1 2use strict; 3use warnings; 4use bytes; 5 6use Test::More ; 7use CompTestUtils; 8 9use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); 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 => 666 + $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 sometines 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; 681 is $io->input_line_number, 0; 682 ok ! $io->eof; 683 my @lines = $io->getlines; 684 is $., 1; 685 is $io->input_line_number, 1; 686 ok $io->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 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 ok defined $io; 843 ok ! $io->eof; 844 ok $io->tell() == 0 ; 845 my @lines = $io->getlines(); 846 is @lines, 6; 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 ok $line eq $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 "# exected 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 15851; 1586 1587 1588 1589 1590 1591