diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive/Tar/File.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar/File.pm | 115 |
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 |