File Coverage

/home/pjcj/g/Test-Smoke/perl-current-gcov/Porting/Maintainers.pm
Criterion Covered Total %
statement 93 180 51.7
branch 32 88 36.4
condition 18 46 39.1
subroutine 24 28 85.7
total 167 342 48.8


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