1
2use lib 't';
3use strict;
4use warnings;
5use bytes;
6
7use Test::More ;
8use CompTestUtils;
9
10sub run
11{
12    my $CompressClass   = identify();
13    my $UncompressClass = getInverse($CompressClass);
14    my $Error           = getErrorRef($CompressClass);
15    my $UnError         = getErrorRef($UncompressClass);
16
17#    my $hello = <<EOM ;
18#hello world
19#this is a test
20#some more stuff on this line
21#and finally...
22#EOM
23
24    # ASCII hex equivalent of the text above. This makes the test
25    # harness behave identically on an EBCDIC platform.
26    my $hello =
27      "\x68\x65\x6c\x6c\x6f\x20\x77\x6f\x72\x6c\x64\x0a\x74\x68\x69\x73" .
28      "\x20\x69\x73\x20\x61\x20\x74\x65\x73\x74\x0a\x73\x6f\x6d\x65\x20" .
29      "\x6d\x6f\x72\x65\x20\x73\x74\x75\x66\x66\x20\x6f\x6e\x20\x74\x68" .
30      "\x69\x73\x20\x6c\x69\x6e\x65\x0a\x61\x6e\x64\x20\x66\x69\x6e\x61" .
31      "\x6c\x6c\x79\x2e\x2e\x2e\x0a" ;
32
33    my $blocksize = 10 ;
34
35
36    my ($info, $compressed) = mkComplete($CompressClass, $hello);
37
38    my $header_size  = $info->{HeaderLength};
39    my $trailer_size = $info->{TrailerLength};
40    my $fingerprint_size = $info->{FingerprintLength};
41    ok 1, "Compressed size is " . length($compressed) ;
42    ok 1, "Fingerprint size is $fingerprint_size" ;
43    ok 1, "Header size is $header_size" ;
44    ok 1, "Trailer size is $trailer_size" ;
45
46    foreach my $fb ( qw( filehandle buffer ) )
47    {
48        for my $trans ( 0 .. 1)
49        {
50            title "Truncating $CompressClass, Source $fb, Transparent $trans";
51
52
53            foreach my $i (1 .. $fingerprint_size-1)
54            {
55                my $lex = new LexFile my $name ;
56                my $input;
57
58                title "Fingerprint Truncation - length $i, Transparent $trans";
59
60                my $part = substr($compressed, 0, $i);
61                if ($fb eq 'filehandle')
62                {
63                    writeFile($name, $part);
64                    $input = $name ;
65                }
66                else
67                {
68                    $input = \$part;
69                }
70
71                my $gz = new $UncompressClass $input,
72                                              -BlockSize   => $blocksize,
73                                              -Transparent => $trans;
74                if ($trans) {
75                    ok $gz;
76                    ok ! $gz->error() ;
77                    my $buff ;
78                    is $gz->read($buff, 5000), length($part) ;
79                    ok $buff eq $part ;
80                    ok $gz->eof() ;
81                    $gz->close();
82                }
83                else {
84                    ok !$gz;
85                }
86
87            }
88
89            #
90            # Any header corruption past the fingerprint is considered catastrophic
91            # so even if Transparent is set, it should still fail
92            #
93            foreach my $i ($fingerprint_size .. $header_size -1)
94            {
95                my $lex = new LexFile my $name ;
96                my $input;
97
98                title "Header Truncation - length $i, Source $fb, Transparent $trans";
99
100                my $part = substr($compressed, 0, $i);
101                if ($fb eq 'filehandle')
102                {
103                    writeFile($name, $part);
104                    $input = $name ;
105                }
106                else
107                {
108                    $input = \$part;
109                }
110
111                ok ! defined new $UncompressClass $input,
112                                                  -BlockSize   => $blocksize,
113                                                  -Transparent => $trans;
114                #ok $gz->eof() ;
115            }
116
117            # Test curruption directly after the header
118            # In this case the uncompression object will have been created,
119            # so need to check that subsequent reads from the object fail
120            if ($header_size > 0)
121            {
122                for my $mode (qw(block line para record slurp))
123                {
124
125                    title "Corruption after header - Mode $mode, Source $fb, Transparent $trans";
126
127                    my $lex = new LexFile my $name ;
128                    my $input;
129
130                    my $part = substr($compressed, 0, $header_size);
131                    # Append corrupt data
132                    $part .= "\xFF" x 100 ;
133                    if ($fb eq 'filehandle')
134                    {
135                        writeFile($name, $part);
136                        $input = $name ;
137                    }
138                    else
139                    {
140                        $input = \$part;
141                    }
142
143                    ok my $gz = new $UncompressClass $input,
144                                                     -Strict      => 1,
145                                                     -BlockSize   => $blocksize,
146                                                     -Transparent => $trans
147                         or diag $$UnError;
148
149                    my $un ;
150                    my $status = 1;
151                    if ($mode eq 'block')
152                    {
153                        $status = $gz->read($un) ;
154                        is $status, -1, "got -1";
155                    }
156                    else
157                    {
158                        if ($mode eq 'line')
159                        {
160                            $status = <$gz>;
161                        }
162                        elsif ($mode eq 'para')
163                        {
164                            local $/ = "\n\n";
165                            $status = <$gz>;
166                        }
167                        elsif ($mode eq 'record')
168                        {
169                            local $/ = \ 4;
170                            $status = <$gz>;
171                        }
172                        elsif ($mode eq 'slurp')
173                        {
174                            local $/ ;
175                            $status = <$gz>;
176                        }
177
178                        is $status, undef, "got undef";
179                    }
180
181                    ok $gz->error() ;
182                    $gz->close();
183                }
184            }
185
186            # Back to truncation tests
187
188            foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size)
189            {
190                next if $i == 0 ;
191
192                for my $mode (qw(block line))
193                {
194
195                    title "Compressed Data Truncation - length $i, MOde $mode, Source $fb, Transparent $trans";
196
197                    my $lex = new LexFile my $name ;
198                    my $input;
199
200                    my $part = substr($compressed, 0, $i);
201                    if ($fb eq 'filehandle')
202                    {
203                        writeFile($name, $part);
204                        $input = $name ;
205                    }
206                    else
207                    {
208                        $input = \$part;
209                    }
210
211                    ok my $gz = new $UncompressClass $input,
212                                                     -Strict      => 1,
213                                                     -BlockSize   => $blocksize,
214                                                     -Transparent => $trans
215                         or diag $$UnError;
216
217                    my $un ;
218                    if ($mode eq 'block')
219                    {
220                        my $status = 1 ;
221                        $status = $gz->read($un) while $status > 0 ;
222                        cmp_ok $status, "<", 0 ;
223                    }
224                    else
225                    {
226                        1 while <$gz> ;
227                    }
228                    ok $gz->error() ;
229                    cmp_ok $gz->errorNo(), '<', 0 ;
230                    ok $gz->eof() ;
231                    $gz->close();
232                }
233            }
234
235            # RawDeflate does not have a trailer
236            next if $CompressClass eq 'IO::Compress::RawDeflate' ;
237
238            title "Compressed Trailer Truncation";
239            foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 )
240            {
241                foreach my $lax (0, 1)
242                {
243                    my $lex = new LexFile my $name ;
244                    my $input;
245
246                    ok 1, "Compressed Trailer Truncation - Length $i, Lax $lax, Transparent $trans" ;
247                    my $part = substr($compressed, 0, $i);
248                    if ($fb eq 'filehandle')
249                    {
250                        writeFile($name, $part);
251                        $input = $name ;
252                    }
253                    else
254                    {
255                        $input = \$part;
256                    }
257
258                    ok my $gz = new $UncompressClass $input,
259                                                     -BlockSize   => $blocksize,
260                                                     -Strict      => !$lax,
261                                                     -Append      => 1,
262                                                     -Transparent => $trans;
263                    my $un = '';
264                    my $status = 1 ;
265                    $status = $gz->read($un) while $status > 0 ;
266
267                    if ($lax)
268                    {
269                        is $un, $hello;
270                        is $status, 0
271                            or diag "Status $status Error is " . $gz->error() ;
272                        ok $gz->eof()
273                            or diag "Status $status Error is " . $gz->error() ;
274                        ok ! $gz->error() ;
275                    }
276                    else
277                    {
278                        cmp_ok $status, "<", 0
279                            or diag "Status $status Error is " . $gz->error() ;
280                        ok $gz->eof()
281                            or diag "Status $status Error is " . $gz->error() ;
282                        ok $gz->error() ;
283                    }
284
285                    $gz->close();
286                }
287            }
288        }
289    }
290}
291
2921;
293
294