[perl5.git] / cpan / Archive-Extract / t / 01_Archive-Extract.t

BEGIN { chdir 't' if -d 't' };
BEGIN { mkdir 'out' unless -d 'out' };

### left behind, at least on Win32. See core patch #31904
END   { rmtree('out') };        

use strict;
use lib qw[../lib];

use constant IS_WIN32   => $^O eq 'MSWin32' ? 1 : 0;
use constant IS_CYGWIN  => $^O eq 'cygwin'  ? 1 : 0;
use constant IS_VMS     => $^O eq 'VMS'     ? 1 : 0;

use Cwd                         qw[cwd];
use Test::More                  qw[no_plan];
use File::Spec;
use File::Spec::Unix;
use File::Path;
use Data::Dumper;
use File::Basename              qw[basename];
use Module::Load::Conditional   qw[check_install];

### uninitialized value in File::Spec warnings come from A::Zip:
# t/01_Archive-Extract....ok 135/0Use of uninitialized value in concatenation (.) or string at /opt/lib/perl5/5.8.3/File/Spec/Unix.pm line 313.
#         File::Spec::Unix::catpath('File::Spec','','','undef') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 473
#         Archive::Zip::_asLocalName('') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 652
#         Archive::Zip::Archive::extractMember('Archive::Zip::Archive=HASH(0x9679c8)','Archive::Zip::ZipFileMember=HASH(0x9678fc)') called at ../lib/Archive/Extract.pm line 753
#         Archive::Extract::_unzip_az('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 674
#         Archive::Extract::_unzip('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 275
#         Archive::Extract::extract('Archive::Extract=HASH(0x966eac)','to','/Users/kane/sources/p4/other/archive-extract/t/out') called at t/01_Archive-Extract.t line 180
#BEGIN { $SIG{__WARN__} = sub { require Carp; Carp::cluck(@_) } };

if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) {
    diag( "Older versions of Archive::Zip may cause File::Spec warnings" );
    diag( "See bug #19713 in rt.cpan.org. It is safe to ignore them" );
}

my $Me      = basename( $0 );
my $Class   = 'Archive::Extract';

use_ok($Class);

### debug will always be enabled on dev versions
my $Debug   = (not $ENV{PERL_CORE} and 
              ($ARGV[0] or $Archive::Extract::VERSION =~ /_/))
                ? 1 
                : 0;

my $Self    = File::Spec->rel2abs( 
                    IS_WIN32 ? &Win32::GetShortPathName( cwd() ) : cwd() 
                );
my $SrcDir  = File::Spec->catdir( $Self,'src' );
my $OutDir  = File::Spec->catdir( $Self,'out' );

### stupid stupid silly stupid warnings silly! ###
$Archive::Extract::DEBUG    = $Archive::Extract::DEBUG  = $Debug;
$Archive::Extract::WARN     = $Archive::Extract::WARN   = $Debug;

diag( "\n\n*** DEBUG INFORMATION ENABLED ***\n\n" ) if $Debug;

# Be as evil as possible to print
$\ = "ORS_FLAG";
$, = "OFS_FLAG";
$" = "LISTSEP_FLAG";

my $tmpl = {
    ### plain files
    'x.bz2' => {    programs    => [qw[bunzip2]],
                    modules     => [qw[IO::Uncompress::Bunzip2]],
                    method      => 'is_bz2',
                    outfile     => 'a',
                },
    'x.tgz' => {    programs    => [qw[gzip tar]],
                    modules     => [qw[Archive::Tar IO::Zlib]],
                    method      => 'is_tgz',
                    outfile     => 'a',
                },
    'x.tar.gz' => { programs    => [qw[gzip tar]],
                    modules     => [qw[Archive::Tar IO::Zlib]],
                    method      => 'is_tgz',
                    outfile     => 'a',
                },
    'x.tar' => {    programs    => [qw[tar]],
                    modules     => [qw[Archive::Tar]],
                    method      => 'is_tar',
                    outfile     => 'a',
                },
    'x.gz'  => {    programs    => [qw[gzip]],
                    modules     => [qw[Compress::Zlib]],
                    method      => 'is_gz',
                    outfile     => 'a',
                },
    'x.Z'   => {    programs    => [qw[uncompress]],
                    modules     => [qw[Compress::Zlib]],
                    method      => 'is_Z',
                    outfile     => 'a',
                },
    'x.zip' => {    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'a',
                },
    'x.jar' => {    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'a',
                },                
    'x.par' => {    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'a',
                },                
    'x.lzma' => {   programs    => [qw[unlzma]],
                    modules     => [qw[Compress::unLZMA]],
                    method      => 'is_lzma',
                    outfile     => 'a',
                },
    'x.xz'   => {   programs    => [qw[unxz]],
                    modules     => [qw[IO::Uncompress::UnXz]],
                    method      => 'is_xz',
                    outfile     => 'a',
                },
    'x.txz'  => {   programs    => [qw[unxz tar]],
                    modules     => [qw[Archive::Tar
                                           IO::Uncompress::UnXz]],
                    method      => 'is_txz',
                    outfile     => 'a',
                },
    'x.tar.xz'=> {  programs    => [qw[unxz tar]],
                    modules     => [qw[Archive::Tar
                                           IO::Uncompress::UnXz]],
                    method      => 'is_txz',
                    outfile     => 'a',
                },
    ### with a directory
    'y.tbz'     => {    programs    => [qw[bunzip2 tar]],
                        modules     => [qw[Archive::Tar 
                                           IO::Uncompress::Bunzip2]],
                        method      => 'is_tbz',
                        outfile     => 'z',
                        outdir      => 'y',
                    },
    'y.tar.bz2' => {    programs    => [qw[bunzip2 tar]],
                        modules     => [qw[Archive::Tar 
                                           IO::Uncompress::Bunzip2]],
                        method      => 'is_tbz',
                        outfile     => 'z',
                        outdir      => 'y'
                    },    
    'y.txz'     => {    programs    => [qw[unxz tar]],
                        modules     => [qw[Archive::Tar 
                                           IO::Uncompress::UnXz]],
                        method      => 'is_txz',
                        outfile     => 'z',
                        outdir      => 'y',
                    },
    'y.tar.xz'  => {    programs    => [qw[unxz tar]],
                        modules     => [qw[Archive::Tar 
                                           IO::Uncompress::UnXz]],
                        method      => 'is_txz',
                        outfile     => 'z',
                        outdir      => 'y'
                    },    
    'y.tgz'     => {    programs    => [qw[gzip tar]],
                        modules     => [qw[Archive::Tar IO::Zlib]],
                        method      => 'is_tgz',
                        outfile     => 'z',
                        outdir      => 'y'
                    },
    'y.tar.gz' => {     programs    => [qw[gzip tar]],
                        modules     => [qw[Archive::Tar IO::Zlib]],
                        method      => 'is_tgz',
                        outfile     => 'z',
                        outdir      => 'y'
                    },
    'y.tar' => {    programs    => [qw[tar]],
                    modules     => [qw[Archive::Tar]],
                    method      => 'is_tar',
                    outfile     => 'z',
                    outdir      => 'y'
                },
    'y.zip' => {    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'z',
                    outdir      => 'y'
                },
    'y.par' => {    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'z',
                    outdir      => 'y'
                },
    'y.jar' => {    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'z',
                    outdir      => 'y'
                },
    ### with non-same top dir
    'double_dir.zip' => {
                    programs    => [qw[unzip]],
                    modules     => [qw[Archive::Zip]],
                    method      => 'is_zip',
                    outfile     => 'w',
                    outdir      => 'x'
                },
};

