From: Craig A. Berry <craigberry@mac.com>
Date: Mon, 3 Sep 2007 19:36:39 +0000 (+0000)
Subject: Portability tweaks for Archive::Tar::_extract_file.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=48e76d2db35bb77675a7512e24a8932a1e79d838;p=p5sagit%2Fp5-mst-13.2.git

Portability tweaks for Archive::Tar::_extract_file.

p4raw-id: //depot/perl@31788
---

diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm
index 34792e9..21d71bd 100644
--- a/lib/Archive/Tar.pm
+++ b/lib/Archive/Tar.pm
@@ -14,7 +14,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
 $DEBUG              = 0;
 $WARN               = 1;
 $FOLLOW_SYMLINK     = 0;
-$VERSION            = "1.34";
+$VERSION            = "1.34_01";
 $CHOWN              = 1;
 $CHMOD              = 1;
 $DO_NOT_USE_PREFIX  = 0;
@@ -496,7 +496,7 @@ sub extract {
 =head2 $tar->extract_file( $file, [$extract_path] )
 
 Write an entry, whose name is equivalent to the file name provided to
-disk. Optionally takes a second parameter, which is the full (unix)
+disk. Optionally takes a second parameter, which is the full native
 path (including filename) the entry will be written to.
 
 For example:
@@ -547,9 +547,18 @@ sub _extract_file {
     ### it's a relative path ###
     } else {
         my $cwd     = (defined $self->{cwd} ? $self->{cwd} : cwd());
-        my @dirs    = File::Spec::Unix->splitdir( $dirs );
-        my @cwd     = File::Spec->splitdir( $cwd );
-        $dir        = File::Spec->catdir( @cwd, @dirs );
+        my @dirs;
+        if ( defined $alt ) { # It's a local-OS path
+            @dirs   = File::Spec->splitdir( $dirs );
+        } else {              # it's UNIX-style, likely straight from the tarball
+            @dirs   = File::Spec::Unix->splitdir( $dirs );
+        }
+        map tr/\./_/, @dirs if $^O eq 'VMS'; # '.' is the directory delimiter
+        my ($cwd_vol,$cwd_dir,$cwd_file) 
+                    = File::Spec->splitpath( $cwd );
+        my @cwd     = File::Spec->splitdir( $cwd_dir );
+        push @cwd, $cwd_file if length $cwd_file;
+        $dir        = File::Spec->catpath( $cwd_vol, File::Spec->catdir( @cwd, @dirs ) );
 
         # catdir() returns undef if the path is longer than 255 chars on VMS
         unless ( defined $dir ) {