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