Upgrade to ExtUtils::MakeMaker 6.40.

[p5sagit/p5-mst-13.2.git] / lib / Archive / Tar.pm

diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm
index 21d71bd..9881c96 100644 (file)
--- a/lib/Archive/Tar.pm
+++ b/lib/Archive/Tar.pm
@@ -9,15 +9,18 @@ require 5.005_03;
 
 use strict;
 use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
-            $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING];
-
-$DEBUG              = 0;
-$WARN               = 1;
-$FOLLOW_SYMLINK     = 0;
-$VERSION            = "1.34_01";
-$CHOWN              = 1;
-$CHMOD              = 1;
-$DO_NOT_USE_PREFIX  = 0;
+            $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING
+            $INSECURE_EXTRACT_MODE
+         ];
+
+$DEBUG                  = 0;
+$WARN                   = 1;
+$FOLLOW_SYMLINK         = 0;
+$VERSION                = "1.37_01";
+$CHOWN                  = 1;
+$CHMOD                  = 1;
+$DO_NOT_USE_PREFIX      = 0;
+$INSECURE_EXTRACT_MODE  = 0;
 
 BEGIN {
     use Config;
@@ -542,25 +545,68 @@ sub _extract_file {
     my $dir;
     ### is $name an absolute path? ###
     if( File::Spec->file_name_is_absolute( $dirs ) ) {
+
+        ### absolute names are not allowed to be in tarballs under
+        ### strict mode, so only allow it if a user tells us to do it
+        if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
+            $self->_error( 
+                q[Entry ']. $entry->full_path .q[' is an absolute path. ].
+                q[Not extracting absolute paths under SECURE EXTRACT MODE]
+            );  
+            return;
+        }
+        
+        ### user asked us to, it's fine.
         $dir = $dirs;
 
     ### it's a relative path ###
     } else {
         my $cwd     = (defined $self->{cwd} ? $self->{cwd} : cwd());
-        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 @dirs = defined $alt
+            ? File::Spec->splitdir( $dirs )         # It's a local-OS path
+            : File::Spec::Unix->splitdir( $dirs );  # it's UNIX-style, likely
+                                                    # straight from the tarball
+
+        ### paths that leave the current directory are not allowed under
+        ### strict mode, so only allow it if a user tells us to do this.
+        if( not defined $alt            and 
+            not $INSECURE_EXTRACT_MODE  and 
+            grep { $_ eq '..' } @dirs
+        ) {
+            $self->_error(
+                q[Entry ']. $entry->full_path .q[' is attempting to leave the ].
+                q[current working directory. Not extracting under SECURE ].
+                q[EXTRACT MODE]
+            );
+            return;
+        }            
+        
+        ### '.' is the directory delimiter, of which the first one has to
+        ### be escaped/changed.
+        map tr/\./_/, @dirs if ON_VMS;        
+
         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
+        ### We need to pass '' as the last elemant to catpath. Craig Berry
+        ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
+        ### The root problem is that splitpath on UNIX always returns the 
+        ### final path element as a file even if it is a directory, and of
+        ### course there is no way it can know the difference without checking
+        ### against the filesystem, which it is documented as not doing.  When
+        ### you turn around and call catpath, on VMS you have to know which bits
+        ### are directory bits and which bits are file bits.  In this case we
+        ### know the result should be a directory.  I had thought you could omit
+        ### the file argument to catpath in such a case, but apparently on UNIX
+        ### you can't.
+        $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 ) {
             $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
             return;
@@ -1536,6 +1582,23 @@ use is very much discouraged. Use the C<error()> method instead:
 
     warn $tar->error unless $tar->extract;
 
+=head2 $Archive::Tar::INSECURE_EXTRACT_MODE
+
+This variable indicates whether C<Archive::Tar> should allow
+files to be extracted outside their current working directory.
+
+Allowing this could have security implications, as a malicious
+tar archive could alter or replace any file the extracting user
+has permissions to. Therefor, the default is to not allow 
+insecure extractions. 
+
+If you trust the archive, or have other reasons to allow the 
+archive to write files outside your current working directory, 
+set this variable to C<true>.
+
+Note that this is a backwards incompatible change from version
+C<1.36> and before.
+
 =head2 $Archive::Tar::HAS_PERLIO
 
 This variable holds a boolean indicating if we currently have