1#!/usr/bin/perl -w 2# (c) 2007, Joe Perches <joe@perches.com> 3# created from checkpatch.pl 4# 5# Print selected MAINTAINERS information for 6# the files modified in a patch or for a file 7# 8# usage: perl scripts/get_maintainer.pl [OPTIONS] <patch> 9# perl scripts/get_maintainer.pl [OPTIONS] -f <file> 10# 11# Licensed under the terms of the GNU GPL License version 2 12 13use strict; 14 15my $P = $0; 16my $V = '0.26'; 17 18use Getopt::Long qw(:config no_auto_abbrev); 19 20my $lk_path = "./"; 21my $email = 1; 22my $email_usename = 1; 23my $email_maintainer = 1; 24my $email_reviewer = 1; 25my $email_list = 1; 26my $email_subscriber_list = 0; 27my $email_git_penguin_chiefs = 0; 28my $email_git = 0; 29my $email_git_all_signature_types = 0; 30my $email_git_blame = 0; 31my $email_git_blame_signatures = 1; 32my $email_git_fallback = 1; 33my $email_git_min_signatures = 1; 34my $email_git_max_maintainers = 5; 35my $email_git_min_percent = 5; 36my $email_git_since = "1-year-ago"; 37my $email_hg_since = "-365"; 38my $interactive = 0; 39my $email_remove_duplicates = 1; 40my $email_use_mailmap = 1; 41my $output_multiline = 1; 42my $output_separator = ", "; 43my $output_roles = 0; 44my $output_rolestats = 1; 45my $output_section_maxlen = 50; 46my $scm = 0; 47my $web = 0; 48my $subsystem = 0; 49my $status = 0; 50my $keywords = 1; 51my $sections = 0; 52my $file_emails = 0; 53my $from_filename = 0; 54my $pattern_depth = 0; 55my $version = 0; 56my $help = 0; 57 58my $vcs_used = 0; 59 60my $exit = 0; 61 62my %commit_author_hash; 63my %commit_signer_hash; 64 65my @penguin_chief = (); 66push(@penguin_chief, "Linus Torvalds:torvalds\@linux-foundation.org"); 67#Andrew wants in on most everything - 2009/01/14 68#push(@penguin_chief, "Andrew Morton:akpm\@linux-foundation.org"); 69 70my @penguin_chief_names = (); 71foreach my $chief (@penguin_chief) { 72 if ($chief =~ m/^(.*):(.*)/) { 73 my $chief_name = $1; 74 my $chief_addr = $2; 75 push(@penguin_chief_names, $chief_name); 76 } 77} 78my $penguin_chiefs = "\(" . join("|", @penguin_chief_names) . "\)"; 79 80# Signature types of people who are either 81# a) responsible for the code in question, or 82# b) familiar enough with it to give relevant feedback 83my @signature_tags = (); 84push(@signature_tags, "Signed-off-by:"); 85push(@signature_tags, "Reviewed-by:"); 86push(@signature_tags, "Acked-by:"); 87 88my $signature_pattern = "\(" . join("|", @signature_tags) . "\)"; 89 90# rfc822 email address - preloaded methods go here. 91my $rfc822_lwsp = "(?:(?:\\r\\n)?[ \\t])"; 92my $rfc822_char = '[\\000-\\377]'; 93 94# VCS command support: class-like functions and strings 95 96my %VCS_cmds; 97 98my %VCS_cmds_git = ( 99 "execute_cmd" => \&git_execute_cmd, 100 "available" => '(which("git") ne "") && (-e ".git")', 101 "find_signers_cmd" => 102 "git log --no-color --follow --since=\$email_git_since " . 103 '--numstat --no-merges ' . 104 '--format="GitCommit: %H%n' . 105 'GitAuthor: %an <%ae>%n' . 106 'GitDate: %aD%n' . 107 'GitSubject: %s%n' . 108 '%b%n"' . 109 " -- \$file", 110 "find_commit_signers_cmd" => 111 "git log --no-color " . 112 '--numstat ' . 113 '--format="GitCommit: %H%n' . 114 'GitAuthor: %an <%ae>%n' . 115 'GitDate: %aD%n' . 116 'GitSubject: %s%n' . 117 '%b%n"' . 118 " -1 \$commit", 119 "find_commit_author_cmd" => 120 "git log --no-color " . 121 '--numstat ' . 122 '--format="GitCommit: %H%n' . 123 'GitAuthor: %an <%ae>%n' . 124 'GitDate: %aD%n' . 125 'GitSubject: %s%n"' . 126 " -1 \$commit", 127 "blame_range_cmd" => "git blame -l -L \$diff_start,+\$diff_length \$file", 128 "blame_file_cmd" => "git blame -l \$file", 129 "commit_pattern" => "^GitCommit: ([0-9a-f]{40,40})", 130 "blame_commit_pattern" => "^([0-9a-f]+) ", 131 "author_pattern" => "^GitAuthor: (.*)", 132 "subject_pattern" => "^GitSubject: (.*)", 133 "stat_pattern" => "^(\\d+)\\t(\\d+)\\t\$file\$", 134); 135 136my %VCS_cmds_hg = ( 137 "execute_cmd" => \&hg_execute_cmd, 138 "available" => '(which("hg") ne "") && (-d ".hg")', 139 "find_signers_cmd" => 140 "hg log --date=\$email_hg_since " . 141 "--template='HgCommit: {node}\\n" . 142 "HgAuthor: {author}\\n" . 143 "HgSubject: {desc}\\n'" . 144 " -- \$file", 145 "find_commit_signers_cmd" => 146 "hg log " . 147 "--template='HgSubject: {desc}\\n'" . 148 " -r \$commit", 149 "find_commit_author_cmd" => 150 "hg log " . 151 "--template='HgCommit: {node}\\n" . 152 "HgAuthor: {author}\\n" . 153 "HgSubject: {desc|firstline}\\n'" . 154 " -r \$commit", 155 "blame_range_cmd" => "", # not supported 156 "blame_file_cmd" => "hg blame -n \$file", 157 "commit_pattern" => "^HgCommit: ([0-9a-f]{40,40})", 158 "blame_commit_pattern" => "^([ 0-9a-f]+):", 159 "author_pattern" => "^HgAuthor: (.*)", 160 "subject_pattern" => "^HgSubject: (.*)", 161 "stat_pattern" => "^(\\d+)\t(\\d+)\t\$file\$", 162); 163 164my $conf = which_conf(".get_maintainer.conf"); 165if (-f $conf) { 166 my @conf_args; 167 open(my $conffile, '<', "$conf") 168 or warn "$P: Can't find a readable .get_maintainer.conf file $!\n"; 169 170 while (<$conffile>) { 171 my $line = $_; 172 173 $line =~ s/\s*\n?$//g; 174 $line =~ s/^\s*//g; 175 $line =~ s/\s+/ /g; 176 177 next if ($line =~ m/^\s*#/); 178 next if ($line =~ m/^\s*$/); 179 180 my @words = split(" ", $line); 181 foreach my $word (@words) { 182 last if ($word =~ m/^#/); 183 push (@conf_args, $word); 184 } 185 } 186 close($conffile); 187 unshift(@ARGV, @conf_args) if @conf_args; 188} 189 190my @ignore_emails = (); 191my $ignore_file = which_conf(".get_maintainer.ignore"); 192if (-f $ignore_file) { 193 open(my $ignore, '<', "$ignore_file") 194 or warn "$P: Can't find a readable .get_maintainer.ignore file $!\n"; 195 while (<$ignore>) { 196 my $line = $_; 197 198 $line =~ s/\s*\n?$//; 199 $line =~ s/^\s*//; 200 $line =~ s/\s+$//; 201 $line =~ s/#.*$//; 202 203 next if ($line =~ m/^\s*$/); 204 if (rfc822_valid($line)) { 205 push(@ignore_emails, $line); 206 } 207 } 208 close($ignore); 209} 210 211if (!GetOptions( 212 'email!' => \$email, 213 'git!' => \$email_git, 214 'git-all-signature-types!' => \$email_git_all_signature_types, 215 'git-blame!' => \$email_git_blame, 216 'git-blame-signatures!' => \$email_git_blame_signatures, 217 'git-fallback!' => \$email_git_fallback, 218 'git-chief-penguins!' => \$email_git_penguin_chiefs, 219 'git-min-signatures=i' => \$email_git_min_signatures, 220 'git-max-maintainers=i' => \$email_git_max_maintainers, 221 'git-min-percent=i' => \$email_git_min_percent, 222 'git-since=s' => \$email_git_since, 223 'hg-since=s' => \$email_hg_since, 224 'i|interactive!' => \$interactive, 225 'remove-duplicates!' => \$email_remove_duplicates, 226 'mailmap!' => \$email_use_mailmap, 227 'm!' => \$email_maintainer, 228 'r!' => \$email_reviewer, 229 'n!' => \$email_usename, 230 'l!' => \$email_list, 231 's!' => \$email_subscriber_list, 232 'multiline!' => \$output_multiline, 233 'roles!' => \$output_roles, 234 'rolestats!' => \$output_rolestats, 235 'separator=s' => \$output_separator, 236 'subsystem!' => \$subsystem, 237 'status!' => \$status, 238 'scm!' => \$scm, 239 'web!' => \$web, 240 'pattern-depth=i' => \$pattern_depth, 241 'k|keywords!' => \$keywords, 242 'sections!' => \$sections, 243 'fe|file-emails!' => \$file_emails, 244 'f|file' => \$from_filename, 245 'v|version' => \$version, 246 'h|help|usage' => \$help, 247 )) { 248 die "$P: invalid argument - use --help if necessary\n"; 249} 250 251if ($help != 0) { 252 usage(); 253 exit 0; 254} 255 256if ($version != 0) { 257 print("${P} ${V}\n"); 258 exit 0; 259} 260 261if (-t STDIN && !@ARGV) { 262 # We're talking to a terminal, but have no command line arguments. 263 die "$P: missing patchfile or -f file - use --help if necessary\n"; 264} 265 266$output_multiline = 0 if ($output_separator ne ", "); 267$output_rolestats = 1 if ($interactive); 268$output_roles = 1 if ($output_rolestats); 269 270if ($sections) { 271 $email = 0; 272 $email_list = 0; 273 $scm = 0; 274 $status = 0; 275 $subsystem = 0; 276 $web = 0; 277 $keywords = 0; 278 $interactive = 0; 279} else { 280 my $selections = $email + $scm + $status + $subsystem + $web; 281 if ($selections == 0) { 282 die "$P: Missing required option: email, scm, status, subsystem or web\n"; 283 } 284} 285 286if ($email && 287 ($email_maintainer + $email_reviewer + 288 $email_list + $email_subscriber_list + 289 $email_git + $email_git_penguin_chiefs + $email_git_blame) == 0) { 290 die "$P: Please select at least 1 email option\n"; 291} 292 293if (!top_of_kernel_tree($lk_path)) { 294 die "$P: The current directory does not appear to be " 295 . "a linux kernel source tree.\n"; 296} 297 298## Read MAINTAINERS for type/value pairs 299 300my @typevalue = (); 301my %keyword_hash; 302 303open (my $maint, '<', "${lk_path}MAINTAINERS") 304 or die "$P: Can't open MAINTAINERS: $!\n"; 305while (<$maint>) { 306 my $line = $_; 307 308 if ($line =~ m/^([A-Z]):\s*(.*)/) { 309 my $type = $1; 310 my $value = $2; 311 312 ##Filename pattern matching 313 if ($type eq "F" || $type eq "X") { 314 $value =~ s@\.@\\\.@g; ##Convert . to \. 315 $value =~ s/\*/\.\*/g; ##Convert * to .* 316 $value =~ s/\?/\./g; ##Convert ? to . 317 ##if pattern is a directory and it lacks a trailing slash, add one 318 if ((-d $value)) { 319 $value =~ s@([^/])$@$1/@; 320 } 321 } elsif ($type eq "K") { 322 $keyword_hash{@typevalue} = $value; 323 } 324 push(@typevalue, "$type:$value"); 325 } elsif (!/^(\s)*$/) { 326 $line =~ s/\n$//g; 327 push(@typevalue, $line); 328 } 329} 330close($maint); 331 332 333# 334# Read mail address map 335# 336 337my $mailmap; 338 339read_mailmap(); 340 341sub read_mailmap { 342 $mailmap = { 343 names => {}, 344 addresses => {} 345 }; 346 347 return if (!$email_use_mailmap || !(-f "${lk_path}.mailmap")); 348 349 open(my $mailmap_file, '<', "${lk_path}.mailmap") 350 or warn "$P: Can't open .mailmap: $!\n"; 351 352 while (<$mailmap_file>) { 353 s/#.*$//; #strip comments 354 s/^\s+|\s+$//g; #trim 355 356 next if (/^\s*$/); #skip empty lines 357 #entries have one of the following formats: 358 # name1 <mail1> 359 # <mail1> <mail2> 360 # name1 <mail1> <mail2> 361 # name1 <mail1> name2 <mail2> 362 # (see man git-shortlog) 363 364 if (/^([^<]+)<([^>]+)>$/) { 365 my $real_name = $1; 366 my $address = $2; 367 368 $real_name =~ s/\s+$//; 369 ($real_name, $address) = parse_email("$real_name <$address>"); 370 $mailmap->{names}->{$address} = $real_name; 371 372 } elsif (/^<([^>]+)>\s*<([^>]+)>$/) { 373 my $real_address = $1; 374 my $wrong_address = $2; 375 376 $mailmap->{addresses}->{$wrong_address} = $real_address; 377 378 } elsif (/^(.+)<([^>]+)>\s*<([^>]+)>$/) { 379 my $real_name = $1; 380 my $real_address = $2; 381 my $wrong_address = $3; 382 383 $real_name =~ s/\s+$//; 384 ($real_name, $real_address) = 385 parse_email("$real_name <$real_address>"); 386 $mailmap->{names}->{$wrong_address} = $real_name; 387 $mailmap->{addresses}->{$wrong_address} = $real_address; 388 389 } elsif (/^(.+)<([^>]+)>\s*(.+)\s*<([^>]+)>$/) { 390 my $real_name = $1; 391 my $real_address = $2; 392 my $wrong_name = $3; 393 my $wrong_address = $4; 394 395 $real_name =~ s/\s+$//; 396 ($real_name, $real_address) = 397 parse_email("$real_name <$real_address>"); 398 399 $wrong_name =~ s/\s+$//; 400 ($wrong_name, $wrong_address) = 401 parse_email("$wrong_name <$wrong_address>"); 402 403 my $wrong_email = format_email($wrong_name, $wrong_address, 1); 404 $mailmap->{names}->{$wrong_email} = $real_name; 405 $mailmap->{addresses}->{$wrong_email} = $real_address; 406 } 407 } 408 close($mailmap_file); 409} 410 411## use the filenames on the command line or find the filenames in the patchfiles 412 413my @files = (); 414my @range = (); 415my @keyword_tvi = (); 416my @file_emails = (); 417 418if (!@ARGV) { 419 push(@ARGV, "&STDIN"); 420} 421 422foreach my $file (@ARGV) { 423 if ($file ne "&STDIN") { 424 ##if $file is a directory and it lacks a trailing slash, add one 425 if ((-d $file)) { 426 $file =~ s@([^/])$@$1/@; 427 } elsif (!(-f $file)) { 428 die "$P: file '${file}' not found\n"; 429 } 430 } 431 if ($from_filename) { 432 push(@files, $file); 433 if ($file ne "MAINTAINERS" && -f $file && ($keywords || $file_emails)) { 434 open(my $f, '<', $file) 435 or die "$P: Can't open $file: $!\n"; 436 my $text = do { local($/) ; <$f> }; 437 close($f); 438 if ($keywords) { 439 foreach my $line (keys %keyword_hash) { 440 if ($text =~ m/$keyword_hash{$line}/x) { 441 push(@keyword_tvi, $line); 442 } 443 } 444 } 445 if ($file_emails) { 446 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; 447 push(@file_emails, clean_file_emails(@poss_addr)); 448 } 449 } 450 } else { 451 my $file_cnt = @files; 452 my $lastfile; 453 454 open(my $patch, "< $file") 455 or die "$P: Can't open $file: $!\n"; 456 457 # We can check arbitrary information before the patch 458 # like the commit message, mail headers, etc... 459 # This allows us to match arbitrary keywords against any part 460 # of a git format-patch generated file (subject tags, etc...) 461 462 my $patch_prefix = ""; #Parsing the intro 463 464 while (<$patch>) { 465 my $patch_line = $_; 466 if (m/^\+\+\+\s+(\S+)/ or m/^---\s+(\S+)/) { 467 my $filename = $1; 468 $filename =~ s@^[^/]*/@@; 469 $filename =~ s@\n@@; 470 $lastfile = $filename; 471 push(@files, $filename); 472 $patch_prefix = "^[+-].*"; #Now parsing the actual patch 473 } elsif (m/^\@\@ -(\d+),(\d+)/) { 474 if ($email_git_blame) { 475 push(@range, "$lastfile:$1:$2"); 476 } 477 } elsif ($keywords) { 478 foreach my $line (keys %keyword_hash) { 479 if ($patch_line =~ m/${patch_prefix}$keyword_hash{$line}/x) { 480 push(@keyword_tvi, $line); 481 } 482 } 483 } 484 } 485 close($patch); 486 487 if ($file_cnt == @files) { 488 warn "$P: file '${file}' doesn't appear to be a patch. " 489 . "Add -f to options?\n"; 490 } 491 @files = sort_and_uniq(@files); 492 } 493} 494 495@file_emails = uniq(@file_emails); 496 497my %email_hash_name; 498my %email_hash_address; 499my @email_to = (); 500my %hash_list_to; 501my @list_to = (); 502my @scm = (); 503my @web = (); 504my @subsystem = (); 505my @status = (); 506my %deduplicate_name_hash = (); 507my %deduplicate_address_hash = (); 508 509my @maintainers = get_maintainers(); 510 511if (@maintainers) { 512 @maintainers = merge_email(@maintainers); 513 output(@maintainers); 514} 515 516if ($scm) { 517 @scm = uniq(@scm); 518 output(@scm); 519} 520 521if ($status) { 522 @status = uniq(@status); 523 output(@status); 524} 525 526if ($subsystem) { 527 @subsystem = uniq(@subsystem); 528 output(@subsystem); 529} 530 531if ($web) { 532 @web = uniq(@web); 533 output(@web); 534} 535 536exit($exit); 537 538sub ignore_email_address { 539 my ($address) = @_; 540 541 foreach my $ignore (@ignore_emails) { 542 return 1 if ($ignore eq $address); 543 } 544 545 return 0; 546} 547 548sub range_is_maintained { 549 my ($start, $end) = @_; 550 551 for (my $i = $start; $i < $end; $i++) { 552 my $line = $typevalue[$i]; 553 if ($line =~ m/^([A-Z]):\s*(.*)/) { 554 my $type = $1; 555 my $value = $2; 556 if ($type eq 'S') { 557 if ($value =~ /(maintain|support)/i) { 558 return 1; 559 } 560 } 561 } 562 } 563 return 0; 564} 565 566sub range_has_maintainer { 567 my ($start, $end) = @_; 568 569 for (my $i = $start; $i < $end; $i++) { 570 my $line = $typevalue[$i]; 571 if ($line =~ m/^([A-Z]):\s*(.*)/) { 572 my $type = $1; 573 my $value = $2; 574 if ($type eq 'M') { 575 return 1; 576 } 577 } 578 } 579 return 0; 580} 581 582sub get_maintainers { 583 %email_hash_name = (); 584 %email_hash_address = (); 585 %commit_author_hash = (); 586 %commit_signer_hash = (); 587 @email_to = (); 588 %hash_list_to = (); 589 @list_to = (); 590 @scm = (); 591 @web = (); 592 @subsystem = (); 593 @status = (); 594 %deduplicate_name_hash = (); 595 %deduplicate_address_hash = (); 596 if ($email_git_all_signature_types) { 597 $signature_pattern = "(.+?)[Bb][Yy]:"; 598 } else { 599 $signature_pattern = "\(" . join("|", @signature_tags) . "\)"; 600 } 601 602 # Find responsible parties 603 604 my %exact_pattern_match_hash = (); 605 606 foreach my $file (@files) { 607 608 my %hash; 609 my $tvi = find_first_section(); 610 while ($tvi < @typevalue) { 611 my $start = find_starting_index($tvi); 612 my $end = find_ending_index($tvi); 613 my $exclude = 0; 614 my $i; 615 616 #Do not match excluded file patterns 617 618 for ($i = $start; $i < $end; $i++) { 619 my $line = $typevalue[$i]; 620 if ($line =~ m/^([A-Z]):\s*(.*)/) { 621 my $type = $1; 622 my $value = $2; 623 if ($type eq 'X') { 624 if (file_match_pattern($file, $value)) { 625 $exclude = 1; 626 last; 627 } 628 } 629 } 630 } 631 632 if (!$exclude) { 633 for ($i = $start; $i < $end; $i++) { 634 my $line = $typevalue[$i]; 635 if ($line =~ m/^([A-Z]):\s*(.*)/) { 636 my $type = $1; 637 my $value = $2; 638 if ($type eq 'F') { 639 if (file_match_pattern($file, $value)) { 640 my $value_pd = ($value =~ tr@/@@); 641 my $file_pd = ($file =~ tr@/@@); 642 $value_pd++ if (substr($value,-1,1) ne "/"); 643 $value_pd = -1 if ($value =~ /^\.\*/); 644 if ($value_pd >= $file_pd && 645 range_is_maintained($start, $end) && 646 range_has_maintainer($start, $end)) { 647 $exact_pattern_match_hash{$file} = 1; 648 } 649 if ($pattern_depth == 0 || 650 (($file_pd - $value_pd) < $pattern_depth)) { 651 $hash{$tvi} = $value_pd; 652 } 653 } 654 } elsif ($type eq 'N') { 655 if ($file =~ m/$value/x) { 656 $hash{$tvi} = 0; 657 } 658 } 659 } 660 } 661 } 662 $tvi = $end + 1; 663 } 664 665 foreach my $line (sort {$hash{$b} <=> $hash{$a}} keys %hash) { 666 add_categories($line); 667 if ($sections) { 668 my $i; 669 my $start = find_starting_index($line); 670 my $end = find_ending_index($line); 671 for ($i = $start; $i < $end; $i++) { 672 my $line = $typevalue[$i]; 673 if ($line =~ /^[FX]:/) { ##Restore file patterns 674 $line =~ s/([^\\])\.([^\*])/$1\?$2/g; 675 $line =~ s/([^\\])\.$/$1\?/g; ##Convert . back to ? 676 $line =~ s/\\\./\./g; ##Convert \. to . 677 $line =~ s/\.\*/\*/g; ##Convert .* to * 678 } 679 $line =~ s/^([A-Z]):/$1:\t/g; 680 print("$line\n"); 681 } 682 print("\n"); 683 } 684 } 685 } 686 687 if ($keywords) { 688 @keyword_tvi = sort_and_uniq(@keyword_tvi); 689 foreach my $line (@keyword_tvi) { 690 add_categories($line); 691 } 692 } 693 694 foreach my $email (@email_to, @list_to) { 695 $email->[0] = deduplicate_email($email->[0]); 696 } 697 698 foreach my $file (@files) { 699 if ($email && 700 ($email_git || ($email_git_fallback && 701 !$exact_pattern_match_hash{$file}))) { 702 vcs_file_signoffs($file); 703 } 704 if ($email && $email_git_blame) { 705 vcs_file_blame($file); 706 } 707 } 708 709 if ($email) { 710 foreach my $chief (@penguin_chief) { 711 if ($chief =~ m/^(.*):(.*)/) { 712 my $email_address; 713 714 $email_address = format_email($1, $2, $email_usename); 715 if ($email_git_penguin_chiefs) { 716 push(@email_to, [$email_address, 'chief penguin']); 717 } else { 718 @email_to = grep($_->[0] !~ /${email_address}/, @email_to); 719 } 720 } 721 } 722 723 foreach my $email (@file_emails) { 724 my ($name, $address) = parse_email($email); 725 726 my $tmp_email = format_email($name, $address, $email_usename); 727 push_email_address($tmp_email, ''); 728 add_role($tmp_email, 'in file'); 729 } 730 } 731 732 my @to = (); 733 if ($email || $email_list) { 734 if ($email) { 735 @to = (@to, @email_to); 736 } 737 if ($email_list) { 738 @to = (@to, @list_to); 739 } 740 } 741 742 if ($interactive) { 743 @to = interactive_get_maintainers(\@to); 744 } 745 746 return @to; 747} 748 749sub file_match_pattern { 750 my ($file, $pattern) = @_; 751 if (substr($pattern, -1) eq "/") { 752 if ($file =~ m@^$pattern@) { 753 return 1; 754 } 755 } else { 756 if ($file =~ m@^$pattern@) { 757 my $s1 = ($file =~ tr@/@@); 758 my $s2 = ($pattern =~ tr@/@@); 759 if ($s1 == $s2) { 760 return 1; 761 } 762 } 763 } 764 return 0; 765} 766 767sub usage { 768 print <<EOT; 769usage: $P [options] patchfile 770 $P [options] -f file|directory 771version: $V 772 773MAINTAINER field selection options: 774 --email => print email address(es) if any 775 --git => include recent git \*-by: signers 776 --git-all-signature-types => include signers regardless of signature type 777 or use only ${signature_pattern} signers (default: $email_git_all_signature_types) 778 --git-fallback => use git when no exact MAINTAINERS pattern (default: $email_git_fallback) 779 --git-chief-penguins => include ${penguin_chiefs} 780 --git-min-signatures => number of signatures required (default: $email_git_min_signatures) 781 --git-max-maintainers => maximum maintainers to add (default: $email_git_max_maintainers) 782 --git-min-percent => minimum percentage of commits required (default: $email_git_min_percent) 783 --git-blame => use git blame to find modified commits for patch or file 784 --git-since => git history to use (default: $email_git_since) 785 --hg-since => hg history to use (default: $email_hg_since) 786 --interactive => display a menu (mostly useful if used with the --git option) 787 --m => include maintainer(s) if any 788 --r => include reviewer(s) if any 789 --n => include name 'Full Name <addr\@domain.tld>' 790 --l => include list(s) if any 791 --s => include subscriber only list(s) if any 792 --remove-duplicates => minimize duplicate email names/addresses 793 --roles => show roles (status:subsystem, git-signer, list, etc...) 794 --rolestats => show roles and statistics (commits/total_commits, %) 795 --file-emails => add email addresses found in -f file (default: 0 (off)) 796 --scm => print SCM tree(s) if any 797 --status => print status if any 798 --subsystem => print subsystem name if any 799 --web => print website(s) if any 800 801Output type options: 802 --separator [, ] => separator for multiple entries on 1 line 803 using --separator also sets --nomultiline if --separator is not [, ] 804 --multiline => print 1 entry per line 805 806Other options: 807 --pattern-depth => Number of pattern directory traversals (default: 0 (all)) 808 --keywords => scan patch for keywords (default: $keywords) 809 --sections => print all of the subsystem sections with pattern matches 810 --mailmap => use .mailmap file (default: $email_use_mailmap) 811 --version => show version 812 --help => show this help information 813 814Default options: 815 [--email --nogit --git-fallback --m --n --l --multiline -pattern-depth=0 816 --remove-duplicates --rolestats] 817 818Notes: 819 Using "-f directory" may give unexpected results: 820 Used with "--git", git signators for _all_ files in and below 821 directory are examined as git recurses directories. 822 Any specified X: (exclude) pattern matches are _not_ ignored. 823 Used with "--nogit", directory is used as a pattern match, 824 no individual file within the directory or subdirectory 825 is matched. 826 Used with "--git-blame", does not iterate all files in directory 827 Using "--git-blame" is slow and may add old committers and authors 828 that are no longer active maintainers to the output. 829 Using "--roles" or "--rolestats" with git send-email --cc-cmd or any 830 other automated tools that expect only ["name"] <email address> 831 may not work because of additional output after <email address>. 832 Using "--rolestats" and "--git-blame" shows the #/total=% commits, 833 not the percentage of the entire file authored. # of commits is 834 not a good measure of amount of code authored. 1 major commit may 835 contain a thousand lines, 5 trivial commits may modify a single line. 836 If git is not installed, but mercurial (hg) is installed and an .hg 837 repository exists, the following options apply to mercurial: 838 --git, 839 --git-min-signatures, --git-max-maintainers, --git-min-percent, and 840 --git-blame 841 Use --hg-since not --git-since to control date selection 842 File ".get_maintainer.conf", if it exists in the linux kernel source root 843 directory, can change whatever get_maintainer defaults are desired. 844 Entries in this file can be any command line argument. 845 This file is prepended to any additional command line arguments. 846 Multiple lines and # comments are allowed. 847EOT 848} 849 850sub top_of_kernel_tree { 851 my ($lk_path) = @_; 852 853 if ($lk_path ne "" && substr($lk_path,length($lk_path)-1,1) ne "/") { 854 $lk_path .= "/"; 855 } 856 if ( (-f "${lk_path}COPYING") 857 && (-f "${lk_path}CREDITS") 858 && (-f "${lk_path}Kbuild") 859 && (-f "${lk_path}MAINTAINERS") 860 && (-f "${lk_path}Makefile") 861 && (-f "${lk_path}README") 862 && (-d "${lk_path}Documentation") 863 && (-d "${lk_path}arch") 864 && (-d "${lk_path}include") 865 && (-d "${lk_path}drivers") 866 && (-d "${lk_path}fs") 867 && (-d "${lk_path}init") 868 && (-d "${lk_path}ipc") 869 && (-d "${lk_path}kernel") 870 && (-d "${lk_path}lib") 871 && (-d "${lk_path}scripts")) { 872 return 1; 873 } 874 return 0; 875} 876 877sub 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 904sub 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 931sub 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 945sub 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 959sub 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 973sub get_maintainer_role { 974 my ($index) = @_; 975 976 my $i; 977 my $start = find_starting_index($index); 978 my $end = find_ending_index($index); 979 980 my $role = "unknown"; 981 my $subsystem = $typevalue[$start]; 982 if ($output_section_maxlen && length($subsystem) > $output_section_maxlen) { 983 $subsystem = substr($subsystem, 0, $output_section_maxlen - 3); 984 $subsystem =~ s/\s*$//; 985 $subsystem = $subsystem . "..."; 986 } 987 988 for ($i = $start + 1; $i < $end; $i++) { 989 my $tv = $typevalue[$i]; 990 if ($tv =~ m/^([A-Z]):\s*(.*)/) { 991 my $ptype = $1; 992 my $pvalue = $2; 993 if ($ptype eq "S") { 994 $role = $pvalue; 995 } 996 } 997 } 998 999 $role = lc($role); 1000 if ($role eq "supported") { 1001 $role = "supporter"; 1002 } elsif ($role eq "maintained") { 1003 $role = "maintainer"; 1004 } elsif ($role eq "odd fixes") { 1005 $role = "odd fixer"; 1006 } elsif ($role eq "orphan") { 1007 $role = "orphan minder"; 1008 } elsif ($role eq "obsolete") { 1009 $role = "obsolete minder"; 1010 } elsif ($role eq "buried alive in reporters") { 1011 $role = "chief penguin"; 1012 } 1013 1014 return $role . ":" . $subsystem; 1015} 1016 1017sub get_list_role { 1018 my ($index) = @_; 1019 1020 my $i; 1021 my $start = find_starting_index($index); 1022 my $end = find_ending_index($index); 1023 1024 my $subsystem = $typevalue[$start]; 1025 if ($output_section_maxlen && length($subsystem) > $output_section_maxlen) { 1026 $subsystem = substr($subsystem, 0, $output_section_maxlen - 3); 1027 $subsystem =~ s/\s*$//; 1028 $subsystem = $subsystem . "..."; 1029 } 1030 1031 if ($subsystem eq "THE REST") { 1032 $subsystem = ""; 1033 } 1034 1035 return $subsystem; 1036} 1037 1038sub 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 push_email_addresses($pvalue, 'reviewer'); 1118 } 1119 } elsif ($ptype eq "T") { 1120 push(@scm, $pvalue); 1121 } elsif ($ptype eq "W") { 1122 push(@web, $pvalue); 1123 } elsif ($ptype eq "S") { 1124 push(@status, $pvalue); 1125 } 1126 } 1127 } 1128} 1129 1130sub email_inuse { 1131 my ($name, $address) = @_; 1132 1133 return 1 if (($name eq "") && ($address eq "")); 1134 return 1 if (($name ne "") && exists($email_hash_name{lc($name)})); 1135 return 1 if (($address ne "") && exists($email_hash_address{lc($address)})); 1136 1137 return 0; 1138} 1139 1140sub push_email_address { 1141 my ($line, $role) = @_; 1142 1143 my ($name, $address) = parse_email($line); 1144 1145 if ($address eq "") { 1146 return 0; 1147 } 1148 1149 if (!$email_remove_duplicates) { 1150 push(@email_to, [format_email($name, $address, $email_usename), $role]); 1151 } elsif (!email_inuse($name, $address)) { 1152 push(@email_to, [format_email($name, $address, $email_usename), $role]); 1153 $email_hash_name{lc($name)}++ if ($name ne ""); 1154 $email_hash_address{lc($address)}++; 1155 } 1156 1157 return 1; 1158} 1159 1160sub push_email_addresses { 1161 my ($address, $role) = @_; 1162 1163 my @address_list = (); 1164 1165 if (rfc822_valid($address)) { 1166 push_email_address($address, $role); 1167 } elsif (@address_list = rfc822_validlist($address)) { 1168 my $array_count = shift(@address_list); 1169 while (my $entry = shift(@address_list)) { 1170 push_email_address($entry, $role); 1171 } 1172 } else { 1173 if (!push_email_address($address, $role)) { 1174 warn("Invalid MAINTAINERS address: '" . $address . "'\n"); 1175 } 1176 } 1177} 1178 1179sub add_role { 1180 my ($line, $role) = @_; 1181 1182 my ($name, $address) = parse_email($line); 1183 my $email = format_email($name, $address, $email_usename); 1184 1185 foreach my $entry (@email_to) { 1186 if ($email_remove_duplicates) { 1187 my ($entry_name, $entry_address) = parse_email($entry->[0]); 1188 if (($name eq $entry_name || $address eq $entry_address) 1189 && ($role eq "" || !($entry->[1] =~ m/$role/)) 1190 ) { 1191 if ($entry->[1] eq "") { 1192 $entry->[1] = "$role"; 1193 } else { 1194 $entry->[1] = "$entry->[1],$role"; 1195 } 1196 } 1197 } else { 1198 if ($email eq $entry->[0] 1199 && ($role eq "" || !($entry->[1] =~ m/$role/)) 1200 ) { 1201 if ($entry->[1] eq "") { 1202 $entry->[1] = "$role"; 1203 } else { 1204 $entry->[1] = "$entry->[1],$role"; 1205 } 1206 } 1207 } 1208 } 1209} 1210 1211sub which { 1212 my ($bin) = @_; 1213 1214 foreach my $path (split(/:/, $ENV{PATH})) { 1215 if (-e "$path/$bin") { 1216 return "$path/$bin"; 1217 } 1218 } 1219 1220 return ""; 1221} 1222 1223sub which_conf { 1224 my ($conf) = @_; 1225 1226 foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) { 1227 if (-e "$path/$conf") { 1228 return "$path/$conf"; 1229 } 1230 } 1231 1232 return ""; 1233} 1234 1235sub mailmap_email { 1236 my ($line) = @_; 1237 1238 my ($name, $address) = parse_email($line); 1239 my $email = format_email($name, $address, 1); 1240 my $real_name = $name; 1241 my $real_address = $address; 1242 1243 if (exists $mailmap->{names}->{$email} || 1244 exists $mailmap->{addresses}->{$email}) { 1245 if (exists $mailmap->{names}->{$email}) { 1246 $real_name = $mailmap->{names}->{$email}; 1247 } 1248 if (exists $mailmap->{addresses}->{$email}) { 1249 $real_address = $mailmap->{addresses}->{$email}; 1250 } 1251 } else { 1252 if (exists $mailmap->{names}->{$address}) { 1253 $real_name = $mailmap->{names}->{$address}; 1254 } 1255 if (exists $mailmap->{addresses}->{$address}) { 1256 $real_address = $mailmap->{addresses}->{$address}; 1257 } 1258 } 1259 return format_email($real_name, $real_address, 1); 1260} 1261 1262sub mailmap { 1263 my (@addresses) = @_; 1264 1265 my @mapped_emails = (); 1266 foreach my $line (@addresses) { 1267 push(@mapped_emails, mailmap_email($line)); 1268 } 1269 merge_by_realname(@mapped_emails) if ($email_use_mailmap); 1270 return @mapped_emails; 1271} 1272 1273sub merge_by_realname { 1274 my %address_map; 1275 my (@emails) = @_; 1276 1277 foreach my $email (@emails) { 1278 my ($name, $address) = parse_email($email); 1279 if (exists $address_map{$name}) { 1280 $address = $address_map{$name}; 1281 $email = format_email($name, $address, 1); 1282 } else { 1283 $address_map{$name} = $address; 1284 } 1285 } 1286} 1287 1288sub git_execute_cmd { 1289 my ($cmd) = @_; 1290 my @lines = (); 1291 1292 my $output = `$cmd`; 1293 $output =~ s/^\s*//gm; 1294 @lines = split("\n", $output); 1295 1296 return @lines; 1297} 1298 1299sub hg_execute_cmd { 1300 my ($cmd) = @_; 1301 my @lines = (); 1302 1303 my $output = `$cmd`; 1304 @lines = split("\n", $output); 1305 1306 return @lines; 1307} 1308 1309sub extract_formatted_signatures { 1310 my (@signature_lines) = @_; 1311 1312 my @type = @signature_lines; 1313 1314 s/\s*(.*):.*/$1/ for (@type); 1315 1316 # cut -f2- -d":" 1317 s/\s*.*:\s*(.+)\s*/$1/ for (@signature_lines); 1318 1319## Reformat email addresses (with names) to avoid badly written signatures 1320 1321 foreach my $signer (@signature_lines) { 1322 $signer = deduplicate_email($signer); 1323 } 1324 1325 return (\@type, \@signature_lines); 1326} 1327 1328sub vcs_find_signers { 1329 my ($cmd, $file) = @_; 1330 my $commits; 1331 my @lines = (); 1332 my @signatures = (); 1333 my @authors = (); 1334 my @stats = (); 1335 1336 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd); 1337 1338 my $pattern = $VCS_cmds{"commit_pattern"}; 1339 my $author_pattern = $VCS_cmds{"author_pattern"}; 1340 my $stat_pattern = $VCS_cmds{"stat_pattern"}; 1341 1342 $stat_pattern =~ s/(\$\w+)/$1/eeg; #interpolate $stat_pattern 1343 1344 $commits = grep(/$pattern/, @lines); # of commits 1345 1346 @authors = grep(/$author_pattern/, @lines); 1347 @signatures = grep(/^[ \t]*${signature_pattern}.*\@.*$/, @lines); 1348 @stats = grep(/$stat_pattern/, @lines); 1349 1350# print("stats: <@stats>\n"); 1351 1352 return (0, \@signatures, \@authors, \@stats) if !@signatures; 1353 1354 save_commits_by_author(@lines) if ($interactive); 1355 save_commits_by_signer(@lines) if ($interactive); 1356 1357 if (!$email_git_penguin_chiefs) { 1358 @signatures = grep(!/${penguin_chiefs}/i, @signatures); 1359 } 1360 1361 my ($author_ref, $authors_ref) = extract_formatted_signatures(@authors); 1362 my ($types_ref, $signers_ref) = extract_formatted_signatures(@signatures); 1363 1364 return ($commits, $signers_ref, $authors_ref, \@stats); 1365} 1366 1367sub vcs_find_author { 1368 my ($cmd) = @_; 1369 my @lines = (); 1370 1371 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd); 1372 1373 if (!$email_git_penguin_chiefs) { 1374 @lines = grep(!/${penguin_chiefs}/i, @lines); 1375 } 1376 1377 return @lines if !@lines; 1378 1379 my @authors = (); 1380 foreach my $line (@lines) { 1381 if ($line =~ m/$VCS_cmds{"author_pattern"}/) { 1382 my $author = $1; 1383 my ($name, $address) = parse_email($author); 1384 $author = format_email($name, $address, 1); 1385 push(@authors, $author); 1386 } 1387 } 1388 1389 save_commits_by_author(@lines) if ($interactive); 1390 save_commits_by_signer(@lines) if ($interactive); 1391 1392 return @authors; 1393} 1394 1395sub vcs_save_commits { 1396 my ($cmd) = @_; 1397 my @lines = (); 1398 my @commits = (); 1399 1400 @lines = &{$VCS_cmds{"execute_cmd"}}($cmd); 1401 1402 foreach my $line (@lines) { 1403 if ($line =~ m/$VCS_cmds{"blame_commit_pattern"}/) { 1404 push(@commits, $1); 1405 } 1406 } 1407 1408 return @commits; 1409} 1410 1411sub vcs_blame { 1412 my ($file) = @_; 1413 my $cmd; 1414 my @commits = (); 1415 1416 return @commits if (!(-f $file)); 1417 1418 if (@range && $VCS_cmds{"blame_range_cmd"} eq "") { 1419 my @all_commits = (); 1420 1421 $cmd = $VCS_cmds{"blame_file_cmd"}; 1422 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd 1423 @all_commits = vcs_save_commits($cmd); 1424 1425 foreach my $file_range_diff (@range) { 1426 next if (!($file_range_diff =~ m/(.+):(.+):(.+)/)); 1427 my $diff_file = $1; 1428 my $diff_start = $2; 1429 my $diff_length = $3; 1430 next if ("$file" ne "$diff_file"); 1431 for (my $i = $diff_start; $i < $diff_start + $diff_length; $i++) { 1432 push(@commits, $all_commits[$i]); 1433 } 1434 } 1435 } elsif (@range) { 1436 foreach my $file_range_diff (@range) { 1437 next if (!($file_range_diff =~ m/(.+):(.+):(.+)/)); 1438 my $diff_file = $1; 1439 my $diff_start = $2; 1440 my $diff_length = $3; 1441 next if ("$file" ne "$diff_file"); 1442 $cmd = $VCS_cmds{"blame_range_cmd"}; 1443 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd 1444 push(@commits, vcs_save_commits($cmd)); 1445 } 1446 } else { 1447 $cmd = $VCS_cmds{"blame_file_cmd"}; 1448 $cmd =~ s/(\$\w+)/$1/eeg; #interpolate $cmd 1449 @commits = vcs_save_commits($cmd); 1450 } 1451 1452 foreach my $commit (@commits) { 1453 $commit =~ s/^\^//g; 1454 } 1455 1456 return @commits; 1457} 1458 1459my $printed_novcs = 0; 1460sub vcs_exists { 1461 %VCS_cmds = %VCS_cmds_git; 1462 return 1 if eval $VCS_cmds{"available"}; 1463 %VCS_cmds = %VCS_cmds_hg; 1464 return 2 if eval $VCS_cmds{"available"}; 1465 %VCS_cmds = (); 1466 if (!$printed_novcs) { 1467 warn("$P: No supported VCS found. Add --nogit to options?\n"); 1468 warn("Using a git repository produces better results.\n"); 1469 warn("Try Linus Torvalds' latest git repository using:\n"); 1470 warn("git clone git://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git\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