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