2 # (c) 2007, Joe Perches <joe@perches.com>
3 # created from checkpatch.pl
5 # Print selected MAINTAINERS information for
6 # the files modified in a patch or for a file
8 # usage: perl scripts/get_maintainer.pl [OPTIONS] <patch>
9 # perl scripts/get_maintainer.pl [OPTIONS] -f <file>
11 # Licensed under the terms of the GNU GPL License version 2
19 use Getopt
::Long
qw(:config no_auto_abbrev);
23 my $email_usename = 1;
24 my $email_maintainer = 1;
26 my $email_subscriber_list = 0;
28 my $email_git_all_signature_types = 0;
29 my $email_git_blame = 0;
30 my $email_git_blame_signatures = 1;
31 my $email_git_fallback = 1;
32 my $email_git_min_signatures = 1;
33 my $email_git_max_maintainers = 5;
34 my $email_git_min_percent = 5;
35 my $email_git_since = "1-year-ago";
36 my $email_hg_since = "-365";
38 my $email_remove_duplicates = 1;
39 my $email_use_mailmap = 1;
40 my $output_multiline = 1;
41 my $output_separator = ", ";
43 my $output_rolestats = 1;
51 my $from_filename = 0;
52 my $pattern_depth = 0;
60 my %commit_author_hash;
61 my %commit_signer_hash;
63 # Signature types of people who are either
64 # a) responsible for the code in question, or
65 # b) familiar enough with it to give relevant feedback
66 my @signature_tags = ();
67 push(@signature_tags, "Signed-off-by:");
68 push(@signature_tags, "Reviewed-by:");
69 push(@signature_tags, "Acked-by:");
71 my $signature_pattern = "\(" . join("|", @signature_tags) . "\)";
73 # rfc822 email address - preloaded methods go here.
74 my $rfc822_lwsp = "(?:(?:\\r\\n)?[ \\t])";
75 my $rfc822_char = '[\\000-\\377]';
77 # VCS command support: class-like functions and strings
82 "execute_cmd" => \
&git_execute_cmd
,
83 "available" => '(which("git") ne "") && (-d ".git")',
85 "git log --no-color --follow --since=\$email_git_since " .
86 '--format="GitCommit: %H%n' .
87 'GitAuthor: %an <%ae>%n' .
92 "find_commit_signers_cmd" =>
93 "git log --no-color " .
94 '--format="GitCommit: %H%n' .
95 'GitAuthor: %an <%ae>%n' .
100 "find_commit_author_cmd" =>
101 "git log --no-color " .
102 '--format="GitCommit: %H%n' .
103 'GitAuthor: %an <%ae>%n' .
105 'GitSubject: %s%n"' .
107 "blame_range_cmd" => "git blame -l -L \$diff_start,+\$diff_length \$file",
108 "blame_file_cmd" => "git blame -l \$file",
109 "commit_pattern" => "^GitCommit: ([0-9a-f]{40,40})",
110 "blame_commit_pattern" => "^([0-9a-f]+) ",
111 "author_pattern" => "^GitAuthor: (.*)",
112 "subject_pattern" => "^GitSubject: (.*)",
116 "execute_cmd" => \
&hg_execute_cmd
,
117 "available" => '(which("hg") ne "") && (-d ".hg")',
118 "find_signers_cmd" =>
119 "hg log --date=\$email_hg_since " .
120 "--template='HgCommit: {node}\\n" .
121 "HgAuthor: {author}\\n" .
122 "HgSubject: {desc}\\n'" .
124 "find_commit_signers_cmd" =>
126 "--template='HgSubject: {desc}\\n'" .
128 "find_commit_author_cmd" =>
130 "--template='HgCommit: {node}\\n" .
131 "HgAuthor: {author}\\n" .
132 "HgSubject: {desc|firstline}\\n'" .
134 "blame_range_cmd" => "", # not supported
135 "blame_file_cmd" => "hg blame -n \$file",
136 "commit_pattern" => "^HgCommit: ([0-9a-f]{40,40})",
137 "blame_commit_pattern" => "^([ 0-9a-f]+):",
138 "author_pattern" => "^HgAuthor: (.*)",
139 "subject_pattern" => "^HgSubject: (.*)",
142 my $conf = which_conf
(".get_maintainer.conf");
145 open(my $conffile, '<', "$conf")
146 or warn "$P: Can't find a readable .get_maintainer.conf file $!\n";
148 while (<$conffile>) {
151 $line =~ s/\s*\n?$//g;
155 next if ($line =~ m/^\s*#/);
156 next if ($line =~ m/^\s*$/);
158 my @words = split(" ", $line);
159 foreach my $word (@words) {
160 last if ($word =~ m/^#/);
161 push (@conf_args, $word);
165 unshift(@ARGV, @conf_args) if @conf_args;
170 'git!' => \
$email_git,
171 'git-all-signature-types!' => \
$email_git_all_signature_types,
172 'git-blame!' => \
$email_git_blame,
173 'git-blame-signatures!' => \
$email_git_blame_signatures,
174 'git-fallback!' => \
$email_git_fallback,
175 'git-min-signatures=i' => \
$email_git_min_signatures,
176 'git-max-maintainers=i' => \
$email_git_max_maintainers,
177 'git-min-percent=i' => \
$email_git_min_percent,
178 'git-since=s' => \
$email_git_since,
179 'hg-since=s' => \
$email_hg_since,
180 'i|interactive!' => \
$interactive,
181 'remove-duplicates!' => \
$email_remove_duplicates,
182 'mailmap!' => \
$email_use_mailmap,
183 'm!' => \
$email_maintainer,
184 'n!' => \
$email_usename,
185 'l!' => \
$email_list,
186 's!' => \
$email_subscriber_list,
187 'multiline!' => \
$output_multiline,
188 'roles!' => \
$output_roles,
189 'rolestats!' => \
$output_rolestats,
190 'separator=s' => \
$output_separator,
191 'subsystem!' => \
$subsystem,
192 'status!' => \
$status,
195 'pattern-depth=i' => \
$pattern_depth,
196 'k|keywords!' => \
$keywords,
197 'sections!' => \
$sections,
198 'fe|file-emails!' => \
$file_emails,
199 'f|file' => \
$from_filename,
200 'v|version' => \
$version,
201 'h|help|usage' => \
$help,
203 die "$P: invalid argument - use --help if necessary\n";
212 print("${P} ${V}\n");
216 if (-t STDIN
&& !@ARGV) {
217 # We're talking to a terminal, but have no command line arguments.
218 die "$P: missing patchfile or -f file - use --help if necessary\n";
221 $output_multiline = 0 if ($output_separator ne ", ");
222 $output_rolestats = 1 if ($interactive);
223 $output_roles = 1 if ($output_rolestats);
235 my $selections = $email + $scm + $status + $subsystem + $web;
236 if ($selections == 0) {
237 die "$P: Missing required option: email, scm, status, subsystem or web\n";
242 ($email_maintainer + $email_list + $email_subscriber_list +
243 $email_git + $email_git_blame) == 0) {
244 die "$P: Please select at least 1 email option\n";
247 if (!top_of_tree
($lk_path)) {
248 die "$P: The current directory does not appear to be "
249 . "a QEMU source tree.\n";
252 ## Read MAINTAINERS for type/value pairs
257 open (my $maint, '<', "${lk_path}MAINTAINERS")
258 or die "$P: Can't open MAINTAINERS: $!\n";
262 if ($line =~ m/^(.):\s*(.*)/) {
266 ##Filename pattern matching
267 if ($type eq "F" || $type eq "X") {
268 $value =~ s
@\.@\\\.@g; ##Convert . to \.
269 $value =~ s/\*/\.\*/g; ##Convert * to .*
270 $value =~ s/\?/\./g; ##Convert ? to .
271 ##if pattern is a directory and it lacks a trailing slash, add one
273 $value =~ s
@([^/])$@$1/@;
275 } elsif ($type eq "K") {
276 $keyword_hash{@typevalue} = $value;
278 push(@typevalue, "$type:$value");
279 } elsif (!/^(\s)*$/) {
281 push(@typevalue, $line);
288 # Read mail address map
301 return if (!$email_use_mailmap || !(-f
"${lk_path}.mailmap"));
303 open(my $mailmap_file, '<', "${lk_path}.mailmap")
304 or warn "$P: Can't open .mailmap: $!\n";
306 while (<$mailmap_file>) {
307 s/#.*$//; #strip comments
308 s/^\s+|\s+$//g; #trim
310 next if (/^\s*$/); #skip empty lines
311 #entries have one of the following formats:
314 # name1 <mail1> <mail2>
315 # name1 <mail1> name2 <mail2>
316 # (see man git-shortlog)
318 if (/^([^<]+)<([^>]+)>$/) {
322 $real_name =~ s/\s+$//;
323 ($real_name, $address) = parse_email
("$real_name <$address>");
324 $mailmap->{names
}->{$address} = $real_name;
326 } elsif (/^<([^>]+)>\s*<([^>]+)>$/) {
327 my $real_address = $1;
328 my $wrong_address = $2;
330 $mailmap->{addresses
}->{$wrong_address} = $real_address;
332 } elsif (/^(.+)<([^>]+)>\s*<([^>]+)>$/) {
334 my $real_address = $2;
335 my $wrong_address = $3;
337 $real_name =~ s/\s+$//;
338 ($real_name, $real_address) =
339 parse_email
("$real_name <$real_address>");
340 $mailmap->{names
}->{$wrong_address} = $real_name;
341 $mailmap->{addresses
}->{$wrong_address} = $real_address;
343 } elsif (/^(.+)<([^>]+)>\s*(.+)\s*<([^>]+)>$/) {
345 my $real_address = $2;
347 my $wrong_address = $4;
349 $real_name =~ s/\s+$//;
350 ($real_name, $real_address) =
351 parse_email
("$real_name <$real_address>");
353 $wrong_name =~ s/\s+$//;
354 ($wrong_name, $wrong_address) =
355 parse_email
("$wrong_name <$wrong_address>");
357 my $wrong_email = format_email
($wrong_name, $wrong_address, 1);
358 $mailmap->{names
}->{$wrong_email} = $real_name;
359 $mailmap->{addresses
}->{$wrong_email} = $real_address;
362 close($mailmap_file);
365 ## use the filenames on the command line or find the filenames in the patchfiles
369 my @keyword_tvi = ();
370 my @file_emails = ();
373 push(@ARGV, "&STDIN");
376 foreach my $file (@ARGV) {
377 if ($file ne "&STDIN") {
378 ##if $file is a directory and it lacks a trailing slash, add one
380 $file =~ s
@([^/])$@$1/@;
381 } elsif (!(-f
$file)) {
382 die "$P: file '${file}' not found\n";
385 if ($from_filename) {
387 if ($file ne "MAINTAINERS" && -f
$file && ($keywords || $file_emails)) {
388 open(my $f, '<', $file)
389 or die "$P: Can't open $file: $!\n";
390 my $text = do { local($/) ; <$f> };
393 foreach my $line (keys %keyword_hash) {
394 if ($text =~ m/$keyword_hash{$line}/x) {
395 push(@keyword_tvi, $line);
400 my @poss_addr = $text =~ m
$[A-Za-zÀ
-ÿ
\"\' \
,\
.\
+-]*\s
*[\
,]*\s
*[\
(\
<\
{]{0,1}[A-Za-z0-9_\
.\
+-]+\
@[A-Za-z0-9\
.-]+\
.[A-Za-z0-9
]+[\
)\
>\
}]{0,1}$g;
401 push(@file_emails, clean_file_emails
(@poss_addr));
405 my $file_cnt = @files;
408 open(my $patch, "< $file")
409 or die "$P: Can't open $file: $!\n";
411 # We can check arbitrary information before the patch
412 # like the commit message, mail headers, etc...
413 # This allows us to match arbitrary keywords against any part
414 # of a git format-patch generated file (subject tags, etc...)
416 my $patch_prefix = ""; #Parsing the intro
420 if (m/^\+\+\+\s+(\S+)/) {
422 $filename =~ s
@^[^/]*/@@;
424 $lastfile = $filename;
425 push(@files, $filename);
426 $patch_prefix = "^[+-].*"; #Now parsing the actual patch
427 } elsif (m/^\@\@ -(\d+),(\d+)/) {
428 if ($email_git_blame) {
429 push(@range, "$lastfile:$1:$2");
431 } elsif ($keywords) {
432 foreach my $line (keys %keyword_hash) {
433 if ($patch_line =~ m/${patch_prefix}$keyword_hash{$line}/x) {
434 push(@keyword_tvi, $line);
441 if ($file_cnt == @files) {
442 warn "$P: file '${file}' doesn't appear to be a patch. "
443 . "Add -f to options?\n";
445 @files = sort_and_uniq
(@files);
449 @file_emails = uniq
(@file_emails);
452 my %email_hash_address;
460 my %deduplicate_name_hash = ();
461 my %deduplicate_address_hash = ();
463 my @maintainers = get_maintainers
();
466 @maintainers = merge_email
(@maintainers);
467 output
(@maintainers);
476 @status = uniq
(@status);
481 @subsystem = uniq
(@subsystem);
492 sub range_is_maintained
{
493 my ($start, $end) = @_;
495 for (my $i = $start; $i < $end; $i++) {
496 my $line = $typevalue[$i];
497 if ($line =~ m/^(.):\s*(.*)/) {
501 if ($value =~ /(maintain|support)/i) {
510 sub range_has_maintainer
{
511 my ($start, $end) = @_;
513 for (my $i = $start; $i < $end; $i++) {
514 my $line = $typevalue[$i];
515 if ($line =~ m/^(.):\s*(.*)/) {
526 sub get_maintainers
{
527 %email_hash_name = ();
528 %email_hash_address = ();
529 %commit_author_hash = ();
530 %commit_signer_hash = ();
538 %deduplicate_name_hash = ();
539 %deduplicate_address_hash = ();
540 if ($email_git_all_signature_types) {
541 $signature_pattern = "(.+?)[Bb][Yy]:";
543 $signature_pattern = "\(" . join("|", @signature_tags) . "\)";
546 # Find responsible parties
548 my %exact_pattern_match_hash = ();
550 foreach my $file (@files) {
553 my $tvi = find_first_section
();
554 while ($tvi < @typevalue) {
555 my $start = find_starting_index
($tvi);
556 my $end = find_ending_index
($tvi);
560 #Do not match excluded file patterns
562 for ($i = $start; $i < $end; $i++) {
563 my $line = $typevalue[$i];
564 if ($line =~ m/^(.):\s*(.*)/) {
568 if (file_match_pattern
($file, $value)) {
577 for ($i = $start; $i < $end; $i++) {
578 my $line = $typevalue[$i];
579 if ($line =~ m/^(.):\s*(.*)/) {
583 if (file_match_pattern
($file, $value)) {
584 my $value_pd = ($value =~ tr
@/@@);
585 my $file_pd = ($file =~ tr
@/@@);
586 $value_pd++ if (substr($value,-1,1) ne "/");
587 $value_pd = -1 if ($value =~ /^\.\*/);
588 if ($value_pd >= $file_pd &&
589 range_is_maintained
($start, $end) &&
590 range_has_maintainer
($start, $end)) {
591 $exact_pattern_match_hash{$file} = 1;
593 if ($pattern_depth == 0 ||
594 (($file_pd - $value_pd) < $pattern_depth)) {
595 $hash{$tvi} = $value_pd;
605 foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) {
606 add_categories
($line);
609 my $start = find_starting_index
($line);
610 my $end = find_ending_index
($line);
611 for ($i = $start; $i < $end; $i++) {
612 my $line = $typevalue[$i];
613 if ($line =~ /^[FX]:/) { ##Restore file patterns
614 $line =~ s/([^\\])\.([^\*])/$1\?$2/g;
615 $line =~ s/([^\\])\.$/$1\?/g; ##Convert . back to ?
616 $line =~ s/\\\./\./g; ##Convert \. to .
617 $line =~ s/\.\*/\*/g; ##Convert .* to *
619 $line =~ s/^([A-Z]):/$1:\t/g;
628 @keyword_tvi = sort_and_uniq
(@keyword_tvi);
629 foreach my $line (@keyword_tvi) {
630 add_categories
($line);
634 foreach my $email (@email_to, @list_to) {
635 $email->[0] = deduplicate_email
($email->[0]);
639 if (! $interactive) {
640 $email_git_fallback = 0 if @email_to > 0 || $email_git || $email_git_blame;
641 if ($email_git_fallback) {
642 print STDERR
"get_maintainer.pl: No maintainers found, printing recent contributors.\n";
643 print STDERR
"get_maintainer.pl: Do not blindly cc: them on patches! Use common sense.\n";
648 foreach my $file (@files) {
649 if ($email_git || ($email_git_fallback &&
650 !$exact_pattern_match_hash{$file})) {
651 vcs_file_signoffs
($file);
653 if ($email_git_blame) {
654 vcs_file_blame
($file);
658 foreach my $email (@file_emails) {
659 my ($name, $address) = parse_email
($email);
661 my $tmp_email = format_email
($name, $address, $email_usename);
662 push_email_address
($tmp_email, '');
663 add_role
($tmp_email, 'in file');
668 if ($email || $email_list) {
670 @to = (@to, @email_to);
673 @to = (@to, @list_to);
678 @to = interactive_get_maintainers
(\
@to);
684 sub file_match_pattern
{
685 my ($file, $pattern) = @_;
686 if (substr($pattern, -1) eq "/") {
687 if ($file =~ m
@^$pattern@) {
691 if ($file =~ m
@^$pattern@) {
692 my $s1 = ($file =~ tr
@/@@);
693 my $s2 = ($pattern =~ tr
@/@@);
704 usage: $P [options] patchfile
705 $P [options] -f file|directory
708 MAINTAINER field selection options:
709 --email => print email address(es) if any
710 --git => include recent git \*-by: signers
711 --git-all-signature-types => include signers regardless of signature type
712 or use only ${signature_pattern} signers (default: $email_git_all_signature_types)
713 --git-fallback => use git when no exact MAINTAINERS pattern (default: $email_git_fallback)
714 --git-min-signatures => number of signatures required (default: $email_git_min_signatures)
715 --git-max-maintainers => maximum maintainers to add (default: $email_git_max_maintainers)
716 --git-min-percent => minimum percentage of commits required (default: $email_git_min_percent)
717 --git-blame => use git blame to find modified commits for patch or file
718 --git-since => git history to use (default: $email_git_since)
719 --hg-since => hg history to use (default: $email_hg_since)
720 --interactive => display a menu (mostly useful if used with the --git option)
721 --m => include maintainer(s) if any
722 --n => include name 'Full Name <addr\@domain.tld>'
723 --l => include list(s) if any
724 --s => include subscriber only list(s) if any
725 --remove-duplicates => minimize duplicate email names/addresses
726 --roles => show roles (status:subsystem, git-signer, list, etc...)
727 --rolestats => show roles and statistics (commits/total_commits, %)
728 --file-emails => add email addresses found in -f file (default: 0 (off))
729 --scm => print SCM tree(s) if any
730 --status => print status if any
731 --subsystem => print subsystem name if any
732 --web => print website(s) if any
735 --separator [, ] => separator for multiple entries on 1 line
736 using --separator also sets --nomultiline if --separator is not [, ]
737 --multiline => print 1 entry per line
740 --pattern-depth => Number of pattern directory traversals (default: 0 (all))
741 --keywords => scan patch for keywords (default: $keywords)
742 --sections => print all of the subsystem sections with pattern matches
743 --mailmap => use .mailmap file (default: $email_use_mailmap)
744 --version => show version
745 --help => show this help information
748 [--email --nogit --git-fallback --m --n --l --multiline -pattern-depth=0
749 --remove-duplicates --rolestats]
752 Using "-f directory" may give unexpected results:
753 Used with "--git", git signators for _all_ files in and below
754 directory are examined as git recurses directories.
755 Any specified X: (exclude) pattern matches are _not_ ignored.
756 Used with "--nogit", directory is used as a pattern match,
757 no individual file within the directory or subdirectory
759 Used with "--git-blame", does not iterate all files in directory
760 Using "--git-blame" is slow and may add old committers and authors
761 that are no longer active maintainers to the output.
762 Using "--roles" or "--rolestats" with git send-email --cc-cmd or any
763 other automated tools that expect only ["name"] <email address>
764 may not work because of additional output after <email address>.
765 Using "--rolestats" and "--git-blame" shows the #/total=% commits,
766 not the percentage of the entire file authored. # of commits is
767 not a good measure of amount of code authored. 1 major commit may
768 contain a thousand lines, 5 trivial commits may modify a single line.
769 If git is not installed, but mercurial (hg) is installed and an .hg
770 repository exists, the following options apply to mercurial:
772 --git-min-signatures, --git-max-maintainers, --git-min-percent, and
774 Use --hg-since not --git-since to control date selection
775 File ".get_maintainer.conf", if it exists in the QEMU source root
776 directory, can change whatever get_maintainer defaults are desired.
777 Entries in this file can be any command line argument.
778 This file is prepended to any additional command line arguments.
779 Multiple lines and # comments are allowed.
786 if ($lk_path ne "" && substr($lk_path,length($lk_path)-1,1) ne "/") {
789 if ( (-f
"${lk_path}COPYING")
790 && (-f
"${lk_path}MAINTAINERS")
791 && (-f
"${lk_path}Makefile")
792 && (-d
"${lk_path}docs")
793 && (-f
"${lk_path}VERSION")
794 && (-f
"${lk_path}vl.c")) {
801 my ($formatted_email) = @_;
806 if ($formatted_email =~ /^([^<]+)<(.+\@.*)>.*$/) {
809 } elsif ($formatted_email =~ /^\s*<(.+\@\S*)>.*$/) {
811 } elsif ($formatted_email =~ /^(.+\@\S*).*$/) {
815 $name =~ s/^\s+|\s+$//g;
816 $name =~ s/^\"|\"$//g;
817 $address =~ s/^\s+|\s+$//g;
819 if ($name =~ /[^\w \-]/i) { ##has "must quote" chars
820 $name =~ s/(?<!\\)"/\\"/g; ##escape quotes
824 return ($name, $address);
828 my ($name, $address, $usename) = @_;
832 $name =~ s/^\s+|\s+$//g;
833 $name =~ s/^\"|\"$//g;
834 $address =~ s/^\s+|\s+$//g;
836 if ($name =~ /[^\w \-]/i) { ##has "must quote
" chars
837 $name =~ s/(?<!\\)"/\\"/g; ##escape quotes
843 $formatted_email = "$address";
845 $formatted_email = "$name <$address>";
848 $formatted_email = $address;
851 return $formatted_email;
854 sub find_first_section
{
857 while ($index < @typevalue) {
858 my $tv = $typevalue[$index];
859 if (($tv =~ m/^(.):\s*(.*)/)) {
868 sub find_starting_index
{
872 my $tv = $typevalue[$index];
873 if (!($tv =~ m/^(.):\s*(.*)/)) {
882 sub find_ending_index
{
885 while ($index < @typevalue) {
886 my $tv = $typevalue[$index];
887 if (!($tv =~ m/^(.):\s*(.*)/)) {
896 sub get_maintainer_role
{
900 my $start = find_starting_index
($index);
901 my $end = find_ending_index
($index);
903 my $role = "unknown";
904 my $subsystem = $typevalue[$start];
905 if (length($subsystem) > 20) {
906 $subsystem = substr($subsystem, 0, 17);
907 $subsystem =~ s/\s*$//;
908 $subsystem = $subsystem . "...";
911 for ($i = $start + 1; $i < $end; $i++) {
912 my $tv = $typevalue[$i];
913 if ($tv =~ m/^(.):\s*(.*)/) {
923 if ($role eq "supported") {
925 } elsif ($role eq "maintained") {
926 $role = "maintainer";
927 } elsif ($role eq "odd fixes") {
929 } elsif ($role eq "orphan") {
930 $role = "orphan minder";
931 } elsif ($role eq "obsolete") {
932 $role = "obsolete minder";
933 } elsif ($role eq "buried alive in reporters") {
934 $role = "chief penguin";
937 return $role . ":" . $subsystem;
944 my $start = find_starting_index
($index);
945 my $end = find_ending_index
($index);
947 my $subsystem = $typevalue[$start];
948 if (length($subsystem) > 20) {
949 $subsystem = substr($subsystem, 0, 17);
950 $subsystem =~ s/\s*$//;
951 $subsystem = $subsystem . "...";
954 if ($subsystem eq "THE REST") {
965 my $start = find_starting_index
($index);
966 my $end = find_ending_index
($index);
968 push(@subsystem, $typevalue[$start]);
970 for ($i = $start + 1; $i < $end; $i++) {
971 my $tv = $typevalue[$i];
972 if ($tv =~ m/^(.):\s*(.*)/) {
976 my $list_address = $pvalue;
977 my $list_additional = "";
978 my $list_role = get_list_role
($i);
980 if ($list_role ne "") {
981 $list_role = ":" . $list_role;
983 if ($list_address =~ m/([^\s]+)\s+(.*)$/) {
985 $list_additional = $2;
987 if ($list_additional =~ m/subscribers-only/) {
988 if ($email_subscriber_list) {
989 if (!$hash_list_to{lc($list_address)}) {
990 $hash_list_to{lc($list_address)} = 1;
991 push(@list_to, [$list_address,
992 "subscriber list${list_role}"]);
997 if (!$hash_list_to{lc($list_address)}) {
998 $hash_list_to{lc($list_address)} = 1;
999 if ($list_additional =~ m/moderated/) {
1000 push(@list_to, [$list_address,
1001 "moderated list${list_role}"]);
1003 push(@list_to, [$list_address,
1004 "open list${list_role}"]);
1009 } elsif ($ptype eq "M") {
1010 my ($name, $address) = parse_email
($pvalue);
1013 my $tv = $typevalue[$i - 1];
1014 if ($tv =~ m/^(.):\s*(.*)/) {
1017 $pvalue = format_email
($name, $address, $email_usename);
1022 if ($email_maintainer) {
1023 my $role = get_maintainer_role
($i);
1024 push_email_addresses
($pvalue, $role);
1026 } elsif ($ptype eq "T") {
1027 push(@scm, $pvalue);
1028 } elsif ($ptype eq "W") {
1029 push(@web, $pvalue);
1030 } elsif ($ptype eq "S") {
1031 push(@status, $pvalue);
1038 my ($name, $address) = @_;
1040 return 1 if (($name eq "") && ($address eq ""));
1041 return 1 if (($name ne "") && exists($email_hash_name{lc($name)}));
1042 return 1 if (($address ne "") && exists($email_hash_address{lc($address)}));
1047 sub push_email_address
{
1048 my ($line, $role) = @_;
1050 my ($name, $address) = parse_email
($line);
1052 if ($address eq "") {
1056 if (!$email_remove_duplicates) {
1057 push(@email_to, [format_email
($name, $address, $email_usename), $role]);
1058 } elsif (!email_inuse
($name, $address)) {
1059 push(@email_to, [format_email
($name, $address, $email_usename), $role]);
1060 $email_hash_name{lc($name)}++ if ($name ne "");
1061 $email_hash_address{lc($address)}++;
1067 sub push_email_addresses
{
1068 my ($address, $role) = @_;
1070 my @address_list = ();
1072 if (rfc822_valid
($address)) {
1073 push_email_address
($address, $role);
1074 } elsif (@address_list = rfc822_validlist
($address)) {
1075 my $array_count = shift(@address_list);
1076 while (my $entry = shift(@address_list)) {
1077 push_email_address
($entry, $role);
1080 if (!push_email_address
($address, $role)) {
1081 warn("Invalid MAINTAINERS address: '" . $address . "'\n");
1087 my ($line, $role) = @_;
1089 my ($name, $address) = parse_email
($line);
1090 my $email = format_email
($name, $address, $email_usename);
1092 foreach my $entry (@email_to) {
1093 if ($email_remove_duplicates) {
1094 my ($entry_name, $entry_address) = parse_email
($entry->[0]);
1095 if (($name eq $entry_name || $address eq $entry_address)
1096 && ($role eq "" || !($entry->[1] =~ m/$role/))
1098 if ($entry->[1] eq "") {
1099 $entry->[1] = "$role";
1101 $entry->[1] = "$entry->[1],$role";
1105 if ($email eq $entry->[0]
1106 && ($role eq "" || !($entry->[1] =~ m/$role/))
1108 if ($entry->[1] eq "") {
1109 $entry->[1] = "$role";
1111 $entry->[1] = "$entry->[1],$role";
1121 foreach my $path (split(/:/, $ENV{PATH
})) {
1122 if (-e
"$path/$bin") {
1123 return "$path/$bin";
1133 foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) {
1134 if (-e
"$path/$conf") {
1135 return "$path/$conf";
1145 my ($name, $address) = parse_email
($line);
1146 my $email = format_email
($name, $address, 1);
1147 my $real_name = $name;
1148 my $real_address = $address;
1150 if (exists $mailmap->{names
}->{$email} ||
1151 exists $mailmap->{addresses
}->{$email}) {
1152 if (exists $mailmap->{names
}->{$email}) {
1153 $real_name = $mailmap->{names
}->{$email};
1155 if (exists $mailmap->{addresses
}->{$email}) {
1156 $real_address = $mailmap->{addresses
}->{$email};
1159 if (exists $mailmap->{names
}->{$address}) {
1160 $real_name = $mailmap->{names
}->{$address};
1162 if (exists $mailmap->{addresses
}->{$address}) {
1163 $real_address = $mailmap->{addresses
}->{$address};
1166 return format_email
($real_name, $real_address, 1);
1170 my (@addresses) = @_;
1172 my @mapped_emails = ();
1173 foreach my $line (@addresses) {
1174 push(@mapped_emails, mailmap_email
($line));
1176 merge_by_realname
(@mapped_emails) if ($email_use_mailmap);
1177 return @mapped_emails;
1180 sub merge_by_realname
{
1184 foreach my $email (@emails) {
1185 my ($name, $address) = parse_email
($email);
1186 if (exists $address_map{$name}) {
1187 $address = $address_map{$name};
1188 $email = format_email
($name, $address, 1);
1190 $address_map{$name} = $address;
1195 sub git_execute_cmd
{
1199 my $output = `$cmd`;
1200 $output =~ s/^\s*//gm;
1201 @lines = split("\n", $output);
1206 sub hg_execute_cmd {
1210 my $output = `$cmd`;
1211 @lines = split("\n", $output);
1216 sub extract_formatted_signatures
{
1217 my (@signature_lines) = @_;
1219 my @type = @signature_lines;
1221 s/\s*(.*):.*/$1/ for (@type);
1224 s/\s*.*:\s*(.+)\s*/$1/ for (@signature_lines);
1226 ## Reformat email addresses (with names) to avoid badly written signatures
1228 foreach my $signer (@signature_lines) {
1229 $signer = deduplicate_email
($signer);
1232 return (\
@type, \
@signature_lines);
1235 sub vcs_find_signers
{
1239 my @signatures = ();
1241 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1243 my $pattern = $VCS_cmds{"commit_pattern"};
1245 $commits = grep(/$pattern/, @lines); # of commits
1247 @signatures = grep(/^[ \t]*${signature_pattern}.*\@.*$/, @lines);
1249 return (0, @signatures) if !@signatures;
1251 save_commits_by_author
(@lines) if ($interactive);
1252 save_commits_by_signer
(@lines) if ($interactive);
1254 my ($types_ref, $signers_ref) = extract_formatted_signatures
(@signatures);
1256 return ($commits, @$signers_ref);
1259 sub vcs_find_author
{
1263 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1265 return @lines if !@lines;
1268 foreach my $line (@lines) {
1269 if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1271 my ($name, $address) = parse_email
($author);
1272 $author = format_email
($name, $address, 1);
1273 push(@authors, $author);
1277 save_commits_by_author
(@lines) if ($interactive);
1278 save_commits_by_signer
(@lines) if ($interactive);
1283 sub vcs_save_commits
{
1288 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1290 foreach my $line (@lines) {
1291 if ($line =~ m/$VCS_cmds{"blame_commit_pattern"}/) {
1304 return @commits if (!(-f
$file));
1306 if (@range && $VCS_cmds{"blame_range_cmd"} eq "") {
1307 my @all_commits = ();
1309 $cmd = $VCS_cmds{"blame_file_cmd"};
1310 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd
1311 @all_commits = vcs_save_commits
($cmd);
1313 foreach my $file_range_diff (@range) {
1314 next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1316 my $diff_start = $2;
1317 my $diff_length = $3;
1318 next if ("$file" ne "$diff_file");
1319 for (my $i = $diff_start; $i < $diff_start + $diff_length; $i++) {
1320 push(@commits, $all_commits[$i]);
1324 foreach my $file_range_diff (@range) {
1325 next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1327 my $diff_start = $2;
1328 my $diff_length = $3;
1329 next if ("$file" ne "$diff_file");
1330 $cmd = $VCS_cmds{"blame_range_cmd"};
1331 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd
1332 push(@commits, vcs_save_commits
($cmd));
1335 $cmd = $VCS_cmds{"blame_file_cmd"};
1336 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd
1337 @commits = vcs_save_commits
($cmd);
1340 foreach my $commit (@commits) {
1341 $commit =~ s/^\^//g;
1347 my $printed_novcs = 0;
1349 %VCS_cmds = %VCS_cmds_git;
1350 return 1 if eval $VCS_cmds{"available"};
1351 %VCS_cmds = %VCS_cmds_hg;
1352 return 2 if eval $VCS_cmds{"available"};
1354 if (!$printed_novcs) {
1355 warn("$P: No supported VCS found. Add --nogit to options?\n");
1356 warn("Using a git repository produces better results.\n");
1357 warn("Try latest git repository using:\n");
1358 warn("git clone git://git.qemu-project.org/qemu.git\n");
1366 return $vcs_used == 1;
1370 return $vcs_used == 2;
1373 sub interactive_get_maintainers
{
1374 my ($list_ref) = @_;
1375 my @list = @$list_ref;
1384 foreach my $entry (@list) {
1385 $maintained = 1 if ($entry->[1] =~ /^(maintainer|supporter)/i);
1386 $selected{$count} = 1;
1387 $authored{$count} = 0;
1388 $signed{$count} = 0;
1394 my $print_options = 0;
1399 printf STDERR
"\n%1s %2s %-65s",
1400 "*", "#", "email/list and role:stats";
1402 ($email_git_fallback && !$maintained) ||
1404 print STDERR
"auth sign";
1407 foreach my $entry (@list) {
1408 my $email = $entry->[0];
1409 my $role = $entry->[1];
1411 $sel = "*" if ($selected{$count});
1412 my $commit_author = $commit_author_hash{$email};
1413 my $commit_signer = $commit_signer_hash{$email};
1416 $authored++ for (@{$commit_author});
1417 $signed++ for (@{$commit_signer});
1418 printf STDERR
"%1s %2d %-65s", $sel, $count + 1, $email;
1419 printf STDERR
"%4d %4d", $authored, $signed
1420 if ($authored > 0 || $signed > 0);
1421 printf STDERR
"\n %s\n", $role;
1422 if ($authored{$count}) {
1423 my $commit_author = $commit_author_hash{$email};
1424 foreach my $ref (@{$commit_author}) {
1425 print STDERR
" Author: @{$ref}[1]\n";
1428 if ($signed{$count}) {
1429 my $commit_signer = $commit_signer_hash{$email};
1430 foreach my $ref (@{$commit_signer}) {
1431 print STDERR
" @{$ref}[2]: @{$ref}[1]\n";
1438 my $date_ref = \
$email_git_since;
1439 $date_ref = \
$email_hg_since if (vcs_is_hg
());
1440 if ($print_options) {
1445 Version Control options:
1446 g use git history [$email_git]
1447 gf use git-fallback [$email_git_fallback]
1448 b use git blame [$email_git_blame]
1449 bs use blame signatures [$email_git_blame_signatures]
1450 c# minimum commits [$email_git_min_signatures]
1451 %# min percent [$email_git_min_percent]
1452 d# history to use [$$date_ref]
1453 x# max maintainers [$email_git_max_maintainers]
1454 t all signature types [$email_git_all_signature_types]
1455 m use .mailmap [$email_use_mailmap]
1462 tm toggle maintainers
1463 tg toggle git entries
1464 tl toggle open list entries
1465 ts toggle subscriber list entries
1466 f emails in file [$file_emails]
1467 k keywords in file [$keywords]
1468 r remove duplicates [$email_remove_duplicates]
1469 p# pattern match depth [$pattern_depth]
1473 "\n#(toggle), A#(author), S#(signed) *(all), ^(none), O(options), Y(approve): ";
1475 my $input = <STDIN
>;
1480 my @wish = split(/[, ]+/, $input);
1481 foreach my $nr (@wish) {
1483 my $sel = substr($nr, 0, 1);
1484 my $str = substr($nr, 1);
1486 $val = $1 if $str =~ /^(\d+)$/;
1491 $output_rolestats = 0;
1494 } elsif ($nr =~ /^\d+$/ && $nr > 0 && $nr <= $count) {
1495 $selected{$nr - 1} = !$selected{$nr - 1};
1496 } elsif ($sel eq "*" || $sel eq '^') {
1498 $toggle = 1 if ($sel eq '*');
1499 for (my $i = 0; $i < $count; $i++) {
1500 $selected{$i} = $toggle;
1502 } elsif ($sel eq "0") {
1503 for (my $i = 0; $i < $count; $i++) {
1504 $selected{$i} = !$selected{$i};
1506 } elsif ($sel eq "t") {
1507 if (lc($str) eq "m") {
1508 for (my $i = 0; $i < $count; $i++) {
1509 $selected{$i} = !$selected{$i}
1510 if ($list[$i]->[1] =~ /^(maintainer|supporter)/i);
1512 } elsif (lc($str) eq "g") {
1513 for (my $i = 0; $i < $count; $i++) {
1514 $selected{$i} = !$selected{$i}
1515 if ($list[$i]->[1] =~ /^(author|commit|signer)/i);
1517 } elsif (lc($str) eq "l") {
1518 for (my $i = 0; $i < $count; $i++) {
1519 $selected{$i} = !$selected{$i}
1520 if ($list[$i]->[1] =~ /^(open list)/i);
1522 } elsif (lc($str) eq "s") {
1523 for (my $i = 0; $i < $count; $i++) {
1524 $selected{$i} = !$selected{$i}
1525 if ($list[$i]->[1] =~ /^(subscriber list)/i);
1528 } elsif ($sel eq "a") {
1529 if ($val > 0 && $val <= $count) {
1530 $authored{$val - 1} = !$authored{$val - 1};
1531 } elsif ($str eq '*' || $str eq '^') {
1533 $toggle = 1 if ($str eq '*');
1534 for (my $i = 0; $i < $count; $i++) {
1535 $authored{$i} = $toggle;
1538 } elsif ($sel eq "s") {
1539 if ($val > 0 && $val <= $count) {
1540 $signed{$val - 1} = !$signed{$val - 1};
1541 } elsif ($str eq '*' || $str eq '^') {
1543 $toggle = 1 if ($str eq '*');
1544 for (my $i = 0; $i < $count; $i++) {
1545 $signed{$i} = $toggle;
1548 } elsif ($sel eq "o") {
1551 } elsif ($sel eq "g") {
1553 bool_invert
(\
$email_git_fallback);
1555 bool_invert
(\
$email_git);
1558 } elsif ($sel eq "b") {
1560 bool_invert
(\
$email_git_blame_signatures);
1562 bool_invert
(\
$email_git_blame);
1565 } elsif ($sel eq "c") {
1567 $email_git_min_signatures = $val;
1570 } elsif ($sel eq "x") {
1572 $email_git_max_maintainers = $val;
1575 } elsif ($sel eq "%") {
1576 if ($str ne "" && $val >= 0) {
1577 $email_git_min_percent = $val;
1580 } elsif ($sel eq "d") {
1582 $email_git_since = $str;
1583 } elsif (vcs_is_hg
()) {
1584 $email_hg_since = $str;
1587 } elsif ($sel eq "t") {
1588 bool_invert
(\
$email_git_all_signature_types);
1590 } elsif ($sel eq "f") {
1591 bool_invert
(\
$file_emails);
1593 } elsif ($sel eq "r") {
1594 bool_invert
(\
$email_remove_duplicates);
1596 } elsif ($sel eq "m") {
1597 bool_invert
(\
$email_use_mailmap);
1600 } elsif ($sel eq "k") {
1601 bool_invert
(\
$keywords);
1603 } elsif ($sel eq "p") {
1604 if ($str ne "" && $val >= 0) {
1605 $pattern_depth = $val;
1608 } elsif ($sel eq "h" || $sel eq "?") {
1611 Interactive mode allows you to select the various maintainers, submitters,
1612 commit signers and mailing lists that could be CC'd on a patch.
1614 Any *'d entry is selected.
1616 If you have git or hg installed, you can choose to summarize the commit
1617 history of files in the patch. Also, each line of the current file can
1618 be matched to its commit author and that commits signers with blame.
1620 Various knobs exist to control the length of time for active commit
1621 tracking, the maximum number of commit authors and signers to add,
1624 Enter selections at the prompt until you are satisfied that the selected
1625 maintainers are appropriate. You may enter multiple selections separated
1626 by either commas or spaces.
1630 print STDERR
"invalid option: '$nr'\n";
1635 print STDERR
"git-blame can be very slow, please have patience..."
1636 if ($email_git_blame);
1637 goto &get_maintainers
;
1641 #drop not selected entries
1643 my @new_emailto = ();
1644 foreach my $entry (@list) {
1645 if ($selected{$count}) {
1646 push(@new_emailto, $list[$count]);
1650 return @new_emailto;
1654 my ($bool_ref) = @_;
1663 sub deduplicate_email
{
1667 my ($name, $address) = parse_email
($email);
1668 $email = format_email
($name, $address, 1);
1669 $email = mailmap_email
($email);
1671 return $email if (!$email_remove_duplicates);
1673 ($name, $address) = parse_email
($email);
1675 if ($name ne "" && $deduplicate_name_hash{lc($name)}) {
1676 $name = $deduplicate_name_hash{lc($name)}->[0];
1677 $address = $deduplicate_name_hash{lc($name)}->[1];
1679 } elsif ($deduplicate_address_hash{lc($address)}) {
1680 $name = $deduplicate_address_hash{lc($address)}->[0];
1681 $address = $deduplicate_address_hash{lc($address)}->[1];
1685 $deduplicate_name_hash{lc($name)} = [ $name, $address ];
1686 $deduplicate_address_hash{lc($address)} = [ $name, $address ];
1688 $email = format_email
($name, $address, 1);
1689 $email = mailmap_email
($email);
1693 sub save_commits_by_author
{
1700 foreach my $line (@lines) {
1701 if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1703 $author = deduplicate_email
($author);
1704 push(@authors, $author);
1706 push(@commits, $1) if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1707 push(@subjects, $1) if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1710 for (my $i = 0; $i < @authors; $i++) {
1712 foreach my $ref(@{$commit_author_hash{$authors[$i]}}) {
1713 if (@{$ref}[0] eq $commits[$i] &&
1714 @{$ref}[1] eq $subjects[$i]) {
1720 push(@{$commit_author_hash{$authors[$i]}},
1721 [ ($commits[$i], $subjects[$i]) ]);
1726 sub save_commits_by_signer
{
1732 foreach my $line (@lines) {
1733 $commit = $1 if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1734 $subject = $1 if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1735 if ($line =~ /^[ \t]*${signature_pattern}.*\@.*$/) {
1736 my @signatures = ($line);
1737 my ($types_ref, $signers_ref) = extract_formatted_signatures
(@signatures);
1738 my @types = @$types_ref;
1739 my @signers = @$signers_ref;
1741 my $type = $types[0];
1742 my $signer = $signers[0];
1744 $signer = deduplicate_email
($signer);
1747 foreach my $ref(@{$commit_signer_hash{$signer}}) {
1748 if (@{$ref}[0] eq $commit &&
1749 @{$ref}[1] eq $subject &&
1750 @{$ref}[2] eq $type) {
1756 push(@{$commit_signer_hash{$signer}},
1757 [ ($commit, $subject, $type) ]);
1764 my ($role, $divisor, @lines) = @_;
1769 return if (@lines <= 0);
1771 if ($divisor <= 0) {
1772 warn("Bad divisor in " . (caller(0))[3] . ": $divisor\n");
1776 @lines = mailmap
(@lines);
1778 return if (@lines <= 0);
1780 @lines = sort(@lines);
1783 $hash{$_}++ for @lines;
1786 foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) {
1787 my $sign_offs = $hash{$line};
1788 my $percent = $sign_offs * 100 / $divisor;
1790 $percent = 100 if ($percent > 100);
1792 last if ($sign_offs < $email_git_min_signatures ||
1793 $count > $email_git_max_maintainers ||
1794 $percent < $email_git_min_percent);
1795 push_email_address
($line, '');
1796 if ($output_rolestats) {
1797 my $fmt_percent = sprintf("%.0f", $percent);
1798 add_role
($line, "$role:$sign_offs/$divisor=$fmt_percent%");
1800 add_role
($line, $role);
1805 sub vcs_file_signoffs
{
1811 $vcs_used = vcs_exists
();
1812 return if (!$vcs_used);
1814 my $cmd = $VCS_cmds{"find_signers_cmd"};
1815 $cmd =~ s/(\$\w+)/$1/eeg; # interpolate $cmd
1817 ($commits, @signers) = vcs_find_signers
($cmd);
1819 foreach my $signer (@signers) {
1820 $signer = deduplicate_email
($signer);
1823 vcs_assign
("commit_signer", $commits, @signers);
1826 sub vcs_file_blame
{
1830 my @all_commits = ();
1835 $vcs_used = vcs_exists
();
1836 return if (!$vcs_used);
1838 @all_commits = vcs_blame
($file);
1839 @commits = uniq
(@all_commits);
1840 $total_commits = @commits;
1841 $total_lines = @all_commits;
1843 if ($email_git_blame_signatures) {
1846 my @commit_signers = ();
1847 my $commit = join(" -r ", @commits);
1850 $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1851 $cmd =~ s/(\$\w+)/$1/eeg; #substitute variables in $cmd
1853 ($commit_count, @commit_signers) = vcs_find_signers
($cmd);
1855 push(@signers, @commit_signers);
1857 foreach my $commit (@commits) {
1859 my @commit_signers = ();
1862 $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1863 $cmd =~ s/(\$\w+)/$1/eeg; #substitute variables in $cmd
1865 ($commit_count, @commit_signers) = vcs_find_signers
($cmd);
1867 push(@signers, @commit_signers);
1872 if ($from_filename) {
1873 if ($output_rolestats) {
1875 if (vcs_is_hg
()) {{ # Double brace for last exit
1877 my @commit_signers = ();
1878 @commits = uniq
(@commits);
1879 @commits = sort(@commits);
1880 my $commit = join(" -r ", @commits);
1883 $cmd = $VCS_cmds{"find_commit_author_cmd"};
1884 $cmd =~ s/(\$\w+)/$1/eeg; #substitute variables in $cmd
1888 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1893 foreach my $line (@lines) {
1894 if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1896 $author = deduplicate_email
($author);
1897 push(@authors, $author);
1901 save_commits_by_author
(@lines) if ($interactive);
1902 save_commits_by_signer
(@lines) if ($interactive);
1904 push(@signers, @authors);
1907 foreach my $commit (@commits) {
1909 my $cmd = $VCS_cmds{"find_commit_author_cmd"};
1910 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd
1911 my @author = vcs_find_author
($cmd);
1914 my $formatted_author = deduplicate_email
($author[0]);
1916 my $count = grep(/$commit/, @all_commits);
1917 for ($i = 0; $i < $count ; $i++) {
1918 push(@blame_signers, $formatted_author);
1922 if (@blame_signers) {
1923 vcs_assign
("authored lines", $total_lines, @blame_signers);
1926 foreach my $signer (@signers) {
1927 $signer = deduplicate_email
($signer);
1929 vcs_assign
("commits", $total_commits, @signers);
1931 foreach my $signer (@signers) {
1932 $signer = deduplicate_email
($signer);
1934 vcs_assign
("modified commits", $total_commits, @signers);
1942 @parms = grep(!$saw{$_}++, @parms);
1950 @parms = sort @parms;
1951 @parms = grep(!$saw{$_}++, @parms);
1955 sub clean_file_emails
{
1956 my (@file_emails) = @_;
1957 my @fmt_emails = ();
1959 foreach my $email (@file_emails) {
1960 $email =~ s/[\(\<\{]{0,1}([A-Za-z0-9_\.\+-]+\@[A-Za-z0-9\.-]+)[\)\>\}]{0,1}/\<$1\>/g;
1961 my ($name, $address) = parse_email
($email);
1962 if ($name eq '"[,\.]"') {
1966 my @nw = split(/[^A-Za-zÀ-ÿ\'\,\.\+-]/, $name);
1968 my $first = $nw[@nw - 3];
1969 my $middle = $nw[@nw - 2];
1970 my $last = $nw[@nw - 1];
1972 if (((length($first) == 1 && $first =~ m/[A-Za-z]/) ||
1973 (length($first) == 2 && substr($first, -1) eq ".")) ||
1974 (length($middle) == 1 ||
1975 (length($middle) == 2 && substr($middle, -1) eq "."))) {
1976 $name = "$first $middle $last";
1978 $name = "$middle $last";
1982 if (substr($name, -1) =~ /[,\.]/) {
1983 $name = substr($name, 0, length($name) - 1);
1984 } elsif (substr($name, -2) =~ /[,\.]"/) {
1985 $name = substr($name, 0, length($name) - 2) . '"';
1988 if (substr($name, 0, 1) =~ /[,\.]/) {
1989 $name = substr($name, 1, length($name) - 1);
1990 } elsif (substr($name, 0, 2) =~ /"[,\.]/) {
1991 $name = '"' . substr($name, 2, length($name) - 2);
1994 my $fmt_email = format_email
($name, $address, $email_usename);
1995 push(@fmt_emails, $fmt_email);
2005 my ($address, $role) = @$_;
2006 if (!$saw{$address}) {
2007 if ($output_roles) {
2008 push(@lines, "$address ($role)");
2010 push(@lines, $address);
2022 if ($output_multiline) {
2023 foreach my $line (@parms) {
2027 print(join($output_separator, @parms));
2035 # Basic lexical tokens are specials, domain_literal, quoted_string, atom, and
2036 # comment. We must allow for rfc822_lwsp (or comments) after each of these.
2037 # This regexp will only work on addresses which have had comments stripped
2038 # and replaced with rfc822_lwsp.
2040 my $specials = '()<>@,;:\\\\".\\[\\]';
2041 my $controls = '\\000-\\037\\177';
2043 my $dtext = "[^\\[\\]\\r\\\\]";
2044 my $domain_literal = "\\[(?:$dtext|\\\\.)*\\]$rfc822_lwsp*";
2046 my $quoted_string = "\"(?:[^\\\"\\r\\\\]|\\\\.|$rfc822_lwsp)*\"$rfc822_lwsp*";
2048 # Use zero-width assertion to spot the limit of an atom. A simple
2049 # $rfc822_lwsp* causes the regexp engine to hang occasionally.
2050 my $atom = "[^$specials $controls]+(?:$rfc822_lwsp+|\\Z|(?=[\\[\"$specials]))";
2051 my $word = "(?:$atom|$quoted_string)";
2052 my $localpart = "$word(?:\\.$rfc822_lwsp*$word)*";
2054 my $sub_domain = "(?:$atom|$domain_literal)";
2055 my $domain = "$sub_domain(?:\\.$rfc822_lwsp*$sub_domain)*";
2057 my $addr_spec = "$localpart\@$rfc822_lwsp*$domain";
2059 my $phrase = "$word*";
2060 my $route = "(?:\@$domain(?:,\@$rfc822_lwsp*$domain)*:$rfc822_lwsp*)";
2061 my $route_addr = "\\<$rfc822_lwsp*$route?$addr_spec\\>$rfc822_lwsp*";
2062 my $mailbox = "(?:$addr_spec|$phrase$route_addr)";
2064 my $group = "$phrase:$rfc822_lwsp*(?:$mailbox(?:,\\s*$mailbox)*)?;\\s*";
2065 my $address = "(?:$mailbox|$group)";
2067 return "$rfc822_lwsp*$address";
2070 sub rfc822_strip_comments
{
2072 # Recursively remove comments, and replace with a single space. The simpler
2073 # regexps in the Email Addressing FAQ are imperfect - they will miss escaped
2074 # chars in atoms, for example.
2076 while ($s =~ s
/^((?
:[^"\\]|\\.)*
2077 (?:"(?
:[^"\\]|\\.)*"(?
:[^"\\]|\\.)*)*)
2078 \((?:[^()\\]|\\.)*\)/$1 /osx) {}
2082 # valid: returns true if the parameter is an RFC822 valid address
2085 my $s = rfc822_strip_comments(shift);
2088 $rfc822re = make_rfc822re();
2091 return $s =~ m/^$rfc822re$/so && $s =~ m/^$rfc822_char*$/;
2094 # validlist: In scalar context, returns true if the parameter is an RFC822
2095 # valid list of addresses.
2097 # In list context, returns an empty list on failure (an invalid
2098 # address was found); otherwise a list whose first element is the
2099 # number of addresses found and whose remaining elements are the
2100 # addresses. This is needed to disambiguate failure (invalid)
2101 # from success with no addresses found, because an empty string is
2104 sub rfc822_validlist {
2105 my $s = rfc822_strip_comments(shift);
2108 $rfc822re = make_rfc822re();
2110 # * null list items are valid according to the RFC
2111 # * the '1' business is to aid in distinguishing failure from no results
2114 if ($s =~ m/^(?:$rfc822re)?(?:,(?:$rfc822re)?)*$/so &&
2115 $s =~ m/^$rfc822_char*$/) {
2116 while ($s =~ m/(?:^|,$rfc822_lwsp*)($rfc822re)/gos) {
2119 return wantarray ? (scalar(@r), @r) : 1;
2121 return wantarray ? () : 0;