diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Extract.pm | 281 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar.pm | 84 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm | 16 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar/File.pm | 115 |
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 |