core-cpan-diff: various enhancements

* Extracted directories are cached and re-used
* Perl vs CPAN version mismatches shown in summary output
* Various minor code cleanup

Some diagnostic output was surpressed in diff mode, but not all.
I found the output confusing to follow in diff mode as a result
so I enabled some of the previously surpressed output.

1 files changed, 45 insertions, 57 deletions

diff --git a/Porting/core-cpan-diff b/Porting/core-cpan-diff
index 0f303c2c70..d35d173bcb 100755
--- a/Porting/core-cpan-diff
+++ b/Porting/core-cpan-diff
@@ -14,12 +14,12 @@ use File::Basename ();
 use File::Copy ();
 use File::Temp ();
 use File::Path ();
-use File::Spec;
-use File::Spec::Unix ();
+use File::Spec::Functions;
 use Archive::Extract;
 use IO::Uncompress::Gunzip ();
 use File::Compare ();
 use ExtUtils::Manifest;
+use ExtUtils::MakeMaker ();
 
 BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
 use lib 'Porting';
@@ -36,20 +36,9 @@ $Module::Load::Conditional::CHECK_INC_HASH = 1;
 # stop Archive::Extract whinging about lack of Archive::Zip
 $Archive::Extract::WARN = 0;
 
-
-# Files, which if they exist in CPAN but not in perl, will not generate
-# an 'Only in CPAN' listing
-#
-our %IGNORABLE = map { ($_ => 1) }
-	qw(.cvsignore .dualLivedDiffConfig .gitignore
-	      ANNOUNCE Announce Artistic AUTHORS BENCHMARK BUGS Build.PL
-	      CHANGELOG ChangeLog CHANGES Changes COPYING Copying CREDITS
-	      GOALS HISTORY INSTALL INSTALL.SKIP LICENSE Makefile.PL
-	      MANIFEST MANIFEST.SKIP META.yml NEW NOTES ppport.h README
-	      SIGNATURE THANKS TODO Todo VERSION WHATSNEW);
-
+# where, under the cache dir, to download tarballs to
+use constant SRC_DIR   => 'tarballs';
 # where, under the cache dir, to untar stuff to
-
 use constant UNTAR_DIR => 'untarred';
 
 use constant DIFF_CMD  => 'diff';
