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