1use lib 't';
2use strict;
3use warnings;
4use bytes;
5
6use Test::More ;
7use CompTestUtils;
8
9our ($BadPerl, $UncompressClass);
10
11BEGIN
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
37use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
38
39
40
41sub 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
61sub 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;
137This is an example
138of a paragraph
139
140
141and a single line.
142
143EOT
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 ;
339hello world
340this is a test
341EOM
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
3741;
375