File: Maintainers.pm

package info (click to toggle)
perl 5.24.1-3+deb9u5
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 103,716 kB
  • sloc: perl: 559,611; ansic: 293,886; sh: 67,316; pascal: 7,632; cpp: 3,895; makefile: 2,436; xml: 2,410; yacc: 989; sed: 6; lisp: 1
file content (384 lines) | stat: -rw-r--r-- 8,890 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
#
# Maintainers.pm - show information about maintainers
#

package Maintainers;

use strict;
use warnings;

use lib "Porting";
# Please don't use post 5.008 features as this module is used by
# Porting/makemeta, and that in turn has to be run by the perl just built.
use 5.008;

require "Maintainers.pl";
use vars qw(%Modules %Maintainers);

use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(%Modules %Maintainers
		get_module_files get_module_pat
		show_results process_options files_to_modules
		finish_tap_output
		reload_manifest);
$VERSION = 0.10;

require Exporter;

use File::Find;
use Getopt::Long;

my %MANIFEST;

# (re)read the MANIFEST file, blowing away any previous effort

sub reload_manifest {
    %MANIFEST = ();

    my $manifest_path = 'MANIFEST';
   if (! -e  $manifest_path) {
        $manifest_path = "../MANIFEST";
    }

    if (open(my $manfh,  $manifest_path )) {
	while (<$manfh>) {
	    if (/^(\S+)/) {
		$MANIFEST{$1}++;
	    }
	    else {
		warn "MANIFEST:$.: malformed line: $_\n";
	    }
	}
	close $manfh;
    } else {
	    die "$0: Failed to open MANIFEST for reading: $!\n";
    }
}

reload_manifest;


sub get_module_pat {
    my $m = shift;
    split ' ', $Modules{$m}{FILES};
}

