comptestutils.pm

source of perl for linux application,

%inverse  = map { ($_ => $inverse{$_}, $inverse{$_} => $_) } keys %inverse;

sub getInverse
{
    my $class = shift ;

    return $inverse{$class} ;
}

sub getErrorRef
{
    my $class = shift ;

    return $ErrorMap{$class} ;
}

sub getTopFuncRef
{
    my $class = shift ;

    return \&{ $TopFuncMap{$class} } ;
}

sub getTopFuncName
{
    my $class = shift ;

    return $TopFuncMap{$class}  ;
}

sub compressBuffer
{
    my $compWith = shift ;
    my $buffer = shift ;

    my %mapping = ( 'IO::Uncompress::Gunzip'                  => 'IO::Compress::Gzip',
                    'IO::Uncompress::Gunzip::gunzip'          => 'IO::Compress::Gzip',
                    'IO::Uncompress::Inflate'                 => 'IO::Compress::Deflate',
                    'IO::Uncompress::Inflate::inflate'        => 'IO::Compress::Deflate',
                    'IO::Uncompress::RawInflate'              => 'IO::Compress::RawDeflate',
                    'IO::Uncompress::RawInflate::rawinflate'  => 'IO::Compress::RawDeflate',
                    'IO::Uncompress::Bunzip2'                 => 'IO::Compress::Bzip2',
                    'IO::Uncompress::Bunzip2::bunzip2'        => 'IO::Compress::Bzip2',
                    'IO::Uncompress::Unzip'                   => 'IO::Compress::Zip',
                    'IO::Uncompress::Unzip::unzip'            => 'IO::Compress::Zip',
                    'IO::Uncompress::UnLzop'                  => 'IO::Compress::Lzop',
                    'IO::Uncompress::UnLzop::unlzop'          => 'IO::Compress::Lzop',
                    'IO::Uncompress::UnLzp'                   => 'IO::Compress::Lzf',
                    'IO::Uncompress::UnLzf::unlzf'            => 'IO::Compress::Lzf',
                    'IO::Uncompress::AnyInflate'              => 'IO::Compress::Gzip',
                    'IO::Uncompress::AnyInflate::anyinflate'  => 'IO::Compress::Gzip',
                    'IO::Uncompress::AnyUncompress'           => 'IO::Compress::Gzip',
                    'IO::Uncompress::AnyUncompress::anyuncompress'  => 'IO::Compress::Gzip',
                    'IO::Uncompress::DummyUncomp'             => 'IO::Compress::DummyComp',
                    'IO::Uncompress::DummyUncomp::dummyuncomp'=> 'IO::Compress::DummyComp',
                );

    my $out ;
    my $obj = $mapping{$compWith}->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.