### XXX special case: on older solaris boxes (8),
### bunzip2 is version 0.9.x. Older versions (pre 1),
### only extract files that end in .bz2, and nothing
### else. So remove that test case if we have an older
### bunzip2 :(
{   if( $Class->have_old_bunzip2 ) {
        delete $tmpl->{'y.tbz'};
        diag "Old bunzip2 detected, skipping .tbz test";
    }
}    

### show us the tools IPC::Cmd will use to run binary programs
if( $Debug ) {
    diag( "IPC::Run enabled: $IPC::Cmd::USE_IPC_RUN " );
    diag( "IPC::Run available: " . IPC::Cmd->can_use_ipc_run );
    diag( "IPC::Run vesion: $IPC::Run::VERSION" );
    diag( "IPC::Open3 enabled: $IPC::Cmd::USE_IPC_OPEN3 " );
    diag( "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3 );
    diag( "IPC::Open3 vesion: $IPC::Open3::VERSION" );
}

### test all type specifications to new()
### this tests bug #24578: Wrong check for `type' argument
{   my $meth = 'types';

    can_ok( $Class, $meth );

    my @types = $Class->$meth;
    ok( scalar(@types),         "   Got a list of types" );
    
    for my $type ( @types ) {
        my $obj = $Class->new( archive => $Me, type => $type );
        ok( $obj,               "   Object created based on '$type'" );
        ok( !$obj->error,       "       No error logged" );
    }
    
    ### test unknown type
    {   ### must turn on warnings to catch error here
        local $Archive::Extract::WARN = 1;
        
        my $warnings;
        local $SIG{__WARN__} = sub { $warnings .= "@_" };
        
        my $ae = $Class->new( archive => $Me );
        ok( !$ae,               "   No archive created based on '$Me'" );
        ok( !$Class->error,     "       Error not captured in class method" );
        ok( $warnings,          "       Error captured as warning" );
        like( $warnings, qr/Cannot determine file type for/,
                                "           Error is: unknown file type" );
    }                                
}    

### test multiple errors
### XXX whitebox test
{   ### grab a random file from the template, so we can make an object
    my $ae = Archive::Extract->new( 
                archive =>  File::Spec->catfile($SrcDir,[keys %$tmpl]->[0]) 
             );
    ok( $ae,                    "Archive created" );
    ok( not($ae->error),        "   No errors yet" );

    ### log a few errors
    {   local $Archive::Extract::WARN = 0;
        $ae->_error( $_ ) for 1..5;
    }

    my $err = $ae->error;
    ok( $err,                   "   Errors retrieved" );
    
    my $expect = join $/, 1..5;
    is( $err, $expect,          "       As expected" );

    ### this resets the errors
    ### override the 'check' routine to return false, so we bail out of 
    ### extract() early and just run the error reset code;
    {   no warnings qw[once redefine];
        local *Archive::Extract::check = sub { return }; 
        $ae->extract;
    }
    ok( not($ae->error),        "   Errors erased after ->extract() call" );
}

### XXX whitebox test
### test __get_extract_dir 
SKIP: {   my $meth = '__get_extract_dir';

    ### get the right separator -- File::Spec does clean ups for
    ### paths, so we need to join ourselves.
    my $sep  = [ split '', File::Spec->catfile( 'a', 'b' ) ]->[1];
    
    ### bug #23999: Attempt to generate Makefile.PL gone awry
    ### showed that dirs in the style of './dir/' were reported
    ### to be unpacked in '.' rather than in 'dir'. here we test
    ### for this.
    for my $prefix ( '', '.' ) {
        skip "Prepending ./ to a valid path doesn't give you another valid path on VMS", 2
            if IS_VMS && length($prefix);

        my $dir = basename( $SrcDir );

        ### build a list like [dir, dir/file] and [./dir ./dir/file]
        ### where the dir and file actually exist, which is important
        ### for the method call
        my @files = map { length $prefix 
                                ? join $sep, $prefix, $_
                                : $_
                      } $dir, File::Spec->catfile( $dir, [keys %$tmpl]->[0] );
        
        my $res = $Class->$meth( \@files );
        $res = &Win32::GetShortPathName( $res ) if IS_WIN32;

        ok( $res,               "Found extraction dir '$res'" );
        is( $res, $SrcDir,      "   Is expected dir '$SrcDir'" );
    }        
}

### configuration to run in: allow perl or allow binaries
for my $switch ( [0,1], [1,0] ) {
    my $cfg = "PP: $switch->[0] Bin: $switch->[1]";

    local $Archive::Extract::_ALLOW_PURE_PERL   = $switch->[0];
    local $Archive::Extract::_ALLOW_BIN         = $switch->[1];
    
    diag("Running extract with configuration: $cfg") if $Debug;

    for my $archive (keys %$tmpl) {
        diag("Archive : $archive") if $Debug;

        ### check first if we can do the proper

        my $ae = Archive::Extract->new(
                        archive => File::Spec->catfile($SrcDir,$archive) );

        ### Do an extra run with _ALLOW_TAR_ITER = 0 if it's a tar file of some
        ### sort
        my @with_tar_iter = ( 1 );
        push @with_tar_iter, 0 if grep { $ae->$_ } qw[is_tbz is_tgz is_txz is_tar];

        for my $tar_iter (@with_tar_iter) { SKIP: {

            ### Doesn't matter unless .tar, .tbz, .tgz, .txz
            local $Archive::Extract::_ALLOW_TAR_ITER = $tar_iter; 
        
            diag("Archive::Tar->iter: $tar_iter") if $Debug;

            isa_ok( $ae, $Class );

            my $method = $tmpl->{$archive}->{method};
            ok( $ae->$method(),         "Archive type $method recognized properly" );
        
            my $file        = $tmpl->{$archive}->{outfile};
            my $dir         = $tmpl->{$archive}->{outdir};  # can be undef
            my $rel_path    = File::Spec->catfile( grep { defined } $dir, $file );
            my $abs_path    = File::Spec->catfile( $OutDir, $rel_path );
            my $abs_dir     = File::Spec->catdir( 
                                grep { defined } $OutDir, $dir );
            my $nix_path    = File::Spec::Unix->catfile(
                                grep { defined } $dir, $file );

            ### check if we can run this test ###
            my $pgm_fail; my $mod_fail;
            for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
                ### no binary extract method
                $pgm_fail++, next unless $pgm;

                ### we dont have the program
                $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
                                   $Archive::Extract::PROGRAMS->{$pgm};

            }

            for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
                ### no module extract method
                $mod_fail++, next unless $mod;

                ### we dont have the module
                $mod_fail++ unless check_install( module => $mod );
            }

            ### where to extract to -- try both dir and file for gz files
            ### XXX test me!
            #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
            my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma || $ae->is_xz
                            ? ($abs_path) 
                            : ($OutDir);

            ### 10 tests from here on down ###
            if( ($mod_fail && ($pgm_fail || !$Archive::Extract::_ALLOW_BIN))
                ||
                ($pgm_fail && ($mod_fail || !$Archive::Extract::_ALLOW_PURE_PERL))
            ) {                
                skip "No binaries or modules to extract ".$archive, 
                    (10 * scalar @outs);
            }

            ### we dont warnings spewed about missing modules, that might
            ### be a problem...
            local $IPC::Cmd::WARN = 0;
            local $IPC::Cmd::WARN = 0;
            
            for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {

                ### test buffers ###
                my $turn_off = !$use_buffer && !$pgm_fail &&
                                $Archive::Extract::_ALLOW_BIN;

                ### whitebox test ###
                ### stupid warnings ###
                local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
                local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
                local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;
                local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;


                ### try extracting ###
                for my $to ( @outs ) {

                    diag("Extracting to: $to")                  if $Debug;
                    diag("Buffers enabled: ".!$turn_off)        if $Debug;
      
                    my $rv = $ae->extract( to => $to );
        
                    SKIP: {
                        my $re  = qr/^No buffer captured/;
                        my $err = $ae->error || '';
                  
                        ### skip buffer tests if we dont have buffers or
                        ### explicitly turned them off
                        skip "No buffers available", 8
                            if ( $turn_off || !IPC::Cmd->can_capture_buffer)
                                && $err =~ $re;

                        ### skip tests if we dont have an extractor
                        skip "No extractor available", 8 
                            if $err =~ /Extract failed; no extractors available/;
                            
                        ### win32 + bin utils is notorious, and none of them are
                        ### officially supported by strawberry. So if we 
                        ### encounter an error while extracting whlie running 
                        ### with $PREFER_BIN on win32, just skip the tests.
                        ### See rt#46948: unable to install install on win32
                        ### for details on the pain
                        skip "Binary tools on Win32 are very unreliable", 8
                            if $err and $Archive::Extract::_ALLOW_BIN 
                                    and IS_WIN32;
        
                        ok( $rv, "extract() for '$archive' reports success ($cfg)");
        
                        diag("Extractor was: " . $ae->_extractor)   if $Debug;
        
                        ### if we /should/ have buffers, there should be
                        ### no errors complaining we dont have them...
                        unlike( $err, $re,
                                        "No errors capturing buffers" );
        
                        ### might be 1 or 2, depending wether we extracted 
                        ### a dir too
                        my $files    = $ae->files || [];
                        my $file_cnt = grep { defined } $file, $dir;
                        is( scalar @$files, $file_cnt,
                                        "Found correct number of output files (@$files)" );
                        
                        ### due to prototypes on is(), if there's no -1 index on
                        ### the array ref, it'll give a fatal exception:
                        ### "Modification of non-creatable array value attempted,
                        ### subscript -1 at -e line 1." So wrap it in do { }
                        is( do { $files->[-1] }, $nix_path,
                                        "Found correct output file '$nix_path'" );
        
                        ok( -e $abs_path,
                                        "Output file '$abs_path' exists" );
                        ok( $ae->extract_path,
                                        "Extract dir found" );
                        ok( -d $ae->extract_path,
                                        "Extract dir exists" );
                        is( $ae->extract_path, $abs_dir,
                                        "Extract dir is expected '$abs_dir'" );
                    }

                    SKIP: {
                        skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;

                        1 while unlink $abs_path;
                        ok( !(-e $abs_path), "Output file successfully removed" );
            
                        SKIP: {
                            skip "No extract path captured, can't remove paths", 2
                                unless $ae->extract_path;
            
                            ### if something went wrong with determining the out
                            ### path, don't go deleting stuff.. might be Really Bad
                            my $out_re = quotemeta( $OutDir );
                            
                            ### VMS directory layout is different. Craig Berry
                            ### explains:
                            ### the test is trying to determine if C</disk1/foo/bar>
                            ### is part of C</disk1/foo/bar/baz>.  Except in VMS
                            ### syntax, that would mean trying to determine whether
                            ### C<disk1:[foo.bar]> is part of C<disk1:[foo.bar.baz]>
                            ### Because we have both a directory delimiter
                            ### (dot) and a directory spec terminator (right 
                            ### bracket), we have to trim the right bracket from 
                            ### the first one to make it successfully match the
                            ### second one.  Since we're asserting the same truth --
                            ### that one path spec is the leading part of the other
                            ### -- it seems to me ok to have this in the test only.
                            ### 
                            ### so we strip the ']' of the back of the regex
                            $out_re =~ s/\\\]// if IS_VMS; 
                            
                            if( $ae->extract_path !~ /^$out_re/ ) {   
                                ok( 0, "Extractpath WRONG (".$ae->extract_path.")"); 
                                skip(  "Unsafe operation -- skip cleanup!!!" ), 1;
                            }                    
            
                            eval { rmtree( $ae->extract_path ) }; 
                            ok( !$@,        "   rmtree gave no error" );
                            ok( !(-d $ae->extract_path ),
                                            "   Extract dir succesfully removed" );
                        }
                    }
                }
            }
        } }
    }
}
Commit	Line	Data
520c99e2 JB	1	BEGIN { chdir 't' if -d 't' };
520c99e2 JB	2	BEGIN { mkdir 'out' unless -d 'out' };
9e5a0ef9 JB	3
	4	### left behind, at least on Win32. See core patch #31904
	5	END { rmtree('out') };
