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