|
996
|
1 # Check the GenericIO code
|
|
|
2
|
|
|
3 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
4
|
|
|
5 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
6 # and distribute it is granted provided that the conditions set out in the
|
|
|
7 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
8
|
|
|
9 use IO::File;
|
|
|
10 use Language::INTERCAL::GenericIO '1.-94.-2';
|
|
|
11 use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(roman_type read_number);
|
|
|
12 use Language::INTERCAL::WriteNumbers '1.-94.-2', qw(write_number);
|
|
|
13 use Language::INTERCAL::ArrayIO '1.-94.-2',
|
|
|
14 qw(read_array_16 write_array_16 read_array_32 write_array_32);
|
|
|
15
|
|
|
16 print "1..72\n";
|
|
|
17 $| = 1;
|
|
|
18
|
|
|
19 my $tmpfile = ".iotest";
|
|
|
20 END { defined $tmpfile && unlink $tmpfile }
|
|
|
21
|
|
|
22 my $file;
|
|
|
23 my $string;
|
|
|
24 my $file1;
|
|
|
25 my $file2;
|
|
|
26
|
|
|
27 # 1 - FILE, text, read
|
|
|
28 $file = new Language::INTERCAL::GenericIO 'FILE', 'r', $tmpfile;
|
|
|
29 $file->read_text("TESTING\n");
|
|
|
30 $file = new IO::File $tmpfile;
|
|
|
31 print <$file> eq "TESTING\n" ? "" : "not ", "ok 1\n";
|
|
|
32
|
|
|
33 # 2 - FILE, text, write
|
|
|
34 $file = new Language::INTERCAL::GenericIO 'FILE', 'w', $tmpfile;
|
|
|
35 print $file->write_text() eq "TESTING\n" ? "" : "not ", "ok 2\n";
|
|
|
36
|
|
|
37 # 3 - FILE, binary, read
|
|
|
38 $file = new Language::INTERCAL::GenericIO 'FILE', 'r', $tmpfile;
|
|
|
39 $file->read_binary("TESTING\n");
|
|
|
40 $file = new IO::File $tmpfile;
|
|
|
41 print <$file> eq "TESTING\n" ? "" : "not ", "ok 3\n";
|
|
|
42
|
|
|
43 # 4 - FILE, binary, write
|
|
|
44 $file = new Language::INTERCAL::GenericIO 'FILE', 'w', $tmpfile;
|
|
|
45 print $file->write_binary(8) eq "TESTING\n" ? "" : "not ", "ok 4\n";
|
|
|
46
|
|
|
47 # 5 - UFILE, text, read
|
|
|
48 $file = new Language::INTERCAL::GenericIO 'UFILE', 'r', $tmpfile;
|
|
|
49 $file->read_text("TESTING\n");
|
|
|
50 $file = new IO::File $tmpfile;
|
|
|
51 print <$file> eq "TESTING\n" ? "" : "not ", "ok 5\n";
|
|
|
52
|
|
|
53 # 6 - UFILE, text, write
|
|
|
54 $file = new Language::INTERCAL::GenericIO 'UFILE', 'w', $tmpfile;
|
|
|
55 print $file->write_text() eq "TESTING\n" ? "" : "not ", "ok 6\n";
|
|
|
56
|
|
|
57 # 7 - UFILE, binary, read
|
|
|
58 $file = new Language::INTERCAL::GenericIO 'UFILE', 'r', $tmpfile;
|
|
|
59 $file->read_binary("TESTING\n");
|
|
|
60 $file = new IO::File $tmpfile;
|
|
|
61 print <$file> eq "TESTING\n" ? "" : "not ", "ok 7\n";
|
|
|
62
|
|
|
63 # 8 - UFILE, binary, write
|
|
|
64 $file = new Language::INTERCAL::GenericIO 'UFILE', 'w', $tmpfile;
|
|
|
65 print $file->write_binary(8) eq "TESTING\n" ? "" : "not ", "ok 8\n";
|
|
|
66
|
|
|
67 # 9 - ARRAY, text, read
|
|
|
68 my @data = ();
|
|
|
69 $file = new Language::INTERCAL::GenericIO 'ARRAY', 'r', \@data;
|
|
|
70 $file->read_text("TESTING\n");
|
|
|
71 print @data == 1 && $data[0] eq "TESTING\n" ? "" : "not ", "ok 9\n";
|
|
|
72
|
|
|
73 # 10 - ARRAY, text, write
|
|
|
74 $file = new Language::INTERCAL::GenericIO 'ARRAY', 'w', ["TES", "TIN", "G\n"];
|
|
|
75 print $file->write_text() eq "TESTING\n" ? "" : "not ", "ok 10\n";
|
|
|
76
|
|
|
77 # 11 - ARRAY, binary, read
|
|
|
78 @data = ();
|
|
|
79 $file = new Language::INTERCAL::GenericIO 'ARRAY', 'r', \@data;
|
|
|
80 $file->read_binary("TESTING\n");
|
|
|
81 print @data == 1 && $data[0] eq "TESTING\n" ? "" : "not ", "ok 11\n";
|
|
|
82
|
|
|
83 # 12 - ARRAY, binary, write
|
|
|
84 $file = new Language::INTERCAL::GenericIO 'ARRAY', 'w', [qw(TES TIN GXY)];
|
|
|
85 print $file->write_binary(7) eq "TESTING" &&
|
|
|
86 $file->write_binary(99) eq "XY" ? "" : "not ", "ok 12\n";
|
|
|
87
|
|
|
88 # 13 - STRING, text, read
|
|
|
89 my $data = '';
|
|
|
90 $file = new Language::INTERCAL::GenericIO 'STRING', 'r', \$data;
|
|
|
91 $file->read_text("TESTING\n");
|
|
|
92 print $data eq "TESTING\n" ? "" : "not ", "ok 13\n";
|
|
|
93
|
|
|
94 # 14 - STRING, text, write
|
|
|
95 $string = "TESTING\nXYZT";
|
|
|
96 $file = new Language::INTERCAL::GenericIO 'STRING', 'w', \$string;
|
|
|
97 print $file->write_text() eq "TESTING\n" ? "" : "not ", "ok 14\n";
|
|
|
98
|
|
|
99 # 15 - STRING, binary, read
|
|
|
100 $data = '';
|
|
|
101 $file = new Language::INTERCAL::GenericIO 'STRING', 'r', \$data;
|
|
|
102 $file->read_binary("TESTING\n");
|
|
|
103 print $data eq "TESTING\n" ? "" : "not ", "ok 15\n";
|
|
|
104
|
|
|
105 # 16 - STRING, binary, write
|
|
|
106 $string = "TESTINGXY";
|
|
|
107 $file = new Language::INTERCAL::GenericIO 'STRING', 'w', \$string;
|
|
|
108 print $file->write_binary(7) eq "TESTING" &&
|
|
|
109 $file->write_binary(99) eq "XY" ? "" : "not ", "ok 16\n";
|
|
|
110
|
|
|
111 # 17 - TEE, text, read
|
|
|
112 my $data1 = '';
|
|
|
113 $file1 = new Language::INTERCAL::GenericIO 'STRING', 'r', \$data1;
|
|
|
114 my $data2 = '';
|
|
|
115 $file2 = new Language::INTERCAL::GenericIO 'STRING', 'r', \$data2;
|
|
|
116 $file = new Language::INTERCAL::GenericIO 'TEE', 'r', [$file1, $file2];
|
|
|
117 $file->read_text("TESTING\n");
|
|
|
118 print $data1 eq "TESTING\n" && $data1 eq $data2 ? "" : "not ", "ok 17\n";
|
|
|
119
|
|
|
120 # 18 - TEE, binary, read
|
|
|
121 $data1 = '';
|
|
|
122 $file1 = new Language::INTERCAL::GenericIO 'STRING', 'r', \$data1;
|
|
|
123 $data2 = '';
|
|
|
124 $file2 = new Language::INTERCAL::GenericIO 'STRING', 'r', \$data2;
|
|
|
125 $file = new Language::INTERCAL::GenericIO 'TEE', 'r', [$file1, $file2];
|
|
|
126 $file->read_binary("TESTING\n");
|
|
|
127 print $data1 eq "TESTING\n" && $data1 eq $data2 ? "" : "not ", "ok 18\n";
|
|
|
128
|
|
|
129 # 19 - OBJECT, text, read
|
|
|
130 my $object = bless \$data, ReadObject;
|
|
|
131 $data = '';
|
|
|
132 $file = new Language::INTERCAL::GenericIO 'OBJECT', 'r', $object;
|
|
|
133 $file->read_text("TESTING\n");
|
|
|
134 print $data eq "TESTING\n" ? "" : "not ", "ok 19\n";
|
|
|
135
|
|
|
136 # 20 - OBJECT, text, write
|
|
|
137 $object = bless \$string, WriteObject;
|
|
|
138 $string = "TESTING\nXYZT";
|
|
|
139 $file = new Language::INTERCAL::GenericIO 'OBJECT', 'w', $object;
|
|
|
140 print $file->write_text() eq "TESTING\n" ? "" : "not ", "ok 20\n";
|
|
|
141
|
|
|
142 # 21 - OBJECT, binary, read
|
|
|
143 $object = bless \$data, ReadObject;
|
|
|
144 $data = '';
|
|
|
145 $file = new Language::INTERCAL::GenericIO 'OBJECT', 'r', $object;
|
|
|
146 $file->read_binary("TESTING\n");
|
|
|
147 print $data eq "TESTING\n" ? "" : "not ", "ok 21\n";
|
|
|
148
|
|
|
149 # 22 - OBJECT, binary, write
|
|
|
150 $object = bless \$string, WriteObject;
|
|
|
151 $string = "TESTINGXY";
|
|
|
152 $file = new Language::INTERCAL::GenericIO 'OBJECT', 'w', $object;
|
|
|
153 print $file->write_binary(7) eq "TESTING" &&
|
|
|
154 $file->write_binary(99) eq "XY" ? "" : "not ", "ok 22\n";
|
|
|
155
|
|
|
156 # 23..36 - Read Numbers
|
|
|
157 my @list = (
|
|
|
158 [1234, "CLC", 'MCCXXXIV'],
|
|
|
159 [1234, "UNDERLINE", 'MCCXXXIV'],
|
|
|
160 [1234, "ARCHAIC", '(I)CCXXXIIII'],
|
|
|
161 [1234, "MEDIAEVAL", 'MCCXXXIIII'],
|
|
|
162 [1234, "MODERN", '_', 'ICCXXXIV'],
|
|
|
163 [1234, "TRADITIONAL", '', 'MCCXXXIV'],
|
|
|
164 [1234, "WIMPMODE", 1234],
|
|
|
165 [5678901234, "CLC", '\v\D\C\L\X\X\V\I\I\IcmiCCXXXIV'],
|
|
|
166 [5678901234, "UNDERLINE", "_v_D_C_L_X_X_V_I_I_IcmiCCXXXIV"],
|
|
|
167 [5678901234, "ARCHAIC", 'I))))))))I)))))))((((((I))))))I))))))(((((I)))))(((((I)))))' .
|
|
|
168 'I)))))((((I))))((((I))))((((I))))I))))(((I)))(((I)))(((I)))(((I)))(I)CCXXXIIII'],
|
|
|
169 [5678901234, "MEDIAEVAL", ' _ _ _ _ _ _ _ ________',
|
|
|
170 '||L||||V|||C||L||X||X||V|MMMDCCCCMCCXXXIIII'],
|
|
|
171 [5678901234, "MODERN", ' _ _ _ _ _ _ _ _ _ _ ___',
|
|
|
172 '||D||||L||||X|||D||C||C||L||X||X||X|CMICCXXXIV'],
|
|
|
173 [5678901234, "TRADITIONAL", '_ ___', 'vdclxxviiiCMICCXXXIV'],
|
|
|
174 [5678901234, "WIMPMODE", 5678901234],
|
|
|
175 );
|
|
|
176 @data = ();
|
|
|
177 my $testnum = 23;
|
|
|
178 $file = new Language::INTERCAL::GenericIO 'ARRAY', 'r', \@data;
|
|
|
179 for my $n (@list) {
|
|
|
180 my ($num, $type, @result) = @$n;
|
|
|
181 @data = ();
|
|
|
182 read_number($num, roman_type($type), $file);
|
|
|
183 my $ok = @data == @result;
|
|
|
184 if ($ok) {
|
|
|
185 chomp @data;
|
|
|
186 for (my $i = 0; $i < @data; $i++) {
|
|
|
187 $ok = 0 if $data[$i] ne $result[$i];
|
|
|
188 }
|
|
|
189 }
|
|
|
190 print $ok ? '' : 'not ', 'ok ', $testnum++, "\n";
|
|
|
191 }
|
|
|
192
|
|
|
193 # 37..60 Write numbers
|
|
|
194 @list = (
|
|
|
195 ['ONE OH ZERO TWO THREE FOUR FIVE', 1002345],
|
|
|
196 ['SIX SEVEN NINER EIGHT NINE', 67989],
|
|
|
197 ['AON A H-AON AONAR DA DHA TRIUIR A NAOI', 1112239],
|
|
|
198 ['A DHA NONI NEONI DITHIS TRI CEITHIR NAONAR', 2002349],
|
|
|
199 ['A TRI A CEITHIR CEATHRAR COIG A COIG SIA', 344556],
|
|
|
200 ['CÒIG C\`OIG A C\`OIG A CÒIG COIGNEAR C\`OIGNEAR', 555555],
|
|
|
201 ['CÒIGNEAR SE A SIA A SE SEANAR SEACHD', 566667],
|
|
|
202 ['A SEACHD SEACHDNAR OCHD A H-OCHD OCHDNAR NAOI', 778889],
|
|
|
203 ['EKA DVI TRI SUTYA CHATUR PANCHAN', 123045],
|
|
|
204 ['SHASH SHUTYA SAPTAM ASHTAN NAVAN', 60789],
|
|
|
205 ['BAT BI HIRO LAU ZEROA BORTZ', 123405],
|
|
|
206 ['SEI ZAZPI ZORTZI BEDERATZI', 6789],
|
|
|
207 ['ISA DALAWA TATLO APAT WALA LIMA', 123405],
|
|
|
208 ['ANIM PITO WALO SIYAM', 6789],
|
|
|
209 ['CE OME IEI NAUI NACUILI AHTLE', 123450],
|
|
|
210 ['CHIQUACE CHICOME CHICUE CHICUNAUI', 6789],
|
|
|
211 ['ERTI ORI SAMI OTXI NULI XUTI', 123405],
|
|
|
212 ['EKSVI SHVIDI RVA CXRA', 6789],
|
|
|
213 ["'NEM MAL'H YUDEXW MU SEK'A Q'ETL'A", 123456],
|
|
|
214 ["ETLEBU KE'YOS MALHGWENALH 'NA'NE'MA", 7089],
|
|
|
215 ['BAL TEL KIL FOL LUL M\\"AL MÄL', 1234566],
|
|
|
216 ['VEL J\\"OL NOS JÖL Z\\"UL ZÜL', 780899],
|
|
|
217 ["UNUS UNA UNUM DUO NIL DUAE DUÆ DU\\AE TRES", 111202223],
|
|
|
218 ["QUATTUOR QUINQUE SEX NIHIL SEPTEM OCTO NOVEM", 4560789],
|
|
|
219 );
|
|
|
220 $testnum = 37;
|
|
|
221 my $win = join("\n", map { $_->[0] } @list);
|
|
|
222 $file = new Language::INTERCAL::GenericIO 'STRING', 'w', \$win;
|
|
|
223 for my $n (@list) {
|
|
|
224 my ($out, $in) = @$n;
|
|
|
225 my $n = write_number($file, 0);
|
|
|
226 print defined $n && $n == $in ? '' : 'not ', 'ok ', $testnum++, "\n";
|
|
|
227 }
|
|
|
228
|
|
|
229 # 61..66 - read array
|
|
|
230 @list = (
|
|
|
231 [\&read_array_16, 'CLC', 0, undef, 'Hello, World',
|
|
|
232 91, 95, 84, 95, 65, 83, 83, 88, 91, 76, 68, 95, 82, 95, 88, 74, 83, 73],
|
|
|
233 [\&read_array_32, 'CLC', 0, undef, 'Pleasure to meet you',
|
|
|
234 3422748677, 1823736845, 558760182, 1223229687, 3168141630, 575406774,
|
|
|
235 4222943924, 2596733168, 124190837, 1023152199, 2074214626, 2064122373,
|
|
|
236 1203114246, 2930967199, 660930815, 52363501, 2511863925, 375328790,
|
|
|
237 2930639514, 515967526],
|
|
|
238 [\&read_array_16, 'C', 69, 38, 'Hello, World',
|
|
|
239 51, 108, 112, 0, 64, 194, 48, 26, 244, 168, 24, 16],
|
|
|
240 [\&read_array_32, 'C', 0, 38, 'Hello, World',
|
|
|
241 238, 108, 112, 0, 64, 194, 48, 26, 244, 168, 24, 16],
|
|
|
242 );
|
|
|
243 my $rou = '';
|
|
|
244 $file = new Language::INTERCAL::GenericIO 'STRING', 'r', \$rou;
|
|
|
245 $testnum = 61;
|
|
|
246 for my $n (@list) {
|
|
|
247 my ($code, $iotype, $iovalue, $lastvalue, $result, @array) = @$n;
|
|
|
248 $rou = '';
|
|
|
249 $file->reset;
|
|
|
250 $code->($iotype, \$iovalue, $file, \@array, 0);
|
|
|
251 my $ok = $rou eq $result;
|
|
|
252 print $ok ? '' : 'not ', 'ok ', $testnum++, "\n";
|
|
|
253 defined $lastvalue or next;
|
|
|
254 $ok = $lastvalue == $iovalue;
|
|
|
255 print $ok ? '' : 'not ', 'ok ', $testnum++, "\n";
|
|
|
256 }
|
|
|
257
|
|
|
258 # 67..72 - write array
|
|
|
259 @list = (
|
|
|
260 [\&write_array_16, 'CLC', 0, undef, undef, 'Hello, World',
|
|
|
261 91, 95, 84, 95, 65, 83, 83, 88, 91, 76, 68, 95, 82, 95, 88, 74, 83, 73],
|
|
|
262 [\&write_array_32, 'CLC', 0, undef, 0xffff, 'Pleasure to meet you',
|
|
|
263 5, 1037, 246, 247, 318, 694, 692, 240, 117, 4167, 226, 517, 4358,
|
|
|
264 671, 255, 237, 117, 4118, 666, 2598],
|
|
|
265 [\&write_array_16, 'C', 69, 100, undef, 'Hello, World',
|
|
|
266 3, 29, 7, 0, 3, 189, 244, 55, 24, 3, 250, 248],
|
|
|
267 [\&write_array_32, 'C', 0, 100, undef, 'Hello, World',
|
|
|
268 72, 29, 7, 0, 3, 189, 244, 55, 24, 3, 250, 248],
|
|
|
269 );
|
|
|
270 $win = '';
|
|
|
271 $file = new Language::INTERCAL::GenericIO 'STRING', 'w', \$win;
|
|
|
272 $testnum = 67;
|
|
|
273 for my $n (@list) {
|
|
|
274 my ($code, $iotype, $iovalue, $lastvalue, $mask, $text, @result) = @$n;
|
|
|
275 $win = $text;
|
|
|
276 $file->seek(0);
|
|
|
277 my @win = $code->($iotype, \$iovalue, $file, length $text);
|
|
|
278 my $ok = @win == @result;
|
|
|
279 if ($ok) {
|
|
|
280 for (my $i = 0; $i < @win; $i++) {
|
|
|
281 my $x = $win[$i];
|
|
|
282 $x &= $mask if defined $mask;
|
|
|
283 $ok = 0 if $result[$i] != $x;
|
|
|
284 }
|
|
|
285 }
|
|
|
286 print $ok ? '' : 'not ', 'ok ', $testnum++, "\n";
|
|
|
287 defined $lastvalue or next;
|
|
|
288 $ok = $lastvalue == $iovalue;
|
|
|
289 print $ok ? '' : 'not ', 'ok ', $testnum++, "\n";
|
|
|
290 }
|
|
|
291
|
|
|
292 package ReadObject;
|
|
|
293
|
|
|
294 sub read {
|
|
|
295 my ($obj, $data) = @_;
|
|
|
296 $$obj .= $data;
|
|
|
297 }
|
|
|
298
|
|
|
299 package WriteObject;
|
|
|
300
|
|
|
301 sub write {
|
|
|
302 my ($obj, $size) = @_;
|
|
|
303 substr($$obj, 0, $size, '');
|
|
|
304 }
|
|
|
305
|
