Upgrade to ExtUtils::MakeMaker 6.40.
[p5sagit/p5-mst-13.2.git] / lib / Archive / Tar.pm
index 536336a..9881c96 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
@@ -9,15 +9,18 @@ require 5.005_03;
 
 use strict;
 use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
-            $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING];
-
-$DEBUG              = 0;
-$WARN               = 1;
-$FOLLOW_SYMLINK     = 0;
-$VERSION            = "1.29";
-$CHOWN              = 1;
-$CHMOD              = 1;
-$DO_NOT_USE_PREFIX  = 0;
+            $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING
+            $INSECURE_EXTRACT_MODE
+         ];
+
+$DEBUG                  = 0;
+$WARN                   = 1;
+$FOLLOW_SYMLINK         = 0;
+$VERSION                = "1.37_01";
+$CHOWN                  = 1;
+$CHMOD                  = 1;
+$DO_NOT_USE_PREFIX      = 0;
+$INSECURE_EXTRACT_MODE  = 0;
 
 BEGIN {
     use Config;
@@ -303,7 +306,7 @@ sub _read_tar {
 
             if ( $entry->is_file && !$entry->validate ) {
                 ### sometimes the chunk is rather fux0r3d and a whole 512
-                ### bytes ends p in the ->name area.
+                ### bytes ends up in the ->name area.
                 ### clean it up, if need be
                 my $name = $entry->name;
                 $name = substr($name, 0, 100) if length $name > 100;
@@ -328,7 +331,7 @@ sub _read_tar {
             }
 
             ### 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.
@@ -406,8 +409,13 @@ underlying file.
 
 sub contains_file {
     my $self = shift;
-    my $full = shift or return;
+    my $full = shift;
+    
+    return unless defined $full;
 
+    ### don't warn if the entry isn't there.. that's what this function
+    ### is for after all.
+    local $WARN = 0;
     return 1 if $self->_find_entry($full);
     return;
 }
@@ -435,6 +443,9 @@ sub extract {
     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( @args ) {
         for my $file ( @args ) {
@@ -488,7 +499,7 @@ sub extract {
 =head2 $tar->extract_file( $file, [$extract_path] )
 
 Write an entry, whose name is equivalent to the file name provided to
-disk. Optionally takes a second parameter, which is the full (unix)
+disk. Optionally takes a second parameter, which is the full native
 path (including filename) the entry will be written to.
 
 For example:
@@ -503,7 +514,7 @@ Returns true on success, false on failure.
 
 sub extract_file {
     my $self = shift;
-    my $file = shift or return;
+    my $file = shift;   return unless defined $file;
     my $alt  = shift;
 
     my $entry = $self->_find_entry( $file )
@@ -534,16 +545,68 @@ sub _extract_file {
     my $dir;
     ### is $name an absolute path? ###
     if( File::Spec->file_name_is_absolute( $dirs ) ) {
+
+        ### absolute names are not allowed to be in tarballs under
+        ### strict mode, so only allow it if a user tells us to do it
+        if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
+            $self->_error( 
+                q[Entry ']. $entry->full_path .q[' is an absolute path. ].
+                q[Not extracting absolute paths under SECURE EXTRACT MODE]
+            );  
+            return;
+        }
+        
+        ### user asked us to, it's fine.
         $dir = $dirs;
 
     ### it's a relative path ###
     } else {
-        my $cwd     = cwd();
-        my @dirs    = File::Spec::Unix->splitdir( $dirs );
-        my @cwd     = File::Spec->splitdir( $cwd );
-        $dir        = File::Spec->catdir( @cwd, @dirs );
+        my $cwd     = (defined $self->{cwd} ? $self->{cwd} : cwd());
+
+        my @dirs = defined $alt
+            ? File::Spec->splitdir( $dirs )         # It's a local-OS path
+            : File::Spec::Unix->splitdir( $dirs );  # it's UNIX-style, likely
+                                                    # straight from the tarball
+
+        ### paths that leave the current directory are not allowed under
+        ### strict mode, so only allow it if a user tells us to do this.
+        if( not defined $alt            and 
+            not $INSECURE_EXTRACT_MODE  and 
+            grep { $_ eq '..' } @dirs
+        ) {
+            $self->_error(
+                q[Entry ']. $entry->full_path .q[' is attempting to leave the ].
+                q[current working directory. Not extracting under SECURE ].
+                q[EXTRACT MODE]
+            );
+            return;
+        }            
+        
+        ### '.' is the directory delimiter, of which the first one has to
+        ### be escaped/changed.
+        map tr/\./_/, @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 elemant 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( 
+                            $cwd_vol, File::Spec->catdir( @cwd, @dirs ), '' 
+                        );
 
-        # catdir() returns undef if the path is longer than 255 chars on VMS
+        ### catdir() returns undef if the path is longer than 255 chars on VMS
         unless ( defined $dir ) {
             $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
             return;
@@ -562,6 +625,17 @@ sub _extract_file {
             $self->_error( qq[Could not create directory '$dir': $@] );
             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 ###
@@ -1113,7 +1187,7 @@ sub add_files {
 
     my @rv;
     for my $file ( @files ) {
-        unless( -e $file ) {
+        unless( -e $file || -l $file ) {
             $self->_error( qq[No such file: '$file'] );
             next;
         }
@@ -1236,6 +1310,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
 
@@ -1429,13 +1542,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>.
 
@@ -1464,6 +1582,23 @@ use is very much discouraged. Use the C<error()> method instead:
 
     warn $tar->error unless $tar->extract;
 
+=head2 $Archive::Tar::INSECURE_EXTRACT_MODE
+
+This variable indicates whether C<Archive::Tar> should allow
+files to be extracted outside their current working directory.
+
+Allowing this could have security implications, as a malicious
+tar archive could alter or replace any file the extracting user
+has permissions to. Therefor, the default is to not allow 
+insecure extractions. 
+
+If you trust the archive, or have other reasons to allow the 
+archive to write files outside your current working directory, 
+set this variable to C<true>.
+
+Note that this is a backwards incompatible change from version
+C<1.36> and before.
+
 =head2 $Archive::Tar::HAS_PERLIO
 
 This variable holds a boolean indicating if we currently have 
@@ -1537,6 +1672,21 @@ 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.
+
+Note that GNU tar earlier than version 1.14 does not cope well with
+the C<POSIX header prefix>. If you use such a version, consider setting
+the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>.
+
 =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
@@ -1593,6 +1743,56 @@ write a C<.tar.Z> file
     $tar->write($fh);
     $fh->close ;
 
+=item How do I handle Unicode strings?
+
+C<Archive::Tar> uses byte semantics for any files it reads from or writes
+to disk. This is not a problem if you only deal with files and never
+look at their content or work solely with byte strings. But if you use
+Unicode strings with character semantics, some additional steps need
+to be taken.
+
+For example, if you add a Unicode string like
+
+    # Problem
+    $tar->add_data('file.txt', "Euro: \x{20AC}");
+
+then there will be a problem later when the tarfile gets written out
+to disk via C<$tar->write()>:
+
+    Wide character in print at .../Archive/Tar.pm line 1014.
+
+The data was added as a Unicode string and when writing it out to disk,
+the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl
+tried to convert the string to ISO-8859 and failed. The written file
+now contains garbage.
+
+For this reason, Unicode strings need to be converted to UTF-8-encoded
+bytestrings before they are handed off to C<add_data()>:
+
+    use Encode;
+    my $data = "Accented character: \x{20AC}";
+    $data = encode('utf8', $data);
+
+    $tar->add_data('file.txt', $data);
+
+A opposite problem occurs if you extract a UTF8-encoded file from a 
+tarball. Using C<get_content()> on the C<Archive::Tar::File> object
+will return its content as a bytestring, not as a Unicode string.
+
+If you want it to be a Unicode string (because you want character
+semantics with operations like regular expression matching), you need
+to decode the UTF8-encoded content and have Perl convert it into 
+a Unicode string:
+
+    use Encode;
+    my $data = $tar->get_content();
+    
+    # Make it a Unicode string
+    $data = decode('utf8', $data);
+
+There is no easy way to provide this functionality in C<Archive::Tar>, 
+because a tarball can contain many files, and each of which could be
+encoded in a different way.
 
 =back
 
@@ -1619,10 +1819,36 @@ 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
-Jos Boumans E<lt>kane@cpan.orgE<gt>.
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>.
 
 =head1 ACKNOWLEDGEMENTS
 
@@ -1631,12 +1857,10 @@ especially Andrew Savige for their help and suggestions.
 
 =head1 COPYRIGHT
 
-This module is
-copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
-All rights reserved.
+This module is copyright (c) 2002 - 2007 Jos Boumans 
+E<lt>kane@cpan.orgE<gt>. All rights reserved.
 
-This library is free software;
-you may redistribute and/or modify it under the same
-terms as Perl itself.
+This library is free software; you may redistribute and/or modify 
+it under the same terms as Perl itself.
 
 =cut