1BEGIN {
2    if ($ENV{PERL_CORE}) {
3	chdir 't' if -d 't';
4	@INC = ("../lib", "lib/compress");
5    }
6}
7
8use lib qw(t t/compress);
9use strict;
10use warnings;
11use bytes;
12
13use Test::More ;
14use CompTestUtils;
15
16BEGIN {
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 => 595 + $extra ;
23
24    use_ok('Compress::Raw::Zlib') ;
25
26    use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
27    use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
28
29    use_ok('IO::Compress::Zlib::Constants');
30
31}
32
33
34sub ReadHeaderInfo
35{
36    my $string = shift || '' ;
37    my %opts = @_ ;
38
39    my $buffer ;
40    ok my $def = new IO::Compress::Deflate \$buffer, %opts ;
41    is $def->write($string), length($string) ;
42    ok $def->close ;
43    #print "ReadHeaderInfo\n"; hexDump(\$buffer);
44
45    ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1  ;
46    my $uncomp ;
47    #ok $inf->read($uncomp) ;
48    my $actual = 0 ;
49    my $status = 1 ;
50    while (($status = $inf->read($uncomp)) > 0) {
51        $actual += $status ;
52    }
53
54    is $actual, length($string) ;
55    is $uncomp, $string;
56    ok ! $inf->error() ;
57    ok $inf->eof() ;
58    ok my $hdr = $inf->getHeaderInfo();
59    ok $inf->close ;
60
61    return $hdr ;
62}
63
64sub ReadHeaderInfoZlib
65{
66    my $string = shift || '' ;
67    my %opts = @_ ;
68
69    my $buffer ;
70    ok my $def = new Compress::Raw::Zlib::Deflate AppendOutput => 1, %opts ;
71    cmp_ok $def->deflate($string, $buffer), '==',  Z_OK;
72    cmp_ok $def->flush($buffer), '==', Z_OK;
73    #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer);
74
75    ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1  ;
76    my $uncomp ;
77    #ok $inf->read($uncomp) ;
78    my $actual = 0 ;
79    my $status = 1 ;
80    while (($status = $inf->read($uncomp)) > 0) {
81        $actual += $status ;
82    }
83
84    is $actual, length($string) ;
85    is $uncomp, $string;
86    ok ! $inf->error() ;
87    ok $inf->eof() ;
88    ok my $hdr = $inf->getHeaderInfo();
89    ok $inf->close ;
90
91    return $hdr ;
92}
93
94sub printHeaderInfo
95{
96    my $buffer = shift ;
97    my $inf = new IO::Uncompress::Inflate \$buffer  ;
98    my $hdr = $inf->getHeaderInfo();
99
100    no warnings 'uninitialized' ;
101    while (my ($k, $v) = each %$hdr) {
102        print "  $k -> $v\n" ;
103    }
104}
105
106
107# Check the Deflate Header Parameters
108#========================================
109
110my $lex = new LexFile my $name ;
111
112{
113    title "Check default header settings" ;
114
115    my $string = <<EOM;
116some text
117EOM
118
119    my $hdr = ReadHeaderInfo($string);
120
121    is $hdr->{CM}, 8, "  CM is 8";
122    is $hdr->{FDICT}, 0, "  FDICT is 0";
123
124}
125
126{
127    title "Check user-defined header settings match zlib" ;
128
129    my $string = <<EOM;
130some text
131EOM
132
133    my @tests = (
134        [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
135        [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
136        [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
137        [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
138        [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
139        [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
140        [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ],
141        [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
142        [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
143        [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
144
145        [ {-Level => Z_NO_COMPRESSION  }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
146        [ {-Level => Z_BEST_SPEED      }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
147        [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
148        [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ],
149
150        [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
151        [ {-Strategy => Z_HUFFMAN_ONLY,
152           -Level    => 3             }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
153    );
154
155    foreach my $test (@tests)
156    {
157        my $opts = $test->[0] ;
158        my $expect = $test->[1] ;
159
160        my @title ;
161        while (my ($k, $v) = each %$opts)
162        {
163            push @title, "$k => $v";
164        }
165        title " Set @title";
166
167        my $hdr = ReadHeaderInfo($string, %$opts);
168
169        my $hdr1 = ReadHeaderInfoZlib($string, %$opts);
170
171        is $hdr->{CM},     8, "  CM is 8";
172        is $hdr->{CINFO},  7, "  CINFO is 7";
173        is $hdr->{FDICT},  0, "  FDICT is 0";
174
175        while (my ($k, $v) = each %$expect)
176        {
177            if (ZLIB_VERNUM >= 0x1220)
178              { is $hdr->{$k}, $v, "  $k is $v" }
179            else
180              { ok 1, "  Skip test for $k" }
181        }
182
183        is $hdr->{CM},     $hdr1->{CM},     "  CM matches";
184        is $hdr->{CINFO},  $hdr1->{CINFO},  "  CINFO matches";
185        is $hdr->{FDICT},  $hdr1->{FDICT},  "  FDICT matches";
186        is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, "  FLEVEL matches";
187        is $hdr->{FCHECK}, $hdr1->{FCHECK}, "  FCHECK matches";
188    }
189
190
191}
192
193{
194    title "No compressed data at all";
195
196    my $hdr = ReadHeaderInfo("");
197
198    is $hdr->{CM}, 8, "  CM is 8";
199    is $hdr->{FDICT}, 0, "  FDICT is 0";
200
201    ok defined $hdr->{ADLER32}, "  ADLER32 is defined" ;
202    is $hdr->{ADLER32}, 1, "  ADLER32 is 1";
203}
204
205{
206    # Header Corruption Tests
207
208    my $string = <<EOM;
209some text
210EOM
211
212    my $good ;
213    ok my $x = new IO::Compress::Deflate \$good ;
214    ok $x->write($string) ;
215    ok $x->close ;
216
217    {
218        title "Header Corruption - FCHECK failure - 1st byte wrong";
219        my $buffer = $good ;
220        substr($buffer, 0, 1) = "\x00" ;
221
222        ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
223        like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/',
224            "CRC mismatch";
225    }
226
227    {
228        title "Header Corruption - FCHECK failure - 2nd byte wrong";
229        my $buffer = $good ;
230        substr($buffer, 1, 1) = "\x00" ;
231
232        ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
233        like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/',
234            "CRC mismatch";
235    }
236
237
238    sub mkZlibHdr
239    {
240        my $method = shift ;
241        my $cinfo  = shift ;
242        my $fdict  = shift ;
243        my $level  = shift ;
244
245        my $cmf  = ($method & 0x0F) ;
246           $cmf |= (($cinfo  & 0x0F) << 4) ;
247        my $flg  = (($level & 0x03) << 6) ;
248           $flg |= (($fdict & 0x01) << 5) ;
249        my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
250        $flg |= $fcheck ;
251        #print "check $fcheck\n";
252
253        return pack("CC", $cmf, $flg) ;
254    }
255
256    {
257        title "Header Corruption - CM not 8";
258        my $buffer = $good ;
259        my $header = mkZlibHdr(3, 6, 0, 3);
260
261        substr($buffer, 0, 2) = $header;
262
263        my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
264        ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
265        like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/',
266            "  Not Deflate";
267    }
268
269}
270
271{
272    # Trailer Corruption tests
273
274    my $string = <<EOM;
275some text
276EOM
277
278    my $good ;
279    ok my $x = new IO::Compress::Deflate \$good ;
280    ok $x->write($string) ;
281    ok $x->close ;
282
283    foreach my $trim (-4 .. -1)
284    {
285        my $got = $trim + 4 ;
286        foreach my $s (0, 1)
287        {
288            title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ;
289            my $buffer = $good ;
290            my $expected_trailing = substr($good, -4, 4) ;
291            substr($expected_trailing, $trim) = '';
292
293            substr($buffer, $trim) = '';
294            writeFile($name, $buffer) ;
295
296            ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s;
297            my $uncomp ;
298            if ($s)
299            {
300                ok $gunz->read($uncomp) < 0 ;
301                like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/",
302                    "Trailer Error";
303            }
304            else
305            {
306                is $gunz->read($uncomp), length $string ;
307            }
308            ok $gunz->eof() ;
309            ok $uncomp eq $string;
310            ok $gunz->close ;
311        }
312
313    }
314
315    {
316        title "Trailer Corruption - CRC Wrong, strict" ;
317        my $buffer = $good ;
318        my $crc = unpack("N", substr($buffer, -4, 4));
319        substr($buffer, -4, 4) = pack('N', $crc+1);
320        writeFile($name, $buffer) ;
321
322        ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1;
323        my $uncomp ;
324        ok $gunz->read($uncomp) < 0 ;
325        like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/',
326            "Trailer Error: CRC mismatch";
327        ok $gunz->eof() ;
328        ok ! $gunz->trailingData() ;
329        ok $uncomp eq $string;
330        ok $gunz->close ;
331    }
332
333    {
334        title "Trailer Corruption - CRC Wrong, no strict" ;
335        my $buffer = $good ;
336        my $crc = unpack("N", substr($buffer, -4, 4));
337        substr($buffer, -4, 4) = pack('N', $crc+1);
338        writeFile($name, $buffer) ;
339
340        ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0;
341        my $uncomp ;
342        ok $gunz->read($uncomp) >= 0  ;
343        ok $gunz->eof() ;
344        ok ! $gunz->trailingData() ;
345        ok $uncomp eq $string;
346        ok $gunz->close ;
347    }
348}
349
350