520c99e2 JB	6
	7	use strict;
	8	use lib qw[../lib];
	9
	10	use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
	11	use constant IS_CYGWIN => $^O eq 'cygwin' ? 1 : 0;
e87b63e2	12	use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
520c99e2 JB	13
	14	use Cwd qw[cwd];
	15	use Test::More qw[no_plan];
	16	use File::Spec;
	17	use File::Spec::Unix;
	18	use File::Path;
	19	use Data::Dumper;
	20	use File::Basename qw[basename];
	21	use Module::Load::Conditional qw[check_install];
	22
	23	### uninitialized value in File::Spec warnings come from A::Zip:
	24	# t/01_Archive-Extract....ok 135/0Use of uninitialized value in concatenation (.) or string at /opt/lib/perl5/5.8.3/File/Spec/Unix.pm line 313.
	25	# File::Spec::Unix::catpath('File::Spec','','','undef') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 473
	26	# Archive::Zip::_asLocalName('') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 652
	27	# Archive::Zip::Archive::extractMember('Archive::Zip::Archive=HASH(0x9679c8)','Archive::Zip::ZipFileMember=HASH(0x9678fc)') called at ../lib/Archive/Extract.pm line 753
	28	# Archive::Extract::_unzip_az('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 674
	29	# Archive::Extract::_unzip('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 275
	30	# Archive::Extract::extract('Archive::Extract=HASH(0x966eac)','to','/Users/kane/sources/p4/other/archive-extract/t/out') called at t/01_Archive-Extract.t line 180
	31	#BEGIN { $SIG{__WARN__} = sub { require Carp; Carp::cluck(@_) } };
	32
