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