Commit | Line | Data |
25f0751f |
1 | package CompTestUtils; |
2 | |
3 | package main ; |
4 | |
5 | use strict ; |
6 | use warnings; |
7 | use bytes; |
8 | |
9 | use Carp ; |
10 | |
11 | |
12 | sub title |
13 | { |
14 | #diag "" ; |
15 | ok 1, $_[0] ; |
16 | #diag "" ; |
17 | } |
18 | |
19 | sub like_eval |
20 | { |
21 | like $@, @_ ; |
22 | } |
23 | |
24 | { |
25 | package LexFile ; |
26 | |
27 | our ($index); |
28 | $index = '00000'; |
29 | |
30 | sub new |
31 | { |
32 | my $self = shift ; |
33 | foreach (@_) |
34 | { |
35 | # autogenerate the name unless if none supplied |
36 | $_ = "tst" . $index ++ . ".tmp" |
37 | unless defined $_; |
38 | } |
39 | chmod 0777, @_; |
40 | for (@_) { 1 while unlink $_ } ; |
41 | bless [ @_ ], $self ; |
42 | } |
43 | |
44 | sub DESTROY |
45 | { |
46 | my $self = shift ; |
47 | chmod 0777, @{ $self } ; |
48 | for (@$self) { 1 while unlink $_ } ; |
49 | } |
50 | |
51 | } |
52 | |
53 | { |
54 | package LexDir ; |
55 | |
56 | use File::Path; |
57 | sub new |
58 | { |
59 | my $self = shift ; |
60 | foreach (@_) { rmtree $_ } |
61 | bless [ @_ ], $self ; |
62 | } |
63 | |
64 | sub DESTROY |
65 | { |
66 | my $self = shift ; |
67 | foreach (@$self) { rmtree $_ } |
68 | } |
69 | } |
70 | sub readFile |
71 | { |
72 | my $f = shift ; |
73 | |
74 | my @strings ; |
75 | |
76 | if (IO::Compress::Base::Common::isaFilehandle($f)) |
77 | { |
78 | my $pos = tell($f); |
79 | seek($f, 0,0); |
80 | @strings = <$f> ; |
81 | seek($f, 0, $pos); |
82 | } |
83 | else |
84 | { |
85 | open (F, "<$f") |
86 | or croak "Cannot open $f: $!\n" ; |
87 | binmode F; |
88 | @strings = <F> ; |
89 | close F ; |
90 | } |
91 | |
92 | return @strings if wantarray ; |
93 | return join "", @strings ; |
94 | } |
95 | |
96 | sub touch |
97 | { |
98 | foreach (@_) { writeFile($_, '') } |
99 | } |
100 | |
101 | sub writeFile |
102 | { |
103 | my($filename, @strings) = @_ ; |
104 | 1 while unlink $filename ; |
105 | open (F, ">$filename") |
106 | or croak "Cannot open $filename: $!\n" ; |
107 | binmode F; |
108 | foreach (@strings) { |
109 | no warnings ; |
110 | print F $_ ; |
111 | } |
112 | close F ; |
113 | } |
114 | |
115 | sub GZreadFile |
116 | { |
117 | my ($filename) = shift ; |
118 | |
119 | my ($uncomp) = "" ; |
120 | my $line = "" ; |
121 | my $fil = gzopen($filename, "rb") |
122 | or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; |
123 | |
124 | $uncomp .= $line |
125 | while $fil->gzread($line) > 0; |
126 | |
127 | $fil->gzclose ; |
128 | return $uncomp ; |
129 | } |
130 | |
131 | sub hexDump |
132 | { |
133 | my $d = shift ; |
134 | |
135 | if (IO::Compress::Base::Common::isaFilehandle($d)) |
136 | { |
137 | $d = readFile($d); |
138 | } |
139 | elsif (IO::Compress::Base::Common::isaFilename($d)) |
140 | { |
141 | $d = readFile($d); |
142 | } |
143 | else |
144 | { |
145 | $d = $$d ; |
146 | } |
147 | |
148 | my $offset = 0 ; |
149 | |
150 | $d = '' unless defined $d ; |
151 | #while (read(STDIN, $data, 16)) { |
152 | while (my $data = substr($d, 0, 16)) { |
153 | substr($d, 0, 16) = '' ; |
154 | printf "# %8.8lx ", $offset; |
155 | $offset += 16; |
156 | |
157 | my @array = unpack('C*', $data); |
158 | foreach (@array) { |
159 | printf('%2.2x ', $_); |
160 | } |
161 | print " " x (16 - @array) |
162 | if @array < 16 ; |
163 | $data =~ tr/\0-\37\177-\377/./; |
164 | print " $data\n"; |
165 | } |
166 | |
167 | } |
168 | |
169 | sub readHeaderInfo |
170 | { |
171 | my $name = shift ; |
172 | my %opts = @_ ; |
173 | |
174 | my $string = <<EOM; |
175 | some text |
176 | EOM |
177 | |
178 | ok my $x = new IO::Compress::Gzip $name, %opts |
179 | or diag "GzipError is $IO::Compress::Gzip::GzipError" ; |
180 | ok $x->write($string) ; |
181 | ok $x->close ; |
182 | |
183 | #is GZreadFile($name), $string ; |
184 | |
185 | ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0 |
186 | or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; |
187 | ok my $hdr = $gunz->getHeaderInfo(); |
188 | my $uncomp ; |
189 | ok $gunz->read($uncomp) ; |
190 | ok $uncomp eq $string; |
191 | ok $gunz->close ; |
192 | |
193 | return $hdr ; |
194 | } |
195 | |
196 | sub cmpFile |
197 | { |
198 | my ($filename, $uue) = @_ ; |
199 | return readFile($filename) eq unpack("u", $uue) ; |
200 | } |
201 | |
202 | sub uncompressBuffer |
203 | { |
204 | my $compWith = shift ; |
205 | my $buffer = shift ; |
206 | |
207 | my %mapping = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip', |
208 | 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip', |
209 | 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate', |
210 | 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate', |
211 | 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate', |
212 | 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate', |
213 | 'IO::Compress::Bzip2' => 'IO::Uncompress::Bunzip2', |
214 | 'IO::Compress::Bzip2::bzip2' => 'IO::Uncompress::Bunzip2', |
215 | 'IO::Compress::Zip' => 'IO::Uncompress::Unzip', |
216 | 'IO::Compress::Zip::zip' => 'IO::Uncompress::Unzip', |
217 | 'IO::Compress::Lzop' => 'IO::Uncompress::UnLzop', |
218 | 'IO::Compress::Lzop::lzop' => 'IO::Uncompress::UnLzop', |
219 | 'IO::Compress::DummyComp' => 'IO::Uncompress::DummyUncomp', |
220 | 'IO::Compress::DummyComp::dummycomp' => 'IO::Uncompress::DummyUncomp', |
221 | ); |
222 | |
223 | my $out ; |
224 | my $obj = $mapping{$compWith}->new( \$buffer, -Append => 1); |
225 | 1 while $obj->read($out) > 0 ; |
226 | return $out ; |
227 | |
228 | } |
229 | |
230 | my %ErrorMap = ( 'IO::Compress::Gzip' => \$IO::Compress::Gzip::GzipError, |
231 | 'IO::Compress::Gzip::gzip' => \$IO::Compress::Gzip::GzipError, |
232 | 'IO::Uncompress::Gunzip' => \$IO::Uncompress::Gunzip::GunzipError, |
233 | 'IO::Uncompress::Gunzip::gunzip' => \$IO::Uncompress::Gunzip::GunzipError, |
234 | 'IO::Uncompress::Inflate' => \$IO::Uncompress::Inflate::InflateError, |
235 | 'IO::Uncompress::Inflate::inflate' => \$IO::Uncompress::Inflate::InflateError, |
236 | 'IO::Compress::Deflate' => \$IO::Compress::Deflate::DeflateError, |
237 | 'IO::Compress::Deflate::deflate' => \$IO::Compress::Deflate::DeflateError, |
238 | 'IO::Uncompress::RawInflate' => \$IO::Uncompress::RawInflate::RawInflateError, |
239 | 'IO::Uncompress::RawInflate::rawinflate' => \$IO::Uncompress::RawInflate::RawInflateError, |
240 | 'IO::Uncompress::AnyInflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, |
241 | 'IO::Uncompress::AnyInflate::anyinflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, |
242 | 'IO::Uncompress::AnyUncompress' => \$IO::Uncompress::AnyUncompress::AnyUncompressError, |
243 | 'IO::Uncompress::AnyUncompress::anyUncompress' => \$IO::Uncompress::AnyUncompress::AnyUncompressError, |
244 | 'IO::Compress::RawDeflate' => \$IO::Compress::RawDeflate::RawDeflateError, |
245 | 'IO::Compress::RawDeflate::rawdeflate' => \$IO::Compress::RawDeflate::RawDeflateError, |
246 | 'IO::Compress::Bzip2' => \$IO::Compress::Bzip2::Bzip2Error, |
247 | 'IO::Compress::Bzip2::bzip2' => \$IO::Compress::Bzip2::Bzip2Error, |
248 | 'IO::Uncompress::Bunzip2' => \$IO::Uncompress::Bunzip2::Bunzip2Error, |
249 | 'IO::Uncompress::Bunzip2::bunzip2' => \$IO::Uncompress::Bunzip2::Bunzip2Error, |
250 | 'IO::Compress::Zip' => \$IO::Compress::Zip::ZipError, |
251 | 'IO::Compress::Zip::zip' => \$IO::Compress::Zip::ZipError, |
252 | 'IO::Uncompress::Unzip' => \$IO::Uncompress::Unzip::UnzipError, |
253 | 'IO::Uncompress::Unzip::unzip' => \$IO::Uncompress::Unzip::UnzipError, |
254 | 'IO::Compress::Lzop' => \$IO::Compress::Lzop::LzopError, |
255 | 'IO::Compress::Lzop::lzop' => \$IO::Compress::Lzop::LzopError, |
256 | 'IO::Uncompress::UnLzop' => \$IO::Uncompress::UnLzop::UnLzopError, |
257 | 'IO::Uncompress::UnLzop::unlzop' => \$IO::Uncompress::UnLzop::UnLzopError, |
258 | |
259 | 'IO::Compress::DummyComp' => \$IO::Compress::DummyComp::DummyCompError, |
260 | 'IO::Compress::DummyComp::dummycomp'=> \$IO::Compress::DummyComp::DummyCompError, |
261 | 'IO::Uncompress::DummyUncomp' => \$IO::Uncompress::DummyUncomp::DummyUncompError, |
262 | 'IO::Uncompress::DummyUncomp::dummyuncomp' => \$IO::Uncompress::DummyUncomp::DummyUncompError, |
263 | ); |
264 | |
265 | my %TopFuncMap = ( 'IO::Compress::Gzip' => 'IO::Compress::Gzip::gzip', |
266 | 'IO::Uncompress::Gunzip' => 'IO::Uncompress::Gunzip::gunzip', |
267 | |
268 | 'IO::Compress::Deflate' => 'IO::Compress::Deflate::deflate', |
269 | 'IO::Uncompress::Inflate' => 'IO::Uncompress::Inflate::inflate', |
270 | |
271 | 'IO::Compress::RawDeflate' => 'IO::Compress::RawDeflate::rawdeflate', |
272 | 'IO::Uncompress::RawInflate' => 'IO::Uncompress::RawInflate::rawinflate', |
273 | |
274 | 'IO::Uncompress::AnyInflate' => 'IO::Uncompress::AnyInflate::anyinflate', |
275 | 'IO::Uncompress::AnyUncompress' => 'IO::Uncompress::AnyUncompress::anyuncompress', |
276 | |
277 | 'IO::Compress::Bzip2' => 'IO::Compress::Bzip2::bzip2', |
278 | 'IO::Uncompress::Bunzip2' => 'IO::Uncompress::Bunzip2::bunzip2', |
279 | |
280 | 'IO::Compress::Zip' => 'IO::Compress::Zip::zip', |
281 | 'IO::Uncompress::Unzip' => 'IO::Uncompress::Unzip::unzip', |
282 | 'IO::Compress::Lzop' => 'IO::Compress::Lzop::lzop', |
283 | 'IO::Uncompress::UnLzop' => 'IO::Uncompress::UnLzop::unlzop', |
284 | 'IO::Compress::DummyComp' => 'IO::Compress::DummyComp::dummyuncomp', |
285 | 'IO::Uncompress::DummyUncomp' => 'IO::Uncompress::DummyUncomp::dummyuncomp', |
286 | ); |
287 | |
288 | %TopFuncMap = map { ($_ => $TopFuncMap{$_}, |
289 | $TopFuncMap{$_} => $TopFuncMap{$_}) } |
290 | keys %TopFuncMap ; |
291 | |
292 | #%TopFuncMap = map { ($_ => \&{ $TopFuncMap{$_} ) } |
293 | #keys %TopFuncMap ; |
294 | |
295 | |
296 | my %inverse = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip', |
297 | 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip::gunzip', |
298 | 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate', |
299 | 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate::inflate', |
300 | 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate', |
301 | 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate::rawinflate', |
302 | 'IO::Compress::Bzip2::bzip2' => 'IO::Uncompress::Bunzip2::bunzip2', |
303 | 'IO::Compress::Bzip2' => 'IO::Uncompress::Bunzip2', |
304 | 'IO::Compress::Zip::zip' => 'IO::Uncompress::Unzip::unzip', |
305 | 'IO::Compress::Zip' => 'IO::Uncompress::Unzip', |
306 | 'IO::Compress::Lzop::lzop' => 'IO::Uncompress::UnLzop::unlzop', |
307 | 'IO::Compress::Lzop' => 'IO::Uncompress::UnLzop', |
308 | 'IO::Compress::DummyComp::dummycomp' => 'IO::Uncompress::DummyUncomp::dummyuncomp', |
309 | 'IO::Compress::DummyComp' => 'IO::Uncompress::DummyUncomp', |
310 | ); |
311 | |
312 | %inverse = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse; |
313 | |
314 | sub getInverse |
315 | { |
316 | my $class = shift ; |
317 | |
318 | return $inverse{$class} ; |
319 | } |
320 | |
321 | sub getErrorRef |
322 | { |
323 | my $class = shift ; |
324 | |
325 | return $ErrorMap{$class} ; |
326 | } |
327 | |
328 | sub getTopFuncRef |
329 | { |
330 | my $class = shift ; |
331 | |
332 | return \&{ $TopFuncMap{$class} } ; |
333 | } |
334 | |
335 | sub getTopFuncName |
336 | { |
337 | my $class = shift ; |
338 | |
339 | return $TopFuncMap{$class} ; |
340 | } |
341 | |
342 | sub compressBuffer |
343 | { |
344 | my $compWith = shift ; |
345 | my $buffer = shift ; |
346 | |
347 | my %mapping = ( 'IO::Uncompress::Gunzip' => 'IO::Compress::Gzip', |
348 | 'IO::Uncompress::Gunzip::gunzip' => 'IO::Compress::Gzip', |
349 | 'IO::Uncompress::Inflate' => 'IO::Compress::Deflate', |
350 | 'IO::Uncompress::Inflate::inflate' => 'IO::Compress::Deflate', |
351 | 'IO::Uncompress::RawInflate' => 'IO::Compress::RawDeflate', |
352 | 'IO::Uncompress::RawInflate::rawinflate' => 'IO::Compress::RawDeflate', |
353 | 'IO::Uncompress::Bunzip2' => 'IO::Compress::Bzip2', |
354 | 'IO::Uncompress::Bunzip2::bunzip2' => 'IO::Compress::Bzip2', |
355 | 'IO::Uncompress::Unzip' => 'IO::Compress::Zip', |
356 | 'IO::Uncompress::Unzip::unzip' => 'IO::Compress::Zip', |
357 | 'IO::Uncompress::UnLzop' => 'IO::Compress::Lzop', |
358 | 'IO::Uncompress::UnLzop::unlzop' => 'IO::Compress::Lzop', |
359 | 'IO::Uncompress::AnyInflate' => 'IO::Compress::Gzip', |
360 | 'IO::Uncompress::AnyInflate::anyinflate' => 'IO::Compress::Gzip', |
361 | 'IO::Uncompress::AnyUncompress' => 'IO::Compress::Gzip', |
362 | 'IO::Uncompress::AnyUncompress::anyuncompress' => 'IO::Compress::Gzip', |
363 | 'IO::Uncompress::DummyUncomp' => 'IO::Compress::DummyComp', |
364 | 'IO::Uncompress::DummyUncomp::dummyuncomp'=> 'IO::Compress::DummyComp', |
365 | ); |
366 | |
367 | my $out ; |
368 | my $obj = $mapping{$compWith}->new( \$out); |
369 | $obj->write($buffer) ; |
370 | $obj->close(); |
371 | return $out ; |
372 | } |
373 | |
374 | our ($AnyUncompressError); |
375 | BEGIN |
376 | { |
377 | eval { require IO::Uncompress::AnyUncompress ; |
378 | import IO::Uncompress::AnyUncompress qw($AnyUncompressError) } ; |
379 | } |
380 | |
381 | sub anyUncompress |
382 | { |
383 | my $buffer = shift ; |
384 | my $already = shift; |
385 | |
386 | my @opts = (); |
387 | if (ref $buffer && ref $buffer eq 'ARRAY') |
388 | { |
389 | @opts = @$buffer; |
390 | $buffer = shift @opts; |
391 | } |
392 | |
393 | if (ref $buffer) |
394 | { |
395 | croak "buffer is undef" unless defined $$buffer; |
396 | croak "buffer is empty" unless length $$buffer; |
397 | |
398 | } |
399 | |
400 | |
401 | my $data ; |
402 | if (IO::Compress::Base::Common::isaFilehandle($buffer)) |
403 | { |
404 | $data = readFile($buffer); |
405 | } |
406 | elsif (IO::Compress::Base::Common::isaFilename($buffer)) |
407 | { |
408 | $data = readFile($buffer); |
409 | } |
410 | else |
411 | { |
412 | $data = $$buffer ; |
413 | } |
414 | |
415 | if (defined $already && length $already) |
416 | { |
417 | |
418 | my $got = substr($data, 0, length($already)); |
419 | substr($data, 0, length($already)) = ''; |
420 | |
421 | is $got, $already, ' Already OK' ; |
422 | } |
423 | |
424 | my $out = ''; |
425 | my $o = new IO::Uncompress::AnyUncompress \$data, -Append => 1, Transparent => 0, @opts |
426 | or croak "Cannot open buffer/file: $AnyUncompressError" ; |
427 | |
428 | 1 while $o->read($out) > 0 ; |
429 | |
430 | croak "Error uncompressing -- " . $o->error() |
431 | if $o->error() ; |
432 | |
433 | return $out ; |
434 | |
435 | } |
436 | |
437 | sub getHeaders |
438 | { |
439 | my $buffer = shift ; |
440 | my $already = shift; |
441 | |
442 | my @opts = (); |
443 | if (ref $buffer && ref $buffer eq 'ARRAY') |
444 | { |
445 | @opts = @$buffer; |
446 | $buffer = shift @opts; |
447 | } |
448 | |
449 | if (ref $buffer) |
450 | { |
451 | croak "buffer is undef" unless defined $$buffer; |
452 | croak "buffer is empty" unless length $$buffer; |
453 | |
454 | } |
455 | |
456 | |
457 | my $data ; |
458 | if (IO::Compress::Base::Common::isaFilehandle($buffer)) |
459 | { |
460 | $data = readFile($buffer); |
461 | } |
462 | elsif (IO::Compress::Base::Common::isaFilename($buffer)) |
463 | { |
464 | $data = readFile($buffer); |
465 | } |
466 | else |
467 | { |
468 | $data = $$buffer ; |
469 | } |
470 | |
471 | if (defined $already && length $already) |
472 | { |
473 | |
474 | my $got = substr($data, 0, length($already)); |
475 | substr($data, 0, length($already)) = ''; |
476 | |
477 | is $got, $already, ' Already OK' ; |
478 | } |
479 | |
480 | my $out = ''; |
481 | my $o = new IO::Uncompress::AnyUncompress \$data, MultiStream => 1, -Append => 1, Transparent => 0, @opts |
482 | or croak "Cannot open buffer/file: $AnyUncompressError" ; |
483 | |
484 | 1 while $o->read($out) > 0 ; |
485 | |
486 | croak "Error uncompressing -- " . $o->error() |
487 | if $o->error() ; |
488 | |
489 | return ($o->getHeaderInfo()) ; |
490 | |
491 | } |
492 | |
493 | sub mkComplete |
494 | { |
495 | my $class = shift ; |
496 | my $data = shift; |
497 | my $Error = getErrorRef($class); |
498 | |
499 | my $buffer ; |
500 | my %params = (); |
501 | |
502 | if ($class eq 'IO::Compress::Gzip') { |
503 | %params = ( |
504 | -Name => "My name", |
505 | -Comment => "a comment", |
506 | -ExtraField => ['ab' => "extra"], |
507 | -HeaderCRC => 1); |
508 | } |
509 | elsif ($class eq 'IO::Compress::Zip'){ |
510 | %params = ( |
511 | # TODO -- add more here |
512 | -Name => "My name", |
513 | -Comment => "a comment", |
514 | ); |
515 | } |
516 | |
517 | my $z = new $class( \$buffer, %params) |
518 | or croak "Cannot create $class object: $$Error"; |
519 | $z->write($data); |
520 | $z->close(); |
521 | |
522 | my $unc = getInverse($class); |
523 | anyUncompress(\$buffer) eq $data |
524 | or die "bad bad bad"; |
525 | my $u = new $unc( \$buffer); |
526 | my $info = $u->getHeaderInfo() ; |
527 | |
528 | |
529 | return wantarray ? ($info, $buffer) : $buffer ; |
530 | } |
531 | |
532 | sub mkErr |
533 | { |
534 | my $string = shift ; |
535 | my ($dummy, $file, $line) = caller ; |
536 | -- $line ; |
537 | |
538 | $file = quotemeta($file); |
539 | |
540 | return "/$string\\s+at $file line $line/" if $] >= 5.006 ; |
541 | return "/$string\\s+at /" ; |
542 | } |
543 | |
544 | sub mkEvalErr |
545 | { |
546 | my $string = shift ; |
547 | |
548 | return "/$string\\s+at \\(eval /" if $] > 5.006 ; |
549 | return "/$string\\s+at /" ; |
550 | } |
551 | |
552 | sub dumpObj |
553 | { |
554 | my $obj = shift ; |
555 | |
556 | my ($dummy, $file, $line) = caller ; |
557 | |
558 | if (@_) |
559 | { |
560 | print "#\n# dumpOBJ from $file line $line @_\n" ; |
561 | } |
562 | else |
563 | { |
564 | print "#\n# dumpOBJ from $file line $line \n" ; |
565 | } |
566 | |
567 | my $max = 0 ;; |
568 | foreach my $k (keys %{ *$obj }) |
569 | { |
570 | $max = length $k if length $k > $max ; |
571 | } |
572 | |
573 | foreach my $k (sort keys %{ *$obj }) |
574 | { |
575 | my $v = $obj->{$k} ; |
576 | $v = '-undef-' unless defined $v; |
577 | my $pad = ' ' x ($max - length($k) + 2) ; |
578 | print "# $k$pad: [$v]\n"; |
579 | } |
580 | print "#\n" ; |
581 | } |
582 | |
583 | |
584 | package CompTestUtils; |
585 | |
586 | 1; |