scripts/get_maintainer.pl

   1 #!/usr/bin/env perl
   2 # (c) 2007, Joe Perches <joe@perches.com>
   3 #           created from checkpatch.pl
   4 #
   5 # Print selected MAINTAINERS information for
   6 # the files modified in a patch or for a file
   7 #
   8 # usage: perl scripts/get_maintainer.pl [OPTIONS] <patch>
   9 #        perl scripts/get_maintainer.pl [OPTIONS] -f <file>
  10 #
  11 # Licensed under the terms of the GNU GPL License version 2
  12
  13 use strict;
  14 use warnings;
  15
  16 my $P = $0;
  17 my $V = '0.26';
  18
  19 use Getopt::Long qw(:config no_auto_abbrev);
  20
  21 my $lk_path = "./";
  22 my $email = 1;
  23 my $email_usename = 1;
  24 my $email_maintainer = 1;
  25 my $email_reviewer = 1;
  26 my $email_list = 1;
  27 my $email_subscriber_list = 0;
  28 my $email_git = 0;
  29 my $email_git_all_signature_types = 0;
  30 my $email_git_blame = 0;
  31 my $email_git_blame_signatures = 1;
  32 my $email_git_fallback = 1;
  33 my $email_git_min_signatures = 1;
  34 my $email_git_max_maintainers = 5;
  35 my $email_git_min_percent = 5;
  36 my $email_git_since = "1-year-ago";
  37 my $email_hg_since = "-365";
  38 my $interactive = 0;
  39 my $email_remove_duplicates = 1;
  40 my $email_use_mailmap = 1;
  41 my $output_multiline = 1;
  42 my $output_separator = ", ";
  43 my $output_roles = 0;
  44 my $output_rolestats = 1;
  45 my $scm = 0;
  46 my $web = 0;
  47 my $subsystem = 0;
  48 my $status = 0;
  49 my $keywords = 1;
  50 my $sections = 0;
  51 my $file_emails = 0;
  52 my $from_filename = 0;
  53 my $pattern_depth = 0;
  54 my $version = 0;
  55 my $help = 0;
  56
  57 my $vcs_used = 0;
  58
  59 my $exit = 0;
  60
  61 my %commit_author_hash;
  62 my %commit_signer_hash;
  63
  64 # Signature types of people who are either
  65 #       a) responsible for the code in question, or
  66 #       b) familiar enough with it to give relevant feedback
  67 my @signature_tags = ();
  68 push(@signature_tags, "Signed-off-by:");
  69 push(@signature_tags, "Reviewed-by:");
  70 push(@signature_tags, "Acked-by:");
  71
  72 my $signature_pattern = "\(" . join("|", @signature_tags) . "\)";
  73
  74 # rfc822 email address - preloaded methods go here.
  75 my $rfc822_lwsp = "(?:(?:\\r\\n)?[ \\t])";
  76 my $rfc822_char = '[\\000-\\377]';
  77
  78 # VCS command support: class-like functions and strings
  79
  80 my %VCS_cmds;
  81
  82 my %VCS_cmds_git = (
  83     "execute_cmd" => \&git_execute_cmd,
  84     "available" => '(which("git") ne "") && (-e ".git")',
  85     "find_signers_cmd" =>
  86         "git log --no-color --follow --since=\$email_git_since " .
  87             '--format="GitCommit: %H%n' .
  88                       'GitAuthor: %an <%ae>%n' .
  89                       'GitDate: %aD%n' .
  90                       'GitSubject: %s%n' .
  91                       '%b%n"' .
  92             " -- \$file",
  93     "find_commit_signers_cmd" =>
  94         "git log --no-color " .
  95             '--format="GitCommit: %H%n' .
  96                       'GitAuthor: %an <%ae>%n' .
  97                       'GitDate: %aD%n' .
  98                       'GitSubject: %s%n' .
  99                       '%b%n"' .
 100             " -1 \$commit",
 101     "find_commit_author_cmd" =>
 102         "git log --no-color " .
 103             '--format="GitCommit: %H%n' .
 104                       'GitAuthor: %an <%ae>%n' .
 105                       'GitDate: %aD%n' .
 106                       'GitSubject: %s%n"' .
 107             " -1 \$commit",
 108     "blame_range_cmd" => "git blame -l -L \$diff_start,+\$diff_length \$file",
 109     "blame_file_cmd" => "git blame -l \$file",
 110     "commit_pattern" => "^GitCommit: ([0-9a-f]{40,40})",
 111     "blame_commit_pattern" => "^([0-9a-f]+) ",
 112     "author_pattern" => "^GitAuthor: (.*)",
 113     "subject_pattern" => "^GitSubject: (.*)",
 114 );
 115
 116 my %VCS_cmds_hg = (
 117     "execute_cmd" => \&hg_execute_cmd,
 118     "available" => '(which("hg") ne "") && (-d ".hg")',
 119     "find_signers_cmd" =>
 120         "hg log --date=\$email_hg_since " .
 121             "--template='HgCommit: {node}\\n" .
 122                         "HgAuthor: {author}\\n" .
 123                         "HgSubject: {desc}\\n'" .
 124             " -- \$file",
 125     "find_commit_signers_cmd" =>
 126         "hg log " .
 127             "--template='HgSubject: {desc}\\n'" .
 128             " -r \$commit",
 129     "find_commit_author_cmd" =>
 130         "hg log " .
 131             "--template='HgCommit: {node}\\n" .
 132                         "HgAuthor: {author}\\n" .
 133                         "HgSubject: {desc|firstline}\\n'" .
 134             " -r \$commit",
 135     "blame_range_cmd" => "",            # not supported
 136     "blame_file_cmd" => "hg blame -n \$file",
 137     "commit_pattern" => "^HgCommit: ([0-9a-f]{40,40})",
 138     "blame_commit_pattern" => "^([ 0-9a-f]+):",
 139     "author_pattern" => "^HgAuthor: (.*)",
 140     "subject_pattern" => "^HgSubject: (.*)",
 141 );
 142
 143 my $conf = which_conf(".get_maintainer.conf");
 144 if (-f $conf) {
 145     my @conf_args;
 146     open(my $conffile, '<', "$conf")
 147         or warn "$P: Can't find a readable .get_maintainer.conf file $!\n";
 148
 149     while (<$conffile>) {
 150         my $line = $_;
 151
 152         $line =~ s/\s*\n?$//g;
 153         $line =~ s/^\s*//g;
 154         $line =~ s/\s+/ /g;
 155
 156         next if ($line =~ m/^\s*#/);
 157         next if ($line =~ m/^\s*$/);
 158
 159         my @words = split(" ", $line);
 160         foreach my $word (@words) {
 161             last if ($word =~ m/^#/);
 162             push (@conf_args, $word);
 163         }
 164     }
 165     close($conffile);
 166     unshift(@ARGV, @conf_args) if @conf_args;
 167 }
 168
 169 if (!GetOptions(
 170                 'email!' => \$email,
 171                 'git!' => \$email_git,
 172                 'git-all-signature-types!' => \$email_git_all_signature_types,
 173                 'git-blame!' => \$email_git_blame,
 174                 'git-blame-signatures!' => \$email_git_blame_signatures,
 175                 'git-fallback!' => \$email_git_fallback,
 176                 'git-min-signatures=i' => \$email_git_min_signatures,
 177                 'git-max-maintainers=i' => \$email_git_max_maintainers,
 178                 'git-min-percent=i' => \$email_git_min_percent,
 179                 'git-since=s' => \$email_git_since,
 180                 'hg-since=s' => \$email_hg_since,
 181                 'i|interactive!' => \$interactive,
 182                 'remove-duplicates!' => \$email_remove_duplicates,
 183                 'mailmap!' => \$email_use_mailmap,
 184                 'm!' => \$email_maintainer,
 185                 'r!' => \$email_reviewer,
 186                 'n!' => \$email_usename,
 187                 'l!' => \$email_list,
 188                 's!' => \$email_subscriber_list,
 189                 'multiline!' => \$output_multiline,
 190                 'roles!' => \$output_roles,
 191                 'rolestats!' => \$output_rolestats,
 192                 'separator=s' => \$output_separator,
 193                 'subsystem!' => \$subsystem,
 194                 'status!' => \$status,
 195                 'scm!' => \$scm,
 196                 'web!' => \$web,
 197                 'pattern-depth=i' => \$pattern_depth,
 198                 'k|keywords!' => \$keywords,
 199                 'sections!' => \$sections,
 200                 'fe|file-emails!' => \$file_emails,
 201                 'f|file' => \$from_filename,
 202                 'v|version' => \$version,
 203                 'h|help|usage' => \$help,
 204                 )) {
 205     die "$P: invalid argument - use --help if necessary\n";
 206 }
 207
 208 if ($help != 0) {
 209     usage();
 210     exit 0;
 211 }
 212
 213 if ($version != 0) {
 214     print("${P} ${V}\n");
 215     exit 0;
 216 }
 217
 218 if (-t STDIN && !@ARGV) {
 219     # We're talking to a terminal, but have no command line arguments.
 220     die "$P: missing patchfile or -f file - use --help if necessary\n";
 221 }
 222
 223 $output_multiline = 0 if ($output_separator ne ", ");
 224 $output_rolestats = 1 if ($interactive);
 225 $output_roles = 1 if ($output_rolestats);
 226
 227 if ($sections) {
 228     $email = 0;
 229     $email_list = 0;
 230     $scm = 0;
 231     $status = 0;
 232     $subsystem = 0;
 233     $web = 0;
 234     $keywords = 0;
 235     $interactive = 0;
 236 } else {
 237     my $selections = $email + $scm + $status + $subsystem + $web;
 238     if ($selections == 0) {
 239         die "$P:  Missing required option: email, scm, status, subsystem or web\n";
 240     }
 241 }
 242
 243 if ($email &&
 244     ($email_maintainer + $email_reviewer +
 245      $email_list + $email_subscriber_list +
 246      $email_git + $email_git_blame) == 0) {
 247     die "$P: Please select at least 1 email option\n";
 248 }
 249
 250 if (!top_of_tree($lk_path)) {
 251     die "$P: The current directory does not appear to be "
 252         . "a QEMU source tree.\n";
 253 }
 254
 255 ## Read MAINTAINERS for type/value pairs
 256
 257 my @typevalue = ();
 258 my %keyword_hash;
 259
 260 open (my $maint, '<', "${lk_path}MAINTAINERS")
 261     or die "$P: Can't open MAINTAINERS: $!\n";
 262 while (<$maint>) {
 263     my $line = $_;
 264
 265     if ($line =~ m/^(.):\s*(.*)/) {
 266         my $type = $1;
 267         my $value = $2;
 268
 269         ##Filename pattern matching
 270         if ($type eq "F" || $type eq "X") {
 271             $value =~ s@\.@\\\.@g;       ##Convert . to \.
 272             $value =~ s/\*/\.\*/g;       ##Convert * to .*
 273             $value =~ s/\?/\./g;         ##Convert ? to .
 274             ##if pattern is a directory and it lacks a trailing slash, add one
 275             if ((-d $value)) {
 276                 $value =~ s@([^/])$@$1/@;
 277             }
 278         } elsif ($type eq "K") {
 279             $keyword_hash{@typevalue} = $value;
 280         }
 281         push(@typevalue, "$type:$value");
 282     } elsif (!/^(\s)*$/) {
 283         $line =~ s/\n$//g;
 284         push(@typevalue, $line);
 285     }
 286 }
 287 close($maint);
 288
 289
 290 #
 291 # Read mail address map
 292 #
 293
 294 my $mailmap;
 295
 296 read_mailmap();
 297
 298 sub read_mailmap {
 299     $mailmap = {
 300         names => {},
 301         addresses => {}
 302     };
 303
 304     return if (!$email_use_mailmap || !(-f "${lk_path}.mailmap"));
 305
 306     open(my $mailmap_file, '<', "${lk_path}.mailmap")
 307         or warn "$P: Can't open .mailmap: $!\n";
 308
 309     while (<$mailmap_file>) {
 310         s/#.*$//; #strip comments
 311         s/^\s+|\s+$//g; #trim
 312
 313         next if (/^\s*$/); #skip empty lines
 314         #entries have one of the following formats:
 315         # name1 <mail1>
 316         # <mail1> <mail2>
 317         # name1 <mail1> <mail2>
 318         # name1 <mail1> name2 <mail2>
 319         # (see man git-shortlog)
 320
 321         if (/^([^<]+)<([^>]+)>$/) {
 322             my $real_name = $1;
 323             my $address = $2;
 324
 325             $real_name =~ s/\s+$//;
 326             ($real_name, $address) = parse_email("$real_name <$address>");
 327             $mailmap->{names}->{$address} = $real_name;
 328
 329         } elsif (/^<([^>]+)>\s*<([^>]+)>$/) {
 330             my $real_address = $1;
 331             my $wrong_address = $2;
 332
 333             $mailmap->{addresses}->{$wrong_address} = $real_address;
 334
 335         } elsif (/^(.+)<([^>]+)>\s*<([^>]+)>$/) {
 336             my $real_name = $1;
 337             my $real_address = $2;
 338             my $wrong_address = $3;
 339
 340             $real_name =~ s/\s+$//;
 341             ($real_name, $real_address) =
 342                 parse_email("$real_name <$real_address>");
 343             $mailmap->{names}->{$wrong_address} = $real_name;
 344             $mailmap->{addresses}->{$wrong_address} = $real_address;
 345
 346         } elsif (/^(.+)<([^>]+)>\s*(.+)\s*<([^>]+)>$/) {
 347             my $real_name = $1;
 348             my $real_address = $2;
 349             my $wrong_name = $3;
 350             my $wrong_address = $4;
 351
 352             $real_name =~ s/\s+$//;
 353             ($real_name, $real_address) =
 354                 parse_email("$real_name <$real_address>");
 355
 356             $wrong_name =~ s/\s+$//;
 357             ($wrong_name, $wrong_address) =
 358                 parse_email("$wrong_name <$wrong_address>");
 359
 360             my $wrong_email = format_email($wrong_name, $wrong_address, 1);
 361             $mailmap->{names}->{$wrong_email} = $real_name;
 362             $mailmap->{addresses}->{$wrong_email} = $real_address;
 363         }
 364     }
 365     close($mailmap_file);
 366 }
 367
 368 ## use the filenames on the command line or find the filenames in the patchfiles
 369
 370 my @files = ();
 371 my @range = ();
 372 my @keyword_tvi = ();
 373 my @file_emails = ();
 374
 375 if (!@ARGV) {
 376     push(@ARGV, "&STDIN");
 377 }
 378
 379 foreach my $file (@ARGV) {
 380     if ($file ne "&STDIN") {
 381         ##if $file is a directory and it lacks a trailing slash, add one
 382         if ((-d $file)) {
 383             $file =~ s@([^/])$@$1/@;
 384         } elsif (!(stat $file)) {
 385             die "$P: file '${file}' not found: $!\n";
 386         }
 387     }
 388     if ($from_filename) {
 389         push(@files, $file);
 390         if ($file ne "MAINTAINERS" && -f $file && ($keywords || $file_emails)) {
 391             open(my $f, '<', $file)
 392                 or die "$P: Can't open $file: $!\n";
 393             my $text = do { local($/) ; <$f> };
 394             close($f);
 395             if ($keywords) {
 396                 foreach my $line (keys %keyword_hash) {
 397                     if ($text =~ m/$keyword_hash{$line}/x) {
 398                         push(@keyword_tvi, $line);
 399                     }
 400                 }
 401             }
 402             if ($file_emails) {
 403                 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;
 404                 push(@file_emails, clean_file_emails(@poss_addr));
 405             }
 406         }
 407     } else {
 408         my $file_cnt = @files;
 409         my $lastfile;
 410
 411         open(my $patch, "< $file")
 412             or die "$P: Can't open $file: $!\n";
 413
 414         # We can check arbitrary information before the patch
 415         # like the commit message, mail headers, etc...
 416         # This allows us to match arbitrary keywords against any part
 417         # of a git format-patch generated file (subject tags, etc...)
 418
 419         my $patch_prefix = "";                  #Parsing the intro
 420
 421         while (<$patch>) {
 422             my $patch_line = $_;
 423             if (m/^\+\+\+\s+(\S+)/) {
 424                 my $filename = $1;
 425                 $filename =~ s@^[^/]*/@@;
 426                 $filename =~ s@\n@@;
 427                 $lastfile = $filename;
 428                 push(@files, $filename);
 429                 $patch_prefix = "^[+-].*";      #Now parsing the actual patch
 430             } elsif (m/^\@\@ -(\d+),(\d+)/) {
 431                 if ($email_git_blame) {
 432                     push(@range, "$lastfile:$1:$2");
 433                 }
 434             } elsif ($keywords) {
 435                 foreach my $line (keys %keyword_hash) {
 436                     if ($patch_line =~ m/${patch_prefix}$keyword_hash{$line}/x) {
 437                         push(@keyword_tvi, $line);
 438                     }
 439                 }
 440             }
 441         }
 442         close($patch);
 443
 444         if ($file_cnt == @files) {
 445             warn "$P: file '${file}' doesn't appear to be a patch.  "
 446                 . "Add -f to options?\n";
 447         }
 448         @files = sort_and_uniq(@files);
 449     }
 450 }
 451
 452 @file_emails = uniq(@file_emails);
 453
 454 my %email_hash_name;
 455 my %email_hash_address;
 456 my @email_to = ();
 457 my %hash_list_to;
 458 my @list_to = ();
 459 my @scm = ();
 460 my @web = ();
 461 my @subsystem = ();
 462 my @status = ();
 463 my %deduplicate_name_hash = ();
 464 my %deduplicate_address_hash = ();
 465
 466 my @maintainers = get_maintainers();
 467
 468 if (@maintainers) {
 469     @maintainers = merge_email(@maintainers);
 470     output(@maintainers);
 471 }
 472
 473 if ($scm) {
 474     @scm = uniq(@scm);
 475     output(@scm);
 476 }
 477
 478 if ($status) {
 479     @status = uniq(@status);
 480     output(@status);
 481 }
 482
 483 if ($subsystem) {
 484     @subsystem = uniq(@subsystem);
 485     output(@subsystem);
 486 }
 487
 488 if ($web) {
 489     @web = uniq(@web);
 490     output(@web);
 491 }
 492
 493 exit($exit);
 494
 495 sub range_is_maintained {
 496     my ($start, $end) = @_;
 497
 498     for (my $i = $start; $i < $end; $i++) {
 499         my $line = $typevalue[$i];
 500         if ($line =~ m/^(.):\s*(.*)/) {
 501             my $type = $1;
 502             my $value = $2;
 503             if ($type eq 'S') {
 504                 if ($value =~ /(maintain|support)/i) {
 505                     return 1;
 506                 }
 507             }
 508         }
 509     }
 510     return 0;
 511 }
 512
 513 sub range_has_maintainer {
 514     my ($start, $end) = @_;
 515
 516     for (my $i = $start; $i < $end; $i++) {
 517         my $line = $typevalue[$i];
 518         if ($line =~ m/^(.):\s*(.*)/) {
 519             my $type = $1;
 520             my $value = $2;
 521             if ($type eq 'M') {
 522                 return 1;
 523             }
 524         }
 525     }
 526     return 0;
 527 }
 528
 529 sub get_maintainers {
 530     %email_hash_name = ();
 531     %email_hash_address = ();
 532     %commit_author_hash = ();
 533     %commit_signer_hash = ();
 534     @email_to = ();
 535     %hash_list_to = ();
 536     @list_to = ();
 537     @scm = ();
 538     @web = ();
 539     @subsystem = ();
 540     @status = ();
 541     %deduplicate_name_hash = ();
 542     %deduplicate_address_hash = ();
 543     if ($email_git_all_signature_types) {
 544         $signature_pattern = "(.+?)[Bb][Yy]:";
 545     } else {
 546         $signature_pattern = "\(" . join("|", @signature_tags) . "\)";
 547     }
 548
 549     # Find responsible parties
 550
 551     my %exact_pattern_match_hash = ();
 552
 553     foreach my $file (@files) {
 554
 555         my %hash;
 556         my $tvi = find_first_section();
 557         while ($tvi < @typevalue) {
 558             my $start = find_starting_index($tvi);
 559             my $end = find_ending_index($tvi);
 560             my $exclude = 0;
 561             my $i;
 562
 563             #Do not match excluded file patterns
 564
 565             for ($i = $start; $i < $end; $i++) {
 566                 my $line = $typevalue[$i];
 567                 if ($line =~ m/^(.):\s*(.*)/) {
 568                     my $type = $1;
 569                     my $value = $2;
 570                     if ($type eq 'X') {
 571                         if (file_match_pattern($file, $value)) {
 572                             $exclude = 1;
 573                             last;
 574                         }
 575                     }
 576                 }
 577             }
 578
 579             if (!$exclude) {
 580                 for ($i = $start; $i < $end; $i++) {
 581                     my $line = $typevalue[$i];
 582                     if ($line =~ m/^(.):\s*(.*)/) {
 583                         my $type = $1;
 584                         my $value = $2;
 585                         if ($type eq 'F') {
 586                             if (file_match_pattern($file, $value)) {
 587                                 my $value_pd = ($value =~ tr@/@@);
 588                                 my $file_pd = ($file  =~ tr@/@@);
 589                                 $value_pd++ if (substr($value,-1,1) ne "/");
 590                                 $value_pd = -1 if ($value =~ /^\.\*/);
 591                                 if ($value_pd >= $file_pd &&
 592                                     range_is_maintained($start, $end) &&
 593                                     range_has_maintainer($start, $end)) {
 594                                     $exact_pattern_match_hash{$file} = 1;
 595                                 }
 596                                 if ($pattern_depth == 0 ||
 597                                     (($file_pd - $value_pd) < $pattern_depth)) {
 598                                     $hash{$tvi} = $value_pd;
 599                                 }
 600                             }
 601                         }
 602                     }
 603                 }
 604             }
 605             $tvi = $end + 1;
 606         }
 607
 608         foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) {
 609             add_categories($line);
 610             if ($sections) {
 611                 my $i;
 612                 my $start = find_starting_index($line);
 613                 my $end = find_ending_index($line);
 614                 for ($i = $start; $i < $end; $i++) {
 615                     my $line = $typevalue[$i];
 616                     if ($line =~ /^[FX]:/) {            ##Restore file patterns
 617                         $line =~ s/([^\\])\.([^\*])/$1\?$2/g;
 618                         $line =~ s/([^\\])\.$/$1\?/g;   ##Convert . back to ?
 619                         $line =~ s/\\\./\./g;           ##Convert \. to .
 620                         $line =~ s/\.\*/\*/g;           ##Convert .* to *
 621                     }
 622                     $line =~ s/^([A-Z]):/$1:\t/g;
 623                     print("$line\n");
 624                 }
 625                 print("\n");
 626             }
 627         }
 628     }
 629
 630     if ($keywords) {
 631         @keyword_tvi = sort_and_uniq(@keyword_tvi);
 632         foreach my $line (@keyword_tvi) {
 633             add_categories($line);
 634         }
 635     }
 636
 637     foreach my $email (@email_to, @list_to) {
 638         $email->[0] = deduplicate_email($email->[0]);
 639     }
 640
 641     if ($email) {
 642         if (! $interactive) {
 643             $email_git_fallback = 0 if @email_to > 0 || $email_git || $email_git_blame;
 644             if ($email_git_fallback) {
 645                 print STDERR "get_maintainer.pl: No maintainers found, printing recent contributors.\n";
 646                 print STDERR "get_maintainer.pl: Do not blindly cc: them on patches!  Use common sense.\n";
 647                 print STDERR "\n";
 648             }
 649         }
 650
 651         foreach my $file (@files) {
 652             if ($email_git || ($email_git_fallback &&
 653                                !$exact_pattern_match_hash{$file})) {
 654                 vcs_file_signoffs($file);
 655             }
 656             if ($email_git_blame) {
 657                 vcs_file_blame($file);
 658             }
 659         }
 660
 661         foreach my $email (@file_emails) {
 662             my ($name, $address) = parse_email($email);
 663
 664             my $tmp_email = format_email($name, $address, $email_usename);
 665             push_email_address($tmp_email, '');
 666             add_role($tmp_email, 'in file');
 667         }
 668     }
 669
 670     my @to = ();
 671     if ($email || $email_list) {
 672         if ($email) {
 673             @to = (@to, @email_to);
 674         }
 675         if ($email_list) {
 676             @to = (@to, @list_to);
 677         }
 678     }
 679
 680     if ($interactive) {
 681         @to = interactive_get_maintainers(\@to);
 682     }
 683
 684     return @to;
 685 }
 686
 687 sub file_match_pattern {
 688     my ($file, $pattern) = @_;
 689     if (substr($pattern, -1) eq "/") {
 690         if ($file =~ m@^$pattern@) {
 691             return 1;
 692         }
 693     } else {
 694         if ($file =~ m@^$pattern@) {
 695             my $s1 = ($file =~ tr@/@@);
 696             my $s2 = ($pattern =~ tr@/@@);
 697             if ($s1 == $s2) {
 698                 return 1;
 699             }
 700         }
 701     }
 702     return 0;
 703 }
 704
 705 sub usage {
 706     print <<EOT;
 707 usage: $P [options] patchfile
 708        $P [options] -f file|directory
 709 version: $V
 710
 711 MAINTAINER field selection options:
 712   --email => print email address(es) if any
 713     --git => include recent git \*-by: signers
 714     --git-all-signature-types => include signers regardless of signature type
 715         or use only ${signature_pattern} signers (default: $email_git_all_signature_types)
 716     --git-fallback => use git when no exact MAINTAINERS pattern (default: $email_git_fallback)
 717     --git-min-signatures => number of signatures required (default: $email_git_min_signatures)
 718     --git-max-maintainers => maximum maintainers to add (default: $email_git_max_maintainers)
 719     --git-min-percent => minimum percentage of commits required (default: $email_git_min_percent)
 720     --git-blame => use git blame to find modified commits for patch or file
 721     --git-since => git history to use (default: $email_git_since)
 722     --hg-since => hg history to use (default: $email_hg_since)
 723     --interactive => display a menu (mostly useful if used with the --git option)
 724     --m => include maintainer(s) if any
 725     --r => include reviewer(s) if any
 726     --n => include name 'Full Name <addr\@domain.tld>'
 727     --l => include list(s) if any
 728     --s => include subscriber only list(s) if any
 729     --remove-duplicates => minimize duplicate email names/addresses
 730     --roles => show roles (status:subsystem, git-signer, list, etc...)
 731     --rolestats => show roles and statistics (commits/total_commits, %)
 732     --file-emails => add email addresses found in -f file (default: 0 (off))
 733   --scm => print SCM tree(s) if any
 734   --status => print status if any
 735   --subsystem => print subsystem name if any
 736   --web => print website(s) if any
 737
 738 Output type options:
 739   --separator [, ] => separator for multiple entries on 1 line
 740     using --separator also sets --nomultiline if --separator is not [, ]
 741   --multiline => print 1 entry per line
 742
 743 Other options:
 744   --pattern-depth => Number of pattern directory traversals (default: 0 (all))
 745   --keywords => scan patch for keywords (default: $keywords)
 746   --sections => print all of the subsystem sections with pattern matches
 747   --mailmap => use .mailmap file (default: $email_use_mailmap)
 748   --version => show version
 749   --help => show this help information
 750
 751 Default options:
 752   [--email --nogit --git-fallback --m --r --n --l --multiline --pattern-depth=0
 753    --remove-duplicates --rolestats]
 754
 755 Notes:
 756   Using "-f directory" may give unexpected results:
 757       Used with "--git", git signators for _all_ files in and below
 758           directory are examined as git recurses directories.
 759           Any specified X: (exclude) pattern matches are _not_ ignored.
 760       Used with "--nogit", directory is used as a pattern match,
 761           no individual file within the directory or subdirectory
 762           is matched.
 763       Used with "--git-blame", does not iterate all files in directory
 764   Using "--git-blame" is slow and may add old committers and authors
 765       that are no longer active maintainers to the output.
 766   Using "--roles" or "--rolestats" with git send-email --cc-cmd or any
 767       other automated tools that expect only ["name"] <email address>
 768       may not work because of additional output after <email address>.
 769   Using "--rolestats" and "--git-blame" shows the #/total=% commits,
 770       not the percentage of the entire file authored.  # of commits is
 771       not a good measure of amount of code authored.  1 major commit may
 772       contain a thousand lines, 5 trivial commits may modify a single line.
 773   If git is not installed, but mercurial (hg) is installed and an .hg
 774       repository exists, the following options apply to mercurial:
 775           --git,
 776           --git-min-signatures, --git-max-maintainers, --git-min-percent, and
 777           --git-blame
 778       Use --hg-since not --git-since to control date selection
 779   File ".get_maintainer.conf", if it exists in the QEMU source root
 780       directory, can change whatever get_maintainer defaults are desired.
 781       Entries in this file can be any command line argument.
 782       This file is prepended to any additional command line arguments.
 783       Multiple lines and # comments are allowed.
 784 EOT
 785 }
 786
 787 sub top_of_tree {
 788     my ($lk_path) = @_;
 789
 790     if ($lk_path ne "" && substr($lk_path,length($lk_path)-1,1) ne "/") {
 791         $lk_path .= "/";
 792     }
 793     if (    (-f "${lk_path}COPYING")
 794         && (-f "${lk_path}MAINTAINERS")
 795         && (-f "${lk_path}Makefile")
 796         && (-d "${lk_path}docs")
 797         && (-f "${lk_path}VERSION")
 798         && (-d "${lk_path}linux-user/")
 799         && (-d "${lk_path}system/")) {
 800         return 1;
 801     }
 802     return 0;
 803 }
 804
 805 sub parse_email {
 806     my ($formatted_email) = @_;
 807
 808     my $name = "";
 809     my $address = "";
 810
 811     if ($formatted_email =~ /^([^<]+)<(.+\@.*)>.*$/) {
 812         $name = $1;
 813         $address = $2;
 814     } elsif ($formatted_email =~ /^\s*<(.+\@\S*)>.*$/) {
 815         $address = $1;
 816     } elsif ($formatted_email =~ /^(.+\@\S*).*$/) {
 817         $address = $1;
 818     }
 819
 820     $name =~ s/^\s+|\s+$//g;
 821     $name =~ s/^\"|\"$//g;
 822     $address =~ s/^\s+|\s+$//g;
 823
 824     if ($name =~ /[^\w \-]/i) {          ##has "must quote" chars
 825         $name =~ s/(?<!\\)"/\\"/g;       ##escape quotes
 826         $name = "\"$name\"";
 827     }
 828
 829     return ($name, $address);
 830 }
 831
 832 sub format_email {
 833     my ($name, $address, $usename) = @_;
 834
 835     my $formatted_email;
 836
 837     $name =~ s/^\s+|\s+$//g;
 838     $name =~ s/^\"|\"$//g;
 839     $address =~ s/^\s+|\s+$//g;
 840
 841     if ($name =~ /[^\w \-]/i) {          ##has "must quote" chars
 842         $name =~ s/(?<!\\)"/\\"/g;       ##escape quotes
 843         $name = "\"$name\"";
 844     }
 845
 846     if ($usename) {
 847         if ("$name" eq "") {
 848             $formatted_email = "$address";
 849         } else {
 850             $formatted_email = "$name <$address>";
 851         }
 852     } else {
 853         $formatted_email = $address;
 854     }
 855
 856     return $formatted_email;
 857 }
 858
 859 sub find_first_section {
 860     my $index = 0;
 861
 862     while ($index < @typevalue) {
 863         my $tv = $typevalue[$index];
 864         if (($tv =~ m/^(.):\s*(.*)/)) {
 865             last;
 866         }
 867         $index++;
 868     }
 869
 870     return $index;
 871 }
 872
 873 sub find_starting_index {
 874     my ($index) = @_;
 875
 876     while ($index > 0) {
 877         my $tv = $typevalue[$index];
 878         if (!($tv =~ m/^(.):\s*(.*)/)) {
 879             last;
 880         }
 881         $index--;
 882     }
 883
 884     return $index;
 885 }
 886
 887 sub find_ending_index {
 888     my ($index) = @_;
 889
 890     while ($index < @typevalue) {
 891         my $tv = $typevalue[$index];
 892         if (!($tv =~ m/^(.):\s*(.*)/)) {
 893             last;
 894         }
 895         $index++;
 896     }
 897
 898     return $index;
 899 }
 900
 901 sub get_subsystem_name {
 902     my ($index) = @_;
 903
 904     my $start = find_starting_index($index);
 905
 906     my $subsystem = $typevalue[$start];
 907     if (length($subsystem) > 20) {
 908         $subsystem = substr($subsystem, 0, 17);
 909         $subsystem =~ s/\s*$//;
 910         $subsystem =~ s/[()]//g;
 911         $subsystem = $subsystem . "...";
 912     }
 913     return $subsystem;
 914 }
 915
 916 sub get_maintainer_role {
 917     my ($index) = @_;
 918
 919     my $i;
 920     my $start = find_starting_index($index);
 921     my $end = find_ending_index($index);
 922
 923     my $role = "unknown";
 924     my $subsystem = get_subsystem_name($index);
 925
 926     for ($i = $start + 1; $i < $end; $i++) {
 927         my $tv = $typevalue[$i];
 928         if ($tv =~ m/^(.):\s*(.*)/) {
 929             my $ptype = $1;
 930             my $pvalue = $2;
 931             if ($ptype eq "S") {
 932                 $role = $pvalue;
 933             }
 934         }
 935     }
 936
 937     $role = lc($role);
 938     if      ($role eq "supported") {
 939         $role = "supporter";
 940     } elsif ($role eq "maintained") {
 941         $role = "maintainer";
 942     } elsif ($role eq "odd fixes") {
 943         $role = "odd fixer";
 944     } elsif ($role eq "orphan") {
 945         $role = "orphan minder";
 946     } elsif ($role eq "obsolete") {
 947         $role = "obsolete minder";
 948     } elsif ($role eq "buried alive in reporters") {
 949         $role = "chief penguin";
 950     }
 951
 952     return $role . ":" . $subsystem;
 953 }
 954
 955 sub get_list_role {
 956     my ($index) = @_;
 957
 958     my $subsystem = get_subsystem_name($index);
 959
 960     if ($subsystem eq "THE REST") {
 961         $subsystem = "";
 962     }
 963
 964     return $subsystem;
 965 }
 966
 967 sub add_categories {
 968     my ($index) = @_;
 969
 970     my $i;
 971     my $start = find_starting_index($index);
 972     my $end = find_ending_index($index);
 973
 974     push(@subsystem, $typevalue[$start]);
 975
 976     for ($i = $start + 1; $i < $end; $i++) {
 977         my $tv = $typevalue[$i];
 978         if ($tv =~ m/^(.):\s*(.*)/) {
 979             my $ptype = $1;
 980             my $pvalue = $2;
 981             if ($ptype eq "L") {
 982                 my $list_address = $pvalue;
 983                 my $list_additional = "";
 984                 my $list_role = get_list_role($i);
 985
 986                 if ($list_role ne "") {
 987                     $list_role = ":" . $list_role;
 988                 }
 989                 if ($list_address =~ m/([^\s]+)\s+(.*)$/) {
 990                     $list_address = $1;
 991                     $list_additional = $2;
 992                 }
 993                 if ($list_additional =~ m/subscribers-only/) {
 994                     if ($email_subscriber_list) {
 995                         if (!$hash_list_to{lc($list_address)}) {
 996                             $hash_list_to{lc($list_address)} = 1;
 997                             push(@list_to, [$list_address,
 998                                             "subscriber list${list_role}"]);
 999                         }
1000                     }
1001                 } else {
1002                     if ($email_list) {
1003                         if (!$hash_list_to{lc($list_address)}) {
1004                             $hash_list_to{lc($list_address)} = 1;
1005                             if ($list_additional =~ m/moderated/) {
1006                                 push(@list_to, [$list_address,
1007                                                 "moderated list${list_role}"]);
1008                             } else {
1009                                 push(@list_to, [$list_address,
1010                                                 "open list${list_role}"]);
1011                             }
1012                         }
1013                     }
1014                 }
1015             } elsif ($ptype eq "M") {
1016                 my ($name, $address) = parse_email($pvalue);
1017                 if ($name eq "") {
1018                     if ($i > 0) {
1019                         my $tv = $typevalue[$i - 1];
1020                         if ($tv =~ m/^(.):\s*(.*)/) {
1021                             if ($1 eq "P") {
1022                                 $name = $2;
1023                                 $pvalue = format_email($name, $address, $email_usename);
1024                             }
1025                         }
1026                     }
1027                 }
1028                 if ($email_maintainer) {
1029                     my $role = get_maintainer_role($i);
1030                     push_email_addresses($pvalue, $role);
1031                 }
1032             } elsif ($ptype eq "R") {
1033                 my ($name, $address) = parse_email($pvalue);
1034                 if ($name eq "") {
1035                     if ($i > 0) {
1036                         my $tv = $typevalue[$i - 1];
1037                         if ($tv =~ m/^(.):\s*(.*)/) {
1038                             if ($1 eq "P") {
1039                                 $name = $2;
1040                                 $pvalue = format_email($name, $address, $email_usename);
1041                             }
1042                         }
1043                     }
1044                 }
1045                 if ($email_reviewer) {
1046                     my $subsystem = get_subsystem_name($i);
1047                     push_email_addresses($pvalue, "reviewer:$subsystem");
1048                 }
1049             } elsif ($ptype eq "T") {
1050                 push(@scm, $pvalue);
1051             } elsif ($ptype eq "W") {
1052                 push(@web, $pvalue);
1053             } elsif ($ptype eq "S") {
1054                 push(@status, $pvalue);
1055             }
1056         }
1057     }
1058 }
1059
1060 sub email_inuse {
1061     my ($name, $address) = @_;
1062
1063     return 1 if (($name eq "") && ($address eq ""));
1064     return 1 if (($name ne "") && exists($email_hash_name{lc($name)}));
1065     return 1 if (($address ne "") && exists($email_hash_address{lc($address)}));
1066
1067     return 0;
1068 }
1069
1070 sub push_email_address {
1071     my ($line, $role) = @_;
1072
1073     my ($name, $address) = parse_email($line);
1074
1075     if ($address eq "") {
1076         return 0;
1077     }
1078
1079     if (!$email_remove_duplicates) {
1080         push(@email_to, [format_email($name, $address, $email_usename), $role]);
1081     } elsif (!email_inuse($name, $address)) {
1082         push(@email_to, [format_email($name, $address, $email_usename), $role]);
1083         $email_hash_name{lc($name)}++ if ($name ne "");
1084         $email_hash_address{lc($address)}++;
1085     }
1086
1087     return 1;
1088 }
1089
1090 sub push_email_addresses {
1091     my ($address, $role) = @_;
1092
1093     my @address_list = ();
1094
1095     if (rfc822_valid($address)) {
1096         push_email_address($address, $role);
1097     } elsif (@address_list = rfc822_validlist($address)) {
1098         my $array_count = shift(@address_list);
1099         while (my $entry = shift(@address_list)) {
1100             push_email_address($entry, $role);
1101         }
1102     } else {
1103         if (!push_email_address($address, $role)) {
1104             warn("Invalid MAINTAINERS address: '" . $address . "'\n");
1105         }
1106     }
1107 }
1108
1109 sub add_role {
1110     my ($line, $role) = @_;
1111
1112     my ($name, $address) = parse_email($line);
1113     my $email = format_email($name, $address, $email_usename);
1114
1115     foreach my $entry (@email_to) {
1116         if ($email_remove_duplicates) {
1117             my ($entry_name, $entry_address) = parse_email($entry->[0]);
1118             if (($name eq $entry_name || $address eq $entry_address)
1119                 && ($role eq "" || !($entry->[1] =~ m/$role/))
1120             ) {
1121                 if ($entry->[1] eq "") {
1122                     $entry->[1] = "$role";
1123                 } else {
1124                     $entry->[1] = "$entry->[1],$role";
1125                 }
1126             }
1127         } else {
1128             if ($email eq $entry->[0]
1129                 && ($role eq "" || !($entry->[1] =~ m/$role/))
1130             ) {
1131                 if ($entry->[1] eq "") {
1132                     $entry->[1] = "$role";
1133                 } else {
1134                     $entry->[1] = "$entry->[1],$role";
1135                 }
1136             }
1137         }
1138     }
1139 }
1140
1141 sub which {
1142     my ($bin) = @_;
1143
1144     foreach my $path (split(/:/, $ENV{PATH})) {
1145         if (-e "$path/$bin") {
1146             return "$path/$bin";
1147         }
1148     }
1149
1150     return "";
1151 }
1152
1153 sub which_conf {
1154     my ($conf) = @_;
1155
1156     foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) {
1157         if (-e "$path/$conf") {
1158             return "$path/$conf";
1159         }
1160     }
1161
1162     return "";
1163 }
1164
1165 sub mailmap_email {
1166     my ($line) = @_;
1167
1168     my ($name, $address) = parse_email($line);
1169     my $email = format_email($name, $address, 1);
1170     my $real_name = $name;
1171     my $real_address = $address;
1172
1173     if (exists $mailmap->{names}->{$email} ||
1174         exists $mailmap->{addresses}->{$email}) {
1175         if (exists $mailmap->{names}->{$email}) {
1176             $real_name = $mailmap->{names}->{$email};
1177         }
1178         if (exists $mailmap->{addresses}->{$email}) {
1179             $real_address = $mailmap->{addresses}->{$email};
1180         }
1181     } else {
1182         if (exists $mailmap->{names}->{$address}) {
1183             $real_name = $mailmap->{names}->{$address};
1184         }
1185         if (exists $mailmap->{addresses}->{$address}) {
1186             $real_address = $mailmap->{addresses}->{$address};
1187         }
1188     }
1189     return format_email($real_name, $real_address, 1);
1190 }
1191
1192 sub mailmap {
1193     my (@addresses) = @_;
1194
1195     my @mapped_emails = ();
1196     foreach my $line (@addresses) {
1197         push(@mapped_emails, mailmap_email($line));
1198     }
1199     merge_by_realname(@mapped_emails) if ($email_use_mailmap);
1200     return @mapped_emails;
1201 }
1202
1203 sub merge_by_realname {
1204     my %address_map;
1205     my (@emails) = @_;
1206
1207     foreach my $email (@emails) {
1208         my ($name, $address) = parse_email($email);
1209         if (exists $address_map{$name}) {
1210             $address = $address_map{$name};
1211             $email = format_email($name, $address, 1);
1212         } else {
1213             $address_map{$name} = $address;
1214         }
1215     }
1216 }
1217
1218 sub git_execute_cmd {
1219     my ($cmd) = @_;
1220     my @lines = ();
1221
1222     my $output = `$cmd`;
1223     $output =~ s/^\s*//gm;
1224     @lines = split("\n", $output);
1225
1226     return @lines;
1227 }
1228
1229 sub hg_execute_cmd {
1230     my ($cmd) = @_;
1231     my @lines = ();
1232
1233     my $output = `$cmd`;
1234     @lines = split("\n", $output);
1235
1236     return @lines;
1237 }
1238
1239 sub extract_formatted_signatures {
1240     my (@signature_lines) = @_;
1241
1242     my @type = @signature_lines;
1243
1244     s/\s*(.*):.*/$1/ for (@type);
1245
1246     # cut -f2- -d":"
1247     s/\s*.*:\s*(.+)\s*/$1/ for (@signature_lines);
1248
1249 ## Reformat email addresses (with names) to avoid badly written signatures
1250
1251     foreach my $signer (@signature_lines) {
1252         $signer = deduplicate_email($signer);
1253     }
1254
1255     return (\@type, \@signature_lines);
1256 }
1257
1258 sub vcs_find_signers {
1259     my ($cmd) = @_;
1260     my $commits;
1261     my @lines = ();
1262     my @signatures = ();
1263
1264     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1265
1266     my $pattern = $VCS_cmds{"commit_pattern"};
1267
1268     $commits = grep(/$pattern/, @lines);        # of commits
1269
1270     @signatures = grep(/^[ \t]*${signature_pattern}.*\@.*$/, @lines);
1271
1272     return (0, @signatures) if !@signatures;
1273
1274     save_commits_by_author(@lines) if ($interactive);
1275     save_commits_by_signer(@lines) if ($interactive);
1276
1277     my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures);
1278
1279     return ($commits, @$signers_ref);
1280 }
1281
1282 sub vcs_find_author {
1283     my ($cmd) = @_;
1284     my @lines = ();
1285
1286     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1287
1288     return @lines if !@lines;
1289
1290     my @authors = ();
1291     foreach my $line (@lines) {
1292         if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1293             my $author = $1;
1294             my ($name, $address) = parse_email($author);
1295             $author = format_email($name, $address, 1);
1296             push(@authors, $author);
1297         }
1298     }
1299
1300     save_commits_by_author(@lines) if ($interactive);
1301     save_commits_by_signer(@lines) if ($interactive);
1302
1303     return @authors;
1304 }
1305
1306 sub vcs_save_commits {
1307     my ($cmd) = @_;
1308     my @lines = ();
1309     my @commits = ();
1310
1311     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1312
1313     foreach my $line (@lines) {
1314         if ($line =~ m/$VCS_cmds{"blame_commit_pattern"}/) {
1315             push(@commits, $1);
1316         }
1317     }
1318
1319     return @commits;
1320 }
1321
1322 sub vcs_blame {
1323     my ($file) = @_;
1324     my $cmd;
1325     my @commits = ();
1326
1327     return @commits if (!(-f $file));
1328
1329     if (@range && $VCS_cmds{"blame_range_cmd"} eq "") {
1330         my @all_commits = ();
1331
1332         $cmd = $VCS_cmds{"blame_file_cmd"};
1333         $cmd =~ s/(\$\w+)/$1/eeg;               #interpolate $cmd
1334         @all_commits = vcs_save_commits($cmd);
1335
1336         foreach my $file_range_diff (@range) {
1337             next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1338             my $diff_file = $1;
1339             my $diff_start = $2;
1340             my $diff_length = $3;
1341             next if ("$file" ne "$diff_file");
1342             for (my $i = $diff_start; $i < $diff_start + $diff_length; $i++) {
1343                 push(@commits, $all_commits[$i]);
1344             }
1345         }
1346     } elsif (@range) {
1347         foreach my $file_range_diff (@range) {
1348             next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1349             my $diff_file = $1;
1350             my $diff_start = $2;
1351             my $diff_length = $3;
1352             next if ("$file" ne "$diff_file");
1353             $cmd = $VCS_cmds{"blame_range_cmd"};
1354             $cmd =~ s/(\$\w+)/$1/eeg;           #interpolate $cmd
1355             push(@commits, vcs_save_commits($cmd));
1356         }
1357     } else {
1358         $cmd = $VCS_cmds{"blame_file_cmd"};
1359         $cmd =~ s/(\$\w+)/$1/eeg;               #interpolate $cmd
1360         @commits = vcs_save_commits($cmd);
1361     }
1362
1363     foreach my $commit (@commits) {
1364         $commit =~ s/^\^//g;
1365     }
1366
1367     return @commits;
1368 }
1369
1370 my $printed_novcs = 0;
1371 sub vcs_exists {
1372     %VCS_cmds = %VCS_cmds_git;
1373     return 1 if eval $VCS_cmds{"available"};
1374     %VCS_cmds = %VCS_cmds_hg;
1375     return 2 if eval $VCS_cmds{"available"};
1376     %VCS_cmds = ();
1377     if (!$printed_novcs) {
1378         warn("$P: No supported VCS found.  Add --nogit to options?\n");
1379         warn("Using a git repository produces better results.\n");
1380         warn("Try latest git repository using:\n");
1381         warn("git clone https://gitlab.com/qemu-project/qemu.git\n");
1382         $printed_novcs = 1;
1383     }
1384     return 0;
1385 }
1386
1387 sub vcs_is_git {
1388     vcs_exists();
1389     return $vcs_used == 1;
1390 }
1391
1392 sub vcs_is_hg {
1393     return $vcs_used == 2;
1394 }
1395
1396 sub interactive_get_maintainers {
1397     my ($list_ref) = @_;
1398     my @list = @$list_ref;
1399
1400     vcs_exists();
1401
1402     my %selected;
1403     my %authored;
1404     my %signed;
1405     my $count = 0;
1406     my $maintained = 0;
1407     foreach my $entry (@list) {
1408         $maintained = 1 if ($entry->[1] =~ /^(maintainer|supporter)/i);
1409         $selected{$count} = 1;
1410         $authored{$count} = 0;
1411         $signed{$count} = 0;
1412         $count++;
1413     }
1414
1415     #menu loop
1416     my $done = 0;
1417     my $print_options = 0;
1418     my $redraw = 1;
1419     while (!$done) {
1420         $count = 0;
1421         if ($redraw) {
1422             printf STDERR "\n%1s %2s %-65s",
1423                           "*", "#", "email/list and role:stats";
1424             if ($email_git ||
1425                 ($email_git_fallback && !$maintained) ||
1426                 $email_git_blame) {
1427                 print STDERR "auth sign";
1428             }
1429             print STDERR "\n";
1430             foreach my $entry (@list) {
1431                 my $email = $entry->[0];
1432                 my $role = $entry->[1];
1433                 my $sel = "";
1434                 $sel = "*" if ($selected{$count});
1435                 my $commit_author = $commit_author_hash{$email};
1436                 my $commit_signer = $commit_signer_hash{$email};
1437                 my $authored = 0;
1438                 my $signed = 0;
1439                 $authored++ for (@{$commit_author});
1440                 $signed++ for (@{$commit_signer});
1441                 printf STDERR "%1s %2d %-65s", $sel, $count + 1, $email;
1442                 printf STDERR "%4d %4d", $authored, $signed
1443                     if ($authored > 0 || $signed > 0);
1444                 printf STDERR "\n     %s\n", $role;
1445                 if ($authored{$count}) {
1446                     my $commit_author = $commit_author_hash{$email};
1447                     foreach my $ref (@{$commit_author}) {
1448                         print STDERR "     Author: @{$ref}[1]\n";
1449                     }
1450                 }
1451                 if ($signed{$count}) {
1452                     my $commit_signer = $commit_signer_hash{$email};
1453                     foreach my $ref (@{$commit_signer}) {
1454                         print STDERR "     @{$ref}[2]: @{$ref}[1]\n";
1455                     }
1456                 }
1457
1458                 $count++;
1459             }
1460         }
1461         my $date_ref = \$email_git_since;
1462         $date_ref = \$email_hg_since if (vcs_is_hg());
1463         if ($print_options) {
1464             $print_options = 0;
1465             if (vcs_exists()) {
1466                 print STDERR <<EOT
1467
1468 Version Control options:
1469 g  use git history      [$email_git]
1470 gf use git-fallback     [$email_git_fallback]
1471 b  use git blame        [$email_git_blame]
1472 bs use blame signatures [$email_git_blame_signatures]
1473 c# minimum commits      [$email_git_min_signatures]
1474 %# min percent          [$email_git_min_percent]
1475 d# history to use       [$$date_ref]
1476 x# max maintainers      [$email_git_max_maintainers]
1477 t  all signature types  [$email_git_all_signature_types]
1478 m  use .mailmap         [$email_use_mailmap]
1479 EOT
1480             }
1481             print STDERR <<EOT
1482
1483 Additional options:
1484 0  toggle all
1485 tm toggle maintainers
1486 tg toggle git entries
1487 tl toggle open list entries
1488 ts toggle subscriber list entries
1489 f  emails in file       [$file_emails]
1490 k  keywords in file     [$keywords]
1491 r  remove duplicates    [$email_remove_duplicates]
1492 p# pattern match depth  [$pattern_depth]
1493 EOT
1494         }
1495         print STDERR
1496 "\n#(toggle), A#(author), S#(signed) *(all), ^(none), O(options), Y(approve): ";
1497
1498         my $input = <STDIN>;
1499         chomp($input);
1500
1501         $redraw = 1;
1502         my $rerun = 0;
1503         my @wish = split(/[, ]+/, $input);
1504         foreach my $nr (@wish) {
1505             $nr = lc($nr);
1506             my $sel = substr($nr, 0, 1);
1507             my $str = substr($nr, 1);
1508             my $val = 0;
1509             $val = $1 if $str =~ /^(\d+)$/;
1510
1511             if ($sel eq "y") {
1512                 $interactive = 0;
1513                 $done = 1;
1514                 $output_rolestats = 0;
1515                 $output_roles = 0;
1516                 last;
1517             } elsif ($nr =~ /^\d+$/ && $nr > 0 && $nr <= $count) {
1518                 $selected{$nr - 1} = !$selected{$nr - 1};
1519             } elsif ($sel eq "*" || $sel eq '^') {
1520                 my $toggle = 0;
1521                 $toggle = 1 if ($sel eq '*');
1522                 for (my $i = 0; $i < $count; $i++) {
1523                     $selected{$i} = $toggle;
1524                 }
1525             } elsif ($sel eq "0") {
1526                 for (my $i = 0; $i < $count; $i++) {
1527                     $selected{$i} = !$selected{$i};
1528                 }
1529             } elsif ($sel eq "t") {
1530                 if (lc($str) eq "m") {
1531                     for (my $i = 0; $i < $count; $i++) {
1532                         $selected{$i} = !$selected{$i}
1533                             if ($list[$i]->[1] =~ /^(maintainer|supporter)/i);
1534                     }
1535                 } elsif (lc($str) eq "g") {
1536                     for (my $i = 0; $i < $count; $i++) {
1537                         $selected{$i} = !$selected{$i}
1538                             if ($list[$i]->[1] =~ /^(author|commit|signer)/i);
1539                     }
1540                 } elsif (lc($str) eq "l") {
1541                     for (my $i = 0; $i < $count; $i++) {
1542                         $selected{$i} = !$selected{$i}
1543                             if ($list[$i]->[1] =~ /^(open list)/i);
1544                     }
1545                 } elsif (lc($str) eq "s") {
1546                     for (my $i = 0; $i < $count; $i++) {
1547                         $selected{$i} = !$selected{$i}
1548                             if ($list[$i]->[1] =~ /^(subscriber list)/i);
1549                     }
1550                 }
1551             } elsif ($sel eq "a") {
1552                 if ($val > 0 && $val <= $count) {
1553                     $authored{$val - 1} = !$authored{$val - 1};
1554                 } elsif ($str eq '*' || $str eq '^') {
1555                     my $toggle = 0;
1556                     $toggle = 1 if ($str eq '*');
1557                     for (my $i = 0; $i < $count; $i++) {
1558                         $authored{$i} = $toggle;
1559                     }
1560                 }
1561             } elsif ($sel eq "s") {
1562                 if ($val > 0 && $val <= $count) {
1563                     $signed{$val - 1} = !$signed{$val - 1};
1564                 } elsif ($str eq '*' || $str eq '^') {
1565                     my $toggle = 0;
1566                     $toggle = 1 if ($str eq '*');
1567                     for (my $i = 0; $i < $count; $i++) {
1568                         $signed{$i} = $toggle;
1569                     }
1570                 }
1571             } elsif ($sel eq "o") {
1572                 $print_options = 1;
1573                 $redraw = 1;
1574             } elsif ($sel eq "g") {
1575                 if ($str eq "f") {
1576                     bool_invert(\$email_git_fallback);
1577                 } else {
1578                     bool_invert(\$email_git);
1579                 }
1580                 $rerun = 1;
1581             } elsif ($sel eq "b") {
1582                 if ($str eq "s") {
1583                     bool_invert(\$email_git_blame_signatures);
1584                 } else {
1585                     bool_invert(\$email_git_blame);
1586                 }
1587                 $rerun = 1;
1588             } elsif ($sel eq "c") {
1589                 if ($val > 0) {
1590                     $email_git_min_signatures = $val;
1591                     $rerun = 1;
1592                 }
1593             } elsif ($sel eq "x") {
1594                 if ($val > 0) {
1595                     $email_git_max_maintainers = $val;
1596                     $rerun = 1;
1597                 }
1598             } elsif ($sel eq "%") {
1599                 if ($str ne "" && $val >= 0) {
1600                     $email_git_min_percent = $val;
1601                     $rerun = 1;
1602                 }
1603             } elsif ($sel eq "d") {
1604                 if (vcs_is_git()) {
1605                     $email_git_since = $str;
1606                 } elsif (vcs_is_hg()) {
1607                     $email_hg_since = $str;
1608                 }
1609                 $rerun = 1;
1610             } elsif ($sel eq "t") {
1611                 bool_invert(\$email_git_all_signature_types);
1612                 $rerun = 1;
1613             } elsif ($sel eq "f") {
1614                 bool_invert(\$file_emails);
1615                 $rerun = 1;
1616             } elsif ($sel eq "r") {
1617                 bool_invert(\$email_remove_duplicates);
1618                 $rerun = 1;
1619             } elsif ($sel eq "m") {
1620                 bool_invert(\$email_use_mailmap);
1621                 read_mailmap();
1622                 $rerun = 1;
1623             } elsif ($sel eq "k") {
1624                 bool_invert(\$keywords);
1625                 $rerun = 1;
1626             } elsif ($sel eq "p") {
1627                 if ($str ne "" && $val >= 0) {
1628                     $pattern_depth = $val;
1629                     $rerun = 1;
1630                 }
1631             } elsif ($sel eq "h" || $sel eq "?") {
1632                 print STDERR <<EOT
1633
1634 Interactive mode allows you to select the various maintainers, submitters,
1635 commit signers and mailing lists that could be CC'd on a patch.
1636
1637 Any *'d entry is selected.
1638
1639 If you have git or hg installed, you can choose to summarize the commit
1640 history of files in the patch.  Also, each line of the current file can
1641 be matched to its commit author and that commits signers with blame.
1642
1643 Various knobs exist to control the length of time for active commit
1644 tracking, the maximum number of commit authors and signers to add,
1645 and such.
1646
1647 Enter selections at the prompt until you are satisfied that the selected
1648 maintainers are appropriate.  You may enter multiple selections separated
1649 by either commas or spaces.
1650
1651 EOT
1652             } else {
1653                 print STDERR "invalid option: '$nr'\n";
1654                 $redraw = 0;
1655             }
1656         }
1657         if ($rerun) {
1658             print STDERR "git-blame can be very slow, please have patience..."
1659                 if ($email_git_blame);
1660             goto &get_maintainers;
1661         }
1662     }
1663
1664     #drop not selected entries
1665     $count = 0;
1666     my @new_emailto = ();
1667     foreach my $entry (@list) {
1668         if ($selected{$count}) {
1669             push(@new_emailto, $list[$count]);
1670         }
1671         $count++;
1672     }
1673     return @new_emailto;
1674 }
1675
1676 sub bool_invert {
1677     my ($bool_ref) = @_;
1678
1679     if ($$bool_ref) {
1680         $$bool_ref = 0;
1681     } else {
1682         $$bool_ref = 1;
1683     }
1684 }
1685
1686 sub deduplicate_email {
1687     my ($email) = @_;
1688
1689     my $matched = 0;
1690     my ($name, $address) = parse_email($email);
1691     $email = format_email($name, $address, 1);
1692     $email = mailmap_email($email);
1693
1694     return $email if (!$email_remove_duplicates);
1695
1696     ($name, $address) = parse_email($email);
1697
1698     if ($name ne "" && $deduplicate_name_hash{lc($name)}) {
1699         $name = $deduplicate_name_hash{lc($name)}->[0];
1700         $address = $deduplicate_name_hash{lc($name)}->[1];
1701         $matched = 1;
1702     } elsif ($deduplicate_address_hash{lc($address)}) {
1703         $name = $deduplicate_address_hash{lc($address)}->[0];
1704         $address = $deduplicate_address_hash{lc($address)}->[1];
1705         $matched = 1;
1706     }
1707     if (!$matched) {
1708         $deduplicate_name_hash{lc($name)} = [ $name, $address ];
1709         $deduplicate_address_hash{lc($address)} = [ $name, $address ];
1710     }
1711     $email = format_email($name, $address, 1);
1712     $email = mailmap_email($email);
1713     return $email;
1714 }
1715
1716 sub save_commits_by_author {
1717     my (@lines) = @_;
1718
1719     my @authors = ();
1720     my @commits = ();
1721     my @subjects = ();
1722
1723     foreach my $line (@lines) {
1724         if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1725             my $author = $1;
1726             $author = deduplicate_email($author);
1727             push(@authors, $author);
1728         }
1729         push(@commits, $1) if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1730         push(@subjects, $1) if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1731     }
1732
1733     for (my $i = 0; $i < @authors; $i++) {
1734         my $exists = 0;
1735         foreach my $ref(@{$commit_author_hash{$authors[$i]}}) {
1736             if (@{$ref}[0] eq $commits[$i] &&
1737                 @{$ref}[1] eq $subjects[$i]) {
1738                 $exists = 1;
1739                 last;
1740             }
1741         }
1742         if (!$exists) {
1743             push(@{$commit_author_hash{$authors[$i]}},
1744                  [ ($commits[$i], $subjects[$i]) ]);
1745         }
1746     }
1747 }
1748
1749 sub save_commits_by_signer {
1750     my (@lines) = @_;
1751
1752     my $commit = "";
1753     my $subject = "";
1754
1755     foreach my $line (@lines) {
1756         $commit = $1 if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1757         $subject = $1 if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1758         if ($line =~ /^[ \t]*${signature_pattern}.*\@.*$/) {
1759             my @signatures = ($line);
1760             my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures);
1761             my @types = @$types_ref;
1762             my @signers = @$signers_ref;
1763
1764             my $type = $types[0];
1765             my $signer = $signers[0];
1766
1767             $signer = deduplicate_email($signer);
1768
1769             my $exists = 0;
1770             foreach my $ref(@{$commit_signer_hash{$signer}}) {
1771                 if (@{$ref}[0] eq $commit &&
1772                     @{$ref}[1] eq $subject &&
1773                     @{$ref}[2] eq $type) {
1774                     $exists = 1;
1775                     last;
1776                 }
1777             }
1778             if (!$exists) {
1779                 push(@{$commit_signer_hash{$signer}},
1780                      [ ($commit, $subject, $type) ]);
1781             }
1782         }
1783     }
1784 }
1785
1786 sub vcs_assign {
1787     my ($role, $divisor, @lines) = @_;
1788
1789     my %hash;
1790     my $count = 0;
1791
1792     return if (@lines <= 0);
1793
1794     if ($divisor <= 0) {
1795         warn("Bad divisor in " . (caller(0))[3] . ": $divisor\n");
1796         $divisor = 1;
1797     }
1798
1799     @lines = mailmap(@lines);
1800
1801     return if (@lines <= 0);
1802
1803     @lines = sort(@lines);
1804
1805     # uniq -c
1806     $hash{$_}++ for @lines;
1807
1808     # sort -rn
1809     foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) {
1810         my $sign_offs = $hash{$line};
1811         my $percent = $sign_offs * 100 / $divisor;
1812
1813         $percent = 100 if ($percent > 100);
1814         $count++;
1815         last if ($sign_offs < $email_git_min_signatures ||
1816                  $count > $email_git_max_maintainers ||
1817                  $percent < $email_git_min_percent);
1818         push_email_address($line, '');
1819         if ($output_rolestats) {
1820             my $fmt_percent = sprintf("%.0f", $percent);
1821             add_role($line, "$role:$sign_offs/$divisor=$fmt_percent%");
1822         } else {
1823             add_role($line, $role);
1824         }
1825     }
1826 }
1827
1828 sub vcs_file_signoffs {
1829     my ($file) = @_;
1830
1831     my @signers = ();
1832     my $commits;
1833
1834     $vcs_used = vcs_exists();
1835     return if (!$vcs_used);
1836
1837     my $cmd = $VCS_cmds{"find_signers_cmd"};
1838     $cmd =~ s/(\$\w+)/$1/eeg;           # interpolate $cmd
1839
1840     ($commits, @signers) = vcs_find_signers($cmd);
1841
1842     foreach my $signer (@signers) {
1843         $signer = deduplicate_email($signer);
1844     }
1845
1846     vcs_assign("commit_signer", $commits, @signers);
1847 }
1848
1849 sub vcs_file_blame {
1850     my ($file) = @_;
1851
1852     my @signers = ();
1853     my @all_commits = ();
1854     my @commits = ();
1855     my $total_commits;
1856     my $total_lines;
1857
1858     $vcs_used = vcs_exists();
1859     return if (!$vcs_used);
1860
1861     @all_commits = vcs_blame($file);
1862     @commits = uniq(@all_commits);
1863     $total_commits = @commits;
1864     $total_lines = @all_commits;
1865
1866     if ($email_git_blame_signatures) {
1867         if (vcs_is_hg()) {
1868             my $commit_count;
1869             my @commit_signers = ();
1870             my $commit = join(" -r ", @commits);
1871             my $cmd;
1872
1873             $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1874             $cmd =~ s/(\$\w+)/$1/eeg;   #substitute variables in $cmd
1875
1876             ($commit_count, @commit_signers) = vcs_find_signers($cmd);
1877
1878             push(@signers, @commit_signers);
1879         } else {
1880             foreach my $commit (@commits) {
1881                 my $commit_count;
1882                 my @commit_signers = ();
1883                 my $cmd;
1884
1885                 $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1886                 $cmd =~ s/(\$\w+)/$1/eeg;       #substitute variables in $cmd
1887
1888                 ($commit_count, @commit_signers) = vcs_find_signers($cmd);
1889
1890                 push(@signers, @commit_signers);
1891             }
1892         }
1893     }
1894
1895     if ($from_filename) {
1896         if ($output_rolestats) {
1897             my @blame_signers;
1898             if (vcs_is_hg()) {{         # Double brace for last exit
1899                 my $commit_count;
1900                 my @commit_signers = ();
1901                 @commits = uniq(@commits);
1902                 @commits = sort(@commits);
1903                 my $commit = join(" -r ", @commits);
1904                 my $cmd;
1905
1906                 $cmd = $VCS_cmds{"find_commit_author_cmd"};
1907                 $cmd =~ s/(\$\w+)/$1/eeg;       #substitute variables in $cmd
1908
1909                 my @lines = ();
1910
1911                 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1912
1913                 last if !@lines;
1914
1915                 my @authors = ();
1916                 foreach my $line (@lines) {
1917                     if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1918                         my $author = $1;
1919                         $author = deduplicate_email($author);
1920                         push(@authors, $author);
1921                     }
1922                 }
1923
1924                 save_commits_by_author(@lines) if ($interactive);
1925                 save_commits_by_signer(@lines) if ($interactive);
1926
1927                 push(@signers, @authors);
1928             }}
1929             else {
1930                 foreach my $commit (@commits) {
1931                     my $i;
1932                     my $cmd = $VCS_cmds{"find_commit_author_cmd"};
1933                     $cmd =~ s/(\$\w+)/$1/eeg;   #interpolate $cmd
1934                     my @author = vcs_find_author($cmd);
1935                     next if !@author;
1936
1937                     my $formatted_author = deduplicate_email($author[0]);
1938
1939                     my $count = grep(/$commit/, @all_commits);
1940                     for ($i = 0; $i < $count ; $i++) {
1941                         push(@blame_signers, $formatted_author);
1942                     }
1943                 }
1944             }
1945             if (@blame_signers) {
1946                 vcs_assign("authored lines", $total_lines, @blame_signers);
1947             }
1948         }
1949         foreach my $signer (@signers) {
1950             $signer = deduplicate_email($signer);
1951         }
1952         vcs_assign("commits", $total_commits, @signers);
1953     } else {
1954         foreach my $signer (@signers) {
1955             $signer = deduplicate_email($signer);
1956         }
1957         vcs_assign("modified commits", $total_commits, @signers);
1958     }
1959 }
1960
1961 sub uniq {
1962     my (@parms) = @_;
1963
1964     my %saw;
1965     @parms = grep(!$saw{$_}++, @parms);
1966     return @parms;
1967 }
1968
1969 sub sort_and_uniq {
1970     my (@parms) = @_;
1971
1972     my %saw;
1973     @parms = sort @parms;
1974     @parms = grep(!$saw{$_}++, @parms);
1975     return @parms;
1976 }
1977
1978 sub clean_file_emails {
1979     my (@file_emails) = @_;
1980     my @fmt_emails = ();
1981
1982     foreach my $email (@file_emails) {
1983         $email =~ s/[\(\<\{]{0,1}([A-Za-z0-9_\.\+-]+\@[A-Za-z0-9\.-]+)[\)\>\}]{0,1}/\<$1\>/g;
1984         my ($name, $address) = parse_email($email);
1985         if ($name eq '"[,\.]"') {
1986             $name = "";
1987         }
1988
1989         my @nw = split(/[^A-Za-zÀ-ÿ\'\,\.\+-]/, $name);
1990         if (@nw > 2) {
1991             my $first = $nw[@nw - 3];
1992             my $middle = $nw[@nw - 2];
1993             my $last = $nw[@nw - 1];
1994
1995             if (((length($first) == 1 && $first =~ m/[A-Za-z]/) ||
1996                  (length($first) == 2 && substr($first, -1) eq ".")) ||
1997                 (length($middle) == 1 ||
1998                  (length($middle) == 2 && substr($middle, -1) eq "."))) {
1999                 $name = "$first $middle $last";
2000             } else {
2001                 $name = "$middle $last";
2002             }
2003         }
2004
2005         if (substr($name, -1) =~ /[,\.]/) {
2006             $name = substr($name, 0, length($name) - 1);
2007         } elsif (substr($name, -2) =~ /[,\.]"/) {
2008             $name = substr($name, 0, length($name) - 2) . '"';
2009         }
2010
2011         if (substr($name, 0, 1) =~ /[,\.]/) {
2012             $name = substr($name, 1, length($name) - 1);
2013         } elsif (substr($name, 0, 2) =~ /"[,\.]/) {
2014             $name = '"' . substr($name, 2, length($name) - 2);
2015         }
2016
2017         my $fmt_email = format_email($name, $address, $email_usename);
2018         push(@fmt_emails, $fmt_email);
2019     }
2020     return @fmt_emails;
2021 }
2022
2023 sub merge_email {
2024     my @lines;
2025     my %saw;
2026
2027     for (@_) {
2028         my ($address, $role) = @$_;
2029         if (!$saw{$address}) {
2030             if ($output_roles) {
2031                 push(@lines, "$address ($role)");
2032             } else {
2033                 push(@lines, $address);
2034             }
2035             $saw{$address} = 1;
2036         }
2037     }
2038
2039     return @lines;
2040 }
2041
2042 sub output {
2043     my (@parms) = @_;
2044
2045     if ($output_multiline) {
2046         foreach my $line (@parms) {
2047             print("${line}\n");
2048         }
2049     } else {
2050         print(join($output_separator, @parms));
2051         print("\n");
2052     }
2053 }
2054
2055 my $rfc822re;
2056
2057 sub make_rfc822re {
2058 #   Basic lexical tokens are specials, domain_literal, quoted_string, atom, and
2059 #   comment.  We must allow for rfc822_lwsp (or comments) after each of these.
2060 #   This regexp will only work on addresses which have had comments stripped
2061 #   and replaced with rfc822_lwsp.
2062
2063     my $specials = '()<>@,;:\\\\".\\[\\]';
2064     my $controls = '\\000-\\037\\177';
2065
2066     my $dtext = "[^\\[\\]\\r\\\\]";
2067     my $domain_literal = "\\[(?:$dtext|\\\\.)*\\]$rfc822_lwsp*";
2068
2069     my $quoted_string = "\"(?:[^\\\"\\r\\\\]|\\\\.|$rfc822_lwsp)*\"$rfc822_lwsp*";
2070
2071 #   Use zero-width assertion to spot the limit of an atom.  A simple
2072 #   $rfc822_lwsp* causes the regexp engine to hang occasionally.
2073     my $atom = "[^$specials $controls]+(?:$rfc822_lwsp+|\\Z|(?=[\\[\"$specials]))";
2074     my $word = "(?:$atom|$quoted_string)";
2075     my $localpart = "$word(?:\\.$rfc822_lwsp*$word)*";
2076
2077     my $sub_domain = "(?:$atom|$domain_literal)";
2078     my $domain = "$sub_domain(?:\\.$rfc822_lwsp*$sub_domain)*";
2079
2080     my $addr_spec = "$localpart\@$rfc822_lwsp*$domain";
2081
2082     my $phrase = "$word*";
2083     my $route = "(?:\@$domain(?:,\@$rfc822_lwsp*$domain)*:$rfc822_lwsp*)";
2084     my $route_addr = "\\<$rfc822_lwsp*$route?$addr_spec\\>$rfc822_lwsp*";
2085     my $mailbox = "(?:$addr_spec|$phrase$route_addr)";
2086
2087     my $group = "$phrase:$rfc822_lwsp*(?:$mailbox(?:,\\s*$mailbox)*)?;\\s*";
2088     my $address = "(?:$mailbox|$group)";
2089
2090     return "$rfc822_lwsp*$address";
2091 }
2092
2093 sub rfc822_strip_comments {
2094     my $s = shift;
2095 #   Recursively remove comments, and replace with a single space.  The simpler
2096 #   regexps in the Email Addressing FAQ are imperfect - they will miss escaped
2097 #   chars in atoms, for example.
2098
2099     while ($s =~ s/^((?:[^"\\]|\\.)*
2100                     (?:"(?:[^"\\]|\\.)*"(?:[^"\\]|\\.)*)*)
2101                     \((?:[^()\\]|\\.)*\)/$1 /osx) {}
2102     return $s;
2103 }
2104
2105 #   valid: returns true if the parameter is an RFC822 valid address
2106 #
2107 sub rfc822_valid {
2108     my $s = rfc822_strip_comments(shift);
2109
2110     if (!$rfc822re) {
2111         $rfc822re = make_rfc822re();
2112     }
2113
2114     return $s =~ m/^$rfc822re$/so && $s =~ m/^$rfc822_char*$/;
2115 }
2116
2117 #   validlist: In scalar context, returns true if the parameter is an RFC822
2118 #              valid list of addresses.
2119 #
2120 #              In list context, returns an empty list on failure (an invalid
2121 #              address was found); otherwise a list whose first element is the
2122 #              number of addresses found and whose remaining elements are the
2123 #              addresses.  This is needed to disambiguate failure (invalid)
2124 #              from success with no addresses found, because an empty string is
2125 #              a valid list.
2126
2127 sub rfc822_validlist {
2128     my $s = rfc822_strip_comments(shift);
2129
2130     if (!$rfc822re) {
2131         $rfc822re = make_rfc822re();
2132     }
2133     # * null list items are valid according to the RFC
2134     # * the '1' business is to aid in distinguishing failure from no results
2135
2136     my @r;
2137     if ($s =~ m/^(?:$rfc822re)?(?:,(?:$rfc822re)?)*$/so &&
2138         $s =~ m/^$rfc822_char*$/) {
2139         while ($s =~ m/(?:^|,$rfc822_lwsp*)($rfc822re)/gos) {
2140             push(@r, $1);
2141         }
2142         return wantarray ? (scalar(@r), @r) : 1;
2143     }
2144     return wantarray ? () : 0;
2145 }