CPANPLUS
view release on metacpan or search on metacpan
inc/bundle/Archive/Tar.pm view on Meta::CPAN
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
### 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;
}
inc/bundle/Archive/Tar.pm view on Meta::CPAN
sub get_files {
my $self = shift;
return @{ $self->_data } unless @_;
my @list;
for my $file ( @_ ) {
push @list, grep { defined } $self->_find_entry( $file );
}
return @list;
}
=head2 $tar->get_content( $file )
Return the content of the named file.
=cut
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;
}
inc/bundle/Archive/Tar.pm view on Meta::CPAN
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
use is very much discouraged. Use the C<error()> method instead:
warn $tar->error unless $tar->extract;
Note that in older versions of this module, the C<error()> method
would return an effectively global value even when called an instance
method as above. This has since been fixed, and multiple instances of
C<Archive::Tar> now have separate error strings.
=head2 $Archive::Tar::INSECURE_EXTRACT_MODE
( run in 1.297 second using v1.01-cache-2.11-cpan-39bf76dae61 )