ext/Compress/Zlib/t/04def.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 BEGIN
  17 {
  18     # use Test::NoWarnings, if available
  19     my $extra = 0 ;
  20     $extra = 1
  21         if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };
  22
  23     plan tests => 1775 + $extra ;
  24
  25     use_ok('Compress::Zlib', 2) ;
  26
  27     use_ok('IO::Compress::Gzip', qw($GzipError)) ;
  28     use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
  29
  30     use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
  31     use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
  32
  33     use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
  34     use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
  35
  36 }
  37
  38 use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
  39
  40
  41 our ($UncompressClass);
  42
  43
  44 sub myGZreadFile
  45 {
  46     my $filename = shift ;
  47     my $init = shift ;
  48
  49
  50     my $fil = new $UncompressClass $filename,
  51                                     -Strict   => 1,
  52                                     -Append   => 1
  53                                     ;
  54
  55     my $data = '';
  56     $data = $init if defined $init ;
  57     1 while $fil->read($data) > 0;
  58
  59     $fil->close ;
  60     return $data ;
  61 }
  62
  63 # Check zlib_version and ZLIB_VERSION are the same.
  64 is Compress::Zlib::zlib_version, ZLIB_VERSION,
  65     "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
  66
  67
  68
  69 foreach my $CompressClass ('IO::Compress::Gzip',
  70                            'IO::Compress::Deflate',
  71                            'IO::Compress::RawDeflate')
  72 {
  73
  74     title "Testing $CompressClass";
  75
  76     # Buffer not writable
  77     eval qq[\$a = new $CompressClass(\\1) ;] ;
  78     like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ;
  79
  80     my $out = "" ;
  81     eval qq[\$a = new $CompressClass \$out ;] ;
  82     like $@, mkEvalErr("^$CompressClass: output filename is undef or null string");
  83
  84     $out = undef ;
  85     eval qq[\$a = new $CompressClass \$out ;] ;
  86     like $@, mkEvalErr("^$CompressClass: output filename is undef or null string");
  87
  88     my $x ;
  89     my $gz = new $CompressClass(\$x);
  90
  91     foreach my $name (qw(read readline getc))
  92     {
  93         eval " \$gz->$name() " ;
  94         like $@, mkEvalErr("^$name Not Available: File opened only for output");
  95     }
  96
  97     eval ' $gz->write({})' ;
  98     like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference");
  99     #like $@, mkEvalErr("^${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref");
 100
 101     eval ' $gz->syswrite("abc", 1, 5)' ;
 102     like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
 103
 104     eval ' $gz->syswrite("abc", 1, -4)' ;
 105     like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
 106 }
 107
 108
 109 foreach my $CompressClass ('IO::Compress::Gzip',
 110                            'IO::Compress::Deflate',
 111                            'IO::Compress::RawDeflate',
 112                          )
 113 {
 114     $UncompressClass = getInverse($CompressClass);
 115     my $Error = getErrorRef($CompressClass);
 116     my $UnError = getErrorRef($UncompressClass);
 117
 118     title "Testing $UncompressClass";
 119
 120     my $out = "" ;
 121     eval qq[\$a = new $UncompressClass \$out ;] ;
 122     like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string");
 123
 124     $out = undef ;
 125     eval qq[\$a = new $UncompressClass \$out ;] ;
 126     like $@, mkEvalErr("^$UncompressClass: input filename is undef or null string");
 127
 128     my $lex = new LexFile my $name ;
 129
 130     ok ! -e $name, "  $name does not exist";
 131
 132     eval qq[\$a = new $UncompressClass "$name" ;] ;
 133     is $$UnError, "input file '$name' does not exist";
 134
 135     my $gc ;
 136     my $guz = new $CompressClass(\$gc);
 137     $guz->write("abc") ;
 138     $guz->close();
 139
 140     my $x ;
 141     my $gz = new $UncompressClass(\$gc);
 142
 143     foreach my $name (qw(print printf write))
 144     {
 145         eval " \$gz->$name() " ;
 146         like $@, mkEvalErr("^$name Not Available: File opened only for intput");
 147     }
 148
 149 }
 150
 151 foreach my $CompressClass ('IO::Compress::Gzip',
 152                            'IO::Compress::Deflate',
 153                            'IO::Compress::RawDeflate',
 154                          )
 155 {
 156     $UncompressClass = getInverse($CompressClass);
 157     my $Error = getErrorRef($CompressClass);
 158     my $ErrorUnc = getErrorRef($UncompressClass);
 159
 160
 161     title "Testing $CompressClass and $UncompressClass";
 162
 163     {
 164         my ($a, $x, @x) = ("","","") ;
 165
 166         # Buffer not a scalar reference
 167         eval qq[\$a = new $CompressClass \\\@x ;] ;
 168         like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref");
 169
 170         # Buffer not a scalar reference
 171         eval qq[\$a = new $UncompressClass \\\@x ;] ;
 172         like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref");
 173     }
 174
 175     foreach my $Type ( $CompressClass, $UncompressClass)
 176     {
 177         # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate
 178
 179         my ($a, $x, @x) = ("","","") ;
 180
 181         # Odd number of parameters
 182         eval qq[\$a = new $Type "abc", -Output ] ;
 183         like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1");
 184
 185         # Unknown parameter
 186         eval qq[\$a = new $Type  "anc", -Fred => 123 ;] ;
 187         like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred");
 188
 189         # no in or out param
 190         eval qq[\$a = new $Type ;] ;
 191         like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter");
 192
 193     }
 194
 195
 196     {
 197         # write a very simple compressed file
 198         # and read back
 199         #========================================
 200
 201
 202         my $lex = new LexFile my $name ;
 203
 204         my $hello = <<EOM ;
 205 hello world
 206 this is a test
 207 EOM
 208
 209         {
 210           my $x ;
 211           ok $x = new $CompressClass $name  ;
 212
 213           ok $x->write($hello), "write" ;
 214           ok $x->flush(Z_FINISH), "flush";
 215           ok $x->close, "close" ;
 216         }
 217
 218         {
 219           my $uncomp;
 220           ok my $x = new $UncompressClass $name, -Append => 1  ;
 221
 222           my $len ;
 223           1 while ($len = $x->read($uncomp)) > 0 ;
 224
 225           ok $x->close ;
 226           is $hello, $uncomp ;
 227         }
 228     }
 229
 230     {
 231         # write a very simple compressed file
 232         # and read back
 233         #========================================
 234
 235
 236         my $name = "test.gz" ;
 237         my $lex = new LexFile $name ;
 238
 239         my $hello = <<EOM ;
 240 hello world
 241 this is a test
 242 EOM
 243
 244         {
 245           my $x ;
 246           ok $x = new $CompressClass $name  ;
 247
 248           is $x->write(''), 0, "Write empty string is ok";
 249           is $x->write(undef), 0, "Write undef is ok";
 250           ok $x->write($hello), "Write ok" ;
 251           ok $x->close, "Close ok" ;
 252         }
 253
 254         {
 255           my $uncomp;
 256           my $x = new $UncompressClass $name  ;
 257           ok $x, "creates $UncompressClass $name"  ;
 258
 259           my $data = '';
 260           $data .= $uncomp while $x->read($uncomp) > 0 ;
 261
 262           ok $x->close, "close ok" ;
 263           is $data, $uncomp,"expected output" ;
 264         }
 265     }
 266
 267
 268     {
 269         # write a very simple file with using an IO filehandle
 270         # and read back
 271         #========================================
 272
 273
 274         my $name = "test.gz" ;
 275         my $lex = new LexFile $name ;
 276
 277         my $hello = <<EOM ;
 278 hello world
 279 this is a test
 280 EOM
 281
 282         {
 283           my $fh = new IO::File ">$name" ;
 284           ok $fh, "opened file $name ok";
 285           my $x = new $CompressClass $fh  ;
 286           ok $x, " created $CompressClass $fh"  ;
 287
 288           is $x->fileno(), fileno($fh), "fileno match" ;
 289           is $x->write(''), 0, "Write empty string is ok";
 290           is $x->write(undef), 0, "Write undef is ok";
 291           ok $x->write($hello), "write ok" ;
 292           ok $x->flush(), "flush";
 293           ok $x->close,"close" ;
 294           $fh->close() ;
 295         }
 296
 297         my $uncomp;
 298         {
 299           my $x ;
 300           ok my $fh1 = new IO::File "<$name" ;
 301           ok $x = new $UncompressClass $fh1, -Append => 1  ;
 302           ok $x->fileno() == fileno $fh1 ;
 303
 304           1 while $x->read($uncomp) > 0 ;
 305
 306           ok $x->close ;
 307         }
 308
 309         ok $hello eq $uncomp ;
 310     }
 311
 312     {
 313         # write a very simple file with using a glob filehandle
 314         # and read back
 315         #========================================
 316
 317
 318         my $lex = new LexFile my $name ;
 319
 320         my $hello = <<EOM ;
 321 hello world
 322 this is a test
 323 EOM
 324
 325         {
 326           title "$CompressClass: Input from typeglob filehandle";
 327           ok open FH, ">$name" ;
 328
 329           my $x = new $CompressClass *FH  ;
 330           ok $x, "  create $CompressClass"  ;
 331
 332           is $x->fileno(), fileno(*FH), "  fileno" ;
 333           is $x->write(''), 0, "  Write empty string is ok";
 334           is $x->write(undef), 0, "  Write undef is ok";
 335           ok $x->write($hello), "  Write ok" ;
 336           ok $x->flush(), "  Flush";
 337           ok $x->close, "  Close" ;
 338           close FH;
 339         }
 340
 341         my $uncomp;
 342         {
 343           title "$UncompressClass: Input from typeglob filehandle, append output";
 344           my $x ;
 345           ok open FH, "<$name" ;
 346           ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0  ;
 347           is $x->fileno(), fileno FH, "  fileno ok" ;
 348
 349           1 while $x->read($uncomp) > 0 ;
 350
 351           ok $x->close, "  close" ;
 352         }
 353
 354         is $uncomp, $hello, "  expected output" ;
 355     }
 356
 357     {
 358         my $name = "test.gz" ;
 359         my $lex = new LexFile $name ;
 360
 361         my $hello = <<EOM ;
 362 hello world
 363 this is a test
 364 EOM
 365
 366         {
 367           title "Outout to stdout via '-'" ;
 368
 369           open(SAVEOUT, ">&STDOUT");
 370           my $dummy = fileno SAVEOUT;
 371           open STDOUT, ">$name" ;
 372
 373           my $x = new $CompressClass '-'  ;
 374           $x->write($hello);
 375           $x->close;
 376
 377           open(STDOUT, ">&SAVEOUT");
 378
 379           ok 1, "  wrote to stdout" ;
 380         }
 381
 382         {
 383           title "Input from stdin via filename '-'";
 384
 385           my $x ;
 386           my $uncomp ;
 387           my $stdinFileno = fileno(STDIN);
 388           # open below doesn't return 1 sometines on XP
 389              open(SAVEIN, "<&STDIN");
 390           ok open(STDIN, "<$name"), "  redirect STDIN";
 391           my $dummy = fileno SAVEIN;
 392           $x = new $UncompressClass '-';
 393           ok $x, "  created object" ;
 394           is $x->fileno(), $stdinFileno, "  fileno ok" ;
 395
 396           1 while $x->read($uncomp) > 0 ;
 397
 398           ok $x->close, "  close" ;
 399              open(STDIN, "<&SAVEIN");
 400           is $hello, $uncomp, "  expected output" ;
 401         }
 402     }
 403
 404     {
 405         # write a compressed file to memory
 406         # and read back
 407         #========================================
 408
 409         my $name = "test.gz" ;
 410
 411         my $hello = <<EOM ;
 412 hello world
 413 this is a test
 414 EOM
 415
 416         my $buffer ;
 417         {
 418           my $x ;
 419           ok $x = new $CompressClass(\$buffer) ;
 420
 421           ok ! defined $x->fileno() ;
 422           is $x->write(''), 0, "Write empty string is ok";
 423           is $x->write(undef), 0, "Write undef is ok";
 424           ok $x->write($hello) ;
 425           ok $x->flush();
 426           ok $x->close ;
 427
 428           writeFile($name, $buffer) ;
 429           #is anyUncompress(\$buffer), $hello, "  any ok";
 430         }
 431
 432         my $keep = $buffer ;
 433         my $uncomp;
 434         {
 435           my $x ;
 436           ok $x = new $UncompressClass(\$buffer, Append => 1)  ;
 437
 438           ok ! defined $x->fileno() ;
 439           1 while $x->read($uncomp) > 0  ;
 440
 441           ok $x->close ;
 442         }
 443
 444         is $uncomp, $hello ;
 445         ok $buffer eq $keep ;
 446     }
 447
 448     if ($CompressClass ne 'RawDeflate')
 449     {
 450         # write empty file
 451         #========================================
 452
 453         my $buffer = '';
 454         {
 455           my $x ;
 456           ok $x = new $CompressClass(\$buffer) ;
 457           ok $x->close ;
 458
 459         }
 460
 461         my $keep = $buffer ;
 462         my $uncomp= '';
 463         {
 464           my $x ;
 465           ok $x = new $UncompressClass(\$buffer, Append => 1)  ;
 466
 467           1 while $x->read($uncomp) > 0  ;
 468
 469           ok $x->close ;
 470         }
 471
 472         ok $uncomp eq '' ;
 473         ok $buffer eq $keep ;
 474
 475     }
 476
 477     {
 478         # write a larger file
 479         #========================================
 480
 481
 482         my $lex = new LexFile my $name ;
 483
 484         my $hello = <<EOM ;
 485 hello world
 486 this is a test
 487 EOM
 488
 489         my $input    = '' ;
 490         my $contents = '' ;
 491
 492         {
 493           my $x = new $CompressClass $name  ;
 494           ok $x, "  created $CompressClass object";
 495
 496           ok $x->write($hello), "  write ok" ;
 497           $input .= $hello ;
 498           ok $x->write("another line"), "  write ok" ;
 499           $input .= "another line" ;
 500           # all characters
 501           foreach (0 .. 255)
 502             { $contents .= chr int $_ }
 503           # generate a long random string
 504           foreach (1 .. 5000)
 505             { $contents .= chr int rand 256 }
 506
 507           ok $x->write($contents), "  write ok" ;
 508           $input .= $contents ;
 509           ok $x->close, "  close ok" ;
 510         }
 511
 512         ok myGZreadFile($name) eq $input ;
 513         my $x =  readFile($name) ;
 514         #print "length " . length($x) . " \n";
 515     }
 516
 517     {
 518         # embed a compressed file in another file
 519         #================================
 520
 521
 522         my $name = "test.gz" ;
 523         my $lex = new LexFile $name ;
 524
 525         my $hello = <<EOM ;
 526 hello world
 527 this is a test
 528 EOM
 529
 530         my $header = "header info\n" ;
 531         my $trailer = "trailer data\n" ;
 532
 533         {
 534           my $fh ;
 535           ok $fh = new IO::File ">$name" ;
 536           print $fh $header ;
 537           my $x ;
 538           ok $x = new $CompressClass $fh,
 539                                      -AutoClose => 0   ;
 540
 541           ok $x->binmode();
 542           ok $x->write($hello) ;
 543           ok $x->close ;
 544           print $fh $trailer ;
 545           $fh->close() ;
 546         }
 547
 548         my ($fil, $uncomp) ;
 549         my $fh1 ;
 550         ok $fh1 = new IO::File "<$name" ;
 551         # skip leading junk
 552         my $line = <$fh1> ;
 553         ok $line eq $header ;
 554
 555         ok my $x = new $UncompressClass $fh1  ;
 556         ok $x->binmode();
 557         my $got = $x->read($uncomp);
 558
 559         ok $uncomp eq $hello ;
 560         my $rest ;
 561         read($fh1, $rest, 5000);
 562         is ${ $x->trailingData() } . $rest, $trailer ;
 563         #print ${ $x->trailingData() } . $rest ;
 564
 565     }
 566
 567     {
 568         # Write
 569         # these tests come almost 100% from IO::String
 570
 571         my $name = "test.gz" ;
 572         my $lex = new LexFile $name ;
 573
 574         my $io = $CompressClass->new($name);
 575
 576         is $io->tell(), 0, " tell returns 0"; ;
 577
 578         my $heisan = "Heisan\n";
 579         $io->print($heisan) ;
 580
 581         ok ! $io->eof(), "  ! eof";
 582
 583         is $io->tell(), length($heisan), "  tell is " . length($heisan) ;
 584
 585         $io->print("a", "b", "c");
 586
 587         {
 588             local($\) = "\n";
 589             $io->print("d", "e");
 590             local($,) = ",";
 591             $io->print("f", "g", "h");
 592         }
 593
 594         {
 595             local($\) ;
 596             $io->print("D", "E");
 597             local($,) = ".";
 598             $io->print("F", "G", "H");
 599         }
 600
 601         my $foo = "1234567890";
 602
 603         is $io->syswrite($foo, length($foo)), length($foo), "  syswrite ok" ;
 604         if ( $[ < 5.6 )
 605           { is $io->syswrite($foo, length $foo), length $foo, "  syswrite ok" }
 606         else
 607           { is $io->syswrite($foo), length $foo, "  syswrite ok" }
 608         is $io->syswrite($foo, length($foo)), length $foo, "  syswrite ok";
 609         is $io->write($foo, length($foo), 5), 5,   " write 5";
 610         is $io->write("xxx\n", 100, -1), 1, "  write 1";
 611
 612         for (1..3) {
 613             $io->printf("i(%d)", $_);
 614             $io->printf("[%d]\n", $_);
 615         }
 616         $io->print("\n");
 617
 618         $io->close ;
 619
 620         ok $io->eof(), "  eof";
 621
 622         is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" .
 623                                 ("1234567890" x 3) . "67890\n" .
 624                                     "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
 625
 626
 627     }
 628
 629     {
 630         # Read
 631         my $str = <<EOT;
 632 This is an example
 633 of a paragraph
 634
 635
 636 and a single line.
 637
 638 EOT
 639
 640         my $name = "test.gz" ;
 641         my $lex = new LexFile $name ;
 642
 643         my %opts = () ;
 644         %opts = (CRC32 => 1, Adler32 => 1)
 645             if $CompressClass ne "IO::Compress::Gzip";
 646         my $iow = new $CompressClass $name, %opts;
 647         $iow->print($str) ;
 648         $iow->close ;
 649
 650         my @tmp;
 651         my $buf;
 652         {
 653             my $io = new $UncompressClass $name ;
 654
 655             ok ! $io->eof;
 656             is $io->tell(), 0 ;
 657             #my @lines = <$io>;
 658             my @lines = $io->getlines();
 659             is @lines, 6
 660                 or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
 661             is $lines[1], "of a paragraph\n" ;
 662             is join('', @lines), $str ;
 663             is $., 6;
 664             is $io->tell(), length($str) ;
 665
 666             ok $io->eof;
 667
 668             ok ! ( defined($io->getline)  ||
 669                       (@tmp = $io->getlines) ||
 670                       defined($io->getline)         ||
 671                       defined($io->getc)     ||
 672                       $io->read($buf, 100)   != 0) ;
 673         }
 674
 675
 676         {
 677             local $/;  # slurp mode
 678             my $io = $UncompressClass->new($name);
 679             ok ! $io->eof;
 680             my @lines = $io->getlines;
 681             ok $io->eof;
 682             ok @lines == 1 && $lines[0] eq $str;
 683
 684             $io = $UncompressClass->new($name);
 685             ok ! $io->eof;
 686             my $line = $io->getline();
 687             ok $line eq $str;
 688             ok $io->eof;
 689         }
 690
 691         {
 692             local $/ = "";  # paragraph mode
 693             my $io = $UncompressClass->new($name);
 694             ok ! $io->eof;
 695             my @lines = $io->getlines();
 696             ok $io->eof;
 697             ok @lines == 2
 698                 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
 699             ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 700                 or print "# $lines[0]\n";
 701             ok $lines[1] eq "and a single line.\n\n";
 702         }
 703
 704         {
 705             local $/ = "is";
 706             my $io = $UncompressClass->new($name);
 707             my @lines = ();
 708             my $no = 0;
 709             my $err = 0;
 710             ok ! $io->eof;
 711             while (my $a = $io->getline()) {
 712                 push(@lines, $a);
 713                 $err++ if $. != ++$no;
 714             }
 715
 716             ok $err == 0 ;
 717             ok $io->eof;
 718
 719             ok @lines == 3
 720                 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
 721             ok join("-", @lines) eq
 722                              "This- is- an example\n" .
 723                             "of a paragraph\n\n\n" .
 724                             "and a single line.\n\n";
 725         }
 726
 727
 728         # Test read
 729
 730         {
 731             my $io = $UncompressClass->new($name);
 732
 733
 734             eval { $io->read(1) } ;
 735             like $@, mkErr("buffer parameter is read-only");
 736
 737             is $io->read($buf, 0), 0, "Requested 0 bytes" ;
 738
 739             ok $io->read($buf, 3) == 3 ;
 740             ok $buf eq "Thi";
 741
 742             ok $io->sysread($buf, 3, 2) == 3 ;
 743             ok $buf eq "Ths i"
 744                 or print "# [$buf]\n" ;;
 745             ok ! $io->eof;
 746
 747     #        $io->seek(-4, 2);
 748     #
 749     #        ok ! $io->eof;
 750     #
 751     #        ok read($io, $buf, 20) == 4 ;
 752     #        ok $buf eq "e.\n\n";
 753     #
 754     #        ok read($io, $buf, 20) == 0 ;
 755     #        ok $buf eq "";
 756     #
 757     #        ok ! $io->eof;
 758         }
 759
 760     }
 761
 762     {
 763         # Read from non-compressed file
 764
 765         my $str = <<EOT;
 766 This is an example
 767 of a paragraph
 768
 769
 770 and a single line.
 771
 772 EOT
 773
 774         my $name = "test.gz" ;
 775         my $lex = new LexFile $name ;
 776
 777         writeFile($name, $str);
 778         my @tmp;
 779         my $buf;
 780         {
 781             my $io = new $UncompressClass $name, -Transparent => 1 ;
 782
 783             ok defined $io;
 784             ok ! $io->eof;
 785             ok $io->tell() == 0 ;
 786             my @lines = $io->getlines();
 787             ok @lines == 6;
 788             ok $lines[1] eq "of a paragraph\n" ;
 789             ok join('', @lines) eq $str ;
 790             ok $. == 6;
 791             ok $io->tell() == length($str) ;
 792
 793             ok $io->eof;
 794
 795             ok ! ( defined($io->getline)  ||
 796                       (@tmp = $io->getlines) ||
 797                       defined($io->getline)         ||
 798                       defined($io->getc)     ||
 799                       $io->read($buf, 100)   != 0) ;
 800         }
 801
 802
 803         {
 804             local $/;  # slurp mode
 805             my $io = $UncompressClass->new($name);
 806             ok ! $io->eof;
 807             my @lines = $io->getlines;
 808             ok $io->eof;
 809             ok @lines == 1 && $lines[0] eq $str;
 810
 811             $io = $UncompressClass->new($name);
 812             ok ! $io->eof;
 813             my $line = $io->getline;
 814             ok $line eq $str;
 815             ok $io->eof;
 816         }
 817
 818         {
 819             local $/ = "";  # paragraph mode
 820             my $io = $UncompressClass->new($name);
 821             ok ! $io->eof;
 822             my @lines = $io->getlines;
 823             ok $io->eof;
 824             ok @lines == 2
 825                 or print "# exected 2 lines, got " . scalar(@lines) . "\n";
 826             ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 827                 or print "# [$lines[0]]\n" ;
 828             ok $lines[1] eq "and a single line.\n\n";
 829         }
 830
 831         {
 832             local $/ = "is";
 833             my $io = $UncompressClass->new($name);
 834             my @lines = ();
 835             my $no = 0;
 836             my $err = 0;
 837             ok ! $io->eof;
 838             while (my $a = $io->getline) {
 839                 push(@lines, $a);
 840                 $err++ if $. != ++$no;
 841             }
 842
 843             ok $err == 0 ;
 844             ok $io->eof;
 845
 846             ok @lines == 3 ;
 847             ok join("-", @lines) eq
 848                              "This- is- an example\n" .
 849                             "of a paragraph\n\n\n" .
 850                             "and a single line.\n\n";
 851         }
 852
 853
 854         # Test read
 855
 856         {
 857             my $io = $UncompressClass->new($name);
 858
 859             ok $io->read($buf, 3) == 3 ;
 860             ok $buf eq "Thi";
 861
 862             ok $io->sysread($buf, 3, 2) == 3 ;
 863             ok $buf eq "Ths i";
 864             ok ! $io->eof;
 865
 866     #        $io->seek(-4, 2);
 867     #
 868     #        ok ! $io->eof;
 869     #
 870     #        ok read($io, $buf, 20) == 4 ;
 871     #        ok $buf eq "e.\n\n";
 872     #
 873     #        ok read($io, $buf, 20) == 0 ;
 874     #        ok $buf eq "";
 875     #
 876     #        ok ! $io->eof;
 877         }
 878
 879
 880     }
 881
 882     {
 883         # Vary the length parameter in a read
 884
 885         my $str = <<EOT;
 886 x
 887 x
 888 This is an example
 889 of a paragraph
 890
 891
 892 and a single line.
 893
 894 EOT
 895         $str = $str x 100 ;
 896
 897
 898         foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
 899         {
 900             foreach my $trans (0, 1)
 901             {
 902                 foreach my $append (0, 1)
 903                 {
 904                     title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
 905
 906                     my $name = "testz.gz" ;
 907                     my $lex = new LexFile $name ;
 908
 909                     if ($trans) {
 910                         writeFile($name, $str) ;
 911                     }
 912                     else {
 913                         my $iow = new $CompressClass $name;
 914                         $iow->print($str) ;
 915                         $iow->close ;
 916                     }
 917
 918
 919                     my $io = $UncompressClass->new($name,
 920                                                    -Append => $append,
 921                                                    -Transparent  => $trans);
 922
 923                     my $buf;
 924
 925                     is $io->tell(), 0;
 926
 927                     if ($append) {
 928                         1 while $io->read($buf, $bufsize) > 0;
 929                     }
 930                     else {
 931                         my $tmp ;
 932                         $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
 933                     }
 934                     is length $buf, length $str;
 935                     ok $buf eq $str ;
 936                     ok ! $io->error() ;
 937                     ok $io->eof;
 938                 }
 939             }
 940         }
 941     }
 942
 943     foreach my $file (0, 1)
 944     {
 945         foreach my $trans (0, 1)
 946         {
 947             title "seek tests - file $file trans $trans" ;
 948
 949             my $buffer ;
 950             my $buff ;
 951             my $name = "test.gz" ;
 952             my $lex = new LexFile $name ;
 953
 954             my $first = "beginning" ;
 955             my $last  = "the end" ;
 956
 957             if ($trans)
 958             {
 959                 $buffer = $first . "\x00" x 10 . $last;
 960                 writeFile($name, $buffer);
 961             }
 962             else
 963             {
 964                 my $output ;
 965                 if ($file)
 966                 {
 967                     $output = $name ;
 968                 }
 969                 else
 970                 {
 971                     $output = \$buffer;
 972                 }
 973
 974                 my $iow = new $CompressClass $output ;
 975                 $iow->print($first) ;
 976                 ok $iow->seek(5, SEEK_CUR) ;
 977                 ok $iow->tell() == length($first)+5;
 978                 ok $iow->seek(0, SEEK_CUR) ;
 979                 ok $iow->tell() == length($first)+5;
 980                 ok $iow->seek(length($first)+10, SEEK_SET) ;
 981                 ok $iow->tell() == length($first)+10;
 982
 983                 $iow->print($last) ;
 984                 $iow->close ;
 985             }
 986
 987             my $input ;
 988             if ($file)
 989             {
 990                 $input = $name ;
 991             }
 992             else
 993             {
 994                 $input = \$buffer ;
 995             }
 996
 997             ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ;
 998
 999             my $io = $UncompressClass->new($input, Strict => 1);
1000             ok $io->seek(length($first), SEEK_CUR) ;
1001             ok ! $io->eof;
1002             is $io->tell(), length($first);
1003
1004             ok $io->read($buff, 5) ;
1005             is $buff, "\x00" x 5 ;
1006             is $io->tell(), length($first) + 5;
1007
1008             ok $io->seek(0, SEEK_CUR) ;
1009             my $here = $io->tell() ;
1010             is $here, length($first)+5;
1011
1012             ok $io->seek($here+5, SEEK_SET) ;
1013             is $io->tell(), $here+5 ;
1014             ok $io->read($buff, 100) ;
1015             ok $buff eq $last ;
1016             ok $io->eof;
1017         }
1018     }
1019
1020     {
1021         title "seek error cases" ;
1022
1023         my $b ;
1024         my $a = new $CompressClass(\$b)  ;
1025
1026         ok ! $a->error() ;
1027         eval { $a->seek(-1, 10) ; };
1028         like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter");
1029
1030         eval { $a->seek(-1, SEEK_END) ; };
1031         like $@, mkErr("^${CompressClass}::seek: cannot seek backwards");
1032
1033         $a->write("fred");
1034         $a->close ;
1035
1036
1037         my $u = new $UncompressClass(\$b)  ;
1038
1039         eval { $u->seek(-1, 10) ; };
1040         like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter");
1041
1042         eval { $u->seek(-1, SEEK_END) ; };
1043         like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed");
1044
1045         eval { $u->seek(-1, SEEK_CUR) ; };
1046         like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards");
1047     }
1048
1049     foreach my $fb (qw(filename buffer filehandle))
1050     {
1051         foreach my $append (0, 1)
1052         {
1053             {
1054                 title "$CompressClass -- Append $append, Output to $fb" ;
1055
1056                 my $name = "test.gz" ;
1057                 my $lex = new LexFile $name ;
1058
1059                 my $already = 'already';
1060                 my $buffer = $already;
1061                 my $output;
1062
1063                 if ($fb eq 'buffer')
1064                   { $output = \$buffer }
1065                 elsif ($fb eq 'filename')
1066                 {
1067                     $output = $name ;
1068                     writeFile($name, $buffer);
1069                 }
1070                 elsif ($fb eq 'filehandle')
1071                 {
1072                     $output = new IO::File ">$name" ;
1073                     print $output $buffer;
1074                 }
1075
1076                 my $a = new $CompressClass($output, Append => $append)  ;
1077                 ok $a, "  Created $CompressClass";
1078                 my $string = "appended";
1079                 $a->write($string);
1080                 $a->close ;
1081
1082                 my $data ;
1083                 if ($fb eq 'buffer')
1084                 {
1085                     $data = $buffer;
1086                 }
1087                 else
1088                 {
1089                     $output->close
1090                         if $fb eq 'filehandle';
1091                     $data = readFile($name);
1092                 }
1093
1094                 if ($append || $fb eq 'filehandle')
1095                 {
1096                     is substr($data, 0, length($already)), $already, "  got prefix";
1097                     substr($data, 0, length($already)) = '';
1098                 }
1099
1100
1101                 my $uncomp;
1102                 my $x = new $UncompressClass(\$data, Append => 1)  ;
1103                 ok $x, "  created $UncompressClass";
1104
1105                 my $len ;
1106                 1 while ($len = $x->read($uncomp)) > 0 ;
1107
1108                 $x->close ;
1109                 is $uncomp, $string, '  Got uncompressed data' ;
1110
1111             }
1112         }
1113     }
1114
1115     foreach my $type (qw(buffer filename filehandle))
1116     {
1117         title "$UncompressClass -- InputLength, read from $type";
1118
1119         my $compressed ;
1120         my $string = "some data";
1121         my $c = new $CompressClass(\$compressed);
1122         $c->write($string);
1123         $c->close();
1124
1125         my $appended = "append";
1126         my $comp_len = length $compressed;
1127         $compressed .= $appended;
1128
1129         my $name = "test.gz" ;
1130         my $lex = new LexFile $name ;
1131         my $input ;
1132         writeFile ($name, $compressed);
1133
1134         if ($type eq 'buffer')
1135         {
1136             $input = \$compressed;
1137         }
1138         if ($type eq 'filename')
1139         {
1140             $input = $name;
1141         }
1142         elsif ($type eq 'filehandle')
1143         {
1144             my $fh = new IO::File "<$name" ;
1145             ok $fh, "opened file $name ok";
1146             $input = $fh ;
1147         }
1148
1149         my $x = new $UncompressClass($input, InputLength => $comp_len)  ;
1150         ok $x, "  created $UncompressClass";
1151
1152         my $len ;
1153         my $output;
1154         $len = $x->read($output, 100);
1155         is $len, length($string);
1156         is $output, $string;
1157
1158         if ($type eq 'filehandle')
1159         {
1160             my $rest ;
1161             $input->read($rest, 1000);
1162             is $rest, $appended;
1163         }
1164
1165
1166     }
1167
1168     foreach my $append (0, 1)
1169     {
1170         title "$UncompressClass -- Append $append" ;
1171
1172         my $name = "test.gz" ;
1173         my $lex = new LexFile $name ;
1174
1175         my $string = "appended";
1176         my $compressed ;
1177         my $c = new $CompressClass(\$compressed);
1178         $c->write($string);
1179         $c->close();
1180
1181         my $x = new $UncompressClass(\$compressed, Append => $append)  ;
1182         ok $x, "  created $UncompressClass";
1183
1184         my $already = 'already';
1185         my $output = $already;
1186
1187         my $len ;
1188         $len = $x->read($output, 100);
1189         is $len, length($string);
1190
1191         $x->close ;
1192
1193         if ($append)
1194         {
1195             is substr($output, 0, length($already)), $already, "  got prefix";
1196             substr($output, 0, length($already)) = '';
1197         }
1198         is $output, $string, '  Got uncompressed data' ;
1199     }
1200
1201
1202     foreach my $file (0, 1)
1203     {
1204         foreach my $trans (0, 1)
1205         {
1206             title "ungetc, File $file, Transparent $trans" ;
1207
1208             my $name = "test.gz" ;
1209             my $lex = new LexFile $name ;
1210
1211             my $string = 'abcdeABCDE';
1212             my $b ;
1213             if ($trans)
1214             {
1215                 $b = $string ;
1216             }
1217             else
1218             {
1219                 my $a = new $CompressClass(\$b)  ;
1220                 $a->write($string);
1221                 $a->close ;
1222             }
1223
1224             my $from ;
1225             if ($file)
1226             {
1227                 writeFile($name, $b);
1228                 $from = $name ;
1229             }
1230             else
1231             {
1232                 $from = \$b ;
1233             }
1234
1235             my $u = $UncompressClass->new($from, Transparent => 1)  ;
1236             my $first;
1237             my $buff ;
1238
1239             # do an ungetc before reading
1240             $u->ungetc("X");
1241             $first = $u->getc();
1242             is $first, 'X';
1243
1244             $first = $u->getc();
1245             is $first, substr($string, 0,1);
1246             $u->ungetc($first);
1247             $first = $u->getc();
1248             is $first, substr($string, 0,1);
1249             $u->ungetc($first);
1250
1251             is $u->read($buff, 5), 5 ;
1252             is $buff, substr($string, 0, 5);
1253
1254             $u->ungetc($buff) ;
1255             is $u->read($buff, length($string)), length($string) ;
1256             is $buff, $string;
1257
1258             ok $u->eof() ;
1259
1260             my $extra = 'extra';
1261             $u->ungetc($extra);
1262             ok ! $u->eof();
1263             is $u->read($buff), length($extra) ;
1264             is $buff, $extra;
1265
1266             ok $u->eof() ;
1267
1268             $u->close();
1269
1270         }
1271     }
1272
1273     {
1274         title "inflateSync on plain file";
1275
1276         my $hello = "I am a HAL 9000 computer" x 2001 ;
1277
1278         my ($k, $err) = new $UncompressClass(\$hello, Transparent => 1);
1279         ok $k ;
1280         cmp_ok $err, '==', Z_OK ;
1281
1282         # Skip to the flush point -- no-op for plain file
1283         my $status = $k->inflateSync();
1284         is $status, 1
1285             or diag $k->error() ;
1286
1287         my $rest;
1288         is $k->read($rest, length($hello)), length($hello)
1289             or diag $k->error() ;
1290         ok $rest eq $hello ;
1291
1292         ok $k->close();
1293     }
1294
1295     {
1296         title "inflateSync for real";
1297
1298         # create a deflate stream with flush points
1299
1300         my $hello = "I am a HAL 9000 computer" x 2001 ;
1301         my $goodbye = "Will I dream?" x 2010;
1302         my ($x, $err, $answer, $X, $Z, $status);
1303         my $Answer ;
1304
1305         ok ($x = new $CompressClass(\$Answer));
1306         ok $x ;
1307
1308         is $x->write($hello), length($hello);
1309
1310         # create a flush point
1311         ok $x->flush(Z_FULL_FLUSH) ;
1312
1313         is $x->write($goodbye), length($goodbye);
1314
1315         ok $x->close() ;
1316
1317         my $k;
1318         ($k, $err) = new $UncompressClass(\$Answer, BlockSize => 1);
1319         ok $k ;
1320         cmp_ok $err, '==', Z_OK ;
1321
1322         my $initial;
1323         is $k->read($initial, 1), 1 ;
1324         is $initial, substr($hello, 0, 1);
1325
1326         # Skip to the flush point
1327         $status = $k->inflateSync();
1328         is $status, 1
1329             or diag $k->error() ;
1330
1331         my $rest;
1332         is $k->read($rest, length($hello) + length($goodbye)),
1333                 length($goodbye)
1334             or diag $k->error() ;
1335         ok $rest eq $goodbye ;
1336
1337         ok $k->close();
1338     }
1339
1340     {
1341         title "inflateSync no FLUSH point";
1342
1343         # create a deflate stream with flush points
1344
1345         my $hello = "I am a HAL 9000 computer" x 2001 ;
1346         my ($x, $err, $answer, $X, $Z, $status);
1347         my $Answer ;
1348
1349         ok ($x = new $CompressClass(\$Answer));
1350         ok $x ;
1351
1352         is $x->write($hello), length($hello);
1353
1354         ok $x->close() ;
1355
1356         my $k;
1357         ($k, $err) = new $UncompressClass(\$Answer, BlockSize => 1);
1358         ok $k ;
1359         cmp_ok $err, '==', Z_OK ;
1360
1361         my $initial;
1362         is $k->read($initial, 1), 1 ;
1363         is $initial, substr($hello, 0, 1);
1364
1365         # Skip to the flush point
1366         $status = $k->inflateSync();
1367         is $status, 0
1368             or diag $k->error() ;
1369
1370         ok $k->close();
1371         is $k->inflateSync(), 0 ;
1372     }
1373
1374     {
1375         title "write tests - invalid data" ;
1376
1377         #my $name1 = "test.gz" ;
1378         #my $lex = new LexFile $name1 ;
1379         my $Answer ;
1380
1381         #ok ! -e $name1, "  File $name1 does not exist";
1382
1383         my @data = (
1384             [ '{ }',         "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1385             [ '[ { } ]',     "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1386             [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1387             [ '[ "" ]',      "${CompressClass}::write: input filename is undef or null string" ],
1388             [ '[ undef ]',   "${CompressClass}::write: input filename is undef or null string" ],
1389             [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ],
1390             #[ "not readable", 'xx' ],
1391             # same filehandle twice, 'xx'
1392            ) ;
1393
1394         foreach my $data (@data)
1395         {
1396             my ($send, $get) = @$data ;
1397             title "${CompressClass}::write( $send )";
1398             my $copy;
1399             eval "\$copy = $send";
1400             my $x = new $CompressClass(\$Answer);
1401             ok $x, "  Created $CompressClass object";
1402             eval { $x->write($copy) } ;
1403             #like $@, "/^$get/", "  error - $get";
1404             like $@, "/not a scalar reference /", "  error - not a scalar reference";
1405         }
1406
1407 #        @data = (
1408 #            [ '[ $name1 ]',  "input file '$name1' does not exist" ],
1409 #            #[ "not readable", 'xx' ],
1410 #            # same filehandle twice, 'xx'
1411 #           ) ;
1412 #
1413 #        foreach my $data (@data)
1414 #        {
1415 #            my ($send, $get) = @$data ;
1416 #            title "${CompressClass}::write( $send )";
1417 #            my $copy;
1418 #            eval "\$copy = $send";
1419 #            my $x = new $CompressClass(\$Answer);
1420 #            ok $x, "  Created $CompressClass object";
1421 #            ok ! $x->write($copy), "  write fails"  ;
1422 #            like $$Error, "/^$get/", "  error - $get";
1423 #        }
1424
1425         #exit;
1426
1427     }
1428
1429
1430 #    sub deepCopy
1431 #    {
1432 #        if (! ref $_[0] || ref $_[0] eq 'SCALAR')
1433 #        {
1434 #            return $_[0] ;
1435 #        }
1436 #
1437 #        if (ref $_[0] eq 'ARRAY')
1438 #        {
1439 #            my @a ;
1440 #            for my $x ( @{ $_[0] })
1441 #            {
1442 #                push @a, deepCopy($x);
1443 #            }
1444 #
1445 #            return \@a ;
1446 #        }
1447 #
1448 #        croak "bad! $_[0]";
1449 #
1450 #    }
1451 #
1452 #    sub deepSubst
1453 #    {
1454 #        #my $data = shift ;
1455 #        my $from = $_[1] ;
1456 #        my $to   = $_[2] ;
1457 #
1458 #        if (! ref $_[0])
1459 #        {
1460 #            $_[0] = $to
1461 #                if $_[0] eq $from ;
1462 #            return ;
1463 #
1464 #        }
1465 #
1466 #        if (ref $_[0] eq 'SCALAR')
1467 #        {
1468 #            $_[0] = \$to
1469 #                if defined ${ $_[0] } && ${ $_[0] } eq $from ;
1470 #            return ;
1471 #
1472 #        }
1473 #
1474 #        if (ref $_[0] eq 'ARRAY')
1475 #        {
1476 #            for my $x ( @{ $_[0] })
1477 #            {
1478 #                deepSubst($x, $from, $to);
1479 #            }
1480 #            return ;
1481 #        }
1482 #        #croak "bad! $_[0]";
1483 #    }
1484
1485 #    {
1486 #        title "More write tests" ;
1487 #
1488 #        my $file1 = "file1" ;
1489 #        my $file2 = "file2" ;
1490 #        my $file3 = "file3" ;
1491 #        my $lex = new LexFile $file1, $file2, $file3 ;
1492 #
1493 #        writeFile($file1, "F1");
1494 #        writeFile($file2, "F2");
1495 #        writeFile($file3, "F3");
1496 #
1497 #        my @data = (
1498 #              [ '""',                                   ""      ],
1499 #              [ 'undef',                                ""      ],
1500 #              [ '"abcd"',                               "abcd"  ],
1501 #
1502 #              [ '\""',                                   ""     ],
1503 #              [ '\undef',                                ""     ],
1504 #              [ '\"abcd"',                               "abcd" ],
1505 #
1506 #              [ '[]',                                    ""     ],
1507 #              [ '[[]]',                                  ""     ],
1508 #              [ '[[[]]]',                                ""     ],
1509 #              [ '[\""]',                                 ""     ],
1510 #              [ '[\undef]',                              ""     ],
1511 #              [ '[\"abcd"]',                             "abcd" ],
1512 #              [ '[\"ab", \"cd"]',                        "abcd" ],
1513 #              [ '[[\"ab"], [\"cd"]]',                    "abcd" ],
1514 #
1515 #              [ '$file1',                                $file1 ],
1516 #              [ '$fh2',                                  "F2"   ],
1517 #              [ '[$file1, \"abc"]',                      "F1abc"],
1518 #              [ '[\"a", $file1, \"bc"]',                 "aF1bc"],
1519 #              [ '[\"a", $fh1, \"bc"]',                   "aF1bc"],
1520 #              [ '[\"a", $fh1, \"bc", $file2]',           "aF1bcF2"],
1521 #              [ '[\"a", $fh1, \"bc", $file2, $fh3]',     "aF1bcF2F3"],
1522 #            ) ;
1523 #
1524 #
1525 #        foreach my $data (@data)
1526 #        {
1527 #            my ($send, $get) = @$data ;
1528 #
1529 #            my $fh1 = new IO::File "< $file1" ;
1530 #            my $fh2 = new IO::File "< $file2" ;
1531 #            my $fh3 = new IO::File "< $file3" ;
1532 #
1533 #            title "${CompressClass}::write( $send )";
1534 #            my $copy;
1535 #            eval "\$copy = $send";
1536 #            my $Answer ;
1537 #            my $x = new $CompressClass(\$Answer);
1538 #            ok $x, "  Created $CompressClass object";
1539 #            my $len = length $get;
1540 #            is $x->write($copy), length($get), "  write $len bytes";
1541 #            ok $x->close(), "  close ok" ;
1542 #
1543 #            is myGZreadFile(\$Answer), $get, "  got expected output" ;
1544 #            cmp_ok $$Error, '==', 0, "  no error";
1545 #
1546 #
1547 #        }
1548 #
1549 #    }
1550 }
1551
1552
1553
1554
1555
1556