t/lib/compress/tied.pl

   1
   2 use lib 't';
   3 use strict;
   4 use warnings;
   5 use bytes;
   6
   7 use Test::More ;
   8 use CompTestUtils;
   9
  10 our ($BadPerl, $UncompressClass);
  11
  12 BEGIN
  13 {
  14     plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" )
  15         if $] < 5.005 ;
  16
  17     # use Test::NoWarnings, if available
  18     my $extra = 0 ;
  19     $extra = 1
  20         if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };
  21
  22     my $tests ;
  23     $BadPerl = ($] >= 5.006 and $] <= 5.008) ;
  24
  25     if ($BadPerl) {
  26         $tests = 242 ;
  27     }
  28     else {
  29         $tests = 250 ;
  30     }
  31
  32     plan tests => $tests + $extra ;
  33
  34     use_ok('Compress::Raw::Zlib') ;
  35
  36 }
  37
  38
  39 use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
  40
  41
  42
  43 sub myGZreadFile
  44 {
  45     my $filename = shift ;
  46     my $init = shift ;
  47
  48
  49     my $fil = new $UncompressClass $filename,
  50                                     -Strict   => 1,
  51                                     -Append   => 1
  52                                     ;
  53
  54     my $data ;
  55     $data = $init if defined $init ;
  56     1 while $fil->read($data) > 0;
  57
  58     $fil->close ;
  59     return $data ;
  60 }
  61
  62 sub run
  63 {
  64
  65     my $CompressClass   = identify();
  66     $UncompressClass = getInverse($CompressClass);
  67     my $Error           = getErrorRef($CompressClass);
  68     my $UnError         = getErrorRef($UncompressClass);
  69
  70     {
  71         next if $BadPerl ;
  72
  73
  74         title "Testing $CompressClass";
  75
  76
  77         my $x ;
  78         my $gz = new $CompressClass(\$x);
  79
  80         my $buff ;
  81
  82         eval { getc($gz) } ;
  83         like $@, mkErr("^getc Not Available: File opened only for output");
  84
  85         eval { read($gz, $buff, 1) } ;
  86         like $@, mkErr("^read Not Available: File opened only for output");
  87
  88         eval { <$gz>  } ;
  89         like $@, mkErr("^readline Not Available: File opened only for output");
  90
  91     }
  92
  93     {
  94         next if $BadPerl;
  95         $UncompressClass = getInverse($CompressClass);
  96
  97         title "Testing $UncompressClass";
  98
  99         my $gc ;
 100         my $guz = new $CompressClass(\$gc);
 101         $guz->write("abc") ;
 102         $guz->close();
 103
 104         my $x ;
 105         my $gz = new $UncompressClass(\$gc);
 106
 107         my $buff ;
 108
 109         eval { print $gz "abc" } ;
 110         like $@, mkErr("^print Not Available: File opened only for intput");
 111
 112         eval { printf $gz "fmt", "abc" } ;
 113         like $@, mkErr("^printf Not Available: File opened only for intput");
 114
 115         #eval { write($gz, $buff, 1) } ;
 116         #like $@, mkErr("^write Not Available: File opened only for intput");
 117
 118     }
 119
 120     {
 121         $UncompressClass = getInverse($CompressClass);
 122
 123         title "Testing $CompressClass and $UncompressClass";
 124
 125
 126         {
 127             # Write
 128             # these tests come almost 100% from IO::String
 129
 130             my $lex = new LexFile my $name ;
 131
 132             my $io = $CompressClass->new($name);
 133
 134             is $io->tell(), 0 ;
 135
 136             my $heisan = "Heisan\n";
 137             print $io $heisan ;
 138
 139             ok ! $io->eof;
 140
 141             is $io->tell(), length($heisan) ;
 142
 143             print($io "a", "b", "c");
 144
 145             {
 146                 local($\) = "\n";
 147                 print $io "d", "e";
 148                 local($,) = ",";
 149                 print $io "f", "g", "h";
 150             }
 151
 152             my $foo = "1234567890";
 153
 154             ok syswrite($io, $foo, length($foo)) == length($foo) ;
 155             if ( $[ < 5.6 )
 156               { is $io->syswrite($foo, length $foo), length $foo }
 157             else
 158               { is $io->syswrite($foo), length $foo }
 159             ok $io->syswrite($foo, length($foo)) == length $foo;
 160             ok $io->write($foo, length($foo), 5) == 5;
 161             ok $io->write("xxx\n", 100, -1) == 1;
 162
 163             for (1..3) {
 164                 printf $io "i(%d)", $_;
 165                 $io->printf("[%d]\n", $_);
 166             }
 167             select $io;
 168             print "\n";
 169             select STDOUT;
 170
 171             close $io ;
 172
 173             ok $io->eof;
 174
 175             is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
 176                                     ("1234567890" x 3) . "67890\n" .
 177                                         "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
 178
 179
 180         }
 181
 182         {
 183             # Read
 184             my $str = <<EOT;
 185 This is an example
 186 of a paragraph
 187
 188
 189 and a single line.
 190
 191 EOT
 192
 193             my $lex = new LexFile my $name ;
 194
 195             my $iow = new $CompressClass $name ;
 196             print $iow $str ;
 197             close $iow;
 198
 199             my @tmp;
 200             my $buf;
 201             {
 202                 my $io = new $UncompressClass $name ;
 203
 204                 ok ! $io->eof;
 205                 is $io->tell(), 0 ;
 206                 my @lines = <$io>;
 207                 is @lines, 6
 208                     or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
 209                 is $lines[1], "of a paragraph\n" ;
 210                 is join('', @lines), $str ;
 211                 is $., 6;
 212                 is $io->tell(), length($str) ;
 213
 214                 ok $io->eof;
 215
 216                 ok ! ( defined($io->getline)  ||
 217                           (@tmp = $io->getlines) ||
 218                           defined(<$io>)         ||
 219                           defined($io->getc)     ||
 220                           read($io, $buf, 100)   != 0) ;
 221             }
 222
 223
 224             {
 225                 local $/;  # slurp mode
 226                 my $io = $UncompressClass->new($name);
 227                 ok !$io->eof;
 228                 my @lines = $io->getlines;
 229                 ok $io->eof;
 230                 ok @lines == 1 && $lines[0] eq $str;
 231
 232                 $io = $UncompressClass->new($name);
 233                 ok ! $io->eof;
 234                 my $line = <$io>;
 235                 ok $line eq $str;
 236                 ok $io->eof;
 237             }
 238
 239             {
 240                 local $/ = "";  # paragraph mode
 241                 my $io = $UncompressClass->new($name);
 242                 ok ! $io->eof;
 243                 my @lines = <$io>;
 244                 ok $io->eof;
 245                 ok @lines == 2
 246                     or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
 247                 ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 248                     or print "# $lines[0]\n";
 249                 ok $lines[1] eq "and a single line.\n\n";
 250             }
 251
 252             {
 253                 local $/ = "is";
 254                 my $io = $UncompressClass->new($name);
 255                 my @lines = ();
 256                 my $no = 0;
 257                 my $err = 0;
 258                 ok ! $io->eof;
 259                 while (<$io>) {
 260                     push(@lines, $_);
 261                     $err++ if $. != ++$no;
 262                 }
 263
 264                 ok $err == 0 ;
 265                 ok $io->eof;
 266
 267                 ok @lines == 3
 268                     or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
 269                 ok join("-", @lines) eq
 270                                  "This- is- an example\n" .
 271                                 "of a paragraph\n\n\n" .
 272                                 "and a single line.\n\n";
 273             }
 274
 275
 276             # Test read
 277
 278             {
 279                 my $io = $UncompressClass->new($name);
 280
 281
 282                 if (! $BadPerl) {
 283                     eval { read($io, $buf, -1) } ;
 284                     like $@, mkErr("length parameter is negative");
 285                 }
 286
 287                 is read($io, $buf, 0), 0, "Requested 0 bytes" ;
 288
 289                 ok read($io, $buf, 3) == 3 ;
 290                 ok $buf eq "Thi";
 291
 292                 ok sysread($io, $buf, 3, 2) == 3 ;
 293                 ok $buf eq "Ths i"
 294                     or print "# [$buf]\n" ;;
 295                 ok ! $io->eof;
 296
 297         #        $io->seek(-4, 2);
 298         #
 299         #        ok ! $io->eof;
 300         #
 301         #        ok read($io, $buf, 20) == 4 ;
 302         #        ok $buf eq "e.\n\n";
 303         #
 304         #        ok read($io, $buf, 20) == 0 ;
 305         #        ok $buf eq "";
 306         #
 307         #        ok ! $io->eof;
 308             }
 309
 310         }
 311
 312         {
 313             # Read from non-compressed file
 314
 315             my $str = <<EOT;
 316 This is an example
 317 of a paragraph
 318
 319
 320 and a single line.
 321
 322 EOT
 323
 324             my $lex = new LexFile my $name ;
 325
 326             writeFile($name, $str);
 327             my @tmp;
 328             my $buf;
 329             {
 330                 my $io = new $UncompressClass $name, -Transparent => 1 ;
 331
 332                 ok defined $io;
 333                 ok ! $io->eof;
 334                 ok $io->tell() == 0 ;
 335                 my @lines = <$io>;
 336                 ok @lines == 6;
 337                 ok $lines[1] eq "of a paragraph\n" ;
 338                 ok join('', @lines) eq $str ;
 339                 ok $. == 6;
 340                 ok $io->tell() == length($str) ;
 341
 342                 ok $io->eof;
 343
 344                 ok ! ( defined($io->getline)  ||
 345                           (@tmp = $io->getlines) ||
 346                           defined(<$io>)         ||
 347                           defined($io->getc)     ||
 348                           read($io, $buf, 100)   != 0) ;
 349             }
 350
 351
 352             {
 353                 local $/;  # slurp mode
 354                 my $io = $UncompressClass->new($name);
 355                 ok ! $io->eof;
 356                 my @lines = $io->getlines;
 357                 ok $io->eof;
 358                 ok @lines == 1 && $lines[0] eq $str;
 359
 360                 $io = $UncompressClass->new($name);
 361                 ok ! $io->eof;
 362                 my $line = <$io>;
 363                 ok $line eq $str;
 364                 ok $io->eof;
 365             }
 366
 367             {
 368                 local $/ = "";  # paragraph mode
 369                 my $io = $UncompressClass->new($name);
 370                 ok ! $io->eof;
 371                 my @lines = <$io>;
 372                 ok $io->eof;
 373                 ok @lines == 2
 374                     or print "# exected 2 lines, got " . scalar(@lines) . "\n";
 375                 ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
 376                     or print "# [$lines[0]]\n" ;
 377                 ok $lines[1] eq "and a single line.\n\n";
 378             }
 379
 380             {
 381                 local $/ = "is";
 382                 my $io = $UncompressClass->new($name);
 383                 my @lines = ();
 384                 my $no = 0;
 385                 my $err = 0;
 386                 ok ! $io->eof;
 387                 while (<$io>) {
 388                     push(@lines, $_);
 389                     $err++ if $. != ++$no;
 390                 }
 391
 392                 ok $err == 0 ;
 393                 ok $io->eof;
 394
 395                 ok @lines == 3 ;
 396                 ok join("-", @lines) eq
 397                                  "This- is- an example\n" .
 398                                 "of a paragraph\n\n\n" .
 399                                 "and a single line.\n\n";
 400             }
 401
 402
 403             # Test read
 404
 405             {
 406                 my $io = $UncompressClass->new($name);
 407
 408                 ok read($io, $buf, 3) == 3 ;
 409                 ok $buf eq "Thi";
 410
 411                 ok sysread($io, $buf, 3, 2) == 3 ;
 412                 ok $buf eq "Ths i";
 413                 ok ! $io->eof;
 414
 415         #        $io->seek(-4, 2);
 416         #
 417         #        ok ! $io->eof;
 418         #
 419         #        ok read($io, $buf, 20) == 4 ;
 420         #        ok $buf eq "e.\n\n";
 421         #
 422         #        ok read($io, $buf, 20) == 0 ;
 423         #        ok $buf eq "";
 424         #
 425         #        ok ! $io->eof;
 426             }
 427
 428
 429         }
 430
 431         {
 432             # Vary the length parameter in a read
 433
 434             my $str = <<EOT;
 435 x
 436 x
 437 This is an example
 438 of a paragraph
 439
 440
 441 and a single line.
 442
 443 EOT
 444             $str = $str x 100 ;
 445
 446
 447             foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
 448             {
 449                 foreach my $trans (0, 1)
 450                 {
 451                     foreach my $append (0, 1)
 452                     {
 453                         title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
 454
 455                         my $lex = new LexFile my $name ;
 456
 457                         if ($trans) {
 458                             writeFile($name, $str) ;
 459                         }
 460                         else {
 461                             my $iow = new $CompressClass $name ;
 462                             print $iow $str ;
 463                             close $iow;
 464                         }
 465
 466
 467                         my $io = $UncompressClass->new($name,
 468                                                        -Append => $append,
 469                                                        -Transparent  => $trans);
 470
 471                         my $buf;
 472
 473                         is $io->tell(), 0;
 474
 475                         if ($append) {
 476                             1 while $io->read($buf, $bufsize) > 0;
 477                         }
 478                         else {
 479                             my $tmp ;
 480                             $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
 481                         }
 482                         is length $buf, length $str;
 483                         ok $buf eq $str ;
 484                         ok ! $io->error() ;
 485                         ok $io->eof;
 486                     }
 487                 }
 488             }
 489         }
 490
 491     }
 492 }
 493
 494 1;