Update Archive::Extract to 0.31_02

2 files changed, 147 insertions, 104 deletions

diff --git a/lib/Archive/Extract.pm b/lib/Archive/Extract.pm
index db52684870..c83f581629 100644
--- a/lib/Archive/Extract.pm
+++ b/lib/Archive/Extract.pm
@@ -20,6 +20,9 @@ use constant FILE_EXISTS    => sub { -e $_[0] ? 1 : 0 };
 ### VMS may require quoting upper case command options
 use constant ON_VMS         => $^O eq 'VMS' ? 1 : 0;
 
+### Windows needs special treatment of Tar options
+use constant ON_WIN32       => $^O eq 'MSWin32' ? 1 : 0;
+
 ### we can't use this extraction method, because of missing
 ### modules/binaries:
 use constant METHOD_NA      => []; 
@@ -38,7 +41,7 @@ use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
             $_ALLOW_BIN $_ALLOW_PURE_PERL
          ];
 
-$VERSION            = '0.30';
+$VERSION            = '0.31_02';
 $PREFER_BIN         = 0;
 $WARN               = 1;
 $DEBUG              = 0;
@@ -583,111 +586,125 @@ sub have_old_bunzip2 {
 #
 #################################
 
+### annoying issue with (gnu) tar on win32, as illustrated by this
+### bug: https://rt.cpan.org/Ticket/Display.html?id=40138
+### which shows that (gnu) tar will interpret a file name with a :
+### in it as a remote file name, so C:\tmp\foo.txt is interpreted
+### as a remote shell, and the extract fails.
+{   my @ExtraTarFlags;
+    if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) {
 
-### use /bin/tar to extract ###
-sub _untar_bin {
-    my $self = shift;
-
-    ### check for /bin/tar ###
-    ### check for /bin/gzip if we need it ###
-    ### if any of the binaries are not available, return NA
-    {   my $diag =  not $self->bin_tar ? 
-                        loc("No '%1' program found", '/bin/tar') :
-                    $self->is_tgz && !$self->bin_gzip ? 
-                        loc("No '%1' program found", '/bin/gzip') :
-                    $self->is_tbz && !$self->bin_bunzip2 ?
-                        loc("No '%1' program found", '/bin/bunzip2') :
-                    '';
-                    
-        if( $diag ) {
-            $self->_error( $diag );
-            return METHOD_NA;
-        }
+        ### if this is gnu tar we are running, we need to use --force-local
+        push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
     }        
 
-    ### XXX figure out how to make IPC::Run do this in one call --
-    ### currently i don't know how to get output of a command after a pipe
-    ### trapped in a scalar. Mailed barries about this 5th of june 2004.
-
-    ### see what command we should run, based on whether
-    ### it's a .tgz or .tar
 
-    ### XXX solaris tar and bsdtar are having different outputs
-    ### depending whether you run with -x or -t
-    ### compensate for this insanity by running -t first, then -x
-    {    my $cmd = 
-            $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
-                             $self->bin_tar, '-tf', '-'] :
-            $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',                             
-                             $self->bin_tar, '-tf', '-'] :
-            [$self->bin_tar, '-tf', $self->archive];
-
-        ### run the command ###
-        my $buffer = '';
-        unless( scalar run( command => $cmd,
-                            buffer  => \$buffer,
-                            verbose => $DEBUG )
-        ) {
-            return $self->_error(loc(
-                            "Error listing contents of archive '%1': %2",
-                            $self->archive, $buffer ));
+    ### use /bin/tar to extract ###
+    sub _untar_bin {
+        my $self = shift;
+    
+        ### check for /bin/tar ###
+        ### check for /bin/gzip if we need it ###
+        ### if any of the binaries are not available, return NA
+        {   my $diag =  not $self->bin_tar ? 
+                            loc("No '%1' program found", '/bin/tar') :
+                        $self->is_tgz && !$self->bin_gzip ? 
+                            loc("No '%1' program found", '/bin/gzip') :
+                        $self->is_tbz && !$self->bin_bunzip2 ?
+                            loc("No '%1' program found", '/bin/bunzip2') :
+                        '';
+                        
+            if( $diag ) {
+                $self->_error( $diag );
+                return METHOD_NA;
+            }
+        }        
+    
+        ### XXX figure out how to make IPC::Run do this in one call --
+        ### currently i don't know how to get output of a command after a pipe
+        ### trapped in a scalar. Mailed barries about this 5th of june 2004.
+    
+        ### see what command we should run, based on whether
+        ### it's a .tgz or .tar
+    
+        ### XXX solaris tar and bsdtar are having different outputs
+        ### depending whether you run with -x or -t
+        ### compensate for this insanity by running -t first, then -x
+        {    my $cmd = 
+                $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|', 
+                                 $self->bin_tar, '-tf', '-'] :
+                $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',                             
+                                 $self->bin_tar, '-tf', '-'] :
+                [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive];
+    
+            ### run the command ###
+            my $buffer = '';
+            unless( scalar run( command => $cmd,
+                                buffer  => \$buffer,
+                                verbose => $DEBUG )
+            ) {
+                return $self->_error(loc(
+                                "Error listing contents of archive '%1': %2",
+                                $self->archive, $buffer ));
+            }
+    
+            ### no buffers available?
+            if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+                $self->_error( $self->_no_buffer_files( $self->archive ) );
+            
+            } else {
+                ### if we're on solaris we /might/ be using /bin/tar, which has
+                ### a weird output format... we might also be using
+                ### /usr/local/bin/tar, which is gnu tar, which is perfectly
+                ### fine... so we have to do some guessing here =/
+                my @files = map { chomp;
+                              !ON_SOLARIS ? $_
+                                          : (m|^ x \s+  # 'xtract' -- sigh
+                                                (.+?),  # the actual file name
+                                                \s+ [\d,.]+ \s bytes,
+                                                \s+ [\d,.]+ \s tape \s blocks
+                                            |x ? $1 : $_);
+    
+                        } split $/, $buffer;
+    
+                ### store the files that are in the archive ###
+                $self->files(\@files);
+            }
         }
-
-        ### no buffers available?
-        if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
-            $self->_error( $self->_no_buffer_files( $self->archive ) );
+    
+        ### now actually extract it ###
+        {   my $cmd = 
+                $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+                                 $self->bin_tar, '-xf', '-'] :
+                $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',                             
+                                 $self->bin_tar, '-xf', '-'] :
+                [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive];
+    
+            my $buffer = '';
+            unless( scalar run( command => $cmd,
+                                buffer  => \$buffer,
+                                verbose => $DEBUG )
+            ) {
+                return $self->_error(loc("Error extracting archive '%1': %2",
+                                $self->archive, $buffer ));
+            }
+    
+            ### we might not have them, due to lack of buffers
+            if( $self->files ) {
+                ### now that we've extracted, figure out where we extracted to
+                my $dir = $self->__get_extract_dir( $self->files );
         
-        } else {
-            ### if we're on solaris we /might/ be using /bin/tar, which has
-            ### a weird output format... we might also be using
-            ### /usr/local/bin/tar, which is gnu tar, which is perfectly
-            ### fine... so we have to do some guessing here =/
-            my @files = map { chomp;
-                          !ON_SOLARIS ? $_
-                                      : (m|^ x \s+  # 'xtract' -- sigh
-                                            (.+?),  # the actual file name
-                                            \s+ [\d,.]+ \s bytes,
-                                            \s+ [\d,.]+ \s tape \s blocks
-                                        |x ? $1 : $_);
-
-                    } split $/, $buffer;
-
-            ### store the files that are in the archive ###
-            $self->files(\@files);
-        }
-    }
-
-    ### now actually extract it ###
-    {   my $cmd = 
-            $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
-                             $self->bin_tar, '-xf', '-'] :
-            $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',                             
-                             $self->bin_tar, '-xf', '-'] :
-            [$self->bin_tar, '-xf', $self->archive];
-
-        my $buffer = '';
-        unless( scalar run( command => $cmd,
-                            buffer  => \$buffer,
-                            verbose => $DEBUG )
-        ) {
-            return $self->_error(loc("Error extracting archive '%1': %2",
-                            $self->archive, $buffer ));
+                ### store the extraction dir ###
+                $self->extract_path( $dir );
+            }
         }
