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