Re: [perl #40216] SelfLoader::croak doesn't protect $@ from being clobbered by require
[p5sagit/p5-mst-13.2.git] / lib / Archive / Tar.pm
index 044d9e8..b0f2080 100644 (file)
@@ -1,5 +1,5 @@
 ### the gnu tar specification:
-### http://www.gnu.org/software/tar/manual/html_mono/tar.html
+### http://www.gnu.org/software/tar/manual/tar.html
 ###
 ### and the pax format spec, which tar derives from:
 ### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html
@@ -14,7 +14,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
 $DEBUG              = 0;
 $WARN               = 1;
 $FOLLOW_SYMLINK     = 0;
-$VERSION            = "1.28";
+$VERSION            = "1.30_01";
 $CHOWN              = 1;
 $CHMOD              = 1;
 $DO_NOT_USE_PREFIX  = 0;
@@ -268,6 +268,18 @@ sub _read_tar {
         ### source code (tar.c) to GNU cpio.
         next if $chunk eq TAR_END;
 
+        ### 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:
+        ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx
+        ### line 111
+        {   my $nulls = join '', "\0" x 12;
+            unless( $nulls eq substr( $chunk, 500, 12 ) ) {
+                $self->_error( qq[Invalid header block at offset $offset] );
+                next LOOP;
+            }
+        }
+
         ### pass the realname, so we can set it 'proper' right away
         ### some of the heuristics are done on the name, so important
         ### to set it ASAP
@@ -279,7 +291,7 @@ sub _read_tar {
                                                         %extra_args ) 
             ) {
                 $self->_error( qq[Couldn't read chunk at offset $offset] );
-                next;
+                next LOOP;
             }
         }
 
@@ -312,11 +324,11 @@ sub _read_tar {
             if( $handle->read( $$data, $block ) < $block ) {
                 $self->_error( qq[Read error on tarfile (missing data) '].
                                     $entry->full_path ."' at offset $offset" );
-                next;
+                next LOOP;
             }
 
             ### throw away trailing garbage ###
-            substr ($$data, $entry->size) = "";
+            substr ($$data, $entry->size) = "" if defined $$data;
 
             ### part II of the @LongLink munging -- need to do /after/
             ### the checksum check.
@@ -350,7 +362,7 @@ sub _read_tar {
         ### this is one ugly hack =/ but needed for direct extraction
         if( $entry->is_longlink ) {
             $real_name = $data;
-            next;
+            next LOOP;
         } elsif ( defined $real_name ) {
             $entry->name( $$real_name );
             $entry->prefix('');
@@ -420,22 +432,37 @@ Returns a list of filenames extracted.
 
 sub extract {
     my $self    = shift;
+    my @args    = @_;
     my @files;
 
+    # use the speed optimization for all extracted files
+    local($self->{cwd}) = cwd() unless $self->{cwd};
+
     ### you requested the extraction of only certian files
-    if( @_ ) {
-        for my $file (@_) {
-            my $found;
-            for my $entry ( @{$self->_data} ) {
-                next unless $file eq $entry->full_path;
-
-                ### we found the file you're looking for
-                push @files, $entry;
-                $found++;
-            }
+    if( @args ) {
+        for my $file ( @args ) {
+            
+            ### it's already an object?
+            if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
+                push @files, $file;
+                next;
 
-            unless( $found ) {
-                return $self->_error( qq[Could not find '$file' in archive] );
+            ### go find it then
+            } else {
+            
+                my $found;
+                for my $entry ( @{$self->_data} ) {
+                    next unless $file eq $entry->full_path;
+    
+                    ### we found the file you're looking for
+                    push @files, $entry;
+                    $found++;
+                }
+    
+                unless( $found ) {
+                    return $self->_error( 
+                        qq[Could not find '$file' in archive] );
+                }
             }
         }
 
@@ -471,6 +498,8 @@ For example:
 
     $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
 
+    $tar->extract_file( $at_file_object,   'name/i/want/to/give/it' );
+
 Returns true on success, false on failure.
 
 =cut
@@ -490,7 +519,6 @@ sub _extract_file {
     my $self    = shift;
     my $entry   = shift or return;
     my $alt     = shift;
-    my $cwd     = cwd();
 
     ### you wanted an alternate extraction location ###
     my $name = defined $alt ? $alt : $entry->full_path;
@@ -513,6 +541,7 @@ sub _extract_file {
 
     ### it's a relative path ###
     } else {
+        my $cwd     = (defined $self->{cwd} ? $self->{cwd} : cwd());
         my @dirs    = File::Spec::Unix->splitdir( $dirs );
         my @cwd     = File::Spec->splitdir( $cwd );
         $dir        = File::Spec->catdir( @cwd, @dirs );
@@ -724,6 +753,9 @@ sub _find_entry {
         return;
     }
 
+    ### it's an object already
+    return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
+
     for my $entry ( @{$self->_data} ) {
         my $path = $entry->full_path;
         return $entry if $path eq $file;
@@ -995,10 +1027,16 @@ sub write {
     ### write the end markers ###
     print $handle TAR_END x 2 or
             return $self->_error( qq[Could not write tar end markers] );
+
     ### did you want it written to a file, or returned as a string? ###
-    return length($file) ? 1
+    my $rv =  length($file) ? 1
                         : $HAS_PERLIO ? $dummy
-                        : do { seek $handle, 0, 0; local $/; <$handle> }
+                        : do { seek $handle, 0, 0; local $/; <$handle> };
+
+    ### make sure to close the handle;
+    close $handle;
+    
+    return $rv;
 }
 
 sub _format_tar_entry {
@@ -1201,6 +1239,45 @@ method call instead.
     }
 }
 
+=head2 $tar->setcwd( $cwd );
+
+C<Archive::Tar> needs to know the current directory, and it will run
+C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the 
+tarfile and saves it in the file system. (As of version 1.30, however,
+C<Archive::Tar> will use the speed optimization described below 
+automatically, so it's only relevant if you're using C<extract_file()>).
+
+Since C<Archive::Tar> doesn't change the current directory internally
+while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
+can be avoided if we can guarantee that the current directory doesn't
+get changed externally.
+
+To use this performance boost, set the current directory via
+
+    use Cwd;
+    $tar->setcwd( cwd() );
+
+once before calling a function like C<extract_file> and
+C<Archive::Tar> will use the current directory setting from then on
+and won't call C<Cwd::cwd()> internally. 
+
+To switch back to the default behaviour, use
+
+    $tar->setcwd( undef );
+
+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
+be called for you.
+
+=cut 
+
+sub setcwd {
+    my $self     = shift;
+    my $cwd      = shift;
+
+    $self->{cwd} = $cwd;
+}
 
 =head2 $bool = $tar->has_io_string
 
@@ -1394,13 +1471,18 @@ The default is C<1>.
 
 =head2 $Archive::Tar::DO_NOT_USE_PREFIX
 
-By default, C<Archive::Tar> will try to put paths that are over
-100 characters in the C<prefix> field of your tar header. However,
-some older tar programs do not implement this spec. To retain
-compatibility with these older versions, you can set the
-C<$DO_NOT_USE_PREFIX> variable to a true value, and C<Archive::Tar>
-will use an alternate way of dealing with paths over 100 characters
-by using the C<GNU Extended Header> feature.
+By default, C<Archive::Tar> will try to put paths that are over 
+100 characters in the C<prefix> field of your tar header, as
+defined per POSIX-standard. However, some (older) tar programs 
+do not implement this spec. To retain compatibility with these older 
+or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX> 
+variable to a true value, and C<Archive::Tar> will use an alternate 
+way of dealing with paths over 100 characters by using the 
+C<GNU Extended Header> feature.
+
+Note that clients who do not support the C<GNU Extended Header>
+feature will not be able to read these archives. Such clients include
+tars on C<Solaris>, C<Irix> and C<AIX>.
 
 The default is C<0>.
 
@@ -1502,6 +1584,34 @@ have incompatible filetypes and still expect things to work).
 For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
 the extraction of this particular item didn't work.
 
+=item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly!
+
+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
+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
+C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the 
+C<GLOBAL VARIABLES> section for details on this variable.
+
+=item How do I extract only files that have property X from an archive?
+
+Sometimes, you might not wish to extract a complete archive, just
+the files that are relevant to you, based on some criteria.
+
+You can do this by filtering a list of C<Archive::Tar::File> objects
+based on your criteria. For example, to extract only files that have
+the string C<foo> in their title, you would use:
+
+    $tar->extract( 
+        grep { $_->full_path =~ /foo/ } $tar->get_files
+    ); 
+
+This way, you can filter on any attribute of the files in the archive.
+Consult the C<Archive::Tar::File> documentation on how to use these
+objects.
+
 =item How do I access .tar.Z files?
 
 The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
@@ -1567,6 +1677,31 @@ to an uploaded file, which might be a compressed archive.
 
 =back
 
+=head1 SEE ALSO
+
+=over 4
+
+=item The GNU tar specification
+
+C<http://www.gnu.org/software/tar/manual/tar.html>
+
+=item The PAX format specication
+
+The specifcation 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>
+
+=item GNU tar intends to switch to POSIX compatibility
+
+GNU Tar authors have expressed their intention to become completely
+POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html>
+
+=item A Comparison between various tar implementations
+
+Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs>
+
+=back
+
 =head1 AUTHOR
 
 This module by