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