Update Archive-Tar to CPAN version 1.64

  [DELTA]

  * important changes in version 1.64 09/07/2010
  - Removed the PERL_CORE specific chdir from all the tests
  - Apply a patch from David Muir Sharnoff RT #58916,
    "skip files via a callback and limit memory use when skipping files"
  - Apply a patch from Daphne Pfister RT #59150
    "Assumes all references filename are IO::Handle's instead of trying to stringify."

4 files changed, 105 insertions, 49 deletions

diff --git a/cpan/Archive-Tar/lib/Archive/Tar.pm b/cpan/Archive-Tar/lib/Archive/Tar.pm
index b5ad00b8f2..021d311b9c 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar.pm
+++ b/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                = "1.62";
+$VERSION                = "1.64";
 $CHOWN                  = 1;
 $CHMOD                  = 1;
 $SAME_PERMISSIONS       = $> == 0 ? 1 : 0;
@@ -212,10 +212,15 @@ sub read {
 sub _get_handle {
     my $self     = shift;
     my $file     = shift;   return unless defined $file;
-                            return $file if ref $file;
     my $compress = shift || 0;
     my $mode     = shift || READ_ONLY->( ZLIB ); # default to read only
 
+    ### Check if file is a file handle or IO glob
+    if ( ref $file ) {
+	return $file if eval{ *$file{IO} };
+	return $file if eval{ $file->isa(q{IO::Handle}) };
+	$file = q{}.$file;
+    }
 
     ### get a FH opened to the right class, so we can use it transparently
     ### throughout the program
@@ -301,6 +306,7 @@ sub _read_tar {
 
     my $count   = $opts->{limit}    || 0;
     my $filter  = $opts->{filter};
+    my $filter_cb = $opts->{filter_cb};
     my $extract = $opts->{extract}  || 0;
 
     ### set a cap on the amount of files to extract ###
@@ -392,19 +398,56 @@ sub _read_tar {
 
             $data = $entry->get_content_by_ref;
 
-            ### just read everything into memory
-            ### can't do lazy loading since IO::Zlib doesn't support 'seek'
-            ### this is because Compress::Zlib doesn't support it =/
-            ### this reads in the whole data in one read() call.
-            if( $handle->read( $$data, $block ) < $block ) {
-                $self->_error( qq[Read error on tarfile (missing data) '].
+	    my $skip = 0;
+	    ### skip this entry if we're filtering
+	    if ($filter && $entry->name !~ $filter) {
+		$skip = 1;
+
+	    ### skip this entry if it's a pax header. This is a special file added
+	    ### by, among others, git-generated tarballs. It holds comments and is
+	    ### not meant for extracting. See #38932: pax_global_header extracted
+	    } elsif ( $entry->name eq PAX_HEADER ) {
+		$skip = 2;
+	    } elsif ($filter_cb && ! $filter_cb->($entry)) {
+		$skip = 3;
+	    }
+
+	    if ($skip) {
+		#
+		# Since we're skipping, do not allocate memory for the
+		# whole file.  Read it 64 BLOCKS at a time.  Do not 
+		# complete the skip yet because maybe what we read is a
+		# longlink and it won't get skipped after all
+		#
+		my $amt = $block;
+		while ($amt > 0) {
+		    $$data = '';
+		    my $this = 64 * BLOCK;
+		    $this = $amt if $this > $amt;
+		    if( $handle->read( $$data, $this ) < $this ) {
+			$self->_error( qq[Read error on tarfile (missing data) '].
+					    $entry->full_path ."' at offset $offset" );
+			next LOOP;
+		    }
+		    $amt -= $this;
+		}
+		### throw away trailing garbage ###
+		substr ($$data, $entry->size) = "" if defined $$data && $block < 64 * BLOCK;
+            } else {
+
+		### just read everything into memory
+		### can't do lazy loading since IO::Zlib doesn't support 'seek'
+		### this is because Compress::Zlib doesn't support it =/
+		### this reads in the whole data in one read() call.
+		if ( $handle->read( $$data, $block ) < $block ) {
+		    $self->_error( qq[Read error on tarfile (missing data) '].
                                     $entry->full_path ."' at offset $offset" );
-                next LOOP;
+		    next LOOP;
+		}
+		### throw away trailing garbage ###
+		substr ($$data, $entry->size) = "" if defined $$data;
             }
 
-            ### throw away trailing garbage ###
-            substr ($$data, $entry->size) = "" if defined $$data;
-
             ### part II of the @LongLink munging -- need to do /after/
             ### the checksum check.
             if( $entry->is_longlink ) {
@@ -444,16 +487,17 @@ sub _read_tar {
             undef $real_name;
         }
 
-        ### skip this entry if we're filtering
-        if ($filter && $entry->name !~ $filter) {
-            next LOOP;
+	if ($filter && $entry->name !~ $filter) {
+	    next LOOP;
 
-        ### skip this entry if it's a pax header. This is a special file added
-        ### by, among others, git-generated tarballs. It holds comments and is
-        ### not meant for extracting. See #38932: pax_global_header extracted
-        } elsif ( $entry->name eq PAX_HEADER ) {
-            next LOOP;
-        }
+	### skip this entry if it's a pax header. This is a special file added
+	### by, among others, git-generated tarballs. It holds comments and is
+	### not meant for extracting. See #38932: pax_global_header extracted
+	} elsif ( $entry->name eq PAX_HEADER ) {
+	    next LOOP;
+	} elsif ($filter_cb && ! $filter_cb->($entry)) {
+	    next LOOP;
+	}
 
         if ( $extract && !$entry->is_longlink
                       && !$entry->is_unknown
@@ -1246,7 +1290,12 @@ sub write {
                         : do { seek $handle, 0, 0; local $/; <$handle> };
 
     ### make sure to close the handle if we created it
-    close $handle unless ref($file);
+    if ( $file ne $handle ) {
+	unless( close $handle ) {
+	    $self->_error( qq[Could not write tar] );
+	    return;
+	}
+    }
 
     return $rv;
 }
diff --git a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
index 57ec56715b..cf9a9727ac 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
+++ b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
@@ -3,7 +3,7 @@ package Archive::Tar::Constant;
 BEGIN {
     require Exporter;
     
-    $VERSION    = '1.62';
+    $VERSION    = '1.64';
     @ISA        = qw[Exporter];
 
     require Time::Local if $^O eq "MacOS";
diff --git a/cpan/Archive-Tar/lib/Archive/Tar/File.pm b/cpan/Archive-Tar/lib/Archive/Tar/File.pm
index 251a5c640d..605629284e 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar/File.pm
+++ b/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    = '1.62';
+$VERSION    = '1.64';
 
 ### set value to 1 to oct() it during the unpack ###
 my $tmpl = [
diff --git a/cpan/Archive-Tar/t/05_iter.t b/cpan/Archive-Tar/t/05_iter.t
index 2a05c58341..8d3486c5fd 100644
--- a/cpan/Archive-Tar/t/05_iter.t
+++ b/cpan/Archive-Tar/t/05_iter.t
@@ -23,36 +23,43 @@ for my $index ( \0, 0 .. $#Expect ) {
     my %opts    = ();
     my @expect  = ();
     
+    my $dotest = sub {
+	my $desc = shift;
+	my $next = $Class->iter( $File, 0, \%opts );
+	
+	my $pp_opts = join " => ", %opts;
+	ok( $next,                  "Iterator created from $File ($pp_opts $desc)" );
+	isa_ok( $next, "CODE",      "   Iterator $desc" );
+
+	my @names;
+	while( my $f = $next->() ) {
+	    ok( $f,                 "       File object retrieved $desc" );
+	    isa_ok( $f, $FClass,    "           Object $desc" );
+
+	    push @names, $f->name;
+	}
+	
+	is( scalar(@names), scalar(@expect),
+				    "   Found correct number of files $desc" );
+	
+	my $i = 0;
+	for my $name ( @names ) {
+	    ok( 1,                  "   Inspecting '$name'  $desc" );
+	    like($name, $expect[$i],"       Matches $Expect[$i] $desc" );
+	    $i++;
+	}        
+    };
+
     ### do a full test vs individual filters
     if( not ref $index ) {
         my $regex       = $Expect[$index];
-        $opts{'filter'} = $regex;
         @expect         = ($regex);
+	%opts		= ( filter => $regex );
+	$dotest->("filter $regex");
+	%opts		= ( filter_cb => sub { my ($entry) = @_; $entry->name() =~ /$regex/ } );
+	$dotest->("filter_cb $regex");
     } else {
         @expect         = @Expect;
-    }        
-
-    my $next = $Class->iter( $File, 0, \%opts );
-    
-    my $pp_opts = join " => ", %opts;
-    ok( $next,                  "Iterator created from $File ($pp_opts)" );
-    isa_ok( $next, "CODE",      "   Iterator" );
-
-    my @names;
-    while( my $f = $next->() ) {
-        ok( $f,                 "       File object retrieved" );
-        isa_ok( $f, $FClass,    "           Object" );
-
-        push @names, $f->name;
-    }
-    
-    is( scalar(@names), scalar(@expect),
-                                "   Found correct number of files" );
-    
-    my $i = 0;
-    for my $name ( @names ) {
-        ok( 1,                  "   Inspecting '$name' " );
-        like($name, $expect[$i],"       Matches $Expect[$i]" );
-        $i++;
+	$dotest->("all");
     }        
 }