Commit | Line | Data |
25f0751f |
1 | package CompTestUtils; |
2 | |
3 | package main ; |
4 | |
5 | use strict ; |
6 | use warnings; |
7 | use bytes; |
8 | |
258133d1 |
9 | #use lib qw(t t/compress); |
10 | |
25f0751f |
11 | use Carp ; |
258133d1 |
12 | #use Test::More ; |
13 | |
25f0751f |
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 | |
10c2b2bb |
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) |
d54256af |
354 | { |
10c2b2bb |
355 | no strict; |
356 | no warnings; |
357 | $TOP{$key}{Error} = \${ $key . '::' . $TOP{$key}{Error} }; |
358 | $TOP{$key}{TopLevel} = $key . '::' . $TOP{$key}{TopLevel} ; |
d54256af |
359 | |
10c2b2bb |
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}; |
d54256af |
364 | } |
365 | |
25f0751f |
366 | sub uncompressBuffer |
367 | { |
368 | my $compWith = shift ; |
369 | my $buffer = shift ; |
370 | |
25f0751f |
371 | |
372 | my $out ; |
10c2b2bb |
373 | my $obj = $TOP{$compWith}{Inverse}->new( \$buffer, -Append => 1); |
25f0751f |
374 | 1 while $obj->read($out) > 0 ; |
375 | return $out ; |
376 | |
377 | } |
378 | |
25f0751f |
379 | |
380 | sub getInverse |
381 | { |
382 | my $class = shift ; |
383 | |
10c2b2bb |
384 | return $TOP{$class}{Inverse}; |
25f0751f |
385 | } |
386 | |
387 | sub getErrorRef |
388 | { |
389 | my $class = shift ; |
390 | |
10c2b2bb |
391 | return $TOP{$class}{Error}; |
25f0751f |
392 | } |
393 | |
394 | sub getTopFuncRef |
395 | { |
396 | my $class = shift ; |
397 | |
10c2b2bb |
398 | die "Cannot find $class" |
399 | if ! defined $TOP{$class}{TopLevel}; |
400 | return \&{ $TOP{$class}{TopLevel} } ; |
25f0751f |
401 | } |
402 | |
403 | sub getTopFuncName |
404 | { |
405 | my $class = shift ; |
406 | |
10c2b2bb |
407 | return $TOP{$class}{TopLevel} ; |
25f0751f |
408 | } |
409 | |
410 | sub compressBuffer |
411 | { |
412 | my $compWith = shift ; |
413 | my $buffer = shift ; |
414 | |
25f0751f |
415 | |
416 | my $out ; |
10c2b2bb |
417 | die "Cannot find $compWith" |
418 | if ! defined $TOP{$compWith}{Inverse}; |
419 | my $obj = $TOP{$compWith}{Inverse}->new( \$out); |
25f0751f |
420 | $obj->write($buffer) ; |
421 | $obj->close(); |
422 | return $out ; |
423 | } |
424 | |
425 | our ($AnyUncompressError); |
426 | BEGIN |
427 | { |
258133d1 |
428 | eval ' use IO::Uncompress::AnyUncompress qw($AnyUncompressError); '; |
25f0751f |
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 = ''; |
6ecef415 |
475 | my $o = new IO::Uncompress::AnyUncompress \$data, |
476 | Append => 1, |
477 | Transparent => 0, |
478 | RawInflate => 1, |
479 | @opts |
25f0751f |
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 = ''; |
6ecef415 |
535 | my $o = new IO::Uncompress::AnyUncompress \$data, |
536 | MultiStream => 1, |
537 | Append => 1, |
538 | Transparent => 0, |
539 | RawInflate => 1, |
540 | @opts |
25f0751f |
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 = ( |
c70c1701 |
563 | Name => "My name", |
564 | Comment => "a comment", |
565 | ExtraField => ['ab' => "extra"], |
566 | HeaderCRC => 1); |
25f0751f |
567 | } |
568 | elsif ($class eq 'IO::Compress::Zip'){ |
569 | %params = ( |
c70c1701 |
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"], |
25f0751f |
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 | |
10c2b2bb |
602 | #return "/$string\\s+at $file line $line/" if $] >= 5.006 ; |
25f0751f |
603 | return "/$string\\s+at /" ; |
604 | } |
605 | |
606 | sub mkEvalErr |
607 | { |
608 | my $string = shift ; |
609 | |
10c2b2bb |
610 | #return "/$string\\s+at \\(eval /" if $] > 5.006 ; |
25f0751f |
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 | |
258133d1 |
646 | sub getMultiValues |
647 | { |
648 | my $class = shift ; |
649 | |
650 | return (0,0) if $class =~ /lzf/i; |
651 | return (1,0); |
652 | } |
653 | |
f6fd7794 |
654 | |
655 | sub gotScalarUtilXS |
656 | { |
657 | eval ' use Scalar::Util "dualvar" '; |
658 | return $@ ? 0 : 1 ; |
659 | } |
660 | |
25f0751f |
661 | package CompTestUtils; |
662 | |
663 | 1; |
258133d1 |
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. |