-
-        ### we might not have them, due to lack of buffers
-        if( $self->files ) {
-            ### now that we've extracted, figure out where we extracted to
-            my $dir = $self->__get_extract_dir( $self->files );
     
-            ### store the extraction dir ###
-            $self->extract_path( $dir );
-        }
+        ### we got here, no error happened
+        return 1;
     }
-
-    ### we got here, no error happened
-    return 1;
 }
 
+
 ### use archive::tar to extract ###
 sub _untar_at {
     my $self = shift;
@@ -1010,11 +1027,31 @@ sub _unzip_az {
     }
 
     my @files;
-    ### have to extract every memeber individually ###
+    
+    
+    ### Address: #43278: Explicitly tell Archive::Zip where to put the files:
+    ### "In my BackPAN indexing, Archive::Zip was extracting things
+    ### in my script's directory instead of the current working directory.
+    ### I traced this back through Archive::Zip::_asLocalName which
+    ### eventually calls File::Spec::Win32::rel2abs which on Windows might
+    ### call Cwd::getdcwd. getdcwd returns the wrong directory in my
+    ### case, even though I think I'm on the same drive.
+    ### 
+    ### To fix this, I pass the optional second argument to
+    ### extractMember using the cwd from Archive::Extract." --bdfoy
+
+    ## store cwd() before looping; calls to cwd() can be expensive, and
+    ### it won't change during the loop
+    my $extract_dir = cwd();
+    
+    ### have to extract every member individually ###
     for my $member ($zip->members) {
         push @files, $member->{fileName};
 
-        unless( $zip->extractMember($member) == &Archive::Zip::AZ_OK ) {
+        ### file to extact to, to avoid the above problem
+        my $to = File::Spec->catfile( $extract_dir, $member->{fileName} );
+        
+        unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) {
             return $self->_error(loc("Extraction of '%1' from '%2' failed",
                         $member->{fileName}, $self->archive ));
         }
diff --git a/lib/Archive/Extract/t/01_Archive-Extract.t b/lib/Archive/Extract/t/01_Archive-Extract.t
index 3d414604ec..63a956b26e 100644
--- a/lib/Archive/Extract/t/01_Archive-Extract.t
+++ b/lib/Archive/Extract/t/01_Archive-Extract.t
@@ -42,22 +42,28 @@ if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) {
     diag( "See bug #19713 in rt.cpan.org. It is safe to ignore them" );
 }
 
-my $Debug   = $ARGV[0] ? 1 : 0;
 my $Me      = basename( $0 );
 my $Class   = 'Archive::Extract';
+
+use_ok($Class);
+
+### debug will always be enabled on dev versions
+my $Debug   = (not $ENV{PERL_CORE} and 
+              ($ARGV[0] or $Archive::Extract::VERSION =~ /_/))
+                ? 1 
+                : 0;
+
 my $Self    = File::Spec->rel2abs( 
                     IS_WIN32 ? &Win32::GetShortPathName( cwd() ) : cwd() 
                 );
 my $SrcDir  = File::Spec->catdir( $Self,'src' );
 my $OutDir  = File::Spec->catdir( $Self,'out' );
 
-use_ok($Class);
-
-### set verbose if debug is on ###
 ### stupid stupid silly stupid warnings silly! ###
-$Archive::Extract::VERBOSE  = $Archive::Extract::VERBOSE = $Debug;
-$Archive::Extract::WARN     = $Archive::Extract::WARN    = $Debug ? 1 : 0;
+$Archive::Extract::DEBUG    = $Archive::Extract::DEBUG  = $Debug;
+$Archive::Extract::WARN     = $Archive::Extract::WARN   = $Debug;
 
+diag( "\n\n*** DEBUG INFORMATION ENABLED ***\n\n" ) if $Debug;
 
 my $tmpl = {
     ### plain files
@@ -409,7 +415,7 @@ for my $switch ( [0,1], [1,0] ) {
                     my $files    = $ae->files || [];
                     my $file_cnt = grep { defined } $file, $dir;
                     is( scalar @$files, $file_cnt,
-                                    "Found correct number of output files" );
+                                    "Found correct number of output files (@$files)" );
                     
                     ### due to prototypes on is(), if there's no -1 index on
                     ### the array ref, it'll give a fatal exception: