|
996
|
1 package Language::INTERCAL::Whirlpool;
|
|
|
2
|
|
|
3 # Classes, lectures and filehandles. Yes, they all get stored in the same
|
|
|
4 # place.
|
|
|
5
|
|
|
6 # This file is part of CLC-INTERCAL
|
|
|
7
|
|
|
8 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
9
|
|
|
10 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
11 # and distribute it is granted provided that the conditions set out in the
|
|
|
12 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
13
|
|
|
14 use strict;
|
|
|
15 use vars qw($VERSION $PERVERSION);
|
|
|
16 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Whirlpool.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
17
|
|
|
18 use Carp;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
21 use Language::INTERCAL::Numbers '1.-94.-2';
|
|
|
22 use Language::INTERCAL::Arrays '1.-94.-2';
|
|
|
23 use Language::INTERCAL::DataItem '1.-94.-2';
|
|
|
24 use Language::INTERCAL::GenericIO '1.-94.-2';
|
|
|
25 use vars qw(@ISA);
|
|
|
26 @ISA = qw(Language::INTERCAL::DataItem);
|
|
|
27
|
|
|
28 sub new {
|
|
|
29 @_ == 1 || @_ == 2
|
|
|
30 or croak "Usage: new Language::INTERCAL::Whirlpool [VALUE]";
|
|
|
31 my ($class, $value) = @_;
|
|
|
32 if (defined $value) {
|
|
|
33 ref $value or faint(SP_NOCLASS, $value);
|
|
|
34 if (UNIVERSAL::isa($value, 'Language::INTERCAL::Whirlpool')) {
|
|
|
35 $value = $value->filehandle;
|
|
|
36 } elsif (! UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
|
|
|
37 faint(SP_NOCLASS, $value);
|
|
|
38 }
|
|
|
39 }
|
|
|
40 bless {
|
|
|
41 filehandle => $value,
|
|
|
42 subjects => {},
|
|
|
43 overload => undef,
|
|
|
44 bits => 16,
|
|
|
45 subscripts => [65535],
|
|
|
46 }, $class;
|
|
|
47 }
|
|
|
48
|
|
|
49 sub nuke {
|
|
|
50 @_ == 1 or croak "Usage: CLASS->nuke()";
|
|
|
51 my ($whp) = @_;
|
|
|
52 $whp->{filehanle} = undef;
|
|
|
53 $whp->{subjects} = {};
|
|
|
54 $whp->{overload} = undef;
|
|
|
55 $whp;
|
|
|
56 }
|
|
|
57
|
|
|
58 sub filehandle {
|
|
|
59 @_ == 1 or croak "Usage: CLASS->filehandle";
|
|
|
60 my ($whp) = @_;
|
|
|
61 $whp->{filehandle};
|
|
|
62 }
|
|
|
63
|
|
|
64 sub copy {
|
|
|
65 @_ == 1 or croak "Usage: CLASS->copy";
|
|
|
66 my ($whp) = @_;
|
|
|
67 bless {
|
|
|
68 filehandle => $whp->{filehandle},
|
|
|
69 subjects => {%{$whp->{subjects}}},
|
|
|
70 overload => $whp->{overload},
|
|
|
71 bits => 16,
|
|
|
72 subscripts => [65535],
|
|
|
73 }, ref $whp;
|
|
|
74 }
|
|
|
75
|
|
|
76 sub _store {
|
|
|
77 @_ == 3 or croak "Usage: CLASS->store(SUBSCRIPT, VALUE)";
|
|
|
78 my ($whp, $subscript, $value) = @_;
|
|
|
79 my $lab;
|
|
|
80 if (ref $value) {
|
|
|
81 UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
|
|
|
82 or faint(SP_INVCLASS, 'Not a number');
|
|
|
83 $lab = $value->spot->number;
|
|
|
84 } else {
|
|
|
85 defined $value && $value =~ /^\d+$/
|
|
|
86 or faint(SP_INVCLASS, 'Not a number');
|
|
|
87 $lab = $value;
|
|
|
88 }
|
|
|
89 $lab >= 1000 or faint(SP_EARLY, $lab);
|
|
|
90 if (exists $whp->{subjects}{$subscript->[0]}) {
|
|
|
91 $whp->{subjects}{$subscript->[0]}->assign($lab);
|
|
|
92 } else {
|
|
|
93 $whp->{subjects}{$subscript->[0]} =
|
|
|
94 Language::INTERCAL::Numbers::Spot->new($lab);
|
|
|
95 }
|
|
|
96 $whp;
|
|
|
97 }
|
|
|
98
|
|
|
99 sub _get {
|
|
|
100 @_ == 2 or croak "Usage: CLASS->get(SUBSCRIPT)";
|
|
|
101 my ($whp, $subscript) = @_;
|
|
|
102 exists $whp->{subjects}{$subscript->[0]}
|
|
|
103 or faint(SP_CLASS, '#' . $subscript->[0]);
|
|
|
104 $whp->{subjects}{$subscript->[0]};
|
|
|
105 }
|
|
|
106
|
|
|
107 sub _assign {
|
|
|
108 @_ == 2 or croak "Usage: CLASS->assign(VALUE)";
|
|
|
109 my ($whp, $value) = @_;
|
|
|
110 if (defined $value) {
|
|
|
111 ref $value or faint(SP_NOCLASS, $value);
|
|
|
112 if (UNIVERSAL::isa($value, 'Language::INTERCAL::Whirlpool')) {
|
|
|
113 $value = $value->filehandle;
|
|
|
114 } elsif (! UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
|
|
|
115 faint(SP_NOCLASS, $value);
|
|
|
116 }
|
|
|
117 }
|
|
|
118 $whp->{filehandle} = $value;
|
|
|
119 $whp;
|
|
|
120 }
|
|
|
121
|
|
|
122 # a few methods so that a class can be used as an array
|
|
|
123
|
|
|
124 sub tail {
|
|
|
125 @_ == 1 or croak "Usage: CLASS->tail";
|
|
|
126 my ($whp) = @_;
|
|
|
127 my $t = new Language::INTERCAL::Arrays::Tail 65535;
|
|
|
128 for my $k (keys %{$whp->{subjects}}) {
|
|
|
129 next if $k == 0;
|
|
|
130 my $v = $whp->{subjects}{$k};
|
|
|
131 $t->store($k, $v);
|
|
|
132 }
|
|
|
133 $t;
|
|
|
134 }
|
|
|
135
|
|
|
136 sub hybrid {
|
|
|
137 @_ == 1 or croak "Usage: CLASS->hybrid";
|
|
|
138 my ($whp) = @_;
|
|
|
139 my $h = new Language::INTERCAL::Arrays::Hybrid 65535;
|
|
|
140 for my $k (keys %{$whp->{subjects}}) {
|
|
|
141 next if $k == 0;
|
|
|
142 my $v = $whp->{subjects}{$k};
|
|
|
143 $h->store($k, $v);
|
|
|
144 }
|
|
|
145 $h;
|
|
|
146 }
|
|
|
147
|
|
|
148 # some methods in case classes are used where they don't belong
|
|
|
149
|
|
|
150 sub as_list { faint(SP_ISCLASS) }
|
|
|
151 sub as_string { faint(SP_ISCLASS) }
|
|
|
152 sub digits { faint(SP_ISCLASS) }
|
|
|
153 sub elements { faint(SP_ISCLASS) }
|
|
|
154 sub number { faint(SP_ISCLASS) }
|
|
|
155 sub range { faint(SP_ISCLASS) }
|
|
|
156 sub spot { faint(SP_ISCLASS) }
|
|
|
157 sub twospot { faint(SP_ISCLASS) }
|
|
|
158
|
|
|
159 1;
|
