scripts/get_maintainer.pl

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