Commit | Line | Data |
16816334 |
1 | BEGIN { |
d695c1a1 |
2 | if ($ENV{PERL_CORE}) { |
16816334 |
3 | chdir 't' if -d 't'; |
0ecadccd |
4 | @INC = ("../lib", "lib"); |
16816334 |
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 | |
9f2e3514 |
155 | my $lex = new LexFile my $name ; |
642e522c |
156 | |
157 | my $io = $CompressClass->new($name); |
158 | |
159 | is $io->tell(), 0 ; |
160 | |
161 | my $heisan = "Heisan\n"; |
162 | print $io $heisan ; |
163 | |
164 | ok ! $io->eof; |
165 | |
166 | is $io->tell(), length($heisan) ; |
167 | |
168 | print($io "a", "b", "c"); |
169 | |
170 | { |
171 | local($\) = "\n"; |
172 | print $io "d", "e"; |
173 | local($,) = ","; |
174 | print $io "f", "g", "h"; |
175 | } |
176 | |
177 | my $foo = "1234567890"; |
178 | |
179 | ok syswrite($io, $foo, length($foo)) == length($foo) ; |
180 | if ( $[ < 5.6 ) |
181 | { is $io->syswrite($foo, length $foo), length $foo } |
182 | else |
183 | { is $io->syswrite($foo), length $foo } |
184 | ok $io->syswrite($foo, length($foo)) == length $foo; |
185 | ok $io->write($foo, length($foo), 5) == 5; |
186 | ok $io->write("xxx\n", 100, -1) == 1; |
187 | |
188 | for (1..3) { |
189 | printf $io "i(%d)", $_; |
190 | $io->printf("[%d]\n", $_); |
191 | } |
192 | select $io; |
193 | print "\n"; |
194 | select STDOUT; |
195 | |
196 | close $io ; |
197 | |
198 | ok $io->eof; |
199 | |
200 | is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . |
201 | ("1234567890" x 3) . "67890\n" . |
202 | "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; |
203 | |
204 | |
205 | } |
206 | |
207 | { |
208 | # Read |
209 | my $str = <<EOT; |
210 | This is an example |
211 | of a paragraph |
212 | |
213 | |
214 | and a single line. |
215 | |
216 | EOT |
217 | |
9f2e3514 |
218 | my $lex = new LexFile my $name ; |
642e522c |
219 | |
220 | my $iow = new $CompressClass $name ; |
221 | print $iow $str ; |
222 | close $iow; |
223 | |
224 | my @tmp; |
225 | my $buf; |
226 | { |
227 | my $io = new $UncompressClass $name ; |
228 | |
229 | ok ! $io->eof; |
230 | is $io->tell(), 0 ; |
231 | my @lines = <$io>; |
232 | is @lines, 6 |
233 | or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; |
234 | is $lines[1], "of a paragraph\n" ; |
235 | is join('', @lines), $str ; |
236 | is $., 6; |
237 | is $io->tell(), length($str) ; |
238 | |
239 | ok $io->eof; |
240 | |
241 | ok ! ( defined($io->getline) || |
242 | (@tmp = $io->getlines) || |
243 | defined(<$io>) || |
244 | defined($io->getc) || |
245 | read($io, $buf, 100) != 0) ; |
246 | } |
247 | |
248 | |
249 | { |
250 | local $/; # slurp mode |
251 | my $io = $UncompressClass->new($name); |
252 | ok !$io->eof; |
253 | my @lines = $io->getlines; |
254 | ok $io->eof; |
255 | ok @lines == 1 && $lines[0] eq $str; |
256 | |
257 | $io = $UncompressClass->new($name); |
258 | ok ! $io->eof; |
259 | my $line = <$io>; |
260 | ok $line eq $str; |
261 | ok $io->eof; |
262 | } |
263 | |
264 | { |
265 | local $/ = ""; # paragraph mode |
266 | my $io = $UncompressClass->new($name); |
267 | ok ! $io->eof; |
268 | my @lines = <$io>; |
269 | ok $io->eof; |
270 | ok @lines == 2 |
271 | or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; |
272 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
273 | or print "# $lines[0]\n"; |
274 | ok $lines[1] eq "and a single line.\n\n"; |
275 | } |
276 | |
277 | { |
278 | local $/ = "is"; |
279 | my $io = $UncompressClass->new($name); |
280 | my @lines = (); |
281 | my $no = 0; |
282 | my $err = 0; |
283 | ok ! $io->eof; |
284 | while (<$io>) { |
285 | push(@lines, $_); |
286 | $err++ if $. != ++$no; |
287 | } |
288 | |
289 | ok $err == 0 ; |
290 | ok $io->eof; |
291 | |
292 | ok @lines == 3 |
293 | or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; |
294 | ok join("-", @lines) eq |
295 | "This- is- an example\n" . |
296 | "of a paragraph\n\n\n" . |
297 | "and a single line.\n\n"; |
298 | } |
299 | |
300 | |
301 | # Test read |
302 | |
303 | { |
304 | my $io = $UncompressClass->new($name); |
305 | |
306 | |
307 | if (! $BadPerl) { |
308 | eval { read($io, $buf, -1) } ; |
309 | like $@, mkErr("length parameter is negative"); |
310 | } |
311 | |
312 | is read($io, $buf, 0), 0, "Requested 0 bytes" ; |
313 | |
314 | ok read($io, $buf, 3) == 3 ; |
315 | ok $buf eq "Thi"; |
316 | |
317 | ok sysread($io, $buf, 3, 2) == 3 ; |
318 | ok $buf eq "Ths i" |
319 | or print "# [$buf]\n" ;; |
320 | ok ! $io->eof; |
321 | |
322 | # $io->seek(-4, 2); |
323 | # |
324 | # ok ! $io->eof; |
325 | # |
326 | # ok read($io, $buf, 20) == 4 ; |
327 | # ok $buf eq "e.\n\n"; |
328 | # |
329 | # ok read($io, $buf, 20) == 0 ; |
330 | # ok $buf eq ""; |
331 | # |
332 | # ok ! $io->eof; |
333 | } |
334 | |
335 | } |
336 | |
337 | { |
338 | # Read from non-compressed file |
339 | |
340 | my $str = <<EOT; |
341 | This is an example |
342 | of a paragraph |
343 | |
344 | |
345 | and a single line. |
346 | |
347 | EOT |
348 | |
9f2e3514 |
349 | my $lex = new LexFile my $name ; |
642e522c |
350 | |
351 | writeFile($name, $str); |
352 | my @tmp; |
353 | my $buf; |
354 | { |
355 | my $io = new $UncompressClass $name, -Transparent => 1 ; |
356 | |
357 | ok defined $io; |
358 | ok ! $io->eof; |
359 | ok $io->tell() == 0 ; |
360 | my @lines = <$io>; |
361 | ok @lines == 6; |
362 | ok $lines[1] eq "of a paragraph\n" ; |
363 | ok join('', @lines) eq $str ; |
364 | ok $. == 6; |
365 | ok $io->tell() == length($str) ; |
366 | |
367 | ok $io->eof; |
368 | |
369 | ok ! ( defined($io->getline) || |
370 | (@tmp = $io->getlines) || |
371 | defined(<$io>) || |
372 | defined($io->getc) || |
373 | read($io, $buf, 100) != 0) ; |
374 | } |
375 | |
376 | |
377 | { |
378 | local $/; # slurp mode |
379 | my $io = $UncompressClass->new($name); |
380 | ok ! $io->eof; |
381 | my @lines = $io->getlines; |
382 | ok $io->eof; |
383 | ok @lines == 1 && $lines[0] eq $str; |
384 | |
385 | $io = $UncompressClass->new($name); |
386 | ok ! $io->eof; |
387 | my $line = <$io>; |
388 | ok $line eq $str; |
389 | ok $io->eof; |
390 | } |
391 | |
392 | { |
393 | local $/ = ""; # paragraph mode |
394 | my $io = $UncompressClass->new($name); |
395 | ok ! $io->eof; |
396 | my @lines = <$io>; |
397 | ok $io->eof; |
398 | ok @lines == 2 |
399 | or print "# exected 2 lines, got " . scalar(@lines) . "\n"; |
400 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
401 | or print "# [$lines[0]]\n" ; |
402 | ok $lines[1] eq "and a single line.\n\n"; |
403 | } |
404 | |
405 | { |
406 | local $/ = "is"; |
407 | my $io = $UncompressClass->new($name); |
408 | my @lines = (); |
409 | my $no = 0; |
410 | my $err = 0; |
411 | ok ! $io->eof; |
412 | while (<$io>) { |
413 | push(@lines, $_); |
414 | $err++ if $. != ++$no; |
415 | } |
416 | |
417 | ok $err == 0 ; |
418 | ok $io->eof; |
419 | |
420 | ok @lines == 3 ; |
421 | ok join("-", @lines) eq |
422 | "This- is- an example\n" . |
423 | "of a paragraph\n\n\n" . |
424 | "and a single line.\n\n"; |
425 | } |
426 | |
427 | |
428 | # Test read |
429 | |
430 | { |
431 | my $io = $UncompressClass->new($name); |
432 | |
433 | ok read($io, $buf, 3) == 3 ; |
434 | ok $buf eq "Thi"; |
435 | |
436 | ok sysread($io, $buf, 3, 2) == 3 ; |
437 | ok $buf eq "Ths i"; |
438 | ok ! $io->eof; |
439 | |
440 | # $io->seek(-4, 2); |
441 | # |
442 | # ok ! $io->eof; |
443 | # |
444 | # ok read($io, $buf, 20) == 4 ; |
445 | # ok $buf eq "e.\n\n"; |
446 | # |
447 | # ok read($io, $buf, 20) == 0 ; |
448 | # ok $buf eq ""; |
449 | # |
450 | # ok ! $io->eof; |
451 | } |
452 | |
453 | |
454 | } |
455 | |
456 | { |
457 | # Vary the length parameter in a read |
458 | |
459 | my $str = <<EOT; |
460 | x |
461 | x |
462 | This is an example |
463 | of a paragraph |
464 | |
465 | |
466 | and a single line. |
467 | |
468 | EOT |
469 | $str = $str x 100 ; |
470 | |
471 | |
472 | foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1) |
473 | { |
474 | foreach my $trans (0, 1) |
475 | { |
476 | foreach my $append (0, 1) |
477 | { |
478 | title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; |
479 | |
9f2e3514 |
480 | my $lex = new LexFile my $name ; |
642e522c |
481 | |
482 | if ($trans) { |
483 | writeFile($name, $str) ; |
484 | } |
485 | else { |
486 | my $iow = new $CompressClass $name ; |
487 | print $iow $str ; |
488 | close $iow; |
489 | } |
490 | |
491 | |
492 | my $io = $UncompressClass->new($name, |
493 | -Append => $append, |
494 | -Transparent => $trans); |
495 | |
496 | my $buf; |
497 | |
498 | is $io->tell(), 0; |
499 | |
500 | if ($append) { |
501 | 1 while $io->read($buf, $bufsize) > 0; |
502 | } |
503 | else { |
504 | my $tmp ; |
505 | $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ; |
506 | } |
507 | is length $buf, length $str; |
508 | ok $buf eq $str ; |
509 | ok ! $io->error() ; |
510 | ok $io->eof; |
511 | } |
512 | } |
513 | } |
514 | } |
515 | |
516 | } |