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