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