Porting/ tool: Check for bad commits against cpan/

Porting/check-cpan-pollution runs a series of tests to find potentially
unsafe commits that change dual-lived modules and prints a summary.

1 files changed, 195 insertions, 0 deletions

diff --git a/Porting/check-cpan-pollution b/Porting/check-cpan-pollution
new file mode 100644
index 0000000000..fb2d50e8a3
--- /dev/null
+++ b/Porting/check-cpan-pollution
@@ -0,0 +1,195 @@
+#!perl
+use strict;
+use warnings;
+use Getopt::Long qw/GetOptions/;
+use Term::ANSIColor qw/color/;
+use constant GITCMD => 'git';
+
+sub usage {
+  print <<HERE;
+Usage: $0 [options] [<start-commit> [<end-commit>]] 
+
+Scans the commit logs for commits that are potentially, illegitimately
+touching modules that are primarily maintained outside of the perl core.
+Also checks for commits that span multiple distributions in cpan/ or dist/.
+Ignores MANIFEST and Porting/Maintainers.pl.
+
+Skip the <start-commit> to go back indefinitely. <end-commit> defaults to
+HEAD.
+
+ -h/--help shows this help
+ -v/--verbose shows the output of "git show --stat <commit>" for each commit
+ -c/--color uses colored output
+HERE
+  exit(1);
+}
+
+our $Verbose = 0;
+our $Color   = 0;
+GetOptions(
+  'h|help'         => \&usage,
+  'v|verbose'      => \$Verbose,
+  'c|color|colour' => \$Color,
+);
+
+my $start_commit = shift;
+my $end_commit   = shift;
+$end_commit = 'HEAD' if not defined $end_commit;
+my $commit_range_cmd = defined($start_commit) ? " $start_commit..$end_commit" : "";
+
+# format: hash\0author\0committer\0short_msg
+our $LogCmd = GITCMD() . q{ log --no-color -M -C --name-only '--pretty=format:%h%x00%an%x00%cn%x00%s'} . $commit_range_cmd;
+our @ColumnSpec = qw(hash author committer commit_msg);
+
+open my $fh, '-|', $LogCmd
+  or die "Can't run '$LogCmd' to get the commit log: $!";
+
+my ($safe_commits, $unsafe_commits) = parse_log($fh);
+
+if (@$unsafe_commits) {
+  my $header = "Potentially unsafe commits:";
+  print color("red") if $Color;
+  print $header, "\n";
+  print("=" x length($header), "\n\n") if $Verbose;
+  print color("reset") if $Color;
+  print_commit_info($_) foreach reverse @$unsafe_commits;
+  print "\n";
+}
+
+if (@$safe_commits) {
+  my $header = "Presumably safe commits:";
+  print color("green") if $Color;
+  print $header, "\n";
+  print("=" x length($header), "\n") if $Verbose;
+  print color("reset") if $Color;
+  print_commit_info($_) foreach reverse @$safe_commits;
+  print "\n";
+}
+
+exit(0);
+
+
+
+# single-line info about the commit at hand
+sub print_commit_info {
+  my $commit = shift;
+
+  my $author_info = "by $commit->{author}"
+                    . ($commit->{author} eq $commit->{committer}
+                       ? ''
+                       : " committed by $commit->{committer}");
+
+  if ($Verbose) {
+    print color("yellow") if $Color;
+    my $header = "$commit->{hash} $author_info: $commit->{msg}";
+    print "$header\n", ("-" x length($header)), "\n";
+    print color("reset") if $Color;
+
+    my $cmd = GITCMD() . ' show --stat ' . ($Color?'--color ':'')
+              . $commit->{hash};
+    print `$cmd`; # make sure git knows this isn't a terminal
+    print "\n";
+  }
+  else {
+    print color("yellow") if $Color;
+    print "  $commit->{hash} $author_info: $commit->{msg}\n";
+    print color("reset") if $Color;
+  }
+}
+
+
+# check whether the commit at hand is safe, unsafe or uninteresting
+sub check_commit {
+  my $commit = shift;
+  my $safe   = shift;
+  my $unsafe = shift;
+
+  my @files = grep {$_ ne 'MANIFEST' and $_ ne 'Porting/Maintainers.pl'}
+              @{$commit->{files}};
+  my @touching_cpan = grep {/^cpan\//} @files;
+  return if not @touching_cpan;
+
+  # check for unsafe commits to cpan/
+  my %touched_cpan_dirs;
+  $touched_cpan_dirs{$_}++ for grep {defined $_}
+                               map {s/^cpan\/([^\/]*).*$/$1/; $_}
+                               @touching_cpan;
+
+  my $touches_multiple_cpan_dists = (keys(%touched_cpan_dirs) > 1);
+
+  my $touches_others              = @files - @touching_cpan;
+
+  if (@touching_cpan) {
+    if ($touches_others) {
+      $commit->{msg} = 'Touched files under cpan/ and other locations';
+      push @$unsafe, $commit;
+    }
+    elsif ($touches_multiple_cpan_dists) {
+      $commit->{msg} = 'Touched multiple directories under cpan/';
+      push @$unsafe, $commit;
+    }
+    elsif ($commit->{commit_msg} =~ /(?:up(?:grad|dat)|import)(?:ed?|ing)/i) {
+      $commit->{msg} = 'Touched files under cpan/ with '
+                       . '"upgrading"-like commit message';
+      push @$safe, $commit;
+    }
+    else {
+      $commit->{msg} = 'Touched files under cpan/ without '
+                       . '"upgrading"-like commit message';
+      push @$unsafe, $commit;
+    }
+  }
+
+  # check for unsafe commits to dist/
+  my @touching_dist = grep {/^dist\//} @files;
+  my %touched_dist_dirs;
+  $touched_dist_dirs{$_}++ for grep {defined $_}
+                               map {s/^dist\/([^\/]*).*$/$1/; $_}
+                               @touching_dist;
+  $touches_others = @files - @touching_dist;
+  my $touches_multiple_dists = (keys(%touched_dist_dirs) > 1);
+ 
+  if (@touching_dist) {
+    if ($touches_others) {
+      $commit->{msg} = 'Touched files under dist/ and other locations';
+      push @$unsafe, $commit;
+    }
+    elsif ($touches_multiple_dists) {
+      $commit->{msg} = 'Touched multiple directories under cpan/';
+      push @$unsafe, $commit;
+    }
+  }
+}
+
+# given file handle, parse the git log output and put the resulting commit
+# structure into safe/unsafe compartments
+sub parse_log {
+  my $fh = shift;
+  my @safe_commits;
+  my @unsafe_commits;
+  my $commit;
+  while (defined(my $line = <$fh>)) {
+    chomp $line;
+    if (not $commit) {
+      next if $line =~ /^\s*$/;
+      my @cols = split /\0/, $line;
+      @cols == @ColumnSpec && !grep {!defined($_)} @cols
+        or die "Malformed commit header line: '$line'";
+      $commit = {
+        files => [],
+        map {$ColumnSpec[$_] => $cols[$_]} (0..$#cols)
+      };
+      next;
+    }
+    elsif ($line =~ /^\s*$/) { # within commit, blank line
+      check_commit($commit, \@safe_commits, \@unsafe_commits);
+      $commit = undef;
+    }
+    else { # within commit, non-blank (file) line
+      push @{$commit->{files}}, $line;
+    }
+  }
+
+  return(\@safe_commits, \@unsafe_commits);
+}
+