CPANPLUS
view release on metacpan or search on metacpan
inc/bundle/Archive/Tar.pm view on Meta::CPAN
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 $SAME_PERMISSIONS
$INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT $RESOLVE_SYMLINK
$EXTRACT_BLOCK_SIZE
];
@ISA = qw[Exporter];
@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP COMPRESS_XZ ];
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
$VERSION = "3.02";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
$DO_NOT_USE_PREFIX = 0;
$INSECURE_EXTRACT_MODE = 0;
$ZERO_PAD_NUMBERS = 0;
$RESOLVE_SYMLINK = $ENV{'PERL5_AT_RESOLVE_SYMLINK'} || 'speed';
$EXTRACT_BLOCK_SIZE = 1024 * 1024 * 1024;
BEGIN {
use Config;
$HAS_PERLIO = $Config::Config{useperlio};
### try and load IO::String anyway, so you can dynamically
### switch between perlio and IO::String
$HAS_IO_STRING = eval {
require IO::String;
IO::String->import;
1;
} || 0;
}
=head1 NAME
Archive::Tar - module for manipulations of tar archives
=head1 SYNOPSIS
use Archive::Tar;
my $tar = Archive::Tar->new;
$tar->read('origin.tgz');
$tar->extract();
$tar->add_files('file/foo.pl', 'docs/README');
$tar->add_data('file/baz.txt', 'This is the contents now');
$tar->rename('oldname', 'new/file/name');
$tar->chown('/', 'root');
$tar->chown('/', 'root:root');
$tar->chmod('/tmp', '1777');
$tar->write('files.tar'); # plain tar
$tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed
$tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed
$tar->write('files.txz', COMPRESS_XZ); # xz compressed
=head1 DESCRIPTION
Archive::Tar provides an object oriented mechanism for handling tar
files. It provides class methods for quick and easy files handling
while also allowing for the creation of tar file objects for custom
manipulation. If you have the IO::Zlib module installed,
Archive::Tar will also support compressed or gzipped tar files.
An object of class Archive::Tar represents a .tar(.gz) archive full
of files and things.
=head1 Object Methods
=head2 Archive::Tar->new( [$file, $compressed] )
Returns a new Tar object. If given any arguments, C<new()> calls the
C<read()> method automatically, passing on the arguments provided to
the C<read()> method.
If C<new()> is invoked with arguments and the C<read()> method fails
for any reason, C<new()> returns undef.
=cut
my $tmpl = {
_data => [ ],
_file => 'Unknown',
};
### install get/set accessors for this object.
for my $key ( keys %$tmpl ) {
no strict 'refs';
*{__PACKAGE__."::$key"} = sub {
my $self = shift;
$self->{$key} = $_[0] if @_;
return $self->{$key};
}
}
sub new {
my $class = shift;
$class = ref $class if ref $class;
### copying $tmpl here since a shallow copy makes it use the
### same aref, causing for files to remain in memory always.
my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class;
if (@_) {
unless ( $obj->read( @_ ) ) {
$obj->_error(qq[No data could be read from file]);
return;
}
}
inc/bundle/Archive/Tar.pm view on Meta::CPAN
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 on VMS, which has to be escaped
### 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;
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 element to catpath. Craig Berry
### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
### 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
### you turn around and call catpath, on VMS you have to know which bits
### are directory bits and which bits are file bits. In this case we
### 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 ), ''
);
### 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] );
return;
}
}
if( -e $dir && !-d _ ) {
$^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
return;
}
unless ( -d _ ) {
eval { File::Path::mkpath( $dir, 0, 0777 ) };
if( $@ ) {
my $fp = $entry->full_path;
$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
### be another entry in the archive
### Answer: no, gnu tar doesn't do it either, it'd be the wrong
### way to go.
#if( $CHOWN && CAN_CHOWN ) {
# chown $entry->uid, $entry->gid, $dir or
# $self->_error( qq[Could not set uid/gid on '$dir'] );
#}
}
### we're done if we just needed to create a dir ###
return 1 if $entry->is_dir;
my $full = File::Spec->catfile( $dir, $file );
if( $entry->is_unknown ) {
$self->_error( qq[Unknown file type for file '$full'] );
return;
}
### If a file system already contains a block device with the same name as
### the being extracted regular file, we would write the file's content
### to the block device. So remove the existing file (block device) now.
### If an archive contains multiple same-named entries, the last one
### should replace the previous ones. So remove the old file now.
### If the old entry is a symlink to a file outside of the CWD, the new
### entry would create a file there. This is CVE-2018-12015
### <https://rt.cpan.org/Ticket/Display.html?id=125523>.
if (-l $full || -e _) {
if (!unlink $full) {
$self->_error( qq[Could not remove old file '$full': $!] );
return;
}
}
if( length $entry->type && $entry->is_file ) {
my $fh = IO::File->new;
$fh->open( $full, '>' ) or (
$self->_error( qq[Could not open file '$full': $!] ),
return
);
if( $entry->size ) {
binmode $fh;
my $offset = 0;
my $content = $entry->get_content_by_ref();
while ($offset < $entry->size) {
my $written
= syswrite $fh, $$content, $EXTRACT_BLOCK_SIZE, $offset;
if (defined $written) {
$offset += $written;
} else {
$self->_error( qq[Could not write data to '$full': $!] );
return;
}
}
}
close $fh or (
$self->_error( qq[Could not close file '$full'] ),
return
);
} else {
$self->_make_special_file( $entry, $full ) or return;
}
### 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->() and not -l $full ) {
CORE::chown( $entry->uid, $entry->gid, $full ) or
$self->_error( qq[Could not set uid/gid on '$full'] );
}
### only chmod if we're allowed to, but never chmod symlinks, since they'll
### change the perms on the file they're linking too...
if( $CHMOD and not -l $full ) {
my $mode = $entry->mode;
unless ($SAME_PERMISSIONS) {
$mode &= ~(oct(7000) | umask);
}
CORE::chmod( $mode, $full ) or
$self->_error( qq[Could not chown '$full' to ] . $entry->mode );
}
return 1;
}
sub _make_special_file {
my $self = shift;
my $entry = shift or return;
my $file = shift; return unless defined $file;
my $err;
if( $entry->is_symlink ) {
my $fail;
if( ON_UNIX ) {
symlink( $entry->linkname, $file ) or $fail++;
} else {
$self->_extract_special_file_as_plain_file( $entry, $file )
or $fail++;
}
$err = qq[Making symbolic link '$file' to '] .
$entry->linkname .q[' failed] if $fail;
} elsif ( $entry->is_hardlink ) {
my $fail;
if( ON_UNIX ) {
link( $entry->linkname, $file ) or $fail++;
} else {
$self->_extract_special_file_as_plain_file( $entry, $file )
or $fail++;
}
$err = qq[Making hard link from '] . $entry->linkname .
qq[' to '$file' failed] if $fail;
} elsif ( $entry->is_fifo ) {
ON_UNIX && !system('mknod', $file, 'p') or
$err = qq[Making fifo ']. $entry->name .qq[' failed];
} elsif ( $entry->is_blockdev or $entry->is_chardev ) {
my $mode = $entry->is_blockdev ? 'b' : 'c';
ON_UNIX && !system('mknod', $file, $mode,
$entry->devmajor, $entry->devminor) or
$err = qq[Making block device ']. $entry->name .qq[' (maj=] .
$entry->devmajor . qq[ min=] . $entry->devminor .
qq[) failed.];
} elsif ( $entry->is_socket ) {
### the original doesn't do anything special for sockets.... ###
1;
}
return $err ? $self->_error( $err ) : 1;
}
### don't know how to make symlinks, let's just extract the file as
inc/bundle/Archive/Tar.pm view on Meta::CPAN
sub get_content {
my $self = shift;
my $entry = $self->_find_entry( shift ) or return;
return $entry->data;
}
=head2 $tar->replace_content( $file, $content )
Make the string $content be the content for the file named $file.
=cut
sub replace_content {
my $self = shift;
my $entry = $self->_find_entry( shift ) or return;
return $entry->replace_content( shift );
}
=head2 $tar->rename( $file, $new_name )
Rename the file of the in-memory archive to $new_name.
Note that you must specify a Unix path for $new_name, since per tar
standard, all files in the archive must be Unix paths.
Returns true on success and false on failure.
=cut
sub rename {
my $self = shift;
my $file = shift; return unless defined $file;
my $new = shift; return unless defined $new;
my $entry = $self->_find_entry( $file ) or return;
return $entry->rename( $new );
}
=head2 $tar->chmod( $file, $mode )
Change mode of $file to $mode.
Returns true on success and false on failure.
=cut
sub chmod {
my $self = shift;
my $file = shift; return unless defined $file;
my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
my @args = ("$mode");
my $entry = $self->_find_entry( $file ) or return;
my $x = $entry->chmod( @args );
return $x;
}
=head2 $tar->chown( $file, $uname [, $gname] )
Change owner $file to $uname and $gname.
Returns true on success and false on failure.
=cut
sub chown {
my $self = shift;
my $file = shift; return unless defined $file;
my $uname = shift; return unless defined $uname;
my @args = ($uname);
push(@args, shift);
my $entry = $self->_find_entry( $file ) or return;
my $x = $entry->chown( @args );
return $x;
}
=head2 $tar->remove (@filenamelist)
Removes any entries with names matching any of the given filenames
from the in-memory archive. Returns a list of C<Archive::Tar::File>
objects that remain.
=cut
sub remove {
my $self = shift;
my @list = @_;
my %seen = map { $_->full_path => $_ } @{$self->_data};
delete $seen{ $_ } for @list;
$self->_data( [values %seen] );
return values %seen;
}
=head2 $tar->clear
C<clear> clears the current in-memory archive. This effectively gives
you a 'blank' object, ready to be filled again. Note that C<clear>
only has effect on the object, not the underlying tarfile.
=cut
sub clear {
my $self = shift or return;
$self->_data( [] );
$self->_file( '' );
return 1;
}
=head2 $tar->write ( [$file, $compressed, $prefix] )
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).
The second argument is used to indicate compression. You can
compress using C<gzip>, C<bzip2> or C<xz>. 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 preferred:
# write a gzip compressed file
$tar->write( 'out.tgz', COMPRESS_GZIP );
# write a bzip compressed file
$tar->write( 'out.tbz', COMPRESS_BZIP );
# write a xz compressed file
$tar->write( 'out.txz', COMPRESS_XZ );
inc/bundle/Archive/Tar.pm view on Meta::CPAN
C<IO::Compress::Bzip2> and C<IO::Compress::Xz> 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
C<read> method.
=cut
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");
}
sub _symlinks_resolver{
my ($src, $trg) = @_;
my @src = split /[\/\\]/, $src;
my @trg = split /[\/\\]/, $trg;
pop @src; #strip out current object name
if(@trg and $trg[0] eq ''){
shift @trg;
#restart path from scratch
@src = ( );
}
foreach my $part ( @trg ){
next if $part eq '.'; #ignore current
if($part eq '..'){
#got to parent
pop @src;
}
else{
#append it
push @src, $part;
}
}
my $path = join('/', @src);
warn "_symlinks_resolver('$src','$trg') = $path" if $DEBUG;
return $path;
}
1;
__END__
=head1 GLOBAL VARIABLES
=head2 $Archive::Tar::FOLLOW_SYMLINK
Set this variable to C<1> to make C<Archive::Tar> effectively make a
copy of the file when extracting. Default is C<0>, which
means the symlink stays intact. Of course, you will have to pack the
file linked to as well.
This option is checked when you write out the tarfile using C<write>
or C<create_archive>.
This works just like C</bin/tar>'s C<-h> option.
=head2 $Archive::Tar::CHOWN
By default, C<Archive::Tar> will try to C<chown> your files if it is
able to. In some cases, this may not be desired. In that case, set
this variable to C<0> to disable C<chown>-ing, even if it were
possible.
The default is C<1>.
=head2 $Archive::Tar::CHMOD
By default, C<Archive::Tar> will try to C<chmod> your files to
whatever mode was specified for the particular file in the archive.
In some cases, this may not be desired. In that case, set this
variable to C<0> to disable C<chmod>-ing.
The default is C<1>.
=head2 $Archive::Tar::SAME_PERMISSIONS
When, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether
the permissions on files from the archive are used without modification
of if they are filtered by removing any setid bits and applying the
current umask.
The default is C<1> for the root user and C<0> for normal users.
=head2 $Archive::Tar::DO_NOT_USE_PREFIX
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
C<GNU Extended Header> feature.
Note that clients who do not support the C<GNU Extended Header>
feature will not be able to read these archives. Such clients include
tars on C<Solaris>, C<Irix> and C<AIX>.
The default is C<0>.
=head2 $Archive::Tar::DEBUG
Set this variable to C<1> to always get the C<Carp::longmess> output
of the warnings, instead of the regular C<carp>. This is the same
message you would get by doing:
$tar->error(1);
Defaults to C<0>.
=head2 $Archive::Tar::WARN
Set this variable to C<0> if you do not want any warnings printed.
Personally I recommend against doing this, but people asked for the
option. Also, be advised that this is of course not threadsafe.
Defaults to C<1>.
=head2 $Archive::Tar::error
Holds the last reported error. Kept for historical reasons, but its
( run in 0.813 second using v1.01-cache-2.11-cpan-71847e10f99 )