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