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