03998fa0	33	if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) {
520c99e2 JB	34	diag( "Older versions of Archive::Zip may cause File::Spec warnings" );
	35	diag( "See bug #19713 in rt.cpan.org. It is safe to ignore them" );
	36	}
	37
520c99e2 JB	38	my $Me = basename( $0 );
520c99e2 JB	39	my $Class = 'Archive::Extract';
e74f3fd4 JB	40
	41	use_ok($Class);
	42
	43	### debug will always be enabled on dev versions
	44	my $Debug = (not $ENV{PERL_CORE} and
	45	($ARGV[0] or $Archive::Extract::VERSION =~ /_/))
	46	? 1
	47	: 0;
	48
520c99e2 JB	49	my $Self = File::Spec->rel2abs(
	50	IS_WIN32 ? &Win32::GetShortPathName( cwd() ) : cwd()
	51	);
	52	my $SrcDir = File::Spec->catdir( $Self,'src' );
	53	my $OutDir = File::Spec->catdir( $Self,'out' );
	54
520c99e2	55	### stupid stupid silly stupid warnings silly! ###
e74f3fd4 JB	56	$Archive::Extract::DEBUG = $Archive::Extract::DEBUG = $Debug;
e74f3fd4 JB	57	$Archive::Extract::WARN = $Archive::Extract::WARN = $Debug;
520c99e2	58
e74f3fd4	59	diag( "\n\n* DEBUG INFORMATION ENABLED *\n\n" ) if $Debug;
8d2ac73b	60
35fe4187 CBW	61	# Be as evil as possible to print
	62	$\ = "ORS_FLAG";
	63	$, = "OFS_FLAG";
	64	$" = "LISTSEP_FLAG";
	65
