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