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