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