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