ext/Compress/Zlib/t/21newtied.t

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