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