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