$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.42";
+$VERSION = "1.44";
$CHOWN = 1;
$CHMOD = 1;
$DO_NOT_USE_PREFIX = 0;
The C<read> will I<replace> any previous content in C<$tar>!
-The second argument may be considered optional, but remains for
+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.
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. This means no C<Archive::Tar::File> objects are
+straight to disk. This means no C<Archive::Tar::File> objects are
created for you to inspect.
=back
$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 );
+ sysread( $tmp, $magic, 4 );
close $tmp;
}
### 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
+ ($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 {
);
return;
};
-
+
} else {
$fh = IO::Compress::Bzip2->new( $file ) or do {
$self->_error( qq[Could not write to '$file': ] .
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;
$self->_error(qq[Could not create filehandle for '$file': $!]);
return;
}
-
+
### is it plain tar?
} else {
$fh = IO::File->new;
### enable bin mode on tar archives
binmode $fh;
- }
+ }
}
return $fh;
my $entry;
{ my %extra_args = ();
$extra_args{'name'} = $$real_name if defined $real_name;
-
- unless( $entry = Archive::Tar::File->new( chunk => $chunk,
- %extra_args )
+
+ unless( $entry = Archive::Tar::File->new( chunk => $chunk,
+ %extra_args )
) {
$self->_error( qq[Couldn't read chunk at offset $offset] );
next LOOP;
### 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
+ ### 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
sub contains_file {
my $self = shift;
my $full = shift;
-
+
return unless defined $full;
### don't warn if the entry isn't there.. that's what this function
### you requested the extraction of only certian files
if( @args ) {
for my $file ( @args ) {
-
+
### it's already an object?
if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
push @files, $file;
### go find it then
} else {
-
+
my $found;
for my $entry ( @{$self->_data} ) {
next unless $file eq $entry->full_path;
-
+
### we found the file you're looking for
push @files, $entry;
$found++;
}
-
+
unless( $found ) {
- return $self->_error(
+ return $self->_error(
qq[Could not find '$file' in archive] );
}
}
### absolute names are not allowed to be in tarballs under
### strict mode, so only allow it if a user tells us to do it
if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
- $self->_error(
+ $self->_error(
q[Entry ']. $entry->full_path .q[' is an absolute path. ].
q[Not extracting absolute paths under SECURE EXTRACT MODE]
- );
+ );
return;
}
-
+
### user asked us to, it's fine.
$dir = File::Spec->catpath( $vol, $dirs, "" );
### it's a relative path ###
} else {
- my $cwd = (ref $self and defined $self->{cwd})
- ? $self->{cwd}
+ my $cwd = (ref $self and defined $self->{cwd})
+ ? $self->{cwd}
: cwd();
my @dirs = defined $alt
: File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely
# straight from the tarball
- if( not defined $alt and
- not $INSECURE_EXTRACT_MODE
- ) {
+ if( not defined $alt and
+ 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
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};
);
return;
}
-
+
### XXX keep a cache if possible, so the stats become cheaper:
$self->{_link_cache}->{$full_path} = 1 if ref $self;
}
### or changed to '_' on vms. vmsify is used, because older versions
### of vmspath do not handle this properly.
### Must not add a '/' to an empty directory though.
- map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;
+ map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;
- my ($cwd_vol,$cwd_dir,$cwd_file)
+ my ($cwd_vol,$cwd_dir,$cwd_file)
= File::Spec->splitpath( $cwd );
my @cwd = File::Spec->splitdir( $cwd_dir );
push @cwd, $cwd_file if length $cwd_file;
### We need to pass '' as the last elemant to catpath. Craig Berry
### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
- ### The root problem is that splitpath on UNIX always returns the
+ ### The root problem is that splitpath on UNIX always returns the
### final path element as a file even if it is a directory, and of
### course there is no way it can know the difference without checking
### against the filesystem, which it is documented as not doing. When
### know the result should be a directory. I had thought you could omit
### the file argument to catpath in such a case, but apparently on UNIX
### you can't.
- $dir = File::Spec->catpath(
- $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
+ $dir = File::Spec->catpath(
+ $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
);
- ### catdir() returns undef if the path is longer than 255 chars on
+ ### catdir() returns undef if the path is longer than 255 chars on
### older VMS systems.
unless ( defined $dir ) {
$^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
$self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
return;
}
-
+
### XXX chown here? that might not be the same as in the archive
### as we're only chown'ing to the owner of the file we're extracting
### not to the owner of the directory itself, which may or may not
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).
+GLOB reference).
-The second argument is used to indicate compression. You can either
+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
+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
+ # write a bzip compressed file
$tar->write( 'out.tbz', COMPRESSION_BZIP );
Note that when you pass in a filehandle, the compression argument
my $gzip = shift || 0;
my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
my $dummy = '';
-
+
### only need a handle if we have a file to print to ###
my $handle = length($file)
? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
or return )
: $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h }
- : $HAS_IO_STRING ? IO::String->new
+ : $HAS_IO_STRING ? IO::String->new
: __PACKAGE__->no_string_support();
-
+ ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a
+ ### corrupt TAR file. Must clear out $\ to make sure no garbage is
+ ### printed to the archive
+ local $\;
for my $entry ( @{$self->_data} ) {
### entries to be written to the tarfile ###
my $clone = $entry->clone;
- ### so, if you don't want use to use the prefix, we'll stuff
+ ### so, if you don't want use to use the prefix, we'll stuff
### everything in the name field instead
if( $DO_NOT_USE_PREFIX ) {
### make sure to close the handle;
close $handle;
-
+
return $rv;
}
### clone it so we don't accidentally have a reference to
### an object from another archive
if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) {
- push @rv, $file->clone;
+ push @rv, $file->clone;
next;
}
-
+
unless( -e $file || -l $file ) {
$self->_error( qq[No such file: '$file'] );
next;
=head2 $tar->setcwd( $cwd );
C<Archive::Tar> needs to know the current directory, and it will run
-C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
+C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
tarfile and saves it in the file system. (As of version 1.30, however,
-C<Archive::Tar> will use the speed optimization described below
+C<Archive::Tar> will use the speed optimization described below
automatically, so it's only relevant if you're using C<extract_file()>).
Since C<Archive::Tar> doesn't change the current directory internally
once before calling a function like C<extract_file> and
C<Archive::Tar> will use the current directory setting from then on
-and won't call C<Cwd::cwd()> internally.
+and won't call C<Cwd::cwd()> internally.
To switch back to the default behaviour, use
If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
be called for you.
-=cut
+=cut
sub setcwd {
my $self = shift;
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 is used to indicate compression. You can either
+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
+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
+ # 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
print $f->name, "\n";
$f->extract or warn "Extraction failed";
-
+
# ....
}
### get a handle to read from.
my $handle = $class->_get_handle(
- $filename,
- $compressed,
+ $filename,
+ $compressed,
READ_ONLY->( ZLIB )
) or return;
### return one piece of data
return shift(@data) if @data;
-
+
### data is exhausted, free the filehandle
undef $handle;
return;
If C<list_archive()> is passed an array reference as its third
argument it returns a list of hash references containing the requested
properties of each file. The following list of properties is
-supported: full_path, name, size, mtime (last modified date), mode,
+supported: full_path, name, size, mtime (last modified date), mode,
uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
See C<Archive::Tar::File> for details about supported properties.
Returns true if we currently have C<IO::String> support loaded.
-Either C<IO::String> or C<perlio> support is needed to support writing
+Either C<IO::String> or C<perlio> support is needed to support writing
stringified archives. Currently, C<perlio> is the preferred method, if
available.
Returns true if we currently have C<perlio> support loaded.
-This requires C<perl-5.8> or higher, compiled with C<perlio>
+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
+Either C<IO::String> or C<perlio> support is needed to support writing
stringified archives. Currently, C<perlio> is the preferred method, if
available.
=head2 $Archive::Tar::DO_NOT_USE_PREFIX
-By default, C<Archive::Tar> will try to put paths that are over
+By default, C<Archive::Tar> will try to put paths that are over
100 characters in the C<prefix> field of your tar header, as
-defined per POSIX-standard. However, some (older) tar programs
-do not implement this spec. To retain compatibility with these older
-or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
-variable to a true value, and C<Archive::Tar> will use an alternate
-way of dealing with paths over 100 characters by using the
+defined per POSIX-standard. However, some (older) tar programs
+do not implement this spec. To retain compatibility with these older
+or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
+variable to a true value, and C<Archive::Tar> will use an alternate
+way of dealing with paths over 100 characters by using the
C<GNU Extended Header> feature.
Note that clients who do not support the C<GNU Extended Header>
Allowing this could have security implications, as a malicious
tar archive could alter or replace any file the extracting user
-has permissions to. Therefor, the default is to not allow
-insecure extractions.
+has permissions to. Therefor, the default is to not allow
+insecure extractions.
-If you trust the archive, or have other reasons to allow the
-archive to write files outside your current working directory,
+If you trust the archive, or have other reasons to allow the
+archive to write files outside your current working directory,
set this variable to C<true>.
Note that this is a backwards incompatible change from version
=head2 $Archive::Tar::HAS_PERLIO
-This variable holds a boolean indicating if we currently have
+This variable holds a boolean indicating if we currently have
C<perlio> support loaded. This will be enabled for any perl
-greater than C<5.8> compiled with C<perlio>.
+greater than C<5.8> compiled with C<perlio>.
If you feel strongly about disabling it, set this variable to
C<false>. Note that you will then need C<IO::String> installed
=head2 $Archive::Tar::HAS_IO_STRING
-This variable holds a boolean indicating if we currently have
+This variable holds a boolean indicating if we currently have
C<IO::String> support loaded. This will be enabled for any perl
that has a loadable C<IO::String> module.
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 the C<iter> class method, or C</bin/tar>
+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?
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, including C<iter>
-on archives that have incompatible filetypes and still expect things
+(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
C<POSIX header prefix>. Non-POSIX-compatible clients may not support
this part of the specification, and may only support the C<GNU Extended
Header> functionality. To facilitate those clients, you can set the
-C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
+C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
C<GLOBAL VARIABLES> section for details on this variable.
Note that GNU tar earlier than version 1.14 does not cope well with
based on your criteria. For example, to extract only files that have
the string C<foo> in their title, you would use:
- $tar->extract(
+ $tar->extract(
grep { $_->full_path =~ /foo/ } $tar->get_files
- );
+ );
This way, you can filter on any attribute of the files in the archive.
Consult the C<Archive::Tar::File> documentation on how to use these
$tar->add_data('file.txt', $data);
-A opposite problem occurs if you extract a UTF8-encoded file from a
+A opposite problem occurs if you extract a UTF8-encoded file from a
tarball. Using C<get_content()> on the C<Archive::Tar::File> object
will return its content as a bytestring, not as a Unicode string.
If you want it to be a Unicode string (because you want character
semantics with operations like regular expression matching), you need
-to decode the UTF8-encoded content and have Perl convert it into
+to decode the UTF8-encoded content and have Perl convert it into
a Unicode string:
use Encode;
my $data = $tar->get_content();
-
+
# Make it a Unicode string
$data = decode('utf8', $data);
-There is no easy way to provide this functionality in C<Archive::Tar>,
+There is no easy way to provide this functionality in C<Archive::Tar>,
because a tarball can contain many files, and each of which could be
encoded in a different way.
=head1 COPYRIGHT
-This module is copyright (c) 2002 - 2008 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
+This library is free software; you may redistribute and/or modify
it under the same terms as Perl itself.
=cut
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
- }
+ }
use lib '../../..';
}
my @ROOT = grep { length } 'src', $TOO_LONG ? 'short' : 'long';
my $NO_UNLINK = $ARGV[0] ? 1 : 0;
-### enable debugging?
+### enable debugging?
### pesky warnings
$Archive::Tar::DEBUG = $Archive::Tar::DEBUG = 1 if $ARGV[1];
{ for my $meth ( qw[has_zlib_support has_bzip2_support] ) {
can_ok( $Class, $meth );
}
-}
+}
### check if ->error eq $error
is( $tar->error, $Archive::Tar::error,
"Error '$Archive::Tar::error' matches $Class->error method" );
-
- ### check that 'contains_file' doesn't warn about missing files.
+
+ ### check that 'contains_file' doesn't warn about missing files.
{ ### turn on warnings in general!
local $Archive::Tar::WARN = 1;
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= "@_" };
-
+
my $rv = $tar->contains_file( $$ );
ok( !$rv, "Does not contain file '$$'" );
is( $warnings, '', " No warnings issued during lookup" );
- }
+ }
}
### read tests ###
is( $tar->_find_entry( $test ), $file,
" Found proper object" );
}
-
+
next unless $file->is_file;
my $name = $file->full_path;
skip( "You are building perl using symlinks", 1)
if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/);
- is( $files[0]->is_file, 1,
+ is( $files[0]->is_file, 1,
" Proper type" );
}
" Adding dirs");
ok( $dirs[0]->is_dir, " Proper type" );
}
-
+
### check if we can add a A::T::File object
{ my $tar2 = $Class->new;
my($added) = $tar2->add_files( $add[0] );
-
+
ok( $added, " Added a file '$add[0]' to new object" );
- isa_ok( $added, $FClass, " Object" );
+ isa_ok( $added, $FClass, " Object" );
my($added2) = $tar2->add_files( $added );
ok( $added2, " Added an $FClass object" );
- isa_ok( $added2, $FClass, " Object" );
-
+ isa_ok( $added2, $FClass, " Object" );
+
is_deeply( [$added, $added2], [$tar2->get_files],
" All files accounted for" );
isnt( $added, $added2, " Different memory allocations" );
- }
+ }
}
### add data tests ###
### write + read + extract tests ###
SKIP: { ### pesky warnings
- skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO &&
- !$Archive::Tar::HAS_PERLIO &&
+ 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 = $Class->new;
my $new = $Class->new;
ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
### write tar tests
{ my $out = $OUT_TAR_FILE;
+ ### bug #41798: 'Nonempty $\ when writing a TAR file produces a
+ ### corrupt TAR file' shows that setting $\ breaks writing tar files
+ ### set it here purposely so we can verify NOTHING breaks
+ local $\ = 'FOOBAR';
+
{ ### write()
ok( $obj->write($out),
" Wrote tarfile using 'write'" );
{ 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 ) {
my( $out, $compression ) = @$entry;
close $fh;
$NO_UNLINK or 1 while unlink $path;
- ### alternate extract path tests
+ ### alternate extract path tests
### to abs and rel paths
{ for my $outpath ( File::Spec->catdir( @ROOT ),
- File::Spec->rel2abs(
+ File::Spec->rel2abs(
File::Spec->catdir( @ROOT )
)
) {
my $outfile = File::Spec->catfile( $outpath, $$ );
-
+
ok( $tar->extract_file( $file->full_path, $outfile ),
" Extracted file '$path' to $outfile" );
ok( -e $outfile," Extracted file '$outfile' exists" );
-
+
rm( $outfile ) unless $NO_UNLINK;
- }
+ }
}
}
sub slurp_compressed_file {
my $file = shift;
my $fh;
-
+
### bzip2
if( $file =~ /.tbz$/ ) {
require IO::Uncompress::Bunzip2;
- $fh = IO::Uncompress::Bunzip2->new( $file )
+ $fh = IO::Uncompress::Bunzip2->new( $file )
or warn( "Error opening '$file' with IO::Uncompress::Bunzip2" ), return
### gzip
$fh = new IO::Zlib;
$fh->open( $file, READ_ONLY->(1) )
or warn( "Error opening '$file' with IO::Zlib" ), return
- }
+ }
my $str;
my $buff;
projects / p5sagit/p5-mst-13.2.git / commitdiff