@@ -163,10 +152,13 @@ sub run {
     if (defined $cache_dir) {
 	die "ERROR: no such directory: '$cache_dir'\n" unless -d $cache_dir;
     }
+    else {
+      $cache_dir = File::Temp::tempdir( CLEANUP => 1 );
+    }
 
     $mirror_url .= "/" unless substr($mirror_url,-1) eq "/";
     my $test_file = "modules/07mirror.yml";
-    my_getstore(cpan_url($mirror_url, $test_file), local_path($cache_dir, $test_file))
+    my_getstore(cpan_url($mirror_url, $test_file), catfile($cache_dir, $test_file))
 	or die "ERROR: not a CPAN mirror '$mirror_url'\n";
 
     if ($do_crosscheck) {
@@ -178,14 +170,6 @@ sub run {
     }
 }
 
-# construct a local path either in cache dir or tempdir
-
-sub local_path {
-    my ($cache_dir, @path) = @_;
-    my $local_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
-    return File::Spec->catfile($local_dir, @path);
-}
-
 # construct a CPAN url
 
 sub cpan_url {
@@ -205,18 +189,11 @@ sub do_compare {
 
     # first, make sure we have a directory where they can all be untarred,
     # and if its a permanent directory, clear any previous content
-    my $untar_dir;
-    if ($cache_dir) {
-	$untar_dir = File::Spec->catdir($cache_dir, UNTAR_DIR);
-	if (-d $untar_dir) {
-	    File::Path::rmtree($untar_dir)
-		    or die "failed to remove $untar_dir\n";
-	}
-	mkdir $untar_dir
-	    or die "mkdir $untar_dir: $!\n";
-    }
-    else {
-	$untar_dir = File::Temp::tempdir( CLEANUP => 1 );
+    my $untar_dir = catdir($cache_dir, UNTAR_DIR);
+    my $src_dir = catdir($cache_dir, SRC_DIR);
+    for my $d ( $src_dir, $untar_dir ) {
+      next if -d $d;
+      mkdir $d or die "mkdir $d: $!\n";
     }
 
     my %ignorable = map { ($_ => 1) } @Maintainers::IGNORABLE;
@@ -236,20 +213,19 @@ sub do_compare {
 	my $dist = $m->{DISTRIBUTION};
 	die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
 
-	if ($seen_dist{$dist}) {
+	if ($seen_dist{$dist}++) {
 	    warn "WARNING: duplicate entry for $dist in $module\n"
 	}
 
 	my $upstream = $m->{UPSTREAM} || 'UNKNOWN';
 	next if @$wanted_upstreams and ! ($upstream ~~ $wanted_upstreams);
-	print $outfh "\n$module - ".$Maintainers::Modules{$module}->{DISTRIBUTION}."\n" unless $use_diff;
-	print $outfh "  upstream is: ".($m->{UPSTREAM} || 'UNKNOWN!')."\n";
 
-	$seen_dist{$dist}++;
+        print $outfh "\n$module - ".$Maintainers::Modules{$module}->{DISTRIBUTION}."\n";
+        print $outfh "  upstream is: ".($m->{UPSTREAM} || 'UNKNOWN!')."\n";
 
 	my $cpan_dir;
 	eval {
-	    $cpan_dir = get_distribution($cache_dir, $mirror_url, $untar_dir, $module, $dist)
+	    $cpan_dir = get_distribution($src_dir, $mirror_url, $untar_dir, $module, $dist)
 	};
 	if ($@) {
 	    print $outfh "  ", $@;
@@ -259,12 +235,15 @@ sub do_compare {
 
 	my @perl_files = Maintainers::get_module_files($module);
 
-	my $manifest = File::Spec->catfile($cpan_dir, 'MANIFEST');
+	my $manifest = catfile($cpan_dir, 'MANIFEST');
 	die "ERROR: no such file: $manifest\n" unless  -f $manifest;
 
 	my $cpan_files = ExtUtils::Manifest::maniread($manifest);
 	my @cpan_files = sort keys %$cpan_files;
 
+        (my $main_pm = $module) =~ s{::}{/}g;
+        $main_pm .= ".pm";
+
 	my ($excluded, $map) =  get_map($m, $module, \@perl_files);
 
 	my %perl_unseen;
@@ -311,7 +290,7 @@ EOF
 	    }
 
 
-	    my $abs_cpan_file = File::Spec->catfile($cpan_dir, $cpan_file);
+	    my $abs_cpan_file = catfile($cpan_dir, $cpan_file);
 
 	    # should never happen
 	    die "ERROR: can't find file $abs_cpan_file\n" unless -f $abs_cpan_file;
@@ -322,8 +301,17 @@ EOF
 	        next;
 	    }
 
-			my $relative_mapped_file = $mapped_file;
-			$relative_mapped_file =~ s/^(cpan|dist|ext)\/.*?\///;
+            my $relative_mapped_file = $mapped_file;
+            $relative_mapped_file =~ s/^(cpan|dist|ext)\/.*?\///;
+
+            for my $f ( catfile('lib', $main_pm), $main_pm ) {
+              next unless $f eq $relative_mapped_file;
+              my $pv = MM->parse_version($mapped_file) || '(unknown)';
+              my $cv = MM->parse_version($abs_cpan_file) || '(unknown)';
+              if ( $pv ne $cv ) {
+                print $outfh "  Version mismatch: $cv (cpan) vs $pv (perl)\n";
+              }
+            }
 
 	    if (File::Compare::compare($abs_cpan_file, $mapped_file)) {
 
@@ -375,7 +363,7 @@ sub do_crosscheck {
 
     my $file = '02packages.details.txt';
     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
-    my $path = File::Spec->catfile($download_dir, $file);
+    my $path = catfile($download_dir, $file);
     my $gzfile = "$path.gz";
 
     # grab 02packages.details.txt
@@ -570,14 +558,13 @@ sub my_getstore {
 # dist:       name of the distribution
 
 sub get_distribution {
-    my ($cache_dir, $mirror_url, $untar_dir, $module, $dist) = @_;
+    my ($src_dir, $mirror_url, $untar_dir, $module, $dist) = @_;
 
     $dist =~ m{.+/([^/]+)$}
 	or die "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
     my $filename = $1;
 
-    my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
-    my $download_file = File::Spec->catfile($download_dir, $filename);
+    my $download_file = catfile($src_dir, $filename);
 
     # download distribution
 
@@ -596,20 +583,21 @@ sub get_distribution {
 	    or die "ERROR: Could not fetch '$url'\n";
     }
 
-    # extract distribution
+    # get the expected name of the extracted distribution dir
 
-    my $ae = Archive::Extract->new( archive => $download_file);
-    $ae->extract( to => $untar_dir )
-	or die "ERROR: failed to extract distribution '$download_file to temp. dir: " . $ae->error() . "\n";
-
-    # get the name of the extracted distribution dir
-
-    my $path = File::Spec->catfile($untar_dir, $filename);
+    my $path = catfile($untar_dir, $filename);
 
     $path =~ s/\.tar\.gz$// or
     $path =~ s/\.zip$// or
       die "ERROR: downloaded file does not have a recognised suffix: $path\n";
 
+    # 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 )
+          or die "ERROR: failed to extract distribution '$download_file to temp. dir: " . $ae->error() . "\n";
+    }
+
     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
 
     return $path;