520c99e2 JB	66	my $tmpl = {
	67	### plain files
	68	'x.bz2' => { programs => [qw[bunzip2]],
	69	modules => [qw[IO::Uncompress::Bunzip2]],
	70	method => 'is_bz2',
	71	outfile => 'a',
	72	},
	73	'x.tgz' => { programs => [qw[gzip tar]],
	74	modules => [qw[Archive::Tar IO::Zlib]],
	75	method => 'is_tgz',
	76	outfile => 'a',
	77	},
	78	'x.tar.gz' => { programs => [qw[gzip tar]],
	79	modules => [qw[Archive::Tar IO::Zlib]],
	80	method => 'is_tgz',
	81	outfile => 'a',
	82	},
	83	'x.tar' => { programs => [qw[tar]],
	84	modules => [qw[Archive::Tar]],
	85	method => 'is_tar',
	86	outfile => 'a',
	87	},
1dae2fb5	88	'x.gz' => { programs => [qw[gzip]],
520c99e2 JB	89	modules => [qw[Compress::Zlib]],
	90	method => 'is_gz',
	91	outfile => 'a',
	92	},
1dae2fb5 RGS	93	'x.Z' => { programs => [qw[uncompress]],
	94	modules => [qw[Compress::Zlib]],
	95	method => 'is_Z',
	96	outfile => 'a',
	97	},
520c99e2 JB	98	'x.zip' => { programs => [qw[unzip]],
	99	modules => [qw[Archive::Zip]],
	100	method => 'is_zip',
	101	outfile => 'a',
	102	},
	103	'x.jar' => { programs => [qw[unzip]],
	104	modules => [qw[Archive::Zip]],
	105	method => 'is_zip',
	106	outfile => 'a',
	107	},
	108	'x.par' => { programs => [qw[unzip]],
	109	modules => [qw[Archive::Zip]],
	110	method => 'is_zip',
	111	outfile => 'a',
	112	},
8d2ac73b SP	113	'x.lzma' => { programs => [qw[unlzma]],
	114	modules => [qw[Compress::unLZMA]],
	115	method => 'is_lzma',
	116	outfile => 'a',
	117	},
d7f87992 CBW	118	'x.xz' => { programs => [qw[unxz]],
	119	modules => [qw[IO::Uncompress::UnXz]],
	120	method => 'is_xz',
	121	outfile => 'a',
	122	},
	123	'x.txz' => { programs => [qw[unxz tar]],
	124	modules => [qw[Archive::Tar
	125	IO::Uncompress::UnXz]],
	126	method => 'is_txz',
	127	outfile => 'a',
	128	},
	129	'x.tar.xz'=> { programs => [qw[unxz tar]],
	130	modules => [qw[Archive::Tar
	131	IO::Uncompress::UnXz]],
	132	method => 'is_txz',
	133	outfile => 'a',
	134	},
520c99e2 JB	135	### with a directory
	136	'y.tbz' => { programs => [qw[bunzip2 tar]],
	137	modules => [qw[Archive::Tar
	138	IO::Uncompress::Bunzip2]],
	139	method => 'is_tbz',
	140	outfile => 'z',
	141	outdir => 'y',
	142	},
	143	'y.tar.bz2' => { programs => [qw[bunzip2 tar]],
	144	modules => [qw[Archive::Tar
	145	IO::Uncompress::Bunzip2]],
	146	method => 'is_tbz',
	147	outfile => 'z',
	148	outdir => 'y'
	149	},
d7f87992 CBW	150	'y.txz' => { programs => [qw[unxz tar]],
	151	modules => [qw[Archive::Tar
	152	IO::Uncompress::UnXz]],
	153	method => 'is_txz',
	154	outfile => 'z',
	155	outdir => 'y',
	156	},
	157	'y.tar.xz' => { programs => [qw[unxz tar]],
	158	modules => [qw[Archive::Tar
	159	IO::Uncompress::UnXz]],
	160	method => 'is_txz',
	161	outfile => 'z',
	162	outdir => 'y'
	163	},
520c99e2 JB	164	'y.tgz' => { programs => [qw[gzip tar]],
	165	modules => [qw[Archive::Tar IO::Zlib]],
	166	method => 'is_tgz',
	167	outfile => 'z',
	168	outdir => 'y'
	169	},
	170	'y.tar.gz' => { programs => [qw[gzip tar]],
	171	modules => [qw[Archive::Tar IO::Zlib]],
	172	method => 'is_tgz',
	173	outfile => 'z',
	174	outdir => 'y'
	175	},
	176	'y.tar' => { programs => [qw[tar]],
	177	modules => [qw[Archive::Tar]],
	178	method => 'is_tar',
	179	outfile => 'z',
	180	outdir => 'y'
	181	},
	182	'y.zip' => { programs => [qw[unzip]],
	183	modules => [qw[Archive::Zip]],
	184	method => 'is_zip',
	185	outfile => 'z',
	186	outdir => 'y'
	187	},
	188	'y.par' => { programs => [qw[unzip]],
	189	modules => [qw[Archive::Zip]],
	190	method => 'is_zip',
	191	outfile => 'z',
	192	outdir => 'y'
	193	},
	194	'y.jar' => { programs => [qw[unzip]],
	195	modules => [qw[Archive::Zip]],
	196	method => 'is_zip',
	197	outfile => 'z',
	198	outdir => 'y'
	199	},
	200	### with non-same top dir
	201	'double_dir.zip' => {
	202	programs => [qw[unzip]],
	203	modules => [qw[Archive::Zip]],
	204	method => 'is_zip',
	205	outfile => 'w',
	206	outdir => 'x'
	207	},
	208	};
	209
