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 => "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 | |
9f2e3514 |
102 | my $lex = new LexFile my $name ; |
642e522c |
103 | |
104 | my $io = $CompressClass->new($name); |
105 | |
106 | is tell($io), 0 ; |
107 | is $io->tell(), 0 ; |
108 | |
109 | my $heisan = "Heisan\n"; |
110 | print $io $heisan ; |
111 | |
112 | ok ! eof($io); |
113 | ok ! $io->eof(); |
114 | |
115 | is tell($io), length($heisan) ; |
116 | is $io->tell(), length($heisan) ; |
117 | |
118 | $io->print("a", "b", "c"); |
119 | |
120 | { |
121 | local($\) = "\n"; |
122 | print $io "d", "e"; |
123 | local($,) = ","; |
124 | print $io "f", "g", "h"; |
125 | } |
126 | |
127 | my $foo = "1234567890"; |
128 | |
129 | ok syswrite($io, $foo, length($foo)) == length($foo) ; |
130 | if ( $[ < 5.6 ) |
131 | { is $io->syswrite($foo, length $foo), length $foo } |
132 | else |
133 | { is $io->syswrite($foo), length $foo } |
134 | ok $io->syswrite($foo, length($foo)) == length $foo; |
135 | ok $io->write($foo, length($foo), 5) == 5; |
136 | ok $io->write("xxx\n", 100, -1) == 1; |
137 | |
138 | for (1..3) { |
139 | printf $io "i(%d)", $_; |
140 | $io->printf("[%d]\n", $_); |
141 | } |
142 | select $io; |
143 | print "\n"; |
144 | select STDOUT; |
145 | |
146 | close $io ; |
147 | |
148 | ok eof($io); |
149 | ok $io->eof(); |
150 | |
151 | is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . |
152 | ("1234567890" x 3) . "67890\n" . |
153 | "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; |
154 | |
155 | |
156 | } |
157 | |
158 | { |
159 | # Read |
160 | my $str = <<EOT; |
161 | This is an example |
162 | of a paragraph |
163 | |
164 | |
165 | and a single line. |
166 | |
167 | EOT |
168 | |
9f2e3514 |
169 | my $lex = new LexFile my $name ; |
642e522c |
170 | |
171 | my $iow = new $CompressClass $name ; |
172 | print $iow $str ; |
173 | close $iow; |
174 | |
175 | my @tmp; |
176 | my $buf; |
177 | { |
178 | my $io = new $UncompressClass $name ; |
179 | |
180 | ok ! $io->eof; |
181 | ok ! eof $io; |
182 | is $io->tell(), 0 ; |
183 | is tell($io), 0 ; |
184 | my @lines = <$io>; |
185 | is @lines, 6 |
186 | or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; |
187 | is $lines[1], "of a paragraph\n" ; |
188 | is join('', @lines), $str ; |
189 | is $., 6; |
190 | #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; |
191 | is $io->tell(), length($str) ; |
192 | is tell($io), length($str) ; |
193 | |
194 | ok $io->eof; |
195 | ok eof $io; |
196 | |
197 | ok ! ( defined($io->getline) || |
198 | (@tmp = $io->getlines) || |
199 | defined(<$io>) || |
200 | defined($io->getc) || |
201 | read($io, $buf, 100) != 0) ; |
202 | } |
203 | |
204 | |
205 | { |
206 | local $/; # slurp mode |
207 | my $io = $UncompressClass->new($name); |
208 | ok ! $io->eof; |
209 | my @lines = $io->getlines; |
210 | ok $io->eof; |
211 | ok @lines == 1 && $lines[0] eq $str; |
212 | |
213 | $io = $UncompressClass->new($name); |
214 | ok ! $io->eof; |
215 | my $line = <$io>; |
216 | ok $line eq $str; |
217 | ok $io->eof; |
218 | } |
219 | |
220 | { |
221 | local $/ = ""; # paragraph mode |
222 | my $io = $UncompressClass->new($name); |
223 | ok ! $io->eof; |
224 | my @lines = <$io>; |
225 | ok $io->eof; |
226 | ok @lines == 2 |
227 | or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; |
228 | ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" |
229 | or print "# $lines[0]\n"; |
230 | ok $lines[1] eq "and a single line.\n\n"; |
231 | } |
232 | |
233 | { |
234 | local $/ = "is"; |
235 | my $io = $UncompressClass->new($name); |
236 | my @lines = (); |
237 | my $no = 0; |
238 | my $err = 0; |
239 | ok ! $io->eof; |
240 | while (<$io>) { |
241 | push(@lines, $_); |
242 | $err++ if $. != ++$no; |
243 | } |
244 | |
245 | ok $err == 0 ; |
246 | ok $io->eof; |
247 | |
248 | ok @lines == 3 |
249 | or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; |
250 | ok join("-", @lines) eq |
251 | "This- is- an example\n" . |
252 | "of a paragraph\n\n\n" . |
253 | "and a single line.\n\n"; |
254 | } |
255 | |
256 | |
257 | # Test read |
258 | |
259 | { |
260 | my $io = $UncompressClass->new($name); |
261 | |
262 | ok $io, "opened ok" ; |
263 | |
264 | #eval { read($io, $buf, -1); } ; |
265 | #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; |
266 | |
267 | #eval { read($io, 1) } ; |
268 | #like $@, mkErr("buffer parameter is read-only"); |
269 | |
270 | is read($io, $buf, 0), 0, "Requested 0 bytes" ; |
271 | |
272 | ok read($io, $buf, 3) == 3 ; |
273 | ok $buf eq "Thi"; |
274 | |
275 | ok sysread($io, $buf, 3, 2) == 3 ; |
276 | ok $buf eq "Ths i" |
277 | or print "# [$buf]\n" ;; |
278 | ok ! $io->eof; |
279 | |
280 | # $io->seek(-4, 2); |
281 | # |
282 | # ok ! $io->eof; |
283 | # |
284 | # ok read($io, $buf, 20) == 4 ; |
285 | # ok $buf eq "e.\n\n"; |
286 | # |
287 | # ok read($io, $buf, 20) == 0 ; |
288 | # ok $buf eq ""; |
289 | # |
290 | # ok ! $io->eof; |
291 | } |
292 | |
293 | } |
294 | |
295 | |
296 | |
297 | { |
298 | title "seek tests" ; |
299 | |
9f2e3514 |
300 | my $lex = new LexFile my $name ; |
642e522c |
301 | |
302 | my $first = "beginning" ; |
303 | my $last = "the end" ; |
304 | my $iow = new $CompressClass $name ; |
305 | print $iow $first ; |
306 | ok seek $iow, 10, SEEK_CUR ; |
307 | is tell($iow), length($first)+10; |
308 | ok $iow->seek(0, SEEK_CUR) ; |
309 | is tell($iow), length($first)+10; |
310 | print $iow $last ; |
311 | close $iow; |
312 | |
313 | my $io = $UncompressClass->new($name); |
314 | ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; |
315 | |
316 | $io = $UncompressClass->new($name); |
317 | ok seek $io, length($first)+10, SEEK_CUR ; |
318 | ok ! $io->eof; |
319 | is tell($io), length($first)+10; |
320 | ok seek $io, 0, SEEK_CUR ; |
321 | is tell($io), length($first)+10; |
322 | my $buff ; |
323 | ok read $io, $buff, 100 ; |
324 | ok $buff eq $last ; |
325 | ok $io->eof; |
326 | } |
327 | |
328 | if (! $BadPerl) |
329 | { |
330 | # seek error cases |
331 | my $b ; |
332 | my $a = new $CompressClass(\$b) ; |
333 | |
334 | ok ! $a->error() ; |
335 | eval { seek($a, -1, 10) ; }; |
336 | like $@, mkErr("^seek: unknown value, 10, for whence parameter"); |
337 | |
338 | eval { seek($a, -1, SEEK_END) ; }; |
339 | like $@, mkErr("^cannot seek backwards"); |
340 | |
341 | print $a "fred"; |
342 | close $a ; |
343 | |
344 | |
345 | my $u = new $UncompressClass(\$b) ; |
346 | |
347 | eval { seek($u, -1, 10) ; }; |
348 | like $@, mkErr("^seek: unknown value, 10, for whence parameter"); |
349 | |
350 | eval { seek($u, -1, SEEK_END) ; }; |
351 | like $@, mkErr("^seek: SEEK_END not allowed"); |
352 | |
353 | eval { seek($u, -1, SEEK_CUR) ; }; |
354 | like $@, mkErr("^cannot seek backwards"); |
355 | } |
356 | |
357 | { |
358 | title 'fileno' ; |
359 | |
9f2e3514 |
360 | my $lex = new LexFile my $name ; |
642e522c |
361 | |
362 | my $hello = <<EOM ; |
363 | hello world |
364 | this is a test |
365 | EOM |
366 | |
367 | { |
368 | my $fh ; |
369 | ok $fh = new IO::File ">$name" ; |
370 | my $x ; |
371 | ok $x = new $CompressClass $fh ; |
372 | |
373 | ok $x->fileno() == fileno($fh) ; |
374 | ok $x->fileno() == fileno($x) ; |
375 | ok $x->write($hello) ; |
376 | ok $x->close ; |
377 | $fh->close() ; |
378 | } |
379 | |
380 | my $uncomp; |
381 | { |
382 | my $x ; |
383 | ok my $fh1 = new IO::File "<$name" ; |
384 | ok $x = new $UncompressClass $fh1, -Append => 1 ; |
385 | ok $x->fileno() == fileno $fh1 ; |
386 | ok $x->fileno() == fileno $x ; |
387 | |
388 | 1 while $x->read($uncomp) > 0 ; |
389 | |
390 | ok $x->close ; |
391 | } |
392 | |
393 | ok $hello eq $uncomp ; |
394 | } |
395 | } |
396 | |