From 83285295780b6718141d6f5bf054a2e6da464e39 Mon Sep 17 00:00:00 2001 From: "Jos I. Boumans" Date: Sat, 13 Dec 2008 18:36:13 +0100 Subject: [PATCH] Update Archive::Extract to 0.28 From: "Jos I. Boumans" Message-Id: p4raw-id: //depot/perl@35105 --- lib/Archive/Extract.pm | 367 +++++++++--------- lib/Archive/Extract/t/01_Archive-Extract.t | 84 +++- .../Extract/t/src/double_dir.zip.packed | 2 +- lib/Archive/Extract/t/src/x.Z.packed | 2 +- lib/Archive/Extract/t/src/x.bz2.packed | 2 +- lib/Archive/Extract/t/src/x.gz.packed | 2 +- lib/Archive/Extract/t/src/x.jar.packed | 2 +- lib/Archive/Extract/t/src/x.lzma.packed | 2 +- lib/Archive/Extract/t/src/x.par.packed | 2 +- lib/Archive/Extract/t/src/x.tar.gz.packed | 2 +- lib/Archive/Extract/t/src/x.tar.packed | 2 +- lib/Archive/Extract/t/src/x.tgz.packed | 2 +- lib/Archive/Extract/t/src/x.zip.packed | 2 +- lib/Archive/Extract/t/src/y.jar.packed | 2 +- lib/Archive/Extract/t/src/y.par.packed | 2 +- lib/Archive/Extract/t/src/y.tar.bz2.packed | 2 +- lib/Archive/Extract/t/src/y.tar.gz.packed | 2 +- lib/Archive/Extract/t/src/y.tar.packed | 2 +- lib/Archive/Extract/t/src/y.tbz.packed | 2 +- lib/Archive/Extract/t/src/y.tgz.packed | 2 +- lib/Archive/Extract/t/src/y.zip.packed | 2 +- 21 files changed, 278 insertions(+), 211 deletions(-) diff --git a/lib/Archive/Extract.pm b/lib/Archive/Extract.pm index d0cba4e776a..c7486bd100d 100644 --- a/lib/Archive/Extract.pm +++ b/lib/Archive/Extract.pm @@ -20,6 +20,10 @@ use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; ### VMS may require quoting upper case command options use constant ON_VMS => $^O eq 'VMS' ? 1 : 0; +### we can't use this extraction method, because of missing +### modules/binaries: +use constant METHOD_NA => []; + ### If these are changed, update @TYPES and the new() POD use constant TGZ => 'tgz'; use constant TAR => 'tar'; @@ -30,13 +34,19 @@ use constant TBZ => 'tbz'; use constant Z => 'Z'; use constant LZMA => 'lzma'; -use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG]; +use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG + $_ALLOW_BIN $_ALLOW_PURE_PERL + ]; + +$VERSION = '0.28'; +$PREFER_BIN = 0; +$WARN = 1; +$DEBUG = 0; +$_ALLOW_PURE_PERL = 1; # allow pure perl extractors +$_ALLOW_BIN = 1; # allow binary extractors -$VERSION = '0.26'; -$PREFER_BIN = 0; -$WARN = 1; -$DEBUG = 0; -my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA ); # same as all constants +# same as all constants +my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA ); local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; @@ -109,27 +119,30 @@ for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) { } ### mapping from types to extractor methods ### -my $Mapping = { - is_tgz => '_untar', - is_tar => '_untar', - is_gz => '_gunzip', - is_zip => '_unzip', - is_tbz => '_untar', - is_bz2 => '_bunzip2', - is_Z => '_uncompress', - is_lzma => '_unlzma', +my $Mapping = { # binary program # pure perl module + is_tgz => { bin => '_untar_bin', pp => '_untar_at' }, + is_tar => { bin => '_untar_bin', pp => '_untar_at' }, + is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' }, + is_zip => { bin => '_unzip_bin', pp => '_unzip_az' }, + is_tbz => { bin => '_untar_bin', pp => '_untar_at' }, + is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, + is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, + is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, }; -{ +{ ### use subs so we re-generate array refs etc for the no-overide flags + ### if we don't, then we reuse the same arrayref, meaning objects store + ### previous errors my $tmpl = { - archive => { required => 1, allow => FILE_EXISTS }, - type => { default => '', allow => [ @Types ] }, + archive => sub { { required => 1, allow => FILE_EXISTS } }, + type => sub { { default => '', allow => [ @Types ] } }, + _error_msg => sub { { no_override => 1, default => [] } }, + _error_msg_long => sub { { no_override => 1, default => [] } }, }; ### build accesssors ### for my $method( keys %$tmpl, qw[_extractor _gunzip_to files extract_path], - qw[_error_msg _error_msg_long] ) { no strict 'refs'; *$method = sub { @@ -202,8 +215,12 @@ Returns a C object on success, or false on failure. sub new { my $class = shift; my %hash = @_; + + ### see above why we use subs here and generate the template; + ### it's basically to not re-use arrayrefs + my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl; - my $parsed = check( $tmpl, \%hash ) or return; + my $parsed = check( \%utmpl, \%hash ) or return; ### make sure we have an absolute path ### my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); @@ -223,11 +240,13 @@ Returns a C object on success, or false on failure. } - ### don't know what type of file it is ### - return __PACKAGE__->_error(loc("Cannot determine file type for '%1'", - $parsed->{archive} )) unless $parsed->{type}; + bless $parsed, $class; - return bless $parsed, $class; + ### don't know what type of file it is + ### XXX this *has* to be an object call, not a package call + return $parsed->_error(loc("Cannot determine file type for '%1'", + $parsed->{archive} )) unless $parsed->{type}; + return $parsed; } } @@ -239,11 +258,11 @@ C. Since C<.gz> files never hold a directory, but only a single file; if the C argument is an existing directory, the file is extracted -there, with it's C<.gz> suffix stripped. +there, with its C<.gz> suffix stripped. If the C argument is not an existing directory, the C argument is understood to be a filename, if the archive type is C. In the case that you did not specify a C argument, the output -file will be the name of the archive file, stripped from it's C<.gz> +file will be the name of the archive file, stripped from its C<.gz> suffix, in the current working directory. C will try a pure perl solution first, and then fall back to @@ -279,6 +298,10 @@ sub extract { my $self = shift; my %hash = @_; + ### reset error messages + $self->_error_msg( [] ); + $self->_error_msg_long( [] ); + my $to; my $tmpl = { to => { default => '.', store => \$to } @@ -340,19 +363,50 @@ sub extract { ### ../lib/Archive/Extract.pm line 742. (rt #19815) $self->files( [] ); - ### find what extractor method to use ### - while( my($type,$method) = each %$Mapping ) { + ### find out the dispatch methods needed for this type of + ### archive. Do a $self->is_XXX to figure out the type, then + ### get the hashref with bin + pure perl dispatchers. + my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping; - ### call the corresponding method if the type is OK ### - if( $self->$type) { - $ok = $self->$method(); - } - } + ### add pure perl extractor if allowed & add bin extractor if allowed + my @methods; + push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL; + push @methods, $map->{'bin'} if $_ALLOW_BIN; + + ### reverse it if we prefer bin extractors + @methods = reverse @methods if $PREFER_BIN; - ### warn something went wrong if we didn't get an OK ### - $self->_error(loc("Extract failed, no extractor found")) - unless $ok; + my($na, $fail); + for my $method (@methods) { + print "# Extracting with ->$method\n" if $DEBUG; + + my $rv = $self->$method; + + ### a positive extraction + if( $rv and $rv ne METHOD_NA ) { + print "# Extraction succeeded\n" if $DEBUG; + $self->_extractor($method); + last; + + ### method is not available + } elsif ( $rv and $rv eq METHOD_NA ) { + print "# Extraction method not available\n" if $DEBUG; + $na++; + } else { + print "# Extraction method failed\n" if $DEBUG; + $fail++; + } + } + ### warn something went wrong if we didn't get an extractor + unless( $self->_extractor ) { + my $diag = $fail ? loc("Extract failed due to errors") : + $na ? loc("Extract failed; no extractors available") : + ''; + + $self->_error($diag); + $ok = 0; + } } ### and chdir back ### @@ -504,7 +558,7 @@ sub have_old_bunzip2 { ### double hateful: bunzip2 --version also hangs if input is a pipe ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH] ### So, we have to provide *another* argument which is a fake filename, - ### just so it wont try to read from stdin to print it's version.. + ### just so it wont try to read from stdin to print its version.. ### *sigh* ### Even if the file exists, it won't clobber or change it. my $buffer; @@ -529,43 +583,32 @@ sub have_old_bunzip2 { # ################################# -### untar wrapper... goes to either Archive::Tar or /bin/tar -### depending on $PREFER_BIN -sub _untar { - my $self = shift; - - ### bzip2 support in A::T via IO::Uncompress::Bzip2 - my @methods = qw[_untar_at _untar_bin]; - @methods = reverse @methods if $PREFER_BIN; - - for my $method (@methods) { - $self->_extractor($method) && return 1 if $self->$method(); - } - - return $self->_error(loc("Unable to untar file '%1'", $self->archive)); -} ### use /bin/tar to extract ### sub _untar_bin { my $self = shift; ### check for /bin/tar ### - return $self->_error(loc("No '%1' program found", '/bin/tar')) - unless $self->bin_tar; - ### check for /bin/gzip if we need it ### - return $self->_error(loc("No '%1' program found", '/bin/gzip')) - if $self->is_tgz && !$self->bin_gzip; - - return $self->_error(loc("No '%1' program found", '/bin/bunzip2')) - if $self->is_tbz && !$self->bin_bunzip2; + ### if any of the binaries are not available, return NA + { my $diag = not $self->bin_tar ? + loc("No '%1' program found", '/bin/tar') : + $self->is_tgz && !$self->bin_gzip ? + loc("No '%1' program found", '/bin/gzip') : + $self->is_tbz && !$self->bin_bunzip2 ? + loc("No '%1' program found", '/bin/bunzip2') : + ''; + + if( $diag ) { + $self->_error( $diag ); + return METHOD_NA; + } + } ### XXX figure out how to make IPC::Run do this in one call -- ### currently i don't know how to get output of a command after a pipe ### trapped in a scalar. Mailed barries about this 5th of june 2004. - - ### see what command we should run, based on whether ### it's a .tgz or .tar @@ -649,14 +692,25 @@ sub _untar_bin { sub _untar_at { my $self = shift; - ### we definitely need A::T, so load that first + ### Loading Archive::Tar is going to set it to 1, so make it local + ### within this block, starting with its initial value. Whatever + ### Achive::Tar does will be undone when we return. + ### + ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN + ### so users don't have to even think about this variable. If they + ### do, they still get their set value outside of this call. + local $Archive::Tar::WARN = $Archive::Tar::WARN; + + ### we definitely need Archive::Tar, so load that first { my $use_list = { 'Archive::Tar' => '0.0' }; unless( can_load( modules => $use_list ) ) { - return $self->_error(loc("You do not have '%1' installed - " . - "Please install it as soon as possible.", - 'Archive::Tar')); + $self->_error(loc("You do not have '%1' installed - " . + "Please install it as soon as possible.", + 'Archive::Tar')); + + return METHOD_NA; } } @@ -673,18 +727,24 @@ sub _untar_at { unless( can_load( modules => $use_list ) ) { my $which = join '/', sort keys %$use_list; - return $self->_error(loc( - "You do not have '%1' installed - Please ". - "install it as soon as possible.", $which)); - + $self->_error(loc( + "You do not have '%1' installed - Please ". + "install it as soon as possible.", $which) + ); + + return METHOD_NA; } + } elsif ( $self->is_tbz ) { my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; unless( can_load( modules => $use_list ) ) { - return $self->_error(loc( - "You do not have '%1' installed - Please " . - "install it as soon as possible.", - 'IO::Uncompress::Bunzip2')); + $self->_error(loc( + "You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::Bunzip2') + ); + + return METHOD_NA; } my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or @@ -695,6 +755,10 @@ sub _untar_at { $fh_to_read = $bz; } + ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've + ### localized $Archive::Tar::WARN already. + $Archive::Tar::WARN = $Archive::Extract::WARN; + my $tar = Archive::Tar->new(); ### only tell it it's compressed if it's a .tgz, as we give it a file @@ -713,8 +777,8 @@ sub _untar_at { *Archive::Tar::chown = sub {}; } - ### for version of archive::tar > 1.04 - local $Archive::Tar::Constant::CHOWN = 0; + ### for version of Archive::Tar > 1.04 + local $Archive::Tar::CHOWN = 0; { local $^W; # quell 'splice() offset past end of array' warnings # on older versions of A::T @@ -749,28 +813,14 @@ sub _untar_at { # ################################# -### gunzip wrapper... goes to either Compress::Zlib or /bin/gzip -### depending on $PREFER_BIN -sub _gunzip { - my $self = shift; - - my @methods = qw[_gunzip_cz _gunzip_bin]; - @methods = reverse @methods if $PREFER_BIN; - - for my $method (@methods) { - $self->_extractor($method) && return 1 if $self->$method(); - } - - return $self->_error(loc("Unable to gunzip file '%1'", $self->archive)); -} - sub _gunzip_bin { my $self = shift; ### check for /bin/gzip -- we need it ### - return $self->_error(loc("No '%1' program found", '/bin/gzip')) - unless $self->bin_gzip; - + unless( $self->bin_gzip ) { + $self->_error(loc("No '%1' program found", '/bin/gzip')); + return METHOD_NA; + } my $fh = FileHandle->new('>'. $self->_gunzip_to) or return $self->_error(loc("Could not open '%1' for writing: %2", @@ -808,8 +858,9 @@ sub _gunzip_cz { my $use_list = { 'Compress::Zlib' => '0.0' }; unless( can_load( modules => $use_list ) ) { - return $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", 'Compress::Zlib')); + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Compress::Zlib')); + return METHOD_NA; } my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or @@ -837,29 +888,14 @@ sub _gunzip_cz { # ################################# - -### untar wrapper... goes to either Archive::Tar or /bin/tar -### depending on $PREFER_BIN -sub _uncompress { - my $self = shift; - - my @methods = qw[_gunzip_cz _uncompress_bin]; - @methods = reverse @methods if $PREFER_BIN; - - for my $method (@methods) { - $self->_extractor($method) && return 1 if $self->$method(); - } - - return $self->_error(loc("Unable to untar file '%1'", $self->archive)); -} - sub _uncompress_bin { my $self = shift; ### check for /bin/gzip -- we need it ### - return $self->_error(loc("No '%1' program found", '/bin/uncompress')) - unless $self->bin_uncompress; - + unless( $self->bin_uncompress ) { + $self->_error(loc("No '%1' program found", '/bin/uncompress')); + return METHOD_NA; + } my $fh = FileHandle->new('>'. $self->_gunzip_to) or return $self->_error(loc("Could not open '%1' for writing: %2", @@ -899,28 +935,15 @@ sub _uncompress_bin { # ################################# -### unzip wrapper... goes to either Archive::Zip or /bin/unzip -### depending on $PREFER_BIN -sub _unzip { - my $self = shift; - - my @methods = qw[_unzip_az _unzip_bin]; - @methods = reverse @methods if $PREFER_BIN; - - for my $method (@methods) { - $self->_extractor($method) && return 1 if $self->$method(); - } - - return $self->_error(loc("Unable to gunzip file '%1'", $self->archive)); -} sub _unzip_bin { my $self = shift; ### check for /bin/gzip if we need it ### - return $self->_error(loc("No '%1' program found", '/bin/unzip')) - unless $self->bin_unzip; - + unless( $self->bin_unzip ) { + $self->_error(loc("No '%1' program found", '/bin/unzip')); + return METHOD_NA; + } ### first, get the files.. it must be 2 different commands with 'unzip' :( { ### on VMS, capital letter options have to be quoted. This is @@ -975,8 +998,9 @@ sub _unzip_az { my $use_list = { 'Archive::Zip' => '0.0' }; unless( can_load( modules => $use_list ) ) { - return $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", 'Archive::Zip')); + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Archive::Zip')); + return METHOD_NA; } my $zip = Archive::Zip->new(); @@ -1052,27 +1076,14 @@ sub __get_extract_dir { # ################################# -### bunzip2 wrapper... -sub _bunzip2 { - my $self = shift; - - my @methods = qw[_bunzip2_cz2 _bunzip2_bin]; - @methods = reverse @methods if $PREFER_BIN; - - for my $method (@methods) { - $self->_extractor($method) && return 1 if $self->$method(); - } - - return $self->_error(loc("Unable to bunzip2 file '%1'", $self->archive)); -} - sub _bunzip2_bin { my $self = shift; ### check for /bin/gzip -- we need it ### - return $self->_error(loc("No '%1' program found", '/bin/bunzip2')) - unless $self->bin_bunzip2; - + unless( $self->bin_bunzip2 ) { + $self->_error(loc("No '%1' program found", '/bin/bunzip2')); + return METHOD_NA; + } my $fh = FileHandle->new('>'. $self->_gunzip_to) or return $self->_error(loc("Could not open '%1' for writing: %2", @@ -1145,14 +1156,15 @@ sub _bunzip2_bin { # return 1; # } -sub _bunzip2_cz2 { +sub _bunzip2_bz2 { my $self = shift; my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; unless( can_load( modules => $use_list ) ) { - return $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", - 'IO::Uncompress::Bunzip2')); + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::Bunzip2')); + return METHOD_NA; } IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to) @@ -1174,27 +1186,14 @@ sub _bunzip2_cz2 { # ################################# -### unlzma wrapper... goes to either Compress::unLZMA or /bin/unlzma -### depending on $PREFER_BIN -sub _unlzma { - my $self = shift; - - my @methods = qw[_unlzma_cz _unlzma_bin]; - @methods = reverse @methods if $PREFER_BIN; - - for my $method (@methods) { - $self->_extractor($method) && return 1 if $self->$method(); - } - - return $self->_error(loc("Unable to unlzma file '%1'", $self->archive)); -} - sub _unlzma_bin { my $self = shift; ### check for /bin/unlzma -- we need it ### - return $self->_error(loc("No '%1' program found", '/bin/unlzma')) - unless $self->bin_unlzma; + unless( $self->bin_unlzma ) { + $self->_error(loc("No '%1' program found", '/bin/unlzma')); + return METHOD_NA; + } my $fh = FileHandle->new('>'. $self->_gunzip_to) or return $self->_error(loc("Could not open '%1' for writing: %2", @@ -1232,8 +1231,9 @@ sub _unlzma_cz { my $use_list = { 'Compress::unLZMA' => '0.0' }; unless( can_load( modules => $use_list ) ) { - return $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", 'Compress::unLZMA')); + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Compress::unLZMA')); + return METHOD_NA; } my $fh = FileHandle->new('>'. $self->_gunzip_to) or @@ -1267,14 +1267,15 @@ sub _unlzma_cz { sub _error { my $self = shift; my $error = shift; - - $self->_error_msg( $error ); - $self->_error_msg_long( Carp::longmess($error) ); + my $lerror = Carp::longmess($error); + + push @{$self->_error_msg}, $error; + push @{$self->_error_msg_long}, $lerror; ### set $Archive::Extract::WARN to 0 to disable printing ### of errors if( $WARN ) { - carp $DEBUG ? $self->_error_msg_long : $self->_error_msg; + carp $DEBUG ? $lerror : $error; } return; @@ -1282,7 +1283,15 @@ sub _error { sub error { my $self = shift; - return shift() ? $self->_error_msg_long : $self->_error_msg; + + ### make sure we have a fallback aref + my $aref = do { + shift() + ? $self->_error_msg_long + : $self->_error_msg + } || []; + + return join $/, @$aref; } sub _no_buffer_files { diff --git a/lib/Archive/Extract/t/01_Archive-Extract.t b/lib/Archive/Extract/t/01_Archive-Extract.t index 90abf20c580..5aa941cf03e 100644 --- a/lib/Archive/Extract/t/01_Archive-Extract.t +++ b/lib/Archive/Extract/t/01_Archive-Extract.t @@ -207,8 +207,53 @@ if( $Debug ) { 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'; @@ -243,15 +288,18 @@ SKIP: { my $meth = '__get_extract_dir'; } } -for my $switch (0,1) { +### 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::PREFER_BIN = $switch; - diag("Running extract with PREFER_BIN = $Archive::Extract::PREFER_BIN") - if $Debug; + 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") if $Debug; + diag("Extracting $archive in config $cfg") if $Debug; ### check first if we can do the proper @@ -313,7 +361,7 @@ for my $switch (0,1) { ### test buffers ### my $turn_off = !$use_buffer && !$pgm_fail && - $Archive::Extract::PREFER_BIN; + $Archive::Extract::_ALLOW_BIN; ### whitebox test ### ### stupid warnings ### @@ -331,20 +379,24 @@ for my $switch (0,1) { my $rv = $ae->extract( to => $to ); - ok( $rv, "extract() for '$archive' reports success"); - - diag("Extractor was: " . $ae->_extractor) if $Debug; - 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", 7, + 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, @@ -352,10 +404,16 @@ for my $switch (0,1) { ### 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 @{ $ae->files || []}, $file_cnt, + is( scalar @$files, $file_cnt, "Found correct number of output files" ); - is( $ae->files->[-1], $nix_path, + + ### 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, diff --git a/lib/Archive/Extract/t/src/double_dir.zip.packed b/lib/Archive/Extract/t/src/double_dir.zip.packed index dc32f2c400b..fdfe6ae01a1 100644 --- a/lib/Archive/Extract/t/src/double_dir.zip.packed +++ b/lib/Archive/Extract/t/src/double_dir.zip.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/double_dir.zip lib/Archive/Extract/t/src/double_dir.zip.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M4$L#!`H``````&QH,S0````````````````%`!4`>"]Y+WI55`D``PR`ST,, diff --git a/lib/Archive/Extract/t/src/x.Z.packed b/lib/Archive/Extract/t/src/x.Z.packed index c23bfbad0b5..9f80e84e533 100644 --- a/lib/Archive/Extract/t/src/x.Z.packed +++ b/lib/Archive/Extract/t/src/x.Z.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.Z lib/Archive/Extract/t/src/x.Z.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ ''YV0>`(J```` diff --git a/lib/Archive/Extract/t/src/x.bz2.packed b/lib/Archive/Extract/t/src/x.bz2.packed index ce2b5057233..93337dd5361 100644 --- a/lib/Archive/Extract/t/src/x.bz2.packed +++ b/lib/Archive/Extract/t/src/x.bz2.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.bz2 lib/Archive/Extract/t/src/x.bz2.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ .0EIH.1=R13A0D``````` diff --git a/lib/Archive/Extract/t/src/x.gz.packed b/lib/Archive/Extract/t/src/x.gz.packed index 9ec46e17ebb..ab6d42ea2ab 100644 --- a/lib/Archive/Extract/t/src/x.gz.packed +++ b/lib/Archive/Extract/t/src/x.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.gz lib/Archive/Extract/t/src/x.gz.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ 6'XL("+F;6D8``W@``P`````````````` diff --git a/lib/Archive/Extract/t/src/x.jar.packed b/lib/Archive/Extract/t/src/x.jar.packed index c04e4d1adec..1d415e03247 100644 --- a/lib/Archive/Extract/t/src/x.jar.packed +++ b/lib/Archive/Extract/t/src/x.jar.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.jar lib/Archive/Extract/t/src/x.jar.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M4$L#!`H```````MAQ3`````````````````!`!``8558#`!)`B%!EIO!0/4! diff --git a/lib/Archive/Extract/t/src/x.lzma.packed b/lib/Archive/Extract/t/src/x.lzma.packed index 9174f44ed6f..83e2c8aebab 100644 --- a/lib/Archive/Extract/t/src/x.lzma.packed +++ b/lib/Archive/Extract/t/src/x.lzma.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.lzma lib/Archive/Extract/t/src/x.lzma.packed -Created at Tue Mar 4 00:26:10 2008 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ 270``@``````````````````` diff --git a/lib/Archive/Extract/t/src/x.par.packed b/lib/Archive/Extract/t/src/x.par.packed index daac16f7013..2e9c462c0c0 100644 --- a/lib/Archive/Extract/t/src/x.par.packed +++ b/lib/Archive/Extract/t/src/x.par.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.par lib/Archive/Extract/t/src/x.par.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M4$L#!`H```````MAQ3`````````````````!`!``8558#`!)`B%!EIO!0/4! diff --git a/lib/Archive/Extract/t/src/x.tar.gz.packed b/lib/Archive/Extract/t/src/x.tar.gz.packed index fc3e40fef06..ff83349ed84 100644 --- a/lib/Archive/Extract/t/src/x.tar.gz.packed +++ b/lib/Archive/Extract/t/src/x.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.tar.gz lib/Archive/Extract/t/src/x.tar.gz.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M'XL(`````````^W.NPW"0!!%T2EE2YC%:[N>#7""1,"G?QM##!&.SDE&(]W@ diff --git a/lib/Archive/Extract/t/src/x.tar.packed b/lib/Archive/Extract/t/src/x.tar.packed index 1683ed19949..658aff3172d 100644 --- a/lib/Archive/Extract/t/src/x.tar.packed +++ b/lib/Archive/Extract/t/src/x.tar.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.tar lib/Archive/Extract/t/src/x.tar.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M80`````````````````````````````````````````````````````````` diff --git a/lib/Archive/Extract/t/src/x.tgz.packed b/lib/Archive/Extract/t/src/x.tgz.packed index 949b59b33fd..114142ef982 100644 --- a/lib/Archive/Extract/t/src/x.tgz.packed +++ b/lib/Archive/Extract/t/src/x.tgz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.tgz lib/Archive/Extract/t/src/x.tgz.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M'XL(`````````^W.NPW"0!!%T2EE2YC%:[N>#7""1,"G?QM##!&.SDE&(]W@ diff --git a/lib/Archive/Extract/t/src/x.zip.packed b/lib/Archive/Extract/t/src/x.zip.packed index 543440af6c7..f51b79ed751 100644 --- a/lib/Archive/Extract/t/src/x.zip.packed +++ b/lib/Archive/Extract/t/src/x.zip.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/x.zip lib/Archive/Extract/t/src/x.zip.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M4$L#!`H```````MAQ3`````````````````!`!``8558#`!)`B%!EIO!0/4! diff --git a/lib/Archive/Extract/t/src/y.jar.packed b/lib/Archive/Extract/t/src/y.jar.packed index 796cd2f947c..d2911e37e5f 100644 --- a/lib/Archive/Extract/t/src/y.jar.packed +++ b/lib/Archive/Extract/t/src/y.jar.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/y.jar lib/Archive/Extract/t/src/y.jar.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M4$L#!`H``````,NBB#$````````````````"`!``>2]56`P`M%6W06Y4MT'U diff --git a/lib/Archive/Extract/t/src/y.par.packed b/lib/Archive/Extract/t/src/y.par.packed index ad44f357721..a6acdda2e65 100644 --- a/lib/Archive/Extract/t/src/y.par.packed +++ b/lib/Archive/Extract/t/src/y.par.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/y.par lib/Archive/Extract/t/src/y.par.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:49 2008 ######################################################################### __UU__ M4$L#!`H``````,NBB#$````````````````"`!``>2]56`P`M%6W06Y4MT'U diff --git a/lib/Archive/Extract/t/src/y.tar.bz2.packed b/lib/Archive/Extract/t/src/y.tar.bz2.packed index 183c1a3855a..23845acf572 100644 --- a/lib/Archive/Extract/t/src/y.tar.bz2.packed +++ b/lib/Archive/Extract/t/src/y.tar.bz2.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/y.tar.bz2 lib/Archive/Extract/t/src/y.tar.bz2.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:50 2008 ######################################################################### __UU__ M0EIH.3%!6293636W".T``+)[E,B``$!``/>```-B"1XP!```0``((`"2A*4] diff --git a/lib/Archive/Extract/t/src/y.tar.gz.packed b/lib/Archive/Extract/t/src/y.tar.gz.packed index 1b68ddf9f68..5afbb486a26 100644 --- a/lib/Archive/Extract/t/src/y.tar.gz.packed +++ b/lib/Archive/Extract/t/src/y.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/y.tar.gz lib/Archive/Extract/t/src/y.tar.gz.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:51 2008 ######################################################################### __UU__ M'XL(`````````^W1,0Z#,`R%81\E-R"F>2\````````````````````````````````````````````````````````` diff --git a/lib/Archive/Extract/t/src/y.tbz.packed b/lib/Archive/Extract/t/src/y.tbz.packed index 14ae9a54fab..5424d8ccc93 100644 --- a/lib/Archive/Extract/t/src/y.tbz.packed +++ b/lib/Archive/Extract/t/src/y.tbz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/y.tbz lib/Archive/Extract/t/src/y.tbz.packed -Created at Thu Sep 20 15:38:01 2007 +Created at Sat Dec 13 17:18:51 2008 ######################################################################### __UU__ M0EIH.3%!6293636W".T``+)[E,B``$!``/>```-B"1XP!```0``((`"2A*4] diff --git a/lib/Archive/Extract/t/src/y.tgz.packed b/lib/Archive/Extract/t/src/y.tgz.packed index ed3e4053c1a..5b09cfb84ed 100644 --- a/lib/Archive/Extract/t/src/y.tgz.packed +++ b/lib/Archive/Extract/t/src/y.tgz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/Archive/Extract/t/src/y.tgz lib/Archive/Extract/t/src/y.tgz.packed -Created at Thu Sep 20 15:38:02 2007 +Created at Sat Dec 13 17:18:51 2008 ######################################################################### __UU__ M'XL(`````````^W1,0Z#,`R%81\E-R"F>2]56`P`M%6W06Y4MT'U