1package CompTestUtils;
2
3package main ;
4
5use strict ;
6use warnings;
7use bytes;
8
9#use lib qw(t t/compress);
10
11use Carp ;
12#use Test::More ;
13
14
15
16sub title
17{
18    #diag "" ;
19    ok(1, $_[0]) ;
20    #diag "" ;
21}
22
23sub like_eval
24{
25    like $@, @_ ;
26}
27
28BEGIN {
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
143sub 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
169sub touch
170{
171    foreach (@_) { writeFile($_, '') }
172}
173
174sub 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
188sub 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
204sub 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
242sub readHeaderInfo
243{
244    my $name = shift ;
245    my %opts = @_ ;
246
247    my $string = <<EOM;
248some text
249EOM
250
251    ok my $x = IO::Compress::Gzip->new( $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 = IO::Uncompress::Gunzip->new( $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
269sub 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
286my %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
443for 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
456sub 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
470sub getInverse
471{
472    my $class = shift ;
473
474    return $TOP{$class}{Inverse};
475}
476
477sub getErrorRef
478{
479    my $class = shift ;
480
481    return $TOP{$class}{Error};
482}
483
484sub 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
493sub getTopFuncName
494{
495    my $class = shift ;
496
497    return $TOP{$class}{TopLevel} ;
498}
499
500sub 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
515our ($AnyUncompressError);
516BEGIN
517{
518    eval ' use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError); ';
519}
520
521sub 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 = IO::Uncompress::AnyUncompress->new( \$data,
566                    Append => 1,
567                    Transparent => 0,
568                    RawInflate => 1,
569                    UnLzma     => 1,
570                    @opts
571            )
572        or croak "Cannot open buffer/file: $AnyUncompressError" ;
573
574    1 while $o->read($out) > 0 ;
575
576    croak "Error uncompressing -- " . $o->error()
577        if $o->error() ;
578
579    return $out ;
580}
581
582sub getHeaders
583{
584    my $buffer = shift ;
585    my $already = shift;
586
587    my @opts = ();
588    if (ref $buffer && ref $buffer eq 'ARRAY')
589    {
590        @opts = @$buffer;
591        $buffer = shift @opts;
592    }
593
594    if (ref $buffer)
595    {
596        croak "buffer is undef" unless defined $$buffer;
597        croak "buffer is empty" unless length $$buffer;
598
599    }
600
601
602    my $data ;
603    if (IO::Compress::Base::Common::isaFilehandle($buffer))
604    {
605        $data = readFile($buffer);
606    }
607    elsif (IO::Compress::Base::Common::isaFilename($buffer))
608    {
609        $data = readFile($buffer);
610    }
611    else
612    {
613        $data = $$buffer ;
614    }
615
616    if (defined $already && length $already)
617    {
618
619        my $got = substr($data, 0, length($already));
620        substr($data, 0, length($already)) = '';
621
622        is $got, $already, '  Already OK' ;
623    }
624
625    my $out = '';
626    my $o = IO::Uncompress::AnyUncompress->new( \$data,
627                MultiStream => 1,
628                Append => 1,
629                Transparent => 0,
630                RawInflate => 1,
631                UnLzma     => 1,
632                @opts
633            )
634        or croak "Cannot open buffer/file: $AnyUncompressError" ;
635
636    1 while $o->read($out) > 0 ;
637
638    croak "Error uncompressing -- " . $o->error()
639        if $o->error() ;
640
641    return ($o->getHeaderInfo()) ;
642
643}
644
645sub mkComplete
646{
647    my $class = shift ;
648    my $data = shift;
649    my $Error = getErrorRef($class);
650
651    my $buffer ;
652    my %params = ();
653
654    if ($class eq 'IO::Compress::Gzip') {
655        %params = (
656            Name       => "My name",
657            Comment    => "a comment",
658            ExtraField => ['ab' => "extra"],
659            HeaderCRC  => 1);
660    }
661    elsif ($class eq 'IO::Compress::Zip'){
662        %params = (
663            Name              => "My name",
664            Comment           => "a comment",
665            ZipComment        => "last comment",
666            exTime            => [100, 200, 300],
667            ExtraFieldLocal   => ["ab" => "extra1"],
668            ExtraFieldCentral => ["cd" => "extra2"],
669        );
670    }
671
672    my $z = $class->can('new')->( $class, \$buffer, %params)
673        or croak "Cannot create $class object: $$Error";
674    $z->write($data);
675    $z->close();
676
677    my $unc = getInverse($class);
678    anyUncompress(\$buffer) eq $data
679        or die "bad bad bad";
680    my $u = $unc->can('new')->( $unc, \$buffer);
681    my $info = $u->getHeaderInfo() ;
682
683
684    return wantarray ? ($info, $buffer) : $buffer ;
685}
686
687sub mkErr
688{
689    my $string = shift ;
690    my ($dummy, $file, $line) = caller ;
691    -- $line ;
692
693    $file = quotemeta($file);
694
695    #return "/$string\\s+at $file line $line/" if $] >= 5.006 ;
696    return "/$string\\s+at /" ;
697}
698
699sub mkEvalErr
700{
701    my $string = shift ;
702
703    #return "/$string\\s+at \\(eval /" if $] > 5.006 ;
704    return "/$string\\s+at /" ;
705}
706
707sub dumpObj
708{
709    my $obj = shift ;
710
711    my ($dummy, $file, $line) = caller ;
712
713    if (@_)
714    {
715        print "#\n# dumpOBJ from $file line $line @_\n" ;
716    }
717    else
718    {
719        print "#\n# dumpOBJ from $file line $line \n" ;
720    }
721
722    my $max = 0 ;;
723    foreach my $k (keys %{ *$obj })
724    {
725        $max = length $k if length $k > $max ;
726    }
727
728    foreach my $k (sort keys %{ *$obj })
729    {
730        my $v = $obj->{$k} ;
731        $v = '-undef-' unless defined $v;
732        my $pad = ' ' x ($max - length($k) + 2) ;
733        print "# $k$pad: [$v]\n";
734    }
735    print "#\n" ;
736}
737
738
739sub getMultiValues
740{
741    my $class = shift ;
742
743    return (0,0) if $class =~ /lzf|lzma|zstd/i;
744    return (1,0);
745}
746
747
748sub gotScalarUtilXS
749{
750    eval ' use Scalar::Util "dualvar" ';
751    return $@ ? 0 : 1 ;
752}
753
754package CompTestUtils;
755
7561;
757__END__
758	t/Test/Builder.pm
759	t/Test/More.pm
760	t/Test/Simple.pm
761	t/compress/CompTestUtils.pm
762	t/compress/any.pl
763	t/compress/anyunc.pl
764	t/compress/destroy.pl
765	t/compress/generic.pl
766	t/compress/merge.pl
767	t/compress/multi.pl
768	t/compress/newtied.pl
769	t/compress/oneshot.pl
770	t/compress/prime.pl
771	t/compress/tied.pl
772	t/compress/truncate.pl
773	t/compress/zlib-generic.plParsing config.in...
774Building Zlib enabled
775Auto Detect Gzip OS Code..
776Setting Gzip OS Code to 3 [Unix/Default]
777Looks Good.
778