CPANPLUS
view release on metacpan or search on metacpan
inc/bundle/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(
inc/bundle/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'] );
inc/bundle/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 ) {
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
inc/bundle/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 {
inc/bundle/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]),
inc/bundle/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
inc/bundle/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 {
inc/bundle/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;
inc/bundle/Archive/Tar/File.pm view on Meta::CPAN
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
$VERSION = '3.02';
### 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
inc/bundle/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
inc/bundle/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.
inc/bundle/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 );
inc/bundle/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,
inc/bundle/IPC/Cmd.pm view on Meta::CPAN
kill_gently($child_child_pid);
}
# in case there are forks in child which
# do not forward or process signals (TERM) correctly
# kill whole child process group, effectively trying
# not to return with some children or their parts still running
#
# to be more accurate -- we need to be sure
# that this is process group created by our child
# (and not some other process group with the same pgid,
# created just after death of our child) -- fortunately
# this might happen only when process group ids
# are reused quickly (there are lots of processes
# spawning new process groups for example)
#
if ($opts->{'clean_up_children'}) {
kill(-9, $pid);
}
# print "child $pid finished\n";
inc/bundle/IPC/Cmd.pm view on Meta::CPAN
close($child_info_socket);
my $o = {
'stdout' => $child_stdout,
'stderr' => $child_stderr,
'merged' => $child_merged,
'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
'exit_code' => $child_exit_code,
'parent_died' => $parent_died,
'killed_by_signal' => $child_killed_by_signal,
'child_pgid' => $pid,
'cmd' => $cmd,
};
my $err_msg = '';
if ($o->{'exit_code'}) {
$err_msg .= "exited with code [$o->{'exit_code'}]\n";
}
if ($o->{'timeout'}) {
$err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
}
( run in 1.082 second using v1.01-cache-2.11-cpan-5735350b133 )