scripts/get_maintainer.pl

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