From: Jos I. Boumans Date: Wed, 4 Mar 2009 12:04:19 +0000 (+0100) Subject: Update Archive::Extract to 0.31_02 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e74f3fd4b4b664f9ec8b6d9693d6a13bb6e50c49;p=p5sagit%2Fp5-mst-13.2.git Update Archive::Extract to 0.31_02 --- diff --git a/lib/Archive/Extract.pm b/lib/Archive/Extract.pm index db526848..c83f581 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 3d41460..63a956b 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: