blob: 278a45bd45a5ea705b3d5bdb36e72a52b41ac08c [file] [log] [blame]
Joe Perchescb7301c2009-04-07 20:40:12 -07001#!/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_maintainers.pl [OPTIONS] <patch>
9# perl scripts/get_maintainers.pl [OPTIONS] -f <file>
10#
11# Licensed under the terms of the GNU GPL License version 2
12
13use strict;
14
15my $P = $0;
Joe Perches870020f2009-07-29 15:04:28 -070016my $V = '0.17';
Joe Perchescb7301c2009-04-07 20:40:12 -070017
18use Getopt::Long qw(:config no_auto_abbrev);
19
20my $lk_path = "./";
21my $email = 1;
22my $email_usename = 1;
23my $email_maintainer = 1;
24my $email_list = 1;
25my $email_subscriber_list = 0;
26my $email_git = 1;
27my $email_git_penguin_chiefs = 0;
28my $email_git_min_signatures = 1;
29my $email_git_max_maintainers = 5;
Joe Perchesafa81ee2009-07-29 15:04:28 -070030my $email_git_min_percent = 5;
Joe Perchescb7301c2009-04-07 20:40:12 -070031my $email_git_since = "1-year-ago";
32my $output_multiline = 1;
33my $output_separator = ", ";
34my $scm = 0;
35my $web = 0;
36my $subsystem = 0;
37my $status = 0;
Joe Perches4a7fdb52009-04-10 12:28:57 -070038my $from_filename = 0;
Joe Perchescb7301c2009-04-07 20:40:12 -070039my $version = 0;
40my $help = 0;
41
42my $exit = 0;
43
44my @penguin_chief = ();
45push(@penguin_chief,"Linus Torvalds:torvalds\@linux-foundation.org");
46#Andrew wants in on most everything - 2009/01/14
47#push(@penguin_chief,"Andrew Morton:akpm\@linux-foundation.org");
48
49my @penguin_chief_names = ();
50foreach my $chief (@penguin_chief) {
51 if ($chief =~ m/^(.*):(.*)/) {
52 my $chief_name = $1;
53 my $chief_addr = $2;
54 push(@penguin_chief_names, $chief_name);
55 }
56}
57my $penguin_chiefs = "\(" . join("|",@penguin_chief_names) . "\)";
58
Joe Perches5f2441e2009-06-16 15:34:02 -070059# rfc822 email address - preloaded methods go here.
Joe Perches1b5e1cf2009-06-16 15:34:01 -070060my $rfc822_lwsp = "(?:(?:\\r\\n)?[ \\t])";
Joe Perchesdf4cc032009-06-16 15:34:04 -070061my $rfc822_char = '[\\000-\\377]';
Joe Perches1b5e1cf2009-06-16 15:34:01 -070062
Joe Perchescb7301c2009-04-07 20:40:12 -070063if (!GetOptions(
64 'email!' => \$email,
65 'git!' => \$email_git,
66 'git-chief-penguins!' => \$email_git_penguin_chiefs,
67 'git-min-signatures=i' => \$email_git_min_signatures,
68 'git-max-maintainers=i' => \$email_git_max_maintainers,
Joe Perchesafa81ee2009-07-29 15:04:28 -070069 'git-min-percent=i' => \$email_git_min_percent,
Joe Perchescb7301c2009-04-07 20:40:12 -070070 'git-since=s' => \$email_git_since,
71 'm!' => \$email_maintainer,
72 'n!' => \$email_usename,
73 'l!' => \$email_list,
74 's!' => \$email_subscriber_list,
75 'multiline!' => \$output_multiline,
76 'separator=s' => \$output_separator,
77 'subsystem!' => \$subsystem,
78 'status!' => \$status,
79 'scm!' => \$scm,
80 'web!' => \$web,
Joe Perches4a7fdb52009-04-10 12:28:57 -070081 'f|file' => \$from_filename,
Joe Perchescb7301c2009-04-07 20:40:12 -070082 'v|version' => \$version,
83 'h|help' => \$help,
84 )) {
85 usage();
86 die "$P: invalid argument\n";
87}
88
89if ($help != 0) {
90 usage();
91 exit 0;
92}
93
94if ($version != 0) {
95 print("${P} ${V}\n");
96 exit 0;
97}
98
Joe Perchescb7301c2009-04-07 20:40:12 -070099if ($#ARGV < 0) {
100 usage();
101 die "$P: argument missing: patchfile or -f file please\n";
102}
103
104my $selections = $email + $scm + $status + $subsystem + $web;
105if ($selections == 0) {
106 usage();
107 die "$P: Missing required option: email, scm, status, subsystem or web\n";
108}
109
110if ($email && ($email_maintainer + $email_list + $email_subscriber_list
111 + $email_git + $email_git_penguin_chiefs) == 0) {
112 usage();
113 die "$P: Please select at least 1 email option\n";
114}
115
116if (!top_of_kernel_tree($lk_path)) {
117 die "$P: The current directory does not appear to be "
118 . "a linux kernel source tree.\n";
119}
120
121## Read MAINTAINERS for type/value pairs
122
123my @typevalue = ();
124open(MAINT, "<${lk_path}MAINTAINERS") || die "$P: Can't open MAINTAINERS\n";
125while (<MAINT>) {
126 my $line = $_;
127
128 if ($line =~ m/^(\C):\s*(.*)/) {
129 my $type = $1;
130 my $value = $2;
131
132 ##Filename pattern matching
133 if ($type eq "F" || $type eq "X") {
134 $value =~ s@\.@\\\.@g; ##Convert . to \.
135 $value =~ s/\*/\.\*/g; ##Convert * to .*
136 $value =~ s/\?/\./g; ##Convert ? to .
Joe Perches870020f2009-07-29 15:04:28 -0700137 ##if pattern is a directory and it lacks a trailing slash, add one
138 if ((-d $value)) {
139 $value =~ s@([^/])$@$1/@;
140 }
Joe Perchescb7301c2009-04-07 20:40:12 -0700141 }
142 push(@typevalue, "$type:$value");
143 } elsif (!/^(\s)*$/) {
144 $line =~ s/\n$//g;
145 push(@typevalue, $line);
146 }
147}
148close(MAINT);
149
Joe Perches4a7fdb52009-04-10 12:28:57 -0700150## use the filenames on the command line or find the filenames in the patchfiles
Joe Perchescb7301c2009-04-07 20:40:12 -0700151
152my @files = ();
153
Joe Perches4a7fdb52009-04-10 12:28:57 -0700154foreach my $file (@ARGV) {
Joe Perches870020f2009-07-29 15:04:28 -0700155 ##if $file is a directory and it lacks a trailing slash, add one
156 if ((-d $file)) {
157 $file =~ s@([^/])$@$1/@;
158 } elsif (!(-f $file)) {
Joe Perches4a7fdb52009-04-10 12:28:57 -0700159 die "$P: file '${file}' not found\n";
Joe Perchescb7301c2009-04-07 20:40:12 -0700160 }
Joe Perches4a7fdb52009-04-10 12:28:57 -0700161 if ($from_filename) {
162 push(@files, $file);
163 } else {
164 my $file_cnt = @files;
165 open(PATCH, "<$file") or die "$P: Can't open ${file}\n";
166 while (<PATCH>) {
167 if (m/^\+\+\+\s+(\S+)/) {
168 my $filename = $1;
169 $filename =~ s@^[^/]*/@@;
170 $filename =~ s@\n@@;
171 push(@files, $filename);
172 }
Joe Perchescb7301c2009-04-07 20:40:12 -0700173 }
Joe Perches4a7fdb52009-04-10 12:28:57 -0700174 close(PATCH);
175 if ($file_cnt == @files) {
Joe Perches7f29fd272009-06-16 15:34:04 -0700176 warn "$P: file '${file}' doesn't appear to be a patch. "
Joe Perches4a7fdb52009-04-10 12:28:57 -0700177 . "Add -f to options?\n";
178 }
179 @files = sort_and_uniq(@files);
Joe Perchescb7301c2009-04-07 20:40:12 -0700180 }
Joe Perchescb7301c2009-04-07 20:40:12 -0700181}
182
183my @email_to = ();
Joe Perches290603c2009-06-16 15:33:58 -0700184my @list_to = ();
Joe Perchescb7301c2009-04-07 20:40:12 -0700185my @scm = ();
186my @web = ();
187my @subsystem = ();
188my @status = ();
189
190# Find responsible parties
191
192foreach my $file (@files) {
193
194#Do not match excluded file patterns
195
196 my $exclude = 0;
197 foreach my $line (@typevalue) {
Joe Perches290603c2009-06-16 15:33:58 -0700198 if ($line =~ m/^(\C):\s*(.*)/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700199 my $type = $1;
200 my $value = $2;
201 if ($type eq 'X') {
202 if (file_match_pattern($file, $value)) {
203 $exclude = 1;
204 }
205 }
206 }
207 }
208
209 if (!$exclude) {
210 my $tvi = 0;
211 foreach my $line (@typevalue) {
Joe Perches290603c2009-06-16 15:33:58 -0700212 if ($line =~ m/^(\C):\s*(.*)/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700213 my $type = $1;
214 my $value = $2;
215 if ($type eq 'F') {
216 if (file_match_pattern($file, $value)) {
217 add_categories($tvi);
218 }
219 }
220 }
221 $tvi++;
222 }
223 }
224
Joe Perches4a7fdb52009-04-10 12:28:57 -0700225 if ($email && $email_git) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700226 recent_git_signoffs($file);
227 }
228
229}
230
Joe Perchesf5f50782009-06-16 15:34:00 -0700231if ($email) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700232 foreach my $chief (@penguin_chief) {
233 if ($chief =~ m/^(.*):(.*)/) {
Joe Perchesf5f50782009-06-16 15:34:00 -0700234 my $email_address;
Joe Perchescb7301c2009-04-07 20:40:12 -0700235 if ($email_usename) {
Joe Perchesf5f50782009-06-16 15:34:00 -0700236 $email_address = format_email($1, $2);
Joe Perchescb7301c2009-04-07 20:40:12 -0700237 } else {
Joe Perchesf5f50782009-06-16 15:34:00 -0700238 $email_address = $2;
239 }
240 if ($email_git_penguin_chiefs) {
241 push(@email_to, $email_address);
242 } else {
243 @email_to = grep(!/${email_address}/, @email_to);
Joe Perchescb7301c2009-04-07 20:40:12 -0700244 }
245 }
246 }
247}
248
Joe Perches290603c2009-06-16 15:33:58 -0700249if ($email || $email_list) {
250 my @to = ();
251 if ($email) {
252 @to = (@to, @email_to);
Joe Perchescb7301c2009-04-07 20:40:12 -0700253 }
Joe Perches290603c2009-06-16 15:33:58 -0700254 if ($email_list) {
Joe Perches290603c2009-06-16 15:33:58 -0700255 @to = (@to, @list_to);
Joe Perches290603c2009-06-16 15:33:58 -0700256 }
257 output(uniq(@to));
Joe Perchescb7301c2009-04-07 20:40:12 -0700258}
259
260if ($scm) {
Joe Perches4a7fdb52009-04-10 12:28:57 -0700261 @scm = sort_and_uniq(@scm);
Joe Perchescb7301c2009-04-07 20:40:12 -0700262 output(@scm);
263}
264
265if ($status) {
Joe Perches4a7fdb52009-04-10 12:28:57 -0700266 @status = sort_and_uniq(@status);
Joe Perchescb7301c2009-04-07 20:40:12 -0700267 output(@status);
268}
269
270if ($subsystem) {
Joe Perches4a7fdb52009-04-10 12:28:57 -0700271 @subsystem = sort_and_uniq(@subsystem);
Joe Perchescb7301c2009-04-07 20:40:12 -0700272 output(@subsystem);
273}
274
275if ($web) {
Joe Perches4a7fdb52009-04-10 12:28:57 -0700276 @web = sort_and_uniq(@web);
Joe Perchescb7301c2009-04-07 20:40:12 -0700277 output(@web);
278}
279
280exit($exit);
281
282sub file_match_pattern {
283 my ($file, $pattern) = @_;
284 if (substr($pattern, -1) eq "/") {
285 if ($file =~ m@^$pattern@) {
286 return 1;
287 }
288 } else {
289 if ($file =~ m@^$pattern@) {
290 my $s1 = ($file =~ tr@/@@);
291 my $s2 = ($pattern =~ tr@/@@);
292 if ($s1 == $s2) {
293 return 1;
294 }
295 }
296 }
297 return 0;
298}
299
300sub usage {
301 print <<EOT;
302usage: $P [options] patchfile
Joe Perches870020f2009-07-29 15:04:28 -0700303 $P [options] -f file|directory
Joe Perchescb7301c2009-04-07 20:40:12 -0700304version: $V
305
306MAINTAINER field selection options:
307 --email => print email address(es) if any
308 --git => include recent git \*-by: signers
309 --git-chief-penguins => include ${penguin_chiefs}
310 --git-min-signatures => number of signatures required (default: 1)
311 --git-max-maintainers => maximum maintainers to add (default: 5)
Joe Perches3d202ae2009-07-29 15:04:29 -0700312 --git-min-percent => minimum percentage of commits required (default: 5)
Joe Perchescb7301c2009-04-07 20:40:12 -0700313 --git-since => git history to use (default: 1-year-ago)
314 --m => include maintainer(s) if any
315 --n => include name 'Full Name <addr\@domain.tld>'
316 --l => include list(s) if any
317 --s => include subscriber only list(s) if any
318 --scm => print SCM tree(s) if any
319 --status => print status if any
320 --subsystem => print subsystem name if any
321 --web => print website(s) if any
322
323Output type options:
324 --separator [, ] => separator for multiple entries on 1 line
325 --multiline => print 1 entry per line
326
327Default options:
Joe Perches290603c2009-06-16 15:33:58 -0700328 [--email --git --m --n --l --multiline]
Joe Perchescb7301c2009-04-07 20:40:12 -0700329
330Other options:
Joe Perchesf5f50782009-06-16 15:34:00 -0700331 --version => show version
Joe Perchescb7301c2009-04-07 20:40:12 -0700332 --help => show this help information
333
Joe Perches870020f2009-07-29 15:04:28 -0700334Notes:
335 Using "-f directory" may give unexpected results:
336
337 Used with "--git", git signators for _all_ files in and below
338 directory are examined as git recurses directories.
339 Any specified X: (exclude) pattern matches are _not_ ignored.
340 Used with "--nogit", directory is used as a pattern match,
341 no individual file within the directory or subdirectory
342 is matched.
Joe Perchescb7301c2009-04-07 20:40:12 -0700343EOT
344}
345
346sub top_of_kernel_tree {
347 my ($lk_path) = @_;
348
349 if ($lk_path ne "" && substr($lk_path,length($lk_path)-1,1) ne "/") {
350 $lk_path .= "/";
351 }
352 if ( (-f "${lk_path}COPYING")
353 && (-f "${lk_path}CREDITS")
354 && (-f "${lk_path}Kbuild")
355 && (-f "${lk_path}MAINTAINERS")
356 && (-f "${lk_path}Makefile")
357 && (-f "${lk_path}README")
358 && (-d "${lk_path}Documentation")
359 && (-d "${lk_path}arch")
360 && (-d "${lk_path}include")
361 && (-d "${lk_path}drivers")
362 && (-d "${lk_path}fs")
363 && (-d "${lk_path}init")
364 && (-d "${lk_path}ipc")
365 && (-d "${lk_path}kernel")
366 && (-d "${lk_path}lib")
367 && (-d "${lk_path}scripts")) {
368 return 1;
369 }
370 return 0;
371}
372
373sub format_email {
374 my ($name, $email) = @_;
375
376 $name =~ s/^\s+|\s+$//g;
Joe Perchesd7895042009-06-16 15:34:02 -0700377 $name =~ s/^\"|\"$//g;
Joe Perchescb7301c2009-04-07 20:40:12 -0700378 $email =~ s/^\s+|\s+$//g;
379
380 my $formatted_email = "";
381
382 if ($name =~ /[^a-z0-9 \.\-]/i) { ##has "must quote" chars
383 $name =~ s/(?<!\\)"/\\"/g; ##escape quotes
384 $formatted_email = "\"${name}\"\ \<${email}\>";
385 } else {
386 $formatted_email = "${name} \<${email}\>";
387 }
388 return $formatted_email;
389}
390
391sub add_categories {
392 my ($index) = @_;
393
394 $index = $index - 1;
395 while ($index >= 0) {
396 my $tv = $typevalue[$index];
Joe Perches290603c2009-06-16 15:33:58 -0700397 if ($tv =~ m/^(\C):\s*(.*)/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700398 my $ptype = $1;
399 my $pvalue = $2;
400 if ($ptype eq "L") {
Joe Perches290603c2009-06-16 15:33:58 -0700401 my $list_address = $pvalue;
402 my $list_additional = "";
403 if ($list_address =~ m/([^\s]+)\s+(.*)$/) {
404 $list_address = $1;
405 $list_additional = $2;
406 }
Joe Perchesbdf7c682009-06-16 15:33:59 -0700407 if ($list_additional =~ m/subscribers-only/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700408 if ($email_subscriber_list) {
Joe Perches290603c2009-06-16 15:33:58 -0700409 push(@list_to, $list_address);
Joe Perchescb7301c2009-04-07 20:40:12 -0700410 }
411 } else {
412 if ($email_list) {
Joe Perches290603c2009-06-16 15:33:58 -0700413 push(@list_to, $list_address);
Joe Perchescb7301c2009-04-07 20:40:12 -0700414 }
415 }
416 } elsif ($ptype eq "M") {
Joe Perches5f2441e2009-06-16 15:34:02 -0700417 my $p_used = 0;
418 if ($index >= 0) {
419 my $tv = $typevalue[$index - 1];
420 if ($tv =~ m/^(\C):\s*(.*)/) {
421 if ($1 eq "P") {
422 if ($email_usename) {
423 push_email_address(format_email($2, $pvalue));
424 $p_used = 1;
425 }
426 }
427 }
428 }
429 if (!$p_used) {
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700430 push_email_addresses($pvalue);
Joe Perchescb7301c2009-04-07 20:40:12 -0700431 }
432 } elsif ($ptype eq "T") {
433 push(@scm, $pvalue);
434 } elsif ($ptype eq "W") {
435 push(@web, $pvalue);
436 } elsif ($ptype eq "S") {
437 push(@status, $pvalue);
438 }
439
440 $index--;
441 } else {
442 push(@subsystem,$tv);
443 $index = -1;
444 }
445 }
446}
447
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700448sub push_email_address {
449 my ($email_address) = @_;
450
451 my $email_name = "";
452 if ($email_address =~ m/([^<]+)<(.*\@.*)>$/) {
453 $email_name = $1;
454 $email_address = $2;
455 }
456
Joe Perches0a79c492009-06-16 15:34:03 -0700457 if ($email_maintainer) {
458 if ($email_usename && $email_name) {
459 push(@email_to, format_email($email_name, $email_address));
460 } else {
461 push(@email_to, $email_address);
462 }
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700463 }
464}
465
466sub push_email_addresses {
467 my ($address) = @_;
468
469 my @address_list = ();
470
Joe Perches5f2441e2009-06-16 15:34:02 -0700471 if (rfc822_valid($address)) {
472 push_email_address($address);
473 } elsif (@address_list = rfc822_validlist($address)) {
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700474 my $array_count = shift(@address_list);
475 while (my $entry = shift(@address_list)) {
476 push_email_address($entry);
477 }
Joe Perches5f2441e2009-06-16 15:34:02 -0700478 } else {
479 warn("Invalid MAINTAINERS address: '" . $address . "'\n");
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700480 }
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700481}
482
Joe Perchescb7301c2009-04-07 20:40:12 -0700483sub which {
484 my ($bin) = @_;
485
Joe Perchesf5f50782009-06-16 15:34:00 -0700486 foreach my $path (split(/:/, $ENV{PATH})) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700487 if (-e "$path/$bin") {
488 return "$path/$bin";
489 }
490 }
491
492 return "";
493}
494
495sub recent_git_signoffs {
496 my ($file) = @_;
497
498 my $sign_offs = "";
499 my $cmd = "";
500 my $output = "";
501 my $count = 0;
502 my @lines = ();
Joe Perchesafa81ee2009-07-29 15:04:28 -0700503 my $total_sign_offs;
Joe Perchescb7301c2009-04-07 20:40:12 -0700504
505 if (which("git") eq "") {
Joe Perchesde2fc492009-06-16 15:34:01 -0700506 warn("$P: git not found. Add --nogit to options?\n");
507 return;
508 }
509 if (!(-d ".git")) {
Joe Perches5f2441e2009-06-16 15:34:02 -0700510 warn("$P: .git directory not found. Use a git repository for better results.\n");
511 warn("$P: perhaps 'git clone git://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux-2.6.git'\n");
Joe Perchesde2fc492009-06-16 15:34:01 -0700512 return;
Joe Perchescb7301c2009-04-07 20:40:12 -0700513 }
514
515 $cmd = "git log --since=${email_git_since} -- ${file}";
Joe Perchesde2fc492009-06-16 15:34:01 -0700516 $cmd .= " | grep -Ei \"^[-_ a-z]+by:.*\\\@.*\$\"";
517 if (!$email_git_penguin_chiefs) {
518 $cmd .= " | grep -Ev \"${penguin_chiefs}\"";
519 }
Joe Perches4a7fdb52009-04-10 12:28:57 -0700520 $cmd .= " | cut -f2- -d\":\"";
Joe Perchescb7301c2009-04-07 20:40:12 -0700521 $cmd .= " | sort | uniq -c | sort -rn";
522
523 $output = `${cmd}`;
524 $output =~ s/^\s*//gm;
525
526 @lines = split("\n", $output);
Joe Perchesafa81ee2009-07-29 15:04:28 -0700527
528 $total_sign_offs = 0;
529 foreach my $line (@lines) {
530 if ($line =~ m/([0-9]+)\s+(.*)/) {
531 $total_sign_offs += $1;
532 } else {
533 die("$P: Unexpected git output: ${line}\n");
534 }
535 }
536
Joe Perchescb7301c2009-04-07 20:40:12 -0700537 foreach my $line (@lines) {
Joe Perches4a7fdb52009-04-10 12:28:57 -0700538 if ($line =~ m/([0-9]+)\s+(.*)/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700539 my $sign_offs = $1;
Joe Perches4a7fdb52009-04-10 12:28:57 -0700540 $line = $2;
Joe Perchescb7301c2009-04-07 20:40:12 -0700541 $count++;
542 if ($sign_offs < $email_git_min_signatures ||
Joe Perchesafa81ee2009-07-29 15:04:28 -0700543 $count > $email_git_max_maintainers ||
544 $sign_offs * 100 / $total_sign_offs < $email_git_min_percent) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700545 last;
546 }
Joe Perchescb7301c2009-04-07 20:40:12 -0700547 }
Joe Perches4a7fdb52009-04-10 12:28:57 -0700548 if ($line =~ m/(.+)<(.+)>/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700549 my $git_name = $1;
550 my $git_addr = $2;
Joe Perchescb7301c2009-04-07 20:40:12 -0700551 if ($email_usename) {
552 push(@email_to, format_email($git_name, $git_addr));
553 } else {
554 push(@email_to, $git_addr);
555 }
Joe Perches4a7fdb52009-04-10 12:28:57 -0700556 } elsif ($line =~ m/<(.+)>/) {
Joe Perchescb7301c2009-04-07 20:40:12 -0700557 my $git_addr = $1;
558 push(@email_to, $git_addr);
559 } else {
560 push(@email_to, $line);
561 }
562 }
Joe Perchescb7301c2009-04-07 20:40:12 -0700563}
564
565sub uniq {
566 my @parms = @_;
567
568 my %saw;
569 @parms = grep(!$saw{$_}++, @parms);
570 return @parms;
571}
572
573sub sort_and_uniq {
574 my @parms = @_;
575
576 my %saw;
577 @parms = sort @parms;
578 @parms = grep(!$saw{$_}++, @parms);
579 return @parms;
580}
581
582sub output {
583 my @parms = @_;
584
585 if ($output_multiline) {
586 foreach my $line (@parms) {
587 print("${line}\n");
588 }
589 } else {
590 print(join($output_separator, @parms));
591 print("\n");
592 }
593}
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700594
595my $rfc822re;
596
597sub make_rfc822re {
598# Basic lexical tokens are specials, domain_literal, quoted_string, atom, and
599# comment. We must allow for rfc822_lwsp (or comments) after each of these.
600# This regexp will only work on addresses which have had comments stripped
601# and replaced with rfc822_lwsp.
602
603 my $specials = '()<>@,;:\\\\".\\[\\]';
604 my $controls = '\\000-\\037\\177';
605
606 my $dtext = "[^\\[\\]\\r\\\\]";
607 my $domain_literal = "\\[(?:$dtext|\\\\.)*\\]$rfc822_lwsp*";
608
609 my $quoted_string = "\"(?:[^\\\"\\r\\\\]|\\\\.|$rfc822_lwsp)*\"$rfc822_lwsp*";
610
611# Use zero-width assertion to spot the limit of an atom. A simple
612# $rfc822_lwsp* causes the regexp engine to hang occasionally.
613 my $atom = "[^$specials $controls]+(?:$rfc822_lwsp+|\\Z|(?=[\\[\"$specials]))";
614 my $word = "(?:$atom|$quoted_string)";
615 my $localpart = "$word(?:\\.$rfc822_lwsp*$word)*";
616
617 my $sub_domain = "(?:$atom|$domain_literal)";
618 my $domain = "$sub_domain(?:\\.$rfc822_lwsp*$sub_domain)*";
619
620 my $addr_spec = "$localpart\@$rfc822_lwsp*$domain";
621
622 my $phrase = "$word*";
623 my $route = "(?:\@$domain(?:,\@$rfc822_lwsp*$domain)*:$rfc822_lwsp*)";
624 my $route_addr = "\\<$rfc822_lwsp*$route?$addr_spec\\>$rfc822_lwsp*";
625 my $mailbox = "(?:$addr_spec|$phrase$route_addr)";
626
627 my $group = "$phrase:$rfc822_lwsp*(?:$mailbox(?:,\\s*$mailbox)*)?;\\s*";
628 my $address = "(?:$mailbox|$group)";
629
630 return "$rfc822_lwsp*$address";
631}
632
633sub rfc822_strip_comments {
634 my $s = shift;
635# Recursively remove comments, and replace with a single space. The simpler
636# regexps in the Email Addressing FAQ are imperfect - they will miss escaped
637# chars in atoms, for example.
638
639 while ($s =~ s/^((?:[^"\\]|\\.)*
640 (?:"(?:[^"\\]|\\.)*"(?:[^"\\]|\\.)*)*)
641 \((?:[^()\\]|\\.)*\)/$1 /osx) {}
642 return $s;
643}
644
645# valid: returns true if the parameter is an RFC822 valid address
646#
647sub rfc822_valid ($) {
648 my $s = rfc822_strip_comments(shift);
649
650 if (!$rfc822re) {
651 $rfc822re = make_rfc822re();
652 }
653
654 return $s =~ m/^$rfc822re$/so && $s =~ m/^$rfc822_char*$/;
655}
656
657# validlist: In scalar context, returns true if the parameter is an RFC822
658# valid list of addresses.
659#
660# In list context, returns an empty list on failure (an invalid
661# address was found); otherwise a list whose first element is the
662# number of addresses found and whose remaining elements are the
663# addresses. This is needed to disambiguate failure (invalid)
664# from success with no addresses found, because an empty string is
665# a valid list.
666
667sub rfc822_validlist ($) {
668 my $s = rfc822_strip_comments(shift);
669
670 if (!$rfc822re) {
671 $rfc822re = make_rfc822re();
672 }
673 # * null list items are valid according to the RFC
674 # * the '1' business is to aid in distinguishing failure from no results
675
676 my @r;
677 if ($s =~ m/^(?:$rfc822re)?(?:,(?:$rfc822re)?)*$/so &&
678 $s =~ m/^$rfc822_char*$/) {
Joe Perches5f2441e2009-06-16 15:34:02 -0700679 while ($s =~ m/(?:^|,$rfc822_lwsp*)($rfc822re)/gos) {
Joe Perches1b5e1cf2009-06-16 15:34:01 -0700680 push @r, $1;
681 }
682 return wantarray ? (scalar(@r), @r) : 1;
683 }
684 else {
685 return wantarray ? () : 0;
686 }
687}