Commit | Line | Data |
16816334 |
1 | BEGIN { |
d695c1a1 |
2 | if ($ENV{PERL_CORE}) { |
16816334 |
3 | chdir 't' if -d 't'; |
4 | @INC = '../lib'; |
5 | } |
6 | } |
642e522c |
7 | |
8 | use lib 't'; |
9 | use strict; |
10 | use warnings; |
11 | use bytes; |
12 | |
13 | use Test::More ; |
14 | use ZlibTestUtils; |
15 | |
16 | our ($BadPerl); |
17 | |
18 | BEGIN |
19 | { |
20 | plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) |
21 | if $] < 5.005 ; |
22 | |
23 | # use Test::NoWarnings, if available |
24 | my $extra = 0 ; |
25 | $extra = 1 |
26 | if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; |
27 | |
28 | my $tests ; |
29 | $BadPerl = ($] >= 5.006 or $] <= 5.008) ; |
30 | |
31 | if ($BadPerl) { |
32 | $tests = 731 ; |
33 | } |
34 | else { |
35 | $tests = 771 ; |
36 | } |
37 | |
38 | plan tests => $tests + $extra ; |
39 | |
40 | use_ok('Compress::Zlib', 2) ; |
41 | |
42 | use_ok('IO::Compress::Gzip', qw($GzipError)) ; |
43 | use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; |
44 | |
45 | use_ok('IO::Compress::Deflate', qw($DeflateError)) ; |
46 | use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; |
47 | |
48 | use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; |
49 | use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; |
50 | } |
51 | |
52 | |
53 | use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); |
54 | |
55 | |
56 | |
57 | |
58 | our ($UncompressClass); |
59 | |
60 | |
61 | sub myGZreadFile |
62 | { |
63 | my $filename = shift ; |
64 | my $init = shift ; |
65 | |
66 | |
67 | my $fil = new $UncompressClass $filename, |
68 | -Strict => 1, |
69 | -Append => 1 |
70 | ; |
71 | |
72 | my $data ; |
73 | $data = $init if defined $init ; |
74 | 1 while $fil->read($data) > 0; |
75 | |
76 | $fil->close ; |
77 | return $data ; |
78 | } |
79 | |
80 | # Check zlib_version and ZLIB_VERSION are the same. |
81 | is Compress::Zlib::zlib_version, ZLIB_VERSION, |
82 | "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; |
83 | |
84 | |
85 | |
86 | foreach my $CompressClass ('IO::Compress::Gzip', |
87 | 'IO::Compress::Deflate', |
88 | 'IO::Compress::RawDeflate') |
89 | { |
90 | next if $BadPerl ; |
91 | |
92 | |
93 | title "Testing $CompressClass"; |
94 | |
95 | |
96 | my $x ; |
97 | my $gz = new $CompressClass(\$x); |
98 | |
99 | my $buff ; |
100 | |
101 | eval { getc($gz) } ; |
102 | like $@, mkErr("^getc Not Available: File opened only for output"); |
103 | |
104 | eval { read($gz, $buff, 1) } ; |
105 | like $@, mkErr("^read Not Available: File opened only for output"); |
106 | |
107 | eval { <$gz> } ; |
108 | like $@, mkErr("^readline Not Available: File opened only for output"); |
109 | |
110 | } |
111 | |
112 | foreach my $CompressClass ('IO::Compress::Gzip', |
113 | 'IO::Compress::Deflate', |
114 | 'IO::Compress::RawDeflate') |
115 | { |
116 | next if $BadPerl; |
117 | $UncompressClass = getInverse($CompressClass); |
118 | |
119 | title "Testing $UncompressClass"; |
120 | |
121 | my $gc ; |
122 | my $guz = new $CompressClass(\$gc); |
123 | $guz->write("abc") ; |
124 | $guz->close(); |
125 | |
126 | my $x ; |
127 | my $gz = new $UncompressClass(\$gc); |
128 | |
129 | my $buff ; |
130 | |
131 | eval { print $gz "abc" } ; |
132 | like $@, mkErr("^print Not Available: File opened only for intput"); |
133 | |
134 | eval { printf $gz "fmt", "abc" } ; |
135 | like $@, mkErr("^printf Not Available: File opened only for intput"); |
136 | |
137 | #eval { write($gz, $buff, 1) } ; |
138 | #like $@, mkErr("^write Not Available: File opened only for intput"); |
139 | |
140 | } |
141 | |
142 | foreach my $CompressClass ('IO::Compress::Gzip', |
143 | 'IO::Compress::Deflate', |
144 | 'IO::Compress::RawDeflate') |
145 | { |
146 | $UncompressClass = getInverse($CompressClass); |
147 | |
148 | title "Testing $CompressClass and $UncompressClass"; |
149 | |
150 | |
151 | { |
152 | # Write |
153 | # these tests come almost 100% from IO::String |
154 | |
155 | my $name = "test.gz" ; |
156 | my $lex = new LexFile $name ; |
157 | |
158 | my $io = $CompressClass->new($name); |
159 | |
160 | is $io->tell(), 0 ; |
161 | |
162 | my $heisan = "Heisan\n"; |
163 | print $io $heisan ; |
164 | |
165 | ok ! $io->eof; |
166 | |
167 | is $io->tell(), length($heisan) ; |
168 | |
169 | print($io "a", "b", "c"); |
170 | |
171 | { |
172 | local($\) = "\n"; |
173 | print $io "d", "e"; |
174 | local($,) = ","; |
175 | print $io "f", "g", "h"; |
176 | } |
177 | |
178 | my $foo = "1234567890"; |
179 | |
180 | ok syswrite($io, $foo, length($foo)) == length($foo) ; |
181 | if ( $[ < 5.6 ) |
182 | { is $io->syswrite($foo, length $foo), length $foo } |
183 | else |
184 | { is $io->syswrite($foo), length $foo } |
185 | ok $io->syswrite($foo, length($foo)) == length $foo; |
186 | ok $io->write($foo, length($foo), 5) == 5; |
187 | ok $io->write("xxx\n", 100, -1) == 1; |
188 | |
189 | for (1..3) { |
190 | printf $io "i(%d)", $_; |
191 | $io->printf("[%d]\n", $_); |
192 | } |
193 | select $io; |
194 | print "\n"; |
195 | select STDOUT; |
196 | |
197 | close $io ; |
198 | |
199 | ok $io->eof; |
200 | |
201 | is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . |
202 | ("1234567890" x 3) . "67890\n" . |
203 | "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; |
204 | |
205 | |
206 | } |
207 | |
208 | { |
209 | # Read |
210 | my $str = <<EOT; |
211 | This is an example |
212 | of a paragraph |
213 | |
214 | |
215 | and a single line. |
216 | |
217 | EOT |
218 | |
219 | my $name = "test.gz" ; |
220 | my $lex = new LexFile $name ; |
221 | |
222 | my $iow = new $CompressClass $name ; |
223 | print $iow $str ; |
224 | close $iow; |
225 | |
226 | my @tmp; |
227 | my $buf; |
228 | { |
229 | my $io = new $UncompressClass $name ; |
230 | |
231 | ok ! $io->eof; |
232 | is $io->tell(), 0 ; |
233 | my @lines = <$io>; |
234 | is @lines, 6 |
235 | or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; |
236 | is $lines[1], "of a paragraph\n" ; |
237 | is join('', @lines), $str ; |
238 | is $., 6; |
239 | is $io->tell(), length($str) ; |
240 | |
241 | ok $io->eof; |
242 | |
243 | ok ! ( defined($io->getline) || |
244 | (@tmp = $io->getlines) || |
245 | defined(<$io>) || |
246 | defined($io->getc) || |
247 | read($io, $buf, 100) != 0) ; |
248 | } |
249 | |
250 | |
251 | { |
252 | local $/; # slurp mode |
253 | my $io = $UncompressClass->new($name); |
254 | ok !$io->eof; |
255 | my @lines = $io->getlines; |
256 | ok $io->eof; |
257 | ok @lines == 1 && $lines[0] eq $str; |
258 | |
259 | $io = $UncompressClass->new($name); |
260 | ok ! $io->eof; |
261 | my $line = <$io>; |
262 | ok $line eq $str; |
263 | ok $io->eof; |
264 | } |
265 | |
266 | { |
267 | local $/ = ""; # paragraph mode |
268 | my $io = $UncompressClass->new($name); |
269 | ok ! $io->eof; |
270 | my @lines = <$io>; |
271 | ok $io->eof; |
272 | ok @lines == 2 |
273 | or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; |
274 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
275 | or print "# $lines[0]\n"; |
276 | ok $lines[1] eq "and a single line.\n\n"; |
277 | } |
278 | |
279 | { |
280 | local $/ = "is"; |
281 | my $io = $UncompressClass->new($name); |
282 | my @lines = (); |
283 | my $no = 0; |
284 | my $err = 0; |
285 | ok ! $io->eof; |
286 | while (<$io>) { |
287 | push(@lines, $_); |
288 | $err++ if $. != ++$no; |
289 | } |
290 | |
291 | ok $err == 0 ; |
292 | ok $io->eof; |
293 | |
294 | ok @lines == 3 |
295 | or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; |
296 | ok join("-", @lines) eq |
297 | "This- is- an example\n" . |
298 | "of a paragraph\n\n\n" . |
299 | "and a single line.\n\n"; |
300 | } |
301 | |
302 | |
303 | # Test read |
304 | |
305 | { |
306 | my $io = $UncompressClass->new($name); |
307 | |
308 | |
309 | if (! $BadPerl) { |
310 | eval { read($io, $buf, -1) } ; |
311 | like $@, mkErr("length parameter is negative"); |
312 | } |
313 | |
314 | is read($io, $buf, 0), 0, "Requested 0 bytes" ; |
315 | |
316 | ok read($io, $buf, 3) == 3 ; |
317 | ok $buf eq "Thi"; |
318 | |
319 | ok sysread($io, $buf, 3, 2) == 3 ; |
320 | ok $buf eq "Ths i" |
321 | or print "# [$buf]\n" ;; |
322 | ok ! $io->eof; |
323 | |
324 | # $io->seek(-4, 2); |
325 | # |
326 | # ok ! $io->eof; |
327 | # |
328 | # ok read($io, $buf, 20) == 4 ; |
329 | # ok $buf eq "e.\n\n"; |
330 | # |
331 | # ok read($io, $buf, 20) == 0 ; |
332 | # ok $buf eq ""; |
333 | # |
334 | # ok ! $io->eof; |
335 | } |
336 | |
337 | } |
338 | |
339 | { |
340 | # Read from non-compressed file |
341 | |
342 | my $str = <<EOT; |
343 | This is an example |
344 | of a paragraph |
345 | |
346 | |
347 | and a single line. |
348 | |
349 | EOT |
350 | |
351 | my $name = "test.gz" ; |
352 | my $lex = new LexFile $name ; |
353 | |
354 | writeFile($name, $str); |
355 | my @tmp; |
356 | my $buf; |
357 | { |
358 | my $io = new $UncompressClass $name, -Transparent => 1 ; |
359 | |
360 | ok defined $io; |
361 | ok ! $io->eof; |
362 | ok $io->tell() == 0 ; |
363 | my @lines = <$io>; |
364 | ok @lines == 6; |
365 | ok $lines[1] eq "of a paragraph\n" ; |
366 | ok join('', @lines) eq $str ; |
367 | ok $. == 6; |
368 | ok $io->tell() == length($str) ; |
369 | |
370 | ok $io->eof; |
371 | |
372 | ok ! ( defined($io->getline) || |
373 | (@tmp = $io->getlines) || |
374 | defined(<$io>) || |
375 | defined($io->getc) || |
376 | read($io, $buf, 100) != 0) ; |
377 | } |
378 | |
379 | |
380 | { |
381 | local $/; # slurp mode |
382 | my $io = $UncompressClass->new($name); |
383 | ok ! $io->eof; |
384 | my @lines = $io->getlines; |
385 | ok $io->eof; |
386 | ok @lines == 1 && $lines[0] eq $str; |
387 | |
388 | $io = $UncompressClass->new($name); |
389 | ok ! $io->eof; |
390 | my $line = <$io>; |
391 | ok $line eq $str; |
392 | ok $io->eof; |
393 | } |
394 | |
395 | { |
396 | local $/ = ""; # paragraph mode |
397 | my $io = $UncompressClass->new($name); |
398 | ok ! $io->eof; |
399 | my @lines = <$io>; |
400 | ok $io->eof; |
401 | ok @lines == 2 |
402 | or print "# exected 2 lines, got " . scalar(@lines) . "\n"; |
403 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
404 | or print "# [$lines[0]]\n" ; |
405 | ok $lines[1] eq "and a single line.\n\n"; |
406 | } |
407 | |
408 | { |
409 | local $/ = "is"; |
410 | my $io = $UncompressClass->new($name); |
411 | my @lines = (); |
412 | my $no = 0; |
413 | my $err = 0; |
414 | ok ! $io->eof; |
415 | while (<$io>) { |
416 | push(@lines, $_); |
417 | $err++ if $. != ++$no; |
418 | } |
419 | |
420 | ok $err == 0 ; |
421 | ok $io->eof; |
422 | |
423 | ok @lines == 3 ; |
424 | ok join("-", @lines) eq |
425 | "This- is- an example\n" . |
426 | "of a paragraph\n\n\n" . |
427 | "and a single line.\n\n"; |
428 | } |
429 | |
430 | |
431 | # Test read |
432 | |
433 | { |
434 | my $io = $UncompressClass->new($name); |
435 | |
436 | ok read($io, $buf, 3) == 3 ; |
437 | ok $buf eq "Thi"; |
438 | |
439 | ok sysread($io, $buf, 3, 2) == 3 ; |
440 | ok $buf eq "Ths i"; |
441 | ok ! $io->eof; |
442 | |
443 | # $io->seek(-4, 2); |
444 | # |
445 | # ok ! $io->eof; |
446 | # |
447 | # ok read($io, $buf, 20) == 4 ; |
448 | # ok $buf eq "e.\n\n"; |
449 | # |
450 | # ok read($io, $buf, 20) == 0 ; |
451 | # ok $buf eq ""; |
452 | # |
453 | # ok ! $io->eof; |
454 | } |
455 | |
456 | |
457 | } |
458 | |
459 | { |
460 | # Vary the length parameter in a read |
461 | |
462 | my $str = <<EOT; |
463 | x |
464 | x |
465 | This is an example |
466 | of a paragraph |
467 | |
468 | |
469 | and a single line. |
470 | |
471 | EOT |
472 | $str = $str x 100 ; |
473 | |
474 | |
475 | foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) |
476 | { |
477 | foreach my $trans (0, 1) |
478 | { |
479 | foreach my $append (0, 1) |
480 | { |
481 | title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; |
482 | |
483 | my $name = "testz.gz" ; |
484 | my $lex = new LexFile $name ; |
485 | |
486 | if ($trans) { |
487 | writeFile($name, $str) ; |
488 | } |
489 | else { |
490 | my $iow = new $CompressClass $name ; |
491 | print $iow $str ; |
492 | close $iow; |
493 | } |
494 | |
495 | |
496 | my $io = $UncompressClass->new($name, |
497 | -Append => $append, |
498 | -Transparent => $trans); |
499 | |
500 | my $buf; |
501 | |
502 | is $io->tell(), 0; |
503 | |
504 | if ($append) { |
505 | 1 while $io->read($buf, $bufsize) > 0; |
506 | } |
507 | else { |
508 | my $tmp ; |
509 | $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; |
510 | } |
511 | is length $buf, length $str; |
512 | ok $buf eq $str ; |
513 | ok ! $io->error() ; |
514 | ok $io->eof; |
515 | } |
516 | } |
517 | } |
518 | } |
519 | |
520 | } |