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);
+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);
+ show_results process_options files_to_modules
+ finish_tap_output
+ reload_manifest);
+$VERSION = 0.04;
+
require Exporter;
use File::Find;
use Getopt::Long;
my %MANIFEST;
-if (open(MANIFEST, "MANIFEST")) {
- while (<MANIFEST>) {
- if (/^(\S+)\t+(.+)$/) {
- $MANIFEST{$1}++;
+
+# (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";
}
- close MANIFEST;
-} else {
- die "$0: Failed to open MANIFEST for reading: $!\n";
}
+reload_manifest;
+
+
sub get_module_pat {
my $m = shift;
split ' ', $Modules{$m}{FILES};
}
+# exand 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;
+ }
+ # The rest are globbable patterns; expand the glob, then
+ # recurively perform directory expansion on any results
+ : expand_glob(grep -e $_,glob($_))
+ } @_;
+}
+
sub get_module_files {
my $m = shift;
- sort { lc $a cmp lc $b }
- map {
- -f $_ ? # Files as-is.
- $_ :
- -d _ ? # Recurse into directories.
- do {
- my @files;
- find(
- sub {
- push @files, $File::Find::name
- if -f $_ && exists $MANIFEST{$File::Find::name};
- }, $_);
- @files;
- }
- : glob($_) # The rest are globbable patterns.
- } get_module_pat($m);
+ my %exclude;
+ my @files;
+ for (get_module_pat($m)) {
+ if (s/^!//) {
+ $exclude{$_}=1 for expand_glob($_);
+ }
+ else {
+ push @files, expand_glob($_);
+ }
+ }
+ return grep !$exclude{$_}, @files;
}
+
sub get_maintainer_modules {
my $m = shift;
sort { lc $a cmp lc $b }
}
sub usage {
- print <<__EOF__;
-$0: Usage: $0 [[--maintainer M --module M --files --check]|file ...]
---maintainer M list all maintainers matching M
---module M list all modules matching M
---files list all files
---check check consistency of Maintainers.pl
+ 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
+
+ --tap-output
+ Show results as valid TAP output. Currently only compatible
+ with --check, --checkmani
+
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.
my $Module;
my $Files;
my $Check;
+my $Checkmani;
+my $Opened;
+my $TestCounter = 0;
+my $TapOutput;
sub process_options {
usage()
'module=s' => \$Module,
'files' => \$Files,
'check' => \$Check,
+ 'checkmani' => \$Checkmani,
+ 'opened' => \$Opened,
+ 'tap-output' => \$TapOutput,
);
- my @Files = @ARGV;
+ 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);
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 longst 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) = @_;
my @files = get_module_files($m);
printf "%-15s @files\n", $m;
} else {
- printf "%-15s $Modules{$m}{MAINTAINER}\n", $m;
- }
- }
- }
- } elsif (@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};
+ printf "%-15s %-12s %s\n", $m, $Modules{$m}{MAINTAINER}, $Modules{$m}{UPSTREAM}||'unknown';
}
}
}
- %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.
-
- # Remove trailing slashes.
- for (@ToDo) { s|/$|| }
-
- my %ToDo;
- @ToDo{@ToDo} = ();
-
- for my $pat (keys %ModuleByPat) {
- 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};
- }
+ } elsif ($Check or $Checkmani) {
+ if( @Files ) {
+ missing_maintainers(
+ $Checkmani
+ ? sub { -f $_ and exists $MANIFEST{$File::Find::name} }
+ : sub { /\.(?:[chty]|p[lm]|xs)\z/msx },
+ @Files
+ );
+ } else {
+ duplicated_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};
- printf "%-15s $module $maintainer $Maintainers{$maintainer}\n", $file;
+ 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 ($Check) {
- duplicated_maintainers();
+ elsif ($Opened) {
+ print STDERR "(No files are modified)\n";
}
else {
usage();
}
}
-sub duplicated_maintainers {
- my %files;
+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 (keys %files) {
- if ($files{$f} > 1) {
- warn "File $f appears $files{$f} times in Maintainers.pl\n";
- }
+ if ($TapOutput) {
+ if ($files{$f} > 1) {
+ print "not ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n";
+ } else {
+ print "ok ".++$TestCounter." - File $f appears $files{$f} times in Maintainers.pl\n";
+ }
+ } else {
+ if ($files{$f} > 1) {
+ warn "File $f appears $files{$f} times in Maintainers.pl\n";
+ }
+ }
+ }
+}
+
+sub warn_maintainer {
+ my $name = shift;
+ if ($TapOutput) {
+ if ($files{$name}) {
+ print "ok ".++$TestCounter." - $name has a maintainer\n";
+ } else {
+ print "not ok ".++$TestCounter." - $name has NO maintainer\n";
+
+ }
+
+ } else {
+ warn "File $name has no maintainer\n" if not $files{$name};
}
}
+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 finish_tap_output {
+ print "1..".$TestCounter."\n";
+}
+
1;
https://perl5.git.perl.org / perl5.git / blobdiff