t/lib/compress/generic.pl

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