summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xPorting/Maintainers.pl2
-rw-r--r--cpan/Archive-Tar/lib/Archive/Tar.pm93
-rw-r--r--cpan/Archive-Tar/lib/Archive/Tar/Constant.pm2
-rw-r--r--cpan/Archive-Tar/lib/Archive/Tar/File.pm2
-rw-r--r--cpan/Archive-Tar/t/05_iter.t57
5 files changed, 106 insertions, 50 deletions
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 240b6c8f2d..a1e445838b 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 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");
}
}
View Lorry Controller Status