From: Rafael Garcia-Suarez Date: Mon, 6 Mar 2006 14:52:48 +0000 (+0000) Subject: Upgrade to Archive::Tar 1.29 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b30bcf62f5b15c203de3cee9cf8d918ec38ad867;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Archive::Tar 1.29 p4raw-id: //depot/perl@27388 --- diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm index 044d9e8..536336a 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 and C 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 objects +based on your criteria. For example, to extract only files that have +the string C 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 documentation on how to use these +objects. + =item How do I access .tar.Z files? The C module can optionally use C (via diff --git a/lib/Archive/Tar/t/00_setup.t b/lib/Archive/Tar/t/00_setup.t index 7c63306..691e09f 100644 --- a/lib/Archive/Tar/t/00_setup.t +++ b/lib/Archive/Tar/t/00_setup.t @@ -1,15 +1,19 @@ -#!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"; @@ -22,12 +26,12 @@ sub output { 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 @@ -349,7 +353,7 @@ output( 'long/bar.tar', qw( 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 )); -output( 'long/foo.tgz', qw( +output( File::Spec->catfile( qw[src long foo.tgz] ), qw( 1f8b0800000000000003edd74b6e8330100660af730a2e4098c10fb63d009740 8949501c902851c4ed6bc8ab515abaf2b485f93616c9481e64fe91bc11e10102 18a5047899d1e30ae9e57984fe37ff074a4c4daac77a09220282dec4e9bd2bda @@ -362,7 +366,7 @@ e2fc871cdf5f29ae8ba30d38d7e680e0fc2ff3ff9af7e9f99f2a35dc05a54454 df0cf35f81411f7d1ce6bf7fe4fb3f85bd75aee1cb3f638c31c618638c31c6d8 6c7d00dd7a588000280000 )); -output( 'short/bar.tar', qw( +output( File::Spec->catfile( qw[src short bar.tar] ), qw( 6300000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -684,7 +688,7 @@ output( 'short/bar.tar', qw( 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 )); -output( 'short/foo.tgz', qw( +output( File::Spec->catfile( qw[src short foo.tgz] ), qw( 1f8b0800000000000003edd3410ac2301085e159f71439c24cdaa6e7296a4184 2eaabd7f87e84210ecaa23c2ff6d862403799b7792e3a9a996ae137543e9ebd4 fc3c57e677fe60ade592fbbadfaa240dc826ebfd312e29c96d9c2fdff67c6d9a diff --git a/lib/Archive/Tar/t/02_methods.t b/lib/Archive/Tar/t/02_methods.t index be73ed8..a5d7617 100644 --- a/lib/Archive/Tar/t/02_methods.t +++ b/lib/Archive/Tar/t/02_methods.t @@ -12,6 +12,7 @@ use strict; use lib '../lib'; use Cwd; +use Config; use IO::File; use File::Copy; use File::Path; @@ -165,6 +166,13 @@ chmod 0644, $COMPRESS_FILE; 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; @@ -221,11 +229,10 @@ chmod 0644, $COMPRESS_FILE; "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" ); } @@ -476,12 +483,18 @@ SKIP: { 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 @@ -693,7 +706,6 @@ sub check_tar_extract { like( $content, qr/$econtent/, " Contents OK" ); - close $fh; $NO_UNLINK or 1 while unlink $path; ### alternate extract path tests diff --git a/lib/Archive/Tar/t/99_clean.t b/lib/Archive/Tar/t/99_clean.t index 216cab2..5c6d2bf 100644 --- a/lib/Archive/Tar/t/99_clean.t +++ b/lib/Archive/Tar/t/99_clean.t @@ -1,19 +1,38 @@ #!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" ); +}