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";
-$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;
=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:
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 = File::Spec::Unix->splitdir( $dirs );
- my @cwd = File::Spec->splitdir( $cwd );
- $dir = File::Spec->catdir( @cwd, @dirs );
- # catdir() returns undef if the path is longer than 255 chars on VMS
+ 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;
+
+ ### 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;
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