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