This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Archive-Tar to CPAN version 1.96
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Thu, 24 Oct 2013 19:13:11 +0000 (20:13 +0100)
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Thu, 24 Oct 2013 20:19:40 +0000 (21:19 +0100)
  [DELTA]

1.96  24/10/2013
- integrate Package::Constants into Constant module
  and remove requirement on it.

1.94  24/10/2013
- install into site if >= 5.012

1.93_02 22/10/2013 (XLAT)
- [rt.cpan.org #78030] symlinks resolution on MSWin32

Porting/Maintainers.pl
cpan/Archive-Tar/lib/Archive/Tar.pm
cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
cpan/Archive-Tar/lib/Archive/Tar/File.pm
cpan/Archive-Tar/t/04_resolved_issues.t

index e2c479f..206f320 100755 (executable)
@@ -48,7 +48,7 @@ use File::Glob qw(:case);
 # of the module is, but this is no longer stated explicitly. It is now
 # understood to be either the Perl 5 Porters if UPSTREAM is 'blead', or else
 # the CPAN author whose PAUSE user ID forms the first part of the DISTRIBUTION
-# value, e.g. 'BINGOS' in the case of 'BINGOS/Archive-Tar-1.92.tar.gz'.
+# value, e.g. 'BINGOS' in the case of 'BINGOS/Archive-Tar-1.96.tar.gz'.
 # (PAUSE's View Permissions page may be consulted to find other authors who
 # have owner or co-maint permissions for the module in question.)
 
@@ -119,7 +119,7 @@ use File::Glob qw(:case);
 %Modules = (
 
     'Archive::Tar' => {
-        'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.92.tar.gz',
+        'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.96.tar.gz',
         'FILES'        => q[cpan/Archive-Tar],
         'BUGS'         => 'bug-archive-tar@rt.cpan.org',
     },
index bd22d2a..50afbb3 100644 (file)
@@ -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.92";
+$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;
@@ -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;
@@ -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
index 2bddf71..957ac27 100644 (file)
@@ -3,14 +3,13 @@ package Archive::Tar::Constant;
 BEGIN {
     require Exporter;
 
-    $VERSION    = '1.92';
+    $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;
index 3f13bc8..39fca62 100644 (file)
@@ -13,7 +13,7 @@ use Archive::Tar::Constant;
 
 use vars qw[@ISA $VERSION];
 #@ISA        = qw[Archive::Tar];
-$VERSION    = '1.92';
+$VERSION    = '1.96';
 
 ### set value to 1 to oct() it during the unpack ###
 
index 45b7a91..4572b87 100644 (file)
@@ -194,3 +194,56 @@ use_ok( $FileClass );
                                 "       Expected error reported" );
 }
 
+### bug #78030
+### tests for symlinks with relative paths
+### seen on MSWin32
+{   ok( 1,                      "Testing bug 78030" );
+               my $archname = 'tmp-symlink.tar.gz';
+               {       #build archive
+                       unlink $archname if -e $archname;
+                       local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
+                       my $t=Archive::Tar->new;
+                       my $f = $t->add_data( 'tmp/a/b/link.txt', '',
+                               {
+                                       linkname => '../c/ori.txt',
+                                       type     => 2,
+                               } );
+                       #why doesn't it keep my wish?
+                       $f->{name}   = 'tmp/a/b/link.txt';
+                       $f->{prefix} = '';
+                       $t->add_data( 'tmp/a/c/ori.txt', 'test case' );
+                       $t->write( $archname, 1 );
+               }
+
+    { #use case 1 - in memory extraction
+                       my $t=Archive::Tar->new;
+                       $t->read( $archname );
+                       my $r = eval{ $t->extract };
+                       ok( $r && !$@,            "   In memory extraction/symlinks" );
+                       ok((stat 'tmp/a/b/link.txt')[7] == 9,
+                                                 "       Linked content" ) unless $r;
+                       clean_78030();
+               }
+
+               { #use case 2 - iter extraction
+                 #$DB::single = 2;
+                       my $next=Archive::Tar->iter( $archname, 1 );
+                       my $failed = 0;
+                       #use Data::Dumper;
+                       while(my $f = $next->() ){
+                       #  print "\$f = ", Dumper( $f ), $/;
+                               eval{ $f->extract } or $failed++;
+                       }
+                       ok( !$failed,             "   From disk extraction/symlinks" );
+                       ok((stat 'tmp/a/b/link.txt')[7] == 9,
+                                                 "       Linked content" ) unless $failed;
+               }
+
+    #remove tmp files
+               sub clean_78030{
+                       unlink for ('tmp/a/c/ori.txt', 'tmp/a/b/link.txt');
+                       rmdir for ('tmp/a/c', 'tmp/a/b', 'tmp/a', 'tmp');
+               }
+               clean_78030();
+               unlink $archname;
+}