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