ext/Compress/Zlib/t/21newtied.t

   1 BEGIN {
   2     if ($ENV{PERL_CORE}) {
   3         chdir 't' if -d 't';
   4         @INC = '../lib';
   5     }
   6 }
   7
   8 use lib 't';
   9 use strict;
  10 use warnings;
  11 use bytes;
  12
  13 use Test::More ;
  14 use ZlibTestUtils;
  15
  16 our ($BadPerl);
  17
  18 BEGIN
  19 {
  20     plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" )
  21         if $] < 5.006 ;
  22
  23     my $tests ;
  24
  25     $BadPerl = ($] >= 5.006 or $] <= 5.008) ;
  26
  27     if ($BadPerl) {
  28         $tests = 242 ;
  29     }
  30     else {
  31         $tests = 242 ;
  32     }
  33
  34     # use Test::NoWarnings, if available
  35     my $extra = 0 ;
  36     $extra = 1
  37         if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };
  38
  39     plan tests => $tests + $extra ;
  40
  41     use_ok('Compress::Zlib', 2) ;
  42
  43     use_ok('IO::Compress::Gzip', qw($GzipError)) ;
  44     use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
  45
  46     use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
  47     use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
  48
  49     use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
  50     use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
  51
  52
  53 }
  54
  55
  56 use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
  57
  58
  59 our ($UncompressClass);
  60
  61
  62 sub myGZreadFile
  63 {
  64     my $filename = shift ;
  65     my $init = shift ;
  66
  67
  68     my $fil = new $UncompressClass $filename,
  69                                     -Strict   => 1,
  70                                     -Append   => 1
  71                                     ;
  72
  73     my $data ;
  74     $data = $init if defined $init ;
  75     1 while $fil->read($data) > 0;
  76
  77     $fil->close ;
  78     return $data ;
  79 }
  80
  81 # Check zlib_version and ZLIB_VERSION are the same.
  82 is Compress::Zlib::zlib_version, ZLIB_VERSION,
  83     "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
  84
  85
  86
  87 foreach my $CompressClass ('IO::Compress::Gzip',
  88                            'IO::Compress::Deflate',
  89                            'IO::Compress::RawDeflate',
  90                           )
  91 {
  92     $UncompressClass = getInverse($CompressClass);
  93
  94     title "Testing $CompressClass and $UncompressClass";
  95
  96
  97
  98     {
  99         # Write
 100         # these tests come almost 100% from IO::String
 101
 102         my $name = "test.gz" ;
 103         my $lex = new LexFile $name ;
 104
 105         my $io = $CompressClass->new($name);
 106
 107         is tell($io), 0 ;
 108         is $io->tell(), 0 ;
 109
 110         my $heisan = "Heisan\n";
 111         print $io $heisan ;
 112
 113         ok ! eof($io);
 114         ok ! $io->eof();
 115
 116         is tell($io), length($heisan) ;
 117         is $io->tell(), length($heisan) ;
 118
 119         $io->print("a", "b", "c");
 120
 121         {
 122             local($\) = "\n";
 123             print $io "d", "e";
 124             local($,) = ",";
 125             print $io "f", "g", "h";
 126         }
 127
 128         my $foo = "1234567890";
 129
 130         ok syswrite($io, $foo, length($foo)) == length($foo) ;
 131         if ( $[ < 5.6 )
 132           { is $io->syswrite($foo, length $foo), length $foo }
 133         else
 134           { is $io->syswrite($foo), length $foo }
 135         ok $io->syswrite($foo, length($foo)) == length $foo;
 136         ok $io->write($foo, length($foo), 5) == 5;
 137         ok $io->write("xxx\n", 100, -1) == 1;
 138
 139         for (1..3) {
 140             printf $io "i(%d)", $_;
 141             $io->printf("[%d]\n", $_);
 142         }
 143         select $io;
 144         print "\n";
 145         select STDOUT;
 146
 147         close $io ;
 148
 149         ok eof($io);
 150         ok $io->eof();
 151
 152         is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
 153                                 ("1234567890" x 3) . "67890\n" .
 154                                     "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
 155
 156
 157     }
 158
 159     {
 160         # Read
 161         my $str = <<EOT;
 162 This is an example
 163 of a paragraph
 164
 165
 166 and a single line.
 167
 168 EOT
 169
 170         my $name = "test.gz" ;
 171         my $lex = new LexFile $name ;
 172
 173         my $iow = new $CompressClass $name ;
 174         print $iow $str ;
 175         close $iow;
 176
 177         my @tmp;
 178         my $buf;
 179         {
 180             my $io = new $UncompressClass $name ;
 181
 182             ok ! $io->eof;
 183             ok ! eof $io;
 184             is $io->tell(), 0 ;
 185             is tell($io), 0 ;
 186             my @lines = <$io>;
 187             is @lines, 6
 188                 or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
 189             is $lines[1], "of a paragraph\n" ;
 190             is join('', @lines), $str ;
 191             is $., 6;
 192     #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ;
 193             is $io->tell(), length($str) ;
 194             is tell($io), length($str) ;
 195
 196             ok $io->eof;
 197             ok eof $io;
 198
 199             ok ! ( defined($io->getline)  ||
 200                       (@tmp = $io->getlines) ||
 201                       defined(<$io>)         ||
 202                       defined($io->getc)     ||
 203                       read($io, $buf, 100)   != 0) ;
 204         }
 205
 206
 207         {
 208             local $/;  # slurp mode
 209             my $io = $UncompressClass->new($name);
 210             ok ! $io->eof;
 211             my @lines = $io->getlines;
 212             ok $io->eof;
 213             ok @lines == 1 && $lines[0] eq $str;
 214
 215             $io = $UncompressClass->new($name);
 216             ok ! $io->eof;
 217             my $line = <$io>;
 218             ok $line eq $str;
 219             ok $io->eof;
 220         }
 221
 222         {
 223             local $/ = "";  # paragraph mode
 224             my $io = $UncompressClass->new($name);
 225             ok ! $io->eof;
 226             my @lines = <$io>;
 227             ok $io->eof;
 228             ok @lines == 2
 229                 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
 230             ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 231                 or print "# $lines[0]\n";
 232             ok $lines[1] eq "and a single line.\n\n";
 233         }
 234
 235         {
 236             local $/ = "is";
 237             my $io = $UncompressClass->new($name);
 238             my @lines = ();
 239             my $no = 0;
 240             my $err = 0;
 241             ok ! $io->eof;
 242             while (<$io>) {
 243                 push(@lines, $_);
 244                 $err++ if $. != ++$no;
 245             }
 246
 247             ok $err == 0 ;
 248             ok $io->eof;
 249
 250             ok @lines == 3
 251                 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
 252             ok join("-", @lines) eq
 253                              "This- is- an example\n" .
 254                             "of a paragraph\n\n\n" .
 255                             "and a single line.\n\n";
 256         }
 257
 258
 259         # Test read
 260
 261         {
 262             my $io = $UncompressClass->new($name);
 263
 264             ok $io, "opened ok" ;
 265
 266             #eval { read($io, $buf, -1); } ;
 267             #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ;
 268
 269             #eval { read($io, 1) } ;
 270             #like $@, mkErr("buffer parameter is read-only");
 271
 272             is read($io, $buf, 0), 0, "Requested 0 bytes" ;
 273
 274             ok read($io, $buf, 3) == 3 ;
 275             ok $buf eq "Thi";
 276
 277             ok sysread($io, $buf, 3, 2) == 3 ;
 278             ok $buf eq "Ths i"
 279                 or print "# [$buf]\n" ;;
 280             ok ! $io->eof;
 281
 282     #        $io->seek(-4, 2);
 283     #
 284     #        ok ! $io->eof;
 285     #
 286     #        ok read($io, $buf, 20) == 4 ;
 287     #        ok $buf eq "e.\n\n";
 288     #
 289     #        ok read($io, $buf, 20) == 0 ;
 290     #        ok $buf eq "";
 291     #
 292     #        ok ! $io->eof;
 293         }
 294
 295     }
 296
 297
 298
 299     {
 300         title "seek tests" ;
 301
 302         my $name = "test.gz" ;
 303         my $lex = new LexFile $name ;
 304
 305         my $first = "beginning" ;
 306         my $last  = "the end" ;
 307         my $iow = new $CompressClass $name ;
 308         print $iow $first ;
 309         ok seek $iow, 10, SEEK_CUR ;
 310         is tell($iow), length($first)+10;
 311         ok $iow->seek(0, SEEK_CUR) ;
 312         is tell($iow), length($first)+10;
 313         print $iow $last ;
 314         close $iow;
 315
 316         my $io = $UncompressClass->new($name);
 317         ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ;
 318
 319         $io = $UncompressClass->new($name);
 320         ok seek $io, length($first)+10, SEEK_CUR ;
 321         ok ! $io->eof;
 322         is tell($io), length($first)+10;
 323         ok seek $io, 0, SEEK_CUR ;
 324         is tell($io), length($first)+10;
 325         my $buff ;
 326         ok read $io, $buff, 100 ;
 327         ok $buff eq $last ;
 328         ok $io->eof;
 329     }
 330
 331     if (! $BadPerl)
 332     {
 333         # seek error cases
 334         my $b ;
 335         my $a = new $CompressClass(\$b)  ;
 336
 337         ok ! $a->error() ;
 338         eval { seek($a, -1, 10) ; };
 339         like $@, mkErr("^seek: unknown value, 10, for whence parameter");
 340
 341         eval { seek($a, -1, SEEK_END) ; };
 342         like $@, mkErr("^cannot seek backwards");
 343
 344         print $a "fred";
 345         close $a ;
 346
 347
 348         my $u = new $UncompressClass(\$b)  ;
 349
 350         eval { seek($u, -1, 10) ; };
 351         like $@, mkErr("^seek: unknown value, 10, for whence parameter");
 352
 353         eval { seek($u, -1, SEEK_END) ; };
 354         like $@, mkErr("^seek: SEEK_END not allowed");
 355
 356         eval { seek($u, -1, SEEK_CUR) ; };
 357         like $@, mkErr("^cannot seek backwards");
 358     }
 359
 360     {
 361         title 'fileno' ;
 362
 363         my $name = "test.gz" ;
 364         my $lex = new LexFile $name ;
 365
 366         my $hello = <<EOM ;
 367 hello world
 368 this is a test
 369 EOM
 370
 371         {
 372           my $fh ;
 373           ok $fh = new IO::File ">$name" ;
 374           my $x ;
 375           ok $x = new $CompressClass $fh  ;
 376
 377           ok $x->fileno() == fileno($fh) ;
 378           ok $x->fileno() == fileno($x) ;
 379           ok $x->write($hello) ;
 380           ok $x->close ;
 381           $fh->close() ;
 382         }
 383
 384         my $uncomp;
 385         {
 386           my $x ;
 387           ok my $fh1 = new IO::File "<$name" ;
 388           ok $x = new $UncompressClass $fh1, -Append => 1  ;
 389           ok $x->fileno() == fileno $fh1 ;
 390           ok $x->fileno() == fileno $x ;
 391
 392           1 while $x->read($uncomp) > 0 ;
 393
 394           ok $x->close ;
 395         }
 396
 397         ok $hello eq $uncomp ;
 398     }
 399 }
 400