cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm

   1 package CompTestUtils;
   2
   3 package main ;
   4
   5 use strict ;
   6 use warnings;
   7 use bytes;
   8
   9 #use lib qw(t t/compress);
  10
  11 use Carp ;
  12 #use Test::More ;
  13
  14
  15
  16 sub title
  17 {
  18     #diag "" ;
  19     ok 1, $_[0] ;
  20     #diag "" ;
  21 }
  22
  23 sub like_eval
  24 {
  25     like $@, @_ ;
  26 }
  27
  28 {
  29     package LexFile ;
  30
  31     our ($index);
  32     $index = '00000';
  33
  34     sub new
  35     {
  36         my $self = shift ;
  37         foreach (@_)
  38         {
  39             # autogenerate the name unless if none supplied
  40             $_ = "tst" . $index ++ . ".tmp"
  41                 unless defined $_;
  42         }
  43         chmod 0777, @_;
  44         for (@_) { 1 while unlink $_ } ;
  45         bless [ @_ ], $self ;
  46     }
  47
  48     sub DESTROY
  49     {
  50         my $self = shift ;
  51         chmod 0777, @{ $self } ;
  52         for (@$self) { 1 while unlink $_ } ;
  53     }
  54
  55 }
  56
  57 {
  58     package LexDir ;
  59
  60     use File::Path;
  61     sub new
  62     {
  63         my $self = shift ;
  64         foreach (@_) { rmtree $_ }
  65         bless [ @_ ], $self ;
  66     }
  67
  68     sub DESTROY
  69     {
  70         my $self = shift ;
  71         foreach (@$self) { rmtree $_ }
  72     }
  73 }
  74 sub readFile
  75 {
  76     my $f = shift ;
  77
  78     my @strings ;
  79
  80     if (IO::Compress::Base::Common::isaFilehandle($f))
  81     {
  82         my $pos = tell($f);
  83         seek($f, 0,0);
  84         @strings = <$f> ;
  85         seek($f, 0, $pos);
  86     }
  87     else
  88     {
  89         open (F, "<$f")
  90             or croak "Cannot open $f: $!\n" ;
  91         binmode F;
  92         @strings = <F> ;
  93         close F ;
  94     }
  95
  96     return @strings if wantarray ;
  97     return join "", @strings ;
  98 }
  99
 100 sub touch
 101 {
 102     foreach (@_) { writeFile($_, '') }
 103 }
 104
 105 sub writeFile
 106 {
 107     my($filename, @strings) = @_ ;
 108     1 while unlink $filename ;
 109     open (F, ">$filename")
 110         or croak "Cannot open $filename: $!\n" ;
 111     binmode F;
 112     foreach (@strings) {
 113         no warnings ;
 114         print F $_ ;
 115     }
 116     close F ;
 117 }
 118
 119 sub GZreadFile
 120 {
 121     my ($filename) = shift ;
 122
 123     my ($uncomp) = "" ;
 124     my $line = "" ;
 125     my $fil = gzopen($filename, "rb")
 126         or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ;
 127
 128     $uncomp .= $line
 129         while $fil->gzread($line) > 0;
 130
 131     $fil->gzclose ;
 132     return $uncomp ;
 133 }
 134
 135 sub hexDump
 136 {
 137     my $d = shift ;
 138
 139     if (IO::Compress::Base::Common::isaFilehandle($d))
 140     {
 141         $d = readFile($d);
 142     }
 143     elsif (IO::Compress::Base::Common::isaFilename($d))
 144     {
 145         $d = readFile($d);
 146     }
 147     else
 148     {
 149         $d = $$d ;
 150     }
 151
 152     my $offset = 0 ;
 153
 154     $d = '' unless defined $d ;
 155     #while (read(STDIN, $data, 16)) {
 156     while (my $data = substr($d, 0, 16)) {
 157         substr($d, 0, 16) = '' ;
 158         printf "# %8.8lx    ", $offset;
 159         $offset += 16;
 160
 161         my @array = unpack('C*', $data);
 162         foreach (@array) {
 163             printf('%2.2x ', $_);
 164         }
 165         print "   " x (16 - @array)
 166             if @array < 16 ;
 167         $data =~ tr/\0-\37\177-\377/./;
 168         print "  $data\n";
 169     }
 170
 171 }
 172
 173 sub readHeaderInfo
 174 {
 175     my $name = shift ;
 176     my %opts = @_ ;
 177
 178     my $string = <<EOM;
 179 some text
 180 EOM
 181
 182     ok my $x = new IO::Compress::Gzip $name, %opts
 183         or diag "GzipError is $IO::Compress::Gzip::GzipError" ;
 184     ok $x->write($string) ;
 185     ok $x->close ;
 186
 187     #is GZreadFile($name), $string ;
 188
 189     ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0
 190         or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ;
 191     ok my $hdr = $gunz->getHeaderInfo();
 192     my $uncomp ;
 193     ok $gunz->read($uncomp) ;
 194     ok $uncomp eq $string;
 195     ok $gunz->close ;
 196
 197     return $hdr ;
 198 }
 199
 200 sub cmpFile
 201 {
 202     my ($filename, $uue) = @_ ;
 203     return readFile($filename) eq unpack("u", $uue) ;
 204 }
 205
 206 #sub isRawFormat
 207 #{
 208 #    my $class = shift;
 209 #    # TODO -- add Lzma here?
 210 #    my %raw = map { $_ => 1 } qw( RawDeflate );
 211 #
 212 #    return defined $raw{$class};
 213 #}
 214
 215
 216
 217 my %TOP = (
 218     'IO::Uncompress::AnyInflate' => { Inverse  => 'IO::Compress::Gzip',
 219                                       Error    => 'AnyInflateError',
 220                                       TopLevel => 'anyinflate',
 221                                       Raw      => 0,
 222                             },
 223
 224     'IO::Uncompress::AnyUncompress' => { Inverse  => 'IO::Compress::Gzip',
 225                                          Error    => 'AnyUncompressError',
 226                                          TopLevel => 'anyuncompress',
 227                                          Raw      => 0,
 228                             },
 229
 230     'IO::Compress::Gzip' => { Inverse  => 'IO::Uncompress::Gunzip',
 231                               Error    => 'GzipError',
 232                               TopLevel => 'gzip',
 233                               Raw      => 0,
 234                             },
 235     'IO::Uncompress::Gunzip' => { Inverse  => 'IO::Compress::Gzip',
 236                                   Error    => 'GunzipError',
 237                                   TopLevel => 'gunzip',
 238                                   Raw      => 0,
 239                             },
 240
 241     'IO::Compress::Deflate' => { Inverse  => 'IO::Uncompress::Inflate',
 242                                  Error    => 'DeflateError',
 243                                  TopLevel => 'deflate',
 244                                  Raw      => 0,
 245                             },
 246     'IO::Uncompress::Inflate' => { Inverse  => 'IO::Compress::Deflate',
 247                                    Error    => 'InflateError',
 248                                    TopLevel => 'inflate',
 249                                    Raw      => 0,
 250                             },
 251
 252     'IO::Compress::RawDeflate' => { Inverse  => 'IO::Uncompress::RawInflate',
 253                                     Error    => 'RawDeflateError',
 254                                     TopLevel => 'rawdeflate',
 255                                     Raw      => 1,
 256                             },
 257     'IO::Uncompress::RawInflate' => { Inverse  => 'IO::Compress::RawDeflate',
 258                                       Error    => 'RawInflateError',
 259                                       TopLevel => 'rawinflate',
 260                                       Raw      => 1,
 261                             },
 262
 263     'IO::Compress::Zip' => { Inverse  => 'IO::Uncompress::Unzip',
 264                              Error    => 'ZipError',
 265                              TopLevel => 'zip',
 266                              Raw      => 0,
 267                             },
 268     'IO::Uncompress::Unzip' => { Inverse  => 'IO::Compress::Zip',
 269                                  Error    => 'UnzipError',
 270                                  TopLevel => 'unzip',
 271                                  Raw      => 0,
 272                             },
 273
 274     'IO::Compress::Bzip2' => { Inverse  => 'IO::Uncompress::Bunzip2',
 275                                Error    => 'Bzip2Error',
 276                                TopLevel => 'bzip2',
 277                                Raw      => 0,
 278                             },
 279     'IO::Uncompress::Bunzip2' => { Inverse  => 'IO::Compress::Bzip2',
 280                                    Error    => 'Bunzip2Error',
 281                                    TopLevel => 'bunzip2',
 282                                    Raw      => 0,
 283                             },
 284
 285     'IO::Compress::Lzop' => { Inverse  => 'IO::Uncompress::UnLzop',
 286                               Error    => 'LzopError',
 287                               TopLevel => 'lzop',
 288                               Raw      => 0,
 289                             },
 290     'IO::Uncompress::UnLzop' => { Inverse  => 'IO::Compress::Lzop',
 291                                   Error    => 'UnLzopError',
 292                                   TopLevel => 'unlzop',
 293                                   Raw      => 0,
 294                             },
 295
 296     'IO::Compress::Lzf' => { Inverse  => 'IO::Uncompress::UnLzf',
 297                              Error    => 'LzfError',
 298                              TopLevel => 'lzf',
 299                              Raw      => 0,
 300                             },
 301     'IO::Uncompress::UnLzf' => { Inverse  => 'IO::Compress::Lzf',
 302                                  Error    => 'UnLzfError',
 303                                  TopLevel => 'unlzf',
 304                                  Raw      => 0,
 305                             },
 306
 307     'IO::Compress::Lzma' => { Inverse  => 'IO::Uncompress::UnLzma',
 308                               Error    => 'LzmaError',
 309                               TopLevel => 'lzma',
 310                               Raw      => 1,
 311                             },
 312     'IO::Uncompress::UnLzma' => { Inverse  => 'IO::Compress::Lzma',
 313                                   Error    => 'UnLzmaError',
 314                                   TopLevel => 'unlzma',
 315                                   Raw      => 1,
 316                                 },
 317
 318     'IO::Compress::Xz' => { Inverse  => 'IO::Uncompress::UnXz',
 319                             Error    => 'XzError',
 320                             TopLevel => 'xz',
 321                             Raw      => 0,
 322                           },
 323     'IO::Uncompress::UnXz' => { Inverse  => 'IO::Compress::Xz',
 324                                 Error    => 'UnXzError',
 325                                 TopLevel => 'unxz',
 326                                 Raw      => 0,
 327                               },
 328
 329     'IO::Compress::PPMd' => { Inverse  => 'IO::Uncompress::UnPPMd',
 330                               Error    => 'PPMdError',
 331                               TopLevel => 'ppmd',
 332                               Raw      => 0,
 333                             },
 334     'IO::Uncompress::UnPPMd' => { Inverse  => 'IO::Compress::PPMd',
 335                                   Error    => 'UnPPMdError',
 336                                   TopLevel => 'unppmd',
 337                                   Raw      => 0,
 338                                 },
 339
 340     'IO::Compress::DummyComp' => { Inverse  => 'IO::Uncompress::DummyUnComp',
 341                                    Error    => 'DummyCompError',
 342                                    TopLevel => 'dummycomp',
 343                                    Raw      => 0,
 344                                  },
 345     'IO::Uncompress::DummyUnComp' => { Inverse  => 'IO::Compress::DummyComp',
 346                                        Error    => 'DummyUnCompError',
 347                                        TopLevel => 'dummyunComp',
 348                                        Raw      => 0,
 349                                      },
 350 );
 351
 352
 353 for my $key (keys %TOP)
 354 {
 355     no strict;
 356     no warnings;
 357     $TOP{$key}{Error}    = \${ $key . '::' . $TOP{$key}{Error}    };
 358     $TOP{$key}{TopLevel} =     $key . '::' . $TOP{$key}{TopLevel}  ;
 359
 360     # Silence used once warning in really old perl
 361     my $dummy            = \${ $key . '::' . $TOP{$key}{Error}    };
 362
 363     #$TOP{$key . "::" . $TOP{$key}{TopLevel} } = $TOP{$key};
 364 }
 365
 366 sub uncompressBuffer
 367 {
 368     my $compWith = shift ;
 369     my $buffer = shift ;
 370
 371
 372     my $out ;
 373     my $obj = $TOP{$compWith}{Inverse}->new( \$buffer, -Append => 1);
 374     1 while $obj->read($out) > 0 ;
 375     return $out ;
 376
 377 }
 378
 379
 380 sub getInverse
 381 {
 382     my $class = shift ;
 383
 384     return $TOP{$class}{Inverse};
 385 }
 386
 387 sub getErrorRef
 388 {
 389     my $class = shift ;
 390
 391     return $TOP{$class}{Error};
 392 }
 393
 394 sub getTopFuncRef
 395 {
 396     my $class = shift ;
 397
 398     die "Cannot find $class"
 399         if ! defined $TOP{$class}{TopLevel};
 400     return \&{ $TOP{$class}{TopLevel} } ;
 401 }
 402
 403 sub getTopFuncName
 404 {
 405     my $class = shift ;
 406
 407     return $TOP{$class}{TopLevel} ;
 408 }
 409
 410 sub compressBuffer
 411 {
 412     my $compWith = shift ;
 413     my $buffer = shift ;
 414
 415
 416     my $out ;
 417     die "Cannot find $compWith"
 418         if ! defined $TOP{$compWith}{Inverse};
 419     my $obj = $TOP{$compWith}{Inverse}->new( \$out);
 420     $obj->write($buffer) ;
 421     $obj->close();
 422     return $out ;
 423 }
 424
 425 our ($AnyUncompressError);
 426 BEGIN
 427 {
 428     eval ' use IO::Uncompress::AnyUncompress qw($AnyUncompressError); ';
 429 }
 430
 431 sub anyUncompress
 432 {
 433     my $buffer = shift ;
 434     my $already = shift;
 435
 436     my @opts = ();
 437     if (ref $buffer && ref $buffer eq 'ARRAY')
 438     {
 439         @opts = @$buffer;
 440         $buffer = shift @opts;
 441     }
 442
 443     if (ref $buffer)
 444     {
 445         croak "buffer is undef" unless defined $$buffer;
 446         croak "buffer is empty" unless length $$buffer;
 447
 448     }
 449
 450
 451     my $data ;
 452     if (IO::Compress::Base::Common::isaFilehandle($buffer))
 453     {
 454         $data = readFile($buffer);
 455     }
 456     elsif (IO::Compress::Base::Common::isaFilename($buffer))
 457     {
 458         $data = readFile($buffer);
 459     }
 460     else
 461     {
 462         $data = $$buffer ;
 463     }
 464
 465     if (defined $already && length $already)
 466     {
 467
 468         my $got = substr($data, 0, length($already));
 469         substr($data, 0, length($already)) = '';
 470
 471         is $got, $already, '  Already OK' ;
 472     }
 473
 474     my $out = '';
 475     my $o = new IO::Uncompress::AnyUncompress \$data,
 476                     Append => 1,
 477                     Transparent => 0,
 478                     RawInflate => 1,
 479                     @opts
 480         or croak "Cannot open buffer/file: $AnyUncompressError" ;
 481
 482     1 while $o->read($out) > 0 ;
 483
 484     croak "Error uncompressing -- " . $o->error()
 485         if $o->error() ;
 486
 487     return $out ;
 488
 489 }
 490
 491 sub getHeaders
 492 {
 493     my $buffer = shift ;
 494     my $already = shift;
 495
 496     my @opts = ();
 497     if (ref $buffer && ref $buffer eq 'ARRAY')
 498     {
 499         @opts = @$buffer;
 500         $buffer = shift @opts;
 501     }
 502
 503     if (ref $buffer)
 504     {
 505         croak "buffer is undef" unless defined $$buffer;
 506         croak "buffer is empty" unless length $$buffer;
 507
 508     }
 509
 510
 511     my $data ;
 512     if (IO::Compress::Base::Common::isaFilehandle($buffer))
 513     {
 514         $data = readFile($buffer);
 515     }
 516     elsif (IO::Compress::Base::Common::isaFilename($buffer))
 517     {
 518         $data = readFile($buffer);
 519     }
 520     else
 521     {
 522         $data = $$buffer ;
 523     }
 524
 525     if (defined $already && length $already)
 526     {
 527
 528         my $got = substr($data, 0, length($already));
 529         substr($data, 0, length($already)) = '';
 530
 531         is $got, $already, '  Already OK' ;
 532     }
 533
 534     my $out = '';
 535     my $o = new IO::Uncompress::AnyUncompress \$data,
 536                 MultiStream => 1,
 537                 Append => 1,
 538                 Transparent => 0,
 539                 RawInflate => 1,
 540                 @opts
 541         or croak "Cannot open buffer/file: $AnyUncompressError" ;
 542
 543     1 while $o->read($out) > 0 ;
 544
 545     croak "Error uncompressing -- " . $o->error()
 546         if $o->error() ;
 547
 548     return ($o->getHeaderInfo()) ;
 549
 550 }
 551
 552 sub mkComplete
 553 {
 554     my $class = shift ;
 555     my $data = shift;
 556     my $Error = getErrorRef($class);
 557
 558     my $buffer ;
 559     my %params = ();
 560
 561     if ($class eq 'IO::Compress::Gzip') {
 562         %params = (
 563             Name       => "My name",
 564             Comment    => "a comment",
 565             ExtraField => ['ab' => "extra"],
 566             HeaderCRC  => 1);
 567     }
 568     elsif ($class eq 'IO::Compress::Zip'){
 569         %params = (
 570             Name              => "My name",
 571             Comment           => "a comment",
 572             ZipComment        => "last comment",
 573             exTime            => [100, 200, 300],
 574             ExtraFieldLocal   => ["ab" => "extra1"],
 575             ExtraFieldCentral => ["cd" => "extra2"],
 576         );
 577     }
 578
 579     my $z = new $class( \$buffer, %params)
 580         or croak "Cannot create $class object: $$Error";
 581     $z->write($data);
 582     $z->close();
 583
 584     my $unc = getInverse($class);
 585     anyUncompress(\$buffer) eq $data
 586         or die "bad bad bad";
 587     my $u = new $unc( \$buffer);
 588     my $info = $u->getHeaderInfo() ;
 589
 590
 591     return wantarray ? ($info, $buffer) : $buffer ;
 592 }
 593
 594 sub mkErr
 595 {
 596     my $string = shift ;
 597     my ($dummy, $file, $line) = caller ;
 598     -- $line ;
 599
 600     $file = quotemeta($file);
 601
 602     #return "/$string\\s+at $file line $line/" if $] >= 5.006 ;
 603     return "/$string\\s+at /" ;
 604 }
 605
 606 sub mkEvalErr
 607 {
 608     my $string = shift ;
 609
 610     #return "/$string\\s+at \\(eval /" if $] > 5.006 ;
 611     return "/$string\\s+at /" ;
 612 }
 613
 614 sub dumpObj
 615 {
 616     my $obj = shift ;
 617
 618     my ($dummy, $file, $line) = caller ;
 619
 620     if (@_)
 621     {
 622         print "#\n# dumpOBJ from $file line $line @_\n" ;
 623     }
 624     else
 625     {
 626         print "#\n# dumpOBJ from $file line $line \n" ;
 627     }
 628
 629     my $max = 0 ;;
 630     foreach my $k (keys %{ *$obj })
 631     {
 632         $max = length $k if length $k > $max ;
 633     }
 634
 635     foreach my $k (sort keys %{ *$obj })
 636     {
 637         my $v = $obj->{$k} ;
 638         $v = '-undef-' unless defined $v;
 639         my $pad = ' ' x ($max - length($k) + 2) ;
 640         print "# $k$pad: [$v]\n";
 641     }
 642     print "#\n" ;
 643 }
 644
 645
 646 sub getMultiValues
 647 {
 648     my $class = shift ;
 649
 650     return (0,0) if $class =~ /lzf/i;
 651     return (1,0);
 652 }
 653
 654
 655 sub gotScalarUtilXS
 656 {
 657     eval ' use Scalar::Util "dualvar" ';
 658     return $@ ? 0 : 1 ;
 659 }
 660
 661 package CompTestUtils;
 662
 663 1;
 664 __END__
 665         t/Test/Builder.pm
 666         t/Test/More.pm
 667         t/Test/Simple.pm
 668         t/compress/CompTestUtils.pm
 669         t/compress/any.pl
 670         t/compress/anyunc.pl
 671         t/compress/destroy.pl
 672         t/compress/generic.pl
 673         t/compress/merge.pl
 674         t/compress/multi.pl
 675         t/compress/newtied.pl
 676         t/compress/oneshot.pl
 677         t/compress/prime.pl
 678         t/compress/tied.pl
 679         t/compress/truncate.pl
 680         t/compress/zlib-generic.plParsing config.in...
 681 Building Zlib enabled
 682 Auto Detect Gzip OS Code..
 683 Setting Gzip OS Code to 3 [Unix/Default]
 684 Looks Good.