From: Rafael Garcia-Suarez Date: Mon, 22 Aug 2005 10:09:40 +0000 (+0000) Subject: Upgrade to Archive::Tar 1.26 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=81a5970e912566b5c9c8facefe529df99b642c39;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Archive::Tar 1.26 Preserve some local typo fixes Don't load Data::Dumper p4raw-id: //depot/perl@25312 --- diff --git a/MANIFEST b/MANIFEST index 7f46fb9..8cfade5 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1186,10 +1186,12 @@ lib/assert.pl assertion and panic with stack trace lib/Archive/Tar/Constant.pm Archive::Tar lib/Archive/Tar/File.pm Archive::Tar lib/Archive/Tar/bin/ptar the ptar utility +lib/Archive/Tar/bin/ptardiff the ptardiff utility lib/Archive/Tar/t/00_setup.t Archive::Tar test setup lib/Archive/Tar/t/01_use.t Archive::Tar tests lib/Archive/Tar/t/02_methods.t Archive::Tar tests lib/Archive/Tar/t/03_file.t Archive::Tar tests +lib/Archive/Tar/t/04_resolved issues.t Archive::Tar tests lib/Archive/Tar/t/99_clean.t Archive::Tar test cleanup lib/Archive/Tar/t/src/long/b Archive::Tar tests lib/Archive/Tar/t/src/short/b Archive::Tar tests diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm index 9064f2b..28338df 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.24_02"; +$VERSION = "1.26_01"; $CHOWN = 1; $CHMOD = 1; $DO_NOT_USE_PREFIX = 0; @@ -110,7 +110,10 @@ sub new { my $obj = bless { _data => [ ], _file => 'Unknown' }, $class; if (@_) { - return unless $obj->read( @_ ); + unless ( $obj->read( @_ ) ) { + $obj->_error(qq[No data could be read from file]); + return; + } } return $obj; @@ -259,10 +262,19 @@ sub _read_tar { ### source code (tar.c) to GNU cpio. next if $chunk eq TAR_END; + ### 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 my $entry; - unless( $entry = Archive::Tar::File->new( chunk => $chunk ) ) { - $self->_error( qq[Couldn't read chunk at offset $offset] ); - next; + { my %extra_args = (); + $extra_args{'name'} = $$real_name if defined $real_name; + + unless( $entry = Archive::Tar::File->new( chunk => $chunk, + %extra_args ) + ) { + $self->_error( qq[Couldn't read chunk at offset $offset] ); + next; + } } ### ignore labels: @@ -497,7 +509,14 @@ sub _extract_file { } else { my @dirs = File::Spec::Unix->splitdir( $dirs ); my @cwd = File::Spec->splitdir( $cwd ); - $dir = File::Spec->catdir(@cwd, @dirs); + $dir = File::Spec->catdir( @cwd, @dirs ); + + # catdir() returns undef if the path is longer than 255 chars on VMS + unless ( defined $dir ) { + $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] ); + return; + } + } if( -e $dir && !-d _ ) { @@ -1439,6 +1458,46 @@ 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 access .tar.Z files? + +The C module can optionally use C (via +the C module) to access tar files that have been compressed +with C. Unfortunately tar files compressed with the Unix C +utility cannot be read by C and so cannot be directly +accesses by C. + +If the C or C programs are available, you can use +one of these workarounds to read C<.tar.Z> files from C + +Firstly with C + + use Archive::Tar; + + open F, "uncompress -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +and this with C + + use Archive::Tar; + + open F, "gunzip -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +Similarly, if the C program is available, you can use this to +write a C<.tar.Z> file + + use Archive::Tar; + use IO::File; + + my $fh = new IO::File "| compress -c >$filename"; + my $tar = Archive::Tar->new(); + ... + $tar->write($fh); + $fh->close ; + + =back =head1 TODO diff --git a/lib/Archive/Tar/Constant.pm b/lib/Archive/Tar/Constant.pm index f7f0f6d..3112d59 100644 --- a/lib/Archive/Tar/Constant.pm +++ b/lib/Archive/Tar/Constant.pm @@ -62,7 +62,12 @@ use constant MAGIC => "ustar"; use constant TAR_VERSION => "00"; use constant LONGLINK_NAME => '././@LongLink'; -use constant ZLIB => do { eval { require IO::Zlib }; $@ ? 0 : 1 }; + ### allow ZLIB to be turned off using ENV + ### DEBUG only +use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and + eval { require IO::Zlib }; + $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1 }; + use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/; use constant CAN_CHOWN => do { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") }; diff --git a/lib/Archive/Tar/File.pm b/lib/Archive/Tar/File.pm index a310ee9..42b0860 100644 --- a/lib/Archive/Tar/File.pm +++ b/lib/Archive/Tar/File.pm @@ -2,9 +2,10 @@ package Archive::Tar::File; use strict; use IO::File; -use File::Spec::Unix (); -use File::Spec (); -use File::Basename (); +use File::Spec::Unix (); +use File::Spec (); +use File::Basename (); + use Archive::Tar::Constant; use vars qw[@ISA $VERSION]; @@ -200,6 +201,12 @@ sub clone { sub _new_from_chunk { my $class = shift; my $chunk = shift or return; + my %hash = @_; + + ### filter any arguments on defined-ness of values. + ### this allows overriding from what the tar-header is saying + ### about this tar-entry. Particularly useful for @LongLink files + my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash; ### makes it start at 0 actually... :) ### my $i = -1; @@ -207,7 +214,7 @@ sub _new_from_chunk { $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); - my $obj = bless \%entry, $class; + my $obj = bless { %entry, %args }, $class; ### magic is a filetype string.. it should have something like 'ustar' or ### something similar... if the chunk is garbage, skip it diff --git a/lib/Archive/Tar/bin/ptar b/lib/Archive/Tar/bin/ptar index 8947257..014d2f7 100644 --- a/lib/Archive/Tar/bin/ptar +++ b/lib/Archive/Tar/bin/ptar @@ -28,34 +28,34 @@ if( $opts->{c} ) { my @files; find( sub { push @files, $File::Find::name; print $File::Find::name.$/ if $verbose }, @ARGV ); - - Archive::Tar->create_archive( $file, $compress, @files ); + + Archive::Tar->create_archive( $file, $compress, @files ); exit; -} +} my $tar = Archive::Tar->new($file, $compress); if( $opts->{t} ) { - print map { $_->full_path . $/ } $tar->get_files; + print map { $_->full_path . $/ } $tar->get_files; -} elsif( $opts->{x} ) { +} elsif( $opts->{x} ) { print map { $_->full_path . $/ } $tar->get_files if $verbose; Archive::Tar->extract_archive($file, $compress); -} +} sub usage { qq[ -Usage: ptar -c [-v] [-z] [-f ARCHIVE_FILE] FILE FILE ... - ptar -x [-v] [-z] [-f ARCHIVE_FILE] - ptar -t [-z] [-f ARCHIVE_FILE] +Usage: ptar -c [-v] [-z] [-f ARCHIVE_FILE] FILE FILE ... + ptar -x [-v] [-z] [-f ARCHIVE_FILE] + ptar -t [-z] [-f ARCHIVE_FILE] ptar -h - + ptar is a small, tar look-alike program that uses the perl module - Archive::Tar to extract, create and list tar archives. - + Archive::Tar to extract, create and list tar archives. + Options: x Extract from ARCHIVE_FILE c Create ARCHIVE_FILE from FILE @@ -72,34 +72,3 @@ See Also: \n] } -=head1 NAME - -ptar - a tar-like program written in perl - -=head1 DESCRIPTION - -ptar is a small, tar look-alike program that uses the perl module -Archive::Tar to extract, create and list tar archives. - -=head1 SYNOPSIS - - ptar -c [-v] [-z] [-f ARCHIVE_FILE] FILE FILE ... - ptar -x [-v] [-z] [-f ARCHIVE_FILE] - ptar -t [-z] [-f ARCHIVE_FILE] - ptar -h - -=head1 OPTIONS - - x Extract from ARCHIVE_FILE - c Create ARCHIVE_FILE from FILE - t List the contents of ARCHIVE_FILE - f Name of the ARCHIVE_FILE to use. Default is './default.tar' - z Read/Write zlib compressed ARCHIVE_FILE (not always available) - v Print filenames as they are added or extraced from ARCHIVE_FILE - h Prints this help message - -=head1 SEE ALSO - -tar(1), L. - -=cut diff --git a/lib/Archive/Tar/bin/ptardiff b/lib/Archive/Tar/bin/ptardiff new file mode 100644 index 0000000..19c9b90 --- /dev/null +++ b/lib/Archive/Tar/bin/ptardiff @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use Archive::Tar; +use Getopt::Std; + +my $opts = {}; +getopts('h:', $opts) or die usage(); + +die usages() if $opts->{h}; + +### need Text::Diff -- give a polite error (not a standard prereq) +unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) { + die "\n\t This tool requires the 'Text::Diff' module to be installed\n"; +} + +my $arch = shift or die usage(); +my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!"; + + +foreach my $file ( $tar->get_files ) { + next unless $file->is_file; + my $name = $file->name; + + diff( \($file->get_content), $name, + { FILENAME_A => $name, + MTIME_A => $file->mtime, + OUTPUT => \*STDOUT + } + ); +} + + + + +sub usage { + return q[ + +Usage: ptardiff ARCHIVE_FILE + ptardiff -h + + ptardiff is a small program that diffs an extracted archive + against an unextracted one, using the perl module Archive::Tar. + + This effectively lets you view changes made to an archives contents. + + Provide the progam with an ARCHIVE_FILE and it will look up all + the files with in the archive, scan the current working directory + for a file with the name and diff it against the contents of the + archive. + + +Options: + h Prints this help message + + +Sample Usage: + + $ tar -xzf Acme-Buffy-1.3.tar.gz + $ vi Acme-Buffy-1.3/README + + [...] + + $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch + + +See Also: + tar(1) + ptar + Archive::Tar + + ] . $/; +} diff --git a/lib/Archive/Tar/t/02_methods.t b/lib/Archive/Tar/t/02_methods.t index 3721025..9f9d667 100644 --- a/lib/Archive/Tar/t/02_methods.t +++ b/lib/Archive/Tar/t/02_methods.t @@ -60,7 +60,7 @@ my @EXPECTX = ( my $LONG_FILE = qq[directory/really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-long-directory-name/myfile]; ### wintendo can't deal with too long paths, so we might have to skip tests ### -my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin') +my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS') && length( cwd(). $LONG_FILE ) > 247; ### warn if we are going to skip long file names @@ -85,12 +85,11 @@ my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' ); my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' ); my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' ); -copy( File::Basename::basename($0), 'copy' ); -my $COMPRESS_FILE = 'copy'; +my $COMPRESS_FILE = 'copy'; +$^O eq 'VMS' and $COMPRESS_FILE .= '.'; +copy( File::Basename::basename($0), $COMPRESS_FILE ); chmod 0644, $COMPRESS_FILE; -END { unlink $COMPRESS_FILE; } - ### done setting up environment ### @@ -221,7 +220,7 @@ END { unlink $COMPRESS_FILE; } is( scalar @files, scalar @add, "Adding files"); is( $files[0]->name, 'b', " Proper name" ); - is( $files[0]->is_file, !-l $add[0] && -f _, " Proper type" ); + is( $files[0]->is_file, 1, " Proper type" ); like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/, " Content OK" ); @@ -559,6 +558,7 @@ END { my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE ); rmtree $dir if $dir && -d $dir && not $NO_UNLINK; + 1 while unlink $COMPRESS_FILE; } ########################### @@ -581,7 +581,11 @@ sub is_dir { sub rm { my $x = shift; - is_dir($x) ? rmtree($x) : unlink $x; + if ( is_dir($x) ) { + rmtree($x); + } else { + 1 while unlink $x; + } } sub check_tar_file { @@ -680,8 +684,7 @@ sub check_tar_extract { like( $content, qr/$econtent/, " Contents OK" ); - close $fh; - unlink $path unless $NO_UNLINK; + $NO_UNLINK or 1 while unlink $path; ### alternate extract path tests ### to abs and rel paths @@ -690,8 +693,8 @@ sub check_tar_extract { File::Spec->catdir( @ROOT ) ) ) { - - my $outfile = File::Spec->catfile( $outpath, $$ ); + + my $outfile = File::Spec->catfile( $outpath, $$ ); ok( $tar->extract_file( $file->full_path, $outfile ), " Extracted file '$path' to $outfile" ); diff --git a/lib/Archive/Tar/t/04_resolved_issues.t b/lib/Archive/Tar/t/04_resolved_issues.t new file mode 100644 index 0000000..865cf04 --- /dev/null +++ b/lib/Archive/Tar/t/04_resolved_issues.t @@ -0,0 +1,59 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar'; + } + use lib '../../..'; +} + +BEGIN { chdir 't' if -d 't' } + +use Test::More 'no_plan'; +use strict; +use lib '../lib'; + +my $NO_UNLINK = @ARGV ? 1 : 0; + +my $Class = 'Archive::Tar'; + +use_ok( $Class ); + +### bug #13636 +### tests for @longlink behaviour on files that have a / at the end +### of their shortened path, making them appear to be directories +{ ### dont use the prefix, otherwise A::T will not use @longlink + ### encoding style + local $Archive::Tar::DO_NOT_USE_PREFIX = 1; + local $Archive::Tar::DO_NOT_USE_PREFIX = 1; + + my $dir = 'Catalyst-Helper-Controller-Scaffold-HTML-Template-0.03/' . + 'lib/Catalyst/Helper/Controller/Scaffold/HTML/'; + my $file = 'Template.pm'; + my $out = $$ . '.tar'; + + ### first create the file + { my $tar = $Class->new; + + isa_ok( $tar, $Class ); + ok( $tar->add_data( $dir.$file => $$ ), + " Added long file" ); + + ok( $tar->write($out), " File written to $out" ); + } + + ### then read it back in + { my $tar = $Class->new; + isa_ok( $tar, $Class ); + ok( $tar->read( $out ), " Read in $out again" ); + + my @files = $tar->get_files; + is( scalar(@files), 1, " Only 1 entry found" ); + + my $entry = shift @files; + ok( $entry->is_file, " Entry is a file" ); + is( $entry->name, $dir.$file, + " With the proper name" ); + } + + ### remove the file + unless( $NO_UNLINK ) { 1 while unlink $out } +}