rpms/perl
7
0
Fork 0
Code Issues Pull Requests Releases Activity
7e2d107a0d
perl/perl-5.10.0-ArchiveTar1.40.patch
Marcela Mašláňová 26f4e8d424 - 295021 CVE-2007-4829 perl-Archive-Tar directory traversal flaws 
- add another source for binary files, which test untaring links
2008-12-12 14:37:24 +00:00

1757 lines
59 KiB
Diff
Raw Blame History

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(
Reference in New Issue View Git Blame Copy Permalink