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