9e5a0ef9 JB	210	### XXX special case: on older solaris boxes (8),
	211	### bunzip2 is version 0.9.x. Older versions (pre 1),
	212	### only extract files that end in .bz2, and nothing
	213	### else. So remove that test case if we have an older
	214	### bunzip2 :(
	215	{ if( $Class->have_old_bunzip2 ) {
	216	delete $tmpl->{'y.tbz'};
	217	diag "Old bunzip2 detected, skipping .tbz test";
	218	}
	219	}
	220
520c99e2 JB	221	### show us the tools IPC::Cmd will use to run binary programs
	222	if( $Debug ) {
	223	diag( "IPC::Run enabled: $IPC::Cmd::USE_IPC_RUN " );
	224	diag( "IPC::Run available: " . IPC::Cmd->can_use_ipc_run );
	225	diag( "IPC::Run vesion: $IPC::Run::VERSION" );
	226	diag( "IPC::Open3 enabled: $IPC::Cmd::USE_IPC_OPEN3 " );
	227	diag( "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3 );
	228	diag( "IPC::Open3 vesion: $IPC::Open3::VERSION" );
	229	}
	230
	231	### test all type specifications to new()
	232	### this tests bug #24578: Wrong check for `type' argument
	233	{ my $meth = 'types';
	234
	235	can_ok( $Class, $meth );
	236
	237	my @types = $Class->$meth;
	238	ok( scalar(@types), " Got a list of types" );
	239
	240	for my $type ( @types ) {
	241	my $obj = $Class->new( archive => $Me, type => $type );
	242	ok( $obj, " Object created based on '$type'" );
	243	ok( !$obj->error, " No error logged" );
	244	}
83285295 JB	245
	246	### test unknown type
	247	{ ### must turn on warnings to catch error here
	248	local $Archive::Extract::WARN = 1;
	249
	250	my $warnings;
	251	local $SIG{__WARN__} = sub { $warnings .= "@_" };
	252
	253	my $ae = $Class->new( archive => $Me );
	254	ok( !$ae, " No archive created based on '$Me'" );
	255	ok( !$Class->error, " Error not captured in class method" );
	256	ok( $warnings, " Error captured as warning" );
	257	like( $warnings, qr/Cannot determine file type for/,
	258	" Error is: unknown file type" );
	259	}
520c99e2 JB	260	}
520c99e2 JB	261
83285295 JB	262	### test multiple errors
	263	### XXX whitebox test
	264	{ ### grab a random file from the template, so we can make an object
	265	my $ae = Archive::Extract->new(
	266	archive => File::Spec->catfile($SrcDir,[keys %$tmpl]->[0])
	267	);
	268	ok( $ae, "Archive created" );
	269	ok( not($ae->error), " No errors yet" );
	270
	271	### log a few errors
	272	{ local $Archive::Extract::WARN = 0;
	273	$ae->_error( $_ ) for 1..5;
	274	}
	275
	276	my $err = $ae->error;
	277	ok( $err, " Errors retrieved" );
	278
	279	my $expect = join $/, 1..5;
	280	is( $err, $expect, " As expected" );
	281
	282	### this resets the errors
	283	### override the 'check' routine to return false, so we bail out of
	284	### extract() early and just run the error reset code;
	285	{ no warnings qw[once redefine];
	286	local *Archive::Extract::check = sub { return };
	287	$ae->extract;
	288	}
	289	ok( not($ae->error), " Errors erased after ->extract() call" );
	290	}
	291
520c99e2 JB	292	### XXX whitebox test
520c99e2 JB	293	### test __get_extract_dir
e87b63e2	294	SKIP: { my $meth = '__get_extract_dir';
520c99e2	295
e87b63e2	296	### get the right separator -- File::Spec does clean ups for
520c99e2 JB	297	### paths, so we need to join ourselves.
	298	my $sep = [ split '', File::Spec->catfile( 'a', 'b' ) ]->[1];
	299
	300	### bug #23999: Attempt to generate Makefile.PL gone awry
	301	### showed that dirs in the style of './dir/' were reported
	302	### to be unpacked in '.' rather than in 'dir'. here we test
	303	### for this.
	304	for my $prefix ( '', '.' ) {
e87b63e2 CB	305	skip "Prepending ./ to a valid path doesn't give you another valid path on VMS", 2
	306	if IS_VMS && length($prefix);
	307
520c99e2 JB	308	my $dir = basename( $SrcDir );
	309
	310	### build a list like [dir, dir/file] and [./dir ./dir/file]
	311	### where the dir and file actually exist, which is important
	312	### for the method call
	313	my @files = map { length $prefix
	314	? join $sep, $prefix, $_
	315	: $_
	316	} $dir, File::Spec->catfile( $dir, [keys %$tmpl]->[0] );
	317
	318	my $res = $Class->$meth( \@files );
	319	$res = &Win32::GetShortPathName( $res ) if IS_WIN32;
	320
	321	ok( $res, "Found extraction dir '$res'" );
	322	is( $res, $SrcDir, " Is expected dir '$SrcDir'" );
	323	}
	324	}
	325
83285295 JB	326	### configuration to run in: allow perl or allow binaries
	327	for my $switch ( [0,1], [1,0] ) {
	328	my $cfg = "PP: $switch->[0] Bin: $switch->[1]";
520c99e2	329
83285295 JB	330	local $Archive::Extract::_ALLOW_PURE_PERL = $switch->[0];
	331	local $Archive::Extract::_ALLOW_BIN = $switch->[1];
	332
	333	diag("Running extract with configuration: $cfg") if $Debug;
520c99e2 JB	334
520c99e2 JB	335	for my $archive (keys %$tmpl) {
d7f87992	336	diag("Archive : $archive") if $Debug;
520c99e2	337
520c99e2 JB	338	### check first if we can do the proper
	339
	340	my $ae = Archive::Extract->new(
	341	archive => File::Spec->catfile($SrcDir,$archive) );
	342
198e857c JB	343	### Do an extra run with _ALLOW_TAR_ITER = 0 if it's a tar file of some
	344	### sort
	345	my @with_tar_iter = ( 1 );
d7f87992	346	push @with_tar_iter, 0 if grep { $ae->$_ } qw[is_tbz is_tgz is_txz is_tar];
520c99e2	347
198e857c	348	for my $tar_iter (@with_tar_iter) { SKIP: {
520c99e2	349
d7f87992	350	### Doesn't matter unless .tar, .tbz, .tgz, .txz
ea079934 DM	351	local $Archive::Extract::_ALLOW_TAR_ITER = $tar_iter;
ea079934 DM	352
198e857c	353	diag("Archive::Tar->iter: $tar_iter") if $Debug;
520c99e2	354
198e857c	355	isa_ok( $ae, $Class );
520c99e2	356
198e857c	357	my $method = $tmpl->{$archive}->{method};
d7f87992	358	ok( $ae->$method(), "Archive type $method recognized properly" );
ea079934	359
198e857c JB	360	my $file = $tmpl->{$archive}->{outfile};
	361	my $dir = $tmpl->{$archive}->{outdir}; # can be undef
	362	my $rel_path = File::Spec->catfile( grep { defined } $dir, $file );
	363	my $abs_path = File::Spec->catfile( $OutDir, $rel_path );
ea079934	364	my $abs_dir = File::Spec->catdir(
198e857c JB	365	grep { defined } $OutDir, $dir );
	366	my $nix_path = File::Spec::Unix->catfile(
	367	grep { defined } $dir, $file );
	368
	369	### check if we can run this test ###
	370	my $pgm_fail; my $mod_fail;
	371	for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
	372	### no binary extract method
	373	$pgm_fail++, next unless $pgm;
	374
	375	### we dont have the program
	376	$pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
	377	$Archive::Extract::PROGRAMS->{$pgm};
	378
	379	}
	380
	381	for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
	382	### no module extract method
	383	$mod_fail++, next unless $mod;
	384
	385	### we dont have the module
	386	$mod_fail++ unless check_install( module => $mod );
	387	}
	388
	389	### where to extract to -- try both dir and file for gz files
	390	### XXX test me!
	391	#my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
d7f87992	392	my @outs = $ae->is_gz \|\| $ae->is_bz2 \|\| $ae->is_Z \|\| $ae->is_lzma \|\| $ae->is_xz
ea079934	393	? ($abs_path)
198e857c JB	394	: ($OutDir);
	395
	396	### 10 tests from here on down ###
	397	if( ($mod_fail && ($pgm_fail \|\| !$Archive::Extract::_ALLOW_BIN))
	398	\|\|
	399	($pgm_fail && ($mod_fail \|\| !$Archive::Extract::_ALLOW_PURE_PERL))
ea079934 DM	400	) {
ea079934 DM	401	skip "No binaries or modules to extract ".$archive,
198e857c JB	402	(10 * scalar @outs);
	403	}
	404
	405	### we dont warnings spewed about missing modules, that might
	406	### be a problem...
	407	local $IPC::Cmd::WARN = 0;
	408	local $IPC::Cmd::WARN = 0;
ea079934	409
198e857c JB	410	for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {
	411
	412	### test buffers ###
	413	my $turn_off = !$use_buffer && !$pgm_fail &&
	414	$Archive::Extract::_ALLOW_BIN;
	415
	416	### whitebox test ###
	417	### stupid warnings ###
	418	local $IPC::Cmd::USE_IPC_RUN = 0 if $turn_off;
	419	local $IPC::Cmd::USE_IPC_RUN = 0 if $turn_off;
	420	local $IPC::Cmd::USE_IPC_OPEN3 = 0 if $turn_off;
	421	local $IPC::Cmd::USE_IPC_OPEN3 = 0 if $turn_off;
	422
	423
	424	### try extracting ###
	425	for my $to ( @outs ) {
	426
	427	diag("Extracting to: $to") if $Debug;
	428	diag("Buffers enabled: ".!$turn_off) if $Debug;
ea079934	429
198e857c	430	my $rv = $ae->extract( to => $to );
520c99e2 JB	431
520c99e2 JB	432	SKIP: {
198e857c JB	433	my $re = qr/^No buffer captured/;
198e857c JB	434	my $err = $ae->error \|\| '';
ea079934	435
198e857c JB	436	### skip buffer tests if we dont have buffers or
	437	### explicitly turned them off
	438	skip "No buffers available", 8
	439	if ( $turn_off \|\| !IPC::Cmd->can_capture_buffer)
	440	&& $err =~ $re;
	441
	442	### skip tests if we dont have an extractor
ea079934	443	skip "No extractor available", 8
198e857c	444	if $err =~ /Extract failed; no extractors available/;
ea079934	445
198e857c	446	### win32 + bin utils is notorious, and none of them are
ea079934 DM	447	### officially supported by strawberry. So if we
ea079934 DM	448	### encounter an error while extracting whlie running
198e857c JB	449	### with $PREFER_BIN on win32, just skip the tests.
	450	### See rt#46948: unable to install install on win32
	451	### for details on the pain
	452	skip "Binary tools on Win32 are very unreliable", 8
ea079934	453	if $err and $Archive::Extract::_ALLOW_BIN
198e857c	454	and IS_WIN32;
520c99e2	455
198e857c	456	ok( $rv, "extract() for '$archive' reports success ($cfg)");
ea079934	457
198e857c	458	diag("Extractor was: " . $ae->_extractor) if $Debug;
ea079934	459
198e857c JB	460	### if we /should/ have buffers, there should be
	461	### no errors complaining we dont have them...
	462	unlike( $err, $re,
	463	"No errors capturing buffers" );
ea079934 DM	464
ea079934 DM	465	### might be 1 or 2, depending wether we extracted
198e857c JB	466	### a dir too
	467	my $files = $ae->files \|\| [];
	468	my $file_cnt = grep { defined } $file, $dir;
	469	is( scalar @$files, $file_cnt,
	470	"Found correct number of output files (@$files)" );
9e5a0ef9	471
198e857c JB	472	### due to prototypes on is(), if there's no -1 index on
	473	### the array ref, it'll give a fatal exception:
	474	### "Modification of non-creatable array value attempted,
	475	### subscript -1 at -e line 1." So wrap it in do { }
	476	is( do { $files->[-1] }, $nix_path,
	477	"Found correct output file '$nix_path'" );
ea079934	478
198e857c JB	479	ok( -e $abs_path,
	480	"Output file '$abs_path' exists" );
	481	ok( $ae->extract_path,
	482	"Extract dir found" );
	483	ok( -d $ae->extract_path,
	484	"Extract dir exists" );
	485	is( $ae->extract_path, $abs_dir,
	486	"Extract dir is expected '$abs_dir'" );
	487	}
	488
	489	SKIP: {
	490	skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;
	491
	492	1 while unlink $abs_path;
	493	ok( !(-e $abs_path), "Output file successfully removed" );
ea079934	494
198e857c JB	495	SKIP: {
	496	skip "No extract path captured, can't remove paths", 2
	497	unless $ae->extract_path;
ea079934	498
198e857c JB	499	### if something went wrong with determining the out
	500	### path, don't go deleting stuff.. might be Really Bad
	501	my $out_re = quotemeta( $OutDir );
ea079934	502
198e857c JB	503	### VMS directory layout is different. Craig Berry
	504	### explains:
	505	### the test is trying to determine if C</disk1/foo/bar>
	506	### is part of C</disk1/foo/bar/baz>. Except in VMS
	507	### syntax, that would mean trying to determine whether
	508	### C<disk1:[foo.bar]> is part of C<disk1:[foo.bar.baz]>
	509	### Because we have both a directory delimiter
ea079934 DM	510	### (dot) and a directory spec terminator (right
ea079934 DM	511	### bracket), we have to trim the right bracket from
198e857c JB	512	### the first one to make it successfully match the
	513	### second one. Since we're asserting the same truth --
	514	### that one path spec is the leading part of the other
	515	### -- it seems to me ok to have this in the test only.
ea079934	516	###
198e857c	517	### so we strip the ']' of the back of the regex
ea079934 DM	518	$out_re =~ s/\\\]// if IS_VMS;
	519
	520	if( $ae->extract_path !~ /^$out_re/ ) {
	521	ok( 0, "Extractpath WRONG (".$ae->extract_path.")");
198e857c	522	skip( "Unsafe operation -- skip cleanup!!!" ), 1;
ea079934 DM	523	}
	524
	525	eval { rmtree( $ae->extract_path ) };
198e857c JB	526	ok( !$@, " rmtree gave no error" );
	527	ok( !(-d $ae->extract_path ),
	528	" Extract dir succesfully removed" );
	529	}
520c99e2 JB	530	}
	531	}
	532	}
198e857c JB	533	} }
198e857c JB	534	}
520c99e2	535	}