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.04;
  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             # recurively perform directory expansion on any results
  86             : expand_glob(grep -e $_,glob($_))
  87             } @_;
  88 }
  89
  90 sub get_module_files {
  91     my $m = shift;
  92     my %exclude;
  93     my @files;
  94     for (get_module_pat($m)) {
  95         if (s/^!//) {
  96             $exclude{$_}=1 for expand_glob($_);
  97         }
  98         else {
  99             push @files, expand_glob($_);
 100         }
 101     }
 102     return grep !$exclude{$_}, @files;
 103 }
 104
 105
 106 sub get_maintainer_modules {
 107     my $m = shift;
 108     sort { lc $a cmp lc $b }
 109     grep { $Modules{$_}{MAINTAINER} eq $m }
 110     keys %Modules;
 111 }
 112
 113 sub usage {
 114     warn <<__EOF__;
 115 $0: Usage:
 116     --maintainer M | --module M [--files]
 117                 List modules or maintainers matching the pattern M.
 118                 With --files, list all the files associated with them
 119 or
 120     --check | --checkmani [commit | file ... | dir ... ]
 121                 Check consistency of Maintainers.pl
 122                         with a file     checks if it has a maintainer
 123                         with a dir      checks all files have a maintainer
 124                         with a commit   checks files modified by that commit
 125                         no arg          checks for multiple maintainers
 126                --checkmani is like --check, but only reports on unclaimed
 127                files if they are in MANIFEST
 128 or
 129     --opened  | file ....
 130                 List the module ownership of modified or the listed files
 131
 132     --tap-output
 133         Show results as valid TAP output. Currently only compatible
 134         with --check, --checkmani
 135
 136 Matching is case-ignoring regexp, author matching is both by
 137 the short id and by the full name and email.  A "module" may
 138 not be just a module, it may be a file or files or a subdirectory.
 139 The options may be abbreviated to their unique prefixes
 140 __EOF__
 141     exit(0);
 142 }
 143
 144 my $Maintainer;
 145 my $Module;
 146 my $Files;
 147 my $Check;
 148 my $Checkmani;
 149 my $Opened;
 150 my $TestCounter = 0;
 151 my $TapOutput;
 152
 153 sub process_options {
 154     usage()
 155         unless
 156             GetOptions(
 157                        'maintainer=s'   => \$Maintainer,
 158                        'module=s'       => \$Module,
 159                        'files'          => \$Files,
 160                        'check'          => \$Check,
 161                        'checkmani'      => \$Checkmani,
 162                        'opened'         => \$Opened,
 163                        'tap-output' => \$TapOutput,
 164                       );
 165
 166     my @Files;
 167
 168     if ($Opened) {
 169         usage if @ARGV;
 170         chomp (@Files = `git ls-files -m --full-name`);
 171         die if $?;
 172     } elsif (@ARGV == 1 &&
 173              $ARGV[0] =~ /^(?:HEAD|[0-9a-f]{4,40})(?:~\d+)?\^*$/) {
 174         my $command = "git diff --name-only $ARGV[0]^ $ARGV[0]";
 175         chomp (@Files = `$command`);
 176         die "'$command' failed: $?" if $?;
 177     } else {
 178         @Files = @ARGV;
 179     }
 180
 181     usage() if @Files && ($Maintainer || $Module || $Files);
 182
 183     for my $mean ($Maintainer, $Module) {
 184         warn "$0: Did you mean '$0 $mean'?\n"
 185             if $mean && -e $mean && $mean ne '.' && !$Files;
 186     }
 187
 188     warn "$0: Did you mean '$0 -mo $Maintainer'?\n"
 189         if defined $Maintainer && exists $Modules{$Maintainer};
 190
 191     warn "$0: Did you mean '$0 -ma $Module'?\n"
 192         if defined $Module     && exists $Maintainers{$Module};
 193
 194     return ($Maintainer, $Module, $Files, @Files);
 195 }
 196
 197 sub files_to_modules {
 198     my @Files = @_;
 199     my %ModuleByFile;
 200
 201     for (@Files) { s:^\./:: }
 202
 203     @ModuleByFile{@Files} = ();
 204
 205     # First try fast match.
 206
 207     my %ModuleByPat;
 208     for my $module (keys %Modules) {
 209         for my $pat (get_module_pat($module)) {
 210             $ModuleByPat{$pat} = $module;
 211         }
 212     }
 213     # Expand any globs.
 214     my %ExpModuleByPat;
 215     for my $pat (keys %ModuleByPat) {
 216         if (-e $pat) {
 217             $ExpModuleByPat{$pat} = $ModuleByPat{$pat};
 218         } else {
 219             for my $exp (glob($pat)) {
 220                 $ExpModuleByPat{$exp} = $ModuleByPat{$pat};
 221             }
 222         }
 223     }
 224     %ModuleByPat = %ExpModuleByPat;
 225     for my $file (@Files) {
 226         $ModuleByFile{$file} = $ModuleByPat{$file}
 227             if exists $ModuleByPat{$file};
 228     }
 229
 230     # If still unresolved files...
 231     if (my @ToDo = grep { !defined $ModuleByFile{$_} } keys %ModuleByFile) {
 232
 233         # Cannot match what isn't there.
 234         @ToDo = grep { -e $_ } @ToDo;
 235
 236         if (@ToDo) {
 237             # Try prefix matching.
 238
 239             # Need to try longst prefixes first, else lib/CPAN may match
 240             # lib/CPANPLUS/... and similar
 241
 242             my @OrderedModuleByPat
 243                 = sort {length $b <=> length $a} keys %ModuleByPat;
 244
 245             # Remove trailing slashes.
 246             for (@ToDo) { s|/$|| }
 247
 248             my %ToDo;
 249             @ToDo{@ToDo} = ();
 250
 251             for my $pat (@OrderedModuleByPat) {
 252                 last unless keys %ToDo;
 253                 if (-d $pat) {
 254                     my @Done;
 255                     for my $file (keys %ToDo) {
 256                         if ($file =~ m|^$pat|i) {
 257                             $ModuleByFile{$file} = $ModuleByPat{$pat};
 258                             push @Done, $file;
 259                         }
 260                     }
 261                     delete @ToDo{@Done};
 262                 }
 263             }
 264         }
 265     }
 266     \%ModuleByFile;
 267 }
 268 sub show_results {
 269     my ($Maintainer, $Module, $Files, @Files) = @_;
 270
 271     if ($Maintainer) {
 272         for my $m (sort keys %Maintainers) {
 273             if ($m =~ /$Maintainer/io || $Maintainers{$m} =~ /$Maintainer/io) {
 274                 my @modules = get_maintainer_modules($m);
 275                 if ($Module) {
 276                     @modules = grep { /$Module/io } @modules;
 277                 }
 278                 if ($Files) {
 279                     my @files;
 280                     for my $module (@modules) {
 281                         push @files, get_module_files($module);
 282                     }
 283                     printf "%-15s @files\n", $m;
 284                 } else {
 285                     if ($Module) {
 286                         printf "%-15s @modules\n", $m;
 287                     } else {
 288                         printf "%-15s $Maintainers{$m}\n", $m;
 289                     }
 290                 }
 291             }
 292         }
 293     } elsif ($Module) {
 294         for my $m (sort { lc $a cmp lc $b } keys %Modules) {
 295             if ($m =~ /$Module/io) {
 296                 if ($Files) {
 297                     my @files = get_module_files($m);
 298                     printf "%-15s @files\n", $m;
 299                 } else {
 300                     printf "%-15s %-12s %s\n", $m, $Modules{$m}{MAINTAINER}, $Modules{$m}{UPSTREAM}||'unknown';
 301                 }
 302             }
 303         }
 304     } elsif ($Check or $Checkmani) {
 305         if( @Files ) {
 306                     missing_maintainers(
 307                         $Checkmani
 308                             ? sub { -f $_ and exists $MANIFEST{$File::Find::name} }
 309                             : sub { /\.(?:[chty]|p[lm]|xs)\z/msx },
 310                         @Files
 311                     );
 312                 } else {
 313                     duplicated_maintainers();
 314                 }
 315     } elsif (@Files) {
 316         my $ModuleByFile = files_to_modules(@Files);
 317         for my $file (@Files) {
 318             if (defined $ModuleByFile->{$file}) {
 319                 my $module     = $ModuleByFile->{$file};
 320                 my $maintainer = $Modules{$ModuleByFile->{$file}}{MAINTAINER};
 321                 my $upstream   = $Modules{$module}{UPSTREAM}||'unknown';
 322                 printf "%-15s [%-7s] $module $maintainer $Maintainers{$maintainer}\n", $file, $upstream;
 323             } else {
 324                 printf "%-15s ?\n", $file;
 325             }
 326         }
 327     }
 328     elsif ($Opened) {
 329         print STDERR "(No files are modified)\n";
 330     }
 331     else {
 332         usage();
 333     }
 334 }
 335
 336 my %files;
 337
 338 sub maintainers_files {
 339     %files = ();
 340     for my $k (keys %Modules) {
 341         for my $f (get_module_files($k)) {
 342             ++$files{$f};
 343         }
 344     }
 345 }
 346
 347 sub duplicated_maintainers {
 348     maintainers_files();
 349     for my $f (keys %files) {
 350         if ($TapOutput) {
 351                 if ($files{$f} > 1) {
 352                     print  "not ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n";
 353             } else {
 354                     print  "ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n";
 355             }
 356         } else {
 357                 if ($files{$f} > 1) {
 358                     warn "File $f appears $files{$f} times in Maintainers.pl\n";
 359                 }
 360     }
 361     }
 362 }
 363
 364 sub warn_maintainer {
 365     my $name = shift;
 366     if ($TapOutput) {
 367         if ($files{$name}) {
 368             print "ok ".++$TestCounter." - $name has a maintainer\n";
 369         } else {
 370             print "not ok ".++$TestCounter." - $name has NO maintainer\n";
 371
 372         }
 373
 374     } else {
 375         warn "File $name has no maintainer\n" if not $files{$name};
 376     }
 377 }
 378
 379 sub missing_maintainers {
 380     my($check, @path) = @_;
 381     maintainers_files();
 382     my @dir;
 383     for my $d (@path) {
 384             if( -d $d ) { push @dir, $d } else { warn_maintainer($d) }
 385     }
 386     find sub { warn_maintainer($File::Find::name) if $check->() }, @dir if @dir;
 387 }
 388
 389 sub finish_tap_output {
 390     print "1..".$TestCounter."\n";
 391 }
 392
 393 1;
 394