scripts/get_maintainer.pl

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