$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.62";
+$VERSION = "1.64";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
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
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 ###
$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 ) {
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
: 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;
}
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");
}
}
projects / platform / upstream / perl.git / commitdiff