In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/d7f879921f707b4cc33b49b406921979dac5afd0?hp=4c9d89c5499b414815601cb441e37d78915fb129>
- Log ----------------------------------------------------------------- commit d7f879921f707b4cc33b49b406921979dac5afd0 Author: Chris 'BinGOs' Williams <[email protected]> Date: Mon Jun 28 19:53:51 2010 +0100 Update Archive-Extract to CPAN version 0.42 [DELTA] Updates since 0.38 include: a safe print method that Michael Schwern contributed, that guards Archive::Extract from changes to $\; a fix to the tests when run in core perl from Robin Barker; and support for TZ files contributed by Paul Marquess, who also supplied a modification for the lzma logic to favour IO::Uncompress::Unlzma ----------------------------------------------------------------------- Summary of changes: MANIFEST | 5 + Porting/Maintainers.pl | 2 +- cpan/Archive-Extract/lib/Archive/Extract.pm | 179 +++++++++++++++++++++++---- cpan/Archive-Extract/t/01_Archive-Extract.t | 48 ++++++-- cpan/Archive-Extract/t/src/x.tar.xz | Bin 0 -> 168 bytes cpan/Archive-Extract/t/src/x.txz | Bin 0 -> 168 bytes cpan/Archive-Extract/t/src/x.xz | Bin 0 -> 32 bytes cpan/Archive-Extract/t/src/y.tar.xz | Bin 0 -> 196 bytes cpan/Archive-Extract/t/src/y.txz | Bin 0 -> 196 bytes 9 files changed, 199 insertions(+), 35 deletions(-) create mode 100644 cpan/Archive-Extract/t/src/x.tar.xz create mode 100644 cpan/Archive-Extract/t/src/x.txz create mode 100644 cpan/Archive-Extract/t/src/x.xz create mode 100644 cpan/Archive-Extract/t/src/y.tar.xz create mode 100644 cpan/Archive-Extract/t/src/y.txz diff --git a/MANIFEST b/MANIFEST index d0e8004..7e21702 100644 --- a/MANIFEST +++ b/MANIFEST @@ -27,7 +27,10 @@ cpan/Archive-Extract/t/src/x.lzma Archive::Extract tests cpan/Archive-Extract/t/src/x.par Archive::Extract tests cpan/Archive-Extract/t/src/x.tar Archive::Extract tests cpan/Archive-Extract/t/src/x.tar.gz Archive::Extract tests +cpan/Archive-Extract/t/src/x.tar.xz Archive::Extract tests cpan/Archive-Extract/t/src/x.tgz Archive::Extract tests +cpan/Archive-Extract/t/src/x.txz Archive::Extract tests +cpan/Archive-Extract/t/src/x.xz Archive::Extract tests cpan/Archive-Extract/t/src/x.Z Archive::Extract tests cpan/Archive-Extract/t/src/x.zip Archive::Extract tests cpan/Archive-Extract/t/src/y.jar Archive::Extract tests @@ -35,8 +38,10 @@ cpan/Archive-Extract/t/src/y.par Archive::Extract tests cpan/Archive-Extract/t/src/y.tar Archive::Extract tests cpan/Archive-Extract/t/src/y.tar.bz2 Archive::Extract tests cpan/Archive-Extract/t/src/y.tar.gz Archive::Extract tests +cpan/Archive-Extract/t/src/y.tar.xz Archive::Extract tests cpan/Archive-Extract/t/src/y.tbz Archive::Extract tests cpan/Archive-Extract/t/src/y.tgz Archive::Extract tests +cpan/Archive-Extract/t/src/y.txz Archive::Extract tests cpan/Archive-Extract/t/src/y.zip Archive::Extract tests cpan/Archive-Tar/bin/ptar the ptar utility cpan/Archive-Tar/bin/ptardiff the ptardiff utility diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index f630693..1a90159 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -183,7 +183,7 @@ use File::Glob qw(:case); 'Archive::Extract' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/Archive-Extract-0.38.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Archive-Extract-0.42.tar.gz', 'FILES' => q[cpan/Archive-Extract], 'UPSTREAM' => 'cpan', 'BUGS' => '[email protected]', diff --git a/cpan/Archive-Extract/lib/Archive/Extract.pm b/cpan/Archive-Extract/lib/Archive/Extract.pm index 08676fb..538d8c3 100644 --- a/cpan/Archive-Extract/lib/Archive/Extract.pm +++ b/cpan/Archive-Extract/lib/Archive/Extract.pm @@ -36,12 +36,14 @@ use constant BZ2 => 'bz2'; use constant TBZ => 'tbz'; use constant Z => 'Z'; use constant LZMA => 'lzma'; +use constant XZ => 'xz'; +use constant TXZ => 'txz'; use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER ]; -$VERSION = '0.38'; +$VERSION = '0.42'; $PREFER_BIN = 0; $WARN = 1; $DEBUG = 0; @@ -50,7 +52,7 @@ $_ALLOW_BIN = 1; # allow binary extractors $_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available # same as all constants -my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA ); +my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA, XZ, TXZ ); local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; @@ -91,6 +93,8 @@ Archive::Extract - A generic archive extracting mechanism $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? + $ae->is_xz; # is it a .xz file? + $ae->is_txz; # is it a .tar.xz or .txz file? ### absolute path to the archive you provided ### $ae->archive; @@ -101,13 +105,15 @@ Archive::Extract - A generic archive extracting mechanism $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 + $ae->bin_unxz # path to /bin/unxz 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, .zip or .lzma without having to worry how it +.gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz 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. @@ -118,7 +124,7 @@ See the C<HOW IT WORKS> section further down for details. ### see what /bin/programs are available ### $PROGRAMS = {}; -for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) { +for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) { $PROGRAMS->{$pgm} = can_run($pgm); } @@ -132,6 +138,8 @@ my $Mapping = { # binary program # pure perl module is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, + is_xz => { bin => '_unxz_bin', pp => '_unxz_cz' }, + is_txz => { bin => '_untar_bin', pp => '_untar_at' }, }; { ### use subs so we re-generate array refs etc for the no-overide flags @@ -209,6 +217,16 @@ Corresponds to a C<.tbz> or C<.tar.bz2> suffix. Lzma compressed file, as produced by C</bin/lzma>. Corresponds to a C<.lzma> suffix. +=item xz + +Xz compressed file, as produced by C</bin/xz>. +Corresponds to a C<.xz> suffix. + +=item txz + +Xz compressed tar file, as produced by, for exmample C</bin/tar -J>. +Corresponds to a C<.txz> or C<.tar.xz> suffix. + =back Returns a C<Archive::Extract> object on success, or false on failure. @@ -240,6 +258,8 @@ Returns a C<Archive::Extract> object on success, or false on failure. $ar =~ /.+?\.bz2$/i ? BZ2 : $ar =~ /.+?\.Z$/ ? Z : $ar =~ /.+?\.lzma$/ ? LZMA : + $ar =~ /.+?\.(?:txz|tar\.xz)$/i ? TXZ : + $ar =~ /.+?\.xz$/ ? XZ : ''; } @@ -320,9 +340,9 @@ sub extract { ### to. my $dir; { ### a foo.gz file - if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) { + if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) { - my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i; + my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i; ### to is a dir? if ( -d $to ) { @@ -491,6 +511,11 @@ See the C<new()> method for details. Returns true if the file is of type C<.lzma>. See the C<new()> method for details. +=head2 $ae->is_xz + +Returns true if the file is of type C<.xz>. +See the C<new()> method for details. + =cut ### quick check methods ### @@ -502,6 +527,8 @@ 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 } +sub is_xz { return $_[0]->type eq XZ } +sub is_txz { return $_[0]->type eq TXZ } =pod @@ -521,6 +548,10 @@ Returns the full path to your unzip binary, if found Returns the full path to your unlzma binary, if found +=head2 $ae->bin_unxz + +Returns the full path to your unxz binary, if found + =cut ### paths to commandline tools ### @@ -531,6 +562,7 @@ 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'} } +sub bin_unxz { return $PROGRAMS->{'unxz'} if $PROGRAMS->{'unxz'} } =head2 $bool = $ae->have_old_bunzip2 @@ -613,6 +645,8 @@ sub have_old_bunzip2 { loc("No '%1' program found", '/bin/gzip') : $self->is_tbz && !$self->bin_bunzip2 ? loc("No '%1' program found", '/bin/bunzip2') : + $self->is_txz && !$self->bin_unxz ? + loc("No '%1' program found", '/bin/unxz') : ''; if( $diag ) { @@ -636,6 +670,8 @@ sub have_old_bunzip2 { $self->bin_tar, '-tf', '-'] : $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|', $self->bin_tar, '-tf', '-'] : + $self->is_txz ? [$self->bin_unxz, '-cd', $self->archive, '|', + $self->bin_tar, '-tf', '-'] : [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive]; ### run the command @@ -689,6 +725,8 @@ sub have_old_bunzip2 { $self->bin_tar, '-xf', '-'] : $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|', $self->bin_tar, '-xf', '-'] : + $self->is_txz ? [$self->bin_unxz, '-cd', $self->archive, '|', + $self->bin_tar, '-xf', '-'] : [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive]; my $buffer = ''; @@ -781,6 +819,24 @@ sub _untar_at { $IO::Uncompress::Bunzip2::Bunzip2Error)); $fh_to_read = $bz; + } elsif ( $self->is_txz ) { + my $use_list = { 'IO::Uncompress::UnXz' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc( + "You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::UnXz') + ); + + return METHOD_NA; + } + + my $xz = IO::Uncompress::UnXz->new( $self->archive ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, + $IO::Uncompress::UnXz::UnXzError)); + + $fh_to_read = $xz; } my @files; @@ -1256,6 +1312,75 @@ sub _bunzip2_bz2 { return 1; } +################################# +# +# UnXz code +# +################################# + +sub _unxz_bin { + my $self = shift; + + ### check for /bin/unxz -- we need it ### + unless( $self->bin_unxz ) { + $self->_error(loc("No '%1' program found", '/bin/unxz')); + 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_unxz, '-cdf', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unxz '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_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 _unxz_cz { + my $self = shift; + + my $use_list = { 'IO::Uncompress::UnXz' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::UnXz')); + return METHOD_NA; + } + + IO::Uncompress::UnXz::unxz($self->archive => $self->_gunzip_to) + or return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, + $IO::Uncompress::UnXz::UnXzError)); + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + ################################# # @@ -1306,27 +1431,37 @@ sub _unlzma_bin { 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 $use_list1 = { 'IO::Uncompress::UnLzma' => '0.0' }; + my $use_list2 = { 'Compress::unLZMA' => '0.0' }; + + if (can_load( modules => $use_list1 ) ) { + IO::Uncompress::UnLzma::unlzma($self->archive => $self->_gunzip_to) + or return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, + $IO::Uncompress::UnLzma::UnLzmaError)); } + elsif (can_load( modules => $use_list2 ) ) { - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); + 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, $@)); - } + my $buffer; + $buffer = Compress::unLZMA::uncompressfile( $self->archive ); + unless ( defined $buffer ) { + return $self->_error(loc("Could not unlzma '%1': %2", + $self->archive, $@)); + } - $self->_print($fh, $buffer) if defined $buffer; + $self->_print($fh, $buffer) if defined $buffer; - close $fh; + close $fh; + } + else { + $self->_error(loc("You do not have '%1' or '%2' installed - Please " . + "install it as soon as possible.", 'Compress::unLZMA', 'IO::Uncompress::UnLzma')); + return METHOD_NA; + } ### set what files where extract, and where they went ### $self->files( [$self->_gunzip_to] ); diff --git a/cpan/Archive-Extract/t/01_Archive-Extract.t b/cpan/Archive-Extract/t/01_Archive-Extract.t index 93c9026..941ac83 100644 --- a/cpan/Archive-Extract/t/01_Archive-Extract.t +++ b/cpan/Archive-Extract/t/01_Archive-Extract.t @@ -1,10 +1,3 @@ -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir '../lib/Archive/Extract' if -d '../lib/Archive/Extract'; - unshift @INC, '../../..', '../../../..'; - } -} - BEGIN { chdir 't' if -d 't' }; BEGIN { mkdir 'out' unless -d 'out' }; @@ -122,6 +115,23 @@ my $tmpl = { method => 'is_lzma', outfile => 'a', }, + 'x.xz' => { programs => [qw[unxz]], + modules => [qw[IO::Uncompress::UnXz]], + method => 'is_xz', + outfile => 'a', + }, + 'x.txz' => { programs => [qw[unxz tar]], + modules => [qw[Archive::Tar + IO::Uncompress::UnXz]], + method => 'is_txz', + outfile => 'a', + }, + 'x.tar.xz'=> { programs => [qw[unxz tar]], + modules => [qw[Archive::Tar + IO::Uncompress::UnXz]], + method => 'is_txz', + outfile => 'a', + }, ### with a directory 'y.tbz' => { programs => [qw[bunzip2 tar]], modules => [qw[Archive::Tar @@ -137,6 +147,20 @@ my $tmpl = { outfile => 'z', outdir => 'y' }, + 'y.txz' => { programs => [qw[unxz tar]], + modules => [qw[Archive::Tar + IO::Uncompress::UnXz]], + method => 'is_txz', + outfile => 'z', + outdir => 'y', + }, + 'y.tar.xz' => { programs => [qw[unxz tar]], + modules => [qw[Archive::Tar + IO::Uncompress::UnXz]], + method => 'is_txz', + outfile => 'z', + outdir => 'y' + }, 'y.tgz' => { programs => [qw[gzip tar]], modules => [qw[Archive::Tar IO::Zlib]], method => 'is_tgz', @@ -309,6 +333,7 @@ for my $switch ( [0,1], [1,0] ) { diag("Running extract with configuration: $cfg") if $Debug; for my $archive (keys %$tmpl) { + diag("Archive : $archive") if $Debug; ### check first if we can do the proper @@ -318,11 +343,11 @@ for my $switch ( [0,1], [1,0] ) { ### Do an extra run with _ALLOW_TAR_ITER = 0 if it's a tar file of some ### sort my @with_tar_iter = ( 1 ); - push @with_tar_iter, 0 if grep { $ae->$_ } qw[is_tbz is_tgz is_tar]; + push @with_tar_iter, 0 if grep { $ae->$_ } qw[is_tbz is_tgz is_txz is_tar]; for my $tar_iter (@with_tar_iter) { SKIP: { - ### Doesn't matter unless .tar, .tbz, .tgz + ### Doesn't matter unless .tar, .tbz, .tgz, .txz local $Archive::Extract::_ALLOW_TAR_ITER = $tar_iter; diag("Archive::Tar->iter: $tar_iter") if $Debug; @@ -330,8 +355,7 @@ for my $switch ( [0,1], [1,0] ) { isa_ok( $ae, $Class ); my $method = $tmpl->{$archive}->{method}; - ok( $ae->$method(), "Archive type recognized properly" ); - + ok( $ae->$method(), "Archive type $method recognized properly" ); my $file = $tmpl->{$archive}->{outfile}; my $dir = $tmpl->{$archive}->{outdir}; # can be undef @@ -365,7 +389,7 @@ for my $switch ( [0,1], [1,0] ) { ### where to extract to -- try both dir and file for gz files ### XXX test me! #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir); - my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma + my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma || $ae->is_xz ? ($abs_path) : ($OutDir); diff --git a/cpan/Archive-Extract/t/src/x.tar.xz b/cpan/Archive-Extract/t/src/x.tar.xz new file mode 100644 index 0000000..531eee8 Binary files /dev/null and b/cpan/Archive-Extract/t/src/x.tar.xz differ diff --git a/cpan/Archive-Extract/t/src/x.txz b/cpan/Archive-Extract/t/src/x.txz new file mode 100644 index 0000000..531eee8 Binary files /dev/null and b/cpan/Archive-Extract/t/src/x.txz differ diff --git a/cpan/Archive-Extract/t/src/x.xz b/cpan/Archive-Extract/t/src/x.xz new file mode 100644 index 0000000..ea28d9e Binary files /dev/null and b/cpan/Archive-Extract/t/src/x.xz differ diff --git a/cpan/Archive-Extract/t/src/y.tar.xz b/cpan/Archive-Extract/t/src/y.tar.xz new file mode 100644 index 0000000..dfca273 Binary files /dev/null and b/cpan/Archive-Extract/t/src/y.tar.xz differ diff --git a/cpan/Archive-Extract/t/src/y.txz b/cpan/Archive-Extract/t/src/y.txz new file mode 100644 index 0000000..dfca273 Binary files /dev/null and b/cpan/Archive-Extract/t/src/y.txz differ -- Perl5 Master Repository
