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

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