### 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';
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;
}
### 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 {
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} );
}
- ### 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;
}
}
Since C<.gz> files never hold a directory, but only a single file; if
the C<to> 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<to> argument is not an existing directory, the C<to> argument
is understood to be a filename, if the archive type is C<gz>.
In the case that you did not specify a C<to> 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<extract> will try a pure perl solution first, and then fall back to
my $self = shift;
my %hash = @_;
+ ### reset error messages
+ $self->_error_msg( [] );
+ $self->_error_msg_long( [] );
+
my $to;
my $tmpl = {
to => { default => '.', store => \$to }
### ../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 ###
### 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;
#
#################################
-### 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
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;
}
}
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
$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
*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
#
#################################
-### 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",
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
#
#################################
-
-### 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",
#
#################################
-### 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
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();
#
#################################
-### 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",
# 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)
#
#################################
-### 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",
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
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;
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 {
projects / p5sagit/p5-mst-13.2.git / blobdiff