summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive/Tar/File.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar/File.pm115
1 files changed, 85 insertions, 30 deletions
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
index 8604ab83247..9067de10863 100644
--- a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
@@ -13,26 +13,27 @@ use Archive::Tar::Constant;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '1.76';
+$VERSION = '1.82';
### set value to 1 to oct() it during the unpack ###
+
my $tmpl = [
- name => 0, # string
- mode => 1, # octal
- uid => 1, # octal
- gid => 1, # octal
- size => 1, # octal
- mtime => 1, # octal
- chksum => 1, # octal
- type => 0, # character
- linkname => 0, # string
- magic => 0, # string
- version => 0, # 2 bytes
- uname => 0, # string
- gname => 0, # string
- devmajor => 1, # octal
- devminor => 1, # octal
- prefix => 0,
+ 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
+ devminor => 1, # octal A8
+ prefix => 0, # A155 x 12
### end UNPACK items ###
raw => 0, # the raw data chunk
@@ -214,8 +215,20 @@ sub _new_from_chunk {
### makes it start at 0 actually... :) ###
my $i = -1;
my %entry = map {
- $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
- } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
+ my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
+ ($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
+ $s=> $v ? oct $_ : $_ # cdrake
+ # $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
+ } unpack( UNPACK, $chunk ); # cdrake
+ # } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
+
+
+ if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
+ my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikley to ever be needed - the numbers are just too big...) # cdrake
+ } else { # cdrake
+ ($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
+ } # cdrake
+
my $obj = bless { %entry, %args }, $class;
@@ -236,23 +249,23 @@ sub _new_from_chunk {
sub _new_from_file {
my $class = shift;
- my $path = shift;
-
+ my $path = shift;
+
### path has to at least exist
return unless defined $path;
-
+
my $type = __PACKAGE__->_filetype($path);
my $data = '';
- READ: {
+ READ: {
unless ($type == DIR ) {
my $fh = IO::File->new;
-
+
unless( $fh->open($path) ) {
### dangling symlinks are fine, stop reading but continue
### creating the object
last READ if $type == SYMLINK;
-
+
### otherwise, return from this function --
### anything that's *not* a symlink should be
### resolvable
@@ -405,7 +418,7 @@ sub _prefix_and_file {
sub _filetype {
my $self = shift;
my $file = shift;
-
+
return unless defined $file;
return SYMLINK if (-l $file); # Symlink
@@ -442,7 +455,7 @@ sub _downgrade_to_plainfile {
=head2 $bool = $file->extract( [ $alternative_name ] )
-Extract this object, optionally to an alternative name.
+Extract this object, optionally to an alternative name.
See C<< Archive::Tar->extract_file >> for details.
@@ -452,9 +465,9 @@ Returns true on success and false on failure.
sub extract {
my $self = shift;
-
+
local $Carp::CarpLevel += 1;
-
+
return Archive::Tar->_extract_file( $self, @_ );
}
@@ -576,7 +589,7 @@ Returns true on success and false on failure.
sub rename {
my $self = shift;
my $path = shift;
-
+
return unless defined $path;
my ($prefix,$file) = $self->_prefix_and_file( $path );
@@ -587,6 +600,48 @@ sub rename {
return 1;
}
+=head2 $bool = $file->chmod $mode)
+
+Change mode of $file to $mode. The mode can be a string or a number
+which is interpreted as octal whether or not a leading 0 is given.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chmod {
+ my $self = shift;
+ my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
+ $self->{mode} = oct($mode);
+ return 1;
+}
+
+=head2 $bool = $file->chown( $user [, $group])
+
+Change owner of $file to $user. If a $group is given that is changed
+as well. You can also pass a single parameter with a colon separating the
+use and group as in 'root:wheel'.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chown {
+ my $self = shift;
+ my $uname = shift;
+ return unless defined $uname;
+ my $gname;
+ if (-1 != index($uname, ':')) {
+ ($uname, $gname) = split(/:/, $uname);
+ } else {
+ $gname = shift if @_ > 0;
+ }
+
+ $self->uname( $uname );
+ $self->gname( $gname ) if $gname;
+ return 1;
+}
+
=head1 Convenience methods
To quickly check the type of a C<Archive::Tar::File> object, you can