summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Archive
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive')
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Extract.pm281
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar.pm84
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm16
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar/File.pm115
4 files changed, 310 insertions, 186 deletions
diff --git a/Master/tlpkg/tlperl/lib/Archive/Extract.pm b/Master/tlpkg/tlperl/lib/Archive/Extract.pm
index a6fa3fb195c..4a0727f6eeb 100644
--- a/Master/tlpkg/tlperl/lib/Archive/Extract.pm
+++ b/Master/tlpkg/tlperl/lib/Archive/Extract.pm
@@ -16,6 +16,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 ON_FREEBSD => $^O eq 'freebsd' ? 1 : 0;
use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 };
### VMS may require quoting upper case command options
@@ -26,7 +27,7 @@ use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
### we can't use this extraction method, because of missing
### modules/binaries:
-use constant METHOD_NA => [];
+use constant METHOD_NA => [];
### If these are changed, update @TYPES and the new() POD
use constant TGZ => 'tgz';
@@ -40,11 +41,11 @@ use constant LZMA => 'lzma';
use constant XZ => 'xz';
use constant TXZ => 'txz';
-use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
+use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
$_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
];
-$VERSION = '0.48';
+$VERSION = '0.58';
$PREFER_BIN = 0;
$WARN = 1;
$DEBUG = 0;
@@ -53,7 +54,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, XZ, TXZ );
+my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA, XZ, TXZ );
local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
@@ -113,9 +114,9 @@ Archive::Extract - A generic archive extracting mechanism
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, .xz,, .txz, .tar.xz or .lzma
-without having to worry how it
-does so, or use different interfaces for each type by using either
+.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.
See the C<HOW IT WORKS> section further down for details.
@@ -126,10 +127,10 @@ 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 unxz]) {
- if ( $pgm eq 'unzip' and ON_NETBSD ) {
+ if ( $pgm eq 'unzip' and ( ON_NETBSD or ON_FREEBSD ) ) {
local $IPC::Cmd::INSTANCES = 1;
my @possibles = can_run($pgm);
- ($PROGRAMS->{$pgm}) = grep { m!/usr/pkg/! } can_run($pgm);
+ ($PROGRAMS->{$pgm}) = grep { ON_NETBSD ? m!/usr/pkg/! : m!/usr/local! } can_run($pgm);
next;
}
$PROGRAMS->{$pgm} = can_run($pgm);
@@ -160,7 +161,7 @@ my $Mapping = { # binary program # pure perl module
};
### build accessors ###
- for my $method( keys %$tmpl,
+ for my $method( keys %$tmpl,
qw[_extractor _gunzip_to files extract_path],
) {
no strict 'refs';
@@ -244,7 +245,7 @@ Returns a C<Archive::Extract> object on success, or false on failure.
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;
@@ -257,23 +258,23 @@ Returns a C<Archive::Extract> object on success, or false on failure.
### figure out the type, if it wasn't already specified ###
unless ( $parsed->{type} ) {
$parsed->{type} =
- $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ :
- $ar =~ /.+?\.gz$/i ? GZ :
- $ar =~ /.+?\.tar$/i ? TAR :
- $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP :
- $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
- $ar =~ /.+?\.bz2$/i ? BZ2 :
- $ar =~ /.+?\.Z$/ ? Z :
- $ar =~ /.+?\.lzma$/ ? LZMA :
- $ar =~ /.+?\.(?:txz|tar\.xz)$/i ? TXZ :
- $ar =~ /.+?\.xz$/ ? XZ :
+ $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ :
+ $ar =~ /.+?\.gz$/i ? GZ :
+ $ar =~ /.+?\.tar$/i ? TAR :
+ $ar =~ /.+?\.(zip|jar|ear|war|par)$/i ? ZIP :
+ $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
+ $ar =~ /.+?\.bz2$/i ? BZ2 :
+ $ar =~ /.+?\.Z$/ ? Z :
+ $ar =~ /.+?\.lzma$/ ? LZMA :
+ $ar =~ /.+?\.(?:txz|tar\.xz)$/i ? TXZ :
+ $ar =~ /.+?\.xz$/ ? XZ :
'';
}
bless $parsed, $class;
- ### don't know what type of file it is
+ ### 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};
@@ -287,11 +288,11 @@ Extracts the archive represented by the C<Archive::Extract> object to
the path of your choice as specified by the C<to> argument. Defaults to
C<cwd()>.
-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 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>.
+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 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 its C<.gz>
suffix, in the current working directory.
@@ -340,7 +341,7 @@ sub extract {
check( $tmpl, \%hash ) or return;
- ### so 'to' could be a file or a dir, depending on whether it's a .gz
+ ### so 'to' could be a file or a dir, depending on whether it's a .gz
### file, or basically anything else.
### so, check that, then act accordingly.
### set an accessor specifically so _gunzip can know what file to extract
@@ -348,12 +349,12 @@ sub extract {
my $dir;
{ ### a foo.gz file
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|xz)$//i;
-
+
### to is a dir?
if ( -d $to ) {
- $dir = $to;
+ $dir = $to;
$self->_gunzip_to( basename($cp) );
### then it's a filename
@@ -394,7 +395,7 @@ sub extract {
### ../lib/Archive/Extract.pm line 742. (rt #19815)
$self->files( [] );
- ### find out the dispatch methods needed for this type of
+ ### 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;
@@ -403,30 +404,30 @@ sub extract {
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;
my($na, $fail);
for my $method (@methods) {
$self->debug( "# Extracting with ->$method\n" );
-
+
my $rv = $self->$method;
-
+
### a positive extraction
if( $rv and $rv ne METHOD_NA ) {
$self->debug( "# Extraction succeeded\n" );
$self->_extractor($method);
last;
-
+
### method is not available
- } elsif ( $rv and $rv eq METHOD_NA ) {
+ } elsif ( $rv and $rv eq METHOD_NA ) {
$self->debug( "# Extraction method not available\n" );
- $na++;
+ $na++;
} else {
$self->debug( "# Extraction method failed\n" );
$fail++;
- }
+ }
}
### warn something went wrong if we didn't get an extractor
@@ -434,10 +435,10 @@ sub extract {
my $diag = $fail ? loc("Extract failed due to errors") :
$na ? loc("Extract failed; no extractors available") :
'';
-
+
$self->_error($diag);
$ok = 0;
- }
+ }
}
### and chdir back ###
@@ -566,7 +567,7 @@ sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} }
sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} }
sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} }
sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
-sub bin_uncompress { return $PROGRAMS->{'uncompress'}
+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'} }
@@ -586,7 +587,7 @@ sub have_old_bunzip2 {
### no bunzip2? no old bunzip2 either :)
return unless $self->bin_bunzip2;
- ### if we can't run this, we can't be sure if it's too old or not
+ ### if we can't run this, we can't be sure if it's too old or not
### XXX stupid stupid stupid bunzip2 doesn't understand --version
### is not a request to extract data:
### $ bunzip2 --version
@@ -597,7 +598,7 @@ sub have_old_bunzip2 {
### $ 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,
@@ -605,7 +606,7 @@ sub have_old_bunzip2 {
### *sigh*
### Even if the file exists, it won't clobber or change it.
my $buffer;
- scalar run(
+ scalar run(
command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
verbose => 0,
buffer => \$buffer
@@ -613,7 +614,7 @@ sub have_old_bunzip2 {
### no output
return unless $buffer;
-
+
my ($version) = $buffer =~ /version \s+ (\d+)/ix;
return 1 if $version < 1;
@@ -636,73 +637,77 @@ sub have_old_bunzip2 {
### if this is gnu tar we are running, we need to use --force-local
push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
- }
+ }
### use /bin/tar to extract ###
sub _untar_bin {
my $self = shift;
-
+
### check for /bin/tar ###
### check for /bin/gzip if we need it ###
### if any of the binaries are not available, return NA
- { my $diag = not $self->bin_tar ?
+ { my $diag = not $self->bin_tar ?
loc("No '%1' program found", '/bin/tar') :
- $self->is_tgz && !$self->bin_gzip ?
+ $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') :
$self->is_txz && !$self->bin_unxz ?
loc("No '%1' program found", '/bin/unxz') :
'';
-
+
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
-
+
+ ### GNU tar can't handled VMS filespecs, but VMSTAR can handle Unix filespecs.
+ my $archive = $self->archive;
+ $archive = VMS::Filespec::unixify($archive) if ON_VMS;
+
### XXX solaris tar and bsdtar are having different outputs
### depending whether you run with -x or -t
### compensate for this insanity by running -t first, then -x
- { my $cmd =
- $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+ { my $cmd =
+ $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
$self->bin_tar, '-tf', '-'] :
- $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
$self->bin_tar, '-tf', '-'] :
- $self->is_txz ? [$self->bin_unxz, '-cd', $self->archive, '|',
+ $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
$self->bin_tar, '-tf', '-'] :
- [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive];
-
- ### run the command
+ [$self->bin_tar, @ExtraTarFlags, '-tf', $archive];
+
+ ### run the command
### newer versions of 'tar' (1.21 and up) now print record size
- ### to STDERR as well if v OR t is given (used to be both). This
+ ### to STDERR as well if v OR t is given (used to be both). This
### is a 'feature' according to the changelog, so we must now only
### inspect STDOUT, otherwise, failures like these occur:
- ### nntp.perl.org/group/perl.cpan.testers/2009/02/msg3230366.html
+ ### http://www.cpantesters.org/cpan/report/3230366
my $buffer = '';
my @out = run( command => $cmd,
buffer => \$buffer,
verbose => $DEBUG );
- ### command was unsuccessful
- unless( $out[0] ) {
+ ### command was unsuccessful
+ unless( $out[0] ) {
return $self->_error(loc(
"Error listing contents of archive '%1': %2",
- $self->archive, $buffer ));
+ $archive, $buffer ));
}
-
+
### no buffers available?
if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
- $self->_error( $self->_no_buffer_files( $self->archive ) );
-
+ $self->_error( $self->_no_buffer_files( $archive ) );
+
} else {
### if we're on solaris we /might/ be using /bin/tar, which has
### a weird output format... we might also be using
@@ -715,46 +720,46 @@ sub have_old_bunzip2 {
\s+ [\d,.]+ \s bytes,
\s+ [\d,.]+ \s tape \s blocks
|x ? $1 : $_);
-
+
### 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]};
-
+ } grep { length } map { split $/, $_ } join '', @{$out[3]};
+
### store the files that are in the archive ###
$self->files(\@files);
}
}
-
+
### now actually extract it ###
- { my $cmd =
- $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+ { my $cmd =
+ $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
$self->bin_tar, '-xf', '-'] :
- $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
$self->bin_tar, '-xf', '-'] :
- $self->is_txz ? [$self->bin_unxz, '-cd', $self->archive, '|',
+ $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
$self->bin_tar, '-xf', '-'] :
- [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive];
-
+ [$self->bin_tar, @ExtraTarFlags, '-xf', $archive];
+
my $buffer = '';
unless( scalar run( command => $cmd,
buffer => \$buffer,
verbose => $DEBUG )
) {
return $self->_error(loc("Error extracting archive '%1': %2",
- $self->archive, $buffer ));
+ $archive, $buffer ));
}
-
+
### we might not have them, due to lack of buffers
if( $self->files ) {
### now that we've extracted, figure out where we extracted to
my $dir = $self->__get_extract_dir( $self->files );
-
+
### store the extraction dir ###
$self->extract_path( $dir );
}
}
-
+
### we got here, no error happened
return 1;
}
@@ -773,7 +778,7 @@ sub _untar_at {
### 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' };
@@ -782,7 +787,7 @@ sub _untar_at {
$self->_error(loc("You do not have '%1' installed - " .
"Please install it as soon as possible.",
'Archive::Tar'));
-
+
return METHOD_NA;
}
}
@@ -804,7 +809,7 @@ sub _untar_at {
"You do not have '%1' installed - Please ".
"install it as soon as possible.", $which)
);
-
+
return METHOD_NA;
}
@@ -813,10 +818,10 @@ sub _untar_at {
unless( can_load( modules => $use_list ) ) {
$self->_error(loc(
"You do not have '%1' installed - Please " .
- "install it as soon as possible.",
+ "install it as soon as possible.",
'IO::Uncompress::Bunzip2')
);
-
+
return METHOD_NA;
}
@@ -831,10 +836,10 @@ sub _untar_at {
unless( can_load( modules => $use_list ) ) {
$self->_error(loc(
"You do not have '%1' installed - Please " .
- "install it as soon as possible.",
+ "install it as soon as possible.",
'IO::Uncompress::UnXz')
);
-
+
return METHOD_NA;
}
@@ -865,26 +870,26 @@ sub _untar_at {
my $next;
unless ( $next = Archive::Tar->iter( @read ) ) {
return $self->_error(loc(
- "Unable to read '%1': %2", $self->archive,
+ "Unable to read '%1': %2", $self->archive,
$Archive::Tar::error));
}
while ( my $file = $next->() ) {
push @files, $file->full_path;
-
+
$file->extract or return $self->_error(loc(
- "Unable to read '%1': %2",
+ "Unable to read '%1': %2",
$self->archive,
$Archive::Tar::error));
}
-
- ### older version, read the archive into memory
+
+ ### older version, read the archive into memory
} else {
my $tar = Archive::Tar->new();
unless( $tar->read( @read ) ) {
- return $self->_error(loc("Unable to read '%1': %2",
+ return $self->_error(loc("Unable to read '%1': %2",
$self->archive, $Archive::Tar::error));
}
@@ -900,7 +905,7 @@ sub _untar_at {
{ local $^W; # quell 'splice() offset past end of array' warnings
# on older versions of A::T
- ### older archive::tar always returns $self, return value
+ ### older archive::tar always returns $self, return value
### slightly fux0r3d because of it.
$tar->extract or return $self->_error(loc(
"Unable to extract '%1': %2",
@@ -1063,7 +1068,7 @@ sub _unzip_bin {
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
@@ -1071,7 +1076,7 @@ sub _unzip_bin {
### Subject: [patch@31735]Archive Extract fix on VMS.
my $opt = ON_VMS ? '"-Z"' : '-Z';
my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ];
-
+
my $buffer = '';
unless( scalar run( command => $cmd,
verbose => $DEBUG,
@@ -1086,6 +1091,10 @@ sub _unzip_bin {
$self->_error( $self->_no_buffer_files( $self->archive ) );
} else {
+ ### Annoyingly, pesky MSWin32 can either have 'native' tools
+ ### which have \r\n line endings or Cygwin-based tools which
+ ### have \n line endings. Jan Dubois suggested using this fix
+ local $/ = ON_WIN32 ? qr/\r?\n/ : "\n";
$self->files( [split $/, $buffer] );
}
}
@@ -1120,7 +1129,7 @@ sub _unzip_az {
unless( can_load( modules => $use_list ) ) {
$self->_error(loc("You do not have '%1' installed - Please " .
"install it as soon as possible.", 'Archive::Zip'));
- return METHOD_NA;
+ return METHOD_NA;
}
my $zip = Archive::Zip->new();
@@ -1130,8 +1139,8 @@ sub _unzip_az {
}
my @files;
-
-
+
+
### Address: #43278: Explicitly tell Archive::Zip where to put the files:
### "In my BackPAN indexing, Archive::Zip was extracting things
### in my script's directory instead of the current working directory.
@@ -1139,21 +1148,21 @@ sub _unzip_az {
### eventually calls File::Spec::Win32::rel2abs which on Windows might
### call Cwd::getdcwd. getdcwd returns the wrong directory in my
### case, even though I think I'm on the same drive.
- ###
+ ###
### To fix this, I pass the optional second argument to
### extractMember using the cwd from Archive::Extract." --bdfoy
## store cwd() before looping; calls to cwd() can be expensive, and
### it won't change during the loop
my $extract_dir = cwd();
-
+
### have to extract every member individually ###
for my $member ($zip->members) {
push @files, $member->{fileName};
### 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 ) {
return $self->_error(loc("Extraction of '%1' from '%2' failed",
$member->{fileName}, $self->archive ));
@@ -1185,27 +1194,27 @@ sub __get_extract_dir {
### which was the problem in bug #23999
my $res = -d $files->[$pos]
? File::Spec->catdir( $files->[$pos], '' )
- : File::Spec->catdir( dirname( $files->[$pos] ) );
+ : File::Spec->catdir( dirname( $files->[$pos] ) );
$$dir = $res;
}
- ### if the first and last dir don't match, make sure the
+ ### if the first and last dir don't match, make sure the
### dirname is not set wrongly
my $dir;
-
+
### dirs are the same, so we know for sure what the extract dir is
if( $dir1 eq $dir2 ) {
$dir = $dir1;
-
+
### dirs are different.. do they share the base dir?
### if so, use that, if not, fall back to '.'
} else {
my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
-
- $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
- }
+
+ $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
+ }
return File::Spec->rel2abs( $dir );
}
@@ -1223,12 +1232,12 @@ sub _bunzip2_bin {
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",
$self->_gunzip_to, $! ));
-
+
### guard against broken bunzip2. See ->have_old_bunzip2()
### for details
if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) {
@@ -1252,7 +1261,7 @@ sub _bunzip2_bin {
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;
@@ -1268,31 +1277,31 @@ sub _bunzip2_bin {
### extractor..
# sub _bunzip2_cz1 {
# 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'));
# }
-#
+#
# my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
# return $self->_error(loc("Unable to open '%1': %2",
# $self->archive,
# $IO::Uncompress::Bunzip2::Bunzip2Error));
-#
+#
# my $fh = FileHandle->new('>'. $self->_gunzip_to) or
# return $self->_error(loc("Could not open '%1' for writing: %2",
# $self->_gunzip_to, $! ));
-#
+#
# my $buffer;
# $fh->print($buffer) while $bz->read($buffer) > 0;
# $fh->close;
-#
+#
# ### set what files where extract, and where they went ###
# $self->files( [$self->_gunzip_to] );
# $self->extract_path( File::Spec->rel2abs(cwd()) );
-#
+#
# return 1;
# }
@@ -1304,7 +1313,7 @@ sub _bunzip2_bz2 {
$self->_error(loc("You do not have '%1' installed - Please " .
"install it as soon as possible.",
'IO::Uncompress::Bunzip2'));
- return METHOD_NA;
+ return METHOD_NA;
}
IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to)
@@ -1373,7 +1382,7 @@ sub _unxz_cz {
$self->_error(loc("You do not have '%1' installed - Please " .
"install it as soon as possible.",
'IO::Uncompress::UnXz'));
- return METHOD_NA;
+ return METHOD_NA;
}
IO::Uncompress::UnXz::unxz($self->archive => $self->_gunzip_to)
@@ -1402,7 +1411,7 @@ sub _unlzma_bin {
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",
@@ -1467,7 +1476,7 @@ sub _unlzma_cz {
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;
+ return METHOD_NA;
}
### set what files where extract, and where they went ###
@@ -1499,7 +1508,7 @@ sub _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 ) {
@@ -1513,12 +1522,12 @@ sub error {
my $self = shift;
### make sure we have a fallback aref
- my $aref = do {
- shift()
- ? $self->_error_msg_long
- : $self->_error_msg
+ my $aref = do {
+ shift()
+ ? $self->_error_msg_long
+ : $self->_error_msg
} || [];
-
+
return join $/, @$aref;
}
@@ -1578,7 +1587,7 @@ C<Archive::Extract> will not be able to extract the archive for you.
=head2 Supporting Very Large Files
C<Archive::Extract> can use either pure perl modules or command line
-programs under the hood. Some of the pure perl modules (like
+programs under the hood. Some of the pure perl modules (like
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
@@ -1588,7 +1597,7 @@ See the C<GLOBAL VARIABLES> section below for details.
=head2 Bunzip2 support of arbitrary extensions.
-Older versions of C</bin/bunzip2> do not support arbitrary file
+Older versions of C</bin/bunzip2> do not support arbitrary file
extensions and insist on a C<.bz2> suffix. Although we do our best
to guard against this, if you experience a bunzip2 error, it may
be related to this. For details, please see the C<have_old_bunzip2>
@@ -1639,7 +1648,7 @@ the type, rather than blindly trust the suffix.
=item Thread safety
Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before
-extraction, and a C<chdir> back again after. This is not necessarily
+extraction, and a C<chdir> back again after. This is not necessarily
thread safe. See C<rt.cpan.org> bug C<#45671> for details.
=back
@@ -1654,7 +1663,7 @@ This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
=head1 COPYRIGHT
-This library is free software; you may redistribute and/or modify it
+This library is free software; you may redistribute and/or modify it
under the same terms as Perl itself.
=cut
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar.pm b/Master/tlpkg/tlperl/lib/Archive/Tar.pm
index 0a35cf77cc7..4ed3ae0386e 100644
--- a/Master/tlpkg/tlperl/lib/Archive/Tar.pm
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar.pm
@@ -31,7 +31,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.76";
+$VERSION = "1.82";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
@@ -68,6 +68,9 @@ Archive::Tar - module for manipulations of tar archives
$tar->add_data('file/baz.txt', 'This is the contents now');
$tar->rename('oldname', 'new/file/name');
+ $tar->chown('/', 'root');
+ $tar->chown('/', 'root:root');
+ $tar->chmod('/tmp', '1777');
$tar->write('files.tar'); # plain tar
$tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed
@@ -168,6 +171,14 @@ very big archives, and are only interested in the first few files.
Can be set to a regular expression. Only files with names that match
the expression will be read.
+=item md5
+
+Set to 1 and the md5sum of files will be returned (instead of file data)
+ my $iter = Archive::Tar->iter( $file, 1, {md5 => 1} );
+ while( my $f = $iter->() ) {
+ print $f->data . "\t" . $f->full_path . $/;
+ }
+
=item extract
If set to true, immediately extract entries when reading them. This
@@ -306,6 +317,7 @@ sub _read_tar {
my $count = $opts->{limit} || 0;
my $filter = $opts->{filter};
+ my $md5 = $opts->{md5} || 0; # cdrake
my $filter_cb = $opts->{filter_cb};
my $extract = $opts->{extract} || 0;
@@ -332,7 +344,7 @@ sub _read_tar {
$self->_error( qq[Cannot read compressed format in tar-mode] );
return;
}
-
+
### size is < HEAD, which means a corrupted file, as the minimum
### length is _at least_ HEAD
if (length $chunk != HEAD) {
@@ -399,8 +411,14 @@ sub _read_tar {
$data = $entry->get_content_by_ref;
my $skip = 0;
+ my $ctx; # cdrake
### skip this entry if we're filtering
- if ($filter && $entry->name !~ $filter) {
+
+ if($md5) { # cdrake
+ $ctx = Digest::MD5->new; # cdrake
+ $skip=5; # cdrake
+
+ } elsif ($filter && $entry->name !~ $filter) {
$skip = 1;
### skip this entry if it's a pax header. This is a special file added
@@ -415,11 +433,12 @@ sub _read_tar {
if ($skip) {
#
# Since we're skipping, do not allocate memory for the
- # whole file. Read it 64 BLOCKS at a time. Do not
+ # whole file. Read it 64 BLOCKS at a time. Do not
# complete the skip yet because maybe what we read is a
# longlink and it won't get skipped after all
#
my $amt = $block;
+ my $fsz=$entry->size; # cdrake
while ($amt > 0) {
$$data = '';
my $this = 64 * BLOCK;
@@ -430,9 +449,11 @@ sub _read_tar {
next LOOP;
}
$amt -= $this;
+ $fsz -= $this; # cdrake
+ substr ($$data, $fsz) = "" if ($fsz<0); # remove external junk prior to md5 # cdrake
+ $ctx->add($$data) if($skip==5); # cdrake
}
- ### throw away trailing garbage ###
- substr ($$data, $entry->size) = "" if defined $$data && $block < 64 * BLOCK;
+ $$data = $ctx->hexdigest if($skip==5 && !$entry->is_longlink && !$entry->is_unknown && !$entry->is_label ) ; # cdrake
} else {
### just read everything into memory
@@ -1082,6 +1103,45 @@ sub rename {
return $entry->rename( $new );
}
+=head2 $tar->chmod( $file, $mode )
+
+Change mode of $file to $mode.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chmod {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
+ my @args = ("$mode");
+
+ my $entry = $self->_find_entry( $file ) or return;
+ my $x = $entry->chmod( @args );
+ return $x;
+}
+
+=head2 $tar->chown( $file, $uname [, $gname] )
+
+Change owner $file to $uname and $gname.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chown {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $uname = shift; return unless defined $uname;
+ my @args = ($uname);
+ push(@args, shift);
+
+ my $entry = $self->_find_entry( $file ) or return;
+ my $x = $entry->chown( @args );
+ return $x;
+}
+
=head2 $tar->remove (@filenamelist)
Removes any entries with names matching any of the given filenames
@@ -1645,7 +1705,7 @@ Example usage:
sub iter {
my $class = shift;
my $filename = shift or return;
- my $compressed = shift or 0;
+ my $compressed = shift || 0;
my $opts = shift || {};
### get a handle to read from.
@@ -1930,7 +1990,7 @@ doing.
=head2 $Archive::Tar::ZERO_PAD_NUMBERS
This variable holds a boolean indicating if we will create
-zero padded numbers for C<size>, C<mtime> and C<checksum>.
+zero padded numbers for C<size>, C<mtime> and C<checksum>.
The default is C<0>, indicating that we will create space padded
numbers. Added for compatibility with C<busybox> implementations.
@@ -2114,7 +2174,7 @@ encoded in a different way.
=head1 CAVEATS
-The AIX tar does not fill all unused space in the tar archive with 0x00.
+The AIX tar does not fill all unused space in the tar archive with 0x00.
This sometimes leads to warning messages from C<Archive::Tar>.
Invalid header block at offset nnn
@@ -2126,14 +2186,14 @@ of AIX, all of which should be coming out in the 4th quarter of 2009:
AIX 5.3 TL8 SP8
AIX 5.3 TL9 SP5
AIX 5.3 TL10 SP2
-
+
AIX 6.1 TL0 SP11
AIX 6.1 TL1 SP7
AIX 6.1 TL2 SP6
AIX 6.1 TL3 SP3
-The IBM APAR number for this problem is IZ50240 (Reported component ID:
-5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
+The IBM APAR number for this problem is IZ50240 (Reported component ID:
+5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
If you need an ifix please contact your local IBM AIX support.
=head1 TODO
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
index abeb824a050..1bea5ce12d7 100644
--- a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
@@ -2,8 +2,8 @@ package Archive::Tar::Constant;
BEGIN {
require Exporter;
-
- $VERSION = '1.76';
+
+ $VERSION = '1.82';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
@@ -51,12 +51,12 @@ use constant MODE => do { 0666 & (0777 & ~umask) };
use constant STRIP_MODE => sub { shift() & 0777 };
use constant CHECK_SUM => " ";
-use constant UNPACK => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';
+use constant UNPACK => 'A100 A8 A8 A8 a12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
use constant NAME_LENGTH => 100;
use constant PREFIX_LENGTH => 155;
-use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
+use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
use constant MAGIC => "ustar";
use constant TAR_VERSION => "00";
use constant LONGLINK_NAME => '././@LongLink';
@@ -65,14 +65,14 @@ use constant PAX_HEADER => 'pax_global_header';
### allow ZLIB to be turned off using ENV: DEBUG only
use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
eval { require IO::Zlib };
- $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
+ $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
};
- ### allow BZIP to be turned off using ENV: DEBUG only
+ ### allow BZIP to be turned off using ENV: DEBUG only
use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
eval { require IO::Uncompress::Bunzip2;
require IO::Compress::Bzip2; };
- $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
+ $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
};
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
@@ -81,6 +81,6 @@ use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
-use constant ON_VMS => $^O eq 'VMS';
+use constant ON_VMS => $^O eq 'VMS';
1;
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
index 8604ab83247..9067de10863 100644
--- a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
@@ -13,26 +13,27 @@ use Archive::Tar::Constant;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '1.76';
+$VERSION = '1.82';
### set value to 1 to oct() it during the unpack ###
+
my $tmpl = [
- name => 0, # string
- mode => 1, # octal
- uid => 1, # octal
- gid => 1, # octal
- size => 1, # octal
- mtime => 1, # octal
- chksum => 1, # octal
- type => 0, # character
- linkname => 0, # string
- magic => 0, # string
- version => 0, # 2 bytes
- uname => 0, # string
- gname => 0, # string
- devmajor => 1, # octal
- devminor => 1, # octal
- prefix => 0,
+ name => 0, # string A100
+ mode => 1, # octal A8
+ uid => 1, # octal A8
+ gid => 1, # octal A8
+ size => 0, # octal # cdrake - not *always* octal.. A12
+ mtime => 1, # octal A12
+ chksum => 1, # octal A8
+ type => 0, # character A1
+ linkname => 0, # string A100
+ magic => 0, # string A6
+ version => 0, # 2 bytes A2
+ uname => 0, # string A32
+ gname => 0, # string A32
+ devmajor => 1, # octal A8
+ devminor => 1, # octal A8
+ prefix => 0, # A155 x 12
### end UNPACK items ###
raw => 0, # the raw data chunk
@@ -214,8 +215,20 @@ sub _new_from_chunk {
### makes it start at 0 actually... :) ###
my $i = -1;
my %entry = map {
- $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
- } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
+ my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
+ ($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
+ $s=> $v ? oct $_ : $_ # cdrake
+ # $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
+ } unpack( UNPACK, $chunk ); # cdrake
+ # } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
+
+
+ if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
+ my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikley to ever be needed - the numbers are just too big...) # cdrake
+ } else { # cdrake
+ ($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
+ } # cdrake
+
my $obj = bless { %entry, %args }, $class;
@@ -236,23 +249,23 @@ sub _new_from_chunk {
sub _new_from_file {
my $class = shift;
- my $path = shift;
-
+ my $path = shift;
+
### path has to at least exist
return unless defined $path;
-
+
my $type = __PACKAGE__->_filetype($path);
my $data = '';
- READ: {
+ READ: {
unless ($type == DIR ) {
my $fh = IO::File->new;
-
+
unless( $fh->open($path) ) {
### dangling symlinks are fine, stop reading but continue
### creating the object
last READ if $type == SYMLINK;
-
+
### otherwise, return from this function --
### anything that's *not* a symlink should be
### resolvable
@@ -405,7 +418,7 @@ sub _prefix_and_file {
sub _filetype {
my $self = shift;
my $file = shift;
-
+
return unless defined $file;
return SYMLINK if (-l $file); # Symlink
@@ -442,7 +455,7 @@ sub _downgrade_to_plainfile {
=head2 $bool = $file->extract( [ $alternative_name ] )
-Extract this object, optionally to an alternative name.
+Extract this object, optionally to an alternative name.
See C<< Archive::Tar->extract_file >> for details.
@@ -452,9 +465,9 @@ Returns true on success and false on failure.
sub extract {
my $self = shift;
-
+
local $Carp::CarpLevel += 1;
-
+
return Archive::Tar->_extract_file( $self, @_ );
}
@@ -576,7 +589,7 @@ Returns true on success and false on failure.
sub rename {
my $self = shift;
my $path = shift;
-
+
return unless defined $path;
my ($prefix,$file) = $self->_prefix_and_file( $path );
@@ -587,6 +600,48 @@ sub rename {
return 1;
}
+=head2 $bool = $file->chmod $mode)
+
+Change mode of $file to $mode. The mode can be a string or a number
+which is interpreted as octal whether or not a leading 0 is given.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chmod {
+ my $self = shift;
+ my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
+ $self->{mode} = oct($mode);
+ return 1;
+}
+
+=head2 $bool = $file->chown( $user [, $group])
+
+Change owner of $file to $user. If a $group is given that is changed
+as well. You can also pass a single parameter with a colon separating the
+use and group as in 'root:wheel'.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chown {
+ my $self = shift;
+ my $uname = shift;
+ return unless defined $uname;
+ my $gname;
+ if (-1 != index($uname, ':')) {
+ ($uname, $gname) = split(/:/, $uname);
+ } else {
+ $gname = shift if @_ > 0;
+ }
+
+ $self->uname( $uname );
+ $self->gname( $gname ) if $gname;
+ return 1;
+}
+
=head1 Convenience methods
To quickly check the type of a C<Archive::Tar::File> object, you can