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