Archive-Tar
view release on metacpan or search on metacpan
FAQ patch
1.32 25/7/2007:
- Apply #28407: Unicode and Archive::Tar - documentation patch as
FAQ patch
- Following a report from rgs that A::T 1.31 doesn't play nicely
with -Dmksymlinks under perl core, rewrite the symlink logic in
A::T::File->new to continue building an object when reading a
symlink fails, rather than refusing to read on a symlink (which
is obviously wrong)
- Quell warnings when a gid is not resolvable to a group name
1.31 18/5/2007:
- No longer use the t/setup.t and t/cleanup.t files but just bundle
the binary files; this was done for core integration, but the new
uupacktool.pl script means we dont have to do this anymore
_ Apply core perl Change 30997 by rgs@stcosmo on 2007/04/20 15:03:57
- Address: #27124: Unneeded warning sent when checking for file
inclusion contains_file() will no longer warn to STDERR when a file
is not contained in an archive and $WARN is set to 'true'.
- Address #26492: Dangling symlinks not preserved: Archive::Tar used
lib/Archive/Tar.pm view on Meta::CPAN
### 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(
lib/Archive/Tar.pm view on Meta::CPAN
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'] );
lib/Archive/Tar.pm view on Meta::CPAN
### 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 and not ( $entry->is_hardlink and ON_UNIX and $EXTRACT_HARDLINK ) ) {
utime time, $entry->mtime - TIME_OFFSET, $full or
$self->_error( qq[Could not update timestamp] );
}
if( $CHOWN && CAN_CHOWN->() and not -l $full and not ( $entry->is_hardlink and ON_UNIX and $EXTRACT_HARDLINK ) ) {
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 and not ( $entry->is_hardlink and ON_UNIX and $EXTRACT_HARDLINK ) ) {
my $mode = $entry->mode;
unless ($SAME_PERMISSIONS) {
$mode &= ~(oct(7000) | umask);
}
CORE::chmod( $mode, $full ) or
lib/Archive/Tar.pm view on Meta::CPAN
return $self->_error($err);
}
=head2 $tar->list_files( [\@properties] )
Returns a list of the names of all the files in the archive.
If C<list_files()> is passed an array reference as its first argument
it returns a list of hash references containing the requested
properties of each file. The following list of properties is
supported: name, size, mtime (last modified date), mode, uid, gid,
linkname, uname, gname, devmajor, devminor, prefix.
Passing an array reference containing only one element, 'name', is
special cased to return a list of names rather than a list of hash
references, making it equivalent to calling C<list_files> without
arguments.
=cut
sub list_files {
lib/Archive/Tar.pm view on Meta::CPAN
my $l = PREFIX_LENGTH; # is ambiguous otherwise...
substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
my $f1 = "%06o"; my $f2 = $ZERO_PAD_NUMBERS ? "%011o" : "%11o";
### this might be optimizable with a 'changed' flag in the file objects ###
my $tar = pack (
PACK,
$file,
(map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
(map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
"", # checksum field - space padded a bit down
(map { $entry->$_() } qw[type linkname magic]),
$entry->version || TAR_VERSION,
(map { $entry->$_() } qw[uname gname]),
(map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
lib/Archive/Tar.pm view on Meta::CPAN
}
=head2 $tar->add_data ( $filename, $data, [$opthashref] )
Takes a filename, a scalar full of data and optionally a reference to
a hash with specific options.
Will add a file to the in-memory archive, with name C<$filename> and
content C<$data>. Specific properties can be set using C<$opthashref>.
The following list of properties is supported: name, size, mtime
(last modified date), mode, uid, gid, linkname, uname, gname,
devmajor, devminor, prefix, type. (On MacOS, the file's path and
modification times are converted to Unix equivalents.)
Valid values for the file type are the following constants defined by
Archive::Tar::Constant:
=over 4
=item FILE
lib/Archive/Tar.pm view on Meta::CPAN
=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
reference to an open file handle (e.g. a GLOB reference).
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,
uid, gid, linkname, uname, gname, devmajor, devminor, prefix, type.
See C<Archive::Tar::File> for details about supported properties.
Passing an array reference containing only one element, 'name', is
special cased to return a list of names rather than a list of hash
references.
=cut
sub list_archive {
lib/Archive/Tar/Constant.pm view on Meta::CPAN
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;
use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
# Pointless assignment to make -w shut up
my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
use constant UID => $>;
use constant GID => (split ' ', $) )[0];
use constant MODE => do { 0666 & (0777 & ~umask) };
use constant STRIP_MODE => sub { shift() & 0777 };
use constant CHECK_SUM => " ";
use constant UNPACK => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
use constant NAME_LENGTH => 100;
lib/Archive/Tar/File.pm view on Meta::CPAN
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
$VERSION = '3.12';
### set value to 1 to oct() it during the unpack ###
my $tmpl = [
name => 0, # string A100
mode => 1, # octal A8
uid => 1, # octal A8
gid => 1, # octal A8
size => 0, # octal # cdrake - not *always* octal.. A12
mtime => 1, # octal A12
chksum => 1, # octal A8
type => 0, # character A1
linkname => 0, # string A100
magic => 0, # string A6
version => 0, # 2 bytes A2
uname => 0, # string A32
gname => 0, # string A32
devmajor => 1, # octal A8
lib/Archive/Tar/File.pm view on Meta::CPAN
The file's name
=item mode
The file's mode
=item uid
The user id owning the file
=item gid
The group id owning the file
=item size
File size in bytes
=item mtime
Modification time. Adjusted to mac-time on MacOS if required
lib/Archive/Tar/File.pm view on Meta::CPAN
return;
}
### binmode needed to read files properly on win32 ###
binmode $fh;
$data = do { local $/; <$fh> };
close $fh;
}
}
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.
lib/Archive/Tar/File.pm view on Meta::CPAN
%hash,
name => '',
chksum => CHECK_SUM,
type => $type,
linkname => ($type == SYMLINK and CAN_READLINK)
? readlink $path
: '',
magic => MAGIC,
version => TAR_VERSION,
uname => UNAME->( $hash{uid} ),
gname => GNAME->( $hash{gid} ),
devmajor => 0, # not handled
devminor => 0, # not handled
prefix => '',
data => $data,
};
bless $obj, $class;
### fix up the prefix and file from the path
my($prefix,$file) = $obj->_prefix_and_file( $path );
lib/Archive/Tar/File.pm view on Meta::CPAN
my $class = shift;
my $path = shift; return unless defined $path;
my $data = shift; return unless defined $data;
my $opt = shift;
my $obj = {
data => $data,
name => '',
mode => MODE,
uid => UID,
gid => GID,
size => length $data,
mtime => time - TIME_OFFSET,
chksum => CHECK_SUM,
type => FILE,
linkname => '',
magic => MAGIC,
version => TAR_VERSION,
uname => UNAME->( UID ),
gname => GNAME->( GID ),
devminor => 0,
t/03_file.t view on Meta::CPAN
[ 'bIn0', '' ],
### we didnt handle 'false' filenames very well across A::T as of version
### 1.32, as reported in #28687. Test for the handling of such files here.
[ 0, '', ],
### keep this one as the last entry
[ 'x/yy/z', '', { type => DIR,
mode => 0777,
uid => 42,
gid => 43,
uname => 'Ford',
gname => 'Prefect',
mtime => $start_time } ],
);
### new( data => ... ) tests ###
for my $f ( @test_files ) {
my $unix_path = $f->[0];
my $contents = $f->[1];
my $attr = $f->[2] || {};
t/03_file.t view on Meta::CPAN
my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr );
isa_ok( $obj, 'Archive::Tar::File', "Object created" );
is( $obj->name, $file, " name '$file' ok" );
is( $obj->prefix, $dir, " prefix '$dir' ok" );
is( $obj->size, length($contents), " size ok" );
is( $obj->mode, exists($attr->{mode}) ? $attr->{mode} : MODE,
" mode ok" );
is( $obj->uid, exists($attr->{uid}) ? $attr->{uid} : UID,
" uid ok" );
is( $obj->gid, exists($attr->{gid}) ? $attr->{gid} : GID,
" gid ok" );
is( $obj->uname, exists($attr->{uname}) ? $attr->{uname} : UNAME->(UID ),
" uname ok" );
is( $obj->gname, exists($attr->{gname}) ? $attr->{gname} : GNAME->( GID ),
" gname ok" );
is( $obj->type, exists($attr->{type}) ? $attr->{type} : FILE,
" type ok" );
if (exists($attr->{mtime})) {
is( $obj->mtime, $attr->{mtime}, " mtime matches" );
} else {
cmp_ok( $obj->mtime, '>', $start_time, " mtime after start time" );
( run in 0.531 second using v1.01-cache-2.11-cpan-ceb78f64989 )