CompTestUtils.pm revision 1.1.1.3 
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::PPMd' => { Inverse  => 'IO::Uncompress::UnPPMd',
399                              Error    => 'PPMdError',
400                              TopLevel => 'ppmd',
401                              Raw      => 0,
402                            },
403    'IO::Uncompress::UnPPMd' => { Inverse  => 'IO::Compress::PPMd',
404                                  Error    => 'UnPPMdError',
405                                  TopLevel => 'unppmd',
406                                  Raw      => 0,
407                                },
408
409    'IO::Compress::DummyComp' => { Inverse  => 'IO::Uncompress::DummyUnComp',
410                                   Error    => 'DummyCompError',
411                                   TopLevel => 'dummycomp',
412                                   Raw      => 0,
413                                 },
414    'IO::Uncompress::DummyUnComp' => { Inverse  => 'IO::Compress::DummyComp',
415                                       Error    => 'DummyUnCompError',
416                                       TopLevel => 'dummyunComp',
417                                       Raw      => 0,
418                                     },
419);
420
421
422for my $key (keys %TOP)
423{
424    no strict;
425    no warnings;
426    $TOP{$key}{Error}    = \${ $key . '::' . $TOP{$key}{Error}    };
427    $TOP{$key}{TopLevel} =     $key . '::' . $TOP{$key}{TopLevel}  ;
428
429    # Silence used once warning in really old perl
430    my $dummy            = \${ $key . '::' . $TOP{$key}{Error}    };
431
432    #$TOP{$key . "::" . $TOP{$key}{TopLevel} } = $TOP{$key};
433}
434
435sub uncompressBuffer
436{
437    my $compWith = shift ;
438    my $buffer = shift ;
439
440
441    my $out ;
442    my $obj = $TOP{$compWith}{Inverse}->new( \$buffer, -Append => 1);
443    1 while $obj->read($out) > 0 ;
444    return $out ;
445
446}
447
448
449sub getInverse
450{
451    my $class = shift ;
452
453    return $TOP{$class}{Inverse};
454}
455
456sub getErrorRef
457{
458    my $class = shift ;
459
460    return $TOP{$class}{Error};
461}
462
463sub getTopFuncRef
464{
465    my $class = shift ;
466
467    die "Cannot find $class"
468        if ! defined $TOP{$class}{TopLevel};
469    return \&{ $TOP{$class}{TopLevel} } ;
470}
471
472sub getTopFuncName
473{
474    my $class = shift ;
475
476    return $TOP{$class}{TopLevel} ;
477}
478
479sub compressBuffer
480{
481    my $compWith = shift ;
482    my $buffer = shift ;
483
484
485    my $out ;
486    die "Cannot find $compWith"
487        if ! defined $TOP{$compWith}{Inverse};
488    my $obj = $TOP{$compWith}{Inverse}->new( \$out);
489    $obj->write($buffer) ;
490    $obj->close();
491    return $out ;
492}
493
494our ($AnyUncompressError);
495BEGIN
496{
497    eval ' use IO::Uncompress::AnyUncompress qw($AnyUncompressError); ';
498}
499
500sub anyUncompress
501{
502    my $buffer = shift ;
503    my $already = shift;
504
505    my @opts = ();
506    if (ref $buffer && ref $buffer eq 'ARRAY')
507    {
508        @opts = @$buffer;
509        $buffer = shift @opts;
510    }
511
512    if (ref $buffer)
513    {
514        croak "buffer is undef" unless defined $$buffer;
515        croak "buffer is empty" unless length $$buffer;
516
517    }
518
519
520    my $data ;
521    if (IO::Compress::Base::Common::isaFilehandle($buffer))
522    {
523        $data = readFile($buffer);
524    }
525    elsif (IO::Compress::Base::Common::isaFilename($buffer))
526    {
527        $data = readFile($buffer);
528    }
529    else
530    {
531        $data = $$buffer ;
532    }
533
534    if (defined $already && length $already)
535    {
536
537        my $got = substr($data, 0, length($already));
538        substr($data, 0, length($already)) = '';
539
540        is $got, $already, '  Already OK' ;
541    }
542
543    my $out = '';
544    my $o = new IO::Uncompress::AnyUncompress \$data,
545                    Append => 1,
546                    Transparent => 0,
547                    RawInflate => 1,
548                    UnLzma     => 1,
549                    @opts
550        or croak "Cannot open buffer/file: $AnyUncompressError" ;
551
552    1 while $o->read($out) > 0 ;
553
554    croak "Error uncompressing -- " . $o->error()
555        if $o->error() ;
556
557    return $out ;
558
559}
560
561sub getHeaders
562{
563    my $buffer = shift ;
564    my $already = shift;
565
566    my @opts = ();
567    if (ref $buffer && ref $buffer eq 'ARRAY')
568    {
569        @opts = @$buffer;
570        $buffer = shift @opts;
571    }
572
573    if (ref $buffer)
574    {
575        croak "buffer is undef" unless defined $$buffer;
576        croak "buffer is empty" unless length $$buffer;
577
578    }
579
580
581    my $data ;
582    if (IO::Compress::Base::Common::isaFilehandle($buffer))
583    {
584        $data = readFile($buffer);
585    }
586    elsif (IO::Compress::Base::Common::isaFilename($buffer))
587    {
588        $data = readFile($buffer);
589    }
590    else
591    {
592        $data = $$buffer ;
593    }
594
595    if (defined $already && length $already)
596    {
597
598        my $got = substr($data, 0, length($already));
599        substr($data, 0, length($already)) = '';
600
601        is $got, $already, '  Already OK' ;
602    }
603
604    my $out = '';
605    my $o = new IO::Uncompress::AnyUncompress \$data,
606                MultiStream => 1,
607                Append => 1,
608                Transparent => 0,
609                RawInflate => 1,
610                UnLzma     => 1,
611                @opts
612        or croak "Cannot open buffer/file: $AnyUncompressError" ;
613
614    1 while $o->read($out) > 0 ;
615
616    croak "Error uncompressing -- " . $o->error()
617        if $o->error() ;
618
619    return ($o->getHeaderInfo()) ;
620
621}
622
623sub mkComplete
624{
625    my $class = shift ;
626    my $data = shift;
627    my $Error = getErrorRef($class);
628
629    my $buffer ;
630    my %params = ();
631
632    if ($class eq 'IO::Compress::Gzip') {
633        %params = (
634            Name       => "My name",
635            Comment    => "a comment",
636            ExtraField => ['ab' => "extra"],
637            HeaderCRC  => 1);
638    }
639    elsif ($class eq 'IO::Compress::Zip'){
640        %params = (
641            Name              => "My name",
642            Comment           => "a comment",
643            ZipComment        => "last comment",
644            exTime            => [100, 200, 300],
645            ExtraFieldLocal   => ["ab" => "extra1"],
646            ExtraFieldCentral => ["cd" => "extra2"],
647        );
648    }
649
650    my $z = new $class( \$buffer, %params)
651        or croak "Cannot create $class object: $$Error";
652    $z->write($data);
653    $z->close();
654
655    my $unc = getInverse($class);
656    anyUncompress(\$buffer) eq $data
657        or die "bad bad bad";
658    my $u = new $unc( \$buffer);
659    my $info = $u->getHeaderInfo() ;
660
661
662    return wantarray ? ($info, $buffer) : $buffer ;
663}
664
665sub mkErr
666{
667    my $string = shift ;
668    my ($dummy, $file, $line) = caller ;
669    -- $line ;
670
671    $file = quotemeta($file);
672
673    #return "/$string\\s+at $file line $line/" if $] >= 5.006 ;
674    return "/$string\\s+at /" ;
675}
676
677sub mkEvalErr
678{
679    my $string = shift ;
680
681    #return "/$string\\s+at \\(eval /" if $] > 5.006 ;
682    return "/$string\\s+at /" ;
683}
684
685sub dumpObj
686{
687    my $obj = shift ;
688
689    my ($dummy, $file, $line) = caller ;
690
691    if (@_)
692    {
693        print "#\n# dumpOBJ from $file line $line @_\n" ;
694    }
695    else
696    {
697        print "#\n# dumpOBJ from $file line $line \n" ;
698    }
699
700    my $max = 0 ;;
701    foreach my $k (keys %{ *$obj })
702    {
703        $max = length $k if length $k > $max ;
704    }
705
706    foreach my $k (sort keys %{ *$obj })
707    {
708        my $v = $obj->{$k} ;
709        $v = '-undef-' unless defined $v;
710        my $pad = ' ' x ($max - length($k) + 2) ;
711        print "# $k$pad: [$v]\n";
712    }
713    print "#\n" ;
714}
715
716
717sub getMultiValues
718{
719    my $class = shift ;
720
721    return (0,0) if $class =~ /lzf|lzma/i;
722    return (1,0);
723}
724
725
726sub gotScalarUtilXS
727{
728    eval ' use Scalar::Util "dualvar" ';
729    return $@ ? 0 : 1 ;
730}
731
732package CompTestUtils;
733
7341;
735__END__
736	t/Test/Builder.pm
737	t/Test/More.pm
738	t/Test/Simple.pm
739	t/compress/CompTestUtils.pm
740	t/compress/any.pl
741	t/compress/anyunc.pl
742	t/compress/destroy.pl
743	t/compress/generic.pl
744	t/compress/merge.pl
745	t/compress/multi.pl
746	t/compress/newtied.pl
747	t/compress/oneshot.pl
748	t/compress/prime.pl
749	t/compress/tied.pl
750	t/compress/truncate.pl
751	t/compress/zlib-generic.plParsing config.in...
752Building Zlib enabled
753Auto Detect Gzip OS Code..
754Setting Gzip OS Code to 3 [Unix/Default]
755Looks Good.
756