summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Archive/Extract.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
committerKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
commita4c42bfb2337d37da89d789cb8cc226367994e32 (patch)
treec3eabdef5d565a4e515d2be0d9d4d0540bde0250 /Master/tlpkg/tlperl/lib/Archive/Extract.pm
parent8274475057f024d35332ac47c2e2f23ea156e6ed (diff)
perl 5.14.2 from siep
git-svn-id: svn://tug.org/texlive/trunk@26525 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive/Extract.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Extract.pm221
1 files changed, 189 insertions, 32 deletions
diff --git a/Master/tlpkg/tlperl/lib/Archive/Extract.pm b/Master/tlpkg/tlperl/lib/Archive/Extract.pm
index 08676fb1e08..a6fa3fb195c 100644
--- a/Master/tlpkg/tlperl/lib/Archive/Extract.pm
+++ b/Master/tlpkg/tlperl/lib/Archive/Extract.pm
@@ -15,6 +15,7 @@ use Locale::Maketext::Simple Style => 'gettext';
### solaris has silly /bin/tar output ###
use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0;
+use constant ON_NETBSD => $^O eq 'netbsd' ? 1 : 0;
use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 };
### VMS may require quoting upper case command options
@@ -36,12 +37,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.48';
$PREFER_BIN = 0;
$WARN = 1;
$DEBUG = 0;
@@ -50,7 +53,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 +94,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 +106,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 +125,13 @@ 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]) {
+ if ( $pgm eq 'unzip' and ON_NETBSD ) {
+ local $IPC::Cmd::INSTANCES = 1;
+ my @possibles = can_run($pgm);
+ ($PROGRAMS->{$pgm}) = grep { m!/usr/pkg/! } can_run($pgm);
+ next;
+ }
$PROGRAMS->{$pgm} = can_run($pgm);
}
@@ -132,9 +145,11 @@ 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
+{ ### use subs so we re-generate array refs etc for the no-override flags
### if we don't, then we reuse the same arrayref, meaning objects store
### previous errors
my $tmpl = {
@@ -144,7 +159,7 @@ my $Mapping = { # binary program # pure perl module
_error_msg_long => sub { { no_override => 1, default => [] } },
};
- ### build accesssors ###
+ ### build accessors ###
for my $method( keys %$tmpl,
qw[_extractor _gunzip_to files extract_path],
) {
@@ -201,7 +216,7 @@ Corresponds to a C<.bz2> suffix.
=item tbz
-Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>.
+Bzip2 compressed tar file, as produced by, for example C</bin/tar -j>.
Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
=item lzma
@@ -209,6 +224,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 example 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 +265,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 +347,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 ) {
@@ -382,22 +409,22 @@ sub extract {
my($na, $fail);
for my $method (@methods) {
- print "# Extracting with ->$method\n" if $DEBUG;
+ $self->debug( "# Extracting with ->$method\n" );
my $rv = $self->$method;
### a positive extraction
if( $rv and $rv ne METHOD_NA ) {
- print "# Extraction succeeded\n" if $DEBUG;
+ $self->debug( "# Extraction succeeded\n" );
$self->_extractor($method);
last;
### method is not available
} elsif ( $rv and $rv eq METHOD_NA ) {
- print "# Extraction method not available\n" if $DEBUG;
+ $self->debug( "# Extraction method not available\n" );
$na++;
} else {
- print "# Extraction method failed\n" if $DEBUG;
+ $self->debug( "# Extraction method failed\n" );
$fail++;
}
}
@@ -491,6 +518,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 +534,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 +555,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 +569,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 +652,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 +677,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
@@ -673,7 +716,7 @@ sub have_old_bunzip2 {
\s+ [\d,.]+ \s tape \s blocks
|x ? $1 : $_);
- ### only STDOUT, see above. Sometims, extra whitespace
+ ### only STDOUT, see above. Sometimes, extra whitespace
### is present, so make sure we only pick lines with
### a length
} grep { length } map { split $/, $_ } @{$out[3]};
@@ -689,6 +732,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 +826,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;
@@ -1004,7 +1067,7 @@ sub _unzip_bin {
### first, get the files.. it must be 2 different commands with 'unzip' :(
{ ### on VMS, capital letter options have to be quoted. This is
- ### peported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
+ ### reported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
### Subject: [patch@31735]Archive Extract fix on VMS.
my $opt = ON_VMS ? '"-Z"' : '-Z';
my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ];
@@ -1088,7 +1151,7 @@ sub _unzip_az {
for my $member ($zip->members) {
push @files, $member->{fileName};
- ### file to extact to, to avoid the above problem
+ ### file to extract to, to avoid the above problem
my $to = File::Spec->catfile( $extract_dir, $member->{fileName} );
unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) {
@@ -1256,6 +1319,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 +1438,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] );
@@ -1380,6 +1522,21 @@ sub error {
return join $/, @$aref;
}
+=head2 debug( MESSAGE )
+
+This method outputs MESSAGE to the default filehandle if C<$DEBUG> is
+true. It's a small method, but it's here if you'd like to subclass it
+so you can so something else with any debugging output.
+
+=cut
+
+### this is really a stub for subclassing
+sub debug {
+ return unless $DEBUG;
+
+ print $_[1];
+}
+
sub _no_buffer_files {
my $self = shift;
my $file = shift or return;