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 | BEGIN { |
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 | plan tests => 2374 + $extra; |
23 | |
24 | use_ok('Compress::Zlib', 2) ; |
25 | |
26 | use_ok('IO::Compress::Gzip', qw($GzipError)) ; |
27 | use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ; |
28 | |
29 | use_ok('IO::Compress::Deflate', qw($DeflateError)) ; |
30 | use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; |
31 | |
32 | use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ; |
33 | use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ; |
34 | |
35 | } |
36 | |
37 | |
38 | my $hello = <<EOM ; |
39 | hello world |
40 | this is a test |
41 | some more stuff on this line |
42 | ad finally... |
43 | EOM |
44 | |
45 | my $blocksize = 10 ; |
46 | |
47 | |
48 | foreach my $CompressClass ('IO::Compress::Gzip', 'IO::Compress::Deflate') |
49 | { |
50 | my $UncompressClass = getInverse($CompressClass); |
51 | |
52 | |
53 | my $compressed ; |
54 | my $cc ; |
55 | my $gz ; |
56 | if ($CompressClass eq 'IO::Compress::Gzip') { |
57 | ok( my $x = new IO::Compress::Gzip \$compressed, |
58 | -Name => "My name", |
59 | -Comment => "a comment", |
60 | -ExtraField => ['ab' => "extra"], |
61 | -HeaderCRC => 1); |
62 | ok $x->write($hello) ; |
63 | ok $x->close ; |
64 | $cc = $compressed ; |
65 | |
66 | ok($gz = new IO::Uncompress::Gunzip \$cc, |
67 | -Transparent => 0) |
68 | or diag "$GunzipError"; |
69 | my $un; |
70 | ok $gz->read($un) > 0 ; |
71 | ok $gz->close(); |
72 | ok $un eq $hello ; |
73 | } |
74 | else { |
75 | ok( my $x = new $CompressClass(\$compressed)); |
76 | ok $x->write($hello) ; |
77 | ok $x->close ; |
78 | $cc = $compressed ; |
79 | |
80 | ok($gz = new $UncompressClass(\$cc, |
81 | -Transparent => 0)) |
82 | or diag "$GunzipError"; |
83 | my $un; |
84 | ok $gz->read($un) > 0 ; |
85 | ok $gz->close(); |
86 | ok $un eq $hello ; |
87 | } |
88 | |
89 | |
90 | for my $trans ( 0 .. 1) |
91 | { |
92 | title "Testing $CompressClass, Transparent $trans"; |
93 | |
94 | my $info = $gz->getHeaderInfo() ; |
95 | my $header_size = $info->{HeaderLength}; |
96 | my $trailer_size = $info->{TrailerLength}; |
97 | ok 1, "Compressed size is " . length($compressed) ; |
98 | ok 1, "Header size is $header_size" ; |
99 | ok 1, "Trailer size is $trailer_size" ; |
100 | |
101 | title "Fingerprint Truncation"; |
102 | foreach my $i (1) |
103 | { |
104 | my $name = "test.gz" ; |
105 | unlink $name ; |
106 | my $lex = new LexFile $name ; |
107 | |
108 | ok 1, "Length $i" ; |
109 | my $part = substr($compressed, 0, $i); |
110 | writeFile($name, $part); |
111 | |
112 | my $gz = new $UncompressClass $name, |
113 | -BlockSize => $blocksize, |
114 | -Transparent => $trans; |
115 | if ($trans) { |
116 | ok $gz; |
117 | ok ! $gz->error() ; |
118 | my $buff ; |
119 | ok $gz->read($buff) == length($part) ; |
120 | ok $buff eq $part ; |
121 | ok $gz->eof() ; |
122 | $gz->close(); |
123 | } |
124 | else { |
125 | ok !$gz; |
126 | } |
127 | |
128 | } |
129 | |
130 | title "Header Truncation"; |
131 | # |
132 | # Any header corruption past the fingerprint is considered catastrophic |
133 | # so even if Transparent is set, it should still fail |
134 | # |
135 | foreach my $i (2 .. $header_size -1) |
136 | { |
137 | my $name = "test.gz" ; |
138 | unlink $name ; |
139 | my $lex = new LexFile $name ; |
140 | |
141 | ok 1, "Length $i" ; |
142 | my $part = substr($compressed, 0, $i); |
143 | writeFile($name, $part); |
144 | ok ! defined new $UncompressClass $name, |
145 | -BlockSize => $blocksize, |
146 | -Transparent => $trans; |
147 | #ok $gz->eof() ; |
148 | } |
149 | |
150 | title "Compressed Data Truncation"; |
151 | foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size) |
152 | { |
153 | |
154 | my $name = "test.gz" ; |
155 | unlink $name ; |
156 | my $lex = new LexFile $name ; |
157 | |
158 | ok 1, "Length $i" ; |
159 | my $part = substr($compressed, 0, $i); |
160 | writeFile($name, $part); |
161 | ok my $gz = new $UncompressClass $name, |
162 | -BlockSize => $blocksize, |
163 | -Transparent => $trans; |
164 | my $un ; |
165 | my $status = 0 ; |
166 | $status = $gz->read($un) while $status >= 0 ; |
167 | ok $status < 0 ; |
168 | ok $gz->eof() ; |
169 | ok $gz->error() ; |
170 | $gz->close(); |
171 | } |
172 | |
173 | # RawDeflate does not have a trailer |
174 | next if $CompressClass eq 'IO::Compress::RawDeflate' ; |
175 | |
176 | title "Compressed Trailer Truncation"; |
177 | foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 ) |
178 | { |
179 | foreach my $lax (0, 1) |
180 | { |
181 | my $name = "test.gz" ; |
182 | unlink $name ; |
183 | my $lex = new LexFile $name ; |
184 | |
185 | ok 1, "Length $i, Lax $lax" ; |
186 | my $part = substr($compressed, 0, $i); |
187 | writeFile($name, $part); |
188 | ok my $gz = new $UncompressClass $name, |
189 | -BlockSize => $blocksize, |
190 | -Strict => !$lax, |
191 | -Append => 1, |
192 | -Transparent => $trans; |
193 | my $un = ''; |
194 | my $status = 1 ; |
195 | $status = $gz->read($un) while $status > 0 ; |
196 | |
197 | if ($lax) |
198 | { |
199 | is $un, $hello; |
200 | is $status, 0 |
201 | or diag "Status $status Error is " . $gz->error() ; |
202 | ok $gz->eof() |
203 | or diag "Status $status Error is " . $gz->error() ; |
204 | ok ! $gz->error() ; |
205 | } |
206 | else |
207 | { |
208 | ok $status < 0 |
209 | or diag "Status $status Error is " . $gz->error() ; |
210 | ok $gz->eof() |
211 | or diag "Status $status Error is " . $gz->error() ; |
212 | ok $gz->error() ; |
213 | } |
214 | |
215 | $gz->close(); |
216 | } |
217 | } |
218 | } |
219 | } |
220 | |
221 | |
222 | foreach my $CompressClass ( 'IO::Compress::RawDeflate') |
223 | { |
224 | my $UncompressClass = getInverse($CompressClass); |
225 | my $Error = getErrorRef($UncompressClass); |
226 | |
227 | my $compressed ; |
228 | ok( my $x = new IO::Compress::RawDeflate \$compressed); |
229 | ok $x->write($hello) ; |
230 | ok $x->close ; |
231 | |
232 | |
233 | my $cc = $compressed ; |
234 | |
235 | my $gz ; |
236 | ok($gz = new $UncompressClass(\$cc, |
237 | -Transparent => 0)) |
238 | or diag "$$Error\n"; |
239 | my $un; |
240 | ok $gz->read($un) > 0 ; |
241 | ok $gz->close(); |
242 | ok $un eq $hello ; |
243 | |
244 | for my $trans (0 .. 1) |
245 | { |
246 | title "Testing $CompressClass, Transparent = $trans"; |
247 | |
248 | my $info = $gz->getHeaderInfo() ; |
249 | my $header_size = $info->{HeaderLength}; |
250 | my $trailer_size = $info->{TrailerLength}; |
251 | ok 1, "Compressed size is " . length($compressed) ; |
252 | ok 1, "Header size is $header_size" ; |
253 | ok 1, "Trailer size is $trailer_size" ; |
254 | |
255 | |
256 | title "Compressed Data Truncation"; |
257 | foreach my $i (0 .. $blocksize) |
258 | { |
259 | |
260 | my $name = "test.gz" ; |
261 | unlink $name ; |
262 | my $lex = new LexFile $name ; |
263 | |
264 | ok 1, "Length $i" ; |
265 | my $part = substr($compressed, 0, $i); |
266 | writeFile($name, $part); |
267 | my $gz = new $UncompressClass $name, |
268 | -BlockSize => $blocksize, |
269 | -Transparent => $trans; |
270 | if ($trans) { |
271 | ok $gz; |
272 | ok ! $gz->error() ; |
273 | my $buff = ''; |
274 | ok $gz->read($buff) == length $part ; |
275 | ok $buff eq $part ; |
276 | ok $gz->eof() ; |
277 | $gz->close(); |
278 | } |
279 | else { |
280 | ok !$gz; |
281 | } |
282 | } |
283 | |
284 | foreach my $i ($blocksize+1 .. length($compressed)-1) |
285 | { |
286 | |
287 | my $name = "test.gz" ; |
288 | unlink $name ; |
289 | my $lex = new LexFile $name ; |
290 | |
291 | ok 1, "Length $i" ; |
292 | my $part = substr($compressed, 0, $i); |
293 | writeFile($name, $part); |
294 | ok my $gz = new $UncompressClass $name, |
295 | -BlockSize => $blocksize, |
296 | -Transparent => $trans; |
297 | my $un ; |
298 | my $status = 0 ; |
299 | $status = $gz->read($un) while $status >= 0 ; |
300 | ok $status < 0 ; |
301 | ok $gz->eof() ; |
302 | ok $gz->error() ; |
303 | $gz->close(); |
304 | } |
305 | } |
306 | |
307 | } |
308 | |