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