From: Rafael Garcia-Suarez Date: Thu, 15 Nov 2007 08:31:48 +0000 (+0000) Subject: Upgrade to Archive::Tar 1.37_01 (security fix) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=178aef9aa1f4253b99f9aad2f0a0533dcb0c3f73;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Archive::Tar 1.37_01 (security fix) p4raw-id: //depot/perl@32326 --- diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm index 2b57b59..9881c96 100644 --- 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.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; @@ -542,18 +545,42 @@ 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 = 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. @@ -1555,6 +1582,23 @@ use is very much discouraged. Use the C method instead: warn $tar->error unless $tar->extract; +=head2 $Archive::Tar::INSECURE_EXTRACT_MODE + +This variable indicates whether C 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. + +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 diff --git a/lib/Archive/Tar/bin/ptar b/lib/Archive/Tar/bin/ptar index 8947257..9b2901b 100644 --- a/lib/Archive/Tar/bin/ptar +++ b/lib/Archive/Tar/bin/ptar @@ -6,13 +6,16 @@ use Archive::Tar; use File::Find; my $opts = {}; -getopts('dcvzthxf:', $opts) or die usage(); +getopts('dcvzthxf:I', $opts) or die usage(); ### show the help message ### die usage() if $opts->{h}; ### enable debugging (undocumented feature) -local $Archive::Tar::DEBUG = 1 if $opts->{d}; +local $Archive::Tar::DEBUG = 1 if $opts->{d}; + +### enable insecure extracting. +local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I}; ### sanity checks ### unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) { @@ -24,6 +27,7 @@ my $verbose = $opts->{v} ? 1 : 0; my $file = $opts->{f} ? $opts->{f} : 'default.tar'; my $tar = Archive::Tar->new(); + if( $opts->{c} ) { my @files; find( sub { push @files, $File::Find::name; @@ -64,6 +68,8 @@ Options: z Read/Write zlib compressed ARCHIVE_FILE (not always available) v Print filenames as they are added or extraced from ARCHIVE_FILE h Prints this help message + I Enable 'Insecure Extract Mode', which allows archives to extract + files outside the current working directory. (Not advised). See Also: tar(1) diff --git a/lib/Archive/Tar/t/04_resolved_issues.t b/lib/Archive/Tar/t/04_resolved_issues.t index e733cc6..ecaa150 100644 --- a/lib/Archive/Tar/t/04_resolved_issues.t +++ b/lib/Archive/Tar/t/04_resolved_issues.t @@ -7,20 +7,25 @@ BEGIN { 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; @@ -33,25 +38,25 @@ use_ok( $Class ); ### 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 @@ -62,38 +67,88 @@ use_ok( $Class ); ### 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 }; + } + +}