scripts/get_maintainer.pl

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