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 => 641 + $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             is $iow->input_line_number, undef;
 657             $iow->print($str) ;
 658             is $iow->input_line_number, undef;
 659             $iow->close ;
 660
 661             my @tmp;
 662             my $buf;
 663             {
 664                 my $io = new $UncompressClass $name ;
 665
 666                 is $., 0;
 667                 is $io->input_line_number, 0;
 668                 ok ! $io->eof, "eof";
 669                 is $io->tell(), 0, "tell 0" ;
 670                 #my @lines = <$io>;
 671                 my @lines = $io->getlines();
 672                 is @lines, 6
 673                     or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
 674                 is $lines[1], "of a paragraph\n" ;
 675                 is join('', @lines), $str ;
 676                 is $., 6;
 677                 is $io->input_line_number, 6;
 678                 is $io->tell(), length($str) ;
 679
 680                 ok $io->eof;
 681
 682                 ok ! ( defined($io->getline)  ||
 683                           (@tmp = $io->getlines) ||
 684                           defined($io->getline)         ||
 685                           defined($io->getc)     ||
 686                           $io->read($buf, 100)   != 0) ;
 687             }
 688
 689
 690             {
 691                 local $/;  # slurp mode
 692                 my $io = $UncompressClass->new($name);
 693                 is $., 0;
 694                 is $io->input_line_number, 0;
 695                 ok ! $io->eof;
 696                 my @lines = $io->getlines;
 697                 is $., 1;
 698                 is $io->input_line_number, 1;
 699                 ok $io->eof;
 700                 ok @lines == 1 && $lines[0] eq $str;
 701
 702                 $io = $UncompressClass->new($name);
 703                 ok ! $io->eof;
 704                 my $line = $io->getline();
 705                 ok $line eq $str;
 706                 ok $io->eof;
 707             }
 708
 709             {
 710                 local $/ = "";  # paragraph mode
 711                 my $io = $UncompressClass->new($name);
 712                 is $., 0;
 713                 is $io->input_line_number, 0;
 714                 ok ! $io->eof;
 715                 my @lines = $io->getlines();
 716                 is $., 2;
 717                 is $io->input_line_number, 2;
 718                 ok $io->eof;
 719                 ok @lines == 2
 720                     or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
 721                 ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 722                     or print "# $lines[0]\n";
 723                 ok $lines[1] eq "and a single line.\n\n";
 724             }
 725
 726             {
 727                 # Record mode
 728                 my $reclen = 7 ;
 729                 my $expected_records = int(length($str) / $reclen)
 730                                         + (length($str) % $reclen ? 1 : 0);
 731                 local $/ = \$reclen;
 732
 733                 my $io = $UncompressClass->new($name);
 734                 is $., 0;
 735                 is $io->input_line_number, 0;
 736
 737                 ok ! $io->eof;
 738                 my @lines = $io->getlines();
 739                 is $., $expected_records;
 740                 is $io->input_line_number, $expected_records;
 741                 ok $io->eof;
 742                 is @lines, $expected_records,
 743                     "Got $expected_records records\n" ;
 744                 ok $lines[0] eq substr($str, 0, $reclen)
 745                     or print "# $lines[0]\n";
 746                 ok $lines[1] eq substr($str, $reclen, $reclen);
 747             }
 748
 749             {
 750                 local $/ = "is";
 751                 my $io = $UncompressClass->new($name);
 752                 my @lines = ();
 753                 my $no = 0;
 754                 my $err = 0;
 755                 ok ! $io->eof;
 756                 while (my $a = $io->getline()) {
 757                     push(@lines, $a);
 758                     $err++ if $. != ++$no;
 759                 }
 760
 761                 ok $err == 0 ;
 762                 ok $io->eof;
 763
 764                 is $., 3;
 765                 is $io->input_line_number, 3;
 766                 ok @lines == 3
 767                     or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
 768                 ok join("-", @lines) eq
 769                                  "This- is- an example\n" .
 770                                 "of a paragraph\n\n\n" .
 771                                 "and a single line.\n\n";
 772             }
 773
 774
 775             # Test read
 776
 777             {
 778                 my $io = $UncompressClass->new($name);
 779
 780
 781                 eval { $io->read(1) } ;
 782                 like $@, mkErr("buffer parameter is read-only");
 783
 784                 is $io->read($buf, 0), 0, "Requested 0 bytes" ;
 785
 786                 is $io->read($buf, 3), 3 ;
 787                 is $buf, "Thi";
 788
 789                 is $io->sysread($buf, 3, 2), 3 ;
 790                 is $buf, "Ths i"
 791                     or print "# [$buf]\n" ;;
 792                 ok ! $io->eof;
 793
 794         #        $io->seek(-4, 2);
 795         #
 796         #        ok ! $io->eof;
 797         #
 798         #        ok read($io, $buf, 20) == 4 ;
 799         #        ok $buf eq "e.\n\n";
 800         #
 801         #        ok read($io, $buf, 20) == 0 ;
 802         #        ok $buf eq "";
 803         #
 804         #        ok ! $io->eof;
 805             }
 806
 807         }
 808
 809         {
 810             # Read from non-compressed file
 811
 812             my $str = <<EOT;
 813 This is an example
 814 of a paragraph
 815
 816
 817 and a single line.
 818
 819 EOT
 820
 821             my $lex = new LexFile my $name ;
 822
 823             writeFile($name, $str);
 824             my @tmp;
 825             my $buf;
 826             {
 827                 my $io = new $UncompressClass $name, -Transparent => 1 ;
 828
 829                 ok defined $io;
 830                 ok ! $io->eof;
 831                 ok $io->tell() == 0 ;
 832                 my @lines = $io->getlines();
 833                 is @lines, 6;
 834                 ok $lines[1] eq "of a paragraph\n" ;
 835                 ok join('', @lines) eq $str ;
 836                 is $., 6;
 837                 is $io->input_line_number, 6;
 838                 ok $io->tell() == length($str) ;
 839
 840                 ok $io->eof;
 841
 842                 ok ! ( defined($io->getline)  ||
 843                           (@tmp = $io->getlines) ||
 844                           defined($io->getline)         ||
 845                           defined($io->getc)     ||
 846                           $io->read($buf, 100)   != 0) ;
 847             }
 848
 849
 850             {
 851                 local $/;  # slurp mode
 852                 my $io = $UncompressClass->new($name);
 853                 ok ! $io->eof;
 854                 my @lines = $io->getlines;
 855                 is $., 1;
 856                 is $io->input_line_number, 1;
 857                 ok $io->eof;
 858                 ok @lines == 1 && $lines[0] eq $str;
 859
 860                 $io = $UncompressClass->new($name);
 861                 ok ! $io->eof;
 862                 my $line = $io->getline;
 863                 is $., 1;
 864                 is $io->input_line_number, 1;
 865                 ok $line eq $str;
 866                 ok $io->eof;
 867             }
 868
 869             {
 870                 local $/ = "";  # paragraph mode
 871                 my $io = $UncompressClass->new($name);
 872                 ok ! $io->eof;
 873                 my @lines = $io->getlines;
 874                 is $., 2;
 875                 is $io->input_line_number, 2;
 876                 ok $io->eof;
 877                 ok @lines == 2
 878                     or print "# exected 2 lines, got " . scalar(@lines) . "\n";
 879                 ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 880                     or print "# [$lines[0]]\n" ;
 881                 ok $lines[1] eq "and a single line.\n\n";
 882             }
 883
 884             {
 885                 # Record mode
 886                 my $reclen = 7 ;
 887                 my $expected_records = int(length($str) / $reclen)
 888                                         + (length($str) % $reclen ? 1 : 0);
 889                 local $/ = \$reclen;
 890
 891                 my $io = $UncompressClass->new($name);
 892                 is $., 0;
 893                 is $io->input_line_number, 0;
 894
 895                 ok ! $io->eof;
 896                 my @lines = $io->getlines();
 897                 is $., $expected_records;
 898                 is $io->input_line_number, $expected_records;
 899                 ok $io->eof;
 900                 is @lines, $expected_records,
 901                     "Got $expected_records records\n" ;
 902                 ok $lines[0] eq substr($str, 0, $reclen)
 903                     or print "# $lines[0]\n";
 904                 ok $lines[1] eq substr($str, $reclen, $reclen);
 905             }
 906
 907             {
 908                 local $/ = "is";
 909                 my $io = $UncompressClass->new($name);
 910                 my @lines = ();
 911                 my $no = 0;
 912                 my $err = 0;
 913                 ok ! $io->eof;
 914                 while (my $a = $io->getline) {
 915                     push(@lines, $a);
 916                     $err++ if $. != ++$no;
 917                 }
 918
 919                 is $., 3;
 920                 is $io->input_line_number, 3;
 921                 ok $err == 0 ;
 922                 ok $io->eof;
 923
 924
 925                 ok @lines == 3 ;
 926                 ok join("-", @lines) eq
 927                                  "This- is- an example\n" .
 928                                 "of a paragraph\n\n\n" .
 929                                 "and a single line.\n\n";
 930             }
 931
 932
 933             # Test read
 934
 935             {
 936                 my $io = $UncompressClass->new($name);
 937
 938                 ok $io->read($buf, 3) == 3 ;
 939                 ok $buf eq "Thi";
 940
 941                 ok $io->sysread($buf, 3, 2) == 3 ;
 942                 ok $buf eq "Ths i";
 943                 ok ! $io->eof;
 944
 945         #        $io->seek(-4, 2);
 946         #
 947         #        ok ! $io->eof;
 948         #
 949         #        ok read($io, $buf, 20) == 4 ;
 950         #        ok $buf eq "e.\n\n";
 951         #
 952         #        ok read($io, $buf, 20) == 0 ;
 953         #        ok $buf eq "";
 954         #
 955         #        ok ! $io->eof;
 956             }
 957
 958
 959         }
 960
 961         {
 962             # Vary the length parameter in a read
 963
 964             my $str = <<EOT;
 965 x
 966 x
 967 This is an example
 968 of a paragraph
 969
 970
 971 and a single line.
 972
 973 EOT
 974             $str = $str x 100 ;
 975
 976
 977             foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
 978             {
 979                 foreach my $trans (0, 1)
 980                 {
 981                     foreach my $append (0, 1)
 982                     {
 983                         title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
 984
 985                         my $lex = new LexFile my $name ;
 986
 987                         if ($trans) {
 988                             writeFile($name, $str) ;
 989                         }
 990                         else {
 991                             my $iow = new $CompressClass $name;
 992                             $iow->print($str) ;
 993                             $iow->close ;
 994                         }
 995
 996
 997                         my $io = $UncompressClass->new($name,
 998                                                        -Append => $append,
 999                                                        -Transparent  => $trans);
1000
1001                         my $buf;
1002
1003                         is $io->tell(), 0;
1004
1005                         if ($append) {
1006                             1 while $io->read($buf, $bufsize) > 0;
1007                         }
1008                         else {
1009                             my $tmp ;
1010                             $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
1011                         }
1012                         is length $buf, length $str;
1013                         ok $buf eq $str ;
1014                         ok ! $io->error() ;
1015                         ok $io->eof;
1016                     }
1017                 }
1018             }
1019         }
1020
1021         foreach my $file (0, 1)
1022         {
1023             foreach my $trans (0, 1)
1024             {
1025                 title "seek tests - file $file trans $trans" ;
1026
1027                 my $buffer ;
1028                 my $buff ;
1029                 my $lex = new LexFile my $name ;
1030
1031                 my $first = "beginning" ;
1032                 my $last  = "the end" ;
1033
1034                 if ($trans)
1035                 {
1036                     $buffer = $first . "\x00" x 10 . $last;
1037                     writeFile($name, $buffer);
1038                 }
1039                 else
1040                 {
1041                     my $output ;
1042                     if ($file)
1043                     {
1044                         $output = $name ;
1045                     }
1046                     else
1047                     {
1048                         $output = \$buffer;
1049                     }
1050
1051                     my $iow = new $CompressClass $output ;
1052                     $iow->print($first) ;
1053                     ok $iow->seek(5, SEEK_CUR) ;
1054                     ok $iow->tell() == length($first)+5;
1055                     ok $iow->seek(0, SEEK_CUR) ;
1056                     ok $iow->tell() == length($first)+5;
1057                     ok $iow->seek(length($first)+10, SEEK_SET) ;
1058                     ok $iow->tell() == length($first)+10;
1059
1060                     $iow->print($last) ;
1061                     $iow->close ;
1062                 }
1063
1064                 my $input ;
1065                 if ($file)
1066                 {
1067                     $input = $name ;
1068                 }
1069                 else
1070                 {
1071                     $input = \$buffer ;
1072                 }
1073
1074                 ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ;
1075
1076                 my $io = $UncompressClass->new($input, Strict => 1);
1077                 ok $io->seek(length($first), SEEK_CUR)
1078                     or diag $$UnError ;
1079                 ok ! $io->eof;
1080                 is $io->tell(), length($first);
1081
1082                 ok $io->read($buff, 5) ;
1083                 is $buff, "\x00" x 5 ;
1084                 is $io->tell(), length($first) + 5;
1085
1086                 ok $io->seek(0, SEEK_CUR) ;
1087                 my $here = $io->tell() ;
1088                 is $here, length($first)+5;
1089
1090                 ok $io->seek($here+5, SEEK_SET) ;
1091                 is $io->tell(), $here+5 ;
1092                 ok $io->read($buff, 100) ;
1093                 ok $buff eq $last ;
1094                 ok $io->eof;
1095             }
1096         }
1097
1098         {
1099             title "seek error cases" ;
1100
1101             my $b ;
1102             my $a = new $CompressClass(\$b)  ;
1103
1104             ok ! $a->error() ;
1105             eval { $a->seek(-1, 10) ; };
1106             like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter");
1107
1108             eval { $a->seek(-1, SEEK_END) ; };
1109             like $@, mkErr("^${CompressClass}::seek: cannot seek backwards");
1110
1111             $a->write("fred");
1112             $a->close ;
1113
1114
1115             my $u = new $UncompressClass(\$b)  ;
1116
1117             eval { $u->seek(-1, 10) ; };
1118             like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter");
1119
1120             eval { $u->seek(-1, SEEK_END) ; };
1121             like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed");
1122
1123             eval { $u->seek(-1, SEEK_CUR) ; };
1124             like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards");
1125         }
1126
1127         foreach my $fb (qw(filename buffer filehandle))
1128         {
1129             foreach my $append (0, 1)
1130             {
1131                 {
1132                     title "$CompressClass -- Append $append, Output to $fb" ;
1133
1134                     my $lex = new LexFile my $name ;
1135
1136                     my $already = 'already';
1137                     my $buffer = $already;
1138                     my $output;
1139
1140                     if ($fb eq 'buffer')
1141                       { $output = \$buffer }
1142                     elsif ($fb eq 'filename')
1143                     {
1144                         $output = $name ;
1145                         writeFile($name, $buffer);
1146                     }
1147                     elsif ($fb eq 'filehandle')
1148                     {
1149                         $output = new IO::File ">$name" ;
1150                         print $output $buffer;
1151                     }
1152
1153                     my $a = new $CompressClass($output, Append => $append)  ;
1154                     ok $a, "  Created $CompressClass";
1155                     my $string = "appended";
1156                     $a->write($string);
1157                     $a->close ;
1158
1159                     my $data ;
1160                     if ($fb eq 'buffer')
1161                     {
1162                         $data = $buffer;
1163                     }
1164                     else
1165                     {
1166                         $output->close
1167                             if $fb eq 'filehandle';
1168                         $data = readFile($name);
1169                     }
1170
1171                     if ($append || $fb eq 'filehandle')
1172                     {
1173                         is substr($data, 0, length($already)), $already, "  got prefix";
1174                         substr($data, 0, length($already)) = '';
1175                     }
1176
1177
1178                     my $uncomp;
1179                     my $x = new $UncompressClass(\$data, Append => 1)  ;
1180                     ok $x, "  created $UncompressClass";
1181
1182                     my $len ;
1183                     1 while ($len = $x->read($uncomp)) > 0 ;
1184
1185                     $x->close ;
1186                     is $uncomp, $string, '  Got uncompressed data' ;
1187
1188                 }
1189             }
1190         }
1191
1192         foreach my $type (qw(buffer filename filehandle))
1193         {
1194             foreach my $good (0, 1)
1195             {
1196                 title "$UncompressClass -- InputLength, read from $type, good data => $good";
1197
1198                 my $compressed ;
1199                 my $string = "some data";
1200                 my $appended = "append";
1201
1202                 if ($good)
1203                 {
1204                     my $c = new $CompressClass(\$compressed);
1205                     $c->write($string);
1206                     $c->close();
1207                 }
1208                 else
1209                 {
1210                     $compressed = $string ;
1211                 }
1212
1213                 my $comp_len = length $compressed;
1214                 $compressed .= $appended;
1215
1216                 my $lex = new LexFile my $name ;
1217                 my $input ;
1218                 writeFile ($name, $compressed);
1219
1220                 if ($type eq 'buffer')
1221                 {
1222                     $input = \$compressed;
1223                 }
1224                 if ($type eq 'filename')
1225                 {
1226                     $input = $name;
1227                 }
1228                 elsif ($type eq 'filehandle')
1229                 {
1230                     my $fh = new IO::File "<$name" ;
1231                     ok $fh, "opened file $name ok";
1232                     $input = $fh ;
1233                 }
1234
1235                 my $x = new $UncompressClass($input,
1236                                              InputLength => $comp_len,
1237                                              Transparent => 1)  ;
1238                 ok $x, "  created $UncompressClass";
1239
1240                 my $len ;
1241                 my $output;
1242                 $len = $x->read($output, 100);
1243
1244                 is $len, length($string);
1245                 is $output, $string;
1246
1247                 if ($type eq 'filehandle')
1248                 {
1249                     my $rest ;
1250                     $input->read($rest, 1000);
1251                     is $rest, $appended;
1252                 }
1253             }
1254
1255
1256         }
1257
1258         foreach my $append (0, 1)
1259         {
1260             title "$UncompressClass -- Append $append" ;
1261
1262             my $lex = new LexFile my $name ;
1263
1264             my $string = "appended";
1265             my $compressed ;
1266             my $c = new $CompressClass(\$compressed);
1267             $c->write($string);
1268             $c->close();
1269
1270             my $x = new $UncompressClass(\$compressed, Append => $append)  ;
1271             ok $x, "  created $UncompressClass";
1272
1273             my $already = 'already';
1274             my $output = $already;
1275
1276             my $len ;
1277             $len = $x->read($output, 100);
1278             is $len, length($string);
1279
1280             $x->close ;
1281
1282             if ($append)
1283             {
1284                 is substr($output, 0, length($already)), $already, "  got prefix";
1285                 substr($output, 0, length($already)) = '';
1286             }
1287             is $output, $string, '  Got uncompressed data' ;
1288         }
1289
1290
1291         foreach my $file (0, 1)
1292         {
1293             foreach my $trans (0, 1)
1294             {
1295                 title "ungetc, File $file, Transparent $trans" ;
1296
1297                 my $lex = new LexFile my $name ;
1298
1299                 my $string = 'abcdeABCDE';
1300                 my $b ;
1301                 if ($trans)
1302                 {
1303                     $b = $string ;
1304                 }
1305                 else
1306                 {
1307                     my $a = new $CompressClass(\$b)  ;
1308                     $a->write($string);
1309                     $a->close ;
1310                 }
1311
1312                 my $from ;
1313                 if ($file)
1314                 {
1315                     writeFile($name, $b);
1316                     $from = $name ;
1317                 }
1318                 else
1319                 {
1320                     $from = \$b ;
1321                 }
1322
1323                 my $u = $UncompressClass->new($from, Transparent => 1)  ;
1324                 my $first;
1325                 my $buff ;
1326
1327                 # do an ungetc before reading
1328                 $u->ungetc("X");
1329                 $first = $u->getc();
1330                 is $first, 'X';
1331
1332                 $first = $u->getc();
1333                 is $first, substr($string, 0,1);
1334                 $u->ungetc($first);
1335                 $first = $u->getc();
1336                 is $first, substr($string, 0,1);
1337                 $u->ungetc($first);
1338
1339                 is $u->read($buff, 5), 5 ;
1340                 is $buff, substr($string, 0, 5);
1341
1342                 $u->ungetc($buff) ;
1343                 is $u->read($buff, length($string)), length($string) ;
1344                 is $buff, $string;
1345
1346                 is $u->read($buff, 1), 0;
1347                 ok $u->eof() ;
1348
1349                 my $extra = 'extra';
1350                 $u->ungetc($extra);
1351                 ok ! $u->eof();
1352                 is $u->read($buff), length($extra) ;
1353                 is $buff, $extra;
1354
1355                 is $u->read($buff, 1), 0;
1356                 ok $u->eof() ;
1357
1358                 # getc returns undef on eof
1359                 is $u->getc(), undef;
1360                 $u->close();
1361
1362             }
1363         }
1364
1365
1366         {
1367             title "write tests - invalid data" ;
1368
1369             #my $lex = new LexFile my $name1 ;
1370             my($Answer);
1371
1372             #ok ! -e $name1, "  File $name1 does not exist";
1373
1374             my @data = (
1375                 [ '{ }',         "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1376                 [ '[ { } ]',     "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1377                 [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1378                 [ '[ "" ]',      "${CompressClass}::write: input filename is undef or null string" ],
1379                 [ '[ undef ]',   "${CompressClass}::write: input filename is undef or null string" ],
1380                 [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ],
1381                 #[ "not readable", 'xx' ],
1382                 # same filehandle twice, 'xx'
1383                ) ;
1384
1385             foreach my $data (@data)
1386             {
1387                 my ($send, $get) = @$data ;
1388                 title "${CompressClass}::write( $send )";
1389                 my($copy);
1390                 eval "\$copy = $send";
1391                 my $x = new $CompressClass(\$Answer);
1392                 ok $x, "  Created $CompressClass object";
1393                 eval { $x->write($copy) } ;
1394                 #like $@, "/^$get/", "  error - $get";
1395                 like $@, "/not a scalar reference /", "  error - not a scalar reference";
1396             }
1397
1398     #        @data = (
1399     #            [ '[ $name1 ]',  "input file '$name1' does not exist" ],
1400     #            #[ "not readable", 'xx' ],
1401     #            # same filehandle twice, 'xx'
1402     #           ) ;
1403     #
1404     #        foreach my $data (@data)
1405     #        {
1406     #            my ($send, $get) = @$data ;
1407     #            title "${CompressClass}::write( $send )";
1408     #            my $copy;
1409     #            eval "\$copy = $send";
1410     #            my $x = new $CompressClass(\$Answer);
1411     #            ok $x, "  Created $CompressClass object";
1412     #            ok ! $x->write($copy), "  write fails"  ;
1413     #            like $$Error, "/^$get/", "  error - $get";
1414     #        }
1415
1416             #exit;
1417
1418         }
1419
1420
1421     #    sub deepCopy
1422     #    {
1423     #        if (! ref $_[0] || ref $_[0] eq 'SCALAR')
1424     #        {
1425     #            return $_[0] ;
1426     #        }
1427     #
1428     #        if (ref $_[0] eq 'ARRAY')
1429     #        {
1430     #            my @a ;
1431     #            for my $x ( @{ $_[0] })
1432     #            {
1433     #                push @a, deepCopy($x);
1434     #            }
1435     #
1436     #            return \@a ;
1437     #        }
1438     #
1439     #        croak "bad! $_[0]";
1440     #
1441     #    }
1442     #
1443     #    sub deepSubst
1444     #    {
1445     #        #my $data = shift ;
1446     #        my $from = $_[1] ;
1447     #        my $to   = $_[2] ;
1448     #
1449     #        if (! ref $_[0])
1450     #        {
1451     #            $_[0] = $to
1452     #                if $_[0] eq $from ;
1453     #            return ;
1454     #
1455     #        }
1456     #
1457     #        if (ref $_[0] eq 'SCALAR')
1458     #        {
1459     #            $_[0] = \$to
1460     #                if defined ${ $_[0] } && ${ $_[0] } eq $from ;
1461     #            return ;
1462     #
1463     #        }
1464     #
1465     #        if (ref $_[0] eq 'ARRAY')
1466     #        {
1467     #            for my $x ( @{ $_[0] })
1468     #            {
1469     #                deepSubst($x, $from, $to);
1470     #            }
1471     #            return ;
1472     #        }
1473     #        #croak "bad! $_[0]";
1474     #    }
1475
1476     #    {
1477     #        title "More write tests" ;
1478     #
1479     #        my $file1 = "file1" ;
1480     #        my $file2 = "file2" ;
1481     #        my $file3 = "file3" ;
1482     #        my $lex = new LexFile $file1, $file2, $file3 ;
1483     #
1484     #        writeFile($file1, "F1");
1485     #        writeFile($file2, "F2");
1486     #        writeFile($file3, "F3");
1487     #
1488     #        my @data = (
1489     #              [ '""',                                   ""      ],
1490     #              [ 'undef',                                ""      ],
1491     #              [ '"abcd"',                               "abcd"  ],
1492     #
1493     #              [ '\""',                                   ""     ],
1494     #              [ '\undef',                                ""     ],
1495     #              [ '\"abcd"',                               "abcd" ],
1496     #
1497     #              [ '[]',                                    ""     ],
1498     #              [ '[[]]',                                  ""     ],
1499     #              [ '[[[]]]',                                ""     ],
1500     #              [ '[\""]',                                 ""     ],
1501     #              [ '[\undef]',                              ""     ],
1502     #              [ '[\"abcd"]',                             "abcd" ],
1503     #              [ '[\"ab", \"cd"]',                        "abcd" ],
1504     #              [ '[[\"ab"], [\"cd"]]',                    "abcd" ],
1505     #
1506     #              [ '$file1',                                $file1 ],
1507     #              [ '$fh2',                                  "F2"   ],
1508     #              [ '[$file1, \"abc"]',                      "F1abc"],
1509     #              [ '[\"a", $file1, \"bc"]',                 "aF1bc"],
1510     #              [ '[\"a", $fh1, \"bc"]',                   "aF1bc"],
1511     #              [ '[\"a", $fh1, \"bc", $file2]',           "aF1bcF2"],
1512     #              [ '[\"a", $fh1, \"bc", $file2, $fh3]',     "aF1bcF2F3"],
1513     #            ) ;
1514     #
1515     #
1516     #        foreach my $data (@data)
1517     #        {
1518     #            my ($send, $get) = @$data ;
1519     #
1520     #            my $fh1 = new IO::File "< $file1" ;
1521     #            my $fh2 = new IO::File "< $file2" ;
1522     #            my $fh3 = new IO::File "< $file3" ;
1523     #
1524     #            title "${CompressClass}::write( $send )";
1525     #            my $copy;
1526     #            eval "\$copy = $send";
1527     #            my $Answer ;
1528     #            my $x = new $CompressClass(\$Answer);
1529     #            ok $x, "  Created $CompressClass object";
1530     #            my $len = length $get;
1531     #            is $x->write($copy), length($get), "  write $len bytes";
1532     #            ok $x->close(), "  close ok" ;
1533     #
1534     #            is myGZreadFile(\$Answer), $get, "  got expected output" ;
1535     #            cmp_ok $$Error, '==', 0, "  no error";
1536     #
1537     #
1538     #        }
1539     #
1540     #    }
1541     }
1542
1543 }
1544
1545 1;
1546
1547
1548
1549
1550