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