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.36";
-$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;
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 = 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.
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
BEGIN { chdir 't' if -d 't' }
-use Test::More 'no_plan';
+use Test::More 'no_plan';
+use File::Basename 'basename';
use strict;
use lib '../lib';
my $NO_UNLINK = @ARGV ? 1 : 0;
my $Class = 'Archive::Tar';
+my $FileClass = $Class . '::File';
use_ok( $Class );
+use_ok( $FileClass );
### bug #13636
### tests for @longlink behaviour on files that have a / at the end
### of their shortened path, making them appear to be directories
-{ ### dont use the prefix, otherwise A::T will not use @longlink
+{ ok( 1, "Testing bug 13636" );
+
+ ### dont use the prefix, otherwise A::T will not use @longlink
### encoding style
local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
### first create the file
{ my $tar = $Class->new;
- isa_ok( $tar, $Class );
+ isa_ok( $tar, $Class, " Object" );
ok( $tar->add_data( $dir.$file => $$ ),
- " Added long file" );
+ " Added long file" );
- ok( $tar->write($out), " File written to $out" );
+ ok( $tar->write($out), " File written to $out" );
}
### then read it back in
{ my $tar = $Class->new;
- isa_ok( $tar, $Class );
- ok( $tar->read( $out ), " Read in $out again" );
+ isa_ok( $tar, $Class, " Object" );
+ ok( $tar->read( $out ), " Read in $out again" );
my @files = $tar->get_files;
- is( scalar(@files), 1, " Only 1 entry found" );
+ is( scalar(@files), 1, " Only 1 entry found" );
my $entry = shift @files;
- ok( $entry->is_file, " Entry is a file" );
+ ok( $entry->is_file, " Entry is a file" );
is( $entry->name, $dir.$file,
- " With the proper name" );
+ " With the proper name" );
}
### remove the file
### There's a bug in Archive::Tar that causes a file like: foo/foo.txt
### to be stored in the tar file as: foo/.txt
### XXX could not be reproduced in 1.26 -- leave test to be sure
-{ my $dir = $$ . '/';
+{ ok( 1, "Testing bug 14922" );
+
+ my $dir = $$ . '/';
my $file = $$ . '.txt';
my $out = $$ . '.tar';
### first create the file
{ my $tar = $Class->new;
- isa_ok( $tar, $Class );
+ isa_ok( $tar, $Class, " Object" );
ok( $tar->add_data( $dir.$file => $$ ),
- " Added long file" );
+ " Added long file" );
- ok( $tar->write($out), " File written to $out" );
+ ok( $tar->write($out), " File written to $out" );
}
### then read it back in
{ my $tar = $Class->new;
- isa_ok( $tar, $Class );
- ok( $tar->read( $out ), " Read in $out again" );
+ isa_ok( $tar, $Class, " Object" );
+ ok( $tar->read( $out ), " Read in $out again" );
my @files = $tar->get_files;
- is( scalar(@files), 1, " Only 1 entry found" );
+ is( scalar(@files), 1, " Only 1 entry found" );
my $entry = shift @files;
- ok( $entry->is_file, " Entry is a file" );
+ ok( $entry->is_file, " Entry is a file" );
is( $entry->full_path, $dir.$file,
- " With the proper name" );
+ " With the proper name" );
}
### remove the file
unless( $NO_UNLINK ) { 1 while unlink $out }
}
+### bug #30380: directory traversal vulnerability in Archive-Tar
+### Archive::Tar allowed files to be extracted to a dir outside
+### it's cwd(), effectively allowing you to overwrite any files
+### on the system, given the right permissions.
+{ ok( 1, "Testing bug 30880" );
+
+ my $tar = $Class->new;
+ isa_ok( $tar, $Class, " Object" );
+
+ ### absolute paths are already taken care of. Only relative paths
+ ### matter
+ my $in_file = basename($0);
+ my $out_file = '../' . $in_file . ".$$";
+
+ ok( $tar->add_files( $in_file ),
+ " Added '$in_file'" );
+ ok( $tar->rename( $in_file, $out_file ),
+ " Renamed to '$out_file'" );
+
+ ### first, test with strict extract permissions on
+ { local $Archive::Tar::INSECURE_EXTRACT_MODE = 0;
+
+ ### we quell the error on STDERR
+ local $Archive::Tar::WARN = 0;
+ local $Archive::Tar::WARN = 0;
+
+ ok( 1, " Extracting in secure mode" );
+
+ ok( ! $tar->extract_file( $out_file ),
+ " File not extracted" );
+ ok( ! -e $out_file, " File '$out_file' does not exist" );
+
+ ok( $tar->error, " Error message stored" );
+ like( $tar->error, qr/attempting to leave/,
+ " Proper violation detected" );
+ }
+ ### now disable those
+ { local $Archive::Tar::INSECURE_EXTRACT_MODE = 1;
+ ok( 1, " Extracting in insecure mode" );
+ ok( $tar->extract_file( $out_file ),
+ " File extracted" );
+ ok( -e $out_file, " File '$out_file' exists" );
+
+ ### and clean up
+ unless( $NO_UNLINK ) { 1 while unlink $out_file };
+ }
+
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff