/usr/share/perl5/Language/INTERCAL/SharkFin.pm is in clc-intercal 1:1.0~4pre1.-94.-2-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | package Language::INTERCAL::SharkFin;
# Special version of Language::INTERCAL::Arrays used for "Shark Fin"
# registers
# This file is part of CLC-INTERCAL
# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.
use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/SharkFin.pm 1.-94.-2") =~ /\s(\S+)$/;
use Carp;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
use Language::INTERCAL::Arrays '1.-94.-2';
use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::Arrays::Tail);
my %types = (
vector => [\&_code_vector, \&_decode_vector],
);
sub new {
@_ == 3 || @_ == 4
or croak "Usage: Language::INTERCAL::SharkFin->new(TYPE, OBJECT [,VALUE])";
my ($class, $type, $object, @value) = @_;
exists $types{$type} or faint(SP_SPECIAL, "(type $type)");
my $arr;
if (@value) {
@value = &{$types{$type}[0]}($object, @value);
# note, we don't use SUPER here, rather we rebless later
$arr = Language::INTERCAL::Arrays::Tail->from_list(\@value);
} else {
$arr = Language::INTERCAL::Arrays::Tail->new([]);
}
$arr->{sharkfin} = {
object => $object,
type => $types{$type}[0],
typename => $type,
decode => $types{$type}[1],
};
bless $arr, $class;
}
sub type {
@_ == 1 or croak "Usage: SHARKFIN->type";
my ($arr) = @_;
$arr->{sharkfin}{typename};
}
sub _assign {
@_ == 2 or croak "Usage: SHARKFIN->assign(VALUE)";
my ($arr, $value) = @_;
exists $arr->{sharkfin} or faint(SP_NOSPECIAL);
$arr->{sharkfin}{type} or faint(SP_NOSPECIAL);
my @value = &{$arr->{sharkfin}{type}}($arr->{sharkfin}{object}, $value);
$arr->SUPER::_assign(@value ? [scalar @value] : []);
for (my $i = 1; $i <= @value; $i++) {
$arr->_store([$i], $value[$i - 1]);
}
$arr;
}
sub _get_number {
my ($value) = @_;
return $value->spot->number
if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
return $value
if ! ref $value && defined $value && $value =~ /^\d+$/;
faint(SP_INVARRAY, 'Not a number');
}
sub _get_vector {
my ($value) = @_;
return $value->spot->number
if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
return $value
if ! ref $value && defined $value && $value =~ /^\d+$/;
return (unpack('C*', $value), 0)
if ! ref $value && defined $value;
return ( map { _get_number($_) } @$value )
if ref $value eq 'ARRAY';
faint(SP_INVARRAY, 'Not a number');
}
sub _code_vector {
my ($object, $value) = @_;
if (ref $value) {
return ( map { _get_vector($_) } @$value )
if ref $value eq 'ARRAY';
return ( $value->spot->number )
if UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
return ((map { $_->spot->number } $value->tail->as_list))
if UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays');
faint(SP_NOARRAY, "Not an array");
}
if (defined $value) {
return (unpack('C*', $value));
}
faint(SP_NOARRAY, "Not an array");
}
sub _decode_vector {
my ($object, $value) = @_;
my @list = map { $_->number } $value->as_list;
pop @list while @list && $list[-1] == 0;
my $list = pack('C*', @list);
$list =~ s/([\\'])/\\$1/g;
$list = "'$list'" if $list =~ /['\s\\]/;
$list;
}
sub print {
@_ == 1 or croak "Usage: SHARKFIN->print";
my ($arr) = @_;
my $s = $arr->{sharkfin};
return &{$s->{decode}}($s->{object}, $arr) if $s->{decode};
$arr->SUPER::print;
}
sub range {
@_ == 3 or croak "Usage: SHARKFIN->range(START, LEN)";
my ($arr, $start, $len) = @_;
# we just rebless it to a Tail and use their range()
bless $arr, 'Language::INTERCAL::Arrays::Tail';
$arr->range($start, $len);
}
1;
|