$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.28";
+$VERSION = "1.29";
$CHOWN = 1;
$CHMOD = 1;
$DO_NOT_USE_PREFIX = 0;
### 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
%extra_args )
) {
$self->_error( qq[Couldn't read chunk at offset $offset] );
- next;
+ next LOOP;
}
}
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 ###
### 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('');
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] );
+ }
}
}
$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
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;
### 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 );
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;
### 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 {
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
-#!perl
-use File::Spec ();
-
BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir '../lib/Archive/Tar/t' if -d '../lib/Archive/Tar/t';
- mkdir 'src' unless -d 'src';
- chdir 'src';
- }
+ if( $ENV{PERL_CORE} ) {
+ chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
+ }
+ use lib '../../..';
}
-for my $d (qw(short long)) {
+BEGIN { chdir 't' if -d 't' }
+
+use lib '../lib';
+use File::Spec ();
+
+
+mkdir 'src' unless -d 'src';
+
+for my $d ( map { File::Spec->catdir( 'src', $_ ) } qw(short long) ) {
-d $d or mkdir $d;
my $file = File::Spec->catfile($d,'b');
open F, '>', $file or die "Can't create $file: $!\n";
open F, '>', $file or die "Can't create $file: $!\n";
binmode F;
for (@_) {
- print F pack "H*", $_;
+ print F pack "H*", $_;
}
close F;
}
-output( 'long/bar.tar', qw(
+output( File::Spec->catfile( qw[src long bar.tar] ), qw(
6300000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
));
-output( 'long/foo.tgz', qw(
+output( File::Spec->catfile( qw[src long foo.tgz] ), qw(
1f8b0800000000000003edd74b6e8330100660af730a2e4098c10fb63d009740
8949501c902851c4ed6bc8ab515abaf2b485f93616c9481e64fe91bc11e10102
18a5047899d1e30ae9e57984fe37ff074a4c4daac77a09220282dec4e9bd2bda
df0cf35f81411f7d1ce6bf7fe4fb3f85bd75aee1cb3f638c31c618638c31c6d8
6c7d00dd7a588000280000
));
-output( 'short/bar.tar', qw(
+output( File::Spec->catfile( qw[src short bar.tar] ), qw(
6300000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
));
-output( 'short/foo.tgz', qw(
+output( File::Spec->catfile( qw[src short foo.tgz] ), qw(
1f8b0800000000000003edd3410ac2301085e159f71439c24cdaa6e7296a4184
2eaabd7f87e84210ecaa23c2ff6d862403799b7792e3a9a996ae137543e9ebd4
fc3c57e677fe60ade592fbbadfaa240dc826ebfd312e29c96d9c2fdff67c6d9a
use lib '../lib';
use Cwd;
+use Config;
use IO::File;
use File::Copy;
use File::Path;
ok( $file, "Got File object" );
isa_ok( $file, "Archive::Tar::File" );
+ ### whitebox test -- make sure find_entry gets the
+ ### right files
+ for my $test ( $file->full_path, $file ) {
+ is( $tar->_find_entry( $test ), $file,
+ " Found proper object" );
+ }
+
next unless $file->is_file;
my $name = $file->full_path;
"Adding files");
is( $files[0]->name, 'b', " Proper name" );
+ SKIP: {
+ skip( "You are building perl using symlinks", 1)
+ if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/);
- use Config;
- if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/) {
- ok( !$files[0]->is_file," Proper type" );
- } else {
is( $files[0]->is_file, 1,
" Proper type" );
}
is( $obj->name, $name, " Expected file found" );
+
### extract this single file to cwd()
for my $meth (qw[extract extract_file]) {
- ok( $tar->$meth( $obj->full_path ),
+
+ ### extract it by full path and object
+ for my $arg ( $obj, $obj->full_path ) {
+
+ ok( $tar->$meth( $arg ),
"Extracted '$name' to cwd() with $meth" );
- ok( -e $obj->full_path, " Extracted file exists" );
- rm( $obj->full_path ) unless $NO_UNLINK;
+ ok( -e $obj->full_path, " Extracted file exists" );
+ rm( $obj->full_path ) unless $NO_UNLINK;
+ }
}
### extract this file to @ROOT
like( $content, qr/$econtent/,
" Contents OK" );
- close $fh;
$NO_UNLINK or 1 while unlink $path;
### alternate extract path tests
#!perl
-use File::Spec;
-
BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir '../lib/Archive/Tar/t' if -d '../lib/Archive/Tar/t';
- }
+ if( $ENV{PERL_CORE} ) {
+ chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
+ }
+ use lib '../../..';
}
+BEGIN { chdir 't' if -d 't' }
+
+use lib '../lib';
+use File::Spec ();
+use Test::More 'no_plan';
+
for my $d (qw(long short)) {
for my $f (qw(b bar.tar foo.tgz)) {
- unlink File::Spec->catfile('src', $d, $f);
+
+ my $path = File::Spec->catfile('src', $d, $f);
+ ok( -e $path, "File $path exists" );
+
+ 1 while unlink $path;
+
+ ok(!-e $path, " File deleted" );
}
- rmdir File::Spec->catdir('src', $d);
-}
-rmdir 'src';
+ my $dir = File::Spec->catdir('src', $d);
-print "1..1\nok 1 - cleanup done\n";
+ ok( -d $dir, "Dir $dir exists" );
+ 1 while rmdir $dir;
+ ok(!-d $dir, " Dir deleted" );
+
+}
+
+{ my $dir = 'src';
+ ok( -d $dir, "Dir $dir exists" );
+ 1 while rmdir $dir;
+ ok(!-d $dir, " Dir deleted" );
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff