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 = 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
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 = 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
581sub 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
643sub 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
685sub 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
697sub mkEvalErr
698{
699    my $string = shift ;
700
701    #return "/$string\\s+at \\(eval /" if $] > 5.006 ;
702    return "/$string\\s+at /" ;
703}
704
705sub 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
737sub getMultiValues
738{
739    my $class = shift ;
740
741    return (0,0) if $class =~ /lzf|lzma|zstd/i;
742    return (1,0);
743}
744
745
746sub gotScalarUtilXS
747{
748    eval ' use Scalar::Util "dualvar" ';
749    return $@ ? 0 : 1 ;
750}
751
752package CompTestUtils;
753
7541;
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...
772Building Zlib enabled
773Auto Detect Gzip OS Code..
774Setting Gzip OS Code to 3 [Unix/Default]
775Looks Good.
776