Porting/Maintainers.pm

   1 #
   2 # Maintainers.pm - show information about maintainers
   3 #
   4
   5 package Maintainers;
   6
   7 use strict;
   8 use warnings;
   9
  10 use lib "Porting";
  11 # Please don't use post 5.008 features as this module is used by
  12 # Porting/makemeta, and that in turn has to be run by the perl just built.
  13 use 5.008;
  14
  15 require "Maintainers.pl";
  16 use vars qw(%Modules %Maintainers);
  17
  18 use vars qw(@ISA @EXPORT_OK $VERSION);
  19 @ISA = qw(Exporter);
  20 @EXPORT_OK = qw(%Modules %Maintainers
  21                 get_module_files get_module_pat
  22                 show_results process_options files_to_modules
  23         finish_tap_output
  24                 reload_manifest);
  25 $VERSION = 0.05;
  26
  27 require Exporter;
  28
  29 use File::Find;
  30 use Getopt::Long;
  31
  32 my %MANIFEST;
  33
  34 # (re)read the MANIFEST file, blowing away any previous effort
  35
  36 sub reload_manifest {
  37     %MANIFEST = ();
  38
  39     my $manifest_path = 'MANIFEST';
  40    if (! -e  $manifest_path) {
  41         $manifest_path = "../MANIFEST";
  42     }
  43
  44     if (open(my $manfh,  $manifest_path )) {
  45         while (<$manfh>) {
  46             if (/^(\S+)/) {
  47                 $MANIFEST{$1}++;
  48             }
  49             else {
  50                 warn "MANIFEST:$.: malformed line: $_\n";
  51             }
  52         }
  53         close $manfh;
  54     } else {
  55             die "$0: Failed to open MANIFEST for reading: $!\n";
  56     }
  57 }
  58
  59 reload_manifest;
  60
  61
  62 sub get_module_pat {
  63     my $m = shift;
  64     split ' ', $Modules{$m}{FILES};
  65 }
  66
  67 # exand dir/ or foo* into a full list of files
  68 #
  69 sub expand_glob {
  70     sort { lc $a cmp lc $b }
  71         map {
  72             -f $_ && $_ !~ /[*?]/ ? # File as-is.
  73                 $_ :
  74                 -d _ && $_ !~ /[*?]/ ? # Recurse into directories.
  75                 do {
  76                     my @files;
  77                     find(
  78                          sub {
  79                              push @files, $File::Find::name
  80                                  if -f $_ && exists $MANIFEST{$File::Find::name};
  81                          }, $_);
  82                     @files;
  83                 }
  84             # The rest are globbable patterns; expand the glob, then
  85             # recursively perform directory expansion on any results
  86             : expand_glob(grep -e $_,glob($_))
  87             } @_;
  88 }
  89
  90 sub filter_excluded {
  91     my ($m, @files) = @_;
  92
  93     return @files
  94         unless my $excluded = $Modules{$m}{EXCLUDED};
  95
  96     my ($pat) = map { qr/$_/ } join '|' => map {
  97         ref $_ ? qr/\Q$_\E/ : $_
  98     } @{ $excluded };
  99
 100     return grep { $_ !~ $pat } @files;
 101 }
 102
 103 sub get_module_files {
 104     my $m = shift;
 105     return filter_excluded $m => map { expand_glob($_) } get_module_pat($m);
 106 }
 107
 108
 109 sub get_maintainer_modules {
 110     my $m = shift;
 111     sort { lc $a cmp lc $b }
 112     grep { $Modules{$_}{MAINTAINER} eq $m }
 113     keys %Modules;
 114 }
 115
 116 sub usage {
 117     warn <<__EOF__;
 118 $0: Usage:
 119     --maintainer M | --module M [--files]
 120                 List modules or maintainers matching the pattern M.
 121                 With --files, list all the files associated with them
 122 or
 123     --check | --checkmani [commit | file ... | dir ... ]
 124                 Check consistency of Maintainers.pl
 125                         with a file     checks if it has a maintainer
 126                         with a dir      checks all files have a maintainer
 127                         with a commit   checks files modified by that commit
 128                         no arg          checks for multiple maintainers
 129                --checkmani is like --check, but only reports on unclaimed
 130                files if they are in MANIFEST
 131 or
 132     --opened  | file ....
 133                 List the module ownership of modified or the listed files
 134
 135     --tap-output
 136         Show results as valid TAP output. Currently only compatible
 137         with --check, --checkmani
 138
 139 Matching is case-ignoring regexp, author matching is both by
 140 the short id and by the full name and email.  A "module" may
 141 not be just a module, it may be a file or files or a subdirectory.
 142 The options may be abbreviated to their unique prefixes
 143 __EOF__
 144     exit(0);
 145 }
 146
 147 my $Maintainer;
 148 my $Module;
 149 my $Files;
 150 my $Check;
 151 my $Checkmani;
 152 my $Opened;
 153 my $TestCounter = 0;
 154 my $TapOutput;
 155
 156 sub process_options {
 157     usage()
 158         unless
 159             GetOptions(
 160                        'maintainer=s'   => \$Maintainer,
 161                        'module=s'       => \$Module,
 162                        'files'          => \$Files,
 163                        'check'          => \$Check,
 164                        'checkmani'      => \$Checkmani,
 165                        'opened'         => \$Opened,
 166                        'tap-output' => \$TapOutput,
 167                       );
 168
 169     my @Files;
 170
 171     if ($Opened) {
 172         usage if @ARGV;
 173         chomp (@Files = `git ls-files -m --full-name`);
 174         die if $?;
 175     } elsif (@ARGV == 1 &&
 176              $ARGV[0] =~ /^(?:HEAD|[0-9a-f]{4,40})(?:~\d+)?\^*$/) {
 177         my $command = "git diff --name-only $ARGV[0]^ $ARGV[0]";
 178         chomp (@Files = `$command`);
 179         die "'$command' failed: $?" if $?;
 180     } else {
 181         @Files = @ARGV;
 182     }
 183
 184     usage() if @Files && ($Maintainer || $Module || $Files);
 185
 186     for my $mean ($Maintainer, $Module) {
 187         warn "$0: Did you mean '$0 $mean'?\n"
 188             if $mean && -e $mean && $mean ne '.' && !$Files;
 189     }
 190
 191     warn "$0: Did you mean '$0 -mo $Maintainer'?\n"
 192         if defined $Maintainer && exists $Modules{$Maintainer};
 193
 194     warn "$0: Did you mean '$0 -ma $Module'?\n"
 195         if defined $Module     && exists $Maintainers{$Module};
 196
 197     return ($Maintainer, $Module, $Files, @Files);
 198 }
 199
 200 sub files_to_modules {
 201     my @Files = @_;
 202     my %ModuleByFile;
 203
 204     for (@Files) { s:^\./:: }
 205
 206     @ModuleByFile{@Files} = ();
 207
 208     # First try fast match.
 209
 210     my %ModuleByPat;
 211     for my $module (keys %Modules) {
 212         for my $pat (get_module_pat($module)) {
 213             $ModuleByPat{$pat} = $module;
 214         }
 215     }
 216     # Expand any globs.
 217     my %ExpModuleByPat;
 218     for my $pat (keys %ModuleByPat) {
 219         if (-e $pat) {
 220             $ExpModuleByPat{$pat} = $ModuleByPat{$pat};
 221         } else {
 222             for my $exp (glob($pat)) {
 223                 $ExpModuleByPat{$exp} = $ModuleByPat{$pat};
 224             }
 225         }
 226     }
 227     %ModuleByPat = %ExpModuleByPat;
 228     for my $file (@Files) {
 229         $ModuleByFile{$file} = $ModuleByPat{$file}
 230             if exists $ModuleByPat{$file};
 231     }
 232
 233     # If still unresolved files...
 234     if (my @ToDo = grep { !defined $ModuleByFile{$_} } keys %ModuleByFile) {
 235
 236         # Cannot match what isn't there.
 237         @ToDo = grep { -e $_ } @ToDo;
 238
 239         if (@ToDo) {
 240             # Try prefix matching.
 241
 242             # Need to try longst prefixes first, else lib/CPAN may match
 243             # lib/CPANPLUS/... and similar
 244
 245             my @OrderedModuleByPat
 246                 = sort {length $b <=> length $a} keys %ModuleByPat;
 247
 248             # Remove trailing slashes.
 249             for (@ToDo) { s|/$|| }
 250
 251             my %ToDo;
 252             @ToDo{@ToDo} = ();
 253
 254             for my $pat (@OrderedModuleByPat) {
 255                 last unless keys %ToDo;
 256                 if (-d $pat) {
 257                     my @Done;
 258                     for my $file (keys %ToDo) {
 259                         if ($file =~ m|^$pat|i) {
 260                             $ModuleByFile{$file} = $ModuleByPat{$pat};
 261                             push @Done, $file;
 262                         }
 263                     }
 264                     delete @ToDo{@Done};
 265                 }
 266             }
 267         }
 268     }
 269     \%ModuleByFile;
 270 }
 271 sub show_results {
 272     my ($Maintainer, $Module, $Files, @Files) = @_;
 273
 274     if ($Maintainer) {
 275         for my $m (sort keys %Maintainers) {
 276             if ($m =~ /$Maintainer/io || $Maintainers{$m} =~ /$Maintainer/io) {
 277                 my @modules = get_maintainer_modules($m);
 278                 if ($Module) {
 279                     @modules = grep { /$Module/io } @modules;
 280                 }
 281                 if ($Files) {
 282                     my @files;
 283                     for my $module (@modules) {
 284                         push @files, get_module_files($module);
 285                     }
 286                     printf "%-15s @files\n", $m;
 287                 } else {
 288                     if ($Module) {
 289                         printf "%-15s @modules\n", $m;
 290                     } else {
 291                         printf "%-15s $Maintainers{$m}\n", $m;
 292                     }
 293                 }
 294             }
 295         }
 296     } elsif ($Module) {
 297         for my $m (sort { lc $a cmp lc $b } keys %Modules) {
 298             if ($m =~ /$Module/io) {
 299                 if ($Files) {
 300                     my @files = get_module_files($m);
 301                     printf "%-15s @files\n", $m;
 302                 } else {
 303                     printf "%-15s %-12s %s\n", $m, $Modules{$m}{MAINTAINER}, $Modules{$m}{UPSTREAM}||'unknown';
 304                 }
 305             }
 306         }
 307     } elsif ($Check or $Checkmani) {
 308         if( @Files ) {
 309                     missing_maintainers(
 310                         $Checkmani
 311                             ? sub { -f $_ and exists $MANIFEST{$File::Find::name} }
 312                             : sub { /\.(?:[chty]|p[lm]|xs)\z/msx },
 313                         @Files
 314                     );
 315                 } else {
 316                     duplicated_maintainers();
 317                 }
 318     } elsif (@Files) {
 319         my $ModuleByFile = files_to_modules(@Files);
 320         for my $file (@Files) {
 321             if (defined $ModuleByFile->{$file}) {
 322                 my $module     = $ModuleByFile->{$file};
 323                 my $maintainer = $Modules{$ModuleByFile->{$file}}{MAINTAINER};
 324                 my $upstream   = $Modules{$module}{UPSTREAM}||'unknown';
 325                 printf "%-15s [%-7s] $module $maintainer $Maintainers{$maintainer}\n", $file, $upstream;
 326             } else {
 327                 printf "%-15s ?\n", $file;
 328             }
 329         }
 330     }
 331     elsif ($Opened) {
 332         print STDERR "(No files are modified)\n";
 333     }
 334     else {
 335         usage();
 336     }
 337 }
 338
 339 my %files;
 340
 341 sub maintainers_files {
 342     %files = ();
 343     for my $k (keys %Modules) {
 344         for my $f (get_module_files($k)) {
 345             ++$files{$f};
 346         }
 347     }
 348 }
 349
 350 sub duplicated_maintainers {
 351     maintainers_files();
 352     for my $f (keys %files) {
 353         if ($TapOutput) {
 354                 if ($files{$f} > 1) {
 355                     print  "not ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n";
 356             } else {
 357                     print  "ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n";
 358             }
 359         } else {
 360                 if ($files{$f} > 1) {
 361                     warn "File $f appears $files{$f} times in Maintainers.pl\n";
 362                 }
 363     }
 364     }
 365 }
 366
 367 sub warn_maintainer {
 368     my $name = shift;
 369     if ($TapOutput) {
 370         if ($files{$name}) {
 371             print "ok ".++$TestCounter." - $name has a maintainer\n";
 372         } else {
 373             print "not ok ".++$TestCounter." - $name has NO maintainer\n";
 374
 375         }
 376
 377     } else {
 378         warn "File $name has no maintainer\n" if not $files{$name};
 379     }
 380 }
 381
 382 sub missing_maintainers {
 383     my($check, @path) = @_;
 384     maintainers_files();
 385     my @dir;
 386     for my $d (@path) {
 387             if( -d $d ) { push @dir, $d } else { warn_maintainer($d) }
 388     }
 389     find sub { warn_maintainer($File::Find::name) if $check->() }, @dir if @dir;
 390 }
 391
 392 sub finish_tap_output {
 393     print "1..".$TestCounter."\n";
 394 }
 395
 396 1;
 397