Commit | Line | Data |
1a6a8453 |
1 | |
2 | use strict; |
3 | use warnings; |
4 | use bytes; |
5 | |
6 | use Test::More ; |
7 | use ZlibTestUtils; |
8 | |
9 | use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); |
10 | |
11 | our ($UncompressClass); |
12 | BEGIN |
13 | { |
14 | # use Test::NoWarnings, if available |
15 | my $extra = 0 ; |
16 | |
17 | my $st = eval { require Test::NoWarnings ; import Test::NoWarnings; 1; }; |
18 | $extra = 1 |
19 | if $st ; |
20 | |
21 | |
22 | |
23 | plan(tests => 564 + $extra) ; |
24 | } |
25 | |
26 | |
27 | |
28 | |
29 | sub myGZreadFile |
30 | { |
31 | my $filename = shift ; |
32 | my $init = shift ; |
33 | |
34 | |
35 | my $fil = new $UncompressClass $filename, |
36 | -Strict => 0, |
37 | -Append => 1 |
38 | ; |
39 | |
40 | my $data = ''; |
41 | $data = $init if defined $init ; |
42 | 1 while $fil->read($data) > 0; |
43 | |
44 | $fil->close ; |
45 | return $data ; |
46 | } |
47 | |
48 | sub run |
49 | { |
50 | |
51 | my $CompressClass = identify(); |
52 | $UncompressClass = getInverse($CompressClass); |
53 | my $Error = getErrorRef($CompressClass); |
54 | my $UnError = getErrorRef($UncompressClass); |
55 | |
56 | { |
57 | |
58 | title "Testing $CompressClass Errors"; |
59 | |
60 | # Buffer not writable |
61 | eval qq[\$a = new $CompressClass(\\1) ;] ; |
62 | like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ; |
63 | |
64 | my($out, $gz); |
65 | $out = "" ; |
66 | eval qq[\$a = new $CompressClass ] . '$out ;' ; |
67 | like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); |
68 | |
69 | $out = undef ; |
70 | eval qq[\$a = new $CompressClass \$out ;] ; |
71 | like $@, mkEvalErr("^$CompressClass: output filename is undef or null string"); |
72 | |
73 | my $x ; |
74 | $gz = new $CompressClass(\$x); |
75 | |
76 | foreach my $name (qw(read readline getc)) |
77 | { |
78 | eval " \$gz->$name() " ; |
79 | like $@, mkEvalErr("^$name Not Available: File opened only for output"); |
80 | } |
81 | |
82 | eval ' $gz->write({})' ; |
83 | like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference"); |
84 | #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref"); |
85 | |
86 | eval ' $gz->syswrite("abc", 1, 5)' ; |
87 | like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); |
88 | |
89 | eval ' $gz->syswrite("abc", 1, -4)' ; |
90 | like $@, mkEvalErr("^${CompressClass}::write: offset outside string"); |
91 | } |
92 | |
93 | |
94 | { |
95 | title "Testing $UncompressClass Errors"; |
96 | |
97 | my $out = "" ; |
98 | eval qq[\$a = new $UncompressClass \$out ;] ; |
99 | like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); |
100 | $out = undef ; |
101 | eval qq[\$a = new $UncompressClass \$out ;] ; |
102 | like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string"); |
103 | |
104 | my $lex = new LexFile my $name ; |
105 | |
106 | ok ! -e $name, " $name does not exist"; |
107 | |
108 | eval qq[\$a = new $UncompressClass "$name" ;] ; |
109 | is $$UnError, "input file '$name' does not exist"; |
110 | |
111 | my $gc ; |
112 | my $guz = new $CompressClass(\$gc); |
113 | $guz->write("abc") ; |
114 | $guz->close(); |
115 | |
116 | my $x ; |
117 | my $gz = new $UncompressClass(\$gc); |
118 | |
119 | foreach my $name (qw(print printf write)) |
120 | { |
121 | eval " \$gz->$name() " ; |
122 | like $@, mkEvalErr("^$name Not Available: File opened only for intput"); |
123 | } |
124 | |
125 | } |
126 | |
127 | { |
128 | title "Testing $CompressClass and $UncompressClass"; |
129 | |
130 | { |
131 | my ($a, $x, @x) = ("","","") ; |
132 | |
133 | # Buffer not a scalar reference |
134 | eval qq[\$a = new $CompressClass \\\@x ;] ; |
135 | like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref"); |
136 | |
137 | # Buffer not a scalar reference |
138 | eval qq[\$a = new $UncompressClass \\\@x ;] ; |
139 | like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref"); |
140 | } |
141 | |
142 | foreach my $Type ( $CompressClass, $UncompressClass) |
143 | { |
144 | # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate |
145 | |
146 | my ($a, $x, @x) = ("","","") ; |
147 | |
148 | # Odd number of parameters |
149 | eval qq[\$a = new $Type "abc", -Output ] ; |
150 | like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1"); |
151 | |
152 | # Unknown parameter |
153 | eval qq[\$a = new $Type "anc", -Fred => 123 ;] ; |
154 | like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred"); |
155 | |
156 | # no in or out param |
157 | eval qq[\$a = new $Type ;] ; |
158 | like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter"); |
159 | |
160 | } |
161 | |
162 | |
163 | { |
164 | # write a very simple compressed file |
165 | # and read back |
166 | #======================================== |
167 | |
168 | |
169 | my $lex = new LexFile my $name ; |
170 | |
171 | my $hello = <<EOM ; |
172 | hello world |
173 | this is a test |
174 | EOM |
175 | |
176 | { |
177 | my $x ; |
178 | ok $x = new $CompressClass $name ; |
179 | |
180 | ok $x->write($hello), "write" ; |
181 | ok $x->flush(), "flush"; |
182 | ok $x->close, "close" ; |
183 | } |
184 | |
185 | { |
186 | my $uncomp; |
187 | ok my $x = new $UncompressClass $name, -Append => 1 ; |
188 | |
189 | my $len ; |
190 | 1 while ($len = $x->read($uncomp)) > 0 ; |
191 | |
192 | is $len, 0, "read returned 0" |
193 | or diag $$UnError ; |
194 | |
195 | ok $x->close ; |
196 | is $uncomp, $hello ; |
197 | } |
198 | } |
199 | |
200 | { |
201 | # write a very simple compressed file |
202 | # and read back |
203 | #======================================== |
204 | |
205 | |
206 | my $lex = new LexFile my $name ; |
207 | |
208 | my $hello = <<EOM ; |
209 | hello world |
210 | this is a test |
211 | EOM |
212 | |
213 | { |
214 | my $x ; |
215 | ok $x = new $CompressClass $name ; |
216 | |
217 | is $x->write(''), 0, "Write empty string is ok"; |
218 | is $x->write(undef), 0, "Write undef is ok"; |
219 | ok $x->write($hello), "Write ok" ; |
220 | ok $x->close, "Close ok" ; |
221 | } |
222 | |
223 | { |
224 | my $uncomp; |
225 | my $x = new $UncompressClass $name ; |
226 | ok $x, "creates $UncompressClass $name" ; |
227 | |
228 | my $data = ''; |
229 | $data .= $uncomp while $x->read($uncomp) > 0 ; |
230 | |
231 | ok $x->close, "close ok" ; |
232 | is $data, $hello, "expected output" ; |
233 | } |
234 | } |
235 | |
236 | |
237 | { |
238 | # write a very simple file with using an IO filehandle |
239 | # and read back |
240 | #======================================== |
241 | |
242 | |
243 | my $lex = new LexFile my $name ; |
244 | |
245 | my $hello = <<EOM ; |
246 | hello world |
247 | this is a test |
248 | EOM |
249 | |
250 | { |
251 | my $fh = new IO::File ">$name" ; |
252 | ok $fh, "opened file $name ok"; |
253 | my $x = new $CompressClass $fh ; |
254 | ok $x, " created $CompressClass $fh" ; |
255 | |
256 | is $x->fileno(), fileno($fh), "fileno match" ; |
257 | is $x->write(''), 0, "Write empty string is ok"; |
258 | is $x->write(undef), 0, "Write undef is ok"; |
259 | ok $x->write($hello), "write ok" ; |
260 | ok $x->flush(), "flush"; |
261 | ok $x->close,"close" ; |
262 | $fh->close() ; |
263 | } |
264 | |
265 | my $uncomp; |
266 | { |
267 | my $x ; |
268 | ok my $fh1 = new IO::File "<$name" ; |
269 | ok $x = new $UncompressClass $fh1, -Append => 1 ; |
270 | ok $x->fileno() == fileno $fh1 ; |
271 | |
272 | 1 while $x->read($uncomp) > 0 ; |
273 | |
274 | ok $x->close ; |
275 | } |
276 | |
277 | ok $hello eq $uncomp ; |
278 | } |
279 | |
280 | { |
281 | # write a very simple file with using a glob filehandle |
282 | # and read back |
283 | #======================================== |
284 | |
285 | |
286 | my $lex = new LexFile my $name ; |
287 | |
288 | my $hello = <<EOM ; |
289 | hello world |
290 | this is a test |
291 | EOM |
292 | |
293 | { |
294 | title "$CompressClass: Input from typeglob filehandle"; |
295 | ok open FH, ">$name" ; |
296 | |
297 | my $x = new $CompressClass *FH ; |
298 | ok $x, " create $CompressClass" ; |
299 | |
300 | is $x->fileno(), fileno(*FH), " fileno" ; |
301 | is $x->write(''), 0, " Write empty string is ok"; |
302 | is $x->write(undef), 0, " Write undef is ok"; |
303 | ok $x->write($hello), " Write ok" ; |
304 | ok $x->flush(), " Flush"; |
305 | ok $x->close, " Close" ; |
306 | close FH; |
307 | } |
308 | |
309 | |
310 | my $uncomp; |
311 | { |
312 | title "$UncompressClass: Input from typeglob filehandle, append output"; |
313 | my $x ; |
314 | ok open FH, "<$name" ; |
315 | ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 |
316 | or diag $$UnError ; |
317 | is $x->fileno(), fileno FH, " fileno ok" ; |
318 | |
319 | 1 while $x->read($uncomp) > 0 ; |
320 | |
321 | ok $x->close, " close" ; |
322 | } |
323 | #exit; |
324 | |
325 | is $uncomp, $hello, " expected output" ; |
326 | } |
327 | |
328 | { |
329 | my $lex = new LexFile my $name ; |
330 | |
331 | my $hello = <<EOM ; |
332 | hello world |
333 | this is a test |
334 | EOM |
335 | |
336 | { |
337 | title "Outout to stdout via '-'" ; |
338 | |
339 | open(SAVEOUT, ">&STDOUT"); |
340 | my $dummy = fileno SAVEOUT; |
341 | open STDOUT, ">$name" ; |
342 | |
343 | my $x = new $CompressClass '-' ; |
344 | $x->write($hello); |
345 | $x->close; |
346 | |
347 | open(STDOUT, ">&SAVEOUT"); |
348 | |
349 | ok 1, " wrote to stdout" ; |
350 | } |
351 | |
352 | { |
353 | title "Input from stdin via filename '-'"; |
354 | |
355 | my $x ; |
356 | my $uncomp ; |
357 | my $stdinFileno = fileno(STDIN); |
358 | # open below doesn't return 1 sometines on XP |
359 | open(SAVEIN, "<&STDIN"); |
360 | ok open(STDIN, "<$name"), " redirect STDIN"; |
361 | my $dummy = fileno SAVEIN; |
362 | $x = new $UncompressClass '-', Append => 1; |
363 | ok $x, " created object" ; |
364 | is $x->fileno(), $stdinFileno, " fileno ok" ; |
365 | |
366 | 1 while $x->read($uncomp) > 0 ; |
367 | |
368 | ok $x->close, " close" ; |
369 | open(STDIN, "<&SAVEIN"); |
370 | is $uncomp, $hello, " expected output" ; |
371 | } |
372 | } |
373 | |
374 | { |
375 | # write a compressed file to memory |
376 | # and read back |
377 | #======================================== |
378 | |
379 | my $name = "test.gz" ; |
380 | |
381 | my $hello = <<EOM ; |
382 | hello world |
383 | this is a test |
384 | EOM |
385 | |
386 | my $buffer ; |
387 | { |
388 | my $x ; |
389 | ok $x = new $CompressClass(\$buffer) ; |
390 | |
391 | ok ! defined $x->fileno() ; |
392 | is $x->write(''), 0, "Write empty string is ok"; |
393 | is $x->write(undef), 0, "Write undef is ok"; |
394 | ok $x->write($hello) ; |
395 | ok $x->flush(); |
396 | ok $x->close ; |
397 | |
398 | writeFile($name, $buffer) ; |
399 | #is anyUncompress(\$buffer), $hello, " any ok"; |
400 | } |
401 | |
402 | my $keep = $buffer ; |
403 | my $uncomp; |
404 | { |
405 | my $x ; |
406 | ok $x = new $UncompressClass(\$buffer, Append => 1) ; |
407 | |
408 | ok ! defined $x->fileno() ; |
409 | 1 while $x->read($uncomp) > 0 ; |
410 | |
411 | ok $x->close ; |
412 | } |
413 | |
414 | is $uncomp, $hello ; |
415 | ok $buffer eq $keep ; |
416 | } |
417 | |
418 | if ($CompressClass ne 'RawDeflate') |
419 | { |
420 | # write empty file |
421 | #======================================== |
422 | |
423 | my $buffer = ''; |
424 | { |
425 | my $x ; |
426 | ok $x = new $CompressClass(\$buffer) ; |
427 | ok $x->close ; |
428 | |
429 | } |
430 | |
431 | my $keep = $buffer ; |
432 | my $uncomp= ''; |
433 | { |
434 | my $x ; |
435 | ok $x = new $UncompressClass(\$buffer, Append => 1) ; |
436 | |
437 | 1 while $x->read($uncomp) > 0 ; |
438 | |
439 | ok $x->close ; |
440 | } |
441 | |
442 | ok $uncomp eq '' ; |
443 | ok $buffer eq $keep ; |
444 | |
445 | } |
446 | |
447 | { |
448 | # write a larger file |
449 | #======================================== |
450 | |
451 | |
452 | my $lex = new LexFile my $name ; |
453 | |
454 | my $hello = <<EOM ; |
455 | hello world |
456 | this is a test |
457 | EOM |
458 | |
459 | my $input = '' ; |
460 | my $contents = '' ; |
461 | |
462 | { |
463 | my $x = new $CompressClass $name ; |
464 | ok $x, " created $CompressClass object"; |
465 | |
466 | ok $x->write($hello), " write ok" ; |
467 | $input .= $hello ; |
468 | ok $x->write("another line"), " write ok" ; |
469 | $input .= "another line" ; |
470 | # all characters |
471 | foreach (0 .. 255) |
472 | { $contents .= chr int $_ } |
473 | # generate a long random string |
474 | foreach (1 .. 5000) |
475 | { $contents .= chr int rand 256 } |
476 | |
477 | ok $x->write($contents), " write ok" ; |
478 | $input .= $contents ; |
479 | ok $x->close, " close ok" ; |
480 | } |
481 | |
482 | ok myGZreadFile($name) eq $input ; |
483 | my $x = readFile($name) ; |
484 | #print "length " . length($x) . " \n"; |
485 | } |
486 | |
487 | { |
488 | # embed a compressed file in another file |
489 | #================================ |
490 | |
491 | |
492 | my $lex = new LexFile my $name ; |
493 | |
494 | my $hello = <<EOM ; |
495 | hello world |
496 | this is a test |
497 | EOM |
498 | |
499 | my $header = "header info\n" ; |
500 | my $trailer = "trailer data\n" ; |
501 | |
502 | { |
503 | my $fh ; |
504 | ok $fh = new IO::File ">$name" ; |
505 | print $fh $header ; |
506 | my $x ; |
507 | ok $x = new $CompressClass $fh, |
508 | -AutoClose => 0 ; |
509 | |
510 | ok $x->binmode(); |
511 | ok $x->write($hello) ; |
512 | ok $x->close ; |
513 | print $fh $trailer ; |
514 | $fh->close() ; |
515 | } |
516 | |
517 | my ($fil, $uncomp) ; |
518 | my $fh1 ; |
519 | ok $fh1 = new IO::File "<$name" ; |
520 | # skip leading junk |
521 | my $line = <$fh1> ; |
522 | ok $line eq $header ; |
523 | |
524 | ok my $x = new $UncompressClass $fh1, Append => 1 ; |
525 | ok $x->binmode(); |
526 | 1 while $x->read($uncomp) > 0 ; |
527 | |
528 | ok $uncomp eq $hello ; |
529 | my $rest ; |
530 | read($fh1, $rest, 5000); |
531 | is $x->trailingData() . $rest, $trailer ; |
532 | #print "# [".$x->trailingData() . "][$rest]\n" ; |
533 | #exit; |
534 | |
535 | } |
536 | |
537 | { |
538 | # Write |
539 | # these tests come almost 100% from IO::String |
540 | |
541 | my $lex = new LexFile my $name ; |
542 | |
543 | my $io = $CompressClass->new($name); |
544 | |
545 | is $io->tell(), 0, " tell returns 0"; ; |
546 | |
547 | my $heisan = "Heisan\n"; |
548 | $io->print($heisan) ; |
549 | |
550 | ok ! $io->eof(), " ! eof"; |
551 | |
552 | is $io->tell(), length($heisan), " tell is " . length($heisan) ; |
553 | |
554 | $io->print("a", "b", "c"); |
555 | |
556 | { |
557 | local($\) = "\n"; |
558 | $io->print("d", "e"); |
559 | local($,) = ","; |
560 | $io->print("f", "g", "h"); |
561 | } |
562 | |
563 | { |
564 | local($\) ; |
565 | $io->print("D", "E"); |
566 | local($,) = "."; |
567 | $io->print("F", "G", "H"); |
568 | } |
569 | |
570 | my $foo = "1234567890"; |
571 | |
572 | is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ; |
573 | if ( $[ < 5.6 ) |
574 | { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" } |
575 | else |
576 | { is $io->syswrite($foo), length $foo, " syswrite ok" } |
577 | is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok"; |
578 | is $io->write($foo, length($foo), 5), 5, " write 5"; |
579 | is $io->write("xxx\n", 100, -1), 1, " write 1"; |
580 | |
581 | for (1..3) { |
582 | $io->printf("i(%d)", $_); |
583 | $io->printf("[%d]\n", $_); |
584 | } |
585 | $io->print("\n"); |
586 | |
587 | $io->close ; |
588 | |
589 | ok $io->eof(), " eof"; |
590 | |
591 | is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" . |
592 | ("1234567890" x 3) . "67890\n" . |
593 | "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; |
594 | |
595 | |
596 | } |
597 | |
598 | { |
599 | # Read |
600 | my $str = <<EOT; |
601 | This is an example |
602 | of a paragraph |
603 | |
604 | |
605 | and a single line. |
606 | |
607 | EOT |
608 | |
609 | my $lex = new LexFile my $name ; |
610 | |
611 | my %opts = () ; |
612 | my $iow = new $CompressClass $name, %opts; |
613 | $iow->print($str) ; |
614 | $iow->close ; |
615 | |
616 | my @tmp; |
617 | my $buf; |
618 | { |
619 | my $io = new $UncompressClass $name ; |
620 | |
621 | ok ! $io->eof; |
622 | is $io->tell(), 0 ; |
623 | #my @lines = <$io>; |
624 | my @lines = $io->getlines(); |
625 | is @lines, 6 |
626 | or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; |
627 | is $lines[1], "of a paragraph\n" ; |
628 | is join('', @lines), $str ; |
629 | is $., 6; |
630 | is $io->tell(), length($str) ; |
631 | |
632 | ok $io->eof; |
633 | |
634 | ok ! ( defined($io->getline) || |
635 | (@tmp = $io->getlines) || |
636 | defined($io->getline) || |
637 | defined($io->getc) || |
638 | $io->read($buf, 100) != 0) ; |
639 | } |
640 | |
641 | |
642 | { |
643 | local $/; # slurp mode |
644 | my $io = $UncompressClass->new($name); |
645 | ok ! $io->eof; |
646 | my @lines = $io->getlines; |
647 | ok $io->eof; |
648 | ok @lines == 1 && $lines[0] eq $str; |
649 | |
650 | $io = $UncompressClass->new($name); |
651 | ok ! $io->eof; |
652 | my $line = $io->getline(); |
653 | ok $line eq $str; |
654 | ok $io->eof; |
655 | } |
656 | |
657 | { |
658 | local $/ = ""; # paragraph mode |
659 | my $io = $UncompressClass->new($name); |
660 | ok ! $io->eof; |
661 | my @lines = $io->getlines(); |
662 | ok $io->eof; |
663 | ok @lines == 2 |
664 | or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; |
665 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
666 | or print "# $lines[0]\n"; |
667 | ok $lines[1] eq "and a single line.\n\n"; |
668 | } |
669 | |
670 | { |
671 | local $/ = "is"; |
672 | my $io = $UncompressClass->new($name); |
673 | my @lines = (); |
674 | my $no = 0; |
675 | my $err = 0; |
676 | ok ! $io->eof; |
677 | while (my $a = $io->getline()) { |
678 | push(@lines, $a); |
679 | $err++ if $. != ++$no; |
680 | } |
681 | |
682 | ok $err == 0 ; |
683 | ok $io->eof; |
684 | |
685 | ok @lines == 3 |
686 | or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; |
687 | ok join("-", @lines) eq |
688 | "This- is- an example\n" . |
689 | "of a paragraph\n\n\n" . |
690 | "and a single line.\n\n"; |
691 | } |
692 | |
693 | |
694 | # Test read |
695 | |
696 | { |
697 | my $io = $UncompressClass->new($name); |
698 | |
699 | |
700 | eval { $io->read(1) } ; |
701 | like $@, mkErr("buffer parameter is read-only"); |
702 | |
703 | is $io->read($buf, 0), 0, "Requested 0 bytes" ; |
704 | |
705 | ok $io->read($buf, 3) == 3 ; |
706 | ok $buf eq "Thi"; |
707 | |
708 | ok $io->sysread($buf, 3, 2) == 3 ; |
709 | ok $buf eq "Ths i" |
710 | or print "# [$buf]\n" ;; |
711 | ok ! $io->eof; |
712 | |
713 | # $io->seek(-4, 2); |
714 | # |
715 | # ok ! $io->eof; |
716 | # |
717 | # ok read($io, $buf, 20) == 4 ; |
718 | # ok $buf eq "e.\n\n"; |
719 | # |
720 | # ok read($io, $buf, 20) == 0 ; |
721 | # ok $buf eq ""; |
722 | # |
723 | # ok ! $io->eof; |
724 | } |
725 | |
726 | } |
727 | |
728 | { |
729 | # Read from non-compressed file |
730 | |
731 | my $str = <<EOT; |
732 | This is an example |
733 | of a paragraph |
734 | |
735 | |
736 | and a single line. |
737 | |
738 | EOT |
739 | |
740 | my $lex = new LexFile my $name ; |
741 | |
742 | writeFile($name, $str); |
743 | my @tmp; |
744 | my $buf; |
745 | { |
746 | my $io = new $UncompressClass $name, -Transparent => 1 ; |
747 | |
748 | ok defined $io; |
749 | ok ! $io->eof; |
750 | ok $io->tell() == 0 ; |
751 | my @lines = $io->getlines(); |
752 | ok @lines == 6; |
753 | ok $lines[1] eq "of a paragraph\n" ; |
754 | ok join('', @lines) eq $str ; |
755 | ok $. == 6; |
756 | ok $io->tell() == length($str) ; |
757 | |
758 | ok $io->eof; |
759 | |
760 | ok ! ( defined($io->getline) || |
761 | (@tmp = $io->getlines) || |
762 | defined($io->getline) || |
763 | defined($io->getc) || |
764 | $io->read($buf, 100) != 0) ; |
765 | } |
766 | |
767 | |
768 | { |
769 | local $/; # slurp mode |
770 | my $io = $UncompressClass->new($name); |
771 | ok ! $io->eof; |
772 | my @lines = $io->getlines; |
773 | ok $io->eof; |
774 | ok @lines == 1 && $lines[0] eq $str; |
775 | |
776 | $io = $UncompressClass->new($name); |
777 | ok ! $io->eof; |
778 | my $line = $io->getline; |
779 | ok $line eq $str; |
780 | ok $io->eof; |
781 | } |
782 | |
783 | { |
784 | local $/ = ""; # paragraph mode |
785 | my $io = $UncompressClass->new($name); |
786 | ok ! $io->eof; |
787 | my @lines = $io->getlines; |
788 | ok $io->eof; |
789 | ok @lines == 2 |
790 | or print "# exected 2 lines, got " . scalar(@lines) . "\n"; |
791 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
792 | or print "# [$lines[0]]\n" ; |
793 | ok $lines[1] eq "and a single line.\n\n"; |
794 | } |
795 | |
796 | { |
797 | local $/ = "is"; |
798 | my $io = $UncompressClass->new($name); |
799 | my @lines = (); |
800 | my $no = 0; |
801 | my $err = 0; |
802 | ok ! $io->eof; |
803 | while (my $a = $io->getline) { |
804 | push(@lines, $a); |
805 | $err++ if $. != ++$no; |
806 | } |
807 | |
808 | ok $err == 0 ; |
809 | ok $io->eof; |
810 | |
811 | ok @lines == 3 ; |
812 | ok join("-", @lines) eq |
813 | "This- is- an example\n" . |
814 | "of a paragraph\n\n\n" . |
815 | "and a single line.\n\n"; |
816 | } |
817 | |
818 | |
819 | # Test read |
820 | |
821 | { |
822 | my $io = $UncompressClass->new($name); |
823 | |
824 | ok $io->read($buf, 3) == 3 ; |
825 | ok $buf eq "Thi"; |
826 | |
827 | ok $io->sysread($buf, 3, 2) == 3 ; |
828 | ok $buf eq "Ths i"; |
829 | ok ! $io->eof; |
830 | |
831 | # $io->seek(-4, 2); |
832 | # |
833 | # ok ! $io->eof; |
834 | # |
835 | # ok read($io, $buf, 20) == 4 ; |
836 | # ok $buf eq "e.\n\n"; |
837 | # |
838 | # ok read($io, $buf, 20) == 0 ; |
839 | # ok $buf eq ""; |
840 | # |
841 | # ok ! $io->eof; |
842 | } |
843 | |
844 | |
845 | } |
846 | |
847 | { |
848 | # Vary the length parameter in a read |
849 | |
850 | my $str = <<EOT; |
851 | x |
852 | x |
853 | This is an example |
854 | of a paragraph |
855 | |
856 | |
857 | and a single line. |
858 | |
859 | EOT |
860 | $str = $str x 100 ; |
861 | |
862 | |
863 | foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) |
864 | { |
865 | foreach my $trans (0, 1) |
866 | { |
867 | foreach my $append (0, 1) |
868 | { |
869 | title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; |
870 | |
871 | my $lex = new LexFile my $name ; |
872 | |
873 | if ($trans) { |
874 | writeFile($name, $str) ; |
875 | } |
876 | else { |
877 | my $iow = new $CompressClass $name; |
878 | $iow->print($str) ; |
879 | $iow->close ; |
880 | } |
881 | |
882 | |
883 | my $io = $UncompressClass->new($name, |
884 | -Append => $append, |
885 | -Transparent => $trans); |
886 | |
887 | my $buf; |
888 | |
889 | is $io->tell(), 0; |
890 | |
891 | if ($append) { |
892 | 1 while $io->read($buf, $bufsize) > 0; |
893 | } |
894 | else { |
895 | my $tmp ; |
896 | $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; |
897 | } |
898 | is length $buf, length $str; |
899 | ok $buf eq $str ; |
900 | ok ! $io->error() ; |
901 | ok $io->eof; |
902 | } |
903 | } |
904 | } |
905 | } |
906 | |
907 | foreach my $file (0, 1) |
908 | { |
909 | foreach my $trans (0, 1) |
910 | { |
911 | title "seek tests - file $file trans $trans" ; |
912 | |
913 | my $buffer ; |
914 | my $buff ; |
915 | my $lex = new LexFile my $name ; |
916 | |
917 | my $first = "beginning" ; |
918 | my $last = "the end" ; |
919 | |
920 | if ($trans) |
921 | { |
922 | $buffer = $first . "\x00" x 10 . $last; |
923 | writeFile($name, $buffer); |
924 | } |
925 | else |
926 | { |
927 | my $output ; |
928 | if ($file) |
929 | { |
930 | $output = $name ; |
931 | } |
932 | else |
933 | { |
934 | $output = \$buffer; |
935 | } |
936 | |
937 | my $iow = new $CompressClass $output ; |
938 | $iow->print($first) ; |
939 | ok $iow->seek(5, SEEK_CUR) ; |
940 | ok $iow->tell() == length($first)+5; |
941 | ok $iow->seek(0, SEEK_CUR) ; |
942 | ok $iow->tell() == length($first)+5; |
943 | ok $iow->seek(length($first)+10, SEEK_SET) ; |
944 | ok $iow->tell() == length($first)+10; |
945 | |
946 | $iow->print($last) ; |
947 | $iow->close ; |
948 | } |
949 | |
950 | my $input ; |
951 | if ($file) |
952 | { |
953 | $input = $name ; |
954 | } |
955 | else |
956 | { |
957 | $input = \$buffer ; |
958 | } |
959 | |
960 | ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ; |
961 | |
962 | my $io = $UncompressClass->new($input, Strict => 1); |
963 | ok $io->seek(length($first), SEEK_CUR) ; |
964 | ok ! $io->eof; |
965 | is $io->tell(), length($first); |
966 | |
967 | ok $io->read($buff, 5) ; |
968 | is $buff, "\x00" x 5 ; |
969 | is $io->tell(), length($first) + 5; |
970 | |
971 | ok $io->seek(0, SEEK_CUR) ; |
972 | my $here = $io->tell() ; |
973 | is $here, length($first)+5; |
974 | |
975 | ok $io->seek($here+5, SEEK_SET) ; |
976 | is $io->tell(), $here+5 ; |
977 | ok $io->read($buff, 100) ; |
978 | ok $buff eq $last ; |
979 | ok $io->eof; |
980 | } |
981 | } |
982 | |
983 | { |
984 | title "seek error cases" ; |
985 | |
986 | my $b ; |
987 | my $a = new $CompressClass(\$b) ; |
988 | |
989 | ok ! $a->error() ; |
990 | eval { $a->seek(-1, 10) ; }; |
991 | like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter"); |
992 | |
993 | eval { $a->seek(-1, SEEK_END) ; }; |
994 | like $@, mkErr("^${CompressClass}::seek: cannot seek backwards"); |
995 | |
996 | $a->write("fred"); |
997 | $a->close ; |
998 | |
999 | |
1000 | my $u = new $UncompressClass(\$b) ; |
1001 | |
1002 | eval { $u->seek(-1, 10) ; }; |
1003 | like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter"); |
1004 | |
1005 | eval { $u->seek(-1, SEEK_END) ; }; |
1006 | like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed"); |
1007 | |
1008 | eval { $u->seek(-1, SEEK_CUR) ; }; |
1009 | like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards"); |
1010 | } |
1011 | |
1012 | foreach my $fb (qw(filename buffer filehandle)) |
1013 | { |
1014 | foreach my $append (0, 1) |
1015 | { |
1016 | { |
1017 | title "$CompressClass -- Append $append, Output to $fb" ; |
1018 | |
1019 | my $lex = new LexFile my $name ; |
1020 | |
1021 | my $already = 'already'; |
1022 | my $buffer = $already; |
1023 | my $output; |
1024 | |
1025 | if ($fb eq 'buffer') |
1026 | { $output = \$buffer } |
1027 | elsif ($fb eq 'filename') |
1028 | { |
1029 | $output = $name ; |
1030 | writeFile($name, $buffer); |
1031 | } |
1032 | elsif ($fb eq 'filehandle') |
1033 | { |
1034 | $output = new IO::File ">$name" ; |
1035 | print $output $buffer; |
1036 | } |
1037 | |
1038 | my $a = new $CompressClass($output, Append => $append) ; |
1039 | ok $a, " Created $CompressClass"; |
1040 | my $string = "appended"; |
1041 | $a->write($string); |
1042 | $a->close ; |
1043 | |
1044 | my $data ; |
1045 | if ($fb eq 'buffer') |
1046 | { |
1047 | $data = $buffer; |
1048 | } |
1049 | else |
1050 | { |
1051 | $output->close |
1052 | if $fb eq 'filehandle'; |
1053 | $data = readFile($name); |
1054 | } |
1055 | |
1056 | if ($append || $fb eq 'filehandle') |
1057 | { |
1058 | is substr($data, 0, length($already)), $already, " got prefix"; |
1059 | substr($data, 0, length($already)) = ''; |
1060 | } |
1061 | |
1062 | |
1063 | my $uncomp; |
1064 | my $x = new $UncompressClass(\$data, Append => 1) ; |
1065 | ok $x, " created $UncompressClass"; |
1066 | |
1067 | my $len ; |
1068 | 1 while ($len = $x->read($uncomp)) > 0 ; |
1069 | |
1070 | $x->close ; |
1071 | is $uncomp, $string, ' Got uncompressed data' ; |
1072 | |
1073 | } |
1074 | } |
1075 | } |
1076 | |
1077 | foreach my $type (qw(buffer filename filehandle)) |
1078 | { |
1079 | title "$UncompressClass -- InputLength, read from $type"; |
1080 | |
1081 | my $compressed ; |
1082 | my $string = "some data"; |
1083 | my $c = new $CompressClass(\$compressed); |
1084 | $c->write($string); |
1085 | $c->close(); |
1086 | |
1087 | my $appended = "append"; |
1088 | my $comp_len = length $compressed; |
1089 | $compressed .= $appended; |
1090 | |
1091 | my $lex = new LexFile my $name ; |
1092 | my $input ; |
1093 | writeFile ($name, $compressed); |
1094 | |
1095 | if ($type eq 'buffer') |
1096 | { |
1097 | $input = \$compressed; |
1098 | } |
1099 | if ($type eq 'filename') |
1100 | { |
1101 | $input = $name; |
1102 | } |
1103 | elsif ($type eq 'filehandle') |
1104 | { |
1105 | my $fh = new IO::File "<$name" ; |
1106 | ok $fh, "opened file $name ok"; |
1107 | $input = $fh ; |
1108 | } |
1109 | |
1110 | my $x = new $UncompressClass($input, InputLength => $comp_len) ; |
1111 | ok $x, " created $UncompressClass"; |
1112 | |
1113 | my $len ; |
1114 | my $output; |
1115 | $len = $x->read($output, 100); |
1116 | is $len, length($string); |
1117 | is $output, $string; |
1118 | |
1119 | if ($type eq 'filehandle') |
1120 | { |
1121 | my $rest ; |
1122 | $input->read($rest, 1000); |
1123 | is $rest, $appended; |
1124 | } |
1125 | |
1126 | |
1127 | } |
1128 | |
1129 | foreach my $append (0, 1) |
1130 | { |
1131 | title "$UncompressClass -- Append $append" ; |
1132 | |
1133 | my $lex = new LexFile my $name ; |
1134 | |
1135 | my $string = "appended"; |
1136 | my $compressed ; |
1137 | my $c = new $CompressClass(\$compressed); |
1138 | $c->write($string); |
1139 | $c->close(); |
1140 | |
1141 | my $x = new $UncompressClass(\$compressed, Append => $append) ; |
1142 | ok $x, " created $UncompressClass"; |
1143 | |
1144 | my $already = 'already'; |
1145 | my $output = $already; |
1146 | |
1147 | my $len ; |
1148 | $len = $x->read($output, 100); |
1149 | is $len, length($string); |
1150 | |
1151 | $x->close ; |
1152 | |
1153 | if ($append) |
1154 | { |
1155 | is substr($output, 0, length($already)), $already, " got prefix"; |
1156 | substr($output, 0, length($already)) = ''; |
1157 | } |
1158 | is $output, $string, ' Got uncompressed data' ; |
1159 | } |
1160 | |
1161 | |
1162 | foreach my $file (0, 1) |
1163 | { |
1164 | foreach my $trans (0, 1) |
1165 | { |
1166 | title "ungetc, File $file, Transparent $trans" ; |
1167 | |
1168 | my $lex = new LexFile my $name ; |
1169 | |
1170 | my $string = 'abcdeABCDE'; |
1171 | my $b ; |
1172 | if ($trans) |
1173 | { |
1174 | $b = $string ; |
1175 | } |
1176 | else |
1177 | { |
1178 | my $a = new $CompressClass(\$b) ; |
1179 | $a->write($string); |
1180 | $a->close ; |
1181 | } |
1182 | |
1183 | my $from ; |
1184 | if ($file) |
1185 | { |
1186 | writeFile($name, $b); |
1187 | $from = $name ; |
1188 | } |
1189 | else |
1190 | { |
1191 | $from = \$b ; |
1192 | } |
1193 | |
1194 | my $u = $UncompressClass->new($from, Transparent => 1) ; |
1195 | my $first; |
1196 | my $buff ; |
1197 | |
1198 | # do an ungetc before reading |
1199 | $u->ungetc("X"); |
1200 | $first = $u->getc(); |
1201 | is $first, 'X'; |
1202 | |
1203 | $first = $u->getc(); |
1204 | is $first, substr($string, 0,1); |
1205 | $u->ungetc($first); |
1206 | $first = $u->getc(); |
1207 | is $first, substr($string, 0,1); |
1208 | $u->ungetc($first); |
1209 | |
1210 | is $u->read($buff, 5), 5 ; |
1211 | is $buff, substr($string, 0, 5); |
1212 | |
1213 | $u->ungetc($buff) ; |
1214 | is $u->read($buff, length($string)), length($string) ; |
1215 | is $buff, $string; |
1216 | |
1217 | is $u->read($buff, 1), 0; |
1218 | ok $u->eof() ; |
1219 | |
1220 | my $extra = 'extra'; |
1221 | $u->ungetc($extra); |
1222 | ok ! $u->eof(); |
1223 | is $u->read($buff), length($extra) ; |
1224 | is $buff, $extra; |
1225 | |
1226 | is $u->read($buff, 1), 0; |
1227 | ok $u->eof() ; |
1228 | |
1229 | $u->close(); |
1230 | |
1231 | } |
1232 | } |
1233 | |
1234 | |
1235 | { |
1236 | title "write tests - invalid data" ; |
1237 | |
1238 | #my $lex = new LexFile my $name1 ; |
1239 | my($Answer); |
1240 | |
1241 | #ok ! -e $name1, " File $name1 does not exist"; |
1242 | |
1243 | my @data = ( |
1244 | [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], |
1245 | [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], |
1246 | [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], |
1247 | [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], |
1248 | [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], |
1249 | [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], |
1250 | #[ "not readable", 'xx' ], |
1251 | # same filehandle twice, 'xx' |
1252 | ) ; |
1253 | |
1254 | foreach my $data (@data) |
1255 | { |
1256 | my ($send, $get) = @$data ; |
1257 | title "${CompressClass}::write( $send )"; |
1258 | my($copy); |
1259 | eval "\$copy = $send"; |
1260 | my $x = new $CompressClass(\$Answer); |
1261 | ok $x, " Created $CompressClass object"; |
1262 | eval { $x->write($copy) } ; |
1263 | #like $@, "/^$get/", " error - $get"; |
1264 | like $@, "/not a scalar reference /", " error - not a scalar reference"; |
1265 | } |
1266 | |
1267 | # @data = ( |
1268 | # [ '[ $name1 ]', "input file '$name1' does not exist" ], |
1269 | # #[ "not readable", 'xx' ], |
1270 | # # same filehandle twice, 'xx' |
1271 | # ) ; |
1272 | # |
1273 | # foreach my $data (@data) |
1274 | # { |
1275 | # my ($send, $get) = @$data ; |
1276 | # title "${CompressClass}::write( $send )"; |
1277 | # my $copy; |
1278 | # eval "\$copy = $send"; |
1279 | # my $x = new $CompressClass(\$Answer); |
1280 | # ok $x, " Created $CompressClass object"; |
1281 | # ok ! $x->write($copy), " write fails" ; |
1282 | # like $$Error, "/^$get/", " error - $get"; |
1283 | # } |
1284 | |
1285 | #exit; |
1286 | |
1287 | } |
1288 | |
1289 | |
1290 | # sub deepCopy |
1291 | # { |
1292 | # if (! ref $_[0] || ref $_[0] eq 'SCALAR') |
1293 | # { |
1294 | # return $_[0] ; |
1295 | # } |
1296 | # |
1297 | # if (ref $_[0] eq 'ARRAY') |
1298 | # { |
1299 | # my @a ; |
1300 | # for my $x ( @{ $_[0] }) |
1301 | # { |
1302 | # push @a, deepCopy($x); |
1303 | # } |
1304 | # |
1305 | # return \@a ; |
1306 | # } |
1307 | # |
1308 | # croak "bad! $_[0]"; |
1309 | # |
1310 | # } |
1311 | # |
1312 | # sub deepSubst |
1313 | # { |
1314 | # #my $data = shift ; |
1315 | # my $from = $_[1] ; |
1316 | # my $to = $_[2] ; |
1317 | # |
1318 | # if (! ref $_[0]) |
1319 | # { |
1320 | # $_[0] = $to |
1321 | # if $_[0] eq $from ; |
1322 | # return ; |
1323 | # |
1324 | # } |
1325 | # |
1326 | # if (ref $_[0] eq 'SCALAR') |
1327 | # { |
1328 | # $_[0] = \$to |
1329 | # if defined ${ $_[0] } && ${ $_[0] } eq $from ; |
1330 | # return ; |
1331 | # |
1332 | # } |
1333 | # |
1334 | # if (ref $_[0] eq 'ARRAY') |
1335 | # { |
1336 | # for my $x ( @{ $_[0] }) |
1337 | # { |
1338 | # deepSubst($x, $from, $to); |
1339 | # } |
1340 | # return ; |
1341 | # } |
1342 | # #croak "bad! $_[0]"; |
1343 | # } |
1344 | |
1345 | # { |
1346 | # title "More write tests" ; |
1347 | # |
1348 | # my $file1 = "file1" ; |
1349 | # my $file2 = "file2" ; |
1350 | # my $file3 = "file3" ; |
1351 | # my $lex = new LexFile $file1, $file2, $file3 ; |
1352 | # |
1353 | # writeFile($file1, "F1"); |
1354 | # writeFile($file2, "F2"); |
1355 | # writeFile($file3, "F3"); |
1356 | # |
1357 | # my @data = ( |
1358 | # [ '""', "" ], |
1359 | # [ 'undef', "" ], |
1360 | # [ '"abcd"', "abcd" ], |
1361 | # |
1362 | # [ '\""', "" ], |
1363 | # [ '\undef', "" ], |
1364 | # [ '\"abcd"', "abcd" ], |
1365 | # |
1366 | # [ '[]', "" ], |
1367 | # [ '[[]]', "" ], |
1368 | # [ '[[[]]]', "" ], |
1369 | # [ '[\""]', "" ], |
1370 | # [ '[\undef]', "" ], |
1371 | # [ '[\"abcd"]', "abcd" ], |
1372 | # [ '[\"ab", \"cd"]', "abcd" ], |
1373 | # [ '[[\"ab"], [\"cd"]]', "abcd" ], |
1374 | # |
1375 | # [ '$file1', $file1 ], |
1376 | # [ '$fh2', "F2" ], |
1377 | # [ '[$file1, \"abc"]', "F1abc"], |
1378 | # [ '[\"a", $file1, \"bc"]', "aF1bc"], |
1379 | # [ '[\"a", $fh1, \"bc"]', "aF1bc"], |
1380 | # [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"], |
1381 | # [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"], |
1382 | # ) ; |
1383 | # |
1384 | # |
1385 | # foreach my $data (@data) |
1386 | # { |
1387 | # my ($send, $get) = @$data ; |
1388 | # |
1389 | # my $fh1 = new IO::File "< $file1" ; |
1390 | # my $fh2 = new IO::File "< $file2" ; |
1391 | # my $fh3 = new IO::File "< $file3" ; |
1392 | # |
1393 | # title "${CompressClass}::write( $send )"; |
1394 | # my $copy; |
1395 | # eval "\$copy = $send"; |
1396 | # my $Answer ; |
1397 | # my $x = new $CompressClass(\$Answer); |
1398 | # ok $x, " Created $CompressClass object"; |
1399 | # my $len = length $get; |
1400 | # is $x->write($copy), length($get), " write $len bytes"; |
1401 | # ok $x->close(), " close ok" ; |
1402 | # |
1403 | # is myGZreadFile(\$Answer), $get, " got expected output" ; |
1404 | # cmp_ok $$Error, '==', 0, " no error"; |
1405 | # |
1406 | # |
1407 | # } |
1408 | # |
1409 | # } |
1410 | } |
1411 | |
1412 | } |
1413 | |
1414 | 1; |
1415 | |
1416 | |
1417 | |
1418 | |