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