t/lib/compress/CompTestUtils.pm

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