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

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