t/lib/compress/newtied.pl

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