/usr/share/perl5/Language/INTERCAL/Whirlpool.pm is in clc-intercal 1:1.0~4pre1.-94.-2-3.
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 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | package Language::INTERCAL::Whirlpool;
# Classes, lectures and filehandles. Yes, they all get stored in the same
# place.
# 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/Whirlpool.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::Numbers '1.-94.-2';
use Language::INTERCAL::Arrays '1.-94.-2';
use Language::INTERCAL::DataItem '1.-94.-2';
use Language::INTERCAL::GenericIO '1.-94.-2';
use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::DataItem);
sub new {
@_ == 1 || @_ == 2
or croak "Usage: new Language::INTERCAL::Whirlpool [VALUE]";
my ($class, $value) = @_;
if (defined $value) {
ref $value or faint(SP_NOCLASS, $value);
if (UNIVERSAL::isa($value, 'Language::INTERCAL::Whirlpool')) {
$value = $value->filehandle;
} elsif (! UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
faint(SP_NOCLASS, $value);
}
}
bless {
filehandle => $value,
subjects => {},
overload => undef,
bits => 16,
subscripts => [65535],
}, $class;
}
sub nuke {
@_ == 1 or croak "Usage: CLASS->nuke()";
my ($whp) = @_;
$whp->{filehanle} = undef;
$whp->{subjects} = {};
$whp->{overload} = undef;
$whp;
}
sub filehandle {
@_ == 1 or croak "Usage: CLASS->filehandle";
my ($whp) = @_;
$whp->{filehandle};
}
sub copy {
@_ == 1 or croak "Usage: CLASS->copy";
my ($whp) = @_;
bless {
filehandle => $whp->{filehandle},
subjects => {%{$whp->{subjects}}},
overload => $whp->{overload},
bits => 16,
subscripts => [65535],
}, ref $whp;
}
sub _store {
@_ == 3 or croak "Usage: CLASS->store(SUBSCRIPT, VALUE)";
my ($whp, $subscript, $value) = @_;
my $lab;
if (ref $value) {
UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
or faint(SP_INVCLASS, 'Not a number');
$lab = $value->spot->number;
} else {
defined $value && $value =~ /^\d+$/
or faint(SP_INVCLASS, 'Not a number');
$lab = $value;
}
$lab >= 1000 or faint(SP_EARLY, $lab);
if (exists $whp->{subjects}{$subscript->[0]}) {
$whp->{subjects}{$subscript->[0]}->assign($lab);
} else {
$whp->{subjects}{$subscript->[0]} =
Language::INTERCAL::Numbers::Spot->new($lab);
}
$whp;
}
sub _get {
@_ == 2 or croak "Usage: CLASS->get(SUBSCRIPT)";
my ($whp, $subscript) = @_;
exists $whp->{subjects}{$subscript->[0]}
or faint(SP_CLASS, '#' . $subscript->[0]);
$whp->{subjects}{$subscript->[0]};
}
sub _assign {
@_ == 2 or croak "Usage: CLASS->assign(VALUE)";
my ($whp, $value) = @_;
if (defined $value) {
ref $value or faint(SP_NOCLASS, $value);
if (UNIVERSAL::isa($value, 'Language::INTERCAL::Whirlpool')) {
$value = $value->filehandle;
} elsif (! UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
faint(SP_NOCLASS, $value);
}
}
$whp->{filehandle} = $value;
$whp;
}
# a few methods so that a class can be used as an array
sub tail {
@_ == 1 or croak "Usage: CLASS->tail";
my ($whp) = @_;
my $t = new Language::INTERCAL::Arrays::Tail 65535;
for my $k (keys %{$whp->{subjects}}) {
next if $k == 0;
my $v = $whp->{subjects}{$k};
$t->store($k, $v);
}
$t;
}
sub hybrid {
@_ == 1 or croak "Usage: CLASS->hybrid";
my ($whp) = @_;
my $h = new Language::INTERCAL::Arrays::Hybrid 65535;
for my $k (keys %{$whp->{subjects}}) {
next if $k == 0;
my $v = $whp->{subjects}{$k};
$h->store($k, $v);
}
$h;
}
# some methods in case classes are used where they don't belong
sub as_list { faint(SP_ISCLASS) }
sub as_string { faint(SP_ISCLASS) }
sub digits { faint(SP_ISCLASS) }
sub elements { faint(SP_ISCLASS) }
sub number { faint(SP_ISCLASS) }
sub range { faint(SP_ISCLASS) }
sub spot { faint(SP_ISCLASS) }
sub twospot { faint(SP_ISCLASS) }
1;
|