t/lib/compress/generic.pl

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