[p5sagit/p5-mst-13.2.git] / lib / Archive / Extract / t / 01_Archive-Extract.t

BEGIN { 
    if( $ENV{PERL_CORE} ) {
        chdir '../lib/Archive/Extract' if -d '../lib/Archive/Extract';
        unshift @INC, '../../..', '../../../..';
    }
}    

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 $Debug   = $ARGV[0] ? 1 : 0;
my $Me      = basename( $0 );
my $Class   = 'Archive::Extract';
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' );

use_ok($Class);

### set verbose if debug is on ###
### stupid stupid silly stupid warnings silly! ###
$Archive::Extract::VERBOSE  = $Archive::Extract::VERBOSE = $Debug;
$Archive::Extract::WARN     = $Archive::Extract::WARN    = $Debug ? 1 : 0;


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',
                },
    ### 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.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("Extracting $archive in config $cfg") if $Debug;

        ### check first if we can do the proper

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

        isa_ok( $ae, $Class );

        my $method = $tmpl->{$archive}->{method};
        ok( $ae->$method(),         "Archive type recognized properly" );

    ### 10 tests from here on down ###
    SKIP: {
        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
                        ? ($abs_path) 
                        : ($OutDir);

        skip "No binaries or modules to extract ".$archive, 
            (10 * scalar @outs) if $mod_fail && $pgm_fail;

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