Update Archive-Tar to CPAN version 2.28

  [DELTA]

+- fix creating file with trailing whitespace on filename - fixes 103279
+- allow archiving with absolute pathnames - fixes 97748
+- small POD fix
+- Speed up extract when archive contains lots of files
+- CVE-2018-12015 directory traversal vulnerability [RT#125523]

cpan/Archive-Tar/lib/Archive/Tar.pm

@@ -31,7 +31,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
 $DEBUG                  = 0;
 $WARN                   = 1;
 $FOLLOW_SYMLINK         = 0;
-$VERSION                = "2.26";
+$VERSION                = "2.28";
 $CHOWN                  = 1;
 $CHMOD                  = 1;
 $SAME_PERMISSIONS       = $> == 0 ? 1 : 0;
@@ -601,6 +601,7 @@ sub extract {
     my $self    = shift;
     my @args    = @_;
     my @files;
+    my $hashmap;
 
     # use the speed optimization for all extracted files
     local($self->{cwd}) = cwd() unless $self->{cwd};
@@ -617,16 +618,15 @@ sub extract {
             ### go find it then
             } else {
 
-                my $found;
-                for my $entry ( @{$self->_data} ) {
-                    next unless $file eq $entry->full_path;
+                # create hash-map once to speed up lookup
+                $hashmap = $hashmap || {
+                    map { $_->full_path, $_ } @{$self->_data}
+                };
 
+                if (exists $hashmap->{$file}) {
                     ### we found the file you're looking for
-                    push @files, $entry;
-                    $found++;
-                }
-
-                unless( $found ) {
+                    push @files, $hashmap->{$file};
+                } else {
                     return $self->_error(
                         qq[Could not find '$file' in archive] );
                 }
@@ -845,9 +845,23 @@ sub _extract_file {
         return;
     }
 
+    ### If a file system already contains a block device with the same name as
+    ### the being extracted regular file, we would write the file's content
+    ### to the block device. So remove the existing file (block device) now.
+    ### If an archive contains multiple same-named entries, the last one
+    ### should replace the previous ones. So remove the old file now.
+    ### If the old entry is a symlink to a file outside of the CWD, the new
+    ### entry would create a file there. This is CVE-2018-12015
+    ### <https://rt.cpan.org/Ticket/Display.html?id=125523>.
+    if (-l $full || -e _) {
+	if (!unlink $full) {
+	    $self->_error( qq[Could not remove old file '$full': $!] );
+	    return;
+	}
+    }
     if( length $entry->type && $entry->is_file ) {
         my $fh = IO::File->new;
-        $fh->open( '>' . $full ) or (
+        $fh->open( $full, '>' ) or (
             $self->_error( qq[Could not open file '$full': $!] ),
             return
         );
@@ -2250,7 +2264,7 @@ For example, if you add a Unicode string like
     $tar->add_data('file.txt', "Euro: \x{20AC}");
 
 then there will be a problem later when the tarfile gets written out
-to disk via C<$tar->write()>:
+to disk via C<< $tar->write() >>:
 
     Wide character in print at .../Archive/Tar.pm line 1014.
 

cpan/Archive-Tar/lib/Archive/Tar/Constant.pm

@@ -3,7 +3,7 @@ package Archive::Tar::Constant;
 BEGIN {
     require Exporter;
 
-    $VERSION    = '2.26';
+    $VERSION    = '2.28';
     @ISA        = qw[Exporter];
 
     require Time::Local if $^O eq "MacOS";

cpan/Archive-Tar/lib/Archive/Tar/File.pm

@@ -13,7 +13,7 @@ use Archive::Tar::Constant;
 
 use vars qw[@ISA $VERSION];
 #@ISA        = qw[Archive::Tar];
-$VERSION    = '2.26';
+$VERSION    = '2.28';
 
 ### set value to 1 to oct() it during the unpack ###
 
@@ -396,22 +396,15 @@ sub _prefix_and_file {
     my $path = shift;
 
     my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
-    my @dirs = File::Spec->splitdir( $dirs );
-
-    ### so sometimes the last element is '' -- probably when trailing
-    ### dir slashes are encountered... this is of course pointless,
-    ### so remove it
-    pop @dirs while @dirs and not length $dirs[-1];
+    my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
 
     ### if it's a directory, then $file might be empty
     $file = pop @dirs if $self->is_dir and not length $file;
 
     ### splitting ../ gives you the relative path in native syntax
     map { $_ = '..' if $_  eq '-' } @dirs if ON_VMS;
 
-    my $prefix = File::Spec::Unix->catdir(
-                        grep { length } $vol, @dirs
-                    );
+    my $prefix = File::Spec::Unix->catdir(@dirs);
     return( $prefix, $file );
 }
 

cpan/Archive-Tar/t/04_resolved_issues.t

@@ -247,3 +247,31 @@ use_ok( $FileClass );
 		clean_78030();
 		unlink $archname;
 }
+
+### bug 97748
+### retain leading '/' for absolute pathnames.
+{   ok( 1,                      "Testing bug 97748" );
+	my $path= '/absolute/path';
+	my $tar = $Class->new;
+	isa_ok( $tar, $Class,       "   Object" );
+	my $file;
+
+	ok( $file = $tar->add_data( $path, '' ),
+		"       Added $path" );
+
+	ok( $file->full_path eq $path,
+		"	Paths mismatch <" . $file->full_path . "> ne <$path>" );
+}
+
+### bug 103279
+### retain trailing whitespace on filename
+{   ok( 1,                      "Testing bug 103279" );
+	my $tar = $Class->new;
+	isa_ok( $tar, $Class,       "   Object" );
+	ok( $tar->add_data( 'white_space   ', '' ),
+				    "   Add file <white_space   > containing filename with trailing whitespace");
+	ok( $tar->extract(),        "	Extract filename with trailing whitespace" );
+	ok( ! -e 'white_space',     "	<white_space> should not exist" );
+	ok( -e 'white_space   ',    "	<white_space   > should exist" );
+	unlink foreach ('white_space   ', 'white_space');
+}