diff options
Diffstat (limited to 'lib/Archive/Tar.pm')
| -rw-r--r-- | lib/Archive/Tar.pm | 90 |
1 files changed, 71 insertions, 19 deletions
diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm index 044d9e8003..536336abc3 100644 --- a/lib/Archive/Tar.pm +++ b/lib/Archive/Tar.pm @@ -14,7 +14,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD $DEBUG = 0; $WARN = 1; $FOLLOW_SYMLINK = 0; -$VERSION = "1.28"; +$VERSION = "1.29"; $CHOWN = 1; $CHMOD = 1; $DO_NOT_USE_PREFIX = 0; @@ -268,6 +268,18 @@ sub _read_tar { ### source code (tar.c) to GNU cpio. next if $chunk eq TAR_END; + ### according to the posix spec, the last 12 bytes of the header are + ### null bytes, to pad it to a 512 byte block. That means if these + ### bytes are NOT null bytes, it's a corrrupt header. See: + ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx + ### line 111 + { my $nulls = join '', "\0" x 12; + unless( $nulls eq substr( $chunk, 500, 12 ) ) { + $self->_error( qq[Invalid header block at offset $offset] ); + next LOOP; + } + } + ### pass the realname, so we can set it 'proper' right away ### some of the heuristics are done on the name, so important ### to set it ASAP @@ -279,7 +291,7 @@ sub _read_tar { %extra_args ) ) { $self->_error( qq[Couldn't read chunk at offset $offset] ); - next; + next LOOP; } } @@ -312,7 +324,7 @@ sub _read_tar { if( $handle->read( $$data, $block ) < $block ) { $self->_error( qq[Read error on tarfile (missing data) ']. $entry->full_path ."' at offset $offset" ); - next; + next LOOP; } ### throw away trailing garbage ### @@ -350,7 +362,7 @@ sub _read_tar { ### this is one ugly hack =/ but needed for direct extraction if( $entry->is_longlink ) { $real_name = $data; - next; + next LOOP; } elsif ( defined $real_name ) { $entry->name( $$real_name ); $entry->prefix(''); @@ -420,22 +432,34 @@ Returns a list of filenames extracted. sub extract { my $self = shift; + my @args = @_; my @files; ### you requested the extraction of only certian files - if( @_ ) { - for my $file (@_) { - my $found; - for my $entry ( @{$self->_data} ) { - next unless $file eq $entry->full_path; - - ### we found the file you're looking for - push @files, $entry; - $found++; - } + if( @args ) { + for my $file ( @args ) { + + ### it's already an object? + if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) { + push @files, $file; + next; - unless( $found ) { - return $self->_error( qq[Could not find '$file' in archive] ); + ### go find it then + } else { + + my $found; + for my $entry ( @{$self->_data} ) { + next unless $file eq $entry->full_path; + + ### we found the file you're looking for + push @files, $entry; + $found++; + } + + unless( $found ) { + return $self->_error( + qq[Could not find '$file' in archive] ); + } } } @@ -471,6 +495,8 @@ For example: $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' ); + $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' ); + Returns true on success, false on failure. =cut @@ -490,7 +516,6 @@ sub _extract_file { my $self = shift; my $entry = shift or return; my $alt = shift; - my $cwd = cwd(); ### you wanted an alternate extraction location ### my $name = defined $alt ? $alt : $entry->full_path; @@ -513,6 +538,7 @@ sub _extract_file { ### it's a relative path ### } else { + my $cwd = cwd(); my @dirs = File::Spec::Unix->splitdir( $dirs ); my @cwd = File::Spec->splitdir( $cwd ); $dir = File::Spec->catdir( @cwd, @dirs ); @@ -724,6 +750,9 @@ sub _find_entry { return; } + ### it's an object already + return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); + for my $entry ( @{$self->_data} ) { my $path = $entry->full_path; return $entry if $path eq $file; @@ -995,10 +1024,16 @@ sub write { ### write the end markers ### print $handle TAR_END x 2 or return $self->_error( qq[Could not write tar end markers] ); + ### did you want it written to a file, or returned as a string? ### - return length($file) ? 1 + my $rv = length($file) ? 1 : $HAS_PERLIO ? $dummy - : do { seek $handle, 0, 0; local $/; <$handle> } + : do { seek $handle, 0, 0; local $/; <$handle> }; + + ### make sure to close the handle; + close $handle; + + return $rv; } sub _format_tar_entry { @@ -1502,6 +1537,23 @@ have incompatible filetypes and still expect things to work). For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that the extraction of this particular item didn't work. +=item How do I extract only files that have property X from an archive? + +Sometimes, you might not wish to extract a complete archive, just +the files that are relevant to you, based on some criteria. + +You can do this by filtering a list of C<Archive::Tar::File> objects +based on your criteria. For example, to extract only files that have +the string C<foo> in their title, you would use: + + $tar->extract( + grep { $_->full_path =~ /foo/ } $tar->get_files + ); + +This way, you can filter on any attribute of the files in the archive. +Consult the C<Archive::Tar::File> documentation on how to use these +objects. + =item How do I access .tar.Z files? The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via |