X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fb598ba5e55920eb59105c932df653f4fea6966c..97e1df436b02746f964be120ede2a91dc7ce0b59:/Porting/core-cpan-diff

diff --git a/Porting/core-cpan-diff b/Porting/core-cpan-diff
index 60a27d1..dbfeac7 100644
--- a/Porting/core-cpan-diff
+++ b/Porting/core-cpan-diff
@@ -14,8 +14,8 @@ use File::Basename ();
 use File::Copy     ();
 use File::Temp     ();
 use File::Path     ();
+use File::Spec;
 use File::Spec::Functions;
-use Archive::Extract;
 use IO::Uncompress::Gunzip ();
 use File::Compare          ();
 use ExtUtils::Manifest;
@@ -26,17 +26,11 @@ BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
 use lib 'Porting';
 use Maintainers ();
 
-# if running from blead, we may be doing -Ilib, which means when we
-# 'chdir /tmp/foo', Archive::Extract may not find Archive::Tar etc.
-# So preload the things we need, and tell it to check %INC first:
-
 use Archive::Tar;
+use Cwd qw[cwd chdir];
 use IPC::Open3;
 use IO::Select;
-$Module::Load::Conditional::CHECK_INC_HASH = 1;
-
-# stop Archive::Extract whinging about lack of Archive::Zip
-$Archive::Extract::WARN = 0;
+local $Archive::Tar::WARN=0;
 
 # where, under the cache dir, to download tarballs to
 use constant SRC_DIR => 'tarballs';
@@ -667,13 +661,10 @@ sub get_distribution {
 
     # extract it unless we already have it cached or tarball is newer
     if ( !-d $path || ( -M $download_file < -M $path ) ) {
-        my $ae = Archive::Extract->new( archive => $download_file );
-        $ae->extract( to => $untar_dir )
+        $path = extract( $download_file, $untar_dir )
           or die
           "ERROR: failed to extract distribution '$download_file to temp. dir: "
-          . $ae->error() . "\n";
-
-        $path = $ae->extract_path;
+          . $! . "\n";
     }
 
     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
@@ -705,5 +696,70 @@ sub customized {
     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
 }
 
+sub extract {
+  my ($archive,$to) = @_;
+  my $cwd = cwd();
+  chdir $to or die "$!\n";
+  my @files;
+  EXTRACT: {
+    local $Archive::Tar::CHOWN = 0;
+    my $next;
+    unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
+       $! = $Archive::Tar::error;
+       last EXTRACT;
+    }
+    while ( my $file = $next->() ) {
+      push @files, $file->full_path;
+      unless ( $file->extract ) {
+        $! = $Archive::Tar::error;
+        last EXTRACT;
+      }
+    }
+  }
+  my $path = __get_extract_dir( \@files );
+  chdir $cwd or die "$!\n";
+  return $path;
+}
+
+sub __get_extract_dir {
+    my $files   = shift || [];
+
+    return unless scalar @$files;
+
+    my($dir1, $dir2);
+    for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
+        my($dir,$pos) = @$aref;
+
+        ### add a catdir(), so that any trailing slashes get
+        ### take care of (removed)
+        ### also, a catdir() normalises './dir/foo' to 'dir/foo';
+        ### which was the problem in bug #23999
+        my $res = -d $files->[$pos]
+                    ? File::Spec->catdir( $files->[$pos], '' )
+                    : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
+
+        $$dir = $res;
+    }
+
+    ### if the first and last dir don't match, make sure the
+    ### dirname is not set wrongly
+    my $dir;
+
+    ### dirs are the same, so we know for sure what the extract dir is
+    if( $dir1 eq $dir2 ) {
+        $dir = $dir1;
+
+    ### dirs are different.. do they share the base dir?
+    ### if so, use that, if not, fall back to '.'
+    } else {
+        my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
+        my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
+
+        $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
+    }
+
+    return File::Spec->rel2abs( $dir );
+}
+
 run();