ext/Compress/Zlib/t/20tied.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 => "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 $name = "test.gz" ;
 156         my $lex = new LexFile $name ;
 157
 158         my $io = $CompressClass->new($name);
 159
 160         is $io->tell(), 0 ;
 161
 162         my $heisan = "Heisan\n";
 163         print $io $heisan ;
 164
 165         ok ! $io->eof;
 166
 167         is $io->tell(), length($heisan) ;
 168
 169         print($io "a", "b", "c");
 170
 171         {
 172             local($\) = "\n";
 173             print $io "d", "e";
 174             local($,) = ",";
 175             print $io "f", "g", "h";
 176         }
 177
 178         my $foo = "1234567890";
 179
 180         ok syswrite($io, $foo, length($foo)) == length($foo) ;
 181         if ( $[ < 5.6 )
 182           { is $io->syswrite($foo, length $foo), length $foo }
 183         else
 184           { is $io->syswrite($foo), length $foo }
 185         ok $io->syswrite($foo, length($foo)) == length $foo;
 186         ok $io->write($foo, length($foo), 5) == 5;
 187         ok $io->write("xxx\n", 100, -1) == 1;
 188
 189         for (1..3) {
 190             printf $io "i(%d)", $_;
 191             $io->printf("[%d]\n", $_);
 192         }
 193         select $io;
 194         print "\n";
 195         select STDOUT;
 196
 197         close $io ;
 198
 199         ok $io->eof;
 200
 201         is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
 202                                 ("1234567890" x 3) . "67890\n" .
 203                                     "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
 204
 205
 206     }
 207
 208     {
 209         # Read
 210         my $str = <<EOT;
 211 This is an example
 212 of a paragraph
 213
 214
 215 and a single line.
 216
 217 EOT
 218
 219         my $name = "test.gz" ;
 220         my $lex = new LexFile $name ;
 221
 222         my $iow = new $CompressClass $name ;
 223         print $iow $str ;
 224         close $iow;
 225
 226         my @tmp;
 227         my $buf;
 228         {
 229             my $io = new $UncompressClass $name ;
 230
 231             ok ! $io->eof;
 232             is $io->tell(), 0 ;
 233             my @lines = <$io>;
 234             is @lines, 6
 235                 or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
 236             is $lines[1], "of a paragraph\n" ;
 237             is join('', @lines), $str ;
 238             is $., 6;
 239             is $io->tell(), length($str) ;
 240
 241             ok $io->eof;
 242
 243             ok ! ( defined($io->getline)  ||
 244                       (@tmp = $io->getlines) ||
 245                       defined(<$io>)         ||
 246                       defined($io->getc)     ||
 247                       read($io, $buf, 100)   != 0) ;
 248         }
 249
 250
 251         {
 252             local $/;  # slurp mode
 253             my $io = $UncompressClass->new($name);
 254             ok !$io->eof;
 255             my @lines = $io->getlines;
 256             ok $io->eof;
 257             ok @lines == 1 && $lines[0] eq $str;
 258
 259             $io = $UncompressClass->new($name);
 260             ok ! $io->eof;
 261             my $line = <$io>;
 262             ok $line eq $str;
 263             ok $io->eof;
 264         }
 265
 266         {
 267             local $/ = "";  # paragraph mode
 268             my $io = $UncompressClass->new($name);
 269             ok ! $io->eof;
 270             my @lines = <$io>;
 271             ok $io->eof;
 272             ok @lines == 2
 273                 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
 274             ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 275                 or print "# $lines[0]\n";
 276             ok $lines[1] eq "and a single line.\n\n";
 277         }
 278
 279         {
 280             local $/ = "is";
 281             my $io = $UncompressClass->new($name);
 282             my @lines = ();
 283             my $no = 0;
 284             my $err = 0;
 285             ok ! $io->eof;
 286             while (<$io>) {
 287                 push(@lines, $_);
 288                 $err++ if $. != ++$no;
 289             }
 290
 291             ok $err == 0 ;
 292             ok $io->eof;
 293
 294             ok @lines == 3
 295                 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
 296             ok join("-", @lines) eq
 297                              "This- is- an example\n" .
 298                             "of a paragraph\n\n\n" .
 299                             "and a single line.\n\n";
 300         }
 301
 302
 303         # Test read
 304
 305         {
 306             my $io = $UncompressClass->new($name);
 307
 308
 309             if (! $BadPerl) {
 310                 eval { read($io, $buf, -1) } ;
 311                 like $@, mkErr("length parameter is negative");
 312             }
 313
 314             is read($io, $buf, 0), 0, "Requested 0 bytes" ;
 315
 316             ok read($io, $buf, 3) == 3 ;
 317             ok $buf eq "Thi";
 318
 319             ok sysread($io, $buf, 3, 2) == 3 ;
 320             ok $buf eq "Ths i"
 321                 or print "# [$buf]\n" ;;
 322             ok ! $io->eof;
 323
 324     #        $io->seek(-4, 2);
 325     #
 326     #        ok ! $io->eof;
 327     #
 328     #        ok read($io, $buf, 20) == 4 ;
 329     #        ok $buf eq "e.\n\n";
 330     #
 331     #        ok read($io, $buf, 20) == 0 ;
 332     #        ok $buf eq "";
 333     #
 334     #        ok ! $io->eof;
 335         }
 336
 337     }
 338
 339     {
 340         # Read from non-compressed file
 341
 342         my $str = <<EOT;
 343 This is an example
 344 of a paragraph
 345
 346
 347 and a single line.
 348
 349 EOT
 350
 351         my $name = "test.gz" ;
 352         my $lex = new LexFile $name ;
 353
 354         writeFile($name, $str);
 355         my @tmp;
 356         my $buf;
 357         {
 358             my $io = new $UncompressClass $name, -Transparent => 1 ;
 359
 360             ok defined $io;
 361             ok ! $io->eof;
 362             ok $io->tell() == 0 ;
 363             my @lines = <$io>;
 364             ok @lines == 6;
 365             ok $lines[1] eq "of a paragraph\n" ;
 366             ok join('', @lines) eq $str ;
 367             ok $. == 6;
 368             ok $io->tell() == length($str) ;
 369
 370             ok $io->eof;
 371
 372             ok ! ( defined($io->getline)  ||
 373                       (@tmp = $io->getlines) ||
 374                       defined(<$io>)         ||
 375                       defined($io->getc)     ||
 376                       read($io, $buf, 100)   != 0) ;
 377         }
 378
 379
 380         {
 381             local $/;  # slurp mode
 382             my $io = $UncompressClass->new($name);
 383             ok ! $io->eof;
 384             my @lines = $io->getlines;
 385             ok $io->eof;
 386             ok @lines == 1 && $lines[0] eq $str;
 387
 388             $io = $UncompressClass->new($name);
 389             ok ! $io->eof;
 390             my $line = <$io>;
 391             ok $line eq $str;
 392             ok $io->eof;
 393         }
 394
 395         {
 396             local $/ = "";  # paragraph mode
 397             my $io = $UncompressClass->new($name);
 398             ok ! $io->eof;
 399             my @lines = <$io>;
 400             ok $io->eof;
 401             ok @lines == 2
 402                 or print "# exected 2 lines, got " . scalar(@lines) . "\n";
 403             ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 404                 or print "# [$lines[0]]\n" ;
 405             ok $lines[1] eq "and a single line.\n\n";
 406         }
 407
 408         {
 409             local $/ = "is";
 410             my $io = $UncompressClass->new($name);
 411             my @lines = ();
 412             my $no = 0;
 413             my $err = 0;
 414             ok ! $io->eof;
 415             while (<$io>) {
 416                 push(@lines, $_);
 417                 $err++ if $. != ++$no;
 418             }
 419
 420             ok $err == 0 ;
 421             ok $io->eof;
 422
 423             ok @lines == 3 ;
 424             ok join("-", @lines) eq
 425                              "This- is- an example\n" .
 426                             "of a paragraph\n\n\n" .
 427                             "and a single line.\n\n";
 428         }
 429
 430
 431         # Test read
 432
 433         {
 434             my $io = $UncompressClass->new($name);
 435
 436             ok read($io, $buf, 3) == 3 ;
 437             ok $buf eq "Thi";
 438
 439             ok sysread($io, $buf, 3, 2) == 3 ;
 440             ok $buf eq "Ths i";
 441             ok ! $io->eof;
 442
 443     #        $io->seek(-4, 2);
 444     #
 445     #        ok ! $io->eof;
 446     #
 447     #        ok read($io, $buf, 20) == 4 ;
 448     #        ok $buf eq "e.\n\n";
 449     #
 450     #        ok read($io, $buf, 20) == 0 ;
 451     #        ok $buf eq "";
 452     #
 453     #        ok ! $io->eof;
 454         }
 455
 456
 457     }
 458
 459     {
 460         # Vary the length parameter in a read
 461
 462         my $str = <<EOT;
 463 x
 464 x
 465 This is an example
 466 of a paragraph
 467
 468
 469 and a single line.
 470
 471 EOT
 472         $str = $str x 100 ;
 473
 474
 475         foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
 476         {
 477             foreach my $trans (0, 1)
 478             {
 479                 foreach my $append (0, 1)
 480                 {
 481                     title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
 482
 483                     my $name = "testz.gz" ;
 484                     my $lex = new LexFile $name ;
 485
 486                     if ($trans) {
 487                         writeFile($name, $str) ;
 488                     }
 489                     else {
 490                         my $iow = new $CompressClass $name ;
 491                         print $iow $str ;
 492                         close $iow;
 493                     }
 494
 495
 496                     my $io = $UncompressClass->new($name,
 497                                                    -Append => $append,
 498                                                    -Transparent  => $trans);
 499
 500                     my $buf;
 501
 502                     is $io->tell(), 0;
 503
 504                     if ($append) {
 505                         1 while $io->read($buf, $bufsize) > 0;
 506                     }
 507                     else {
 508                         my $tmp ;
 509                         $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
 510                     }
 511                     is length $buf, length $str;
 512                     ok $buf eq $str ;
 513                     ok ! $io->error() ;
 514                     ok $io->eof;
 515                 }
 516             }
 517         }
 518     }
 519
 520 }