Move Compress::Raw::Bzip2 from ext/ to cpan/
[perl.git] / ext / Compress-Raw-Zlib / t / compress / CompTestUtils.pm
1 package CompTestUtils;
2
3 package main ;
4
5 use strict ;
6 use warnings;
7 use bytes;
8
9 #use lib qw(t t/compress);
10
11 use Carp ;
12 #use Test::More ; 
13
14
15
16 sub title
17 {
18     #diag "" ; 
19     ok 1, $_[0] ;
20     #diag "" ;
21 }
22
23 sub 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 }
74 sub 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
100 sub touch
101 {
102     foreach (@_) { writeFile($_, '') }
103 }
104
105 sub 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
119 sub 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
135 sub 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
173 sub readHeaderInfo
174 {
175     my $name = shift ;
176     my %opts = @_ ;
177
178     my $string = <<EOM;
179 some text
180 EOM
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
200 sub 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
217 my %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
353 for 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
366 sub 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
380 sub getInverse
381 {
382     my $class = shift ;
383
384     return $TOP{$class}{Inverse};
385 }
386
387 sub getErrorRef
388 {
389     my $class = shift ;
390
391     return $TOP{$class}{Error};
392 }
393
394 sub 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
403 sub getTopFuncName
404 {
405     my $class = shift ;
406
407     return $TOP{$class}{TopLevel} ;
408 }
409
410 sub 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
425 our ($AnyUncompressError);
426 BEGIN
427 {
428     eval ' use IO::Uncompress::AnyUncompress qw($AnyUncompressError); ';
429 }
430
431 sub 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                     @opts
480         or croak "Cannot open buffer/file: $AnyUncompressError" ;
481
482     1 while $o->read($out) > 0 ;
483
484     croak "Error uncompressing -- " . $o->error()
485         if $o->error() ;
486
487     return $out ;
488
489 }
490
491 sub getHeaders
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                 MultiStream => 1, 
537                 Append => 1, 
538                 Transparent => 0, 
539                 RawInflate => 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 ($o->getHeaderInfo()) ;
549
550 }
551
552 sub mkComplete
553 {
554     my $class = shift ;
555     my $data = shift;
556     my $Error = getErrorRef($class);
557
558     my $buffer ;
559     my %params = ();
560
561     if ($class eq 'IO::Compress::Gzip') {
562         %params = (
563             Name       => "My name",
564             Comment    => "a comment",
565             ExtraField => ['ab' => "extra"],
566             HeaderCRC  => 1);
567     }
568     elsif ($class eq 'IO::Compress::Zip'){
569         %params = (
570             Name              => "My name",
571             Comment           => "a comment",
572             ZipComment        => "last comment",
573             exTime            => [100, 200, 300],
574             ExtraFieldLocal   => ["ab" => "extra1"],
575             ExtraFieldCentral => ["cd" => "extra2"],
576         );
577     }
578
579     my $z = new $class( \$buffer, %params)
580         or croak "Cannot create $class object: $$Error";
581     $z->write($data);
582     $z->close();
583
584     my $unc = getInverse($class);
585     anyUncompress(\$buffer) eq $data
586         or die "bad bad bad";
587     my $u = new $unc( \$buffer);
588     my $info = $u->getHeaderInfo() ;
589
590
591     return wantarray ? ($info, $buffer) : $buffer ;
592 }
593
594 sub mkErr
595 {
596     my $string = shift ;
597     my ($dummy, $file, $line) = caller ;
598     -- $line ;
599
600     $file = quotemeta($file);
601
602     #return "/$string\\s+at $file line $line/" if $] >= 5.006 ;
603     return "/$string\\s+at /" ;
604 }
605
606 sub mkEvalErr
607 {
608     my $string = shift ;
609
610     #return "/$string\\s+at \\(eval /" if $] > 5.006 ;
611     return "/$string\\s+at /" ;
612 }
613
614 sub dumpObj
615 {
616     my $obj = shift ;
617
618     my ($dummy, $file, $line) = caller ;
619
620     if (@_)
621     {
622         print "#\n# dumpOBJ from $file line $line @_\n" ;
623     }
624     else
625     {
626         print "#\n# dumpOBJ from $file line $line \n" ;
627     }
628
629     my $max = 0 ;;
630     foreach my $k (keys %{ *$obj })
631     {
632         $max = length $k if length $k > $max ;
633     }
634
635     foreach my $k (sort keys %{ *$obj })
636     {
637         my $v = $obj->{$k} ;
638         $v = '-undef-' unless defined $v;
639         my $pad = ' ' x ($max - length($k) + 2) ;
640         print "# $k$pad: [$v]\n";
641     }
642     print "#\n" ;
643 }
644
645
646 sub getMultiValues
647 {
648     my $class = shift ;
649
650     return (0,0) if $class =~ /lzf/i;
651     return (1,0);
652 }
653
654
655 sub gotScalarUtilXS
656 {
657     eval ' use Scalar::Util "dualvar" ';
658     return $@ ? 0 : 1 ;
659 }
660
661 package CompTestUtils;
662
663 1;
664 __END__
665         t/Test/Builder.pm
666         t/Test/More.pm
667         t/Test/Simple.pm
668         t/compress/CompTestUtils.pm
669         t/compress/any.pl
670         t/compress/anyunc.pl
671         t/compress/destroy.pl
672         t/compress/generic.pl
673         t/compress/merge.pl
674         t/compress/multi.pl
675         t/compress/newtied.pl
676         t/compress/oneshot.pl
677         t/compress/prime.pl
678         t/compress/tied.pl
679         t/compress/truncate.pl
680         t/compress/zlib-generic.plParsing config.in...
681 Building Zlib enabled
682 Auto Detect Gzip OS Code..
683 Setting Gzip OS Code to 3 [Unix/Default]
684 Looks Good.