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