1757 lines
59 KiB
Diff
1757 lines
59 KiB
Diff
diff -up perl-5.10.0/lib/Archive/Tar/bin/ptar.old perl-5.10.0/lib/Archive/Tar/bin/ptar
|
|
--- perl-5.10.0/lib/Archive/Tar/bin/ptar.old 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/bin/ptar 2008-08-25 05:43:01.000000000 +0200
|
|
@@ -1,12 +1,13 @@
|
|
#!/usr/bin/perl
|
|
use strict;
|
|
|
|
+use File::Find;
|
|
use Getopt::Std;
|
|
use Archive::Tar;
|
|
-use File::Find;
|
|
+use Data::Dumper;
|
|
|
|
my $opts = {};
|
|
-getopts('dcvzthxf:I', $opts) or die usage();
|
|
+getopts('Ddcvzthxf:I', $opts) or die usage();
|
|
|
|
### show the help message ###
|
|
die usage() if $opts->{h};
|
|
@@ -33,72 +34,63 @@ if( $opts->{c} ) {
|
|
find( sub { push @files, $File::Find::name;
|
|
print $File::Find::name.$/ if $verbose }, @ARGV );
|
|
|
|
- Archive::Tar->create_archive( $file, $compress, @files );
|
|
- exit;
|
|
-}
|
|
-
|
|
-my $tar = Archive::Tar->new($file, $compress);
|
|
+ if ($file eq '-') {
|
|
+ use IO::Handle;
|
|
+ $file = IO::Handle->new();
|
|
+ $file->fdopen(fileno(STDOUT),"w");
|
|
+ }
|
|
|
|
-if( $opts->{t} ) {
|
|
- print map { $_->full_path . $/ } $tar->get_files;
|
|
+ Archive::Tar->create_archive( $file, $compress, @files );
|
|
|
|
-} elsif( $opts->{x} ) {
|
|
- print map { $_->full_path . $/ } $tar->get_files
|
|
- if $verbose;
|
|
- Archive::Tar->extract_archive($file, $compress);
|
|
+} else {
|
|
+ if ($file eq '-') {
|
|
+ use IO::Handle;
|
|
+ $file = IO::Handle->new();
|
|
+ $file->fdopen(fileno(STDIN),"r");
|
|
+ }
|
|
+
|
|
+ ### print the files we're finding?
|
|
+ my $print = $verbose || $opts->{'t'} || 0;
|
|
+
|
|
+ my $iter = Archive::Tar->iter( $file );
|
|
+
|
|
+ while( my $f = $iter->() ) {
|
|
+ print $f->full_path . $/ if $print;
|
|
+
|
|
+ ### data dumper output
|
|
+ print Dumper( $f ) if $opts->{'D'};
|
|
+
|
|
+ ### extract it
|
|
+ $f->extract if $opts->{'x'};
|
|
+ }
|
|
}
|
|
|
|
-
|
|
-
|
|
+### pod & usage in one
|
|
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]
|
|
- ptar -h
|
|
-
|
|
- ptar is a small, tar look-alike program that uses the perl module
|
|
- Archive::Tar to extract, create and list tar archives.
|
|
-
|
|
-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
|
|
- I Enable 'Insecure Extract Mode', which allows archives to extract
|
|
- files outside the current working directory. (Not advised).
|
|
-
|
|
-See Also:
|
|
- tar(1)
|
|
- Archive::Tar
|
|
-
|
|
- \n]
|
|
-}
|
|
+ my $usage .= << '=cut';
|
|
+=pod
|
|
|
|
=head1 NAME
|
|
|
|
-ptar - a tar-like program written in perl
|
|
+ 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.
|
|
+ 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 -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
|
|
+ c Create ARCHIVE_FILE or STDOUT (-) from FILE
|
|
+ x Extract from ARCHIVE_FILE or STDIN (-)
|
|
+ t List the contents of ARCHIVE_FILE or STDIN (-)
|
|
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
|
|
@@ -106,6 +98,17 @@ Archive::Tar to extract, create and list
|
|
|
|
=head1 SEE ALSO
|
|
|
|
-tar(1), L<Archive::Tar>.
|
|
+ tar(1), L<Archive::Tar>.
|
|
|
|
=cut
|
|
+
|
|
+ ### strip the pod directives
|
|
+ $usage =~ s/=pod\n//g;
|
|
+ $usage =~ s/=head1 //g;
|
|
+
|
|
+ ### add some newlines
|
|
+ $usage .= $/.$/;
|
|
+
|
|
+ return $usage;
|
|
+}
|
|
+
|
|
diff -up perl-5.10.0/lib/Archive/Tar/Constant.pm.old perl-5.10.0/lib/Archive/Tar/Constant.pm
|
|
--- perl-5.10.0/lib/Archive/Tar/Constant.pm.old 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/Constant.pm 2008-09-10 10:42:08.000000000 +0200
|
|
@@ -2,20 +2,16 @@ package Archive::Tar::Constant;
|
|
|
|
BEGIN {
|
|
require Exporter;
|
|
- $VERSION= '0.02';
|
|
- @ISA = qw[Exporter];
|
|
- @EXPORT = qw[
|
|
- FILE HARDLINK SYMLINK CHARDEV BLOCKDEV DIR FIFO SOCKET UNKNOWN
|
|
- BUFFER HEAD READ_ONLY WRITE_ONLY UNPACK PACK TIME_OFFSET ZLIB
|
|
- BLOCK_SIZE TAR_PAD TAR_END ON_UNIX BLOCK CAN_READLINK MAGIC
|
|
- TAR_VERSION UNAME GNAME CAN_CHOWN MODE CHECK_SUM UID GID
|
|
- GZIP_MAGIC_NUM MODE_READ LONGLINK LONGLINK_NAME PREFIX_LENGTH
|
|
- LABEL NAME_LENGTH STRIP_MODE ON_VMS
|
|
- ];
|
|
+
|
|
+ $VERSION = '0.02';
|
|
+ @ISA = qw[Exporter];
|
|
|
|
require Time::Local if $^O eq "MacOS";
|
|
}
|
|
|
|
+use Package::Constants;
|
|
+@EXPORT = Package::Constants->list( __PACKAGE__ );
|
|
+
|
|
use constant FILE => 0;
|
|
use constant HARDLINK => 1;
|
|
use constant SYMLINK => 2;
|
|
@@ -32,6 +28,9 @@ use constant BUFFER => 4096;
|
|
use constant HEAD => 512;
|
|
use constant BLOCK => 512;
|
|
|
|
+use constant COMPRESS_GZIP => 9;
|
|
+use constant COMPRESS_BZIP => 'bzip2';
|
|
+
|
|
use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
|
|
use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
|
|
use constant TAR_END => "\0" x BLOCK;
|
|
@@ -61,14 +60,23 @@ use constant TIME_OFFSET => ($^O eq "
|
|
use constant MAGIC => "ustar";
|
|
use constant TAR_VERSION => "00";
|
|
use constant LONGLINK_NAME => '././@LongLink';
|
|
+use constant PAX_HEADER => 'pax_global_header';
|
|
|
|
- ### allow ZLIB to be turned off using ENV
|
|
- ### DEBUG only
|
|
+ ### 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 };
|
|
-
|
|
+ $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
|
|
+ };
|
|
+
|
|
+ ### allow BZIP to be turned off using ENV: DEBUG only
|
|
+use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
|
|
+ eval { require IO::Uncompress::Bunzip2;
|
|
+ require IO::Compress::Bzip2; };
|
|
+ $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
|
|
+ };
|
|
+
|
|
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
|
|
+use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
|
|
|
|
use constant CAN_CHOWN => do { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
|
|
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
|
|
diff -up perl-5.10.0/lib/Archive/Tar/File.pm.old perl-5.10.0/lib/Archive/Tar/File.pm
|
|
--- perl-5.10.0/lib/Archive/Tar/File.pm.old 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/File.pm 2008-10-13 13:51:50.000000000 +0200
|
|
@@ -1,15 +1,18 @@
|
|
package Archive::Tar::File;
|
|
use strict;
|
|
|
|
+use Carp ();
|
|
use IO::File;
|
|
use File::Spec::Unix ();
|
|
use File::Spec ();
|
|
use File::Basename ();
|
|
|
|
+### avoid circular use, so only require;
|
|
+require Archive::Tar;
|
|
use Archive::Tar::Constant;
|
|
|
|
use vars qw[@ISA $VERSION];
|
|
-@ISA = qw[Archive::Tar];
|
|
+#@ISA = qw[Archive::Tar];
|
|
$VERSION = '0.02';
|
|
|
|
### set value to 1 to oct() it during the unpack ###
|
|
@@ -154,13 +157,13 @@ Raw tar header -- not useful for most us
|
|
|
|
=head1 Methods
|
|
|
|
-=head2 new( file => $path )
|
|
+=head2 Archive::Tar::File->new( file => $path )
|
|
|
|
Returns a new Archive::Tar::File object from an existing file.
|
|
|
|
Returns undef on failure.
|
|
|
|
-=head2 new( data => $path, $data, $opt )
|
|
+=head2 Archive::Tar::File->new( data => $path, $data, $opt )
|
|
|
|
Returns a new Archive::Tar::File object from data.
|
|
|
|
@@ -171,7 +174,7 @@ tar header), which are described above i
|
|
|
|
Returns undef on failure.
|
|
|
|
-=head2 new( chunk => $chunk )
|
|
+=head2 Archive::Tar::File->new( chunk => $chunk )
|
|
|
|
Returns a new Archive::Tar::File object from a raw 512-byte tar
|
|
archive chunk.
|
|
@@ -266,6 +269,29 @@ sub _new_from_file {
|
|
my @items = qw[mode uid gid size mtime];
|
|
my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
|
|
|
|
+ if (ON_VMS) {
|
|
+ ### VMS has two UID modes, traditional and POSIX. Normally POSIX is
|
|
+ ### not used. We currently do not have an easy way to see if we are in
|
|
+ ### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
|
|
+ ### The VMS UIC has the upper 16 bits is the GID, which in many cases
|
|
+ ### the VMS UIC will be larger than 209715, the largest that TAR can
|
|
+ ### handle. So for now, assume it is traditional if the UID is larger
|
|
+ ### than 0x10000.
|
|
+
|
|
+ if ($hash{uid} > 0x10000) {
|
|
+ $hash{uid} = $hash{uid} & 0xFFFF;
|
|
+ }
|
|
+
|
|
+ ### The file length from stat() is the physical length of the file
|
|
+ ### However the amount of data read in may be more for some file types.
|
|
+ ### Fixed length files are read past the logical EOF to end of the block
|
|
+ ### containing. Other file types get expanded on read because record
|
|
+ ### delimiters are added.
|
|
+
|
|
+ my $data_len = length $data;
|
|
+ $hash{size} = $data_len if $hash{size} < $data_len;
|
|
+
|
|
+ }
|
|
### you *must* set size == 0 on symlinks, or the next entry will be
|
|
### though of as the contents of the symlink, which is wrong.
|
|
### this fixes bug #7937
|
|
@@ -367,6 +393,9 @@ sub _prefix_and_file {
|
|
### if it's a directory, then $file might be empty
|
|
$file = pop @dirs if $self->is_dir and not length $file;
|
|
|
|
+ ### splitting ../ gives you the relative path in native syntax
|
|
+ map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS;
|
|
+
|
|
my $prefix = File::Spec::Unix->catdir(
|
|
grep { length } $vol, @dirs
|
|
);
|
|
@@ -411,7 +440,25 @@ sub _downgrade_to_plainfile {
|
|
return 1;
|
|
}
|
|
|
|
-=head2 full_path
|
|
+=head2 $bool = $file->extract( [ $alternative_name ] )
|
|
+
|
|
+Extract this object, optionally to an alternative name.
|
|
+
|
|
+See C<< Archive::Tar->extract_file >> for details.
|
|
+
|
|
+Returns true on success and false on failure.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub extract {
|
|
+ my $self = shift;
|
|
+
|
|
+ local $Carp::CarpLevel += 1;
|
|
+
|
|
+ return Archive::Tar->_extract_file( $self, @_ );
|
|
+}
|
|
+
|
|
+=head2 $path = $file->full_path
|
|
|
|
Returns the full path from the tar header; this is basically a
|
|
concatenation of the C<prefix> and C<name> fields.
|
|
@@ -429,7 +476,7 @@ sub full_path {
|
|
}
|
|
|
|
|
|
-=head2 validate
|
|
+=head2 $bool = $file->validate
|
|
|
|
Done by Archive::Tar internally when reading the tar file:
|
|
validate the header against the checksum to ensure integer tar file.
|
|
@@ -448,7 +495,7 @@ sub validate {
|
|
return unpack ("%16C*", $raw) == $self->chksum ? 1 : 0;
|
|
}
|
|
|
|
-=head2 has_content
|
|
+=head2 $bool = $file->has_content
|
|
|
|
Returns a boolean to indicate whether the current object has content.
|
|
Some special files like directories and so on never will have any
|
|
@@ -462,7 +509,7 @@ sub has_content {
|
|
return defined $self->data() && length $self->data() ? 1 : 0;
|
|
}
|
|
|
|
-=head2 get_content
|
|
+=head2 $content = $file->get_content
|
|
|
|
Returns the current content for the in-memory file
|
|
|
|
@@ -473,7 +520,7 @@ sub get_content {
|
|
$self->data( );
|
|
}
|
|
|
|
-=head2 get_content_by_ref
|
|
+=head2 $cref = $file->get_content_by_ref
|
|
|
|
Returns the current content for the in-memory file as a scalar
|
|
reference. Normal users won't need this, but it will save memory if
|
|
@@ -489,7 +536,7 @@ sub get_content_by_ref {
|
|
return \$self->{data};
|
|
}
|
|
|
|
-=head2 replace_content( $content )
|
|
+=head2 $bool = $file->replace_content( $content )
|
|
|
|
Replace the current content of the file with the new content. This
|
|
only affects the in-memory archive, not the on-disk version until
|
|
@@ -508,7 +555,7 @@ sub replace_content {
|
|
return 1;
|
|
}
|
|
|
|
-=head2 rename( $new_name )
|
|
+=head2 $bool = $file->rename( $new_name )
|
|
|
|
Rename the current file to $new_name.
|
|
|
|
@@ -540,49 +587,49 @@ use the following methods:
|
|
|
|
=over 4
|
|
|
|
-=item is_file
|
|
+=item $file->is_file
|
|
|
|
Returns true if the file is of type C<file>
|
|
|
|
-=item is_dir
|
|
+=item $file->is_dir
|
|
|
|
Returns true if the file is of type C<dir>
|
|
|
|
-=item is_hardlink
|
|
+=item $file->is_hardlink
|
|
|
|
Returns true if the file is of type C<hardlink>
|
|
|
|
-=item is_symlink
|
|
+=item $file->is_symlink
|
|
|
|
Returns true if the file is of type C<symlink>
|
|
|
|
-=item is_chardev
|
|
+=item $file->is_chardev
|
|
|
|
Returns true if the file is of type C<chardev>
|
|
|
|
-=item is_blockdev
|
|
+=item $file->is_blockdev
|
|
|
|
Returns true if the file is of type C<blockdev>
|
|
|
|
-=item is_fifo
|
|
+=item $file->is_fifo
|
|
|
|
Returns true if the file is of type C<fifo>
|
|
|
|
-=item is_socket
|
|
+=item $file->is_socket
|
|
|
|
Returns true if the file is of type C<socket>
|
|
|
|
-=item is_longlink
|
|
+=item $file->is_longlink
|
|
|
|
Returns true if the file is of type C<LongLink>.
|
|
Should not happen after a successful C<read>.
|
|
|
|
-=item is_label
|
|
+=item $file->is_label
|
|
|
|
Returns true if the file is of type C<Label>.
|
|
Should not happen after a successful C<read>.
|
|
|
|
-=item is_unknown
|
|
+=item $file->is_unknown
|
|
|
|
Returns true if the file type is C<unknown>
|
|
|
|
diff -up perl-5.10.0/lib/Archive/Tar.pm.old perl-5.10.0/lib/Archive/Tar.pm
|
|
--- perl-5.10.0/lib/Archive/Tar.pm.old 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar.pm 2008-10-13 15:16:06.000000000 +0200
|
|
@@ -7,16 +7,31 @@
|
|
package Archive::Tar;
|
|
require 5.005_03;
|
|
|
|
+use Cwd;
|
|
+use IO::Zlib;
|
|
+use IO::File;
|
|
+use Carp qw(carp croak);
|
|
+use File::Spec ();
|
|
+use File::Spec::Unix ();
|
|
+use File::Path ();
|
|
+
|
|
+use Archive::Tar::File;
|
|
+use Archive::Tar::Constant;
|
|
+
|
|
+require Exporter;
|
|
+
|
|
use strict;
|
|
use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
|
|
$DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING
|
|
- $INSECURE_EXTRACT_MODE
|
|
+ $INSECURE_EXTRACT_MODE @ISA @EXPORT
|
|
];
|
|
|
|
+@ISA = qw[Exporter];
|
|
+@EXPORT = ( COMPRESS_GZIP, COMPRESS_BZIP );
|
|
$DEBUG = 0;
|
|
$WARN = 1;
|
|
$FOLLOW_SYMLINK = 0;
|
|
-$VERSION = "1.38";
|
|
+$VERSION = "1.40";
|
|
$CHOWN = 1;
|
|
$CHMOD = 1;
|
|
$DO_NOT_USE_PREFIX = 0;
|
|
@@ -28,24 +43,13 @@ BEGIN {
|
|
|
|
### try and load IO::String anyway, so you can dynamically
|
|
### switch between perlio and IO::String
|
|
- eval {
|
|
+ $HAS_IO_STRING = eval {
|
|
require IO::String;
|
|
import IO::String;
|
|
- };
|
|
- $HAS_IO_STRING = $@ ? 0 : 1;
|
|
-
|
|
+ 1;
|
|
+ } || 0;
|
|
}
|
|
|
|
-use Cwd;
|
|
-use IO::File;
|
|
-use Carp qw(carp croak);
|
|
-use File::Spec ();
|
|
-use File::Spec::Unix ();
|
|
-use File::Path ();
|
|
-
|
|
-use Archive::Tar::File;
|
|
-use Archive::Tar::Constant;
|
|
-
|
|
=head1 NAME
|
|
|
|
Archive::Tar - module for manipulations of tar archives
|
|
@@ -55,7 +59,7 @@ Archive::Tar - module for manipulations
|
|
use Archive::Tar;
|
|
my $tar = Archive::Tar->new;
|
|
|
|
- $tar->read('origin.tgz',1);
|
|
+ $tar->read('origin.tgz');
|
|
$tar->extract();
|
|
|
|
$tar->add_files('file/foo.pl', 'docs/README');
|
|
@@ -63,7 +67,9 @@ Archive::Tar - module for manipulations
|
|
|
|
$tar->rename('oldname', 'new/file/name');
|
|
|
|
- $tar->write('files.tar');
|
|
+ $tar->write('files.tar'); # plain tar
|
|
+ $tar->write('files.tgz', COMPRESSED_GZIP); # gzip compressed
|
|
+ $tar->write('files.tbz', COMPRESSED_BZIP); # bzip2 compressed
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
@@ -122,23 +128,25 @@ sub new {
|
|
return $obj;
|
|
}
|
|
|
|
-=head2 $tar->read ( $filename|$handle, $compressed, {opt => 'val'} )
|
|
+=head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] )
|
|
|
|
Read the given tar file into memory.
|
|
The first argument can either be the name of a file or a reference to
|
|
an already open filehandle (or an IO::Zlib object if it's compressed)
|
|
-The second argument indicates whether the file referenced by the first
|
|
-argument is compressed.
|
|
|
|
The C<read> will I<replace> any previous content in C<$tar>!
|
|
|
|
-The second argument may be considered optional if IO::Zlib is
|
|
-installed, since it will transparently Do The Right Thing.
|
|
-Archive::Tar will warn if you try to pass a compressed file if
|
|
-IO::Zlib is not available and simply return.
|
|
+The second argument may be considered optional, but remains for
|
|
+backwards compatibility. Archive::Tar now looks at the file
|
|
+magic to determine what class should be used to open the file
|
|
+and will transparently Do The Right Thing.
|
|
+
|
|
+Archive::Tar will warn if you try to pass a bzip2 compressed file and the
|
|
+IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return.
|
|
|
|
Note that you can currently B<not> pass a C<gzip> compressed
|
|
-filehandle, which is not opened with C<IO::Zlib>, nor a string
|
|
+filehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed
|
|
+filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string
|
|
containing the full archive information (either compressed or
|
|
uncompressed). These are worth while features, but not currently
|
|
implemented. See the C<TODO> section.
|
|
@@ -153,12 +161,18 @@ all options are case-sensitive.
|
|
Do not read more than C<limit> files. This is useful if you have
|
|
very big archives, and are only interested in the first few files.
|
|
|
|
+=item filter
|
|
+
|
|
+Can be set to a regular expression. Only files with names that match
|
|
+the expression will be read.
|
|
+
|
|
=item extract
|
|
|
|
If set to true, immediately extract entries when reading them. This
|
|
gives you the same memory break as the C<extract_archive> function.
|
|
Note however that entries will not be read into memory, but written
|
|
-straight to disk.
|
|
+straight to disk. This means no C<Archive::Tar::File> objects are
|
|
+created for you to inspect.
|
|
|
|
=back
|
|
|
|
@@ -194,49 +208,97 @@ sub read {
|
|
}
|
|
|
|
sub _get_handle {
|
|
- my $self = shift;
|
|
- my $file = shift; return unless defined $file;
|
|
- return $file if ref $file;
|
|
-
|
|
- my $gzip = shift || 0;
|
|
- my $mode = shift || READ_ONLY->( ZLIB ); # default to read only
|
|
-
|
|
- my $fh; my $bin;
|
|
+ my $self = shift;
|
|
+ my $file = shift; return unless defined $file;
|
|
+ return $file if ref $file;
|
|
+ my $compress = shift || 0;
|
|
+ my $mode = shift || READ_ONLY->( ZLIB ); # default to read only
|
|
|
|
- ### only default to ZLIB if we're not trying to /write/ to a handle ###
|
|
- if( ZLIB and $gzip || MODE_READ->( $mode ) ) {
|
|
|
|
- ### IO::Zlib will Do The Right Thing, even when passed
|
|
- ### a plain file ###
|
|
- $fh = new IO::Zlib;
|
|
+ ### get a FH opened to the right class, so we can use it transparently
|
|
+ ### throughout the program
|
|
+ my $fh;
|
|
+ { ### reading magic only makes sense if we're opening a file for
|
|
+ ### reading. otherwise, just use what the user requested.
|
|
+ my $magic = '';
|
|
+ if( MODE_READ->($mode) ) {
|
|
+ open my $tmp, $file or do {
|
|
+ $self->_error( qq[Could not open '$file' for reading: $!] );
|
|
+ return;
|
|
+ };
|
|
+
|
|
+ ### read the first 4 bites of the file to figure out which class to
|
|
+ ### use to open the file.
|
|
+ sysread( $tmp, $magic, 4 );
|
|
+ close $tmp;
|
|
+ }
|
|
|
|
- } else {
|
|
- if( $gzip ) {
|
|
- $self->_error(qq[Compression not available - Install IO::Zlib!]);
|
|
- return;
|
|
+ ### is it bzip?
|
|
+ ### if you asked specifically for bzip compression, or if we're in
|
|
+ ### read mode and the magic numbers add up, use bzip
|
|
+ if( BZIP and (
|
|
+ ($compress eq COMPRESS_BZIP) or
|
|
+ ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM )
|
|
+ )
|
|
+ ) {
|
|
+
|
|
+ ### different reader/writer modules, different error vars... sigh
|
|
+ if( MODE_READ->($mode) ) {
|
|
+ $fh = IO::Uncompress::Bunzip2->new( $file ) or do {
|
|
+ $self->_error( qq[Could not read '$file': ] .
|
|
+ $IO::Uncompress::Bunzip2::Bunzip2Error
|
|
+ );
|
|
+ return;
|
|
+ };
|
|
+
|
|
+ } else {
|
|
+ $fh = IO::Compress::Bzip2->new( $file ) or do {
|
|
+ $self->_error( qq[Could not write to '$file': ] .
|
|
+ $IO::Compress::Bzip2::Bzip2Error
|
|
+ );
|
|
+ return;
|
|
+ };
|
|
+ }
|
|
+
|
|
+ ### is it gzip?
|
|
+ ### if you asked for compression, if you wanted to read or the gzip
|
|
+ ### magic number is present (redundant with read)
|
|
+ } elsif( ZLIB and (
|
|
+ $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM
|
|
+ )
|
|
+ ) {
|
|
+ $fh = IO::Zlib->new;
|
|
|
|
+ unless( $fh->open( $file, $mode ) ) {
|
|
+ $self->_error(qq[Could not create filehandle for '$file': $!]);
|
|
+ return;
|
|
+ }
|
|
+
|
|
+ ### is it plain tar?
|
|
} else {
|
|
- $fh = new IO::File;
|
|
- $bin++;
|
|
- }
|
|
- }
|
|
+ $fh = IO::File->new;
|
|
|
|
- unless( $fh->open( $file, $mode ) ) {
|
|
- $self->_error( qq[Could not create filehandle for '$file': $!!] );
|
|
- return;
|
|
- }
|
|
+ unless( $fh->open( $file, $mode ) ) {
|
|
+ $self->_error(qq[Could not create filehandle for '$file': $!]);
|
|
+ return;
|
|
+ }
|
|
|
|
- binmode $fh if $bin;
|
|
+ ### enable bin mode on tar archives
|
|
+ binmode $fh;
|
|
+ }
|
|
+ }
|
|
|
|
return $fh;
|
|
}
|
|
|
|
+
|
|
sub _read_tar {
|
|
my $self = shift;
|
|
my $handle = shift or return;
|
|
my $opts = shift || {};
|
|
|
|
my $count = $opts->{limit} || 0;
|
|
+ my $filter = $opts->{filter};
|
|
my $extract = $opts->{extract} || 0;
|
|
|
|
### set a cap on the amount of files to extract ###
|
|
@@ -372,6 +434,17 @@ sub _read_tar {
|
|
undef $real_name;
|
|
}
|
|
|
|
+ ### skip this entry if we're filtering
|
|
+ if ($filter && $entry->name !~ $filter) {
|
|
+ next LOOP;
|
|
+
|
|
+ ### skip this entry if it's a pax header. This is a special file added
|
|
+ ### by, among others, git-generated tarballs. It holds comments and is
|
|
+ ### not meant for extracting. See #38932: pax_global_header extracted
|
|
+ } elsif ( $entry->name eq PAX_HEADER ) {
|
|
+ next LOOP;
|
|
+ }
|
|
+
|
|
$self->_extract_file( $entry ) if $extract
|
|
&& !$entry->is_longlink
|
|
&& !$entry->is_unknown
|
|
@@ -544,7 +617,7 @@ sub _extract_file {
|
|
|
|
my $dir;
|
|
### is $name an absolute path? ###
|
|
- if( File::Spec->file_name_is_absolute( $dirs ) ) {
|
|
+ if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) {
|
|
|
|
### absolute names are not allowed to be in tarballs under
|
|
### strict mode, so only allow it if a user tells us to do it
|
|
@@ -557,30 +630,65 @@ sub _extract_file {
|
|
}
|
|
|
|
### user asked us to, it's fine.
|
|
- $dir = $dirs;
|
|
+ $dir = File::Spec->catpath( $vol, $dirs, "" );
|
|
|
|
### it's a relative path ###
|
|
} else {
|
|
- my $cwd = (defined $self->{cwd} ? $self->{cwd} : cwd());
|
|
+ my $cwd = (ref $self and defined $self->{cwd})
|
|
+ ? $self->{cwd}
|
|
+ : cwd();
|
|
|
|
my @dirs = defined $alt
|
|
? File::Spec->splitdir( $dirs ) # It's a local-OS path
|
|
: File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely
|
|
# straight from the tarball
|
|
|
|
- ### paths that leave the current directory are not allowed under
|
|
- ### strict mode, so only allow it if a user tells us to do this.
|
|
if( not defined $alt and
|
|
- not $INSECURE_EXTRACT_MODE and
|
|
- grep { $_ eq '..' } @dirs
|
|
- ) {
|
|
- $self->_error(
|
|
- q[Entry ']. $entry->full_path .q[' is attempting to leave the ].
|
|
- q[current working directory. Not extracting under SECURE ].
|
|
- q[EXTRACT MODE]
|
|
- );
|
|
- return;
|
|
- }
|
|
+ not $INSECURE_EXTRACT_MODE
|
|
+ ) {
|
|
+
|
|
+ ### paths that leave the current directory are not allowed under
|
|
+ ### strict mode, so only allow it if a user tells us to do this.
|
|
+ if( grep { $_ eq '..' } @dirs ) {
|
|
+
|
|
+ $self->_error(
|
|
+ q[Entry ']. $entry->full_path .q[' is attempting to leave ].
|
|
+ q[the current working directory. Not extracting under ].
|
|
+ q[SECURE EXTRACT MODE]
|
|
+ );
|
|
+ return;
|
|
+ }
|
|
+
|
|
+ ### the archive may be asking us to extract into a symlink. This
|
|
+ ### is not sane and a possible security issue, as outlined here:
|
|
+ ### https://rt.cpan.org/Ticket/Display.html?id=30380
|
|
+ ### https://bugzilla.redhat.com/show_bug.cgi?id=295021
|
|
+ ### https://issues.rpath.com/browse/RPL-1716
|
|
+ my $full_path = $cwd;
|
|
+ for my $d ( @dirs ) {
|
|
+ $full_path = File::Spec->catdir( $full_path, $d );
|
|
+
|
|
+ ### we've already checked this one, and it's safe. Move on.
|
|
+ next if ref $self and $self->{_link_cache}->{$full_path};
|
|
+
|
|
+ if( -l $full_path ) {
|
|
+ my $to = readlink $full_path;
|
|
+ my $diag = "symlinked directory ($full_path => $to)";
|
|
+
|
|
+ $self->_error(
|
|
+ q[Entry ']. $entry->full_path .q[' is attempting to ].
|
|
+ qq[extract to a $diag. This is considered a security ].
|
|
+ q[vulnerability and not allowed under SECURE EXTRACT ].
|
|
+ q[MODE]
|
|
+ );
|
|
+ return;
|
|
+ }
|
|
+
|
|
+ ### XXX keep a cache if possible, so the stats become cheaper:
|
|
+ $self->{_link_cache}->{$full_path} = 1 if ref $self;
|
|
+ }
|
|
+ }
|
|
+
|
|
|
|
### '.' is the directory delimiter, of which the first one has to
|
|
### be escaped/changed.
|
|
@@ -622,7 +730,8 @@ sub _extract_file {
|
|
unless ( -d _ ) {
|
|
eval { File::Path::mkpath( $dir, 0, 0777 ) };
|
|
if( $@ ) {
|
|
- $self->_error( qq[Could not create directory '$dir': $@] );
|
|
+ my $fp = $entry->full_path;
|
|
+ $self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
|
|
return;
|
|
}
|
|
|
|
@@ -672,8 +781,13 @@ sub _extract_file {
|
|
$self->_make_special_file( $entry, $full ) or return;
|
|
}
|
|
|
|
- utime time, $entry->mtime - TIME_OFFSET, $full or
|
|
- $self->_error( qq[Could not update timestamp] );
|
|
+ ### only update the timestamp if it's not a symlink; that will change the
|
|
+ ### timestamp of the original. This addresses bug #33669: Could not update
|
|
+ ### timestamp warning on symlinks
|
|
+ if( not -l $full ) {
|
|
+ utime time, $entry->mtime - TIME_OFFSET, $full or
|
|
+ $self->_error( qq[Could not update timestamp] );
|
|
+ }
|
|
|
|
if( $CHOWN && CAN_CHOWN ) {
|
|
chown $entry->uid, $entry->gid, $full or
|
|
@@ -707,8 +821,8 @@ sub _make_special_file {
|
|
or $fail++;
|
|
}
|
|
|
|
- $err = qq[Making symbolink link from '] . $entry->linkname .
|
|
- qq[' to '$file' failed] if $fail;
|
|
+ $err = qq[Making symbolic link '$file' to '] .
|
|
+ $entry->linkname .q[' failed] if $fail;
|
|
|
|
} elsif ( $entry->is_hardlink ) {
|
|
my $fail;
|
|
@@ -949,17 +1063,23 @@ sub clear {
|
|
|
|
Write the in-memory archive to disk. The first argument can either
|
|
be the name of a file or a reference to an already open filehandle (a
|
|
-GLOB reference). If the second argument is true, the module will use
|
|
-IO::Zlib to write the file in a compressed format. If IO::Zlib is
|
|
-not available, the C<write> method will fail and return.
|
|
+GLOB reference).
|
|
+
|
|
+The second argument is used to indicate compression. You can either
|
|
+compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
|
|
+to be the C<gzip> compression level (between 1 and 9), but the use of
|
|
+constants is prefered:
|
|
+
|
|
+ # write a gzip compressed file
|
|
+ $tar->write( 'out.tgz', COMPRESSION_GZIP );
|
|
+
|
|
+ # write a bzip compressed file
|
|
+ $tar->write( 'out.tbz', COMPRESSION_BZIP );
|
|
|
|
Note that when you pass in a filehandle, the compression argument
|
|
is ignored, as all files are printed verbatim to your filehandle.
|
|
If you wish to enable compression with filehandles, use an
|
|
-C<IO::Zlib> filehandle instead.
|
|
-
|
|
-Specific levels of compression can be chosen by passing the values 2
|
|
-through 9 as the second parameter.
|
|
+C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
|
|
|
|
The third argument is an optional prefix. All files will be tucked
|
|
away in the directory you specify as prefix. So if you have files
|
|
@@ -970,6 +1090,7 @@ If no arguments are given, C<write> retu
|
|
archive as a string, which could be useful if you'd like to stuff the
|
|
archive into a socket or a pipe to gzip or something.
|
|
|
|
+
|
|
=cut
|
|
|
|
sub write {
|
|
@@ -1350,56 +1471,29 @@ sub setcwd {
|
|
$self->{cwd} = $cwd;
|
|
}
|
|
|
|
-=head2 $bool = $tar->has_io_string
|
|
-
|
|
-Returns true if we currently have C<IO::String> support loaded.
|
|
-
|
|
-Either C<IO::String> or C<perlio> support is needed to support writing
|
|
-stringified archives. Currently, C<perlio> is the preferred method, if
|
|
-available.
|
|
-
|
|
-See the C<GLOBAL VARIABLES> section to see how to change this preference.
|
|
-
|
|
-=cut
|
|
-
|
|
-sub has_io_string { return $HAS_IO_STRING; }
|
|
-
|
|
-=head2 $bool = $tar->has_perlio
|
|
-
|
|
-Returns true if we currently have C<perlio> support loaded.
|
|
-
|
|
-This requires C<perl-5.8> or higher, compiled with C<perlio>
|
|
-
|
|
-Either C<IO::String> or C<perlio> support is needed to support writing
|
|
-stringified archives. Currently, C<perlio> is the preferred method, if
|
|
-available.
|
|
-
|
|
-See the C<GLOBAL VARIABLES> section to see how to change this preference.
|
|
-
|
|
-=cut
|
|
-
|
|
-sub has_perlio { return $HAS_PERLIO; }
|
|
-
|
|
-
|
|
=head1 Class Methods
|
|
|
|
-=head2 Archive::Tar->create_archive($file, $compression, @filelist)
|
|
+=head2 Archive::Tar->create_archive($file, $compressed, @filelist)
|
|
|
|
Creates a tar file from the list of files provided. The first
|
|
argument can either be the name of the tar file to create or a
|
|
reference to an open file handle (e.g. a GLOB reference).
|
|
|
|
-The second argument specifies the level of compression to be used, if
|
|
-any. Compression of tar files requires the installation of the
|
|
-IO::Zlib module. Specific levels of compression may be
|
|
-requested by passing a value between 2 and 9 as the second argument.
|
|
-Any other value evaluating as true will result in the default
|
|
-compression level being used.
|
|
+The second argument is used to indicate compression. You can either
|
|
+compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
|
|
+to be the C<gzip> compression level (between 1 and 9), but the use of
|
|
+constants is prefered:
|
|
+
|
|
+ # write a gzip compressed file
|
|
+ Archive::Tar->create_archive( 'out.tgz', COMPRESSION_GZIP, @filelist );
|
|
+
|
|
+ # write a bzip compressed file
|
|
+ Archive::Tar->create_archive( 'out.tbz', COMPRESSION_BZIP, @filelist );
|
|
|
|
Note that when you pass in a filehandle, the compression argument
|
|
is ignored, as all files are printed verbatim to your filehandle.
|
|
If you wish to enable compression with filehandles, use an
|
|
-C<IO::Zlib> filehandle instead.
|
|
+C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
|
|
|
|
The remaining arguments list the files to be included in the tar file.
|
|
These files must all exist. Any files which don't exist or can't be
|
|
@@ -1431,7 +1525,63 @@ sub create_archive {
|
|
return $tar->write( $file, $gzip );
|
|
}
|
|
|
|
-=head2 Archive::Tar->list_archive ($file, $compressed, [\@properties])
|
|
+=head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] )
|
|
+
|
|
+Returns an iterator function that reads the tar file without loading
|
|
+it all in memory. Each time the function is called it will return the
|
|
+next file in the tarball. The files are returned as
|
|
+C<Archive::Tar::File> objects. The iterator function returns the
|
|
+empty list once it has exhausted the the files contained.
|
|
+
|
|
+The second argument can be a hash reference with options, which are
|
|
+identical to the arguments passed to C<read()>.
|
|
+
|
|
+Example usage:
|
|
+
|
|
+ my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} );
|
|
+
|
|
+ while( my $f = $next->() ) {
|
|
+ print $f->name, "\n";
|
|
+
|
|
+ $f->extract or warn "Extraction failed";
|
|
+
|
|
+ # ....
|
|
+ }
|
|
+
|
|
+=cut
|
|
+
|
|
+
|
|
+sub iter {
|
|
+ my $class = shift;
|
|
+ my $filename = shift or return;
|
|
+ my $compressed = shift or 0;
|
|
+ my $opts = shift || {};
|
|
+
|
|
+ ### get a handle to read from.
|
|
+ my $handle = $class->_get_handle(
|
|
+ $filename,
|
|
+ $compressed,
|
|
+ READ_ONLY->( ZLIB )
|
|
+ ) or return;
|
|
+
|
|
+ my @data;
|
|
+ return sub {
|
|
+ return shift(@data) if @data; # more than one file returned?
|
|
+ return unless $handle; # handle exhausted?
|
|
+
|
|
+ ### read data, should only return file
|
|
+ @data = @{ $class->_read_tar($handle, { %$opts, limit => 1 }) };
|
|
+
|
|
+ ### return one piece of data
|
|
+ return shift(@data) if @data;
|
|
+
|
|
+ ### data is exhausted, free the filehandle
|
|
+ undef $handle;
|
|
+ return;
|
|
+ };
|
|
+}
|
|
+
|
|
+=head2 Archive::Tar->list_archive($file, $compressed, [\@properties])
|
|
|
|
Returns a list of the names of all the files in the archive. The
|
|
first argument can either be the name of the tar file to list or a
|
|
@@ -1462,7 +1612,7 @@ sub list_archive {
|
|
return $tar->list_files( @_ );
|
|
}
|
|
|
|
-=head2 Archive::Tar->extract_archive ($file, $gzip)
|
|
+=head2 Archive::Tar->extract_archive($file, $compressed)
|
|
|
|
Extracts the contents of the tar file. The first argument can either
|
|
be the name of the tar file to create or a reference to an open file
|
|
@@ -1486,11 +1636,57 @@ sub extract_archive {
|
|
return $tar->read( $file, $gzip, { extract => 1 } );
|
|
}
|
|
|
|
+=head2 $bool = Archive::Tar->has_io_string
|
|
+
|
|
+Returns true if we currently have C<IO::String> support loaded.
|
|
+
|
|
+Either C<IO::String> or C<perlio> support is needed to support writing
|
|
+stringified archives. Currently, C<perlio> is the preferred method, if
|
|
+available.
|
|
+
|
|
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub has_io_string { return $HAS_IO_STRING; }
|
|
+
|
|
+=head2 $bool = Archive::Tar->has_perlio
|
|
+
|
|
+Returns true if we currently have C<perlio> support loaded.
|
|
+
|
|
+This requires C<perl-5.8> or higher, compiled with C<perlio>
|
|
+
|
|
+Either C<IO::String> or C<perlio> support is needed to support writing
|
|
+stringified archives. Currently, C<perlio> is the preferred method, if
|
|
+available.
|
|
+
|
|
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub has_perlio { return $HAS_PERLIO; }
|
|
+
|
|
+=head2 $bool = Archive::Tar->has_zlib_support
|
|
+
|
|
+Returns true if C<Archive::Tar> can extract C<zlib> compressed archives
|
|
+
|
|
+=cut
|
|
+
|
|
+sub has_zlib_support { return ZLIB }
|
|
+
|
|
+=head2 $bool = Archive::Tar->has_bzip2_support
|
|
+
|
|
+Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives
|
|
+
|
|
+=cut
|
|
+
|
|
+sub has_bzip2_support { return BZIP }
|
|
+
|
|
=head2 Archive::Tar->can_handle_compressed_files
|
|
|
|
A simple checking routine, which will return true if C<Archive::Tar>
|
|
-is able to uncompress compressed archives on the fly with C<IO::Zlib>,
|
|
-or false if C<IO::Zlib> is not installed.
|
|
+is able to uncompress compressed archives on the fly with C<IO::Zlib>
|
|
+and C<IO::Compress::Bzip2> or false if not both are installed.
|
|
|
|
You can use this as a shortcut to determine whether C<Archive::Tar>
|
|
will do what you think before passing compressed archives to its
|
|
@@ -1498,7 +1694,7 @@ C<read> method.
|
|
|
|
=cut
|
|
|
|
-sub can_handle_compressed_files { return ZLIB ? 1 : 0 }
|
|
+sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 }
|
|
|
|
sub no_string_support {
|
|
croak("You have to install IO::String to support writing archives to strings");
|
|
@@ -1645,18 +1841,24 @@ Yes it is, see previous answer. Since C<
|
|
C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
|
|
choice but to read the archive into memory.
|
|
This is ok if you want to do in-memory manipulation of the archive.
|
|
+
|
|
If you just want to extract, use the C<extract_archive> class method
|
|
instead. It will optimize and write to disk immediately.
|
|
|
|
-=item Can't you lazy-load data instead?
|
|
+Another option is to use the C<iter> class method to iterate over
|
|
+the files in the tarball without reading them all in memory at once.
|
|
+
|
|
+=item Can you lazy-load data instead?
|
|
|
|
-No, not easily. See previous question.
|
|
+In some cases, yes. You can use the C<iter> class method to iterate
|
|
+over the files in the tarball without reading them all in memory at once.
|
|
|
|
=item How much memory will an X kb tar file need?
|
|
|
|
Probably more than X kb, since it will all be read into memory. If
|
|
this is a problem, and you don't need to do in memory manipulation
|
|
-of the archive, consider using C</bin/tar> instead.
|
|
+of the archive, consider using the C<iter> class method, or C</bin/tar>
|
|
+instead.
|
|
|
|
=item What do you do with unsupported filetypes in an archive?
|
|
|
|
@@ -1666,8 +1868,9 @@ try to make a copy of the original file,
|
|
|
|
This does require you to read the entire archive in to memory first,
|
|
since otherwise we wouldn't know what data to fill the copy with.
|
|
-(This means that you cannot use the class methods on archives that
|
|
-have incompatible filetypes and still expect things to work).
|
|
+(This means that you cannot use the class methods, including C<iter>
|
|
+on archives that 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.
|
|
@@ -1852,12 +2055,12 @@ Please reports bugs to E<lt>bug-archive-
|
|
|
|
=head1 ACKNOWLEDGEMENTS
|
|
|
|
-Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney and
|
|
-especially Andrew Savige for their help and suggestions.
|
|
+Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas
|
|
+and especially Andrew Savige for their help and suggestions.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
-This module is copyright (c) 2002 - 2007 Jos Boumans
|
|
+This module is copyright (c) 2002 - 2008 Jos Boumans
|
|
E<lt>kane@cpan.orgE<gt>. All rights reserved.
|
|
|
|
This library is free software; you may redistribute and/or modify
|
|
diff -up perl-5.10.0/lib/Archive/Tar/t/01_use.t.old perl-5.10.0/lib/Archive/Tar/t/01_use.t
|
|
diff -up perl-5.10.0/lib/Archive/Tar/t/02_methods.t.old perl-5.10.0/lib/Archive/Tar/t/02_methods.t
|
|
--- perl-5.10.0/lib/Archive/Tar/t/02_methods.t.old 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/t/02_methods.t 2008-10-13 15:00:07.000000000 +0200
|
|
@@ -21,9 +21,14 @@ use File::Spec::Unix ();
|
|
use File::Basename ();
|
|
use Data::Dumper;
|
|
|
|
-use Archive::Tar;
|
|
+### need the constants at compile time;
|
|
use Archive::Tar::Constant;
|
|
|
|
+my $Class = 'Archive::Tar';
|
|
+use_ok( $Class );
|
|
+
|
|
+
|
|
+
|
|
### XXX TODO:
|
|
### * change to fullname
|
|
### * add tests for global variables
|
|
@@ -72,22 +77,23 @@ if ($TOO_LONG) {
|
|
}
|
|
|
|
my @ROOT = grep { length } 'src', $TOO_LONG ? 'short' : 'long';
|
|
-
|
|
-my $ZLIB = eval { require IO::Zlib; 1 } ? 1 : 0;
|
|
my $NO_UNLINK = $ARGV[0] ? 1 : 0;
|
|
|
|
-### enable debugging?
|
|
-$Archive::Tar::DEBUG = 1 if $ARGV[1];
|
|
+### enable debugging?
|
|
+### pesky warnings
|
|
+$Archive::Tar::DEBUG = $Archive::Tar::DEBUG = 1 if $ARGV[1];
|
|
|
|
### tests for binary and x/x files
|
|
-my $TARBIN = Archive::Tar->new;
|
|
-my $TARX = Archive::Tar->new;
|
|
+my $TARBIN = $Class->new;
|
|
+my $TARX = $Class->new;
|
|
|
|
### paths to a .tar and .tgz file to use for tests
|
|
my $TAR_FILE = File::Spec->catfile( @ROOT, 'bar.tar' );
|
|
my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' );
|
|
+my $TBZ_FILE = File::Spec->catfile( @ROOT, 'foo.tbz' );
|
|
my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' );
|
|
my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' );
|
|
+my $OUT_TBZ_FILE = File::Spec->catfile( @ROOT, 'out.tbz' );
|
|
|
|
my $COMPRESS_FILE = 'copy';
|
|
$^O eq 'VMS' and $COMPRESS_FILE .= '.';
|
|
@@ -96,15 +102,16 @@ chmod 0644, $COMPRESS_FILE;
|
|
|
|
### done setting up environment ###
|
|
|
|
+### check for zlib/bzip2 support
|
|
+{ for my $meth ( qw[has_zlib_support has_bzip2_support] ) {
|
|
+ can_ok( $Class, $meth );
|
|
+ }
|
|
+}
|
|
|
|
-### did we probe IO::Zlib support ok? ###
|
|
-{ is( Archive::Tar->can_handle_compressed_files, $ZLIB,
|
|
- "Proper IO::Zlib support detected" );
|
|
-}
|
|
|
|
|
|
### tar error tests
|
|
-{ my $tar = Archive::Tar->new;
|
|
+{ my $tar = $Class->new;
|
|
|
|
ok( $tar, "Object created" );
|
|
isa_ok( $tar, 'Archive::Tar');
|
|
@@ -133,7 +140,7 @@ chmod 0644, $COMPRESS_FILE;
|
|
|
|
### check if ->error eq $error
|
|
is( $tar->error, $Archive::Tar::error,
|
|
- '$error matches error() method' );
|
|
+ "Error '$Archive::Tar::error' matches $Class->error method" );
|
|
|
|
### check that 'contains_file' doesn't warn about missing files.
|
|
{ ### turn on warnings in general!
|
|
@@ -149,89 +156,77 @@ chmod 0644, $COMPRESS_FILE;
|
|
}
|
|
|
|
### read tests ###
|
|
-{ ### normal tar + gz compressed file
|
|
- my $archive = $TAR_FILE;
|
|
- my $compressed = $TGZ_FILE;
|
|
- my $tar = Archive::Tar->new;
|
|
- my $gzip = 0;
|
|
+{ my @to_try = ($TAR_FILE);
|
|
+ push @to_try, $TGZ_FILE if $Class->has_zlib_support;
|
|
+ push @to_try, $TBZ_FILE if $Class->has_bzip2_support;
|
|
|
|
- ### check we got the object
|
|
- ok( $tar, "Object created" );
|
|
- isa_ok( $tar, 'Archive::Tar');
|
|
+ for my $type( @to_try ) {
|
|
|
|
- for my $type( $archive, $compressed ) {
|
|
- my $state = $gzip ? 'compressed' : 'uncompressed';
|
|
+ ### normal tar + gz compressed file
|
|
+ my $tar = $Class->new;
|
|
|
|
- SKIP: {
|
|
+ ### check we got the object
|
|
+ ok( $tar, "Object created" );
|
|
+ isa_ok( $tar, 'Archive::Tar');
|
|
|
|
- ### skip gz compressed archives wihtout IO::Zlib
|
|
- skip( "No IO::Zlib - cannot read compressed archives",
|
|
- 4 + 2 * (scalar @EXPECT_NORMAL)
|
|
- ) if( $gzip and !$ZLIB);
|
|
-
|
|
- ### ->read test
|
|
- { my @list = $tar->read( $type );
|
|
- my $cnt = scalar @list;
|
|
- my $expect = scalar __PACKAGE__->get_expect();
|
|
-
|
|
- ok( $cnt, "Reading $state file using 'read()'" );
|
|
- is( $cnt, $expect, " All files accounted for" );
|
|
-
|
|
- for my $file ( @list ) {
|
|
- 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;
|
|
- my($expect_name, $expect_content) =
|
|
- get_expect_name_and_contents( $name, \@EXPECT_NORMAL );
|
|
+ ### ->read test
|
|
+ my @list = $tar->read( $type );
|
|
+ my $cnt = scalar @list;
|
|
+ my $expect = scalar __PACKAGE__->get_expect();
|
|
+
|
|
+ ok( $cnt, "Reading '$type' using 'read()'" );
|
|
+ is( $cnt, $expect, " All files accounted for" );
|
|
+
|
|
+ for my $file ( @list ) {
|
|
+ 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;
|
|
|
|
- ### ->fullname!
|
|
- ok($expect_name," Found expected file '$name'" );
|
|
+ my $name = $file->full_path;
|
|
+ my($expect_name, $expect_content) =
|
|
+ get_expect_name_and_contents( $name, \@EXPECT_NORMAL );
|
|
|
|
- like($tar->get_content($name), $expect_content,
|
|
- " Content OK" );
|
|
- }
|
|
- }
|
|
+ ### ->fullname!
|
|
+ ok($expect_name," Found expected file '$name'" );
|
|
|
|
+ like($tar->get_content($name), $expect_content,
|
|
+ " Content OK" );
|
|
+ }
|
|
|
|
- ### list_archive test
|
|
- { my @list = Archive::Tar->list_archive( $archive );
|
|
- my $cnt = scalar @list;
|
|
- my $expect = scalar __PACKAGE__->get_expect();
|
|
-
|
|
- ok( $cnt, "Reading $state file using 'list_archive'");
|
|
- is( $cnt, $expect, " All files accounted for" );
|
|
|
|
- for my $file ( @list ) {
|
|
- next if __PACKAGE__->is_dir( $file ); # directories
|
|
+ ### list_archive test
|
|
+ { my @list = $Class->list_archive( $type );
|
|
+ my $cnt = scalar @list;
|
|
+ my $expect = scalar __PACKAGE__->get_expect();
|
|
+
|
|
+ ok( $cnt, "Reading '$type' using 'list_archive'");
|
|
+ is( $cnt, $expect, " All files accounted for" );
|
|
|
|
- my($expect_name, $expect_content) =
|
|
- get_expect_name_and_contents( $file, \@EXPECT_NORMAL );
|
|
+ for my $file ( @list ) {
|
|
+ next if __PACKAGE__->is_dir( $file ); # directories
|
|
|
|
- ok( $expect_name,
|
|
- " Found expected file '$file'" );
|
|
- }
|
|
+ my($expect_name, $expect_content) =
|
|
+ get_expect_name_and_contents( $file, \@EXPECT_NORMAL );
|
|
+
|
|
+ ok( $expect_name,
|
|
+ " Found expected file '$file'" );
|
|
}
|
|
}
|
|
-
|
|
- ### now we try gz compressed archives
|
|
- $gzip++;
|
|
}
|
|
}
|
|
|
|
### add files tests ###
|
|
{ my @add = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
|
|
my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
|
|
- my $tar = Archive::Tar->new;
|
|
+ my $tar = $Class->new;
|
|
|
|
### check we got the object
|
|
ok( $tar, "Object created" );
|
|
@@ -264,7 +259,7 @@ chmod 0644, $COMPRESS_FILE;
|
|
|
|
### check adding files doesn't conflict with a secondary archive
|
|
### old A::T bug, we should keep testing for it
|
|
- { my $tar2 = Archive::Tar->new;
|
|
+ { my $tar2 = $Class->new;
|
|
my @added = $tar2->add_files( $COMPRESS_FILE );
|
|
my @count = $tar2->list_files;
|
|
|
|
@@ -285,7 +280,7 @@ chmod 0644, $COMPRESS_FILE;
|
|
{
|
|
{ ### standard data ###
|
|
my @to_add = ( 'a', 'aaaaa' );
|
|
- my $tar = Archive::Tar->new;
|
|
+ my $tar = $Class->new;
|
|
|
|
### check we got the object
|
|
ok( $tar, "Object created" );
|
|
@@ -330,7 +325,7 @@ chmod 0644, $COMPRESS_FILE;
|
|
}
|
|
|
|
### rename/replace_content tests ###
|
|
-{ my $tar = Archive::Tar->new;
|
|
+{ my $tar = $Class->new;
|
|
my $from = 'c';
|
|
my $to = 'e';
|
|
|
|
@@ -362,7 +357,7 @@ chmod 0644, $COMPRESS_FILE;
|
|
|
|
### remove tests ###
|
|
{ my $remove = 'c';
|
|
- my $tar = Archive::Tar->new;
|
|
+ my $tar = $Class->new;
|
|
|
|
ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
|
|
|
|
@@ -376,12 +371,14 @@ chmod 0644, $COMPRESS_FILE;
|
|
}
|
|
|
|
### write + read + extract tests ###
|
|
-SKIP: {
|
|
+SKIP: { ### pesky warnings
|
|
skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO &&
|
|
+ !$Archive::Tar::HAS_PERLIO &&
|
|
+ !$Archive::Tar::HAS_IO_STRING &&
|
|
!$Archive::Tar::HAS_IO_STRING;
|
|
|
|
- my $tar = Archive::Tar->new;
|
|
- my $new = Archive::Tar->new;
|
|
+ my $tar = $Class->new;
|
|
+ my $new = $Class->new;
|
|
ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
|
|
|
|
for my $aref ( [$tar, \@EXPECT_NORMAL],
|
|
@@ -421,40 +418,31 @@ SKIP: {
|
|
|
|
|
|
{ ### create_archive()
|
|
- ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
|
|
+ ok( $Class->create_archive( $out, 0, $COMPRESS_FILE ),
|
|
"Wrote tarfile using 'create_archive'" );
|
|
check_tar_file( $out );
|
|
|
|
### now extract it again
|
|
- ok( Archive::Tar->extract_archive( $out ),
|
|
+ ok( $Class->extract_archive( $out ),
|
|
"Extracted file using 'extract_archive'");
|
|
rm( $out ) unless $NO_UNLINK;
|
|
}
|
|
}
|
|
|
|
## write tgz tests
|
|
- { my $out = $OUT_TGZ_FILE;
|
|
-
|
|
- SKIP: {
|
|
-
|
|
- ### weird errors from scalar(@x,@y,@z), dot it this way...
|
|
- my $file_cnt;
|
|
- map { $file_cnt += scalar @$_ } \@EXPECT_NORMAL, \@EXPECTBIN,
|
|
- \@EXPECTX;
|
|
-
|
|
- my $cnt = 5 + # the tests below
|
|
- (5*3*2) + # check_tgz_file
|
|
- # check_tar_object fixed tests
|
|
- (3 * 2 * (2 + $file_cnt)) +
|
|
- ((4*$file_cnt) + 1);# check_tar_extract tests
|
|
+ { my @out;
|
|
+ push @out, [ $OUT_TGZ_FILE => 1 ] if $Class->has_zlib_support;
|
|
+ push @out, [ $OUT_TBZ_FILE => COMPRESS_BZIP ] if $Class->has_bzip2_support;
|
|
+
|
|
+ for my $entry ( @out ) {
|
|
|
|
- skip( "No IO::Zlib - cannot write compressed archives", $cnt )
|
|
- unless $ZLIB;
|
|
+ my( $out, $compression ) = @$entry;
|
|
|
|
{ ### write()
|
|
- ok($obj->write($out, 1),
|
|
- "Writing compressed file using 'write'" );
|
|
- check_tgz_file( $out );
|
|
+ ok($obj->write($out, $compression),
|
|
+ "Writing compressed file '$out' using 'write'" );
|
|
+ check_compressed_file( $out );
|
|
+
|
|
check_tar_object( $obj, $struct );
|
|
|
|
### now read it in again
|
|
@@ -471,12 +459,12 @@ SKIP: {
|
|
}
|
|
|
|
{ ### create_archive()
|
|
- ok( Archive::Tar->create_archive( $out, 1, $COMPRESS_FILE ),
|
|
- "Wrote gzip file using 'create_archive'" );
|
|
- check_tgz_file( $out );
|
|
+ ok( $Class->create_archive( $out, $compression, $COMPRESS_FILE ),
|
|
+ "Wrote '$out' using 'create_archive'" );
|
|
+ check_compressed_file( $out );
|
|
|
|
### now extract it again
|
|
- ok( Archive::Tar->extract_archive( $out, 1 ),
|
|
+ ok( $Class->extract_archive( $out, $compression ),
|
|
"Extracted file using 'extract_archive'");
|
|
rm( $out ) unless $NO_UNLINK;
|
|
}
|
|
@@ -487,7 +475,7 @@ SKIP: {
|
|
|
|
|
|
### limited read + extract tests ###
|
|
-{ my $tar = Archive::Tar->new;
|
|
+{ my $tar = $Class->new;
|
|
my @files = $tar->read( $TAR_FILE, 0, { limit => 1 } );
|
|
my $obj = $files[0];
|
|
|
|
@@ -528,7 +516,7 @@ SKIP: {
|
|
|
|
|
|
### clear tests ###
|
|
-{ my $tar = Archive::Tar->new;
|
|
+{ my $tar = $Class->new;
|
|
my @files = $tar->read( $TAR_FILE );
|
|
|
|
my $cnt = $tar->list_files();
|
|
@@ -540,7 +528,7 @@ SKIP: {
|
|
}
|
|
|
|
### $DO_NOT_USE_PREFIX tests
|
|
-{ my $tar = Archive::Tar->new;
|
|
+{ my $tar = $Class->new;
|
|
|
|
|
|
### first write a tar file without prefix
|
|
@@ -556,7 +544,10 @@ SKIP: {
|
|
is( $obj->prefix, $dir, " Prefix set to '$dir'" );
|
|
|
|
### write the tar file without a prefix in it
|
|
+ ### pesky warnings
|
|
local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
|
|
+ local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
|
|
+
|
|
ok( $tar->write( $OUT_TAR_FILE ),
|
|
" Tar file written" );
|
|
|
|
@@ -645,10 +636,10 @@ sub check_tar_file {
|
|
return $contents;
|
|
}
|
|
|
|
-sub check_tgz_file {
|
|
+sub check_compressed_file {
|
|
my $file = shift;
|
|
my $filesize = -s $file;
|
|
- my $contents = slurp_gzfile( $file );
|
|
+ my $contents = slurp_compressed_file( $file );
|
|
my $uncompressedsize = length $contents;
|
|
|
|
ok( defined( $contents ), " File read and uncompressed" );
|
|
@@ -762,18 +753,29 @@ sub slurp_binfile {
|
|
return <$fh>;
|
|
}
|
|
|
|
-sub slurp_gzfile {
|
|
+sub slurp_compressed_file {
|
|
my $file = shift;
|
|
- my $str;
|
|
- my $buff;
|
|
+ my $fh;
|
|
+
|
|
+ ### bzip2
|
|
+ if( $file =~ /.tbz$/ ) {
|
|
+ require IO::Uncompress::Bunzip2;
|
|
+ $fh = IO::Uncompress::Bunzip2->new( $file )
|
|
+ or warn( "Error opening '$file' with IO::Uncompress::Bunzip2" ), return
|
|
|
|
- require IO::Zlib;
|
|
- my $fh = new IO::Zlib;
|
|
- $fh->open( $file, READ_ONLY->(1) )
|
|
- or warn( "Error opening '$file' with IO::Zlib" ), return undef;
|
|
+ ### gzip
|
|
+ } else {
|
|
+ require IO::Zlib;
|
|
+ $fh = new IO::Zlib;
|
|
+ $fh->open( $file, READ_ONLY->(1) )
|
|
+ or warn( "Error opening '$file' with IO::Zlib" ), return
|
|
+ }
|
|
|
|
+ my $str;
|
|
+ my $buff;
|
|
$str .= $buff while $fh->read( $buff, 4096 ) > 0;
|
|
$fh->close();
|
|
+
|
|
return $str;
|
|
}
|
|
|
|
diff -urN perl-5.10.0/lib/Archive/Tar/t.old/04_resolved_issues.t perl-5.10.0/lib/Archive/Tar/t/04_resolved_issues.t
|
|
--- perl-5.10.0/lib/Archive/Tar/t.old/04_resolved_issues.t 2008-12-11 12:43:35.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/t/04_resolved_issues.t 2008-10-13 13:51:50.000000000 +0200
|
|
@@ -113,7 +113,7 @@
|
|
### absolute paths are already taken care of. Only relative paths
|
|
### matter
|
|
my $in_file = basename($0);
|
|
- my $out_file = '../' . $in_file . ".$$";
|
|
+ my $out_file = '../' . $in_file . "_$$";
|
|
|
|
ok( $tar->add_files( $in_file ),
|
|
" Added '$in_file'" );
|
|
diff -urN perl-5.10.0/lib/Archive/Tar/t.old/05_iter.t perl-5.10.0/lib/Archive/Tar/t/05_iter.t
|
|
--- perl-5.10.0/lib/Archive/Tar/t.old/05_iter.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/t/05_iter.t 2008-08-25 05:53:18.000000000 +0200
|
|
@@ -0,0 +1,65 @@
|
|
+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 $Class = 'Archive::Tar';
|
|
+my $FClass = 'Archive::Tar::File';
|
|
+my $File = 'src/long/bar.tar';
|
|
+my @Expect = (
|
|
+ qr|^c$|,
|
|
+ qr|^d$|,
|
|
+ qr|^directory/$|,
|
|
+ qr|^directory/really.*name/$|,
|
|
+ qr|^directory/.*/myfile$|,
|
|
+);
|
|
+
|
|
+use_ok( $Class );
|
|
+
|
|
+### crazy ref to special case 'all'
|
|
+for my $index ( \0, 0 .. $#Expect ) {
|
|
+
|
|
+ my %opts = ();
|
|
+ my @expect = ();
|
|
+
|
|
+ ### do a full test vs individual filters
|
|
+ if( not ref $index ) {
|
|
+ my $regex = $Expect[$index];
|
|
+ $opts{'filter'} = $regex;
|
|
+ @expect = ($regex);
|
|
+ } else {
|
|
+ @expect = @Expect;
|
|
+ }
|
|
+
|
|
+ my $next = $Class->iter( $File, 0, \%opts );
|
|
+
|
|
+ my $pp_opts = join " => ", %opts;
|
|
+ ok( $next, "Iterator created from $File ($pp_opts)" );
|
|
+ isa_ok( $next, "CODE", " Iterator" );
|
|
+
|
|
+ my @names;
|
|
+ while( my $f = $next->() ) {
|
|
+ ok( $f, " File object retrieved" );
|
|
+ isa_ok( $f, $FClass, " Object" );
|
|
+
|
|
+ push @names, $f->name;
|
|
+ }
|
|
+
|
|
+ is( scalar(@names), scalar(@expect),
|
|
+ " Found correct number of files" );
|
|
+
|
|
+ my $i = 0;
|
|
+ for my $name ( @names ) {
|
|
+ ok( 1, " Inspecting '$name' " );
|
|
+ like($name, $expect[$i]," Matches $Expect[$i]" );
|
|
+ $i++;
|
|
+ }
|
|
+}
|
|
diff -urN perl-5.10.0/lib/Archive/Tar/t.old/90_symlink.t perl-5.10.0/lib/Archive/Tar/t/90_symlink.t
|
|
--- perl-5.10.0/lib/Archive/Tar/t.old/90_symlink.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/t/90_symlink.t 2008-08-25 05:43:01.000000000 +0200
|
|
@@ -0,0 +1,62 @@
|
|
+BEGIN {
|
|
+ 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 strict;
|
|
+use File::Spec;
|
|
+use File::Path;
|
|
+use Test::More;
|
|
+
|
|
+### developer tests mostly, so enable them with an extra argument
|
|
+plan skip_all => "Skipping tests on this platform" unless @ARGV;
|
|
+plan 'no_plan';
|
|
+
|
|
+my $Class = 'Archive::Tar';
|
|
+my $Dir = File::Spec->catdir( qw[src linktest] );
|
|
+my %Map = (
|
|
+ File::Spec->catfile( $Dir, "linktest_with_dir.tar" ) => [
|
|
+ [ 0, qr/SECURE EXTRACT MODE/ ],
|
|
+ [ 1, qr/^$/ ]
|
|
+ ],
|
|
+ File::Spec->catfile( $Dir, "linktest_missing_dir.tar" ) => [
|
|
+ [ 0, qr/SECURE EXTRACT MODE/ ],
|
|
+ [ 0, qr/File exists/ ],
|
|
+ ],
|
|
+);
|
|
+
|
|
+use_ok( $Class );
|
|
+
|
|
+{ while( my($file, $aref) = each %Map ) {
|
|
+
|
|
+ for my $mode ( 0, 1 ) {
|
|
+ my $expect = $aref->[$mode]->[0];
|
|
+ my $regex = $aref->[$mode]->[1];
|
|
+
|
|
+ my $tar = $Class->new( $file );
|
|
+ ok( $tar, "Object created from $file" );
|
|
+
|
|
+ ### damn warnings
|
|
+ local $Archive::Tar::INSECURE_EXTRACT_MODE = $mode;
|
|
+ local $Archive::Tar::INSECURE_EXTRACT_MODE = $mode;
|
|
+
|
|
+ ok( 1, " Extracting with insecure mode: $mode" );
|
|
+
|
|
+ my $warning;
|
|
+ local $SIG{__WARN__} = sub { $warning .= "@_"; warn @_; };
|
|
+
|
|
+ my $rv = eval { $tar->extract } || 0;
|
|
+ ok( !$@, " No fatal error" );
|
|
+ is( !!$rv, !!$expect, " RV as expected" );
|
|
+ like( $warning, $regex, " Error matches $regex" );
|
|
+
|
|
+ rmtree( 'linktest' );
|
|
+ }
|
|
+ }
|
|
+}
|
|
diff -urN perl-5.10.0/lib/Archive/Tar/t.old/99_pod.t perl-5.10.0/lib/Archive/Tar/t/99_pod.t
|
|
--- perl-5.10.0/lib/Archive/Tar/t.old/99_pod.t 2008-12-11 12:43:35.000000000 +0100
|
|
+++ perl-5.10.0/lib/Archive/Tar/t/99_pod.t 2008-10-13 14:24:42.000000000 +0200
|
|
@@ -8,6 +8,8 @@
|
|
eval 'use Test::Pod';
|
|
plan skip_all => "Test::Pod v0.95 required for testing POD"
|
|
if $@ || $Test::Pod::VERSION < 0.95;
|
|
+
|
|
+plan skip_all => "Pod tests disabled under perl core" if $ENV{PERL_CORE};
|
|
|
|
my @files;
|
|
find( sub { push @files, File::Spec->catfile(
|