1
2use lib 't';
3use strict;
4use warnings;
5use bytes;
6
7use Test::More ;
8use CompTestUtils;
9
10our ($BadPerl, $UncompressClass);
11
12BEGIN
13{
14    plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" )
15        if $] < 5.005 ;
16
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    my $tests ;
23    $BadPerl = ($] >= 5.006 and $] <= 5.008) ;
24
25    if ($BadPerl) {
26        $tests = 241 ;
27    }
28    else {
29        $tests = 249 ;
30    }
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
60sub run
61{
62
63    my $CompressClass   = identify();
64    $UncompressClass = getInverse($CompressClass);
65    my $Error           = getErrorRef($CompressClass);
66    my $UnError         = getErrorRef($UncompressClass);
67
68    {
69        next if $BadPerl ;
70
71
72        title "Testing $CompressClass";
73
74
75        my $x ;
76        my $gz = new $CompressClass(\$x);
77
78        my $buff ;
79
80        eval { getc($gz) } ;
81        like $@, mkErr("^getc Not Available: File opened only for output");
82
83        eval { read($gz, $buff, 1) } ;
84        like $@, mkErr("^read Not Available: File opened only for output");
85
86        eval { <$gz>  } ;
87        like $@, mkErr("^readline Not Available: File opened only for output");
88
89    }
90
91    {
92        next if $BadPerl;
93        $UncompressClass = getInverse($CompressClass);
94
95        title "Testing $UncompressClass";
96
97        my $gc ;
98        my $guz = new $CompressClass(\$gc);
99        $guz->write("abc") ;
100        $guz->close();
101
102        my $x ;
103        my $gz = new $UncompressClass(\$gc);
104
105        my $buff ;
106
107        eval { print $gz "abc" } ;
108        like $@, mkErr("^print Not Available: File opened only for intput");
109
110        eval { printf $gz "fmt", "abc" } ;
111        like $@, mkErr("^printf Not Available: File opened only for intput");
112
113        #eval { write($gz, $buff, 1) } ;
114        #like $@, mkErr("^write Not Available: File opened only for intput");
115
116    }
117
118    {
119        $UncompressClass = getInverse($CompressClass);
120
121        title "Testing $CompressClass and $UncompressClass";
122
123
124        {
125            # Write
126            # these tests come almost 100% from IO::String
127
128            my $lex = new LexFile my $name ;
129
130            my $io = $CompressClass->new($name);
131
132            is $io->tell(), 0 ;
133
134            my $heisan = "Heisan\n";
135            print $io $heisan ;
136
137            ok ! $io->eof;
138
139            is $io->tell(), length($heisan) ;
140
141            print($io "a", "b", "c");
142
143            {
144                local($\) = "\n";
145                print $io "d", "e";
146                local($,) = ",";
147                print $io "f", "g", "h";
148            }
149
150            my $foo = "1234567890";
151
152            ok syswrite($io, $foo, length($foo)) == length($foo) ;
153            if ( $] < 5.6 )
154              { is $io->syswrite($foo, length $foo), length $foo }
155            else
156              { is $io->syswrite($foo), length $foo }
157            ok $io->syswrite($foo, length($foo)) == length $foo;
158            ok $io->write($foo, length($foo), 5) == 5;
159            ok $io->write("xxx\n", 100, -1) == 1;
160
161            for (1..3) {
162                printf $io "i(%d)", $_;
163                $io->printf("[%d]\n", $_);
164            }
165            select $io;
166            print "\n";
167            select STDOUT;
168
169            close $io ;
170
171            ok $io->eof;
172
173            is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
174                                    ("1234567890" x 3) . "67890\n" .
175                                        "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
176
177
178        }
179
180        {
181            # Read
182            my $str = <<EOT;
183This is an example
184of a paragraph
185
186
187and a single line.
188
189EOT
190
191            my $lex = new LexFile my $name ;
192
193            my $iow = new $CompressClass $name ;
194            print $iow $str ;
195            close $iow;
196
197            my @tmp;
198            my $buf;
199            {
200                my $io = new $UncompressClass $name ;
201
202                ok ! $io->eof, "  Not EOF";
203                is $io->tell(), 0, "  Tell is 0" ;
204                my @lines = <$io>;
205                is @lines, 6, "  Line is 6"
206                    or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
207                is $lines[1], "of a paragraph\n" ;
208                is join('', @lines), $str ;
209                is $., 6;
210                is $io->tell(), length($str) ;
211
212                ok $io->eof;
213
214                ok ! ( defined($io->getline)  ||
215                          (@tmp = $io->getlines) ||
216                          defined(<$io>)         ||
217                          defined($io->getc)     ||
218                          read($io, $buf, 100)   != 0) ;
219            }
220
221
222            {
223                local $/;  # slurp mode
224                my $io = $UncompressClass->new($name);
225                ok !$io->eof;
226                my @lines = $io->getlines;
227                ok $io->eof;
228                ok @lines == 1 && $lines[0] eq $str;
229
230                $io = $UncompressClass->new($name);
231                ok ! $io->eof;
232                my $line = <$io>;
233                ok $line eq $str;
234                ok $io->eof;
235            }
236
237            {
238                local $/ = "";  # paragraph mode
239                my $io = $UncompressClass->new($name);
240                ok ! $io->eof;
241                my @lines = <$io>;
242                ok $io->eof;
243                ok @lines == 2
244                    or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
245                ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
246                    or print "# $lines[0]\n";
247                ok $lines[1] eq "and a single line.\n\n";
248            }
249
250            {
251                local $/ = "is";
252                my $io = $UncompressClass->new($name);
253                my @lines = ();
254                my $no = 0;
255                my $err = 0;
256                ok ! $io->eof;
257                while (<$io>) {
258                    push(@lines, $_);
259                    $err++ if $. != ++$no;
260                }
261
262                ok $err == 0 ;
263                ok $io->eof;
264
265                ok @lines == 3
266                    or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
267                ok join("-", @lines) eq
268                                 "This- is- an example\n" .
269                                "of a paragraph\n\n\n" .
270                                "and a single line.\n\n";
271            }
272
273
274            # Test read
275
276            {
277                my $io = $UncompressClass->new($name);
278
279
280                if (! $BadPerl) {
281                    eval { read($io, $buf, -1) } ;
282                    like $@, mkErr("length parameter is negative");
283                }
284
285                is read($io, $buf, 0), 0, "Requested 0 bytes" ;
286
287                ok read($io, $buf, 3) == 3 ;
288                ok $buf eq "Thi";
289
290                ok sysread($io, $buf, 3, 2) == 3 ;
291                ok $buf eq "Ths i"
292                    or print "# [$buf]\n" ;;
293                ok ! $io->eof;
294
295        #        $io->seek(-4, 2);
296        #
297        #        ok ! $io->eof;
298        #
299        #        ok read($io, $buf, 20) == 4 ;
300        #        ok $buf eq "e.\n\n";
301        #
302        #        ok read($io, $buf, 20) == 0 ;
303        #        ok $buf eq "";
304        #
305        #        ok ! $io->eof;
306            }
307
308        }
309
310        {
311            # Read from non-compressed file
312
313            my $str = <<EOT;
314This is an example
315of a paragraph
316
317
318and a single line.
319
320EOT
321
322            my $lex = new LexFile my $name ;
323
324            writeFile($name, $str);
325            my @tmp;
326            my $buf;
327            {
328                my $io = new $UncompressClass $name, -Transparent => 1 ;
329
330                ok defined $io;
331                ok ! $io->eof;
332                ok $io->tell() == 0 ;
333                my @lines = <$io>;
334                ok @lines == 6;
335                ok $lines[1] eq "of a paragraph\n" ;
336                ok join('', @lines) eq $str ;
337                ok $. == 6;
338                ok $io->tell() == length($str) ;
339
340                ok $io->eof;
341
342                ok ! ( defined($io->getline)  ||
343                          (@tmp = $io->getlines) ||
344                          defined(<$io>)         ||
345                          defined($io->getc)     ||
346                          read($io, $buf, 100)   != 0) ;
347            }
348
349
350            {
351                local $/;  # slurp mode
352                my $io = $UncompressClass->new($name);
353                ok ! $io->eof;
354                my @lines = $io->getlines;
355                ok $io->eof;
356                ok @lines == 1 && $lines[0] eq $str;
357
358                $io = $UncompressClass->new($name);
359                ok ! $io->eof;
360                my $line = <$io>;
361                ok $line eq $str;
362                ok $io->eof;
363            }
364
365            {
366                local $/ = "";  # paragraph mode
367                my $io = $UncompressClass->new($name);
368                ok ! $io->eof;
369                my @lines = <$io>;
370                ok $io->eof;
371                ok @lines == 2
372                    or print "# exected 2 lines, got " . scalar(@lines) . "\n";
373                ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
374                    or print "# [$lines[0]]\n" ;
375                ok $lines[1] eq "and a single line.\n\n";
376            }
377
378            {
379                local $/ = "is";
380                my $io = $UncompressClass->new($name);
381                my @lines = ();
382                my $no = 0;
383                my $err = 0;
384                ok ! $io->eof;
385                while (<$io>) {
386                    push(@lines, $_);
387                    $err++ if $. != ++$no;
388                }
389
390                ok $err == 0 ;
391                ok $io->eof;
392
393                ok @lines == 3 ;
394                ok join("-", @lines) eq
395                                 "This- is- an example\n" .
396                                "of a paragraph\n\n\n" .
397                                "and a single line.\n\n";
398            }
399
400
401            # Test read
402
403            {
404                my $io = $UncompressClass->new($name);
405
406                ok read($io, $buf, 3) == 3 ;
407                ok $buf eq "Thi";
408
409                ok sysread($io, $buf, 3, 2) == 3 ;
410                ok $buf eq "Ths i";
411                ok ! $io->eof;
412
413        #        $io->seek(-4, 2);
414        #
415        #        ok ! $io->eof;
416        #
417        #        ok read($io, $buf, 20) == 4 ;
418        #        ok $buf eq "e.\n\n";
419        #
420        #        ok read($io, $buf, 20) == 0 ;
421        #        ok $buf eq "";
422        #
423        #        ok ! $io->eof;
424            }
425
426
427        }
428
429        {
430            # Vary the length parameter in a read
431
432            my $str = <<EOT;
433x
434x
435This is an example
436of a paragraph
437
438
439and a single line.
440
441EOT
442            $str = $str x 100 ;
443
444
445            foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
446            {
447                foreach my $trans (0, 1)
448                {
449                    foreach my $append (0, 1)
450                    {
451                        title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
452
453                        my $lex = new LexFile my $name ;
454
455                        if ($trans) {
456                            writeFile($name, $str) ;
457                        }
458                        else {
459                            my $iow = new $CompressClass $name ;
460                            print $iow $str ;
461                            close $iow;
462                        }
463
464
465                        my $io = $UncompressClass->new($name,
466                                                       -Append => $append,
467                                                       -Transparent  => $trans);
468
469                        my $buf;
470
471                        is $io->tell(), 0;
472
473                        if ($append) {
474                            1 while $io->read($buf, $bufsize) > 0;
475                        }
476                        else {
477                            my $tmp ;
478                            $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
479                        }
480                        is length $buf, length $str;
481                        ok $buf eq $str ;
482                        ok ! $io->error() ;
483                        ok $io->eof;
484                    }
485                }
486            }
487        }
488
489    }
490}
491
4921;
493