1b39c5158Smillertuse lib 't'; 2b39c5158Smillertuse strict; 3b39c5158Smillertuse warnings; 4b39c5158Smillertuse bytes; 5b39c5158Smillert 6b39c5158Smillertuse Test::More ; 7b39c5158Smillertuse CompTestUtils; 8b39c5158Smillert 9b39c5158Smillertour ($BadPerl, $UncompressClass); 10b39c5158Smillert 11b39c5158SmillertBEGIN 12b39c5158Smillert{ 13b39c5158Smillert plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) 14b39c5158Smillert if $] < 5.006 ; 15b39c5158Smillert 16b39c5158Smillert my $tests ; 17b39c5158Smillert 18b39c5158Smillert $BadPerl = ($] >= 5.006 and $] <= 5.008) ; 19b39c5158Smillert 20b39c5158Smillert if ($BadPerl) { 21b39c5158Smillert $tests = 78 ; 22b39c5158Smillert } 23b39c5158Smillert else { 24b39c5158Smillert $tests = 84 ; 25b39c5158Smillert } 26b39c5158Smillert 27b39c5158Smillert # use Test::NoWarnings, if available 28b39c5158Smillert my $extra = 0 ; 29b39c5158Smillert $extra = 1 30b39c5158Smillert if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; 31b39c5158Smillert 32b39c5158Smillert plan tests => $tests + $extra ; 33b39c5158Smillert 34b39c5158Smillert} 35b39c5158Smillert 36b39c5158Smillert 37b39c5158Smillertuse IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); 38b39c5158Smillert 39b39c5158Smillert 40b39c5158Smillert 41b39c5158Smillertsub myGZreadFile 42b39c5158Smillert{ 43b39c5158Smillert my $filename = shift ; 44b39c5158Smillert my $init = shift ; 45b39c5158Smillert 46b39c5158Smillert 47*256a93a4Safresh1 my $fil = $UncompressClass->can('new')->( $UncompressClass, $filename, 48b39c5158Smillert -Strict => 1, 49b39c5158Smillert -Append => 1 50*256a93a4Safresh1 ); 51b39c5158Smillert 52b39c5158Smillert my $data ; 53b39c5158Smillert $data = $init if defined $init ; 54b39c5158Smillert 1 while $fil->read($data) > 0; 55b39c5158Smillert 56b39c5158Smillert $fil->close ; 57b39c5158Smillert return $data ; 58b39c5158Smillert} 59b39c5158Smillert 60b39c5158Smillert 61b39c5158Smillertsub run 62b39c5158Smillert{ 63b39c5158Smillert 64b39c5158Smillert my $CompressClass = identify(); 65b39c5158Smillert $UncompressClass = getInverse($CompressClass); 66b39c5158Smillert my $Error = getErrorRef($CompressClass); 67b39c5158Smillert my $UnError = getErrorRef($UncompressClass); 68b39c5158Smillert 69b39c5158Smillert { 70b39c5158Smillert title "Testing $CompressClass and $UncompressClass"; 71b39c5158Smillert 72b39c5158Smillert 73b39c5158Smillert 74b39c5158Smillert { 75b39c5158Smillert # Write 76b39c5158Smillert # these tests come almost 100% from IO::String 77b39c5158Smillert 78*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 79b39c5158Smillert 80b39c5158Smillert my $io = $CompressClass->new($name); 81b39c5158Smillert 82b39c5158Smillert is tell($io), 0 ; 83b39c5158Smillert is $io->tell(), 0 ; 84b39c5158Smillert 85b39c5158Smillert my $heisan = "Heisan\n"; 86b39c5158Smillert print $io $heisan ; 87b39c5158Smillert 88b39c5158Smillert ok ! eof($io); 89b39c5158Smillert ok ! $io->eof(); 90b39c5158Smillert 91b39c5158Smillert is tell($io), length($heisan) ; 92b39c5158Smillert is $io->tell(), length($heisan) ; 93b39c5158Smillert 94b39c5158Smillert $io->print("a", "b", "c"); 95b39c5158Smillert 96b39c5158Smillert { 97b39c5158Smillert local($\) = "\n"; 98b39c5158Smillert print $io "d", "e"; 99b39c5158Smillert local($,) = ","; 100b39c5158Smillert print $io "f", "g", "h"; 101b39c5158Smillert } 102b39c5158Smillert 103b39c5158Smillert my $foo = "1234567890"; 104b39c5158Smillert 105b39c5158Smillert ok syswrite($io, $foo, length($foo)) == length($foo) ; 106b39c5158Smillert if ( $] < 5.6 ) 107b39c5158Smillert { is $io->syswrite($foo, length $foo), length $foo } 108b39c5158Smillert else 109b39c5158Smillert { is $io->syswrite($foo), length $foo } 110b39c5158Smillert ok $io->syswrite($foo, length($foo)) == length $foo; 111b39c5158Smillert ok $io->write($foo, length($foo), 5) == 5; 112b39c5158Smillert ok $io->write("xxx\n", 100, -1) == 1; 113b39c5158Smillert 114b39c5158Smillert for (1..3) { 115b39c5158Smillert printf $io "i(%d)", $_; 116b39c5158Smillert $io->printf("[%d]\n", $_); 117b39c5158Smillert } 118b39c5158Smillert select $io; 119b39c5158Smillert print "\n"; 120b39c5158Smillert select STDOUT; 121b39c5158Smillert 122b39c5158Smillert close $io ; 123b39c5158Smillert 124b39c5158Smillert ok eof($io); 125b39c5158Smillert ok $io->eof(); 126b39c5158Smillert 127b39c5158Smillert is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" . 128b39c5158Smillert ("1234567890" x 3) . "67890\n" . 129b39c5158Smillert "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; 130b39c5158Smillert 131b39c5158Smillert 132b39c5158Smillert } 133b39c5158Smillert 134b39c5158Smillert { 135b39c5158Smillert # Read 136b39c5158Smillert my $str = <<EOT; 137b39c5158SmillertThis is an example 138b39c5158Smillertof a paragraph 139b39c5158Smillert 140b39c5158Smillert 141b39c5158Smillertand a single line. 142b39c5158Smillert 143b39c5158SmillertEOT 144b39c5158Smillert 145*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 146b39c5158Smillert 147*256a93a4Safresh1 my $iow = $CompressClass->can('new')->( $CompressClass, $name ); 148b39c5158Smillert print $iow $str ; 149b39c5158Smillert close $iow; 150b39c5158Smillert 151b39c5158Smillert my @tmp; 152b39c5158Smillert my $buf; 153b39c5158Smillert { 154*256a93a4Safresh1 my $io = $UncompressClass->can('new')->( $UncompressClass, $name ); 155b39c5158Smillert 156b39c5158Smillert ok ! $io->eof; 157b39c5158Smillert ok ! eof $io; 158b39c5158Smillert is $io->tell(), 0 ; 159b39c5158Smillert is tell($io), 0 ; 160b39c5158Smillert my @lines = <$io>; 161b39c5158Smillert is @lines, 6 162b39c5158Smillert or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; 163b39c5158Smillert is $lines[1], "of a paragraph\n" ; 164b39c5158Smillert is join('', @lines), $str ; 165b39c5158Smillert is $., 6; 166b39c5158Smillert #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; 167b39c5158Smillert is $io->tell(), length($str) ; 168b39c5158Smillert is tell($io), length($str) ; 169b39c5158Smillert 170b39c5158Smillert ok $io->eof; 171b39c5158Smillert ok eof $io; 172b39c5158Smillert 173b39c5158Smillert ok ! ( defined($io->getline) || 174b39c5158Smillert (@tmp = $io->getlines) || 175b39c5158Smillert defined(<$io>) || 176b39c5158Smillert defined($io->getc) || 177b39c5158Smillert read($io, $buf, 100) != 0) ; 178b39c5158Smillert } 179b39c5158Smillert 180b39c5158Smillert 181b39c5158Smillert { 182b39c5158Smillert local $/; # slurp mode 183b39c5158Smillert my $io = $UncompressClass->new($name); 184b39c5158Smillert ok ! $io->eof; 185b39c5158Smillert my @lines = $io->getlines; 186b39c5158Smillert ok $io->eof; 187b39c5158Smillert ok @lines == 1 && $lines[0] eq $str; 188b39c5158Smillert 189b39c5158Smillert $io = $UncompressClass->new($name); 190b39c5158Smillert ok ! $io->eof; 191b39c5158Smillert my $line = <$io>; 192b39c5158Smillert ok $line eq $str; 193b39c5158Smillert ok $io->eof; 194b39c5158Smillert } 195b39c5158Smillert 196b39c5158Smillert { 197b39c5158Smillert local $/ = ""; # paragraph mode 198b39c5158Smillert my $io = $UncompressClass->new($name); 199b39c5158Smillert ok ! $io->eof; 200b39c5158Smillert my @lines = <$io>; 201b39c5158Smillert ok $io->eof; 202b39c5158Smillert ok @lines == 2 203b39c5158Smillert or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; 204b39c5158Smillert ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" 205b39c5158Smillert or print "# $lines[0]\n"; 206b39c5158Smillert ok $lines[1] eq "and a single line.\n\n"; 207b39c5158Smillert } 208b39c5158Smillert 209b39c5158Smillert { 210b39c5158Smillert local $/ = "is"; 211b39c5158Smillert my $io = $UncompressClass->new($name); 212b39c5158Smillert my @lines = (); 213b39c5158Smillert my $no = 0; 214b39c5158Smillert my $err = 0; 215b39c5158Smillert ok ! $io->eof; 216b39c5158Smillert while (<$io>) { 217b39c5158Smillert push(@lines, $_); 218b39c5158Smillert $err++ if $. != ++$no; 219b39c5158Smillert } 220b39c5158Smillert 221b39c5158Smillert ok $err == 0 ; 222b39c5158Smillert ok $io->eof; 223b39c5158Smillert 224b39c5158Smillert ok @lines == 3 225b39c5158Smillert or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; 226b39c5158Smillert ok join("-", @lines) eq 227b39c5158Smillert "This- is- an example\n" . 228b39c5158Smillert "of a paragraph\n\n\n" . 229b39c5158Smillert "and a single line.\n\n"; 230b39c5158Smillert } 231b39c5158Smillert 232b39c5158Smillert 233b39c5158Smillert # Test read 234b39c5158Smillert 235b39c5158Smillert { 236b39c5158Smillert my $io = $UncompressClass->new($name); 237b39c5158Smillert 238b39c5158Smillert ok $io, "opened ok" ; 239b39c5158Smillert 240b39c5158Smillert #eval { read($io, $buf, -1); } ; 241b39c5158Smillert #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; 242b39c5158Smillert 243b39c5158Smillert #eval { read($io, 1) } ; 244b39c5158Smillert #like $@, mkErr("buffer parameter is read-only"); 245b39c5158Smillert 246b39c5158Smillert is read($io, $buf, 0), 0, "Requested 0 bytes" ; 247b39c5158Smillert 248b39c5158Smillert ok read($io, $buf, 3) == 3 ; 249b39c5158Smillert ok $buf eq "Thi"; 250b39c5158Smillert 251b39c5158Smillert ok sysread($io, $buf, 3, 2) == 3 ; 252b39c5158Smillert ok $buf eq "Ths i" 253b39c5158Smillert or print "# [$buf]\n" ;; 254b39c5158Smillert ok ! $io->eof; 255b39c5158Smillert 256b39c5158Smillert # $io->seek(-4, 2); 257b39c5158Smillert # 258b39c5158Smillert # ok ! $io->eof; 259b39c5158Smillert # 260b39c5158Smillert # ok read($io, $buf, 20) == 4 ; 261b39c5158Smillert # ok $buf eq "e.\n\n"; 262b39c5158Smillert # 263b39c5158Smillert # ok read($io, $buf, 20) == 0 ; 264b39c5158Smillert # ok $buf eq ""; 265b39c5158Smillert # 266b39c5158Smillert # ok ! $io->eof; 267b39c5158Smillert } 268b39c5158Smillert 269b39c5158Smillert } 270b39c5158Smillert 271b39c5158Smillert 272b39c5158Smillert 273b39c5158Smillert { 274b39c5158Smillert title "seek tests" ; 275b39c5158Smillert 276*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 277b39c5158Smillert 278b39c5158Smillert my $first = "beginning" ; 279b39c5158Smillert my $last = "the end" ; 280*256a93a4Safresh1 my $iow = $CompressClass->can('new')->( $CompressClass, $name ); 281b39c5158Smillert print $iow $first ; 282b39c5158Smillert ok seek $iow, 10, SEEK_CUR ; 283b39c5158Smillert is tell($iow), length($first)+10; 284b39c5158Smillert ok $iow->seek(0, SEEK_CUR) ; 285b39c5158Smillert is tell($iow), length($first)+10; 286b39c5158Smillert print $iow $last ; 287b39c5158Smillert close $iow; 288b39c5158Smillert 289b39c5158Smillert my $io = $UncompressClass->new($name); 290b39c5158Smillert ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ; 291b39c5158Smillert 292b39c5158Smillert $io = $UncompressClass->new($name); 293b39c5158Smillert ok seek $io, length($first)+10, SEEK_CUR ; 294b39c5158Smillert ok ! $io->eof; 295b39c5158Smillert is tell($io), length($first)+10; 296b39c5158Smillert ok seek $io, 0, SEEK_CUR ; 297b39c5158Smillert is tell($io), length($first)+10; 298b39c5158Smillert my $buff ; 299b39c5158Smillert ok read $io, $buff, 100 ; 300b39c5158Smillert ok $buff eq $last ; 301b39c5158Smillert ok $io->eof; 302b39c5158Smillert } 303b39c5158Smillert 304b39c5158Smillert if (! $BadPerl) 305b39c5158Smillert { 306b39c5158Smillert # seek error cases 307b39c5158Smillert my $b ; 308*256a93a4Safresh1 my $a = $CompressClass->can('new')->( $CompressClass, \$b) ; 309b39c5158Smillert 310b39c5158Smillert ok ! $a->error() ; 311b39c5158Smillert eval { seek($a, -1, 10) ; }; 312b39c5158Smillert like $@, mkErr("seek: unknown value, 10, for whence parameter"); 313b39c5158Smillert 314b39c5158Smillert eval { seek($a, -1, SEEK_END) ; }; 315b39c5158Smillert like $@, mkErr("cannot seek backwards"); 316b39c5158Smillert 317b39c5158Smillert print $a "fred"; 318b39c5158Smillert close $a ; 319b39c5158Smillert 320b39c5158Smillert 321*256a93a4Safresh1 my $u = $UncompressClass->can('new')->( $UncompressClass, \$b) ; 322b39c5158Smillert 323b39c5158Smillert eval { seek($u, -1, 10) ; }; 324b39c5158Smillert like $@, mkErr("seek: unknown value, 10, for whence parameter"); 325b39c5158Smillert 326b39c5158Smillert eval { seek($u, -1, SEEK_END) ; }; 327b39c5158Smillert like $@, mkErr("seek: SEEK_END not allowed"); 328b39c5158Smillert 329b39c5158Smillert eval { seek($u, -1, SEEK_CUR) ; }; 330b39c5158Smillert like $@, mkErr("cannot seek backwards"); 331b39c5158Smillert } 332b39c5158Smillert 333b39c5158Smillert { 334b39c5158Smillert title 'fileno' ; 335b39c5158Smillert 336*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 337b39c5158Smillert 338b39c5158Smillert my $hello = <<EOM ; 339b39c5158Smillerthello world 340b39c5158Smillertthis is a test 341b39c5158SmillertEOM 342b39c5158Smillert 343b39c5158Smillert { 344b39c5158Smillert my $fh ; 345*256a93a4Safresh1 ok $fh = IO::File->new( ">$name" ); 346b39c5158Smillert my $x ; 347*256a93a4Safresh1 ok $x = $CompressClass->can('new')->( $CompressClass, $fh ); 348b39c5158Smillert 349b39c5158Smillert ok $x->fileno() == fileno($fh) ; 350b39c5158Smillert ok $x->fileno() == fileno($x) ; 351b39c5158Smillert ok $x->write($hello) ; 352b39c5158Smillert ok $x->close ; 353b39c5158Smillert $fh->close() ; 354b39c5158Smillert } 355b39c5158Smillert 356b39c5158Smillert my $uncomp; 357b39c5158Smillert { 358b39c5158Smillert my $x ; 359*256a93a4Safresh1 ok my $fh1 = IO::File->new( "<$name" ); 360*256a93a4Safresh1 ok $x = $UncompressClass->can('new')->( $UncompressClass, $fh1, -Append => 1 ); 361b39c5158Smillert ok $x->fileno() == fileno $fh1 ; 362b39c5158Smillert ok $x->fileno() == fileno $x ; 363b39c5158Smillert 364b39c5158Smillert 1 while $x->read($uncomp) > 0 ; 365b39c5158Smillert 366b39c5158Smillert ok $x->close ; 367b39c5158Smillert } 368b39c5158Smillert 369b39c5158Smillert ok $hello eq $uncomp ; 370b39c5158Smillert } 371b39c5158Smillert } 372b39c5158Smillert} 373b39c5158Smillert 374b39c5158Smillert1; 375