ext/Compress/Zlib/t/20tied.t

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