diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive/Tar.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Archive/Tar.pm | 142 |
1 files changed, 101 insertions, 41 deletions
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar.pm b/Master/tlpkg/tlperl/lib/Archive/Tar.pm index 006edbd5c3e..0a35cf77cc7 100644 --- a/Master/tlpkg/tlperl/lib/Archive/Tar.pm +++ b/Master/tlpkg/tlperl/lib/Archive/Tar.pm @@ -23,7 +23,7 @@ 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 @ISA @EXPORT + $INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT ]; @ISA = qw[Exporter]; @@ -31,12 +31,13 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD $DEBUG = 0; $WARN = 1; $FOLLOW_SYMLINK = 0; -$VERSION = "1.54"; +$VERSION = "1.76"; $CHOWN = 1; $CHMOD = 1; $SAME_PERMISSIONS = $> == 0 ? 1 : 0; $DO_NOT_USE_PREFIX = 0; $INSECURE_EXTRACT_MODE = 0; +$ZERO_PAD_NUMBERS = 0; BEGIN { use Config; @@ -211,10 +212,15 @@ sub read { sub _get_handle { my $self = shift; my $file = shift; return unless defined $file; - return $file if ref $file; my $compress = shift || 0; my $mode = shift || READ_ONLY->( ZLIB ); # default to read only + ### Check if file is a file handle or IO glob + if ( ref $file ) { + return $file if eval{ *$file{IO} }; + return $file if eval{ $file->isa(q{IO::Handle}) }; + $file = q{}.$file; + } ### get a FH opened to the right class, so we can use it transparently ### throughout the program @@ -300,6 +306,7 @@ sub _read_tar { my $count = $opts->{limit} || 0; my $filter = $opts->{filter}; + my $filter_cb = $opts->{filter_cb}; my $extract = $opts->{extract} || 0; ### set a cap on the amount of files to extract ### @@ -317,6 +324,7 @@ sub _read_tar { while( $handle->read( $chunk, HEAD ) ) { ### IO::Zlib doesn't support this yet my $offset = eval { tell $handle } || 'unknown'; + $@ = ''; unless( $read++ ) { my $gzip = GZIP_MAGIC_NUM; @@ -343,7 +351,7 @@ sub _read_tar { ### according to the posix spec, the last 12 bytes of the header are ### null bytes, to pad it to a 512 byte block. That means if these - ### bytes are NOT null bytes, it's a corrrupt header. See: + ### bytes are NOT null bytes, it's a corrupt header. See: ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx ### line 111 { my $nulls = join '', "\0" x 12; @@ -369,7 +377,7 @@ sub _read_tar { } ### ignore labels: - ### http://www.gnu.org/manual/tar/html_node/tar_139.html + ### http://www.gnu.org/software/tar/manual/html_chapter/Media.html#SEC159 next if $entry->is_label; if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) { @@ -390,19 +398,56 @@ sub _read_tar { $data = $entry->get_content_by_ref; - ### just read everything into memory - ### can't do lazy loading since IO::Zlib doesn't support 'seek' - ### this is because Compress::Zlib doesn't support it =/ - ### this reads in the whole data in one read() call. - if( $handle->read( $$data, $block ) < $block ) { - $self->_error( qq[Read error on tarfile (missing data) ']. + my $skip = 0; + ### skip this entry if we're filtering + if ($filter && $entry->name !~ $filter) { + $skip = 1; + + ### skip this entry if it's a pax header. This is a special file added + ### by, among others, git-generated tarballs. It holds comments and is + ### not meant for extracting. See #38932: pax_global_header extracted + } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) { + $skip = 2; + } elsif ($filter_cb && ! $filter_cb->($entry)) { + $skip = 3; + } + + if ($skip) { + # + # Since we're skipping, do not allocate memory for the + # whole file. Read it 64 BLOCKS at a time. Do not + # complete the skip yet because maybe what we read is a + # longlink and it won't get skipped after all + # + my $amt = $block; + while ($amt > 0) { + $$data = ''; + my $this = 64 * BLOCK; + $this = $amt if $this > $amt; + if( $handle->read( $$data, $this ) < $this ) { + $self->_error( qq[Read error on tarfile (missing data) ']. + $entry->full_path ."' at offset $offset" ); + next LOOP; + } + $amt -= $this; + } + ### throw away trailing garbage ### + substr ($$data, $entry->size) = "" if defined $$data && $block < 64 * BLOCK; + } else { + + ### just read everything into memory + ### can't do lazy loading since IO::Zlib doesn't support 'seek' + ### this is because Compress::Zlib doesn't support it =/ + ### this reads in the whole data in one read() call. + if ( $handle->read( $$data, $block ) < $block ) { + $self->_error( qq[Read error on tarfile (missing data) ']. $entry->full_path ."' at offset $offset" ); - next LOOP; + next LOOP; + } + ### throw away trailing garbage ### + substr ($$data, $entry->size) = "" if defined $$data; } - ### throw away trailing garbage ### - substr ($$data, $entry->size) = "" if defined $$data; - ### part II of the @LongLink munging -- need to do /after/ ### the checksum check. if( $entry->is_longlink ) { @@ -442,22 +487,24 @@ sub _read_tar { undef $real_name; } - ### skip this entry if we're filtering - if ($filter && $entry->name !~ $filter) { - next LOOP; - - ### skip this entry if it's a pax header. This is a special file added - ### by, among others, git-generated tarballs. It holds comments and is - ### not meant for extracting. See #38932: pax_global_header extracted - } elsif ( $entry->name eq PAX_HEADER ) { - next LOOP; + if ($filter && $entry->name !~ $filter) { + next LOOP; + + ### skip this entry if it's a pax header. This is a special file added + ### by, among others, git-generated tarballs. It holds comments and is + ### not meant for extracting. See #38932: pax_global_header extracted + } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) { + next LOOP; + } elsif ($filter_cb && ! $filter_cb->($entry)) { + next LOOP; + } + + if ( $extract && !$entry->is_longlink + && !$entry->is_unknown + && !$entry->is_label ) { + $self->_extract_file( $entry ) or return; } - $self->_extract_file( $entry ) if $extract - && !$entry->is_longlink - && !$entry->is_unknown - && !$entry->is_label; - ### Guard against tarfiles with garbage at the end last LOOP if $entry->name eq ''; @@ -527,7 +574,7 @@ sub extract { # use the speed optimization for all extracted files local($self->{cwd}) = cwd() unless $self->{cwd}; - ### you requested the extraction of only certian files + ### you requested the extraction of only certain files if( @args ) { for my $file ( @args ) { @@ -708,7 +755,7 @@ sub _extract_file { my @cwd = File::Spec->splitdir( $cwd_dir ); push @cwd, $cwd_file if length $cwd_file; - ### We need to pass '' as the last elemant to catpath. Craig Berry + ### 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 @@ -1082,7 +1129,7 @@ GLOB reference). The second argument is used to indicate compression. You can either compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed to be the C<gzip> compression level (between 1 and 9), but the use of -constants is prefered: +constants is preferred: # write a gzip compressed file $tar->write( 'out.tgz', COMPRESS_GZIP ); @@ -1242,8 +1289,13 @@ sub write { : $HAS_PERLIO ? $dummy : do { seek $handle, 0, 0; local $/; <$handle> }; - ### make sure to close the handle; - close $handle; + ### make sure to close the handle if we created it + if ( $file ne $handle ) { + unless( close $handle ) { + $self->_error( qq[Could not write tar] ); + return; + } + } return $rv; } @@ -1258,7 +1310,7 @@ sub _format_tar_entry { my $prefix = $entry->prefix; $prefix = '' unless defined $prefix; ### remove the prefix from the file name - ### not sure if this is still neeeded --kane + ### not sure if this is still needed --kane ### no it's not -- Archive::Tar::File->_new_from_file will take care of ### this for us. Even worse, this would break if we tried to add a file ### like x/x. @@ -1273,7 +1325,7 @@ sub _format_tar_entry { my $l = PREFIX_LENGTH; # is ambiguous otherwise... substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH; - my $f1 = "%06o"; my $f2 = "%11o"; + 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 ( @@ -1296,6 +1348,7 @@ sub _format_tar_entry { ); ### add the checksum ### + my $checksum_fmt = $ZERO_PAD_NUMBERS ? "%06o\0" : "%06o\0"; substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar)); return $tar; @@ -1497,7 +1550,7 @@ To switch back to the default behaviour, use and C<Archive::Tar> will call C<Cwd::cwd()> internally again. -If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will +If you're using C<Archive::Tar>'s C<extract()> method, C<setcwd()> will be called for you. =cut @@ -1520,7 +1573,7 @@ reference to an open file handle (e.g. a GLOB reference). The second argument is used to indicate compression. You can either compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed to be the C<gzip> compression level (between 1 and 9), but the use of -constants is prefered: +constants is preferred: # write a gzip compressed file Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist ); @@ -1874,6 +1927,13 @@ your perl to be able to write stringified archives. Don't change this variable unless you B<really> know what you're doing. +=head2 $Archive::Tar::ZERO_PAD_NUMBERS + +This variable holds a boolean indicating if we will create +zero padded numbers for C<size>, C<mtime> and C<checksum>. +The default is C<0>, indicating that we will create space padded +numbers. Added for compatibility with C<busybox> implementations. + =head1 FAQ =over 4 @@ -1932,7 +1992,7 @@ the extraction of this particular item didn't work. By default, C<Archive::Tar> is in a completely POSIX-compatible mode, which uses the POSIX-specification of C<tar> to store files. -For paths greather than 100 characters, this is done using the +For paths greater than 100 characters, this is done using the C<POSIX header prefix>. Non-POSIX-compatible clients may not support this part of the specification, and may only support the C<GNU Extended Header> functionality. To facilitate those clients, you can set the @@ -2107,9 +2167,9 @@ to an uploaded file, which might be a compressed archive. C<http://www.gnu.org/software/tar/manual/tar.html> -=item The PAX format specication +=item The PAX format specification -The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html> +The specification which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html> =item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html> |