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 => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) |
21 | if $] < 5.006 ; |
22 | |
23 | my $tests ; |
24 | |
25 | $BadPerl = ($] >= 5.006 or $] <= 5.008) ; |
26 | |
27 | if ($BadPerl) { |
28 | $tests = 242 ; |
29 | } |
30 | else { |
31 | $tests = 242 ; |
32 | } |
33 | |
34 | # use Test::NoWarnings, if available |
35 | my $extra = 0 ; |
36 | $extra = 1 |
37 | if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; |
38 | |
39 | plan tests => $tests + $extra ; |
40 | |
41 | use_ok('Compress::Zlib', 2) ; |
42 | |
43 | use_ok('IO::Compress::Gzip', qw($GzipError)) ; |
44 | use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; |
45 | |
46 | use_ok('IO::Compress::Deflate', qw($DeflateError)) ; |
47 | use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; |
48 | |
49 | use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; |
50 | use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; |
51 | |
52 | |
53 | } |
54 | |
55 | |
56 | use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); |
57 | |
58 | |
59 | our ($UncompressClass); |
60 | |
61 | |
62 | sub myGZreadFile |
63 | { |
64 | my $filename = shift ; |
65 | my $init = shift ; |
66 | |
67 | |
68 | my $fil = new $UncompressClass $filename, |
69 | -Strict => 1, |
70 | -Append => 1 |
71 | ; |
72 | |
73 | my $data ; |
74 | $data = $init if defined $init ; |
75 | 1 while $fil->read($data) > 0; |
76 | |
77 | $fil->close ; |
78 | return $data ; |
79 | } |
80 | |
81 | # Check zlib_version and ZLIB_VERSION are the same. |
82 | is Compress::Zlib::zlib_version, ZLIB_VERSION, |
83 | "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; |
84 | |
85 | |
86 | |
87 | foreach my $CompressClass ('IO::Compress::Gzip', |
88 | 'IO::Compress::Deflate', |
89 | 'IO::Compress::RawDeflate', |
90 | ) |
91 | { |
92 | $UncompressClass = getInverse($CompressClass); |
93 | |
94 | title "Testing $CompressClass and $UncompressClass"; |
95 | |
96 | |
97 | |
98 | { |
99 | # Write |
100 | # these tests come almost 100% from IO::String |
101 | |
102 | my $name = "test.gz" ; |
103 | my $lex = new LexFile $name ; |
104 | |
105 | my $io = $CompressClass->new($name); |
106 | |
107 | is tell($io), 0 ; |
108 | is $io->tell(), 0 ; |
109 | |
110 | my $heisan = "Heisan\n"; |
111 | print $io $heisan ; |
112 | |
113 | ok ! eof($io); |
114 | ok ! $io->eof(); |
115 | |
116 | is tell($io), length($heisan) ; |
117 | is $io->tell(), length($heisan) ; |
118 | |
119 | $io->print("a", "b", "c"); |
120 | |
121 | { |
122 | local($\) = "\n"; |
123 | print $io "d", "e"; |
124 | local($,) = ","; |
125 | print $io "f", "g", "h"; |
126 | } |
127 | |
128 | my $foo = "1234567890"; |
129 | |
130 | ok syswrite($io, $foo, length($foo)) == length($foo) ; |
131 | if ( $[ < 5.6 ) |
132 | { is $io->syswrite($foo, length $foo), length $foo } |
133 | else |
134 | { is $io->syswrite($foo), length $foo } |
135 | ok $io->syswrite($foo, length($foo)) == length $foo; |
136 | ok $io->write($foo, length($foo), 5) == 5; |
137 | ok $io->write("xxx\n", 100, -1) == 1; |
138 | |
139 | for (1..3) { |
140 | printf $io "i(%d)", $_; |
141 | $io->printf("[%d]\n", $_); |
142 | } |
143 | select $io; |
144 | print "\n"; |
145 | select STDOUT; |
146 | |
147 | close $io ; |
148 | |
149 | ok eof($io); |
150 | ok $io->eof(); |
151 | |
152 | is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . |
153 | ("1234567890" x 3) . "67890\n" . |
154 | "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; |
155 | |
156 | |
157 | } |
158 | |
159 | { |
160 | # Read |
161 | my $str = <<EOT; |
162 | This is an example |
163 | of a paragraph |
164 | |
165 | |
166 | and a single line. |
167 | |
168 | EOT |
169 | |
170 | my $name = "test.gz" ; |
171 | my $lex = new LexFile $name ; |
172 | |
173 | my $iow = new $CompressClass $name ; |
174 | print $iow $str ; |
175 | close $iow; |
176 | |
177 | my @tmp; |
178 | my $buf; |
179 | { |
180 | my $io = new $UncompressClass $name ; |
181 | |
182 | ok ! $io->eof; |
183 | ok ! eof $io; |
184 | is $io->tell(), 0 ; |
185 | is tell($io), 0 ; |
186 | my @lines = <$io>; |
187 | is @lines, 6 |
188 | or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; |
189 | is $lines[1], "of a paragraph\n" ; |
190 | is join('', @lines), $str ; |
191 | is $., 6; |
192 | #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; |
193 | is $io->tell(), length($str) ; |
194 | is tell($io), length($str) ; |
195 | |
196 | ok $io->eof; |
197 | ok eof $io; |
198 | |
199 | ok ! ( defined($io->getline) || |
200 | (@tmp = $io->getlines) || |
201 | defined(<$io>) || |
202 | defined($io->getc) || |
203 | read($io, $buf, 100) != 0) ; |
204 | } |
205 | |
206 | |
207 | { |
208 | local $/; # slurp mode |
209 | my $io = $UncompressClass->new($name); |
210 | ok ! $io->eof; |
211 | my @lines = $io->getlines; |
212 | ok $io->eof; |
213 | ok @lines == 1 && $lines[0] eq $str; |
214 | |
215 | $io = $UncompressClass->new($name); |
216 | ok ! $io->eof; |
217 | my $line = <$io>; |
218 | ok $line eq $str; |
219 | ok $io->eof; |
220 | } |
221 | |
222 | { |
223 | local $/ = ""; # paragraph mode |
224 | my $io = $UncompressClass->new($name); |
225 | ok ! $io->eof; |
226 | my @lines = <$io>; |
227 | ok $io->eof; |
228 | ok @lines == 2 |
229 | or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; |
230 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
231 | or print "# $lines[0]\n"; |
232 | ok $lines[1] eq "and a single line.\n\n"; |
233 | } |
234 | |
235 | { |
236 | local $/ = "is"; |
237 | my $io = $UncompressClass->new($name); |
238 | my @lines = (); |
239 | my $no = 0; |
240 | my $err = 0; |
241 | ok ! $io->eof; |
242 | while (<$io>) { |
243 | push(@lines, $_); |
244 | $err++ if $. != ++$no; |
245 | } |
246 | |
247 | ok $err == 0 ; |
248 | ok $io->eof; |
249 | |
250 | ok @lines == 3 |
251 | or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; |
252 | ok join("-", @lines) eq |
253 | "This- is- an example\n" . |
254 | "of a paragraph\n\n\n" . |
255 | "and a single line.\n\n"; |
256 | } |
257 | |
258 | |
259 | # Test read |
260 | |
261 | { |
262 | my $io = $UncompressClass->new($name); |
263 | |
264 | ok $io, "opened ok" ; |
265 | |
266 | #eval { read($io, $buf, -1); } ; |
267 | #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; |
268 | |
269 | #eval { read($io, 1) } ; |
270 | #like $@, mkErr("buffer parameter is read-only"); |
271 | |
272 | is read($io, $buf, 0), 0, "Requested 0 bytes" ; |
273 | |
274 | ok read($io, $buf, 3) == 3 ; |
275 | ok $buf eq "Thi"; |
276 | |
277 | ok sysread($io, $buf, 3, 2) == 3 ; |
278 | ok $buf eq "Ths i" |
279 | or print "# [$buf]\n" ;; |
280 | ok ! $io->eof; |
281 | |
282 | # $io->seek(-4, 2); |
283 | # |
284 | # ok ! $io->eof; |
285 | # |
286 | # ok read($io, $buf, 20) == 4 ; |
287 | # ok $buf eq "e.\n\n"; |
288 | # |
289 | # ok read($io, $buf, 20) == 0 ; |
290 | # ok $buf eq ""; |
291 | # |
292 | # ok ! $io->eof; |
293 | } |
294 | |
295 | } |
296 | |
297 | |
298 | |
299 | { |
300 | title "seek tests" ; |
301 | |
302 | my $name = "test.gz" ; |
303 | my $lex = new LexFile $name ; |
304 | |
305 | my $first = "beginning" ; |
306 | my $last = "the end" ; |
307 | my $iow = new $CompressClass $name ; |
308 | print $iow $first ; |
309 | ok seek $iow, 10, SEEK_CUR ; |
310 | is tell($iow), length($first)+10; |
311 | ok $iow->seek(0, SEEK_CUR) ; |
312 | is tell($iow), length($first)+10; |
313 | print $iow $last ; |
314 | close $iow; |
315 | |
316 | my $io = $UncompressClass->new($name); |
317 | ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; |
318 | |
319 | $io = $UncompressClass->new($name); |
320 | ok seek $io, length($first)+10, SEEK_CUR ; |
321 | ok ! $io->eof; |
322 | is tell($io), length($first)+10; |
323 | ok seek $io, 0, SEEK_CUR ; |
324 | is tell($io), length($first)+10; |
325 | my $buff ; |
326 | ok read $io, $buff, 100 ; |
327 | ok $buff eq $last ; |
328 | ok $io->eof; |
329 | } |
330 | |
331 | if (! $BadPerl) |
332 | { |
333 | # seek error cases |
334 | my $b ; |
335 | my $a = new $CompressClass(\$b) ; |
336 | |
337 | ok ! $a->error() ; |
338 | eval { seek($a, -1, 10) ; }; |
339 | like $@, mkErr("^seek: unknown value, 10, for whence parameter"); |
340 | |
341 | eval { seek($a, -1, SEEK_END) ; }; |
342 | like $@, mkErr("^cannot seek backwards"); |
343 | |
344 | print $a "fred"; |
345 | close $a ; |
346 | |
347 | |
348 | my $u = new $UncompressClass(\$b) ; |
349 | |
350 | eval { seek($u, -1, 10) ; }; |
351 | like $@, mkErr("^seek: unknown value, 10, for whence parameter"); |
352 | |
353 | eval { seek($u, -1, SEEK_END) ; }; |
354 | like $@, mkErr("^seek: SEEK_END not allowed"); |
355 | |
356 | eval { seek($u, -1, SEEK_CUR) ; }; |
357 | like $@, mkErr("^cannot seek backwards"); |
358 | } |
359 | |
360 | { |
361 | title 'fileno' ; |
362 | |
363 | my $name = "test.gz" ; |
364 | my $lex = new LexFile $name ; |
365 | |
366 | my $hello = <<EOM ; |
367 | hello world |
368 | this is a test |
369 | EOM |
370 | |
371 | { |
372 | my $fh ; |
373 | ok $fh = new IO::File ">$name" ; |
374 | my $x ; |
375 | ok $x = new $CompressClass $fh ; |
376 | |
377 | ok $x->fileno() == fileno($fh) ; |
378 | ok $x->fileno() == fileno($x) ; |
379 | ok $x->write($hello) ; |
380 | ok $x->close ; |
381 | $fh->close() ; |
382 | } |
383 | |
384 | my $uncomp; |
385 | { |
386 | my $x ; |
387 | ok my $fh1 = new IO::File "<$name" ; |
388 | ok $x = new $UncompressClass $fh1, -Append => 1 ; |
389 | ok $x->fileno() == fileno $fh1 ; |
390 | ok $x->fileno() == fileno $x ; |
391 | |
392 | 1 while $x->read($uncomp) > 0 ; |
393 | |
394 | ok $x->close ; |
395 | } |
396 | |
397 | ok $hello eq $uncomp ; |
398 | } |
399 | } |
400 | |