From: David Mitchell Date: Sat, 27 Jun 2009 17:05:17 +0000 (+0100) Subject: sync blead with Update Archive::Extract 0.34 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ea0799344c68cf3c4274aab0c7bdf2f3a9587ed2;p=p5sagit%2Fp5-mst-13.2.git sync blead with Update Archive::Extract 0.34 (follow up to 198e857cc6, syncing whitespace) --- diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index ca9a89c..b83f8ee 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -170,7 +170,7 @@ package Maintainers; 'Archive::Extract' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'KANE/Archive-Extract-0.32.tar.gz', + 'DISTRIBUTION' => 'KANE/Archive-Extract-0.34.tar.gz', 'FILES' => q[lib/Archive/Extract.pm lib/Archive/Extract], 'CPAN' => 1, 'UPSTREAM' => 'cpan', diff --git a/lib/Archive/Extract.pm b/lib/Archive/Extract.pm index 9bb4a06..2c9331e 100644 --- a/lib/Archive/Extract.pm +++ b/lib/Archive/Extract.pm @@ -802,26 +802,26 @@ sub _untar_at { my $next; unless ( $next = Archive::Tar->iter( @read ) ) { return $self->_error(loc( - "Unable to read '%1': %2", $self->archive, + "Unable to read '%1': %2", $self->archive, $Archive::Tar::error)); } while ( my $file = $next->() ) { push @files, $file->full_path; - + $file->extract or return $self->_error(loc( - "Unable to read '%1': %2", + "Unable to read '%1': %2", $self->archive, $Archive::Tar::error)); } - - ### older version, read the archive into memory + + ### older version, read the archive into memory } else { my $tar = Archive::Tar->new(); unless( $tar->read( @read ) ) { - return $self->_error(loc("Unable to read '%1': %2", + return $self->_error(loc("Unable to read '%1': %2", $self->archive, $Archive::Tar::error)); } @@ -837,7 +837,7 @@ sub _untar_at { { local $^W; # quell 'splice() offset past end of array' warnings # on older versions of A::T - ### older archive::tar always returns $self, return value + ### older archive::tar always returns $self, return value ### slightly fux0r3d because of it. $tar->extract or return $self->_error(loc( "Unable to extract '%1': %2", diff --git a/lib/Archive/Extract/t/01_Archive-Extract.t b/lib/Archive/Extract/t/01_Archive-Extract.t index 9b4de26..52decf6 100644 --- a/lib/Archive/Extract/t/01_Archive-Extract.t +++ b/lib/Archive/Extract/t/01_Archive-Extract.t @@ -318,8 +318,8 @@ for my $switch ( [0,1], [1,0] ) { for my $tar_iter (@with_tar_iter) { SKIP: { ### Doesn't matter unless .tar, .tbz, .tgz - local $Archive::Extract::_ALLOW_TAR_ITER = $tar_iter; - + local $Archive::Extract::_ALLOW_TAR_ITER = $tar_iter; + diag("Archive::Tar->iter: $tar_iter") if $Debug; isa_ok( $ae, $Class ); @@ -327,12 +327,12 @@ for my $switch ( [0,1], [1,0] ) { my $method = $tmpl->{$archive}->{method}; ok( $ae->$method(), "Archive type recognized properly" ); - + my $file = $tmpl->{$archive}->{outfile}; my $dir = $tmpl->{$archive}->{outdir}; # can be undef my $rel_path = File::Spec->catfile( grep { defined } $dir, $file ); my $abs_path = File::Spec->catfile( $OutDir, $rel_path ); - my $abs_dir = File::Spec->catdir( + my $abs_dir = File::Spec->catdir( grep { defined } $OutDir, $dir ); my $nix_path = File::Spec::Unix->catfile( grep { defined } $dir, $file ); @@ -361,15 +361,15 @@ for my $switch ( [0,1], [1,0] ) { ### XXX test me! #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir); my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma - ? ($abs_path) + ? ($abs_path) : ($OutDir); ### 10 tests from here on down ### if( ($mod_fail && ($pgm_fail || !$Archive::Extract::_ALLOW_BIN)) || ($pgm_fail && ($mod_fail || !$Archive::Extract::_ALLOW_PURE_PERL)) - ) { - skip "No binaries or modules to extract ".$archive, + ) { + skip "No binaries or modules to extract ".$archive, (10 * scalar @outs); } @@ -377,7 +377,7 @@ for my $switch ( [0,1], [1,0] ) { ### be a problem... local $IPC::Cmd::WARN = 0; local $IPC::Cmd::WARN = 0; - + for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) { ### test buffers ### @@ -397,13 +397,13 @@ for my $switch ( [0,1], [1,0] ) { diag("Extracting to: $to") if $Debug; diag("Buffers enabled: ".!$turn_off) if $Debug; - + my $rv = $ae->extract( to => $to ); SKIP: { my $re = qr/^No buffer captured/; my $err = $ae->error || ''; - + ### skip buffer tests if we dont have buffers or ### explicitly turned them off skip "No buffers available", 8 @@ -411,29 +411,29 @@ for my $switch ( [0,1], [1,0] ) { && $err =~ $re; ### skip tests if we dont have an extractor - skip "No extractor available", 8 + skip "No extractor available", 8 if $err =~ /Extract failed; no extractors available/; - + ### win32 + bin utils is notorious, and none of them are - ### officially supported by strawberry. So if we - ### encounter an error while extracting whlie running + ### officially supported by strawberry. So if we + ### encounter an error while extracting whlie running ### with $PREFER_BIN on win32, just skip the tests. ### See rt#46948: unable to install install on win32 ### for details on the pain skip "Binary tools on Win32 are very unreliable", 8 - if $err and $Archive::Extract::_ALLOW_BIN + if $err and $Archive::Extract::_ALLOW_BIN and IS_WIN32; ok( $rv, "extract() for '$archive' reports success ($cfg)"); - + diag("Extractor was: " . $ae->_extractor) if $Debug; - + ### if we /should/ have buffers, there should be ### no errors complaining we dont have them... unlike( $err, $re, "No errors capturing buffers" ); - - ### might be 1 or 2, depending wether we extracted + + ### might be 1 or 2, depending wether we extracted ### a dir too my $files = $ae->files || []; my $file_cnt = grep { defined } $file, $dir; @@ -446,7 +446,7 @@ for my $switch ( [0,1], [1,0] ) { ### subscript -1 at -e line 1." So wrap it in do { } is( do { $files->[-1] }, $nix_path, "Found correct output file '$nix_path'" ); - + ok( -e $abs_path, "Output file '$abs_path' exists" ); ok( $ae->extract_path, @@ -462,15 +462,15 @@ for my $switch ( [0,1], [1,0] ) { 1 while unlink $abs_path; ok( !(-e $abs_path), "Output file successfully removed" ); - + SKIP: { skip "No extract path captured, can't remove paths", 2 unless $ae->extract_path; - + ### if something went wrong with determining the out ### path, don't go deleting stuff.. might be Really Bad my $out_re = quotemeta( $OutDir ); - + ### VMS directory layout is different. Craig Berry ### explains: ### the test is trying to determine if C @@ -478,22 +478,22 @@ for my $switch ( [0,1], [1,0] ) { ### syntax, that would mean trying to determine whether ### C is part of C ### Because we have both a directory delimiter - ### (dot) and a directory spec terminator (right - ### bracket), we have to trim the right bracket from + ### (dot) and a directory spec terminator (right + ### bracket), we have to trim the right bracket from ### the first one to make it successfully match the ### second one. Since we're asserting the same truth -- ### that one path spec is the leading part of the other ### -- it seems to me ok to have this in the test only. - ### + ### ### so we strip the ']' of the back of the regex - $out_re =~ s/\\\]// if IS_VMS; - - if( $ae->extract_path !~ /^$out_re/ ) { - ok( 0, "Extractpath WRONG (".$ae->extract_path.")"); + $out_re =~ s/\\\]// if IS_VMS; + + if( $ae->extract_path !~ /^$out_re/ ) { + ok( 0, "Extractpath WRONG (".$ae->extract_path.")"); skip( "Unsafe operation -- skip cleanup!!!" ), 1; - } - - eval { rmtree( $ae->extract_path ) }; + } + + eval { rmtree( $ae->extract_path ) }; ok( !$@, " rmtree gave no error" ); ok( !(-d $ae->extract_path ), " Extract dir succesfully removed" );