perldelta: perldelta for previous commit
[perl.git] / cpan / Compress-Raw-Zlib / t / compress / CompTestUtils.pm
1 package CompTestUtils;
2
3 package main ;
4
5 use strict ;
6 use warnings;
7 use bytes;
8
9 #use lib qw(t t/compress);
10
11 use Carp ;
12 #use Test::More ; 
13
14
15
16 sub title
17 {
18     #diag "" ; 
19     ok(1, $_[0]) ;
20     #diag "" ;
21 }
22
23 sub like_eval
24 {
25     like $@, @_ ;
26 }
27
28 BEGIN {
29     eval { 
30        require File::Temp;
31      } ;
32
33 }
34
35
36 {
37     package LexFile ;
38
39     our ($index);
40     $index = '00000';
41     
42     sub new
43     {
44         my $self = shift ;
45         foreach (@_)
46         {
47             Carp::croak "NO!!!!" if defined $_;
48             # autogenerate the name if none supplied
49             $_ = "tst" . $$ . "X" . $index ++ . ".tmp"
50                 unless defined $_;
51         }
52         chmod 0777, @_;
53         for (@_) { 1 while unlink $_ } ;
54         bless [ @_ ], $self ;
55     }
56
57     sub DESTROY
58     {
59         my $self = shift ;
60         chmod 0777, @{ $self } ;
61         for (@$self) { 1 while unlink $_ } ;
62     }
63
64 }
65
66 {
67     package LexDir ;
68
69     use File::Path;
70
71     our ($index);
72     $index = '00000';
73     our ($useTempFile);
74     our ($useTempDir);
75     
76     sub new
77     {
78         my $self = shift ;
79
80         if ( $useTempDir)
81         {
82             foreach (@_)
83             {
84                 Carp::croak "NO!!!!" if defined $_;
85                 $_ = File::Temp->newdir(DIR => '.');
86                 # Subsequent manipulations assume Unix syntax, metacharacters, etc.
87                 if ($^O eq 'VMS')
88                 {
89                     $_->{DIRNAME} = VMS::Filespec::unixify($_->{DIRNAME});
90                     $_->{DIRNAME} =~ s/\/$//;
91                 }
92             }
93             bless [ @_ ], $self ;
94         }
95         elsif ( $useTempFile)
96         {
97             foreach (@_)
98             {
99                 Carp::croak "NO!!!!" if defined $_;
100                 $_ = File::Temp::tempdir(DIR => '.', CLEANUP => 1);
101                 # Subsequent manipulations assume Unix syntax, metacharacters, etc.
102                 if ($^O eq 'VMS')
103                 {
104                     $_ = VMS::Filespec::unixify($_);
105                     $_ =~ s/\/$//;
106                 }
107             }
108             bless [ @_ ], $self ;
109         }
110         else
111         {
112             foreach (@_)
113             {
114                 Carp::croak "NO!!!!" if defined $_;
115                 # autogenerate the name if none supplied
116                 $_ = "tmpdir" . $$ . "X" . $index ++ . ".tmp" ;
117             }
118             foreach (@_) 
119             { 
120                 rmtree $_, {verbose => 0, safe => 1}
121                     if -d $_; 
122                 mkdir $_, 0777 
123             }
124             bless [ @_ ], $self ;
125         }
126
127     }
128
129     sub DESTROY
130     {
131         if (! $useTempFile)
132         {
133             my $self = shift ;
134             foreach (@$self) 
135             { 
136                 rmtree $_, {verbose => 0, safe => 1}
137                     if -d $_ ; 
138             }
139         }
140     }
141 }
142
143 sub readFile
144 {
145     my $f = shift ;
146
147     my @strings ;
148
149     if (IO::Compress::Base::Common::isaFilehandle($f))
150     {
151         my $pos = tell($f);
152         seek($f, 0,0);
153         @strings = <$f> ;       
154         seek($f, 0, $pos);
155     }
156     else
157     {
158         open (F, "<$f") 
159             or croak "Cannot open $f: $!\n" ;
160         binmode F;
161         @strings = <F> ;        
162         close F ;
163     }
164
165     return @strings if wantarray ;
166     return join "", @strings ;
167 }
168
169 sub touch
170 {
171     foreach (@_) { writeFile($_, '') }
172 }
173
174 sub writeFile
175 {
176     my($filename, @strings) = @_ ;
177     1 while unlink $filename ;
178     open (F, ">$filename") 
179         or croak "Cannot open $filename: $!\n" ;
180     binmode F;
181     foreach (@strings) {
182         no warnings ;
183         print F $_ ;
184     }
185     close F ;
186 }
187
188 sub GZreadFile
189 {
190     my ($filename) = shift ;
191
192     my ($uncomp) = "" ;
193     my $line = "" ;
194     my $fil = gzopen($filename, "rb") 
195         or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ;
196
197     $uncomp .= $line 
198         while $fil->gzread($line) > 0;
199
200     $fil->gzclose ;
201     return $uncomp ;
202 }
203
204 sub hexDump
205 {
206     my $d = shift ;
207
208     if (IO::Compress::Base::Common::isaFilehandle($d))
209     {
210         $d = readFile($d);
211     }
212     elsif (IO::Compress::Base::Common::isaFilename($d))
213     {
214         $d = readFile($d);
215     }
216     else
217     {
218         $d = $$d ;
219     }
220
221     my $offset = 0 ;
222
223     $d = '' unless defined $d ;
224     #while (read(STDIN, $data, 16)) {
225     while (my $data = substr($d, 0, 16)) {
226         substr($d, 0, 16) = '' ;
227         printf "# %8.8lx    ", $offset;
228         $offset += 16;
229
230         my @array = unpack('C*', $data);
231         foreach (@array) {
232             printf('%2.2x ', $_);
233         }
234         print "   " x (16 - @array)
235             if @array < 16 ;
236         $data =~ tr/\0-\37\177-\377/./;
237         print "  $data\n";
238     }
239
240 }
241
242 sub readHeaderInfo
243 {
244     my $name = shift ;
245     my %opts = @_ ;
246
247     my $string = <<EOM;
248 some text
249 EOM
250
251     ok my $x = new IO::Compress::Gzip $name, %opts 
252         or diag "GzipError is $IO::Compress::Gzip::GzipError" ;
253     ok $x->write($string) ;
254     ok $x->close ;
255
256     #is GZreadFile($name), $string ;
257
258     ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0
259         or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ;
260     ok my $hdr = $gunz->getHeaderInfo();
261     my $uncomp ;
262     ok $gunz->read($uncomp) ;
263     ok $uncomp eq $string;
264     ok $gunz->close ;
265
266     return $hdr ;
267 }
268
269 sub cmpFile
270 {
271     my ($filename, $uue) = @_ ;
272     return readFile($filename) eq unpack("u", $uue) ;
273 }
274
275 #sub isRawFormat
276 #{
277 #    my $class = shift;
278 #    # TODO -- add Lzma here?
279 #    my %raw = map { $_ => 1 } qw( RawDeflate );
280 #
281 #    return defined $raw{$class};
282 #}
283
284
285
286 my %TOP = (
287     'IO::Uncompress::AnyInflate' => { Inverse  => 'IO::Compress::Gzip',
288                                       Error    => 'AnyInflateError',
289                                       TopLevel => 'anyinflate',
290                                       Raw      => 0,
291                             },
292
293     'IO::Uncompress::AnyUncompress' => { Inverse  => 'IO::Compress::Gzip',
294                                          Error    => 'AnyUncompressError',
295                                          TopLevel => 'anyuncompress',
296                                          Raw      => 0,
297                             },
298
299     'IO::Compress::Gzip' => { Inverse  => 'IO::Uncompress::Gunzip',
300                               Error    => 'GzipError',
301                               TopLevel => 'gzip',
302                               Raw      => 0,
303                             },
304     'IO::Uncompress::Gunzip' => { Inverse  => 'IO::Compress::Gzip',
305                                   Error    => 'GunzipError',
306                                   TopLevel => 'gunzip',
307                                   Raw      => 0,
308                             },
309
310     'IO::Compress::Deflate' => { Inverse  => 'IO::Uncompress::Inflate',
311                                  Error    => 'DeflateError',
312                                  TopLevel => 'deflate',
313                                  Raw      => 0,
314                             },
315     'IO::Uncompress::Inflate' => { Inverse  => 'IO::Compress::Deflate',
316                                    Error    => 'InflateError',
317                                    TopLevel => 'inflate',
318                                    Raw      => 0,
319                             },
320
321     'IO::Compress::RawDeflate' => { Inverse  => 'IO::Uncompress::RawInflate',
322                                     Error    => 'RawDeflateError',
323                                     TopLevel => 'rawdeflate',
324                                     Raw      => 1,
325                             },
326     'IO::Uncompress::RawInflate' => { Inverse  => 'IO::Compress::RawDeflate',
327                                       Error    => 'RawInflateError',
328                                       TopLevel => 'rawinflate',
329                                       Raw      => 1,
330                             },
331
332     'IO::Compress::Zip' => { Inverse  => 'IO::Uncompress::Unzip',
333                              Error    => 'ZipError',
334                              TopLevel => 'zip',
335                              Raw      => 0,
336                             },
337     'IO::Uncompress::Unzip' => { Inverse  => 'IO::Compress::Zip',
338                                  Error    => 'UnzipError',
339                                  TopLevel => 'unzip',
340                                  Raw      => 0,
341                             },
342
343     'IO::Compress::Bzip2' => { Inverse  => 'IO::Uncompress::Bunzip2',
344                                Error    => 'Bzip2Error',
345                                TopLevel => 'bzip2',
346                                Raw      => 0,
347                             },
348     'IO::Uncompress::Bunzip2' => { Inverse  => 'IO::Compress::Bzip2',
349                                    Error    => 'Bunzip2Error',
350                                    TopLevel => 'bunzip2',
351                                    Raw      => 0,
352                             },
353
354     'IO::Compress::Lzop' => { Inverse  => 'IO::Uncompress::UnLzop',
355                               Error    => 'LzopError',
356                               TopLevel => 'lzop',
357                               Raw      => 0,
358                             },
359     'IO::Uncompress::UnLzop' => { Inverse  => 'IO::Compress::Lzop',
360                                   Error    => 'UnLzopError',
361                                   TopLevel => 'unlzop',
362                                   Raw      => 0,
363                             },
364
365     'IO::Compress::Lzf' => { Inverse  => 'IO::Uncompress::UnLzf',
366                              Error    => 'LzfError',
367                              TopLevel => 'lzf',
368                              Raw      => 0,
369                             },
370     'IO::Uncompress::UnLzf' => { Inverse  => 'IO::Compress::Lzf',
371                                  Error    => 'UnLzfError',
372                                  TopLevel => 'unlzf',
373                                  Raw      => 0,
374                             },
375
376     'IO::Compress::Lzma' => { Inverse  => 'IO::Uncompress::UnLzma',
377                               Error    => 'LzmaError',
378                               TopLevel => 'lzma',
379                               Raw      => 1,
380                             },
381     'IO::Uncompress::UnLzma' => { Inverse  => 'IO::Compress::Lzma',
382                                   Error    => 'UnLzmaError',
383                                   TopLevel => 'unlzma',
384                                   Raw      => 1,
385                                 },
386
387     'IO::Compress::Xz' => { Inverse  => 'IO::Uncompress::UnXz',
388                             Error    => 'XzError',
389                             TopLevel => 'xz',
390                             Raw      => 0,
391                           },
392     'IO::Uncompress::UnXz' => { Inverse  => 'IO::Compress::Xz',
393                                 Error    => 'UnXzError',
394                                 TopLevel => 'unxz',
395                                 Raw      => 0,
396                               },
397
398     'IO::Compress::Lzip' => { Inverse  => 'IO::Uncompress::UnLzip',
399                             Error    => 'LzipError',
400                             TopLevel => 'lzip',
401                             Raw      => 0,
402                           },
403     'IO::Uncompress::UnLzip' => { Inverse  => 'IO::Compress::Lzip',
404                                 Error    => 'UnLzipError',
405                                 TopLevel => 'unlzip',
406                                 Raw      => 0,
407                               },
408
409     'IO::Compress::PPMd' => { Inverse  => 'IO::Uncompress::UnPPMd',
410                               Error    => 'PPMdError',
411                               TopLevel => 'ppmd',
412                               Raw      => 0,
413                             },
414     'IO::Uncompress::UnPPMd' => { Inverse  => 'IO::Compress::PPMd',
415                                   Error    => 'UnPPMdError',
416                                   TopLevel => 'unppmd',
417                                   Raw      => 0,
418                                 },
419     'IO::Compress::Zstd' => { Inverse  => 'IO::Uncompress::UnZstd',
420                               Error    => 'ZstdError',
421                               TopLevel => 'zstd',
422                               Raw      => 0,
423                             },
424     'IO::Uncompress::UnZstd' => { Inverse  => 'IO::Compress::Zstd',
425                                   Error    => 'UnZstdError',
426                                   TopLevel => 'unzstd',
427                                   Raw      => 0,
428                                 },
429
430     'IO::Compress::DummyComp' => { Inverse  => 'IO::Uncompress::DummyUnComp',
431                                    Error    => 'DummyCompError',
432                                    TopLevel => 'dummycomp',
433                                    Raw      => 0,
434                                  },
435     'IO::Uncompress::DummyUnComp' => { Inverse  => 'IO::Compress::DummyComp',
436                                        Error    => 'DummyUnCompError',
437                                        TopLevel => 'dummyunComp',
438                                        Raw      => 0,
439                                      },
440 );
441
442
443 for my $key (keys %TOP)
444 {
445     no strict;
446     no warnings;
447     $TOP{$key}{Error}    = \${ $key . '::' . $TOP{$key}{Error}    };
448     $TOP{$key}{TopLevel} =     $key . '::' . $TOP{$key}{TopLevel}  ;
449
450     # Silence used once warning in really old perl
451     my $dummy            = \${ $key . '::' . $TOP{$key}{Error}    };
452
453     #$TOP{$key . "::" . $TOP{$key}{TopLevel} } = $TOP{$key};
454 }
455
456 sub uncompressBuffer
457 {
458     my $compWith = shift ;
459     my $buffer = shift ;
460
461
462     my $out ;
463     my $obj = $TOP{$compWith}{Inverse}->new( \$buffer, -Append => 1);
464     1 while $obj->read($out) > 0 ;
465     return $out ;
466
467 }
468
469
470 sub getInverse
471 {
472     my $class = shift ;
473
474     return $TOP{$class}{Inverse};
475 }
476
477 sub getErrorRef
478 {
479     my $class = shift ;
480
481     return $TOP{$class}{Error};
482 }
483
484 sub getTopFuncRef
485 {
486     my $class = shift ;
487
488     die "Cannot find $class"
489         if ! defined $TOP{$class}{TopLevel};
490     return \&{ $TOP{$class}{TopLevel} } ;
491 }
492
493 sub getTopFuncName
494 {
495     my $class = shift ;
496
497     return $TOP{$class}{TopLevel} ;
498 }
499
500 sub compressBuffer
501 {
502     my $compWith = shift ;
503     my $buffer = shift ;
504
505
506     my $out ;
507     die "Cannot find $compWith"
508         if ! defined $TOP{$compWith}{Inverse};
509     my $obj = $TOP{$compWith}{Inverse}->new( \$out);
510     $obj->write($buffer) ;
511     $obj->close();
512     return $out ;
513 }
514
515 our ($AnyUncompressError);
516 BEGIN
517 {
518     eval ' use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError); ';
519 }
520
521 sub anyUncompress
522 {
523     my $buffer = shift ;
524     my $already = shift;
525
526     my @opts = ();
527     if (ref $buffer && ref $buffer eq 'ARRAY')
528     {
529         @opts = @$buffer;
530         $buffer = shift @opts;
531     }
532
533     if (ref $buffer)
534     {
535         croak "buffer is undef" unless defined $$buffer;
536         croak "buffer is empty" unless length $$buffer;
537
538     }
539
540
541     my $data ;
542     if (IO::Compress::Base::Common::isaFilehandle($buffer))
543     {
544         $data = readFile($buffer);
545     }
546     elsif (IO::Compress::Base::Common::isaFilename($buffer))
547     {
548         $data = readFile($buffer);
549     }
550     else
551     {
552         $data = $$buffer ;
553     }
554
555     if (defined $already && length $already)
556     {
557
558         my $got = substr($data, 0, length($already));
559         substr($data, 0, length($already)) = '';
560
561         is $got, $already, '  Already OK' ;
562     }
563
564     my $out = '';
565     my $o = new IO::Uncompress::AnyUncompress \$data, 
566                     Append => 1, 
567                     Transparent => 0, 
568                     RawInflate => 1,
569                     UnLzma     => 1,
570                     @opts
571         or croak "Cannot open buffer/file: $AnyUncompressError" ;
572
573     1 while $o->read($out) > 0 ;
574
575     croak "Error uncompressing -- " . $o->error()
576         if $o->error() ;
577
578     return $out ;
579 }
580
581 sub getHeaders
582 {
583     my $buffer = shift ;
584     my $already = shift;
585
586     my @opts = ();
587     if (ref $buffer && ref $buffer eq 'ARRAY')
588     {
589         @opts = @$buffer;
590         $buffer = shift @opts;
591     }
592
593     if (ref $buffer)
594     {
595         croak "buffer is undef" unless defined $$buffer;
596         croak "buffer is empty" unless length $$buffer;
597
598     }
599
600
601     my $data ;
602     if (IO::Compress::Base::Common::isaFilehandle($buffer))
603     {
604         $data = readFile($buffer);
605     }
606     elsif (IO::Compress::Base::Common::isaFilename($buffer))
607     {
608         $data = readFile($buffer);
609     }
610     else
611     {
612         $data = $$buffer ;
613     }
614
615     if (defined $already && length $already)
616     {
617
618         my $got = substr($data, 0, length($already));
619         substr($data, 0, length($already)) = '';
620
621         is $got, $already, '  Already OK' ;
622     }
623
624     my $out = '';
625     my $o = new IO::Uncompress::AnyUncompress \$data, 
626                 MultiStream => 1, 
627                 Append => 1, 
628                 Transparent => 0, 
629                 RawInflate => 1,
630                 UnLzma     => 1,
631                 @opts
632         or croak "Cannot open buffer/file: $AnyUncompressError" ;
633
634     1 while $o->read($out) > 0 ;
635
636     croak "Error uncompressing -- " . $o->error()
637         if $o->error() ;
638
639     return ($o->getHeaderInfo()) ;
640
641 }
642
643 sub mkComplete
644 {
645     my $class = shift ;
646     my $data = shift;
647     my $Error = getErrorRef($class);
648
649     my $buffer ;
650     my %params = ();
651
652     if ($class eq 'IO::Compress::Gzip') {
653         %params = (
654             Name       => "My name",
655             Comment    => "a comment",
656             ExtraField => ['ab' => "extra"],
657             HeaderCRC  => 1);
658     }
659     elsif ($class eq 'IO::Compress::Zip'){
660         %params = (
661             Name              => "My name",
662             Comment           => "a comment",
663             ZipComment        => "last comment",
664             exTime            => [100, 200, 300],
665             ExtraFieldLocal   => ["ab" => "extra1"],
666             ExtraFieldCentral => ["cd" => "extra2"],
667         );
668     }
669
670     my $z = new $class( \$buffer, %params)
671         or croak "Cannot create $class object: $$Error";
672     $z->write($data);
673     $z->close();
674
675     my $unc = getInverse($class);
676     anyUncompress(\$buffer) eq $data
677         or die "bad bad bad";
678     my $u = new $unc( \$buffer);
679     my $info = $u->getHeaderInfo() ;
680
681
682     return wantarray ? ($info, $buffer) : $buffer ;
683 }
684
685 sub mkErr
686 {
687     my $string = shift ;
688     my ($dummy, $file, $line) = caller ;
689     -- $line ;
690
691     $file = quotemeta($file);
692
693     #return "/$string\\s+at $file line $line/" if $] >= 5.006 ;
694     return "/$string\\s+at /" ;
695 }
696
697 sub mkEvalErr
698 {
699     my $string = shift ;
700
701     #return "/$string\\s+at \\(eval /" if $] > 5.006 ;
702     return "/$string\\s+at /" ;
703 }
704
705 sub dumpObj
706 {
707     my $obj = shift ;
708
709     my ($dummy, $file, $line) = caller ;
710
711     if (@_)
712     {
713         print "#\n# dumpOBJ from $file line $line @_\n" ;
714     }
715     else
716     {
717         print "#\n# dumpOBJ from $file line $line \n" ;
718     }
719
720     my $max = 0 ;;
721     foreach my $k (keys %{ *$obj })
722     {
723         $max = length $k if length $k > $max ;
724     }
725
726     foreach my $k (sort keys %{ *$obj })
727     {
728         my $v = $obj->{$k} ;
729         $v = '-undef-' unless defined $v;
730         my $pad = ' ' x ($max - length($k) + 2) ;
731         print "# $k$pad: [$v]\n";
732     }
733     print "#\n" ;
734 }
735
736
737 sub getMultiValues
738 {
739     my $class = shift ;
740
741     return (0,0) if $class =~ /lzf|lzma|zstd/i;
742     return (1,0);
743 }
744
745
746 sub gotScalarUtilXS
747 {
748     eval ' use Scalar::Util "dualvar" ';
749     return $@ ? 0 : 1 ;
750 }
751
752 package CompTestUtils;
753
754 1;
755 __END__
756         t/Test/Builder.pm
757         t/Test/More.pm
758         t/Test/Simple.pm
759         t/compress/CompTestUtils.pm
760         t/compress/any.pl
761         t/compress/anyunc.pl
762         t/compress/destroy.pl
763         t/compress/generic.pl
764         t/compress/merge.pl
765         t/compress/multi.pl
766         t/compress/newtied.pl
767         t/compress/oneshot.pl
768         t/compress/prime.pl
769         t/compress/tied.pl
770         t/compress/truncate.pl
771         t/compress/zlib-generic.plParsing config.in...
772 Building Zlib enabled
773 Auto Detect Gzip OS Code..
774 Setting Gzip OS Code to 3 [Unix/Default]
775 Looks Good.