scripts/get_maintainer.pl

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