diff options
Diffstat (limited to 'cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm')
| -rw-r--r-- | cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm | 684 |
1 files changed, 684 insertions, 0 deletions
diff --git a/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm b/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm new file mode 100644 index 0000000000..cb63d6274c --- /dev/null +++ b/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm @@ -0,0 +1,684 @@ +package CompTestUtils; + +package main ; + +use strict ; +use warnings; +use bytes; + +#use lib qw(t t/compress); + +use Carp ; +#use Test::More ; + + + +sub title +{ + #diag "" ; + ok 1, $_[0] ; + #diag "" ; +} + +sub like_eval +{ + like $@, @_ ; +} + +{ + package LexFile ; + + our ($index); + $index = '00000'; + + sub new + { + my $self = shift ; + foreach (@_) + { + # autogenerate the name unless if none supplied + $_ = "tst" . $index ++ . ".tmp" + unless defined $_; + } + chmod 0777, @_; + for (@_) { 1 while unlink $_ } ; + bless [ @_ ], $self ; + } + + sub DESTROY + { + my $self = shift ; + chmod 0777, @{ $self } ; + for (@$self) { 1 while unlink $_ } ; + } + +} + +{ + package LexDir ; + + use File::Path; + sub new + { + my $self = shift ; + foreach (@_) { rmtree $_ } + bless [ @_ ], $self ; + } + + sub DESTROY + { + my $self = shift ; + foreach (@$self) { rmtree $_ } + } +} +sub readFile +{ + my $f = shift ; + + my @strings ; + + if (IO::Compress::Base::Common::isaFilehandle($f)) + { + my $pos = tell($f); + seek($f, 0,0); + @strings = <$f> ; + seek($f, 0, $pos); + } + else + { + open (F, "<$f") + or croak "Cannot open $f: $!\n" ; + binmode F; + @strings = <F> ; + close F ; + } + + return @strings if wantarray ; + return join "", @strings ; +} + +sub touch +{ + foreach (@_) { writeFile($_, '') } +} + +sub writeFile +{ + my($filename, @strings) = @_ ; + 1 while unlink $filename ; + open (F, ">$filename") + or croak "Cannot open $filename: $!\n" ; + binmode F; + foreach (@strings) { + no warnings ; + print F $_ ; + } + close F ; +} + +sub GZreadFile +{ + my ($filename) = shift ; + + my ($uncomp) = "" ; + my $line = "" ; + my $fil = gzopen($filename, "rb") + or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; + + $uncomp .= $line + while $fil->gzread($line) > 0; + + $fil->gzclose ; + return $uncomp ; +} + +sub hexDump +{ + my $d = shift ; + + if (IO::Compress::Base::Common::isaFilehandle($d)) + { + $d = readFile($d); + } + elsif (IO::Compress::Base::Common::isaFilename($d)) + { + $d = readFile($d); + } + else + { + $d = $$d ; + } + + my $offset = 0 ; + + $d = '' unless defined $d ; + #while (read(STDIN, $data, 16)) { + while (my $data = substr($d, 0, 16)) { + substr($d, 0, 16) = '' ; + printf "# %8.8lx ", $offset; + $offset += 16; + + my @array = unpack('C*', $data); + foreach (@array) { + printf('%2.2x ', $_); + } + print " " x (16 - @array) + if @array < 16 ; + $data =~ tr/\0-\37\177-\377/./; + print " $data\n"; + } + +} + +sub readHeaderInfo +{ + my $name = shift ; + my %opts = @_ ; + + my $string = <<EOM; +some text +EOM + + ok my $x = new IO::Compress::Gzip $name, %opts + or diag "GzipError is $IO::Compress::Gzip::GzipError" ; + ok $x->write($string) ; + ok $x->close ; + + #is GZreadFile($name), $string ; + + ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0 + or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; + ok my $hdr = $gunz->getHeaderInfo(); + my $uncomp ; + ok $gunz->read($uncomp) ; + ok $uncomp eq $string; + ok $gunz->close ; + + return $hdr ; +} + +sub cmpFile +{ + my ($filename, $uue) = @_ ; + return readFile($filename) eq unpack("u", $uue) ; +} + +#sub isRawFormat +#{ +# my $class = shift; +# # TODO -- add Lzma here? +# my %raw = map { $_ => 1 } qw( RawDeflate ); +# +# return defined $raw{$class}; +#} + + + +my %TOP = ( + 'IO::Uncompress::AnyInflate' => { Inverse => 'IO::Compress::Gzip', + Error => 'AnyInflateError', + TopLevel => 'anyinflate', + Raw => 0, + }, + + 'IO::Uncompress::AnyUncompress' => { Inverse => 'IO::Compress::Gzip', + Error => 'AnyUncompressError', + TopLevel => 'anyuncompress', + Raw => 0, + }, + + 'IO::Compress::Gzip' => { Inverse => 'IO::Uncompress::Gunzip', + Error => 'GzipError', + TopLevel => 'gzip', + Raw => 0, + }, + 'IO::Uncompress::Gunzip' => { Inverse => 'IO::Compress::Gzip', + Error => 'GunzipError', + TopLevel => 'gunzip', + Raw => 0, + }, + + 'IO::Compress::Deflate' => { Inverse => 'IO::Uncompress::Inflate', + Error => 'DeflateError', + TopLevel => 'deflate', + Raw => 0, + }, + 'IO::Uncompress::Inflate' => { Inverse => 'IO::Compress::Deflate', + Error => 'InflateError', + TopLevel => 'inflate', + Raw => 0, + }, + + 'IO::Compress::RawDeflate' => { Inverse => 'IO::Uncompress::RawInflate', + Error => 'RawDeflateError', + TopLevel => 'rawdeflate', + Raw => 1, + }, + 'IO::Uncompress::RawInflate' => { Inverse => 'IO::Compress::RawDeflate', + Error => 'RawInflateError', + TopLevel => 'rawinflate', + Raw => 1, + }, + + 'IO::Compress::Zip' => { Inverse => 'IO::Uncompress::Unzip', + Error => 'ZipError', + TopLevel => 'zip', + Raw => 0, + }, + 'IO::Uncompress::Unzip' => { Inverse => 'IO::Compress::Zip', + Error => 'UnzipError', + TopLevel => 'unzip', + Raw => 0, + }, + + 'IO::Compress::Bzip2' => { Inverse => 'IO::Uncompress::Bunzip2', + Error => 'Bzip2Error', + TopLevel => 'bzip2', + Raw => 0, + }, + 'IO::Uncompress::Bunzip2' => { Inverse => 'IO::Compress::Bzip2', + Error => 'Bunzip2Error', + TopLevel => 'bunzip2', + Raw => 0, + }, + + 'IO::Compress::Lzop' => { Inverse => 'IO::Uncompress::UnLzop', + Error => 'LzopError', + TopLevel => 'lzop', + Raw => 0, + }, + 'IO::Uncompress::UnLzop' => { Inverse => 'IO::Compress::Lzop', + Error => 'UnLzopError', + TopLevel => 'unlzop', + Raw => 0, + }, + + 'IO::Compress::Lzf' => { Inverse => 'IO::Uncompress::UnLzf', + Error => 'LzfError', + TopLevel => 'lzf', + Raw => 0, + }, + 'IO::Uncompress::UnLzf' => { Inverse => 'IO::Compress::Lzf', + Error => 'UnLzfError', + TopLevel => 'unlzf', + Raw => 0, + }, + + 'IO::Compress::Lzma' => { Inverse => 'IO::Uncompress::UnLzma', + Error => 'LzmaError', + TopLevel => 'lzma', + Raw => 1, + }, + 'IO::Uncompress::UnLzma' => { Inverse => 'IO::Compress::Lzma', + Error => 'UnLzmaError', + TopLevel => 'unlzma', + Raw => 1, + }, + + 'IO::Compress::Xz' => { Inverse => 'IO::Uncompress::UnXz', + Error => 'XzError', + TopLevel => 'xz', + Raw => 0, + }, + 'IO::Uncompress::UnXz' => { Inverse => 'IO::Compress::Xz', + Error => 'UnXzError', + TopLevel => 'unxz', + Raw => 0, + }, + + 'IO::Compress::PPMd' => { Inverse => 'IO::Uncompress::UnPPMd', + Error => 'PPMdError', + TopLevel => 'ppmd', + Raw => 0, + }, + 'IO::Uncompress::UnPPMd' => { Inverse => 'IO::Compress::PPMd', + Error => 'UnPPMdError', + TopLevel => 'unppmd', + Raw => 0, + }, + + 'IO::Compress::DummyComp' => { Inverse => 'IO::Uncompress::DummyUnComp', + Error => 'DummyCompError', + TopLevel => 'dummycomp', + Raw => 0, + }, + 'IO::Uncompress::DummyUnComp' => { Inverse => 'IO::Compress::DummyComp', + Error => 'DummyUnCompError', + TopLevel => 'dummyunComp', + Raw => 0, + }, +); + + +for my $key (keys %TOP) +{ + no strict; + no warnings; + $TOP{$key}{Error} = \${ $key . '::' . $TOP{$key}{Error} }; + $TOP{$key}{TopLevel} = $key . '::' . $TOP{$key}{TopLevel} ; + + # Silence used once warning in really old perl + my $dummy = \${ $key . '::' . $TOP{$key}{Error} }; + + #$TOP{$key . "::" . $TOP{$key}{TopLevel} } = $TOP{$key}; +} + +sub uncompressBuffer +{ + my $compWith = shift ; + my $buffer = shift ; + + + my $out ; + my $obj = $TOP{$compWith}{Inverse}->new( \$buffer, -Append => 1); + 1 while $obj->read($out) > 0 ; + return $out ; + +} + + +sub getInverse +{ + my $class = shift ; + + return $TOP{$class}{Inverse}; +} + +sub getErrorRef +{ + my $class = shift ; + + return $TOP{$class}{Error}; +} + +sub getTopFuncRef +{ + my $class = shift ; + + die "Cannot find $class" + if ! defined $TOP{$class}{TopLevel}; + return \&{ $TOP{$class}{TopLevel} } ; +} + +sub getTopFuncName +{ + my $class = shift ; + + return $TOP{$class}{TopLevel} ; +} + +sub compressBuffer +{ + my $compWith = shift ; + my $buffer = shift ; + + + my $out ; + die "Cannot find $compWith" + if ! defined $TOP{$compWith}{Inverse}; + my $obj = $TOP{$compWith}{Inverse}->new( \$out); + $obj->write($buffer) ; + $obj->close(); + return $out ; +} + +our ($AnyUncompressError); +BEGIN +{ + eval ' use IO::Uncompress::AnyUncompress qw($AnyUncompressError); '; +} + +sub anyUncompress +{ + my $buffer = shift ; + my $already = shift; + + my @opts = (); + if (ref $buffer && ref $buffer eq 'ARRAY') + { + @opts = @$buffer; + $buffer = shift @opts; + } + + if (ref $buffer) + { + croak "buffer is undef" unless defined $$buffer; + croak "buffer is empty" unless length $$buffer; + + } + + + my $data ; + if (IO::Compress::Base::Common::isaFilehandle($buffer)) + { + $data = readFile($buffer); + } + elsif (IO::Compress::Base::Common::isaFilename($buffer)) + { + $data = readFile($buffer); + } + else + { + $data = $$buffer ; + } + + if (defined $already && length $already) + { + + my $got = substr($data, 0, length($already)); + substr($data, 0, length($already)) = ''; + + is $got, $already, ' Already OK' ; + } + + my $out = ''; + my $o = new IO::Uncompress::AnyUncompress \$data, + Append => 1, + Transparent => 0, + RawInflate => 1, + @opts + or croak "Cannot open buffer/file: $AnyUncompressError" ; + + 1 while $o->read($out) > 0 ; + + croak "Error uncompressing -- " . $o->error() + if $o->error() ; + + return $out ; + +} + +sub getHeaders +{ + my $buffer = shift ; + my $already = shift; + + my @opts = (); + if (ref $buffer && ref $buffer eq 'ARRAY') + { + @opts = @$buffer; + $buffer = shift @opts; + } + + if (ref $buffer) + { + croak "buffer is undef" unless defined $$buffer; + croak "buffer is empty" unless length $$buffer; + + } + + + my $data ; + if (IO::Compress::Base::Common::isaFilehandle($buffer)) + { + $data = readFile($buffer); + } + elsif (IO::Compress::Base::Common::isaFilename($buffer)) + { + $data = readFile($buffer); + } + else + { + $data = $$buffer ; + } + + if (defined $already && length $already) + { + + my $got = substr($data, 0, length($already)); + substr($data, 0, length($already)) = ''; + + is $got, $already, ' Already OK' ; + } + + my $out = ''; + my $o = new IO::Uncompress::AnyUncompress \$data, + MultiStream => 1, + Append => 1, + Transparent => 0, + RawInflate => 1, + @opts + or croak "Cannot open buffer/file: $AnyUncompressError" ; + + 1 while $o->read($out) > 0 ; + + croak "Error uncompressing -- " . $o->error() + if $o->error() ; + + return ($o->getHeaderInfo()) ; + +} + +sub mkComplete +{ + my $class = shift ; + my $data = shift; + my $Error = getErrorRef($class); + + my $buffer ; + my %params = (); + + if ($class eq 'IO::Compress::Gzip') { + %params = ( + Name => "My name", + Comment => "a comment", + ExtraField => ['ab' => "extra"], + HeaderCRC => 1); + } + elsif ($class eq 'IO::Compress::Zip'){ + %params = ( + Name => "My name", + Comment => "a comment", + ZipComment => "last comment", + exTime => [100, 200, 300], + ExtraFieldLocal => ["ab" => "extra1"], + ExtraFieldCentral => ["cd" => "extra2"], + ); + } + + my $z = new $class( \$buffer, %params) + or croak "Cannot create $class object: $$Error"; + $z->write($data); + $z->close(); + + my $unc = getInverse($class); + anyUncompress(\$buffer) eq $data + or die "bad bad bad"; + my $u = new $unc( \$buffer); + my $info = $u->getHeaderInfo() ; + + + return wantarray ? ($info, $buffer) : $buffer ; +} + +sub mkErr +{ + my $string = shift ; + my ($dummy, $file, $line) = caller ; + -- $line ; + + $file = quotemeta($file); + + #return "/$string\\s+at $file line $line/" if $] >= 5.006 ; + return "/$string\\s+at /" ; +} + +sub mkEvalErr +{ + my $string = shift ; + + #return "/$string\\s+at \\(eval /" if $] > 5.006 ; + return "/$string\\s+at /" ; +} + +sub dumpObj +{ + my $obj = shift ; + + my ($dummy, $file, $line) = caller ; + + if (@_) + { + print "#\n# dumpOBJ from $file line $line @_\n" ; + } + else + { + print "#\n# dumpOBJ from $file line $line \n" ; + } + + my $max = 0 ;; + foreach my $k (keys %{ *$obj }) + { + $max = length $k if length $k > $max ; + } + + foreach my $k (sort keys %{ *$obj }) + { + my $v = $obj->{$k} ; + $v = '-undef-' unless defined $v; + my $pad = ' ' x ($max - length($k) + 2) ; + print "# $k$pad: [$v]\n"; + } + print "#\n" ; +} + + +sub getMultiValues +{ + my $class = shift ; + + return (0,0) if $class =~ /lzf/i; + return (1,0); +} + + +sub gotScalarUtilXS +{ + eval ' use Scalar::Util "dualvar" '; + return $@ ? 0 : 1 ; +} + +package CompTestUtils; + +1; +__END__ + t/Test/Builder.pm + t/Test/More.pm + t/Test/Simple.pm + t/compress/CompTestUtils.pm + t/compress/any.pl + t/compress/anyunc.pl + t/compress/destroy.pl + t/compress/generic.pl + t/compress/merge.pl + t/compress/multi.pl + t/compress/newtied.pl + t/compress/oneshot.pl + t/compress/prime.pl + t/compress/tied.pl + t/compress/truncate.pl + t/compress/zlib-generic.plParsing config.in... +Building Zlib enabled +Auto Detect Gzip OS Code.. +Setting Gzip OS Code to 3 [Unix/Default] +Looks Good. |