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