diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive/Tar.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar.pm | 121 |
1 files changed, 111 insertions, 10 deletions
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 |