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 --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_maintainer_role {
 900     my ($index) = @_;
 901
 902     my $i;
 903     my $start = find_starting_index($index);
 904     my $end = find_ending_index($index);
 905
 906     my $role = "unknown";
 907     my $subsystem = $typevalue[$start];
 908     if (length($subsystem) > 20) {
 909         $subsystem = substr($subsystem, 0, 17);
 910         $subsystem =~ s/\s*$//;
 911         $subsystem = $subsystem . "...";
 912     }
 913
 914     for ($i = $start + 1; $i < $end; $i++) {
 915         my $tv = $typevalue[$i];
 916         if ($tv =~ m/^(.):\s*(.*)/) {
 917             my $ptype = $1;
 918             my $pvalue = $2;
 919             if ($ptype eq "S") {
 920                 $role = $pvalue;
 921             }
 922         }
 923     }
 924
 925     $role = lc($role);
 926     if      ($role eq "supported") {
 927         $role = "supporter";
 928     } elsif ($role eq "maintained") {
 929         $role = "maintainer";
 930     } elsif ($role eq "odd fixes") {
 931         $role = "odd fixer";
 932     } elsif ($role eq "orphan") {
 933         $role = "orphan minder";
 934     } elsif ($role eq "obsolete") {
 935         $role = "obsolete minder";
 936     } elsif ($role eq "buried alive in reporters") {
 937         $role = "chief penguin";
 938     }
 939
 940     return $role . ":" . $subsystem;
 941 }
 942
 943 sub get_list_role {
 944     my ($index) = @_;
 945
 946     my $i;
 947     my $start = find_starting_index($index);
 948     my $end = find_ending_index($index);
 949
 950     my $subsystem = $typevalue[$start];
 951     if (length($subsystem) > 20) {
 952         $subsystem = substr($subsystem, 0, 17);
 953         $subsystem =~ s/\s*$//;
 954         $subsystem = $subsystem . "...";
 955     }
 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                     push_email_addresses($pvalue, 'reviewer');
1044                 }
1045             } elsif ($ptype eq "T") {
1046                 push(@scm, $pvalue);
1047             } elsif ($ptype eq "W") {
1048                 push(@web, $pvalue);
1049             } elsif ($ptype eq "S") {
1050                 push(@status, $pvalue);
1051             }
1052         }
1053     }
1054 }
1055
1056 sub email_inuse {
1057     my ($name, $address) = @_;
1058
1059     return 1 if (($name eq "") && ($address eq ""));
1060     return 1 if (($name ne "") && exists($email_hash_name{lc($name)}));
1061     return 1 if (($address ne "") && exists($email_hash_address{lc($address)}));
1062
1063     return 0;
1064 }
1065
1066 sub push_email_address {
1067     my ($line, $role) = @_;
1068
1069     my ($name, $address) = parse_email($line);
1070
1071     if ($address eq "") {
1072         return 0;
1073     }
1074
1075     if (!$email_remove_duplicates) {
1076         push(@email_to, [format_email($name, $address, $email_usename), $role]);
1077     } elsif (!email_inuse($name, $address)) {
1078         push(@email_to, [format_email($name, $address, $email_usename), $role]);
1079         $email_hash_name{lc($name)}++ if ($name ne "");
1080         $email_hash_address{lc($address)}++;
1081     }
1082
1083     return 1;
1084 }
1085
1086 sub push_email_addresses {
1087     my ($address, $role) = @_;
1088
1089     my @address_list = ();
1090
1091     if (rfc822_valid($address)) {
1092         push_email_address($address, $role);
1093     } elsif (@address_list = rfc822_validlist($address)) {
1094         my $array_count = shift(@address_list);
1095         while (my $entry = shift(@address_list)) {
1096             push_email_address($entry, $role);
1097         }
1098     } else {
1099         if (!push_email_address($address, $role)) {
1100             warn("Invalid MAINTAINERS address: '" . $address . "'\n");
1101         }
1102     }
1103 }
1104
1105 sub add_role {
1106     my ($line, $role) = @_;
1107
1108     my ($name, $address) = parse_email($line);
1109     my $email = format_email($name, $address, $email_usename);
1110
1111     foreach my $entry (@email_to) {
1112         if ($email_remove_duplicates) {
1113             my ($entry_name, $entry_address) = parse_email($entry->[0]);
1114             if (($name eq $entry_name || $address eq $entry_address)
1115                 && ($role eq "" || !($entry->[1] =~ m/$role/))
1116             ) {
1117                 if ($entry->[1] eq "") {
1118                     $entry->[1] = "$role";
1119                 } else {
1120                     $entry->[1] = "$entry->[1],$role";
1121                 }
1122             }
1123         } else {
1124             if ($email eq $entry->[0]
1125                 && ($role eq "" || !($entry->[1] =~ m/$role/))
1126             ) {
1127                 if ($entry->[1] eq "") {
1128                     $entry->[1] = "$role";
1129                 } else {
1130                     $entry->[1] = "$entry->[1],$role";
1131                 }
1132             }
1133         }
1134     }
1135 }
1136
1137 sub which {
1138     my ($bin) = @_;
1139
1140     foreach my $path (split(/:/, $ENV{PATH})) {
1141         if (-e "$path/$bin") {
1142             return "$path/$bin";
1143         }
1144     }
1145
1146     return "";
1147 }
1148
1149 sub which_conf {
1150     my ($conf) = @_;
1151
1152     foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) {
1153         if (-e "$path/$conf") {
1154             return "$path/$conf";
1155         }
1156     }
1157
1158     return "";
1159 }
1160
1161 sub mailmap_email {
1162     my ($line) = @_;
1163
1164     my ($name, $address) = parse_email($line);
1165     my $email = format_email($name, $address, 1);
1166     my $real_name = $name;
1167     my $real_address = $address;
1168
1169     if (exists $mailmap->{names}->{$email} ||
1170         exists $mailmap->{addresses}->{$email}) {
1171         if (exists $mailmap->{names}->{$email}) {
1172             $real_name = $mailmap->{names}->{$email};
1173         }
1174         if (exists $mailmap->{addresses}->{$email}) {
1175             $real_address = $mailmap->{addresses}->{$email};
1176         }
1177     } else {
1178         if (exists $mailmap->{names}->{$address}) {
1179             $real_name = $mailmap->{names}->{$address};
1180         }
1181         if (exists $mailmap->{addresses}->{$address}) {
1182             $real_address = $mailmap->{addresses}->{$address};
1183         }
1184     }
1185     return format_email($real_name, $real_address, 1);
1186 }
1187
1188 sub mailmap {
1189     my (@addresses) = @_;
1190
1191     my @mapped_emails = ();
1192     foreach my $line (@addresses) {
1193         push(@mapped_emails, mailmap_email($line));
1194     }
1195     merge_by_realname(@mapped_emails) if ($email_use_mailmap);
1196     return @mapped_emails;
1197 }
1198
1199 sub merge_by_realname {
1200     my %address_map;
1201     my (@emails) = @_;
1202
1203     foreach my $email (@emails) {
1204         my ($name, $address) = parse_email($email);
1205         if (exists $address_map{$name}) {
1206             $address = $address_map{$name};
1207             $email = format_email($name, $address, 1);
1208         } else {
1209             $address_map{$name} = $address;
1210         }
1211     }
1212 }
1213
1214 sub git_execute_cmd {
1215     my ($cmd) = @_;
1216     my @lines = ();
1217
1218     my $output = `$cmd`;
1219     $output =~ s/^\s*//gm;
1220     @lines = split("\n", $output);
1221
1222     return @lines;
1223 }
1224
1225 sub hg_execute_cmd {
1226     my ($cmd) = @_;
1227     my @lines = ();
1228
1229     my $output = `$cmd`;
1230     @lines = split("\n", $output);
1231
1232     return @lines;
1233 }
1234
1235 sub extract_formatted_signatures {
1236     my (@signature_lines) = @_;
1237
1238     my @type = @signature_lines;
1239
1240     s/\s*(.*):.*/$1/ for (@type);
1241
1242     # cut -f2- -d":"
1243     s/\s*.*:\s*(.+)\s*/$1/ for (@signature_lines);
1244
1245 ## Reformat email addresses (with names) to avoid badly written signatures
1246
1247     foreach my $signer (@signature_lines) {
1248         $signer = deduplicate_email($signer);
1249     }
1250
1251     return (\@type, \@signature_lines);
1252 }
1253
1254 sub vcs_find_signers {
1255     my ($cmd) = @_;
1256     my $commits;
1257     my @lines = ();
1258     my @signatures = ();
1259
1260     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1261
1262     my $pattern = $VCS_cmds{"commit_pattern"};
1263
1264     $commits = grep(/$pattern/, @lines);        # of commits
1265
1266     @signatures = grep(/^[ \t]*${signature_pattern}.*\@.*$/, @lines);
1267
1268     return (0, @signatures) if !@signatures;
1269
1270     save_commits_by_author(@lines) if ($interactive);
1271     save_commits_by_signer(@lines) if ($interactive);
1272
1273     my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures);
1274
1275     return ($commits, @$signers_ref);
1276 }
1277
1278 sub vcs_find_author {
1279     my ($cmd) = @_;
1280     my @lines = ();
1281
1282     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1283
1284     return @lines if !@lines;
1285
1286     my @authors = ();
1287     foreach my $line (@lines) {
1288         if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1289             my $author = $1;
1290             my ($name, $address) = parse_email($author);
1291             $author = format_email($name, $address, 1);
1292             push(@authors, $author);
1293         }
1294     }
1295
1296     save_commits_by_author(@lines) if ($interactive);
1297     save_commits_by_signer(@lines) if ($interactive);
1298
1299     return @authors;
1300 }
1301
1302 sub vcs_save_commits {
1303     my ($cmd) = @_;
1304     my @lines = ();
1305     my @commits = ();
1306
1307     @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1308
1309     foreach my $line (@lines) {
1310         if ($line =~ m/$VCS_cmds{"blame_commit_pattern"}/) {
1311             push(@commits, $1);
1312         }
1313     }
1314
1315     return @commits;
1316 }
1317
1318 sub vcs_blame {
1319     my ($file) = @_;
1320     my $cmd;
1321     my @commits = ();
1322
1323     return @commits if (!(-f $file));
1324
1325     if (@range && $VCS_cmds{"blame_range_cmd"} eq "") {
1326         my @all_commits = ();
1327
1328         $cmd = $VCS_cmds{"blame_file_cmd"};
1329         $cmd =~ s/(\$\w+)/$1/eeg;               #interpolate $cmd
1330         @all_commits = vcs_save_commits($cmd);
1331
1332         foreach my $file_range_diff (@range) {
1333             next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1334             my $diff_file = $1;
1335             my $diff_start = $2;
1336             my $diff_length = $3;
1337             next if ("$file" ne "$diff_file");
1338             for (my $i = $diff_start; $i < $diff_start + $diff_length; $i++) {
1339                 push(@commits, $all_commits[$i]);
1340             }
1341         }
1342     } elsif (@range) {
1343         foreach my $file_range_diff (@range) {
1344             next if (!($file_range_diff =~ m/(.+):(.+):(.+)/));
1345             my $diff_file = $1;
1346             my $diff_start = $2;
1347             my $diff_length = $3;
1348             next if ("$file" ne "$diff_file");
1349             $cmd = $VCS_cmds{"blame_range_cmd"};
1350             $cmd =~ s/(\$\w+)/$1/eeg;           #interpolate $cmd
1351             push(@commits, vcs_save_commits($cmd));
1352         }
1353     } else {
1354         $cmd = $VCS_cmds{"blame_file_cmd"};
1355         $cmd =~ s/(\$\w+)/$1/eeg;               #interpolate $cmd
1356         @commits = vcs_save_commits($cmd);
1357     }
1358
1359     foreach my $commit (@commits) {
1360         $commit =~ s/^\^//g;
1361     }
1362
1363     return @commits;
1364 }
1365
1366 my $printed_novcs = 0;
1367 sub vcs_exists {
1368     %VCS_cmds = %VCS_cmds_git;
1369     return 1 if eval $VCS_cmds{"available"};
1370     %VCS_cmds = %VCS_cmds_hg;
1371     return 2 if eval $VCS_cmds{"available"};
1372     %VCS_cmds = ();
1373     if (!$printed_novcs) {
1374         warn("$P: No supported VCS found.  Add --nogit to options?\n");
1375         warn("Using a git repository produces better results.\n");
1376         warn("Try latest git repository using:\n");
1377         warn("git clone git://git.qemu-project.org/qemu.git\n");
1378         $printed_novcs = 1;
1379     }
1380     return 0;
1381 }
1382
1383 sub vcs_is_git {
1384     vcs_exists();
1385     return $vcs_used == 1;
1386 }
1387
1388 sub vcs_is_hg {
1389     return $vcs_used == 2;
1390 }
1391
1392 sub interactive_get_maintainers {
1393     my ($list_ref) = @_;
1394     my @list = @$list_ref;
1395
1396     vcs_exists();
1397
1398     my %selected;
1399     my %authored;
1400     my %signed;
1401     my $count = 0;
1402     my $maintained = 0;
1403     foreach my $entry (@list) {
1404         $maintained = 1 if ($entry->[1] =~ /^(maintainer|supporter)/i);
1405         $selected{$count} = 1;
1406         $authored{$count} = 0;
1407         $signed{$count} = 0;
1408         $count++;
1409     }
1410
1411     #menu loop
1412     my $done = 0;
1413     my $print_options = 0;
1414     my $redraw = 1;
1415     while (!$done) {
1416         $count = 0;
1417         if ($redraw) {
1418             printf STDERR "\n%1s %2s %-65s",
1419                           "*", "#", "email/list and role:stats";
1420             if ($email_git ||
1421                 ($email_git_fallback && !$maintained) ||
1422                 $email_git_blame) {
1423                 print STDERR "auth sign";
1424             }
1425             print STDERR "\n";
1426             foreach my $entry (@list) {
1427                 my $email = $entry->[0];
1428                 my $role = $entry->[1];
1429                 my $sel = "";
1430                 $sel = "*" if ($selected{$count});
1431                 my $commit_author = $commit_author_hash{$email};
1432                 my $commit_signer = $commit_signer_hash{$email};
1433                 my $authored = 0;
1434                 my $signed = 0;
1435                 $authored++ for (@{$commit_author});
1436                 $signed++ for (@{$commit_signer});
1437                 printf STDERR "%1s %2d %-65s", $sel, $count + 1, $email;
1438                 printf STDERR "%4d %4d", $authored, $signed
1439                     if ($authored > 0 || $signed > 0);
1440                 printf STDERR "\n     %s\n", $role;
1441                 if ($authored{$count}) {
1442                     my $commit_author = $commit_author_hash{$email};
1443                     foreach my $ref (@{$commit_author}) {
1444                         print STDERR "     Author: @{$ref}[1]\n";
1445                     }
1446                 }
1447                 if ($signed{$count}) {
1448                     my $commit_signer = $commit_signer_hash{$email};
1449                     foreach my $ref (@{$commit_signer}) {
1450                         print STDERR "     @{$ref}[2]: @{$ref}[1]\n";
1451                     }
1452                 }
1453
1454                 $count++;
1455             }
1456         }
1457         my $date_ref = \$email_git_since;
1458         $date_ref = \$email_hg_since if (vcs_is_hg());
1459         if ($print_options) {
1460             $print_options = 0;
1461             if (vcs_exists()) {
1462                 print STDERR <<EOT
1463
1464 Version Control options:
1465 g  use git history      [$email_git]
1466 gf use git-fallback     [$email_git_fallback]
1467 b  use git blame        [$email_git_blame]
1468 bs use blame signatures [$email_git_blame_signatures]
1469 c# minimum commits      [$email_git_min_signatures]
1470 %# min percent          [$email_git_min_percent]
1471 d# history to use       [$$date_ref]
1472 x# max maintainers      [$email_git_max_maintainers]
1473 t  all signature types  [$email_git_all_signature_types]
1474 m  use .mailmap         [$email_use_mailmap]
1475 EOT
1476             }
1477             print STDERR <<EOT
1478
1479 Additional options:
1480 0  toggle all
1481 tm toggle maintainers
1482 tg toggle git entries
1483 tl toggle open list entries
1484 ts toggle subscriber list entries
1485 f  emails in file       [$file_emails]
1486 k  keywords in file     [$keywords]
1487 r  remove duplicates    [$email_remove_duplicates]
1488 p# pattern match depth  [$pattern_depth]
1489 EOT
1490         }
1491         print STDERR
1492 "\n#(toggle), A#(author), S#(signed) *(all), ^(none), O(options), Y(approve): ";
1493
1494         my $input = <STDIN>;
1495         chomp($input);
1496
1497         $redraw = 1;
1498         my $rerun = 0;
1499         my @wish = split(/[, ]+/, $input);
1500         foreach my $nr (@wish) {
1501             $nr = lc($nr);
1502             my $sel = substr($nr, 0, 1);
1503             my $str = substr($nr, 1);
1504             my $val = 0;
1505             $val = $1 if $str =~ /^(\d+)$/;
1506
1507             if ($sel eq "y") {
1508                 $interactive = 0;
1509                 $done = 1;
1510                 $output_rolestats = 0;
1511                 $output_roles = 0;
1512                 last;
1513             } elsif ($nr =~ /^\d+$/ && $nr > 0 && $nr <= $count) {
1514                 $selected{$nr - 1} = !$selected{$nr - 1};
1515             } elsif ($sel eq "*" || $sel eq '^') {
1516                 my $toggle = 0;
1517                 $toggle = 1 if ($sel eq '*');
1518                 for (my $i = 0; $i < $count; $i++) {
1519                     $selected{$i} = $toggle;
1520                 }
1521             } elsif ($sel eq "0") {
1522                 for (my $i = 0; $i < $count; $i++) {
1523                     $selected{$i} = !$selected{$i};
1524                 }
1525             } elsif ($sel eq "t") {
1526                 if (lc($str) eq "m") {
1527                     for (my $i = 0; $i < $count; $i++) {
1528                         $selected{$i} = !$selected{$i}
1529                             if ($list[$i]->[1] =~ /^(maintainer|supporter)/i);
1530                     }
1531                 } elsif (lc($str) eq "g") {
1532                     for (my $i = 0; $i < $count; $i++) {
1533                         $selected{$i} = !$selected{$i}
1534                             if ($list[$i]->[1] =~ /^(author|commit|signer)/i);
1535                     }
1536                 } elsif (lc($str) eq "l") {
1537                     for (my $i = 0; $i < $count; $i++) {
1538                         $selected{$i} = !$selected{$i}
1539                             if ($list[$i]->[1] =~ /^(open list)/i);
1540                     }
1541                 } elsif (lc($str) eq "s") {
1542                     for (my $i = 0; $i < $count; $i++) {
1543                         $selected{$i} = !$selected{$i}
1544                             if ($list[$i]->[1] =~ /^(subscriber list)/i);
1545                     }
1546                 }
1547             } elsif ($sel eq "a") {
1548                 if ($val > 0 && $val <= $count) {
1549                     $authored{$val - 1} = !$authored{$val - 1};
1550                 } elsif ($str eq '*' || $str eq '^') {
1551                     my $toggle = 0;
1552                     $toggle = 1 if ($str eq '*');
1553                     for (my $i = 0; $i < $count; $i++) {
1554                         $authored{$i} = $toggle;
1555                     }
1556                 }
1557             } elsif ($sel eq "s") {
1558                 if ($val > 0 && $val <= $count) {
1559                     $signed{$val - 1} = !$signed{$val - 1};
1560                 } elsif ($str eq '*' || $str eq '^') {
1561                     my $toggle = 0;
1562                     $toggle = 1 if ($str eq '*');
1563                     for (my $i = 0; $i < $count; $i++) {
1564                         $signed{$i} = $toggle;
1565                     }
1566                 }
1567             } elsif ($sel eq "o") {
1568                 $print_options = 1;
1569                 $redraw = 1;
1570             } elsif ($sel eq "g") {
1571                 if ($str eq "f") {
1572                     bool_invert(\$email_git_fallback);
1573                 } else {
1574                     bool_invert(\$email_git);
1575                 }
1576                 $rerun = 1;
1577             } elsif ($sel eq "b") {
1578                 if ($str eq "s") {
1579                     bool_invert(\$email_git_blame_signatures);
1580                 } else {
1581                     bool_invert(\$email_git_blame);
1582                 }
1583                 $rerun = 1;
1584             } elsif ($sel eq "c") {
1585                 if ($val > 0) {
1586                     $email_git_min_signatures = $val;
1587                     $rerun = 1;
1588                 }
1589             } elsif ($sel eq "x") {
1590                 if ($val > 0) {
1591                     $email_git_max_maintainers = $val;
1592                     $rerun = 1;
1593                 }
1594             } elsif ($sel eq "%") {
1595                 if ($str ne "" && $val >= 0) {
1596                     $email_git_min_percent = $val;
1597                     $rerun = 1;
1598                 }
1599             } elsif ($sel eq "d") {
1600                 if (vcs_is_git()) {
1601                     $email_git_since = $str;
1602                 } elsif (vcs_is_hg()) {
1603                     $email_hg_since = $str;
1604                 }
1605                 $rerun = 1;
1606             } elsif ($sel eq "t") {
1607                 bool_invert(\$email_git_all_signature_types);
1608                 $rerun = 1;
1609             } elsif ($sel eq "f") {
1610                 bool_invert(\$file_emails);
1611                 $rerun = 1;
1612             } elsif ($sel eq "r") {
1613                 bool_invert(\$email_remove_duplicates);
1614                 $rerun = 1;
1615             } elsif ($sel eq "m") {
1616                 bool_invert(\$email_use_mailmap);
1617                 read_mailmap();
1618                 $rerun = 1;
1619             } elsif ($sel eq "k") {
1620                 bool_invert(\$keywords);
1621                 $rerun = 1;
1622             } elsif ($sel eq "p") {
1623                 if ($str ne "" && $val >= 0) {
1624                     $pattern_depth = $val;
1625                     $rerun = 1;
1626                 }
1627             } elsif ($sel eq "h" || $sel eq "?") {
1628                 print STDERR <<EOT
1629
1630 Interactive mode allows you to select the various maintainers, submitters,
1631 commit signers and mailing lists that could be CC'd on a patch.
1632
1633 Any *'d entry is selected.
1634
1635 If you have git or hg installed, you can choose to summarize the commit
1636 history of files in the patch.  Also, each line of the current file can
1637 be matched to its commit author and that commits signers with blame.
1638
1639 Various knobs exist to control the length of time for active commit
1640 tracking, the maximum number of commit authors and signers to add,
1641 and such.
1642
1643 Enter selections at the prompt until you are satisfied that the selected
1644 maintainers are appropriate.  You may enter multiple selections separated
1645 by either commas or spaces.
1646
1647 EOT
1648             } else {
1649                 print STDERR "invalid option: '$nr'\n";
1650                 $redraw = 0;
1651             }
1652         }
1653         if ($rerun) {
1654             print STDERR "git-blame can be very slow, please have patience..."
1655                 if ($email_git_blame);
1656             goto &get_maintainers;
1657         }
1658     }
1659
1660     #drop not selected entries
1661     $count = 0;
1662     my @new_emailto = ();
1663     foreach my $entry (@list) {
1664         if ($selected{$count}) {
1665             push(@new_emailto, $list[$count]);
1666         }
1667         $count++;
1668     }
1669     return @new_emailto;
1670 }
1671
1672 sub bool_invert {
1673     my ($bool_ref) = @_;
1674
1675     if ($$bool_ref) {
1676         $$bool_ref = 0;
1677     } else {
1678         $$bool_ref = 1;
1679     }
1680 }
1681
1682 sub deduplicate_email {
1683     my ($email) = @_;
1684
1685     my $matched = 0;
1686     my ($name, $address) = parse_email($email);
1687     $email = format_email($name, $address, 1);
1688     $email = mailmap_email($email);
1689
1690     return $email if (!$email_remove_duplicates);
1691
1692     ($name, $address) = parse_email($email);
1693
1694     if ($name ne "" && $deduplicate_name_hash{lc($name)}) {
1695         $name = $deduplicate_name_hash{lc($name)}->[0];
1696         $address = $deduplicate_name_hash{lc($name)}->[1];
1697         $matched = 1;
1698     } elsif ($deduplicate_address_hash{lc($address)}) {
1699         $name = $deduplicate_address_hash{lc($address)}->[0];
1700         $address = $deduplicate_address_hash{lc($address)}->[1];
1701         $matched = 1;
1702     }
1703     if (!$matched) {
1704         $deduplicate_name_hash{lc($name)} = [ $name, $address ];
1705         $deduplicate_address_hash{lc($address)} = [ $name, $address ];
1706     }
1707     $email = format_email($name, $address, 1);
1708     $email = mailmap_email($email);
1709     return $email;
1710 }
1711
1712 sub save_commits_by_author {
1713     my (@lines) = @_;
1714
1715     my @authors = ();
1716     my @commits = ();
1717     my @subjects = ();
1718
1719     foreach my $line (@lines) {
1720         if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1721             my $author = $1;
1722             $author = deduplicate_email($author);
1723             push(@authors, $author);
1724         }
1725         push(@commits, $1) if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1726         push(@subjects, $1) if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1727     }
1728
1729     for (my $i = 0; $i < @authors; $i++) {
1730         my $exists = 0;
1731         foreach my $ref(@{$commit_author_hash{$authors[$i]}}) {
1732             if (@{$ref}[0] eq $commits[$i] &&
1733                 @{$ref}[1] eq $subjects[$i]) {
1734                 $exists = 1;
1735                 last;
1736             }
1737         }
1738         if (!$exists) {
1739             push(@{$commit_author_hash{$authors[$i]}},
1740                  [ ($commits[$i], $subjects[$i]) ]);
1741         }
1742     }
1743 }
1744
1745 sub save_commits_by_signer {
1746     my (@lines) = @_;
1747
1748     my $commit = "";
1749     my $subject = "";
1750
1751     foreach my $line (@lines) {
1752         $commit = $1 if ($line =~ m/$VCS_cmds{"commit_pattern"}/);
1753         $subject = $1 if ($line =~ m/$VCS_cmds{"subject_pattern"}/);
1754         if ($line =~ /^[ \t]*${signature_pattern}.*\@.*$/) {
1755             my @signatures = ($line);
1756             my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures);
1757             my @types = @$types_ref;
1758             my @signers = @$signers_ref;
1759
1760             my $type = $types[0];
1761             my $signer = $signers[0];
1762
1763             $signer = deduplicate_email($signer);
1764
1765             my $exists = 0;
1766             foreach my $ref(@{$commit_signer_hash{$signer}}) {
1767                 if (@{$ref}[0] eq $commit &&
1768                     @{$ref}[1] eq $subject &&
1769                     @{$ref}[2] eq $type) {
1770                     $exists = 1;
1771                     last;
1772                 }
1773             }
1774             if (!$exists) {
1775                 push(@{$commit_signer_hash{$signer}},
1776                      [ ($commit, $subject, $type) ]);
1777             }
1778         }
1779     }
1780 }
1781
1782 sub vcs_assign {
1783     my ($role, $divisor, @lines) = @_;
1784
1785     my %hash;
1786     my $count = 0;
1787
1788     return if (@lines <= 0);
1789
1790     if ($divisor <= 0) {
1791         warn("Bad divisor in " . (caller(0))[3] . ": $divisor\n");
1792         $divisor = 1;
1793     }
1794
1795     @lines = mailmap(@lines);
1796
1797     return if (@lines <= 0);
1798
1799     @lines = sort(@lines);
1800
1801     # uniq -c
1802     $hash{$_}++ for @lines;
1803
1804     # sort -rn
1805     foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) {
1806         my $sign_offs = $hash{$line};
1807         my $percent = $sign_offs * 100 / $divisor;
1808
1809         $percent = 100 if ($percent > 100);
1810         $count++;
1811         last if ($sign_offs < $email_git_min_signatures ||
1812                  $count > $email_git_max_maintainers ||
1813                  $percent < $email_git_min_percent);
1814         push_email_address($line, '');
1815         if ($output_rolestats) {
1816             my $fmt_percent = sprintf("%.0f", $percent);
1817             add_role($line, "$role:$sign_offs/$divisor=$fmt_percent%");
1818         } else {
1819             add_role($line, $role);
1820         }
1821     }
1822 }
1823
1824 sub vcs_file_signoffs {
1825     my ($file) = @_;
1826
1827     my @signers = ();
1828     my $commits;
1829
1830     $vcs_used = vcs_exists();
1831     return if (!$vcs_used);
1832
1833     my $cmd = $VCS_cmds{"find_signers_cmd"};
1834     $cmd =~ s/(\$\w+)/$1/eeg;           # interpolate $cmd
1835
1836     ($commits, @signers) = vcs_find_signers($cmd);
1837
1838     foreach my $signer (@signers) {
1839         $signer = deduplicate_email($signer);
1840     }
1841
1842     vcs_assign("commit_signer", $commits, @signers);
1843 }
1844
1845 sub vcs_file_blame {
1846     my ($file) = @_;
1847
1848     my @signers = ();
1849     my @all_commits = ();
1850     my @commits = ();
1851     my $total_commits;
1852     my $total_lines;
1853
1854     $vcs_used = vcs_exists();
1855     return if (!$vcs_used);
1856
1857     @all_commits = vcs_blame($file);
1858     @commits = uniq(@all_commits);
1859     $total_commits = @commits;
1860     $total_lines = @all_commits;
1861
1862     if ($email_git_blame_signatures) {
1863         if (vcs_is_hg()) {
1864             my $commit_count;
1865             my @commit_signers = ();
1866             my $commit = join(" -r ", @commits);
1867             my $cmd;
1868
1869             $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1870             $cmd =~ s/(\$\w+)/$1/eeg;   #substitute variables in $cmd
1871
1872             ($commit_count, @commit_signers) = vcs_find_signers($cmd);
1873
1874             push(@signers, @commit_signers);
1875         } else {
1876             foreach my $commit (@commits) {
1877                 my $commit_count;
1878                 my @commit_signers = ();
1879                 my $cmd;
1880
1881                 $cmd = $VCS_cmds{"find_commit_signers_cmd"};
1882                 $cmd =~ s/(\$\w+)/$1/eeg;       #substitute variables in $cmd
1883
1884                 ($commit_count, @commit_signers) = vcs_find_signers($cmd);
1885
1886                 push(@signers, @commit_signers);
1887             }
1888         }
1889     }
1890
1891     if ($from_filename) {
1892         if ($output_rolestats) {
1893             my @blame_signers;
1894             if (vcs_is_hg()) {{         # Double brace for last exit
1895                 my $commit_count;
1896                 my @commit_signers = ();
1897                 @commits = uniq(@commits);
1898                 @commits = sort(@commits);
1899                 my $commit = join(" -r ", @commits);
1900                 my $cmd;
1901
1902                 $cmd = $VCS_cmds{"find_commit_author_cmd"};
1903                 $cmd =~ s/(\$\w+)/$1/eeg;       #substitute variables in $cmd
1904
1905                 my @lines = ();
1906
1907                 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd);
1908
1909                 last if !@lines;
1910
1911                 my @authors = ();
1912                 foreach my $line (@lines) {
1913                     if ($line =~ m/$VCS_cmds{"author_pattern"}/) {
1914                         my $author = $1;
1915                         $author = deduplicate_email($author);
1916                         push(@authors, $author);
1917                     }
1918                 }
1919
1920                 save_commits_by_author(@lines) if ($interactive);
1921                 save_commits_by_signer(@lines) if ($interactive);
1922
1923                 push(@signers, @authors);
1924             }}
1925             else {
1926                 foreach my $commit (@commits) {
1927                     my $i;
1928                     my $cmd = $VCS_cmds{"find_commit_author_cmd"};
1929                     $cmd =~ s/(\$\w+)/$1/eeg;   #interpolate $cmd
1930                     my @author = vcs_find_author($cmd);
1931                     next if !@author;
1932
1933                     my $formatted_author = deduplicate_email($author[0]);
1934
1935                     my $count = grep(/$commit/, @all_commits);
1936                     for ($i = 0; $i < $count ; $i++) {
1937                         push(@blame_signers, $formatted_author);
1938                     }
1939                 }
1940             }
1941             if (@blame_signers) {
1942                 vcs_assign("authored lines", $total_lines, @blame_signers);
1943             }
1944         }
1945         foreach my $signer (@signers) {
1946             $signer = deduplicate_email($signer);
1947         }
1948         vcs_assign("commits", $total_commits, @signers);
1949     } else {
1950         foreach my $signer (@signers) {
1951             $signer = deduplicate_email($signer);
1952         }
1953         vcs_assign("modified commits", $total_commits, @signers);
1954     }
1955 }
1956
1957 sub uniq {
1958     my (@parms) = @_;
1959
1960     my %saw;
1961     @parms = grep(!$saw{$_}++, @parms);
1962     return @parms;
1963 }
1964
1965 sub sort_and_uniq {
1966     my (@parms) = @_;
1967
1968     my %saw;
1969     @parms = sort @parms;
1970     @parms = grep(!$saw{$_}++, @parms);
1971     return @parms;
1972 }
1973
1974 sub clean_file_emails {
1975     my (@file_emails) = @_;
1976     my @fmt_emails = ();
1977
1978     foreach my $email (@file_emails) {
1979         $email =~ s/[\(\<\{]{0,1}([A-Za-z0-9_\.\+-]+\@[A-Za-z0-9\.-]+)[\)\>\}]{0,1}/\<$1\>/g;
1980         my ($name, $address) = parse_email($email);
1981         if ($name eq '"[,\.]"') {
1982             $name = "";
1983         }
1984
1985         my @nw = split(/[^A-Za-zÀ-ÿ\'\,\.\+-]/, $name);
1986         if (@nw > 2) {
1987             my $first = $nw[@nw - 3];
1988             my $middle = $nw[@nw - 2];
1989             my $last = $nw[@nw - 1];
1990
1991             if (((length($first) == 1 && $first =~ m/[A-Za-z]/) ||
1992                  (length($first) == 2 && substr($first, -1) eq ".")) ||
1993                 (length($middle) == 1 ||
1994                  (length($middle) == 2 && substr($middle, -1) eq "."))) {
1995                 $name = "$first $middle $last";
1996             } else {
1997                 $name = "$middle $last";
1998             }
1999         }
2000
2001         if (substr($name, -1) =~ /[,\.]/) {
2002             $name = substr($name, 0, length($name) - 1);
2003         } elsif (substr($name, -2) =~ /[,\.]"/) {
2004             $name = substr($name, 0, length($name) - 2) . '"';
2005         }
2006
2007         if (substr($name, 0, 1) =~ /[,\.]/) {
2008             $name = substr($name, 1, length($name) - 1);
2009         } elsif (substr($name, 0, 2) =~ /"[,\.]/) {
2010             $name = '"' . substr($name, 2, length($name) - 2);
2011         }
2012
2013         my $fmt_email = format_email($name, $address, $email_usename);
2014         push(@fmt_emails, $fmt_email);
2015     }
2016     return @fmt_emails;
2017 }
2018
2019 sub merge_email {
2020     my @lines;
2021     my %saw;
2022
2023     for (@_) {
2024         my ($address, $role) = @$_;
2025         if (!$saw{$address}) {
2026             if ($output_roles) {
2027                 push(@lines, "$address ($role)");
2028             } else {
2029                 push(@lines, $address);
2030             }
2031             $saw{$address} = 1;
2032         }
2033     }
2034
2035     return @lines;
2036 }
2037
2038 sub output {
2039     my (@parms) = @_;
2040
2041     if ($output_multiline) {
2042         foreach my $line (@parms) {
2043             print("${line}\n");
2044         }
2045     } else {
2046         print(join($output_separator, @parms));
2047         print("\n");
2048     }
2049 }
2050
2051 my $rfc822re;
2052
2053 sub make_rfc822re {
2054 #   Basic lexical tokens are specials, domain_literal, quoted_string, atom, and
2055 #   comment.  We must allow for rfc822_lwsp (or comments) after each of these.
2056 #   This regexp will only work on addresses which have had comments stripped
2057 #   and replaced with rfc822_lwsp.
2058
2059     my $specials = '()<>@,;:\\\\".\\[\\]';
2060     my $controls = '\\000-\\037\\177';
2061
2062     my $dtext = "[^\\[\\]\\r\\\\]";
2063     my $domain_literal = "\\[(?:$dtext|\\\\.)*\\]$rfc822_lwsp*";
2064
2065     my $quoted_string = "\"(?:[^\\\"\\r\\\\]|\\\\.|$rfc822_lwsp)*\"$rfc822_lwsp*";
2066
2067 #   Use zero-width assertion to spot the limit of an atom.  A simple
2068 #   $rfc822_lwsp* causes the regexp engine to hang occasionally.
2069     my $atom = "[^$specials $controls]+(?:$rfc822_lwsp+|\\Z|(?=[\\[\"$specials]))";
2070     my $word = "(?:$atom|$quoted_string)";
2071     my $localpart = "$word(?:\\.$rfc822_lwsp*$word)*";
2072
2073     my $sub_domain = "(?:$atom|$domain_literal)";
2074     my $domain = "$sub_domain(?:\\.$rfc822_lwsp*$sub_domain)*";
2075
2076     my $addr_spec = "$localpart\@$rfc822_lwsp*$domain";
2077
2078     my $phrase = "$word*";
2079     my $route = "(?:\@$domain(?:,\@$rfc822_lwsp*$domain)*:$rfc822_lwsp*)";
2080     my $route_addr = "\\<$rfc822_lwsp*$route?$addr_spec\\>$rfc822_lwsp*";
2081     my $mailbox = "(?:$addr_spec|$phrase$route_addr)";
2082
2083     my $group = "$phrase:$rfc822_lwsp*(?:$mailbox(?:,\\s*$mailbox)*)?;\\s*";
2084     my $address = "(?:$mailbox|$group)";
2085
2086     return "$rfc822_lwsp*$address";
2087 }
2088
2089 sub rfc822_strip_comments {
2090     my $s = shift;
2091 #   Recursively remove comments, and replace with a single space.  The simpler
2092 #   regexps in the Email Addressing FAQ are imperfect - they will miss escaped
2093 #   chars in atoms, for example.
2094
2095     while ($s =~ s/^((?:[^"\\]|\\.)*
2096                     (?:"(?:[^"\\]|\\.)*"(?:[^"\\]|\\.)*)*)
2097                     \((?:[^()\\]|\\.)*\)/$1 /osx) {}
2098     return $s;
2099 }
2100
2101 #   valid: returns true if the parameter is an RFC822 valid address
2102 #
2103 sub rfc822_valid {
2104     my $s = rfc822_strip_comments(shift);
2105
2106     if (!$rfc822re) {
2107         $rfc822re = make_rfc822re();
2108     }
2109
2110     return $s =~ m/^$rfc822re$/so && $s =~ m/^$rfc822_char*$/;
2111 }
2112
2113 #   validlist: In scalar context, returns true if the parameter is an RFC822
2114 #              valid list of addresses.
2115 #
2116 #              In list context, returns an empty list on failure (an invalid
2117 #              address was found); otherwise a list whose first element is the
2118 #              number of addresses found and whose remaining elements are the
2119 #              addresses.  This is needed to disambiguate failure (invalid)
2120 #              from success with no addresses found, because an empty string is
2121 #              a valid list.
2122
2123 sub rfc822_validlist {
2124     my $s = rfc822_strip_comments(shift);
2125
2126     if (!$rfc822re) {
2127         $rfc822re = make_rfc822re();
2128     }
2129     # * null list items are valid according to the RFC
2130     # * the '1' business is to aid in distinguishing failure from no results
2131
2132     my @r;
2133     if ($s =~ m/^(?:$rfc822re)?(?:,(?:$rfc822re)?)*$/so &&
2134         $s =~ m/^$rfc822_char*$/) {
2135         while ($s =~ m/(?:^|,$rfc822_lwsp*)($rfc822re)/gos) {
2136             push(@r, $1);
2137         }
2138         return wantarray ? (scalar(@r), @r) : 1;
2139     }
2140     return wantarray ? () : 0;
2141 }