From afabe0e85c5f27746418b976894e482ba3652ee8 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Tue, 13 Jul 2010 12:02:16 +0100 Subject: [PATCH] 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." --- Porting/Maintainers.pl | 2 +- cpan/Archive-Tar/lib/Archive/Tar.pm | 93 +++++++++++++++++++++------- cpan/Archive-Tar/lib/Archive/Tar/Constant.pm | 2 +- cpan/Archive-Tar/lib/Archive/Tar/File.pm | 2 +- cpan/Archive-Tar/t/05_iter.t | 57 +++++++++-------- 5 files changed, 106 insertions(+), 50 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 240b6c8..a1e4458 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -192,7 +192,7 @@ use File::Glob qw(:case); 'Archive::Tar' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.62.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.64.tar.gz', 'FILES' => q[cpan/Archive-Tar], 'UPSTREAM' => 'cpan', 'BUGS' => 'bug-archive-tar@rt.cpan.org', diff --git a/cpan/Archive-Tar/lib/Archive/Tar.pm b/cpan/Archive-Tar/lib/Archive/Tar.pm index b5ad00b..021d311 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 57ec567..cf9a972 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 251a5c6..6056292 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 2a05c58..8d3486c 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"); } } -- 2.7.4