Commit | Line | Data |
642e522c |
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 | unlink @_ ; |
40 | bless [ @_ ], $self ; |
41 | } |
42 | |
43 | sub DESTROY |
44 | { |
45 | my $self = shift ; |
46 | chmod 0777, @{ $self } ; |
47 | unlink @{ $self } ; |
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 die "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 | open (F, ">$filename") |
103 | or die "Cannot open $filename: $!\n" ; |
104 | binmode F; |
105 | foreach (@strings) { |
106 | no warnings ; |
107 | print F $_ ; |
108 | } |
109 | close F ; |
110 | } |
111 | |
112 | sub GZreadFile |
113 | { |
114 | my ($filename) = shift ; |
115 | |
116 | my ($uncomp) = "" ; |
117 | my $line = "" ; |
118 | my $fil = gzopen($filename, "rb") |
119 | or die "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; |
120 | |
121 | $uncomp .= $line |
122 | while $fil->gzread($line) > 0; |
123 | |
124 | $fil->gzclose ; |
125 | return $uncomp ; |
126 | } |
127 | |
128 | sub hexDump |
129 | { |
130 | my $d = shift ; |
131 | |
132 | if (Compress::Zlib::Common::isaFilehandle($d)) |
133 | { |
134 | $d = readFile($d); |
135 | } |
136 | elsif (Compress::Zlib::Common::isaFilename($d)) |
137 | { |
138 | $d = readFile($d); |
139 | } |
140 | else |
141 | { |
142 | $d = $$d ; |
143 | } |
144 | |
145 | my $offset = 0 ; |
146 | |
147 | $d = '' unless defined $d ; |
148 | #while (read(STDIN, $data, 16)) { |
149 | while (my $data = substr($d, 0, 16)) { |
150 | substr($d, 0, 16) = '' ; |
151 | printf "# %8.8lx ", $offset; |
152 | $offset += 16; |
153 | |
154 | my @array = unpack('C*', $data); |
155 | foreach (@array) { |
156 | printf('%2.2x ', $_); |
157 | } |
158 | print " " x (16 - @array) |
159 | if @array < 16 ; |
160 | $data =~ tr/\0-\37\177-\377/./; |
161 | print " $data\n"; |
162 | } |
163 | |
164 | } |
165 | |
166 | sub readHeaderInfo |
167 | { |
168 | my $name = shift ; |
169 | my %opts = @_ ; |
170 | |
171 | my $string = <<EOM; |
172 | some text |
173 | EOM |
174 | |
175 | ok my $x = new IO::Compress::Gzip $name, %opts |
176 | or diag "GzipError is $IO::Compress::Gzip::GzipError" ; |
177 | ok $x->write($string) ; |
178 | ok $x->close ; |
179 | |
180 | ok GZreadFile($name) eq $string ; |
181 | |
182 | ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0 |
183 | or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; |
184 | ok my $hdr = $gunz->getHeaderInfo(); |
185 | my $uncomp ; |
186 | ok $gunz->read($uncomp) ; |
187 | ok $uncomp eq $string; |
188 | ok $gunz->close ; |
189 | |
190 | return $hdr ; |
191 | } |
192 | |
193 | sub cmpFile |
194 | { |
195 | my ($filename, $uue) = @_ ; |
196 | return readFile($filename) eq unpack("u", $uue) ; |
197 | } |
198 | |
199 | sub uncompressBuffer |
200 | { |
201 | my $compWith = shift ; |
202 | my $buffer = shift ; |
203 | |
204 | my %mapping = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip', |
205 | 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip', |
206 | 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate', |
207 | 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate', |
208 | 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate', |
209 | 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate', |
210 | ); |
211 | |
212 | my $out ; |
213 | my $obj = $mapping{$compWith}->new( \$buffer, -Append => 1); |
214 | 1 while $obj->read($out) > 0 ; |
215 | return $out ; |
216 | |
217 | } |
218 | |
219 | my %ErrorMap = ( 'IO::Compress::Gzip' => \$IO::Compress::Gzip::GzipError, |
220 | 'IO::Compress::Gzip::gzip' => \$IO::Compress::Gzip::GzipError, |
221 | 'IO::Uncompress::Gunzip' => \$IO::Uncompress::Gunzip::GunzipError, |
222 | 'IO::Uncompress::Gunzip::gunzip' => \$IO::Uncompress::Gunzip::GunzipError, |
223 | 'IO::Uncompress::Inflate' => \$IO::Uncompress::Inflate::InflateError, |
224 | 'IO::Uncompress::Inflate::inflate' => \$IO::Uncompress::Inflate::InflateError, |
225 | 'IO::Compress::Deflate' => \$IO::Compress::Deflate::DeflateError, |
226 | 'IO::Compress::Deflate::deflate' => \$IO::Compress::Deflate::DeflateError, |
227 | 'IO::Uncompress::RawInflate' => \$IO::Uncompress::RawInflate::RawInflateError, |
228 | 'IO::Uncompress::RawInflate::rawinflate' => \$IO::Uncompress::RawInflate::RawInflateError, |
229 | 'IO::Uncompress::AnyInflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, |
230 | 'IO::Uncompress::AnyInflate::anyinflate' => \$IO::Uncompress::AnyInflate::AnyInflateError, |
231 | 'IO::Compress::RawDeflate' => \$IO::Compress::RawDeflate::RawDeflateError, |
232 | 'IO::Compress::RawDeflate::rawdeflate' => \$IO::Compress::RawDeflate::RawDeflateError, |
233 | ); |
234 | |
235 | my %TopFuncMap = ( 'IO::Compress::Gzip' => 'IO::Compress::Gzip::gzip', |
236 | 'IO::Uncompress::Gunzip' => 'IO::Uncompress::Gunzip::gunzip', |
237 | 'IO::Compress::Deflate' => 'IO::Compress::Deflate::deflate', |
238 | 'IO::Uncompress::Inflate' => 'IO::Uncompress::Inflate::inflate', |
239 | 'IO::Compress::RawDeflate' => 'IO::Compress::RawDeflate::rawdeflate', |
240 | 'IO::Uncompress::RawInflate' => 'IO::Uncompress::RawInflate::rawinflate', |
241 | 'IO::Uncompress::AnyInflate' => 'IO::Uncompress::AnyInflate::anyinflate', |
242 | ); |
243 | |
244 | %TopFuncMap = map { ($_ => $TopFuncMap{$_}, |
245 | $TopFuncMap{$_} => $TopFuncMap{$_}) } |
246 | keys %TopFuncMap ; |
247 | |
248 | #%TopFuncMap = map { ($_ => \&{ $TopFuncMap{$_} ) } |
249 | #keys %TopFuncMap ; |
250 | |
251 | |
252 | my %inverse = ( 'IO::Compress::Gzip' => 'IO::Uncompress::Gunzip', |
253 | 'IO::Compress::Gzip::gzip' => 'IO::Uncompress::Gunzip::gunzip', |
254 | 'IO::Compress::Deflate' => 'IO::Uncompress::Inflate', |
255 | 'IO::Compress::Deflate::deflate' => 'IO::Uncompress::Inflate::inflate', |
256 | 'IO::Compress::RawDeflate' => 'IO::Uncompress::RawInflate', |
257 | 'IO::Compress::RawDeflate::rawdeflate' => 'IO::Uncompress::RawInflate::rawinflate', |
258 | ); |
259 | |
260 | %inverse = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse; |
261 | |
262 | sub getInverse |
263 | { |
264 | my $class = shift ; |
265 | |
266 | return $inverse{$class} ; |
267 | } |
268 | |
269 | sub getErrorRef |
270 | { |
271 | my $class = shift ; |
272 | |
273 | return $ErrorMap{$class} ; |
274 | } |
275 | |
276 | sub getTopFuncRef |
277 | { |
278 | my $class = shift ; |
279 | |
280 | return \&{ $TopFuncMap{$class} } ; |
281 | } |
282 | |
283 | sub getTopFuncName |
284 | { |
285 | my $class = shift ; |
286 | |
287 | return $TopFuncMap{$class} ; |
288 | } |
289 | |
290 | sub compressBuffer |
291 | { |
292 | my $compWith = shift ; |
293 | my $buffer = shift ; |
294 | |
295 | my %mapping = ( 'IO::Uncompress::Gunzip' => 'IO::Compress::Gzip', |
296 | 'IO::Uncompress::Gunzip::gunzip' => 'IO::Compress::Gzip', |
297 | 'IO::Uncompress::Inflate' => 'IO::Compress::Deflate', |
298 | 'IO::Uncompress::Inflate::inflate' => 'IO::Compress::Deflate', |
299 | 'IO::Uncompress::RawInflate' => 'IO::Compress::RawDeflate', |
300 | 'IO::Uncompress::RawInflate::rawinflate' => 'IO::Compress::RawDeflate', |
301 | 'IO::Uncompress::AnyInflate' => 'IO::Compress::Gzip', |
302 | 'IO::Uncompress::AnyInflate::anyinflate' => 'IO::Compress::Gzip', |
303 | ); |
304 | |
305 | my $out ; |
306 | my $obj = $mapping{$compWith}->new( \$out); |
307 | $obj->write($buffer) ; |
308 | $obj->close(); |
309 | return $out ; |
310 | |
311 | } |
312 | |
313 | use IO::Uncompress::AnyInflate qw($AnyInflateError); |
314 | sub anyUncompress |
315 | { |
316 | my $buffer = shift ; |
317 | my $already = shift; |
318 | |
319 | my @opts = (); |
320 | if (ref $buffer && ref $buffer eq 'ARRAY') |
321 | { |
322 | @opts = @$buffer; |
323 | $buffer = shift @opts; |
324 | } |
325 | |
326 | if (ref $buffer) |
327 | { |
328 | croak "buffer is undef" unless defined $$buffer; |
329 | croak "buffer is empty" unless length $$buffer; |
330 | |
331 | } |
332 | |
333 | |
334 | my $data ; |
335 | if (Compress::Zlib::Common::isaFilehandle($buffer)) |
336 | { |
337 | $data = readFile($buffer); |
338 | } |
339 | elsif (Compress::Zlib::Common::isaFilename($buffer)) |
340 | { |
341 | $data = readFile($buffer); |
342 | } |
343 | else |
344 | { |
345 | $data = $$buffer ; |
346 | } |
347 | |
348 | if (defined $already && length $already) |
349 | { |
350 | |
351 | my $got = substr($data, 0, length($already)); |
352 | substr($data, 0, length($already)) = ''; |
353 | |
354 | is $got, $already, ' Already OK' ; |
355 | } |
356 | |
357 | my $out = ''; |
358 | my $o = new IO::Uncompress::AnyInflate \$data, -Append => 1, Transparent => 0, @opts |
359 | or croak "Cannot open buffer/file: $AnyInflateError" ; |
360 | |
361 | 1 while $o->read($out) > 0 ; |
362 | |
363 | croak "Error uncompressing -- " . $o->error() |
364 | if $o->error() ; |
365 | |
366 | return $out ; |
367 | |
368 | } |
369 | |
370 | sub mkErr |
371 | { |
372 | my $string = shift ; |
373 | my ($dummy, $file, $line) = caller ; |
374 | -- $line ; |
375 | |
376 | $file = quotemeta($file); |
377 | |
378 | return "/$string\\s+at $file line $line/" ; |
379 | } |
380 | |
381 | sub mkEvalErr |
382 | { |
383 | my $string = shift ; |
384 | |
385 | return "/$string\\s+at \\(eval /" ; |
386 | } |
387 | |
388 | sub dumpObj |
389 | { |
390 | my $obj = shift ; |
391 | |
392 | my ($dummy, $file, $line) = caller ; |
393 | |
394 | if (@_) |
395 | { |
396 | print "#\n# dumpOBJ from $file line $line @_\n" ; |
397 | } |
398 | else |
399 | { |
400 | print "#\n# dumpOBJ from $file line $line \n" ; |
401 | } |
402 | |
403 | my $max = 0 ;; |
404 | foreach my $k (keys %{ *$obj }) |
405 | { |
406 | $max = length $k if length $k > $max ; |
407 | } |
408 | |
409 | foreach my $k (sort keys %{ *$obj }) |
410 | { |
411 | my $v = $obj->{$k} ; |
412 | $v = '-undef-' unless defined $v; |
413 | my $pad = ' ' x ($max - length($k) + 2) ; |
414 | print "# $k$pad: [$v]\n"; |
415 | } |
416 | print "#\n" ; |
417 | } |
418 | |
419 | |
420 | package ZlibTestUtils; |
421 | |
422 | 1; |