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. Corresponds to a C<.tbz> or C<.tar.bz2> suffix. +=item lzma + +Lzma compressed file, as produced by C. +Corresponds to a C<.lzma> suffix. + =back Returns a C 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 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 @@ -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 method for details. +=head2 $ae->is_lzma + +Returns true if the file is of type C<.lzma>. +See the C 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, from before the C 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 can use either pure perl modules or command line programs under the hood. Some of the pure perl modules (like -C take the entire contents of the archive into memory, +C 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