- use a better BuildRoot - drop a redundant mkdir in %%install - call patchlevel.h only once; rm patchlevel.bak - update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList, Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch), File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch), constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch, File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder - standardize the patches for updating embedded modules - work around a bug in Module::Build tests bu setting TMPDIR to a directory inside the source tree
979 lines
34 KiB
Diff
979 lines
34 KiB
Diff
Archive-Extract-0.30
|
|
|
|
diff -urN perl-5.10.0.orig/lib/Archive/Extract/t/01_Archive-Extract.t perl-5.10.0/lib/Archive/Extract/t/01_Archive-Extract.t
|
|
--- perl-5.10.0.orig/lib/Archive/Extract/t/01_Archive-Extract.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Extract/t/01_Archive-Extract.t 2009-03-10 12:31:09.000000000 +0100
|
|
@@ -58,6 +58,7 @@
|
|
$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]],
|
|
@@ -105,6 +106,11 @@
|
|
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
|
|
@@ -201,8 +207,53 @@
|
|
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';
|
|
@@ -237,15 +288,18 @@
|
|
}
|
|
}
|
|
|
|
-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
|
|
|
|
@@ -291,12 +345,14 @@
|
|
### 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
|
|
+ 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;
|
|
+ (10 * scalar @outs) if
|
|
+ ($mod_fail && ($pgm_fail || !$Archive::Extract::_ALLOW_BIN)) ||
|
|
+ ($pgm_fail && ($mod_fail || !$Archive::Extract::_ALLOW_PURE_PERL));
|
|
|
|
### we dont warnings spewed about missing modules, that might
|
|
### be a problem...
|
|
@@ -307,7 +363,7 @@
|
|
|
|
### test buffers ###
|
|
my $turn_off = !$use_buffer && !$pgm_fail &&
|
|
- $Archive::Extract::PREFER_BIN;
|
|
+ $Archive::Extract::_ALLOW_BIN;
|
|
|
|
### whitebox test ###
|
|
### stupid warnings ###
|
|
@@ -325,20 +381,24 @@
|
|
|
|
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,
|
|
@@ -346,10 +406,16 @@
|
|
|
|
### 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 -urN perl-5.10.0.orig/lib/Archive/Extract/t/src/x.lzma.packed perl-5.10.0/lib/Archive/Extract/t/src/x.lzma.packed
|
|
--- perl-5.10.0.orig/lib/Archive/Extract/t/src/x.lzma.packed 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Extract/t/src/x.lzma.packed 2009-03-10 12:34:10.000000000 +0100
|
|
@@ -0,0 +1,16 @@
|
|
+#########################################################################
|
|
+This is a binary file that was packed with the 'uupacktool.pl' which
|
|
+is included in the Perl distribution.
|
|
+
|
|
+To unpack this file use the following command:
|
|
+
|
|
+ uupacktool.pl -u lib/Archive/Extract/t/src/x.lzma.packed lib/Archive/Extract/t/src/x.lzma
|
|
+
|
|
+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 10 12:34:10 2009
|
|
+#########################################################################
|
|
+__UU__
|
|
+270``@```````````````````
|
|
diff -urN perl-5.10.0.orig/lib/Archive/Extract.pm perl-5.10.0/lib/Archive/Extract.pm
|
|
--- perl-5.10.0.orig/lib/Archive/Extract.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Extract.pm 2009-03-10 12:30:20.000000000 +0100
|
|
@@ -20,6 +20,10 @@
|
|
### 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';
|
|
@@ -28,14 +32,21 @@
|
|
use constant BZ2 => 'bz2';
|
|
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.30';
|
|
+$PREFER_BIN = 0;
|
|
+$WARN = 1;
|
|
+$DEBUG = 0;
|
|
+$_ALLOW_PURE_PERL = 1; # allow pure perl extractors
|
|
+$_ALLOW_BIN = 1; # allow binary extractors
|
|
|
|
-$VERSION = '0.24';
|
|
-$PREFER_BIN = 0;
|
|
-$WARN = 1;
|
|
-$DEBUG = 0;
|
|
-my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z ); # 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;
|
|
|
|
@@ -75,6 +86,7 @@
|
|
$ae->is_zip; # is it a .zip file?
|
|
$ae->is_bz2; # is it a .bz2 file?
|
|
$ae->is_tbz; # is it a .tar.bz2 or .tbz file?
|
|
+ $ae->is_lzma; # is it a .lzma file?
|
|
|
|
### absolute path to the archive you provided ###
|
|
$ae->archive;
|
|
@@ -84,13 +96,14 @@
|
|
$ae->bin_gzip # path to /bin/gzip, if found
|
|
$ae->bin_unzip # path to /bin/unzip, if found
|
|
$ae->bin_bunzip2 # path to /bin/bunzip2 if found
|
|
+ $ae->bin_unlzma # path to /bin/unlzma if found
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Archive::Extract is a generic archive extraction mechanism.
|
|
|
|
It allows you to extract any archive file of the type .tar, .tar.gz,
|
|
-.gz, .Z, tar.bz2, .tbz, .bz2 or .zip without having to worry how it
|
|
+.gz, .Z, tar.bz2, .tbz, .bz2, .zip or .lzma without having to worry how it
|
|
does so, or use different interfaces for each type by using either
|
|
perl modules, or commandline tools on your system.
|
|
|
|
@@ -101,31 +114,35 @@
|
|
|
|
### see what /bin/programs are available ###
|
|
$PROGRAMS = {};
|
|
-for my $pgm (qw[tar unzip gzip bunzip2 uncompress]) {
|
|
+for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) {
|
|
$PROGRAMS->{$pgm} = can_run($pgm);
|
|
}
|
|
|
|
### 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',
|
|
+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 {
|
|
@@ -183,6 +200,11 @@
|
|
Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>.
|
|
Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
|
|
|
|
+=item lzma
|
|
+
|
|
+Lzma compressed file, as produced by C</bin/lzma>.
|
|
+Corresponds to a C<.lzma> suffix.
|
|
+
|
|
=back
|
|
|
|
Returns a C<Archive::Extract> object on success, or false on failure.
|
|
@@ -193,8 +215,12 @@
|
|
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} );
|
|
@@ -209,15 +235,18 @@
|
|
$ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
|
|
$ar =~ /.+?\.bz2$/i ? BZ2 :
|
|
$ar =~ /.+?\.Z$/ ? Z :
|
|
+ $ar =~ /.+?\.lzma$/ ? LZMA :
|
|
'';
|
|
|
|
}
|
|
|
|
- ### 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;
|
|
}
|
|
}
|
|
|
|
@@ -229,11 +258,11 @@
|
|
|
|
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
|
|
@@ -269,6 +298,10 @@
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
+ ### reset error messages
|
|
+ $self->_error_msg( [] );
|
|
+ $self->_error_msg_long( [] );
|
|
+
|
|
my $to;
|
|
my $tmpl = {
|
|
to => { default => '.', store => \$to }
|
|
@@ -283,9 +316,9 @@
|
|
### to.
|
|
my $dir;
|
|
{ ### a foo.gz file
|
|
- if( $self->is_gz or $self->is_bz2 or $self->is_Z) {
|
|
+ if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) {
|
|
|
|
- my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z)$//i;
|
|
+ my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i;
|
|
|
|
### to is a dir?
|
|
if ( -d $to ) {
|
|
@@ -330,19 +363,50 @@
|
|
### ../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;
|
|
+
|
|
+ ### 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;
|
|
|
|
- ### call the corresponding method if the type is OK ###
|
|
- if( $self->$type) {
|
|
- $ok = $self->$method();
|
|
- }
|
|
+ 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 OK ###
|
|
- $self->_error(loc("Extract failed, no extractor found"))
|
|
- unless $ok;
|
|
-
|
|
+ ### 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 ###
|
|
@@ -418,6 +482,11 @@
|
|
Returns true if the file is of type C<.zip>.
|
|
See the C<new()> method for details.
|
|
|
|
+=head2 $ae->is_lzma
|
|
+
|
|
+Returns true if the file is of type C<.lzma>.
|
|
+See the C<new()> method for details.
|
|
+
|
|
=cut
|
|
|
|
### quick check methods ###
|
|
@@ -428,6 +497,7 @@
|
|
sub is_tbz { return $_[0]->type eq TBZ }
|
|
sub is_bz2 { return $_[0]->type eq BZ2 }
|
|
sub is_Z { return $_[0]->type eq Z }
|
|
+sub is_lzma { return $_[0]->type eq LZMA }
|
|
|
|
=pod
|
|
|
|
@@ -443,6 +513,10 @@
|
|
|
|
Returns the full path to your unzip binary, if found
|
|
|
|
+=head2 $ae->bin_unlzma
|
|
+
|
|
+Returns the full path to your unlzma binary, if found
|
|
+
|
|
=cut
|
|
|
|
### paths to commandline tools ###
|
|
@@ -452,6 +526,8 @@
|
|
sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
|
|
sub bin_uncompress { return $PROGRAMS->{'uncompress'}
|
|
if $PROGRAMS->{'uncompress'} }
|
|
+sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} }
|
|
+
|
|
=head2 $bool = $ae->have_old_bunzip2
|
|
|
|
Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
|
|
@@ -478,8 +554,16 @@
|
|
### $ echo $?
|
|
### 1
|
|
### HATEFUL!
|
|
+
|
|
+ ### 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 its version..
|
|
+ ### *sigh*
|
|
+ ### Even if the file exists, it won't clobber or change it.
|
|
my $buffer;
|
|
- scalar run( command => [$self->bin_bunzip2, '--version'],
|
|
+ scalar run(
|
|
+ command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
|
|
verbose => 0,
|
|
buffer => \$buffer
|
|
);
|
|
@@ -500,43 +584,31 @@
|
|
#################################
|
|
|
|
|
|
-### 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
|
|
|
|
@@ -620,14 +692,25 @@
|
|
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;
|
|
}
|
|
}
|
|
|
|
@@ -644,18 +727,24 @@
|
|
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
|
|
@@ -666,6 +755,10 @@
|
|
$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
|
|
@@ -684,8 +777,8 @@
|
|
*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
|
|
@@ -720,28 +813,14 @@
|
|
#
|
|
#################################
|
|
|
|
-### 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",
|
|
@@ -779,8 +858,9 @@
|
|
|
|
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
|
|
@@ -808,29 +888,14 @@
|
|
#
|
|
#################################
|
|
|
|
-
|
|
-### 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",
|
|
@@ -870,28 +935,15 @@
|
|
#
|
|
#################################
|
|
|
|
-### 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
|
|
@@ -946,8 +998,9 @@
|
|
|
|
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();
|
|
@@ -1023,27 +1076,14 @@
|
|
#
|
|
#################################
|
|
|
|
-### 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",
|
|
@@ -1116,14 +1156,15 @@
|
|
# 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)
|
|
@@ -1141,6 +1182,84 @@
|
|
|
|
#################################
|
|
#
|
|
+# unlzma code
|
|
+#
|
|
+#################################
|
|
+
|
|
+sub _unlzma_bin {
|
|
+ my $self = shift;
|
|
+
|
|
+ ### check for /bin/unlzma -- we need it ###
|
|
+ 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",
|
|
+ $self->_gunzip_to, $! ));
|
|
+
|
|
+ my $cmd = [ $self->bin_unlzma, '-c', $self->archive ];
|
|
+
|
|
+ my $buffer;
|
|
+ unless( scalar run( command => $cmd,
|
|
+ verbose => $DEBUG,
|
|
+ buffer => \$buffer )
|
|
+ ) {
|
|
+ return $self->_error(loc("Unable to unlzma '%1': %2",
|
|
+ $self->archive, $buffer));
|
|
+ }
|
|
+
|
|
+ ### no buffers available?
|
|
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
|
|
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
|
|
+ }
|
|
+
|
|
+ print $fh $buffer if defined $buffer;
|
|
+
|
|
+ close $fh;
|
|
+
|
|
+ ### set what files where extract, and where they went ###
|
|
+ $self->files( [$self->_gunzip_to] );
|
|
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
|
|
+
|
|
+ return 1;
|
|
+}
|
|
+
|
|
+sub _unlzma_cz {
|
|
+ my $self = shift;
|
|
+
|
|
+ my $use_list = { 'Compress::unLZMA' => '0.0' };
|
|
+ unless( can_load( modules => $use_list ) ) {
|
|
+ $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
|
|
+ return $self->_error(loc("Could not open '%1' for writing: %2",
|
|
+ $self->_gunzip_to, $! ));
|
|
+
|
|
+ my $buffer;
|
|
+ $buffer = Compress::unLZMA::uncompressfile( $self->archive );
|
|
+ unless ( defined $buffer ) {
|
|
+ return $self->_error(loc("Could not unlzma '%1': %2",
|
|
+ $self->archive, $@));
|
|
+ }
|
|
+
|
|
+ print $fh $buffer if defined $buffer;
|
|
+
|
|
+ close $fh;
|
|
+
|
|
+ ### set what files where extract, and where they went ###
|
|
+ $self->files( [$self->_gunzip_to] );
|
|
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
|
|
+
|
|
+ return 1;
|
|
+}
|
|
+
|
|
+#################################
|
|
+#
|
|
# Error code
|
|
#
|
|
#################################
|
|
@@ -1148,14 +1267,15 @@
|
|
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;
|
|
@@ -1163,7 +1283,15 @@
|
|
|
|
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 {
|
|
@@ -1208,7 +1336,7 @@
|
|
|
|
C<Archive::Extract> can use either pure perl modules or command line
|
|
programs under the hood. Some of the pure perl modules (like
|
|
-C<Archive::Tar> take the entire contents of the archive into memory,
|
|
+C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
|
|
which may not be feasible on your system. Consider setting the global
|
|
variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
|
|
the use of command line programs and won't consume so much memory.
|
|
--- perl-5.10.0.orig/MANIFEST 2009-02-20 18:22:32.000000000 +0100
|
|
+++ perl-5.10.0/MANIFEST 2009-03-10 15:16:45.000000000 +0100
|
|
@@ -1390,6 +1390,7 @@
|
|
lib/Archive/Extract/t/src/x.bz2.packed Archive::Extract tests
|
|
lib/Archive/Extract/t/src/x.gz.packed Archive::Extract tests
|
|
lib/Archive/Extract/t/src/x.jar.packed Archive::Extract tests
|
|
+lib/Archive/Extract/t/src/x.lzma.packed Archive::Extract tests
|
|
lib/Archive/Extract/t/src/x.par.packed Archive::Extract tests
|
|
lib/Archive/Extract/t/src/x.tar.gz.packed Archive::Extract tests
|
|
lib/Archive/Extract/t/src/x.tar.packed Archive::Extract tests
|