diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Extract.pm | 1690 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar.pm | 121 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm | 30 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar/File.pm | 6 |
4 files changed, 141 insertions, 1706 deletions
diff --git a/Master/tlpkg/tlperl/lib/Archive/Extract.pm b/Master/tlpkg/tlperl/lib/Archive/Extract.pm deleted file mode 100644 index ae3af3edf82..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Extract.pm +++ /dev/null @@ -1,1690 +0,0 @@ -package Archive::Extract; -use if $] > 5.017, 'deprecate'; - -use strict; - -use Cwd qw[cwd chdir]; -use Carp qw[carp]; -use IPC::Cmd qw[run can_run]; -use FileHandle; -use File::Path qw[mkpath]; -use File::Spec; -use File::Basename qw[dirname basename]; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load check_install]; -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_OPENBSD => $^O eq 'openbsd' ? 1 : 0; -use constant ON_FREEBSD => $^O =~ m!^(free|midnight)bsd$! ? 1 : 0; -use constant ON_LINUX => $^O eq 'linux' ? 1 : 0; -use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; - -### VMS may require quoting upper case command options -use constant ON_VMS => $^O eq 'VMS' ? 1 : 0; - -### Windows needs special treatment of Tar options -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 => []; - -### If these are changed, update @TYPES and the new() POD -use constant TGZ => 'tgz'; -use constant TAR => 'tar'; -use constant GZ => 'gz'; -use constant ZIP => 'zip'; -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.68'; -$PREFER_BIN = 0; -$WARN = 1; -$DEBUG = 0; -$_ALLOW_PURE_PERL = 1; # allow pure perl extractors -$_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 ); - -local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -Archive::Extract - A generic archive extracting mechanism - -=head1 SYNOPSIS - - use Archive::Extract; - - ### build an Archive::Extract object ### - my $ae = Archive::Extract->new( archive => 'foo.tgz' ); - - ### extract to cwd() ### - my $ok = $ae->extract; - - ### extract to /tmp ### - my $ok = $ae->extract( to => '/tmp' ); - - ### what if something went wrong? - my $ok = $ae->extract or die $ae->error; - - ### files from the archive ### - my $files = $ae->files; - - ### dir that was extracted to ### - my $outdir = $ae->extract_path; - - - ### quick check methods ### - $ae->is_tar # is it a .tar file? - $ae->is_tgz # is it a .tar.gz or .tgz file? - $ae->is_gz; # is it a .gz file? - $ae->is_zip; # is it a .zip file? - $ae->is_bz2; # is it a .bz2 file? - $ae->is_tbz; # is it a .tar.bz2 or .tbz file? - $ae->is_lzma; # is it a .lzma file? - $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; - - ### commandline tools, if found ### - $ae->bin_tar # path to /bin/tar, if found - $ae->bin_gzip # path to /bin/gzip, if found - $ae->bin_unzip # path to /bin/unzip, if found - $ae->bin_bunzip2 # path to /bin/bunzip2 if found - $ae->bin_unlzma # path to /bin/unlzma if found - $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, .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. - -=cut - - -### see what /bin/programs are available ### -$PROGRAMS = {}; -CMD: for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) { - if ( $pgm eq 'unzip' and ( ON_NETBSD or ON_FREEBSD ) ) { - local $IPC::Cmd::INSTANCES = 1; - ($PROGRAMS->{$pgm}) = grep { ON_NETBSD ? m!/usr/pkg/! : m!/usr/local! } can_run($pgm); - next CMD; - } - if ( $pgm eq 'unzip' and ON_LINUX ) { - # Check if 'unzip' is busybox masquerading - local $IPC::Cmd::INSTANCES = 1; - my $opt = ON_VMS ? '"-Z"' : '-Z'; - ($PROGRAMS->{$pgm}) = grep { scalar run(command=> [ $_, $opt, '-1' ]) } can_run($pgm); - next CMD; - } - if ( $pgm eq 'tar' and ON_OPENBSD || ON_SOLARIS ) { - # try gtar first - next CMD if $PROGRAMS->{$pgm} = can_run('gtar'); - } - $PROGRAMS->{$pgm} = can_run($pgm); -} - -### mapping from types to extractor methods ### -my $Mapping = { # binary program # pure perl module - is_tgz => { bin => '_untar_bin', pp => '_untar_at' }, - is_tar => { bin => '_untar_bin', pp => '_untar_at' }, - is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' }, - is_zip => { bin => '_unzip_bin', pp => '_unzip_az' }, - is_tbz => { bin => '_untar_bin', pp => '_untar_at' }, - is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, - is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, - is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, - 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-override flags - ### if we don't, then we reuse the same arrayref, meaning objects store - ### previous errors - my $tmpl = { - archive => sub { { required => 1, allow => FILE_EXISTS } }, - type => sub { { default => '', allow => [ @Types ] } }, - _error_msg => sub { { no_override => 1, default => [] } }, - _error_msg_long => sub { { no_override => 1, default => [] } }, - }; - - ### build accessors ### - for my $method( keys %$tmpl, - qw[_extractor _gunzip_to files extract_path], - ) { - no strict 'refs'; - *$method = sub { - my $self = shift; - $self->{$method} = $_[0] if @_; - return $self->{$method}; - } - } - -=head1 METHODS - -=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE]) - -Creates a new C<Archive::Extract> object based on the archive file you -passed it. Automatically determines the type of archive based on the -extension, but you can override that by explicitly providing the -C<type> argument. - -Valid values for C<type> are: - -=over 4 - -=item tar - -Standard tar files, as produced by, for example, C</bin/tar>. -Corresponds to a C<.tar> suffix. - -=item tgz - -Gzip compressed tar files, as produced by, for example C</bin/tar -z>. -Corresponds to a C<.tgz> or C<.tar.gz> suffix. - -=item gz - -Gzip compressed file, as produced by, for example C</bin/gzip>. -Corresponds to a C<.gz> suffix. - -=item Z - -Lempel-Ziv compressed file, as produced by, for example C</bin/compress>. -Corresponds to a C<.Z> suffix. - -=item zip - -Zip compressed file, as produced by, for example C</bin/zip>. -Corresponds to a C<.zip>, C<.jar> or C<.par> suffix. - -=item bz2 - -Bzip2 compressed file, as produced by, for example, C</bin/bzip2>. -Corresponds to a C<.bz2> suffix. - -=item tbz - -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 - -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. - -=cut - - ### constructor ### - sub new { - my $class = shift; - my %hash = @_; - - ### see above why we use subs here and generate the template; - ### it's basically to not re-use arrayrefs - my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl; - - my $parsed = check( \%utmpl, \%hash ) or return; - - ### make sure we have an absolute path ### - my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); - - ### 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|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 - ### XXX this *has* to be an object call, not a package call - return $parsed->_error(loc("Cannot determine file type for '%1'", - $parsed->{archive} )) unless $parsed->{type}; - return $parsed; - } -} - -=head2 $ae->extract( [to => '/output/path'] ) - -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>. -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. - -C<extract> will try a pure perl solution first, and then fall back to -commandline tools if they are available. See the C<GLOBAL VARIABLES> -section below on how to alter this behaviour. - -It will return true on success, and false on failure. - -On success, it will also set the follow attributes in the object: - -=over 4 - -=item $ae->extract_path - -This is the directory that the files where extracted to. - -=item $ae->files - -This is an array ref with the paths of all the files in the archive, -relative to the C<to> argument you specified. -To get the full path to an extracted file, you would use: - - File::Spec->catfile( $to, $ae->files->[0] ); - -Note that all files from a tar archive will be in unix format, as per -the tar specification. - -=back - -=cut - -sub extract { - my $self = shift; - my %hash = @_; - - ### reset error messages - $self->_error_msg( [] ); - $self->_error_msg_long( [] ); - - my $to; - my $tmpl = { - to => { default => '.', store => \$to } - }; - - check( $tmpl, \%hash ) or return; - - ### 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 - ### to. - 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; - $self->_gunzip_to( basename($cp) ); - - ### then it's a filename - } else { - $dir = dirname($to); - $self->_gunzip_to( basename($to) ); - } - - ### not a foo.gz file - } else { - $dir = $to; - } - } - - ### make the dir if it doesn't exist ### - unless( -d $dir ) { - eval { mkpath( $dir ) }; - - return $self->_error(loc("Could not create path '%1': %2", $dir, $@)) - if $@; - } - - ### get the current dir, to restore later ### - my $cwd = cwd(); - - my $ok = 1; - EXTRACT: { - - ### chdir to the target dir ### - unless( chdir $dir ) { - $self->_error(loc("Could not chdir to '%1': %2", $dir, $!)); - $ok = 0; last EXTRACT; - } - - ### set files to an empty array ref, so there's always an array - ### ref IN the accessor, to avoid errors like: - ### Can't use an undefined value as an ARRAY reference at - ### ../lib/Archive/Extract.pm line 742. (rt #19815) - $self->files( [] ); - - ### find out the dispatch methods needed for this type of - ### archive. Do a $self->is_XXX to figure out the type, then - ### get the hashref with bin + pure perl dispatchers. - my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping; - - ### add pure perl extractor if allowed & add bin extractor if allowed - my @methods; - push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL; - push @methods, $map->{'bin'} if $_ALLOW_BIN; - - ### reverse it if we prefer bin extractors - @methods = reverse @methods if $PREFER_BIN; - - 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 ) { - $self->debug( "# Extraction method not available\n" ); - $na++; - } else { - $self->debug( "# Extraction method failed\n" ); - $fail++; - } - } - - ### warn something went wrong if we didn't get an extractor - unless( $self->_extractor ) { - my $diag = $fail ? loc("Extract failed due to errors") : - $na ? loc("Extract failed; no extractors available") : - ''; - - $self->_error($diag); - $ok = 0; - } - } - - ### and chdir back ### - unless( chdir $cwd ) { - $self->_error(loc("Could not chdir back to start dir '%1': %2'", - $cwd, $!)); - } - - return $ok; -} - -=pod - -=head1 ACCESSORS - -=head2 $ae->error([BOOL]) - -Returns the last encountered error as string. -Pass it a true value to get the C<Carp::longmess()> output instead. - -=head2 $ae->extract_path - -This is the directory the archive got extracted to. -See C<extract()> for details. - -=head2 $ae->files - -This is an array ref holding all the paths from the archive. -See C<extract()> for details. - -=head2 $ae->archive - -This is the full path to the archive file represented by this -C<Archive::Extract> object. - -=head2 $ae->type - -This is the type of archive represented by this C<Archive::Extract> -object. See accessors below for an easier way to use this. -See the C<new()> method for details. - -=head2 $ae->types - -Returns a list of all known C<types> for C<Archive::Extract>'s -C<new> method. - -=cut - -sub types { return @Types } - -=head2 $ae->is_tgz - -Returns true if the file is of type C<.tar.gz>. -See the C<new()> method for details. - -=head2 $ae->is_tar - -Returns true if the file is of type C<.tar>. -See the C<new()> method for details. - -=head2 $ae->is_gz - -Returns true if the file is of type C<.gz>. -See the C<new()> method for details. - -=head2 $ae->is_Z - -Returns true if the file is of type C<.Z>. -See the C<new()> method for details. - -=head2 $ae->is_zip - -Returns true if the file is of type C<.zip>. -See the C<new()> method for details. - -=head2 $ae->is_lzma - -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 ### -sub is_tgz { return $_[0]->type eq TGZ } -sub is_tar { return $_[0]->type eq TAR } -sub is_gz { return $_[0]->type eq GZ } -sub is_zip { return $_[0]->type eq ZIP } -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 - -=head2 $ae->bin_tar - -Returns the full path to your tar binary, if found. - -=head2 $ae->bin_gzip - -Returns the full path to your gzip binary, if found - -=head2 $ae->bin_unzip - -Returns the full path to your unzip binary, if found - -=head2 $ae->bin_unlzma - -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 ### -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'} - 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 - -Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release, -require all archive names to end in C<.bz2> or it will not extract -them. This method checks if you have a recent version of C<bunzip2> -that allows any extension, or an older one that doesn't. - -=cut - -sub have_old_bunzip2 { - my $self = shift; - - ### 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 - ### XXX stupid stupid stupid bunzip2 doesn't understand --version - ### is not a request to extract data: - ### $ bunzip2 --version - ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001. - ### [...] - ### bunzip2: I won't read compressed data from a terminal. - ### bunzip2: For help, type: `bunzip2 --help'. - ### $ echo $? - ### 1 - ### HATEFUL! - - ### double hateful: bunzip2 --version also hangs if input is a pipe - ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH] - ### So, we have to provide *another* argument which is a fake filename, - ### just so it wont try to read from stdin to print its version.. - ### *sigh* - ### Even if the file exists, it won't clobber or change it. - my $buffer; - scalar run( - command => [$self->bin_bunzip2, '--version', 'NoSuchFile'], - verbose => 0, - buffer => \$buffer - ); - - ### no output - return unless $buffer; - - my ($version) = $buffer =~ /version \s+ (\d+)/ix; - - return 1 if $version < 1; - return; -} - -################################# -# -# Untar code -# -################################# - -### annoying issue with (gnu) tar on win32, as illustrated by this -### bug: https://rt.cpan.org/Ticket/Display.html?id=40138 -### which shows that (gnu) tar will interpret a file name with a : -### in it as a remote file name, so C:\tmp\foo.txt is interpreted -### as a remote shell, and the extract fails. -{ my @ExtraTarFlags; - if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) { - - ### 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 = !$self->bin_tar ? - loc("No '%1' program found", '/bin/tar') : - $self->is_tgz && !$self->bin_gzip ? - loc("No '%1' program found", '/bin/gzip') : - $self->is_tbz && !$self->bin_bunzip2 ? - loc("No '%1' program found", '/bin/bunzip2') : - $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', $archive, '|', - $self->bin_tar, '-tf', '-'] : - $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|', - $self->bin_tar, '-tf', '-'] : - $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|', - $self->bin_tar, '-tf', '-'] : - [$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 - ### is a 'feature' according to the changelog, so we must now only - ### inspect STDOUT, otherwise, failures like these occur: - ### http://www.cpantesters.org/cpan/report/3230366 - my $buffer = ''; - my @out = run( command => $cmd, - buffer => \$buffer, - verbose => $DEBUG ); - - ### command was unsuccessful - unless( $out[0] ) { - return $self->_error(loc( - "Error listing contents of archive '%1': %2", - $archive, $buffer )); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $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 - ### /usr/local/bin/tar, which is gnu tar, which is perfectly - ### fine... so we have to do some guessing here =/ - my @files = map { chomp; - !ON_SOLARIS ? $_ - : (m|^ x \s+ # 'xtract' -- sigh - (.+?), # the actual file name - \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 $/, $_ } 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', $archive, '|', - $self->bin_tar, '-xf', '-'] : - $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|', - $self->bin_tar, '-xf', '-'] : - $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|', - $self->bin_tar, '-xf', '-'] : - [$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", - $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; - } -} - - -### use archive::tar to extract ### -sub _untar_at { - my $self = shift; - - ### Loading Archive::Tar is going to set it to 1, so make it local - ### within this block, starting with its initial value. Whatever - ### Achive::Tar does will be undone when we return. - ### - ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN - ### so users don't have to even think about this variable. If they - ### do, they still get their set value outside of this call. - local $Archive::Tar::WARN = $Archive::Tar::WARN; - - ### we definitely need Archive::Tar, so load that first - { my $use_list = { 'Archive::Tar' => '0.0' }; - - unless( can_load( modules => $use_list ) ) { - - $self->_error(loc("You do not have '%1' installed - " . - "Please install it as soon as possible.", - 'Archive::Tar')); - - return METHOD_NA; - } - } - - ### we might pass it a filehandle if it's a .tbz file.. - my $fh_to_read = $self->archive; - - ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib - ### if A::T's version is 0.99 or higher - if( $self->is_tgz ) { - my $use_list = { 'Compress::Zlib' => '0.0' }; - $use_list->{ 'IO::Zlib' } = '0.0' - if $Archive::Tar::VERSION >= '0.99'; - - unless( can_load( modules => $use_list ) ) { - my $which = join '/', sort keys %$use_list; - - $self->_error(loc( - "You do not have '%1' installed - Please ". - "install it as soon as possible.", $which) - ); - - return METHOD_NA; - } - - } elsif ( $self->is_tbz ) { - my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; - unless( can_load( modules => $use_list ) ) { - $self->_error(loc( - "You do not have '%1' installed - Please " . - "install it as soon as possible.", - 'IO::Uncompress::Bunzip2') - ); - - return METHOD_NA; - } - - my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or - return $self->_error(loc("Unable to open '%1': %2", - $self->archive, - $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; - { - ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've - ### localized $Archive::Tar::WARN already. - $Archive::Tar::WARN = $Archive::Extract::WARN; - - ### only tell it it's compressed if it's a .tgz, as we give it a file - ### handle if it's a .tbz - my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ); - - ### for version of Archive::Tar > 1.04 - local $Archive::Tar::CHOWN = 0; - - ### use the iterator if we can. it's a feature of A::T 1.40 and up - if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) { - - my $next; - unless ( $next = Archive::Tar->iter( @read ) ) { - return $self->_error(loc( - "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", - $self->archive, - $Archive::Tar::error)); - } - - ### 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", - $self->archive, $Archive::Tar::error)); - } - - ### workaround to prevent Archive::Tar from setting uid, which - ### is a potential security hole. -autrijus - ### have to do it here, since A::T needs to be /loaded/ first ### - { no strict 'refs'; local $^W; - - ### older versions of archive::tar <= 0.23 - *Archive::Tar::chown = sub {}; - } - - { local $^W; # quell 'splice() offset past end of array' warnings - # on older versions of A::T - - ### 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", - $self->archive, $Archive::Tar::error )); - } - - @files = $tar->list_files; - } - } - - my $dir = $self->__get_extract_dir( \@files ); - - ### store the files that are in the archive ### - $self->files(\@files); - - ### store the extraction dir ### - $self->extract_path( $dir ); - - ### check if the dir actually appeared ### - return 1 if -d $self->extract_path; - - ### no dir, we failed ### - return $self->_error(loc("Unable to extract '%1': %2", - $self->archive, $Archive::Tar::error )); -} - -################################# -# -# Gunzip code -# -################################# - -sub _gunzip_bin { - my $self = shift; - - ### check for /bin/gzip -- we need it ### - unless( $self->bin_gzip ) { - $self->_error(loc("No '%1' program found", '/bin/gzip')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to gunzip '%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 _gunzip_cz { - my $self = shift; - - my $use_list = { 'Compress::Zlib' => '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::Zlib')); - return METHOD_NA; - } - - my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or - return $self->_error(loc("Unable to open '%1': %2", - $self->archive, $Compress::Zlib::gzerrno)); - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $buffer; - $self->_print($fh, $buffer) while $gz->gzread($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; -} - -################################# -# -# Uncompress code -# -################################# - -sub _uncompress_bin { - my $self = shift; - - ### check for /bin/gzip -- we need it ### - unless( $self->bin_uncompress ) { - $self->_error(loc("No '%1' program found", '/bin/uncompress')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $cmd = [ $self->bin_uncompress, '-c', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to uncompress '%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; -} - - -################################# -# -# Unzip code -# -################################# - - -sub _unzip_bin { - my $self = shift; - - ### check for /bin/gzip if we need it ### - 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 - ### 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 ]; - - my $buffer = ''; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to unzip '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $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] ); - } - } - - ### now, extract the archive ### - { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to unzip '%1': %2", - $self->archive, $buffer)); - } - - if( scalar @{$self->files} ) { - my $files = $self->files; - my $dir = $self->__get_extract_dir( $files ); - - $self->extract_path( $dir ); - } - } - - return 1; -} - -sub _unzip_az { - my $self = shift; - - my $use_list = { 'Archive::Zip' => '0.0' }; - 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; - } - - my $zip = Archive::Zip->new(); - - unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) { - return $self->_error(loc("Unable to read '%1'", $self->archive)); - } - - 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. - ### I traced this back through Archive::Zip::_asLocalName which - ### 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 )); - } - } - - my $dir = $self->__get_extract_dir( \@files ); - - ### set what files where extract, and where they went ### - $self->files( \@files ); - $self->extract_path( File::Spec->rel2abs($dir) ); - - return 1; -} - -sub __get_extract_dir { - my $self = shift; - my $files = shift || []; - - return unless scalar @$files; - - my($dir1, $dir2); - for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) { - my($dir,$pos) = @$aref; - - ### add a catdir(), so that any trailing slashes get - ### take care of (removed) - ### also, a catdir() normalises './dir/foo' to 'dir/foo'; - ### which was the problem in bug #23999 - my $res = -d $files->[$pos] - ? File::Spec->catdir( $files->[$pos], '' ) - : File::Spec->catdir( dirname( $files->[$pos] ) ); - - $$dir = $res; - } - - ### 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 : '.' ); - } - - return File::Spec->rel2abs( $dir ); -} - -################################# -# -# Bunzip2 code -# -################################# - -sub _bunzip2_bin { - my $self = shift; - - ### check for /bin/gzip -- we need it ### - 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 ) { - return $self->_error(loc("Your bunzip2 version is too old and ". - "can only extract files ending in '%1'", - '.bz2')); - } - - my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to bunzip2 '%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; -} - -### using cz2, the compact versions... this we use mainly in archive::tar -### 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; -# } - -sub _bunzip2_bz2 { - my $self = shift; - - my $use_list = { 'IO::Uncompress::Bunzip2' => '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::Bunzip2')); - return METHOD_NA; - } - - IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to) - or return $self->_error(loc("Unable to uncompress '%1': %2", - $self->archive, - $IO::Uncompress::Bunzip2::Bunzip2Error)); - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - 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; -} - - -################################# -# -# unlzma code -# -################################# - -sub _unlzma_bin { - my $self = shift; - - ### check for /bin/unlzma -- we need it ### - unless( $self->bin_unlzma ) { - $self->_error(loc("No '%1' program found", '/bin/unlzma')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $cmd = [ $self->bin_unlzma, '-c', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to unlzma '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_content( $self->archive ) ); - } - - $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 _unlzma_cz { - my $self = shift; - - 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 $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; - - 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] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - -################################# -# -# Error code -# -################################# - -# For printing binaries that avoids interfering globals -sub _print { - my $self = shift; - my $fh = shift; - - local( $\, $", $, ) = ( undef, ' ', '' ); - return print $fh @_; -} - -sub _error { - my $self = shift; - my $error = shift; - my $lerror = Carp::longmess($error); - - push @{$self->_error_msg}, $error; - push @{$self->_error_msg_long}, $lerror; - - ### set $Archive::Extract::WARN to 0 to disable printing - ### of errors - if( $WARN ) { - carp $DEBUG ? $lerror : $error; - } - - return; -} - -sub error { - my $self = shift; - - ### make sure we have a fallback aref - my $aref = do { - shift() - ? $self->_error_msg_long - : $self->_error_msg - } || []; - - 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; - return loc("No buffer captured, unable to tell ". - "extracted files or extraction dir for '%1'", $file); -} - -sub _no_buffer_content { - my $self = shift; - my $file = shift or return; - return loc("No buffer captured, unable to get content for '%1'", $file); -} -1; - -=pod - -=head1 HOW IT WORKS - -C<Archive::Extract> tries first to determine what type of archive you -are passing it, by inspecting its suffix. It does not do this by using -Mime magic, or something related. See C<CAVEATS> below. - -Once it has determined the file type, it knows which extraction methods -it can use on the archive. It will try a perl solution first, then fall -back to a commandline tool if that fails. If that also fails, it will -return false, indicating it was unable to extract the archive. -See the section on C<GLOBAL VARIABLES> to see how to alter this order. - -=head1 CAVEATS - -=head2 File Extensions - -C<Archive::Extract> trusts on the extension of the archive to determine -what type it is, and what extractor methods therefore can be used. If -your archives do not have any of the extensions as described in the -C<new()> method, you will have to specify the type explicitly, or -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 -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 -the use of command line programs and won't consume so much memory. - -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 -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> -method. - -=head1 GLOBAL VARIABLES - -=head2 $Archive::Extract::DEBUG - -Set this variable to C<true> to have all calls to command line tools -be printed out, including all their output. -This also enables C<Carp::longmess> errors, instead of the regular -C<carp> errors. - -Good for tracking down why things don't work with your particular -setup. - -Defaults to C<false>. - -=head2 $Archive::Extract::WARN - -This variable controls whether errors encountered internally by -C<Archive::Extract> should be C<carp>'d or not. - -Set to false to silence warnings. Inspect the output of the C<error()> -method manually to see what went wrong. - -Defaults to C<true>. - -=head2 $Archive::Extract::PREFER_BIN - -This variables controls whether C<Archive::Extract> should prefer the -use of perl modules, or commandline tools to extract archives. - -Set to C<true> to have C<Archive::Extract> prefer commandline tools. - -Defaults to C<false>. - -=head1 TODO / CAVEATS - -=over 4 - -=item Mime magic support - -Maybe this module should use something like C<File::Type> to determine -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 -thread safe. See C<rt.cpan.org> bug C<#45671> for details. - -=back - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.orgE<gt>. - -=head1 AUTHOR - -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 -under the same terms as Perl itself. - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar.pm b/Master/tlpkg/tlperl/lib/Archive/Tar.pm index dd4b968acd3..50afbb334b9 100644 --- a/Master/tlpkg/tlperl/lib/Archive/Tar.pm +++ b/Master/tlpkg/tlperl/lib/Archive/Tar.pm @@ -23,7 +23,7 @@ require Exporter; use strict; use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS - $INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT + $INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT $RESOLVE_SYMLINK ]; @ISA = qw[Exporter]; @@ -31,13 +31,14 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD $DEBUG = 0; $WARN = 1; $FOLLOW_SYMLINK = 0; -$VERSION = "1.90"; +$VERSION = "1.96"; $CHOWN = 1; $CHMOD = 1; $SAME_PERMISSIONS = $> == 0 ? 1 : 0; $DO_NOT_USE_PREFIX = 0; $INSECURE_EXTRACT_MODE = 0; $ZERO_PAD_NUMBERS = 0; +$RESOLVE_SYMLINK = $ENV{'PERL5_AT_RESOLVE_SYMLINK'} || 'speed'; BEGIN { use Config; @@ -485,7 +486,7 @@ sub _read_tar { ### but that doesn't *always* happen.. so check if the last ### character is a control character, and if so remove it ### at any rate, we better remove that character here, or tests - ### like 'eq' and hashlook ups based on names will SO not work + ### like 'eq' and hash lookups based on names will SO not work ### remove it by calculating the proper size, and then ### tossing out everything that's longer than that size. @@ -956,7 +957,7 @@ sub _extract_special_file_as_plain_file { my $err; TRY: { - my $orig = $self->_find_entry( $entry->linkname ); + my $orig = $self->_find_entry( $entry->linkname, $entry ); unless( $orig ) { $err = qq[Could not find file '] . $entry->linkname . @@ -965,7 +966,7 @@ sub _extract_special_file_as_plain_file { } ### clone the entry, make it appear as a normal file ### - my $clone = $entry->clone; + my $clone = $orig->clone; $clone->_downgrade_to_plainfile; $self->_extract_file( $clone, $file ) or last TRY; @@ -1030,10 +1031,46 @@ sub _find_entry { ### it's an object already return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); - for my $entry ( @{$self->_data} ) { - my $path = $entry->full_path; - return $entry if $path eq $file; - } +seach_entry: + if($self->_data){ + for my $entry ( @{$self->_data} ) { + my $path = $entry->full_path; + return $entry if $path eq $file; + } + } + + if($Archive::Tar::RESOLVE_SYMLINK!~/none/){ + if(my $link_entry = shift()){#fallback mode when symlinks are using relative notations ( ../a/./b/text.bin ) + $file = _symlinks_resolver( $link_entry->name, $file ); + goto seach_entry if $self->_data; + + #this will be slower than never, but won't failed! + + my $iterargs = $link_entry->{'_archive'}; + if($Archive::Tar::RESOLVE_SYMLINK=~/speed/ && @$iterargs==3){ + #faster but whole archive will be read in memory + #read whole archive and share data + my $archive = Archive::Tar->new; + $archive->read( @$iterargs ); + push @$iterargs, $archive; #take a trace for destruction + if($archive->_data){ + $self->_data( $archive->_data ); + goto seach_entry; + } + }#faster + + {#slower but lower memory usage + # $iterargs = [$filename, $compressed, $opts]; + my $next = Archive::Tar->iter( @$iterargs ); + while(my $e = $next->()){ + if($e->full_path eq $file){ + undef $next; + return $e; + } + } + }#slower + } + } $self->_error( qq[No such file in archive: '$file'] ); return; @@ -1553,7 +1590,7 @@ sub add_data { =head2 $tar->error( [$BOOL] ) -Returns the current errorstring (usually, the last error reported). +Returns the current error string (usually, the last error reported). If a true value was specified, it will give the C<Carp::longmess> equivalent of the error, in effect giving you a stacktrace. @@ -1729,6 +1766,7 @@ sub iter { ) or return; my @data; + my $CONSTRUCT_ARGS = [ $filename, $compressed, $opts ]; return sub { return shift(@data) if @data; # more than one file returned? return unless $handle; # handle exhausted? @@ -1736,12 +1774,25 @@ sub iter { ### read data, should only return file my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 }); @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY'; + if($Archive::Tar::RESOLVE_SYMLINK!~/none/){ + foreach(@data){ + #may refine this heuristic for ON_UNIX? + if($_->linkname){ + #is there a better slot to store/share it ? + $_->{'_archive'} = $CONSTRUCT_ARGS; + } + } + } ### return one piece of data return shift(@data) if @data; ### data is exhausted, free the filehandle undef $handle; + if(@$CONSTRUCT_ARGS == 4){ + #free archive in memory + undef $CONSTRUCT_ARGS->[-1]; + } return; }; } @@ -1865,6 +1916,32 @@ sub no_string_support { croak("You have to install IO::String to support writing archives to strings"); } +sub _symlinks_resolver{ + my ($src, $trg) = @_; + my @src = split /[\/\\]/, $src; + my @trg = split /[\/\\]/, $trg; + pop @src; #strip out current object name + if(@trg and $trg[0] eq ''){ + shift @trg; + #restart path from scratch + @src = ( ); + } + foreach my $part ( @trg ){ + next if $part eq '.'; #ignore current + if($part eq '..'){ + #got to parent + pop @src; + } + else{ + #append it + push @src, $part; + } + } + my $path = join('/', @src); + warn "_symlinks_resolver('$src','$trg') = $path" if $DEBUG; + return $path; +} + 1; __END__ @@ -2007,6 +2084,30 @@ 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. +=head2 Tuning the way RESOLVE_SYMLINK will works + + You can tune the behaviour by setting the $Archive::Tar::RESOLVE_SYMLINK variable, + or $ENV{PERL5_AT_RESOLVE_SYMLINK} before loading the module Archive::Tar. + + Values can be one of the following: + + none + Disable this mechanism and failed as it was in previous version (<1.88) + + speed (default) + If you prefer speed + this will read again the whole archive using read() so all entries + will be available + + memory + If you prefer memory + + Limitation + + It won't work for terminal, pipe or sockets or every non seekable source. + +=cut + =head1 FAQ =over 4 diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm index 7839c6dc5cb..957ac278adc 100644 --- a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm +++ b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm @@ -3,14 +3,13 @@ package Archive::Tar::Constant; BEGIN { require Exporter; - $VERSION = '1.90'; + $VERSION = '1.96'; @ISA = qw[Exporter]; require Time::Local if $^O eq "MacOS"; } -use Package::Constants; -@EXPORT = Package::Constants->list( __PACKAGE__ ); +@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ ); use constant FILE => 0; use constant HARDLINK => 1; @@ -83,4 +82,29 @@ use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i a use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS'); use constant ON_VMS => $^O eq 'VMS'; +sub _list_consts { + my $class = shift; + my $pkg = shift; + return unless defined $pkg; # some joker might use '0' as a pkg... + + my @rv; + { no strict 'refs'; + my $stash = $pkg . '::'; + + for my $name (sort keys %$stash ) { + + ### is it a subentry? + my $sub = $pkg->can( $name ); + next unless defined $sub; + + next unless defined prototype($sub) and + not length prototype($sub); + + push @rv, $name; + } + } + + return sort @rv; +} + 1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm index de01e0513d4..39fca623fab 100644 --- a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm +++ b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm @@ -13,7 +13,7 @@ use Archive::Tar::Constant; use vars qw[@ISA $VERSION]; #@ISA = qw[Archive::Tar]; -$VERSION = '1.90'; +$VERSION = '1.96'; ### set value to 1 to oct() it during the unpack ### @@ -224,7 +224,7 @@ sub _new_from_chunk { 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 + 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 unlikely 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 @@ -481,7 +481,7 @@ concatenation of the C<prefix> and C<name> fields. sub full_path { my $self = shift; - ### if prefix field is emtpy + ### if prefix field is empty return $self->name unless defined $self->prefix and length $self->prefix; ### or otherwise, catfile'd |