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}softmmu/")) {
 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 = $subsystem . "...";
 911     }
 912     return $subsystem;
 913 }
 914
 915 sub get_maintainer_role {
 916     my ($index) = @_;
 917
 918     my $i;
 919     my $start = find_starting_index($index);
 920     my $end = find_ending_index($index);
 921
 922     my $role = "unknown";
 923     my $subsystem = get_subsystem_name($index);
 924
 925     for ($i = $start + 1; $i < $end; $i++) {
 926         my $tv = $typevalue[$i];
 927         if ($tv =~ m/^(.):\s*(.*)/) {
 928             my $ptype = $1;
 929             my $pvalue = $2;
 930             if ($ptype eq "S") {
 931                 $role = $pvalue;
 932             }
 933         }
 934     }
 935
 936     $role = lc($role);
 937     if      ($role eq "supported") {
 938         $role = "supporter";
 939     } elsif ($role eq "maintained") {
 940         $role = "maintainer";
 941     } elsif ($role eq "odd fixes") {
 942         $role = "odd fixer";
 943     } elsif ($role eq "orphan") {
 944         $role = "orphan minder";
 945     } elsif ($role eq "obsolete") {
 946         $role = "obsolete minder";
 947     } elsif ($role eq "buried alive in reporters") {
 948         $role = "chief penguin";
 949     }
 950
 951     return $role . ":" . $subsystem;
 952 }
 953
 954 sub get_list_role {
 955     my ($index) = @_;
 956
 957     my $subsystem = get_subsystem_name($index);
 958
 959     if ($subsystem eq "THE REST") {
 960         $subsystem = "";
 961     }
 962
 963     return $subsystem;
 964 }
 965
 966 sub add_categories {
 967     my ($index) = @_;
 968
 969     my $i;
 970     my $start = find_starting_index($index);
 971     my $end = find_ending_index($index);
 972
 973     push(@subsystem, $typevalue[$start]);
 974
 975     for ($i = $start + 1; $i < $end; $i++) {
 976         my $tv = $typevalue[$i];
 977         if ($tv =~ m/^(.):\s*(.*)/) {
 978             my $ptype = $1;
 979             my $pvalue = $2;
 980             if ($ptype eq "L") {
 981                 my $list_address = $pvalue;
 982                 my $list_additional = "";
 983                 my $list_role = get_list_role($i);
 984
 985                 if ($list_role ne "") {
 986                     $list_role = ":" . $list_role;
 987                 }
 988                 if ($list_address =~ m/([^\s]+)\s+(.*)$/) {
 989                     $list_address = $1;
 990                     $list_additional = $2;
 991                 }
 992                 if ($list_additional =~ m/subscribers-only/) {
 993                     if ($email_subscriber_list) {
 994                         if (!$hash_list_to{lc($list_address)}) {
 995                             $hash_list_to{lc($list_address)} = 1;
 996                             push(@list_to, [$list_address,
 997                                             "subscriber list${list_role}"]);
 998                         }
 999                     }
1000                 } else {
1001                     if ($email_list) {
1002                         if (!$hash_list_to{lc($list_address)}) {
1003                             $hash_list_to{lc($list_address)} = 1;
1004                             if ($list_additional =~ m/moderated/) {
1005                                 push(@list_to, [$list_address,
1006                                                 "moderated list${list_role}"]);
1007                             } else {
1008                                 push(@list_to, [$list_address,
1009                                                 "open list${list_role}"]);
1010                             }
1011                         }
1012                     }
1013                 }
1014             } elsif ($ptype eq "M") {
1015                 my ($name, $address) = parse_email($pvalue);
1016                 if ($name eq "") {
1017                     if ($i > 0) {
1018                         my $tv = $typevalue[$i - 1];
1019                         if ($tv =~ m/^(.):\s*(.*)/) {
1020                             if ($1 eq "P") {
1021                                 $name = $2;
1022                                 $pvalue = format_email($name, $address, $email_usename);
1023                             }
1024                         }
1025                     }
1026                 }
1027                 if ($email_maintainer) {
1028                     my $role = get_maintainer_role($i);
1029                     push_email_addresses($pvalue, $role);
1030                 }
1031             } elsif ($ptype eq "R") {
1032                 my ($name, $address) = parse_email($pvalue);
1033                 if ($name eq "") {
1034                     if ($i > 0) {
1035                         my $tv = $typevalue[$i - 1];
1036                         if ($tv =~ m/^(.):\s*(.*)/) {
1037                             if ($1 eq "P") {
1038                                 $name = $2;
1039                                 $pvalue = format_email($name, $address, $email_usename);
1040                             }
1041                         }
1042                     }
1043                 }
1044                 if ($email_reviewer) {
1045                     my $subsystem = get_subsystem_name($i);
1046                     push_email_addresses($pvalue, "reviewer:$subsystem");
1047                 }
1048             } elsif ($ptype eq "T") {
1049                 push(@scm, $pvalue);
1050             } elsif ($ptype eq "W") {
1051                 push(@web, $pvalue);
1052             } elsif ($ptype eq "S") {
1053                 push(@status, $pvalue);
1054             }
1055         }
1056     }
1057 }
1058
1059 sub email_inuse {
1060     my ($name, $address) = @_;
1061
1062     return 1 if (($name eq "") && ($address eq ""));
1063     return 1 if (($name ne "") && exists($email_hash_name{lc($name)}));
1064     return 1 if (($address ne "") && exists($email_hash_address{lc($address)}));
1065
1066     return 0;
1067 }
1068
1069 sub push_email_address {
1070     my ($line, $role) = @_;
1071
1072     my ($name, $address) = parse_email($line);
1073
1074     if ($address eq "") {
1075         return 0;
1076     }
1077
1078     if (!$email_remove_duplicates) {
1079         push(@email_to, [format_email($name, $address, $email_usename), $role]);
1080     } elsif (!email_inuse($name, $address)) {
1081         push(@email_to, [format_email($name, $address, $email_usename), $role]);
1082         $email_hash_name{lc($name)}++ if ($name ne "");
1083         $email_hash_address{lc($address)}++;
1084     }
1085
1086     return 1;
1087 }
1088
1089 sub push_email_addresses {
1090     my ($address, $role) = @_;
1091
1092     my @address_list = ();
1093
1094     if (rfc822_valid($address)) {
1095         push_email_address($address, $role);
1096     } elsif (@address_list = rfc822_validlist($address)) {
1097         my $array_count = shift(@address_list);
1098         while (my $entry = shift(@address_list)) {
1099             push_email_address($entry, $role);
1100         }
1101     } else {
1102         if (!push_email_address($address, $role)) {
1103             warn("Invalid MAINTAINERS address: '" . $address . "'\n");
1104         }
1105     }
1106 }
1107
1108 sub add_role {
1109     my ($line, $role) = @_;
1110
1111     my ($name, $address) = parse_email($line);
1112     my $email = format_email($name, $address, $email_usename);
1113
1114     foreach my $entry (@email_to) {
1115         if ($email_remove_duplicates) {
1116             my ($entry_name, $entry_address) = parse_email($entry->[0]);
1117             if (($name eq $entry_name || $address eq $entry_address)
1118                 && ($role eq "" || !($entry->[1] =~ m/$role/))
1119             ) {
1120                 if ($entry->[1] eq "") {
1121                     $entry->[1] = "$role";
1122                 } else {
1123                     $entry->[1] = "$entry->[1],$role";
1124                 }
1125             }
1126         } else {
1127             if ($email eq $entry->[0]
1128                 && ($role eq "" || !($entry->[1] =~ m/$role/))
1129             ) {
1130                 if ($entry->[1] eq "") {
1131                     $entry->[1] = "$role";
1132                 } else {
1133                     $entry->[1] = "$entry->[1],$role";
1134                 }
1135             }
1136         }
1137     }
1138 }
1139
1140 sub which {
1141     my ($bin) = @_;
1142
1143     foreach my $path (split(/:/, $ENV{PATH})) {
1144         if (-e "$path/$bin") {
1145             return "$path/$bin";
1146         }
1147     }
1148
1149     return "";
1150 }
1151
1152 sub which_conf {
1153     my ($conf) = @_;
1154
1155     foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) {
1156         if (-e "$path/$conf") {
1157             return "$path/$conf";
1158         }
1159     }
1160
1161     return "";
1162 }
1163
1164 sub mailmap_email {
1165     my ($line) = @_;
1166
1167     my ($name, $address) = parse_email($line);
1168     my $email = format_email($name, $address, 1);
1169     my $real_name = $name;
1170     my $real_address = $address;
1171
1172     if (exists $mailmap->{names}->{$email} ||
1173         exists $mailmap->{addresses}->{$email}) {
1174         if (exists $mailmap->{names}->{$email}) {
1175             $real_name = $mailmap->{names}->{$email};
1176         }
1177         if (exists $mailmap->{addresses}->{$email}) {
1178             $real_address = $mailmap->{addresses}->{$email};
1179         }
1180     } else {
1181         if (exists $mailmap->{names}->{$address}) {
1182             $real_name = $mailmap->{names}->{$address};
1183         }
1184         if (exists $mailmap->{addresses}->{$address}) {
1185             $real_address = $mailmap->{addresses}->{$address};
1186         }
1187     }
1188     return format_email($real_name, $real_address, 1);
1189 }
1190
1191 sub mailmap {
1192     my (@addresses) = @_;
1193
1194     my @mapped_emails = ();
1195     foreach my $line (@addresses) {
1196         push(@mapped_emails, mailmap_email($line));
1197     }
1198     merge_by_realname(@mapped_emails) if ($email_use_mailmap);
1199     return @mapped_emails;
1200 }
1201
1202 sub merge_by_realname {
1203     my %address_map;
1204     my (@emails) = @_;
1205
1206     foreach my $email (@emails) {
1207         my ($name, $address) = parse_email($email);
1208         if (exists $address_map{$name}) {
1209             $address = $address_map{$name};
1210             $email = format_email($name, $address, 1);
1211         } else {
1212             $address_map{$name} = $address;
1213         }
1214     }
1215 }
1216
1217 sub git_execute_cmd {
1218     my ($cmd) = @_;
1219     my @lines = ();
1220
1221     my $output = `$cmd`;
1222     $output =~ s/^\s*//gm;
1223     @lines = split("\n", $output);
1224
1225     return @lines;
1226 }
1227
1228 sub hg_execute_cmd {
1229     my ($cmd) = @_;
1230     my @lines = ();
1231
1232     my $output = `$cmd`;
1233     @lines = split("\n", $output);
1234
1235     return @lines;
1236 }
1237
1238 sub extract_formatted_signatures {
1239     my (@signature_lines) = @_;
1240
1241     my @type = @signature_lines;
1242
1243     s/\s*(.*):.*/$1/ for (@type);
1244
1245     # cut -f2- -d":"
1246     s/\s*.*:\s*(.+)\s*/$1/ for (@signature_lines);
1247
1248 ## Reformat email addresses (with names) to avoid badly written signatures
1249
1250     foreach my $signer (@signature_lines) {
1251         $signer = deduplicate_email($signer);
1252     }
1253
1254     return (\@type, \@signature_lines);
1255 }
1256
1257 sub vcs_find_signers {
1258     my ($cmd) = @_;
1259     my $commits;
1260     my @lines = ();
1261     my @signatures = ();
1262
1263     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1264
1265     my $pattern = $VCS_cmds{"commit_pattern"};
1266
1267     $commits = grep(/$pattern/, @lines);        # of commits
1268
1269     @signatures = grep(/^[ \t]*${signature_pattern}.*\@.*$/, @lines);
1270
1271     return (0, @signatures) if !@signatures;
1272
1273     save_commits_by_author(@lines) if ($interactive);
1274     save_commits_by_signer(@lines) if ($interactive);
1275
1276     my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures);
1277
1278     return ($commits, @$signers_ref);
1279 }
1280
1281 sub vcs_find_author {
1282     my ($cmd) = @_;
1283     my @lines = ();
1284
1285     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1286
1287     return @lines if !@lines;
1288
1289     my @authors = ();
1290     foreach my $line (@lines) {
1291         if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1292             my $author = $1;
1293             my ($name, $address) = parse_email($author);
1294             $author = format_email($name, $address, 1);
1295             push(@authors, $author);
1296         }
1297     }
1298
1299     save_commits_by_author(@lines) if ($interactive);
1300     save_commits_by_signer(@lines) if ($interactive);
1301
1302     return @authors;
1303 }
1304
1305 sub vcs_save_commits {
1306     my ($cmd) = @_;
1307     my @lines = ();
1308     my @commits = ();
1309
1310     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1311
1312     foreach my $line (@lines) {
1313         if ($line =~ m/$VCS_cmds{"blame_commit_pattern"}/) {
1314             push(@commits, $1);
1315         }
1316     }
1317
1318     return @commits;
1319 }
1320
1321 sub vcs_blame {
1322     my ($file) = @_;
1323     my $cmd;
1324     my @commits = ();
1325
1326     return @commits if (!(-f $file));
1327
1328     if (@range && $VCS_cmds{"blame_range_cmd"} eq "") {
1329         my @all_commits = ();
1330
1331         $cmd = $VCS_cmds{"blame_file_cmd"};
1332         $cmd =~ s/(\$\w+)/$1/eeg;               #interpolate $cmd
1333         @all_commits = vcs_save_commits($cmd);
1334
1335         foreach my $file_range_diff (@range) {
1336             next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1337             my $diff_file = $1;
1338             my $diff_start = $2;
1339             my $diff_length = $3;
1340             next if ("$file" ne "$diff_file");
1341             for (my $i = $diff_start; $i < $diff_start + $diff_length; $i++) {
1342                 push(@commits, $all_commits[$i]);
1343             }
1344         }
1345     } elsif (@range) {
1346         foreach my $file_range_diff (@range) {
1347             next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1348             my $diff_file = $1;
1349             my $diff_start = $2;
1350             my $diff_length = $3;
1351             next if ("$file" ne "$diff_file");
1352             $cmd = $VCS_cmds{"blame_range_cmd"};
1353             $cmd =~ s/(\$\w+)/$1/eeg;           #interpolate $cmd
1354             push(@commits, vcs_save_commits($cmd));
1355         }
1356     } else {
1357         $cmd = $VCS_cmds{"blame_file_cmd"};
1358         $cmd =~ s/(\$\w+)/$1/eeg;               #interpolate $cmd
1359         @commits = vcs_save_commits($cmd);
1360     }
1361
1362     foreach my $commit (@commits) {
1363         $commit =~ s/^\^//g;
1364     }
1365
1366     return @commits;
1367 }
1368
1369 my $printed_novcs = 0;
1370 sub vcs_exists {
1371     %VCS_cmds = %VCS_cmds_git;
1372     return 1 if eval $VCS_cmds{"available"};
1373     %VCS_cmds = %VCS_cmds_hg;
1374     return 2 if eval $VCS_cmds{"available"};
1375     %VCS_cmds = ();
1376     if (!$printed_novcs) {
1377         warn("$P: No supported VCS found.  Add --nogit to options?\n");
1378         warn("Using a git repository produces better results.\n");
1379         warn("Try latest git repository using:\n");
1380         warn("git clone https://gitlab.com/qemu-project/qemu.git\n");
1381         $printed_novcs = 1;
1382     }
1383     return 0;
1384 }
1385
1386 sub vcs_is_git {
1387     vcs_exists();
1388     return $vcs_used == 1;
1389 }
1390
1391 sub vcs_is_hg {
1392     return $vcs_used == 2;
1393 }
1394
1395 sub interactive_get_maintainers {
1396     my ($list_ref) = @_;
1397     my @list = @$list_ref;
1398
1399     vcs_exists();
1400
1401     my %selected;
1402     my %authored;
1403     my %signed;
1404     my $count = 0;
1405     my $maintained = 0;
1406     foreach my $entry (@list) {
1407         $maintained = 1 if ($entry->[1] =~ /^(maintainer|supporter)/i);
1408         $selected{$count} = 1;
1409         $authored{$count} = 0;
1410         $signed{$count} = 0;
1411         $count++;
1412     }
1413
1414     #menu loop
1415     my $done = 0;
1416     my $print_options = 0;
1417     my $redraw = 1;
1418     while (!$done) {
1419         $count = 0;
1420         if ($redraw) {
1421             printf STDERR "\n%1s %2s %-65s",
1422                           "*", "#", "email/list and role:stats";
1423             if ($email_git ||
1424                 ($email_git_fallback && !$maintained) ||
1425                 $email_git_blame) {
1426                 print STDERR "auth sign";
1427             }
1428             print STDERR "\n";
1429             foreach my $entry (@list) {
1430                 my $email = $entry->[0];
1431                 my $role = $entry->[1];
1432                 my $sel = "";
1433                 $sel = "*" if ($selected{$count});
1434                 my $commit_author = $commit_author_hash{$email};
1435                 my $commit_signer = $commit_signer_hash{$email};
1436                 my $authored = 0;
1437                 my $signed = 0;
1438                 $authored++ for (@{$commit_author});
1439                 $signed++ for (@{$commit_signer});
1440                 printf STDERR "%1s %2d %-65s", $sel, $count + 1, $email;
1441                 printf STDERR "%4d %4d", $authored, $signed
1442                     if ($authored > 0 || $signed > 0);
1443                 printf STDERR "\n     %s\n", $role;
1444                 if ($authored{$count}) {
1445                     my $commit_author = $commit_author_hash{$email};
1446                     foreach my $ref (@{$commit_author}) {
1447                         print STDERR "     Author: @{$ref}[1]\n";
1448                     }
1449                 }
1450                 if ($signed{$count}) {
1451                     my $commit_signer = $commit_signer_hash{$email};
1452                     foreach my $ref (@{$commit_signer}) {
1453                         print STDERR "     @{$ref}[2]: @{$ref}[1]\n";
1454                     }
1455                 }
1456
1457                 $count++;
1458             }
1459         }
1460         my $date_ref = \$email_git_since;
1461         $date_ref = \$email_hg_since if (vcs_is_hg());
1462         if ($print_options) {
1463             $print_options = 0;
1464             if (vcs_exists()) {
1465                 print STDERR <<EOT
1466
1467 Version Control options:
1468 g  use git history      [$email_git]
1469 gf use git-fallback     [$email_git_fallback]
1470 b  use git blame        [$email_git_blame]
1471 bs use blame signatures [$email_git_blame_signatures]
1472 c# minimum commits      [$email_git_min_signatures]
1473 %# min percent          [$email_git_min_percent]
1474 d# history to use       [$$date_ref]
1475 x# max maintainers      [$email_git_max_maintainers]
1476 t  all signature types  [$email_git_all_signature_types]
1477 m  use .mailmap         [$email_use_mailmap]
1478 EOT
1479             }
1480             print STDERR <<EOT
1481
1482 Additional options:
1483 0  toggle all
1484 tm toggle maintainers
1485 tg toggle git entries
1486 tl toggle open list entries
1487 ts toggle subscriber list entries
1488 f  emails in file       [$file_emails]
1489 k  keywords in file     [$keywords]
1490 r  remove duplicates    [$email_remove_duplicates]
1491 p# pattern match depth  [$pattern_depth]
1492 EOT
1493         }
1494         print STDERR
1495 "\n#(toggle), A#(author), S#(signed) *(all), ^(none), O(options), Y(approve): ";
1496
1497         my $input = <STDIN>;
1498         chomp($input);
1499
1500         $redraw = 1;
1501         my $rerun = 0;
1502         my @wish = split(/[, ]+/, $input);
1503         foreach my $nr (@wish) {
1504             $nr = lc($nr);
1505             my $sel = substr($nr, 0, 1);
1506             my $str = substr($nr, 1);
1507             my $val = 0;
1508             $val = $1 if $str =~ /^(\d+)$/;
1509
1510             if ($sel eq "y") {
1511                 $interactive = 0;
1512                 $done = 1;
1513                 $output_rolestats = 0;
1514                 $output_roles = 0;
1515                 last;
1516             } elsif ($nr =~ /^\d+$/ && $nr > 0 && $nr <= $count) {
1517                 $selected{$nr - 1} = !$selected{$nr - 1};
1518             } elsif ($sel eq "*" || $sel eq '^') {
1519                 my $toggle = 0;
1520                 $toggle = 1 if ($sel eq '*');
1521                 for (my $i = 0; $i < $count; $i++) {
1522                     $selected{$i} = $toggle;
1523                 }
1524             } elsif ($sel eq "0") {
1525                 for (my $i = 0; $i < $count; $i++) {
1526                     $selected{$i} = !$selected{$i};
1527                 }
1528             } elsif ($sel eq "t") {
1529                 if (lc($str) eq "m") {
1530                     for (my $i = 0; $i < $count; $i++) {
1531                         $selected{$i} = !$selected{$i}
1532                             if ($list[$i]->[1] =~ /^(maintainer|supporter)/i);
1533                     }
1534                 } elsif (lc($str) eq "g") {
1535                     for (my $i = 0; $i < $count; $i++) {
1536                         $selected{$i} = !$selected{$i}
1537                             if ($list[$i]->[1] =~ /^(author|commit|signer)/i);
1538                     }
1539                 } elsif (lc($str) eq "l") {
1540                     for (my $i = 0; $i < $count; $i++) {
1541                         $selected{$i} = !$selected{$i}
1542                             if ($list[$i]->[1] =~ /^(open list)/i);
1543                     }
1544                 } elsif (lc($str) eq "s") {
1545                     for (my $i = 0; $i < $count; $i++) {
1546                         $selected{$i} = !$selected{$i}
1547                             if ($list[$i]->[1] =~ /^(subscriber list)/i);
1548                     }
1549                 }
1550             } elsif ($sel eq "a") {
1551                 if ($val > 0 && $val <= $count) {
1552                     $authored{$val - 1} = !$authored{$val - 1};
1553                 } elsif ($str eq '*' || $str eq '^') {
1554                     my $toggle = 0;
1555                     $toggle = 1 if ($str eq '*');
1556                     for (my $i = 0; $i < $count; $i++) {
1557                         $authored{$i} = $toggle;
1558                     }
1559                 }
1560             } elsif ($sel eq "s") {
1561                 if ($val > 0 && $val <= $count) {
1562                     $signed{$val - 1} = !$signed{$val - 1};
1563                 } elsif ($str eq '*' || $str eq '^') {
1564                     my $toggle = 0;
1565                     $toggle = 1 if ($str eq '*');
1566                     for (my $i = 0; $i < $count; $i++) {
1567                         $signed{$i} = $toggle;
1568                     }
1569                 }
1570             } elsif ($sel eq "o") {
1571                 $print_options = 1;
1572                 $redraw = 1;
1573             } elsif ($sel eq "g") {
1574                 if ($str eq "f") {
1575                     bool_invert(\$email_git_fallback);
1576                 } else {
1577                     bool_invert(\$email_git);
1578                 }
1579                 $rerun = 1;
1580             } elsif ($sel eq "b") {
1581                 if ($str eq "s") {
1582                     bool_invert(\$email_git_blame_signatures);
1583                 } else {
1584                     bool_invert(\$email_git_blame);
1585                 }
1586                 $rerun = 1;
1587             } elsif ($sel eq "c") {
1588                 if ($val > 0) {
1589                     $email_git_min_signatures = $val;
1590                     $rerun = 1;
1591                 }
1592             } elsif ($sel eq "x") {
1593                 if ($val > 0) {
1594                     $email_git_max_maintainers = $val;
1595                     $rerun = 1;
1596                 }
1597             } elsif ($sel eq "%") {
1598                 if ($str ne "" && $val >= 0) {
1599                     $email_git_min_percent = $val;
1600                     $rerun = 1;
1601                 }
1602             } elsif ($sel eq "d") {
1603                 if (vcs_is_git()) {
1604                     $email_git_since = $str;
1605                 } elsif (vcs_is_hg()) {
1606                     $email_hg_since = $str;
1607                 }
1608                 $rerun = 1;
1609             } elsif ($sel eq "t") {
1610                 bool_invert(\$email_git_all_signature_types);
1611                 $rerun = 1;
1612             } elsif ($sel eq "f") {
1613                 bool_invert(\$file_emails);
1614                 $rerun = 1;
1615             } elsif ($sel eq "r") {
1616                 bool_invert(\$email_remove_duplicates);
1617                 $rerun = 1;
1618             } elsif ($sel eq "m") {
1619                 bool_invert(\$email_use_mailmap);
1620                 read_mailmap();
1621                 $rerun = 1;
1622             } elsif ($sel eq "k") {
1623                 bool_invert(\$keywords);
1624                 $rerun = 1;
1625             } elsif ($sel eq "p") {
1626                 if ($str ne "" && $val >= 0) {
1627                     $pattern_depth = $val;
1628                     $rerun = 1;
1629                 }
1630             } elsif ($sel eq "h" || $sel eq "?") {
1631                 print STDERR <<EOT
1632
1633 Interactive mode allows you to select the various maintainers, submitters,
1634 commit signers and mailing lists that could be CC'd on a patch.
1635
1636 Any *'d entry is selected.
1637
1638 If you have git or hg installed, you can choose to summarize the commit
1639 history of files in the patch.  Also, each line of the current file can
1640 be matched to its commit author and that commits signers with blame.
1641
1642 Various knobs exist to control the length of time for active commit
1643 tracking, the maximum number of commit authors and signers to add,
1644 and such.
1645
1646 Enter selections at the prompt until you are satisfied that the selected
1647 maintainers are appropriate.  You may enter multiple selections separated
1648 by either commas or spaces.
1649
1650 EOT
1651             } else {
1652                 print STDERR "invalid option: '$nr'\n";
1653                 $redraw = 0;
1654             }
1655         }
1656         if ($rerun) {
1657             print STDERR "git-blame can be very slow, please have patience..."
1658                 if ($email_git_blame);
1659             goto &get_maintainers;
1660         }
1661     }
1662
1663     #drop not selected entries
1664     $count = 0;
1665     my @new_emailto = ();
1666     foreach my $entry (@list) {
1667         if ($selected{$count}) {
1668             push(@new_emailto, $list[$count]);
1669         }
1670         $count++;
1671     }
1672     return @new_emailto;
1673 }
1674
1675 sub bool_invert {
1676     my ($bool_ref) = @_;
1677
1678     if ($$bool_ref) {
1679         $$bool_ref = 0;
1680     } else {
1681         $$bool_ref = 1;
1682     }
1683 }
1684
1685 sub deduplicate_email {
1686     my ($email) = @_;
1687
1688     my $matched = 0;
1689     my ($name, $address) = parse_email($email);
1690     $email = format_email($name, $address, 1);
1691     $email = mailmap_email($email);
1692
1693     return $email if (!$email_remove_duplicates);
1694
1695     ($name, $address) = parse_email($email);
1696
1697     if ($name ne "" && $deduplicate_name_hash{lc($name)}) {
1698         $name = $deduplicate_name_hash{lc($name)}->[0];
1699         $address = $deduplicate_name_hash{lc($name)}->[1];
1700         $matched = 1;
1701     } elsif ($deduplicate_address_hash{lc($address)}) {
1702         $name = $deduplicate_address_hash{lc($address)}->[0];
1703         $address = $deduplicate_address_hash{lc($address)}->[1];
1704         $matched = 1;
1705     }
1706     if (!$matched) {
1707         $deduplicate_name_hash{lc($name)} = [ $name, $address ];
1708         $deduplicate_address_hash{lc($address)} = [ $name, $address ];
1709     }
1710     $email = format_email($name, $address, 1);
1711     $email = mailmap_email($email);
1712     return $email;
1713 }
1714
1715 sub save_commits_by_author {
1716     my (@lines) = @_;
1717
1718     my @authors = ();
1719     my @commits = ();
1720     my @subjects = ();
1721
1722     foreach my $line (@lines) {
1723         if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1724             my $author = $1;
1725             $author = deduplicate_email($author);
1726             push(@authors, $author);
1727         }
1728         push(@commits, $1) if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1729         push(@subjects, $1) if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1730     }
1731
1732     for (my $i = 0; $i < @authors; $i++) {
1733         my $exists = 0;
1734         foreach my $ref(@{$commit_author_hash{$authors[$i]}}) {
1735             if (@{$ref}[0] eq $commits[$i] &&
1736                 @{$ref}[1] eq $subjects[$i]) {
1737                 $exists = 1;
1738                 last;
1739             }
1740         }
1741         if (!$exists) {
1742             push(@{$commit_author_hash{$authors[$i]}},
1743                  [ ($commits[$i], $subjects[$i]) ]);
1744         }
1745     }
1746 }
1747
1748 sub save_commits_by_signer {
1749     my (@lines) = @_;
1750
1751     my $commit = "";
1752     my $subject = "";
1753
1754     foreach my $line (@lines) {
1755         $commit = $1 if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1756         $subject = $1 if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1757         if ($line =~ /^[ \t]*${signature_pattern}.*\@.*$/) {
1758             my @signatures = ($line);
1759             my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures);
1760             my @types = @$types_ref;
1761             my @signers = @$signers_ref;
1762
1763             my $type = $types[0];
1764             my $signer = $signers[0];
1765
1766             $signer = deduplicate_email($signer);
1767
1768             my $exists = 0;
1769             foreach my $ref(@{$commit_signer_hash{$signer}}) {
1770                 if (@{$ref}[0] eq $commit &&
1771                     @{$ref}[1] eq $subject &&
1772                     @{$ref}[2] eq $type) {
1773                     $exists = 1;
1774                     last;
1775                 }
1776             }
1777             if (!$exists) {
1778                 push(@{$commit_signer_hash{$signer}},
1779                      [ ($commit, $subject, $type) ]);
1780             }
1781         }
1782     }
1783 }
1784
1785 sub vcs_assign {
1786     my ($role, $divisor, @lines) = @_;
1787
1788     my %hash;
1789     my $count = 0;
1790
1791     return if (@lines <= 0);
1792
1793     if ($divisor <= 0) {
1794         warn("Bad divisor in " . (caller(0))[3] . ": $divisor\n");
1795         $divisor = 1;
1796     }
1797
1798     @lines = mailmap(@lines);
1799
1800     return if (@lines <= 0);
1801
1802     @lines = sort(@lines);
1803
1804     # uniq -c
1805     $hash{$_}++ for @lines;
1806
1807     # sort -rn
1808     foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) {
1809         my $sign_offs = $hash{$line};
1810         my $percent = $sign_offs * 100 / $divisor;
1811
1812         $percent = 100 if ($percent > 100);
1813         $count++;
1814         last if ($sign_offs < $email_git_min_signatures ||
1815                  $count > $email_git_max_maintainers ||
1816                  $percent < $email_git_min_percent);
1817         push_email_address($line, '');
1818         if ($output_rolestats) {
1819             my $fmt_percent = sprintf("%.0f", $percent);
1820             add_role($line, "$role:$sign_offs/$divisor=$fmt_percent%");
1821         } else {
1822             add_role($line, $role);
1823         }
1824     }
1825 }
1826
1827 sub vcs_file_signoffs {
1828     my ($file) = @_;
1829
1830     my @signers = ();
1831     my $commits;
1832
1833     $vcs_used = vcs_exists();
1834     return if (!$vcs_used);
1835
1836     my $cmd = $VCS_cmds{"find_signers_cmd"};
1837     $cmd =~ s/(\$\w+)/$1/eeg;           # interpolate $cmd
1838
1839     ($commits, @signers) = vcs_find_signers($cmd);
1840
1841     foreach my $signer (@signers) {
1842         $signer = deduplicate_email($signer);
1843     }
1844
1845     vcs_assign("commit_signer", $commits, @signers);
1846 }
1847
1848 sub vcs_file_blame {
1849     my ($file) = @_;
1850
1851     my @signers = ();
1852     my @all_commits = ();
1853     my @commits = ();
1854     my $total_commits;
1855     my $total_lines;
1856
1857     $vcs_used = vcs_exists();
1858     return if (!$vcs_used);
1859
1860     @all_commits = vcs_blame($file);
1861     @commits = uniq(@all_commits);
1862     $total_commits = @commits;
1863     $total_lines = @all_commits;
1864
1865     if ($email_git_blame_signatures) {
1866         if (vcs_is_hg()) {
1867             my $commit_count;
1868             my @commit_signers = ();
1869             my $commit = join(" -r ", @commits);
1870             my $cmd;
1871
1872             $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1873             $cmd =~ s/(\$\w+)/$1/eeg;   #substitute variables in $cmd
1874
1875             ($commit_count, @commit_signers) = vcs_find_signers($cmd);
1876
1877             push(@signers, @commit_signers);
1878         } else {
1879             foreach my $commit (@commits) {
1880                 my $commit_count;
1881                 my @commit_signers = ();
1882                 my $cmd;
1883
1884                 $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1885                 $cmd =~ s/(\$\w+)/$1/eeg;       #substitute variables in $cmd
1886
1887                 ($commit_count, @commit_signers) = vcs_find_signers($cmd);
1888
1889                 push(@signers, @commit_signers);
1890             }
1891         }
1892     }
1893
1894     if ($from_filename) {
1895         if ($output_rolestats) {
1896             my @blame_signers;
1897             if (vcs_is_hg()) {{         # Double brace for last exit
1898                 my $commit_count;
1899                 my @commit_signers = ();
1900                 @commits = uniq(@commits);
1901                 @commits = sort(@commits);
1902                 my $commit = join(" -r ", @commits);
1903                 my $cmd;
1904
1905                 $cmd = $VCS_cmds{"find_commit_author_cmd"};
1906                 $cmd =~ s/(\$\w+)/$1/eeg;       #substitute variables in $cmd
1907
1908                 my @lines = ();
1909
1910                 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1911
1912                 last if !@lines;
1913
1914                 my @authors = ();
1915                 foreach my $line (@lines) {
1916                     if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1917                         my $author = $1;
1918                         $author = deduplicate_email($author);
1919                         push(@authors, $author);
1920                     }
1921                 }
1922
1923                 save_commits_by_author(@lines) if ($interactive);
1924                 save_commits_by_signer(@lines) if ($interactive);
1925
1926                 push(@signers, @authors);
1927             }}
1928             else {
1929                 foreach my $commit (@commits) {
1930                     my $i;
1931                     my $cmd = $VCS_cmds{"find_commit_author_cmd"};
1932                     $cmd =~ s/(\$\w+)/$1/eeg;   #interpolate $cmd
1933                     my @author = vcs_find_author($cmd);
1934                     next if !@author;
1935
1936                     my $formatted_author = deduplicate_email($author[0]);
1937
1938                     my $count = grep(/$commit/, @all_commits);
1939                     for ($i = 0; $i < $count ; $i++) {
1940                         push(@blame_signers, $formatted_author);
1941                     }
1942                 }
1943             }
1944             if (@blame_signers) {
1945                 vcs_assign("authored lines", $total_lines, @blame_signers);
1946             }
1947         }
1948         foreach my $signer (@signers) {
1949             $signer = deduplicate_email($signer);
1950         }
1951         vcs_assign("commits", $total_commits, @signers);
1952     } else {
1953         foreach my $signer (@signers) {
1954             $signer = deduplicate_email($signer);
1955         }
1956         vcs_assign("modified commits", $total_commits, @signers);
1957     }
1958 }
1959
1960 sub uniq {
1961     my (@parms) = @_;
1962
1963     my %saw;
1964     @parms = grep(!$saw{$_}++, @parms);
1965     return @parms;
1966 }
1967
1968 sub sort_and_uniq {
1969     my (@parms) = @_;
1970
1971     my %saw;
1972     @parms = sort @parms;
1973     @parms = grep(!$saw{$_}++, @parms);
1974     return @parms;
1975 }
1976
1977 sub clean_file_emails {
1978     my (@file_emails) = @_;
1979     my @fmt_emails = ();
1980
1981     foreach my $email (@file_emails) {
1982         $email =~ s/[\(\<\{]{0,1}([A-Za-z0-9_\.\+-]+\@[A-Za-z0-9\.-]+)[\)\>\}]{0,1}/\<$1\>/g;
1983         my ($name, $address) = parse_email($email);
1984         if ($name eq '"[,\.]"') {
1985             $name = "";
1986         }
1987
1988         my @nw = split(/[^A-Za-zÀ-ÿ\'\,\.\+-]/, $name);
1989         if (@nw > 2) {
1990             my $first = $nw[@nw - 3];
1991             my $middle = $nw[@nw - 2];
1992             my $last = $nw[@nw - 1];
1993
1994             if (((length($first) == 1 && $first =~ m/[A-Za-z]/) ||
1995                  (length($first) == 2 && substr($first, -1) eq ".")) ||
1996                 (length($middle) == 1 ||
1997                  (length($middle) == 2 && substr($middle, -1) eq "."))) {
1998                 $name = "$first $middle $last";
1999             } else {
2000                 $name = "$middle $last";
2001             }
2002         }
2003
2004         if (substr($name, -1) =~ /[,\.]/) {
2005             $name = substr($name, 0, length($name) - 1);
2006         } elsif (substr($name, -2) =~ /[,\.]"/) {
2007             $name = substr($name, 0, length($name) - 2) . '"';
2008         }
2009
2010         if (substr($name, 0, 1) =~ /[,\.]/) {
2011             $name = substr($name, 1, length($name) - 1);
2012         } elsif (substr($name, 0, 2) =~ /"[,\.]/) {
2013             $name = '"' . substr($name, 2, length($name) - 2);
2014         }
2015
2016         my $fmt_email = format_email($name, $address, $email_usename);
2017         push(@fmt_emails, $fmt_email);
2018     }
2019     return @fmt_emails;
2020 }
2021
2022 sub merge_email {
2023     my @lines;
2024     my %saw;
2025
2026     for (@_) {
2027         my ($address, $role) = @$_;
2028         if (!$saw{$address}) {
2029             if ($output_roles) {
2030                 push(@lines, "$address ($role)");
2031             } else {
2032                 push(@lines, $address);
2033             }
2034             $saw{$address} = 1;
2035         }
2036     }
2037
2038     return @lines;
2039 }
2040
2041 sub output {
2042     my (@parms) = @_;
2043
2044     if ($output_multiline) {
2045         foreach my $line (@parms) {
2046             print("${line}\n");
2047         }
2048     } else {
2049         print(join($output_separator, @parms));
2050         print("\n");
2051     }
2052 }
2053
2054 my $rfc822re;
2055
2056 sub make_rfc822re {
2057 #   Basic lexical tokens are specials, domain_literal, quoted_string, atom, and
2058 #   comment.  We must allow for rfc822_lwsp (or comments) after each of these.
2059 #   This regexp will only work on addresses which have had comments stripped
2060 #   and replaced with rfc822_lwsp.
2061
2062     my $specials = '()<>@,;:\\\\".\\[\\]';
2063     my $controls = '\\000-\\037\\177';
2064
2065     my $dtext = "[^\\[\\]\\r\\\\]";
2066     my $domain_literal = "\\[(?:$dtext|\\\\.)*\\]$rfc822_lwsp*";
2067
2068     my $quoted_string = "\"(?:[^\\\"\\r\\\\]|\\\\.|$rfc822_lwsp)*\"$rfc822_lwsp*";
2069
2070 #   Use zero-width assertion to spot the limit of an atom.  A simple
2071 #   $rfc822_lwsp* causes the regexp engine to hang occasionally.
2072     my $atom = "[^$specials $controls]+(?:$rfc822_lwsp+|\\Z|(?=[\\[\"$specials]))";
2073     my $word = "(?:$atom|$quoted_string)";
2074     my $localpart = "$word(?:\\.$rfc822_lwsp*$word)*";
2075
2076     my $sub_domain = "(?:$atom|$domain_literal)";
2077     my $domain = "$sub_domain(?:\\.$rfc822_lwsp*$sub_domain)*";
2078
2079     my $addr_spec = "$localpart\@$rfc822_lwsp*$domain";
2080
2081     my $phrase = "$word*";
2082     my $route = "(?:\@$domain(?:,\@$rfc822_lwsp*$domain)*:$rfc822_lwsp*)";
2083     my $route_addr = "\\<$rfc822_lwsp*$route?$addr_spec\\>$rfc822_lwsp*";
2084     my $mailbox = "(?:$addr_spec|$phrase$route_addr)";
2085
2086     my $group = "$phrase:$rfc822_lwsp*(?:$mailbox(?:,\\s*$mailbox)*)?;\\s*";
2087     my $address = "(?:$mailbox|$group)";
2088
2089     return "$rfc822_lwsp*$address";
2090 }
2091
2092 sub rfc822_strip_comments {
2093     my $s = shift;
2094 #   Recursively remove comments, and replace with a single space.  The simpler
2095 #   regexps in the Email Addressing FAQ are imperfect - they will miss escaped
2096 #   chars in atoms, for example.
2097
2098     while ($s =~ s/^((?:[^"\\]|\\.)*
2099                     (?:"(?:[^"\\]|\\.)*"(?:[^"\\]|\\.)*)*)
2100                     \((?:[^()\\]|\\.)*\)/$1 /osx) {}
2101     return $s;
2102 }
2103
2104 #   valid: returns true if the parameter is an RFC822 valid address
2105 #
2106 sub rfc822_valid {
2107     my $s = rfc822_strip_comments(shift);
2108
2109     if (!$rfc822re) {
2110         $rfc822re = make_rfc822re();
2111     }
2112
2113     return $s =~ m/^$rfc822re$/so && $s =~ m/^$rfc822_char*$/;
2114 }
2115
2116 #   validlist: In scalar context, returns true if the parameter is an RFC822
2117 #              valid list of addresses.
2118 #
2119 #              In list context, returns an empty list on failure (an invalid
2120 #              address was found); otherwise a list whose first element is the
2121 #              number of addresses found and whose remaining elements are the
2122 #              addresses.  This is needed to disambiguate failure (invalid)
2123 #              from success with no addresses found, because an empty string is
2124 #              a valid list.
2125
2126 sub rfc822_validlist {
2127     my $s = rfc822_strip_comments(shift);
2128
2129     if (!$rfc822re) {
2130         $rfc822re = make_rfc822re();
2131     }
2132     # * null list items are valid according to the RFC
2133     # * the '1' business is to aid in distinguishing failure from no results
2134
2135     my @r;
2136     if ($s =~ m/^(?:$rfc822re)?(?:,(?:$rfc822re)?)*$/so &&
2137         $s =~ m/^$rfc822_char*$/) {
2138         while ($s =~ m/(?:^|,$rfc822_lwsp*)($rfc822re)/gos) {
2139             push(@r, $1);
2140         }
2141         return wantarray ? (scalar(@r), @r) : 1;
2142     }
2143     return wantarray ? () : 0;
2144 }