Porting/Maintainers.pm

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