Commit | Line | Data |
1a6a8453 |
1 | |
2 | use lib 't'; |
3 | use strict; |
4 | use warnings; |
5 | use bytes; |
6 | |
7 | use Test::More ; |
25f0751f |
8 | use CompTestUtils; |
1a6a8453 |
9 | |
10 | our ($BadPerl, $UncompressClass); |
11 | |
12 | BEGIN |
13 | { |
14 | plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) |
15 | if $] < 5.005 ; |
16 | |
17 | # use Test::NoWarnings, if available |
18 | my $extra = 0 ; |
19 | $extra = 1 |
20 | if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; |
21 | |
22 | my $tests ; |
23 | $BadPerl = ($] >= 5.006 and $] <= 5.008) ; |
24 | |
25 | if ($BadPerl) { |
cb7abd7f |
26 | $tests = 241 ; |
1a6a8453 |
27 | } |
28 | else { |
cb7abd7f |
29 | $tests = 249 ; |
1a6a8453 |
30 | } |
31 | |
32 | plan tests => $tests + $extra ; |
33 | |
1a6a8453 |
34 | } |
35 | |
36 | |
37 | use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); |
38 | |
39 | |
40 | |
41 | sub myGZreadFile |
42 | { |
43 | my $filename = shift ; |
44 | my $init = shift ; |
45 | |
46 | |
47 | my $fil = new $UncompressClass $filename, |
48 | -Strict => 1, |
49 | -Append => 1 |
50 | ; |
51 | |
52 | my $data ; |
53 | $data = $init if defined $init ; |
54 | 1 while $fil->read($data) > 0; |
55 | |
56 | $fil->close ; |
57 | return $data ; |
58 | } |
59 | |
60 | sub run |
61 | { |
62 | |
63 | my $CompressClass = identify(); |
64 | $UncompressClass = getInverse($CompressClass); |
65 | my $Error = getErrorRef($CompressClass); |
66 | my $UnError = getErrorRef($UncompressClass); |
67 | |
68 | { |
69 | next if $BadPerl ; |
70 | |
71 | |
72 | title "Testing $CompressClass"; |
73 | |
74 | |
75 | my $x ; |
76 | my $gz = new $CompressClass(\$x); |
77 | |
78 | my $buff ; |
79 | |
80 | eval { getc($gz) } ; |
81 | like $@, mkErr("^getc Not Available: File opened only for output"); |
82 | |
83 | eval { read($gz, $buff, 1) } ; |
84 | like $@, mkErr("^read Not Available: File opened only for output"); |
85 | |
86 | eval { <$gz> } ; |
87 | like $@, mkErr("^readline Not Available: File opened only for output"); |
88 | |
89 | } |
90 | |
91 | { |
92 | next if $BadPerl; |
93 | $UncompressClass = getInverse($CompressClass); |
94 | |
95 | title "Testing $UncompressClass"; |
96 | |
97 | my $gc ; |
98 | my $guz = new $CompressClass(\$gc); |
99 | $guz->write("abc") ; |
100 | $guz->close(); |
101 | |
102 | my $x ; |
103 | my $gz = new $UncompressClass(\$gc); |
104 | |
105 | my $buff ; |
106 | |
107 | eval { print $gz "abc" } ; |
108 | like $@, mkErr("^print Not Available: File opened only for intput"); |
109 | |
110 | eval { printf $gz "fmt", "abc" } ; |
111 | like $@, mkErr("^printf Not Available: File opened only for intput"); |
112 | |
113 | #eval { write($gz, $buff, 1) } ; |
114 | #like $@, mkErr("^write Not Available: File opened only for intput"); |
115 | |
116 | } |
117 | |
118 | { |
119 | $UncompressClass = getInverse($CompressClass); |
120 | |
121 | title "Testing $CompressClass and $UncompressClass"; |
122 | |
123 | |
124 | { |
125 | # Write |
126 | # these tests come almost 100% from IO::String |
127 | |
128 | my $lex = new LexFile my $name ; |
129 | |
130 | my $io = $CompressClass->new($name); |
131 | |
132 | is $io->tell(), 0 ; |
133 | |
134 | my $heisan = "Heisan\n"; |
135 | print $io $heisan ; |
136 | |
137 | ok ! $io->eof; |
138 | |
139 | is $io->tell(), length($heisan) ; |
140 | |
141 | print($io "a", "b", "c"); |
142 | |
143 | { |
144 | local($\) = "\n"; |
145 | print $io "d", "e"; |
146 | local($,) = ","; |
147 | print $io "f", "g", "h"; |
148 | } |
149 | |
150 | my $foo = "1234567890"; |
151 | |
152 | ok syswrite($io, $foo, length($foo)) == length($foo) ; |
d56f7e4c |
153 | if ( $] < 5.6 ) |
1a6a8453 |
154 | { is $io->syswrite($foo, length $foo), length $foo } |
155 | else |
156 | { is $io->syswrite($foo), length $foo } |
157 | ok $io->syswrite($foo, length($foo)) == length $foo; |
158 | ok $io->write($foo, length($foo), 5) == 5; |
159 | ok $io->write("xxx\n", 100, -1) == 1; |
160 | |
161 | for (1..3) { |
162 | printf $io "i(%d)", $_; |
163 | $io->printf("[%d]\n", $_); |
164 | } |
165 | select $io; |
166 | print "\n"; |
167 | select STDOUT; |
168 | |
169 | close $io ; |
170 | |
171 | ok $io->eof; |
172 | |
173 | is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . |
174 | ("1234567890" x 3) . "67890\n" . |
175 | "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; |
176 | |
177 | |
178 | } |
179 | |
180 | { |
181 | # Read |
182 | my $str = <<EOT; |
183 | This is an example |
184 | of a paragraph |
185 | |
186 | |
187 | and a single line. |
188 | |
189 | EOT |
190 | |
191 | my $lex = new LexFile my $name ; |
192 | |
193 | my $iow = new $CompressClass $name ; |
194 | print $iow $str ; |
195 | close $iow; |
196 | |
197 | my @tmp; |
198 | my $buf; |
199 | { |
200 | my $io = new $UncompressClass $name ; |
201 | |
93d092e2 |
202 | ok ! $io->eof, " Not EOF"; |
203 | is $io->tell(), 0, " Tell is 0" ; |
1a6a8453 |
204 | my @lines = <$io>; |
93d092e2 |
205 | is @lines, 6, " Line is 6" |
1a6a8453 |
206 | or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; |
207 | is $lines[1], "of a paragraph\n" ; |
208 | is join('', @lines), $str ; |
209 | is $., 6; |
210 | is $io->tell(), length($str) ; |
211 | |
212 | ok $io->eof; |
213 | |
214 | ok ! ( defined($io->getline) || |
215 | (@tmp = $io->getlines) || |
216 | defined(<$io>) || |
217 | defined($io->getc) || |
218 | read($io, $buf, 100) != 0) ; |
219 | } |
220 | |
221 | |
222 | { |
223 | local $/; # slurp mode |
224 | my $io = $UncompressClass->new($name); |
225 | ok !$io->eof; |
226 | my @lines = $io->getlines; |
227 | ok $io->eof; |
228 | ok @lines == 1 && $lines[0] eq $str; |
229 | |
230 | $io = $UncompressClass->new($name); |
231 | ok ! $io->eof; |
232 | my $line = <$io>; |
233 | ok $line eq $str; |
234 | ok $io->eof; |
235 | } |
236 | |
237 | { |
238 | local $/ = ""; # paragraph mode |
239 | my $io = $UncompressClass->new($name); |
240 | ok ! $io->eof; |
241 | my @lines = <$io>; |
242 | ok $io->eof; |
243 | ok @lines == 2 |
244 | or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; |
245 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
246 | or print "# $lines[0]\n"; |
247 | ok $lines[1] eq "and a single line.\n\n"; |
248 | } |
249 | |
250 | { |
251 | local $/ = "is"; |
252 | my $io = $UncompressClass->new($name); |
253 | my @lines = (); |
254 | my $no = 0; |
255 | my $err = 0; |
256 | ok ! $io->eof; |
257 | while (<$io>) { |
258 | push(@lines, $_); |
259 | $err++ if $. != ++$no; |
260 | } |
261 | |
262 | ok $err == 0 ; |
263 | ok $io->eof; |
264 | |
265 | ok @lines == 3 |
266 | or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; |
267 | ok join("-", @lines) eq |
268 | "This- is- an example\n" . |
269 | "of a paragraph\n\n\n" . |
270 | "and a single line.\n\n"; |
271 | } |
272 | |
273 | |
274 | # Test read |
275 | |
276 | { |
277 | my $io = $UncompressClass->new($name); |
278 | |
279 | |
280 | if (! $BadPerl) { |
281 | eval { read($io, $buf, -1) } ; |
282 | like $@, mkErr("length parameter is negative"); |
283 | } |
284 | |
285 | is read($io, $buf, 0), 0, "Requested 0 bytes" ; |
286 | |
287 | ok read($io, $buf, 3) == 3 ; |
288 | ok $buf eq "Thi"; |
289 | |
290 | ok sysread($io, $buf, 3, 2) == 3 ; |
291 | ok $buf eq "Ths i" |
292 | or print "# [$buf]\n" ;; |
293 | ok ! $io->eof; |
294 | |
295 | # $io->seek(-4, 2); |
296 | # |
297 | # ok ! $io->eof; |
298 | # |
299 | # ok read($io, $buf, 20) == 4 ; |
300 | # ok $buf eq "e.\n\n"; |
301 | # |
302 | # ok read($io, $buf, 20) == 0 ; |
303 | # ok $buf eq ""; |
304 | # |
305 | # ok ! $io->eof; |
306 | } |
307 | |
308 | } |
309 | |
310 | { |
311 | # Read from non-compressed file |
312 | |
313 | my $str = <<EOT; |
314 | This is an example |
315 | of a paragraph |
316 | |
317 | |
318 | and a single line. |
319 | |
320 | EOT |
321 | |
322 | my $lex = new LexFile my $name ; |
323 | |
324 | writeFile($name, $str); |
325 | my @tmp; |
326 | my $buf; |
327 | { |
328 | my $io = new $UncompressClass $name, -Transparent => 1 ; |
329 | |
330 | ok defined $io; |
331 | ok ! $io->eof; |
332 | ok $io->tell() == 0 ; |
333 | my @lines = <$io>; |
334 | ok @lines == 6; |
335 | ok $lines[1] eq "of a paragraph\n" ; |
336 | ok join('', @lines) eq $str ; |
337 | ok $. == 6; |
338 | ok $io->tell() == length($str) ; |
339 | |
340 | ok $io->eof; |
341 | |
342 | ok ! ( defined($io->getline) || |
343 | (@tmp = $io->getlines) || |
344 | defined(<$io>) || |
345 | defined($io->getc) || |
346 | read($io, $buf, 100) != 0) ; |
347 | } |
348 | |
349 | |
350 | { |
351 | local $/; # slurp mode |
352 | my $io = $UncompressClass->new($name); |
353 | ok ! $io->eof; |
354 | my @lines = $io->getlines; |
355 | ok $io->eof; |
356 | ok @lines == 1 && $lines[0] eq $str; |
357 | |
358 | $io = $UncompressClass->new($name); |
359 | ok ! $io->eof; |
360 | my $line = <$io>; |
361 | ok $line eq $str; |
362 | ok $io->eof; |
363 | } |
364 | |
365 | { |
366 | local $/ = ""; # paragraph mode |
367 | my $io = $UncompressClass->new($name); |
368 | ok ! $io->eof; |
369 | my @lines = <$io>; |
370 | ok $io->eof; |
371 | ok @lines == 2 |
372 | or print "# exected 2 lines, got " . scalar(@lines) . "\n"; |
373 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
374 | or print "# [$lines[0]]\n" ; |
375 | ok $lines[1] eq "and a single line.\n\n"; |
376 | } |
377 | |
378 | { |
379 | local $/ = "is"; |
380 | my $io = $UncompressClass->new($name); |
381 | my @lines = (); |
382 | my $no = 0; |
383 | my $err = 0; |
384 | ok ! $io->eof; |
385 | while (<$io>) { |
386 | push(@lines, $_); |
387 | $err++ if $. != ++$no; |
388 | } |
389 | |
390 | ok $err == 0 ; |
391 | ok $io->eof; |
392 | |
393 | ok @lines == 3 ; |
394 | ok join("-", @lines) eq |
395 | "This- is- an example\n" . |
396 | "of a paragraph\n\n\n" . |
397 | "and a single line.\n\n"; |
398 | } |
399 | |
400 | |
401 | # Test read |
402 | |
403 | { |
404 | my $io = $UncompressClass->new($name); |
405 | |
406 | ok read($io, $buf, 3) == 3 ; |
407 | ok $buf eq "Thi"; |
408 | |
409 | ok sysread($io, $buf, 3, 2) == 3 ; |
410 | ok $buf eq "Ths i"; |
411 | ok ! $io->eof; |
412 | |
413 | # $io->seek(-4, 2); |
414 | # |
415 | # ok ! $io->eof; |
416 | # |
417 | # ok read($io, $buf, 20) == 4 ; |
418 | # ok $buf eq "e.\n\n"; |
419 | # |
420 | # ok read($io, $buf, 20) == 0 ; |
421 | # ok $buf eq ""; |
422 | # |
423 | # ok ! $io->eof; |
424 | } |
425 | |
426 | |
427 | } |
428 | |
429 | { |
430 | # Vary the length parameter in a read |
431 | |
432 | my $str = <<EOT; |
433 | x |
434 | x |
435 | This is an example |
436 | of a paragraph |
437 | |
438 | |
439 | and a single line. |
440 | |
441 | EOT |
442 | $str = $str x 100 ; |
443 | |
444 | |
445 | foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) |
446 | { |
447 | foreach my $trans (0, 1) |
448 | { |
449 | foreach my $append (0, 1) |
450 | { |
451 | title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; |
452 | |
453 | my $lex = new LexFile my $name ; |
454 | |
455 | if ($trans) { |
456 | writeFile($name, $str) ; |
457 | } |
458 | else { |
459 | my $iow = new $CompressClass $name ; |
460 | print $iow $str ; |
461 | close $iow; |
462 | } |
463 | |
464 | |
465 | my $io = $UncompressClass->new($name, |
466 | -Append => $append, |
467 | -Transparent => $trans); |
468 | |
469 | my $buf; |
470 | |
471 | is $io->tell(), 0; |
472 | |
473 | if ($append) { |
474 | 1 while $io->read($buf, $bufsize) > 0; |
475 | } |
476 | else { |
477 | my $tmp ; |
478 | $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; |
479 | } |
480 | is length $buf, length $str; |
481 | ok $buf eq $str ; |
482 | ok ! $io->error() ; |
483 | ok $io->eof; |
484 | } |
485 | } |
486 | } |
487 | } |
488 | |
489 | } |
490 | } |
491 | |
492 | 1; |