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