lib/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         unlink @_ ;
  40         bless [ @_ ], $self ;
  41     }
  42
  43     sub DESTROY
  44     {
  45         my $self = shift ;
  46         chmod 0777, @{ $self } ;
  47         unlink @{ $self } ;
  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 die "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     open (F, ">$filename")
 103         or die "Cannot open $filename: $!\n" ;
 104     binmode F;
 105     foreach (@strings) {
 106         no warnings ;
 107         print F $_ ;
 108     }
 109     close F ;
 110 }
 111
 112 sub GZreadFile
 113 {
 114     my ($filename) = shift ;
 115
 116     my ($uncomp) = "" ;
 117     my $line = "" ;
 118     my $fil = gzopen($filename, "rb")
 119         or die "Cannopt open '$filename': $Compress::Zlib::gzerrno" ;
 120
 121     $uncomp .= $line
 122         while $fil->gzread($line) > 0;
 123
 124     $fil->gzclose ;
 125     return $uncomp ;
 126 }
 127
 128 sub hexDump
 129 {
 130     my $d = shift ;
 131
 132     if (Compress::Zlib::Common::isaFilehandle($d))
 133     {
 134         $d = readFile($d);
 135     }
 136     elsif (Compress::Zlib::Common::isaFilename($d))
 137     {
 138         $d = readFile($d);
 139     }
 140     else
 141     {
 142         $d = $$d ;
 143     }
 144
 145     my $offset = 0 ;
 146
 147     $d = '' unless defined $d ;
 148     #while (read(STDIN, $data, 16)) {
 149     while (my $data = substr($d, 0, 16)) {
 150         substr($d, 0, 16) = '' ;
 151         printf "# %8.8lx    ", $offset;
 152         $offset += 16;
 153
 154         my @array = unpack('C*', $data);
 155         foreach (@array) {
 156             printf('%2.2x ', $_);
 157         }
 158         print "   " x (16 - @array)
 159             if @array < 16 ;
 160         $data =~ tr/\0-\37\177-\377/./;
 161         print "  $data\n";
 162     }
 163
 164 }
 165
 166 sub readHeaderInfo
 167 {
 168     my $name = shift ;
 169     my %opts = @_ ;
 170
 171     my $string = <<EOM;
 172 some text
 173 EOM
 174
 175     ok my $x = new IO::Compress::Gzip $name, %opts
 176         or diag "GzipError is $IO::Compress::Gzip::GzipError" ;
 177     ok $x->write($string) ;
 178     ok $x->close ;
 179
 180     ok GZreadFile($name) eq $string ;
 181
 182     ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0
 183         or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ;
 184     ok my $hdr = $gunz->getHeaderInfo();
 185     my $uncomp ;
 186     ok $gunz->read($uncomp) ;
 187     ok $uncomp eq $string;
 188     ok $gunz->close ;
 189
 190     return $hdr ;
 191 }
 192
 193 sub cmpFile
 194 {
 195     my ($filename, $uue) = @_ ;
 196     return readFile($filename) eq unpack("u", $uue) ;
 197 }
 198
 199 sub uncompressBuffer
 200 {
 201     my $compWith = shift ;
 202     my $buffer = shift ;
 203
 204     my %mapping = ( 'IO::Compress::Gzip'                    => 'IO::Uncompress::Gunzip',
 205                     'IO::Compress::Gzip::gzip'               => 'IO::Uncompress::Gunzip',
 206                     'IO::Compress::Deflate'                  => 'IO::Uncompress::Inflate',
 207                     'IO::Compress::Deflate::deflate'         => 'IO::Uncompress::Inflate',
 208                     'IO::Compress::RawDeflate'               => 'IO::Uncompress::RawInflate',
 209                     'IO::Compress::RawDeflate::rawdeflate'   => 'IO::Uncompress::RawInflate',
 210                 );
 211
 212     my $out ;
 213     my $obj = $mapping{$compWith}->new( \$buffer, -Append => 1);
 214     1 while $obj->read($out) > 0 ;
 215     return $out ;
 216
 217 }
 218
 219 my %ErrorMap = (    'IO::Compress::Gzip'        => \$IO::Compress::Gzip::GzipError,
 220                     'IO::Compress::Gzip::gzip'  => \$IO::Compress::Gzip::GzipError,
 221                     'IO::Uncompress::Gunzip'  => \$IO::Uncompress::Gunzip::GunzipError,
 222                     'IO::Uncompress::Gunzip::gunzip'  => \$IO::Uncompress::Gunzip::GunzipError,
 223                     'IO::Uncompress::Inflate'  => \$IO::Uncompress::Inflate::InflateError,
 224                     'IO::Uncompress::Inflate::inflate'  => \$IO::Uncompress::Inflate::InflateError,
 225                     'IO::Compress::Deflate'  => \$IO::Compress::Deflate::DeflateError,
 226                     'IO::Compress::Deflate::deflate'  => \$IO::Compress::Deflate::DeflateError,
 227                     'IO::Uncompress::RawInflate'  => \$IO::Uncompress::RawInflate::RawInflateError,
 228                     'IO::Uncompress::RawInflate::rawinflate'  => \$IO::Uncompress::RawInflate::RawInflateError,
 229                     'IO::Uncompress::AnyInflate'  => \$IO::Uncompress::AnyInflate::AnyInflateError,
 230                     'IO::Uncompress::AnyInflate::anyinflate'  => \$IO::Uncompress::AnyInflate::AnyInflateError,
 231                     'IO::Compress::RawDeflate'  => \$IO::Compress::RawDeflate::RawDeflateError,
 232                     'IO::Compress::RawDeflate::rawdeflate'  => \$IO::Compress::RawDeflate::RawDeflateError,
 233                );
 234
 235 my %TopFuncMap = (  'IO::Compress::Gzip'        => 'IO::Compress::Gzip::gzip',
 236                     'IO::Uncompress::Gunzip'      => 'IO::Uncompress::Gunzip::gunzip',
 237                     'IO::Compress::Deflate'     => 'IO::Compress::Deflate::deflate',
 238                     'IO::Uncompress::Inflate'     => 'IO::Uncompress::Inflate::inflate',
 239                     'IO::Compress::RawDeflate'  => 'IO::Compress::RawDeflate::rawdeflate',
 240                     'IO::Uncompress::RawInflate'  => 'IO::Uncompress::RawInflate::rawinflate',
 241                     'IO::Uncompress::AnyInflate'  => 'IO::Uncompress::AnyInflate::anyinflate',
 242                  );
 243
 244    %TopFuncMap = map { ($_              => $TopFuncMap{$_},
 245                         $TopFuncMap{$_} => $TopFuncMap{$_}) }
 246                  keys %TopFuncMap ;
 247
 248  #%TopFuncMap = map { ($_              => \&{ $TopFuncMap{$_} ) }
 249                  #keys %TopFuncMap ;
 250
 251
 252 my %inverse  = ( 'IO::Compress::Gzip'                    => 'IO::Uncompress::Gunzip',
 253                  'IO::Compress::Gzip::gzip'              => 'IO::Uncompress::Gunzip::gunzip',
 254                  'IO::Compress::Deflate'                 => 'IO::Uncompress::Inflate',
 255                  'IO::Compress::Deflate::deflate'        => 'IO::Uncompress::Inflate::inflate',
 256                  'IO::Compress::RawDeflate'              => 'IO::Uncompress::RawInflate',
 257                  'IO::Compress::RawDeflate::rawdeflate'  => 'IO::Uncompress::RawInflate::rawinflate',
 258              );
 259
 260 %inverse  = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse;
 261
 262 sub getInverse
 263 {
 264     my $class = shift ;
 265
 266     return $inverse{$class} ;
 267 }
 268
 269 sub getErrorRef
 270 {
 271     my $class = shift ;
 272
 273     return $ErrorMap{$class} ;
 274 }
 275
 276 sub getTopFuncRef
 277 {
 278     my $class = shift ;
 279
 280     return \&{ $TopFuncMap{$class} } ;
 281 }
 282
 283 sub getTopFuncName
 284 {
 285     my $class = shift ;
 286
 287     return $TopFuncMap{$class}  ;
 288 }
 289
 290 sub compressBuffer
 291 {
 292     my $compWith = shift ;
 293     my $buffer = shift ;
 294
 295     my %mapping = ( 'IO::Uncompress::Gunzip'                  => 'IO::Compress::Gzip',
 296                     'IO::Uncompress::Gunzip::gunzip'          => 'IO::Compress::Gzip',
 297                     'IO::Uncompress::Inflate'                 => 'IO::Compress::Deflate',
 298                     'IO::Uncompress::Inflate::inflate'        => 'IO::Compress::Deflate',
 299                     'IO::Uncompress::RawInflate'              => 'IO::Compress::RawDeflate',
 300                     'IO::Uncompress::RawInflate::rawinflate'  => 'IO::Compress::RawDeflate',
 301                     'IO::Uncompress::AnyInflate'              => 'IO::Compress::Gzip',
 302                     'IO::Uncompress::AnyInflate::anyinflate'  => 'IO::Compress::Gzip',
 303                 );
 304
 305     my $out ;
 306     my $obj = $mapping{$compWith}->new( \$out);
 307     $obj->write($buffer) ;
 308     $obj->close();
 309     return $out ;
 310
 311 }
 312
 313 use IO::Uncompress::AnyInflate qw($AnyInflateError);
 314 sub anyUncompress
 315 {
 316     my $buffer = shift ;
 317     my $already = shift;
 318
 319     my @opts = ();
 320     if (ref $buffer && ref $buffer eq 'ARRAY')
 321     {
 322         @opts = @$buffer;
 323         $buffer = shift @opts;
 324     }
 325
 326     if (ref $buffer)
 327     {
 328         croak "buffer is undef" unless defined $$buffer;
 329         croak "buffer is empty" unless length $$buffer;
 330
 331     }
 332
 333
 334     my $data ;
 335     if (Compress::Zlib::Common::isaFilehandle($buffer))
 336     {
 337         $data = readFile($buffer);
 338     }
 339     elsif (Compress::Zlib::Common::isaFilename($buffer))
 340     {
 341         $data = readFile($buffer);
 342     }
 343     else
 344     {
 345         $data = $$buffer ;
 346     }
 347
 348     if (defined $already && length $already)
 349     {
 350
 351         my $got = substr($data, 0, length($already));
 352         substr($data, 0, length($already)) = '';
 353
 354         is $got, $already, '  Already OK' ;
 355     }
 356
 357     my $out = '';
 358     my $o = new IO::Uncompress::AnyInflate \$data, -Append => 1, Transparent => 0, @opts
 359         or croak "Cannot open buffer/file: $AnyInflateError" ;
 360
 361     1 while $o->read($out) > 0 ;
 362
 363     croak "Error uncompressing -- " . $o->error()
 364         if $o->error() ;
 365
 366     return $out ;
 367
 368 }
 369
 370 sub mkErr
 371 {
 372     my $string = shift ;
 373     my ($dummy, $file, $line) = caller ;
 374     -- $line ;
 375
 376     $file = quotemeta($file);
 377
 378     return "/$string\\s+at $file line $line/" ;
 379 }
 380
 381 sub mkEvalErr
 382 {
 383     my $string = shift ;
 384
 385     return "/$string\\s+at \\(eval /" ;
 386 }
 387
 388 sub dumpObj
 389 {
 390     my $obj = shift ;
 391
 392     my ($dummy, $file, $line) = caller ;
 393
 394     if (@_)
 395     {
 396         print "#\n# dumpOBJ from $file line $line @_\n" ;
 397     }
 398     else
 399     {
 400         print "#\n# dumpOBJ from $file line $line \n" ;
 401     }
 402
 403     my $max = 0 ;;
 404     foreach my $k (keys %{ *$obj })
 405     {
 406         $max = length $k if length $k > $max ;
 407     }
 408
 409     foreach my $k (sort keys %{ *$obj })
 410     {
 411         my $v = $obj->{$k} ;
 412         $v = '-undef-' unless defined $v;
 413         my $pad = ' ' x ($max - length($k) + 2) ;
 414         print "# $k$pad: [$v]\n";
 415     }
 416     print "#\n" ;
 417 }
 418
 419
 420 package ZlibTestUtils;
 421
 422 1;