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
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.24_02";
+$VERSION = "1.26_01";
$CHOWN = 1;
$CHMOD = 1;
$DO_NOT_USE_PREFIX = 0;
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;
### 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:
} 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 _ ) {
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 access .tar.Z files?
+
+The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
+the C<IO::Zlib> module) to access tar files that have been compressed
+with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
+utility cannot be read by C<Compress::Zlib> and so cannot be directly
+accesses by C<Archive::Tar>.
+
+If the C<uncompress> or C<gunzip> programs are available, you can use
+one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
+
+Firstly with C<uncompress>
+
+ use Archive::Tar;
+
+ open F, "uncompress -c $filename |";
+ my $tar = Archive::Tar->new(*F);
+ ...
+
+and this with C<gunzip>
+
+ use Archive::Tar;
+
+ open F, "gunzip -c $filename |";
+ my $tar = Archive::Tar->new(*F);
+ ...
+
+Similarly, if the C<compress> 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
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") };
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];
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;
$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
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
\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<Archive::Tar>.
-
-=cut
--- /dev/null
+#!/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
+
+ ] . $/;
+}
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
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 ###
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" );
my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE );
rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
+ 1 while unlink $COMPRESS_FILE;
}
###########################
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 {
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
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" );
--- /dev/null
+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 }
+}
projects / platform / upstream / perl.git / commitdiff