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