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