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