# expand dir/ or foo* into a full list of files
#
sub expand_glob {
    sort { lc $a cmp lc $b }
	map {
	    -f $_ && $_ !~ /[*?]/ ? # File as-is.
		$_ :
		-d _ && $_ !~ /[*?]/ ? # Recurse into directories.
		do {
		    my @files;
		    find(
			 sub {
			     push @files, $File::Find::name
				 if -f $_ && exists $MANIFEST{$File::Find::name};
			 }, $_);
		    @files;
		}
	    # Not a glob, but doesn't exist
	    : $_ !~ /[*?{]/ ? $_
	    # The rest are globbable patterns; expand the glob, then
	    # recursively perform directory expansion on any results
	    : expand_glob(glob($_))
	    } @_;
}

sub filter_excluded {
    my ($m, @files) = @_;

    my $excluded = $Modules{$m}{EXCLUDED};
    return @files
	unless $excluded and @$excluded;

    my ($pat) = map { qr/$_/ } join '|' => map {
	ref $_ ? $_ : qr/\b\Q$_\E$/
    } @{ $excluded };

    return grep { $_ !~ $pat } @files;
}

sub get_module_files {
    my $m = shift;
    return filter_excluded $m => map { expand_glob($_) } get_module_pat($m);
}


sub get_maintainer_modules {
    my $m = shift;
    sort { lc $a cmp lc $b }
    grep { $Modules{$_}{MAINTAINER} eq $m }
    keys %Modules;
}

sub usage {
    warn <<__EOF__;
$0: Usage:
    --maintainer M | --module M [--files]
		List modules or maintainers matching the pattern M.
		With --files, list all the files associated with them
or
    --check | --checkmani [commit | file ... | dir ... ]
		Check consistency of Maintainers.pl
			with a file	checks if it has a maintainer
			with a dir	checks all files have a maintainer
			with a commit   checks files modified by that commit
			no arg		checks for multiple maintainers
	       --checkmani is like --check, but only reports on unclaimed
	       files if they are in MANIFEST
or
    --opened  | file ....
		List the module ownership of modified or the listed files

Matching is case-ignoring regexp, author matching is both by
the short id and by the full name and email.  A "module" may
not be just a module, it may be a file or files or a subdirectory.
The options may be abbreviated to their unique prefixes
__EOF__
    exit(0);
}

my $Maintainer;
my $Module;
my $Files;
my $Check;
my $Checkmani;
my $Opened;
my $TestCounter = 0;

sub process_options {
    usage()
	unless
	    GetOptions(
		       'maintainer=s'	=> \$Maintainer,
		       'module=s'	=> \$Module,
		       'files'		=> \$Files,
		       'check'		=> \$Check,
		       'checkmani'	=> \$Checkmani,
		       'opened'		=> \$Opened,
		      );

    my @Files;

    if ($Opened) {
	usage if @ARGV;
	chomp (@Files = `git ls-files -m --full-name`);
	die if $?;
    } elsif (@ARGV == 1 &&
	     $ARGV[0] =~ /^(?:HEAD|[0-9a-f]{4,40})(?:~\d+)?\^*$/) {
	my $command = "git diff --name-only $ARGV[0]^ $ARGV[0]";
	chomp (@Files = `$command`);
	die "'$command' failed: $?" if $?;
    } else {
	@Files = @ARGV;
    }

    usage() if @Files && ($Maintainer || $Module || $Files);

    for my $mean ($Maintainer, $Module) {
	warn "$0: Did you mean '$0 $mean'?\n"
	    if $mean && -e $mean && $mean ne '.' && !$Files;
    }

    warn "$0: Did you mean '$0 -mo $Maintainer'?\n"
	if defined $Maintainer && exists $Modules{$Maintainer};

    warn "$0: Did you mean '$0 -ma $Module'?\n"
	if defined $Module     && exists $Maintainers{$Module};

    return ($Maintainer, $Module, $Files, @Files);
}

sub files_to_modules {
    my @Files = @_;
    my %ModuleByFile;

    for (@Files) { s:^\./:: }

    @ModuleByFile{@Files} = ();

    # First try fast match.

    my %ModuleByPat;
    for my $module (keys %Modules) {
	for my $pat (get_module_pat($module)) {
	    $ModuleByPat{$pat} = $module;
	}
    }
    # Expand any globs.
    my %ExpModuleByPat;
    for my $pat (keys %ModuleByPat) {
	if (-e $pat) {
	    $ExpModuleByPat{$pat} = $ModuleByPat{$pat};
	} else {
	    for my $exp (glob($pat)) {
		$ExpModuleByPat{$exp} = $ModuleByPat{$pat};
	    }
	}
    }
    %ModuleByPat = %ExpModuleByPat;
    for my $file (@Files) {
	$ModuleByFile{$file} = $ModuleByPat{$file}
	    if exists $ModuleByPat{$file};
    }

    # If still unresolved files...
    if (my @ToDo = grep { !defined $ModuleByFile{$_} } keys %ModuleByFile) {

	# Cannot match what isn't there.
	@ToDo = grep { -e $_ } @ToDo;

	if (@ToDo) {
	    # Try prefix matching.

	    # Need to try longest prefixes first, else lib/CPAN may match
	    # lib/CPANPLUS/... and similar

	    my @OrderedModuleByPat
		= sort {length $b <=> length $a} keys %ModuleByPat;

	    # Remove trailing slashes.
	    for (@ToDo) { s|/$|| }

	    my %ToDo;
	    @ToDo{@ToDo} = ();

	    for my $pat (@OrderedModuleByPat) {
		last unless keys %ToDo;
		if (-d $pat) {
		    my @Done;
		    for my $file (keys %ToDo) {
			if ($file =~ m|^$pat|i) {
			    $ModuleByFile{$file} = $ModuleByPat{$pat};
			    push @Done, $file;
			}
		    }
		    delete @ToDo{@Done};
		}
	    }
	}
    }
    \%ModuleByFile;
}
sub show_results {
    my ($Maintainer, $Module, $Files, @Files) = @_;

    if ($Maintainer) {
	for my $m (sort keys %Maintainers) {
	    if ($m =~ /$Maintainer/io || $Maintainers{$m} =~ /$Maintainer/io) {
		my @modules = get_maintainer_modules($m);
		if ($Module) {
		    @modules = grep { /$Module/io } @modules;
		}
		if ($Files) {
		    my @files;
		    for my $module (@modules) {
			push @files, get_module_files($module);
		    }
		    printf "%-15s @files\n", $m;
		} else {
		    if ($Module) {
			printf "%-15s @modules\n", $m;
		    } else {
			printf "%-15s $Maintainers{$m}\n", $m;
		    }
		}
	    }
	}
    } elsif ($Module) {
	for my $m (sort { lc $a cmp lc $b } keys %Modules) {
	    if ($m =~ /$Module/io) {
		if ($Files) {
		    my @files = get_module_files($m);
		    printf "%-15s @files\n", $m;
		} else {
		    printf "%-15s %-12s %s\n", $m, $Modules{$m}{MAINTAINER}, $Modules{$m}{UPSTREAM}||'unknown';
		}
	    }
	}
    } elsif ($Check or $Checkmani) {
        require Test::More;
        Test::More->import;
        if( @Files ) {
		    missing_maintainers(
			$Checkmani
			    ? sub { -f $_ and exists $MANIFEST{$File::Find::name} }
			    : sub { /\.(?:[chty]|p[lm]|xs)\z/msx },
			@Files
		    );
		} else {
		    duplicated_maintainers();
		    superfluous_maintainers();
		}
    } elsif (@Files) {
	my $ModuleByFile = files_to_modules(@Files);
	for my $file (@Files) {
	    if (defined $ModuleByFile->{$file}) {
		my $module     = $ModuleByFile->{$file};
		my $maintainer = $Modules{$ModuleByFile->{$file}}{MAINTAINER};
		my $upstream   = $Modules{$module}{UPSTREAM}||'unknown';
		printf "%-15s [%-7s] $module $maintainer $Maintainers{$maintainer}\n", $file, $upstream;
	    } else {
		printf "%-15s ?\n", $file;
	    }
	}
    }
    elsif ($Opened) {
	print STDERR "(No files are modified)\n";
    }
    else {
	usage();
    }
}

my %files;

sub maintainers_files {
    %files = ();
    for my $k (keys %Modules) {
	for my $f (get_module_files($k)) {
	    ++$files{$f};
	}
    }
}

sub duplicated_maintainers {
    maintainers_files();
    for my $f (sort keys %files) {
        cmp_ok($files{$f}, '<=', 1, "File $f appears $files{$f} times in Maintainers.pl");
    }
}

sub warn_maintainer {
    my $name = shift;
    ok($files{$name}, "$name has a maintainer");
}

sub missing_maintainers {
    my($check, @path) = @_;
    maintainers_files();
    my @dir;
    for my $d (@path) {
	    if( -d $d ) { push @dir, $d } else { warn_maintainer($d) }
    }
    find sub { warn_maintainer($File::Find::name) if $check->() }, @dir if @dir;
}

sub superfluous_maintainers {
    maintainers_files();
    for my $f (sort keys %files) {
        ok($MANIFEST{$f}, "File $f has a maintainer and is in MANIFEST");
    }
}

sub finish_tap_output {
    done_testing();
}

1;