t/lib/compress/ZlibTestUtils.pm

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