Update Archive-Tar to CPAN version 1.96

  [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

4 files changed, 190 insertions, 12 deletions

diff --git a/cpan/Archive-Tar/lib/Archive/Tar.pm b/cpan/Archive-Tar/lib/Archive/Tar.pm
index bd22d2a41b..50afbb334b 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar.pm
+++ b/cpan/Archive-Tar/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.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
diff --git a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
index 2bddf71f5f..957ac278ad 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
+++ b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
@@ -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;
diff --git a/cpan/Archive-Tar/lib/Archive/Tar/File.pm b/cpan/Archive-Tar/lib/Archive/Tar/File.pm
index 3f13bc8189..39fca623fa 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar/File.pm
+++ b/cpan/Archive-Tar/lib/Archive/Tar/File.pm
@@ -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 ###
 
diff --git a/cpan/Archive-Tar/t/04_resolved_issues.t b/cpan/Archive-Tar/t/04_resolved_issues.t
index 45b7a91557..4572b872be 100644
--- a/cpan/Archive-Tar/t/04_resolved_issues.t
+++ b/cpan/Archive-Tar/t/04_resolved_issues.t
@@ -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;
+}