3
3
# Copyright (c) 1995-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
4
# Copyright (c) 2002-2003 Mark Overmeer <mailtools@overmeer.net>
4
# Copyright (c) 2002-2005 Mark Overmeer <mailtools@overmeer.net>
5
5
# This program is free software; you can redistribute it and/or
6
6
# modify it under the same terms as Perl itself.
25
25
my $self = @_ && ref $_[0] ? shift : undef;
27
27
local $_ = shift or return '';
29
# Using encodings, too hard. See Mail::Message::Field::Full.
30
return '' if m/\=\?.*?\?\=/;
29
32
# Bug in unicode \U, perl 5.8.0 breaks when casing utf8 in regex
41
44
return "" if /^[\d ]+$/;
43
46
# remove outermost parenthesis
46
49
# remove outer quotation marks
49
# remove embedded comments
52
# remove minimal embedded comments
58
# remove internal quotation marks
52
61
# reverse "Last, First M." if applicable
53
62
s/^([^\s]+) ?, ?(.*)$/$2 $1/;
82
91
local($_) = join(',', @_);
83
92
my(@words,$snippet,$field);
97
#use Scalar::Util qw/tainted/;
116
s/^("([^"\\]|\\.)*")\s*// # "..."
117
|| s/^(\[([^\]\\]|\\.)*\])\s*// # [...]
118
|| s/^([^\s\Q()<>\@,;:\\".[]\E]+)\s*//
119
|| s/^([\Q()<>\@,;:\\".[]\E])\s*//
120
and do { push(@words, $1); next; };
127
if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..."
128
|| s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...]
129
|| s/^([^\s()<>\@,;:\\".[\]]+)\s*//
130
|| s/^([()<>\@,;:\\".[\]])\s*//
122
croak "Unrecognised line: $_";
136
croak "Unrecognised line: $_";
149
163
if(@{$phrase} || @{$comment} || @{$address}) {
150
$o = $pkg->new(join(" ",@{$phrase}),
164
$o = $pkg->new(join(" ",@{$phrase}),
151
165
join("", @{$address}),
152
166
join(" ",@{$comment}));
195
209
elsif($_ eq '>') {
196
210
$depth-- if $depth;
212
elsif($_ eq ',' || $_ eq ';') {
199
213
warn "Unmatched '<>' in $line" if($depth);
200
214
my $o = _complete($pkg,\@phrase, \@address, \@comment);
201
215
push(@objs, $o) if(defined $o);
259
my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]';
245
261
foreach $me (@_) {
246
262
my($phrase,$addr,$comment) = @{$me};
249
265
if(defined $phrase && length($phrase)) {
251
push(@tmp, "<" . $addr . ">") if(defined $addr && length($addr));
266
push @tmp, $phrase =~ /^(?:\s*$atext\s*)+$/ ? $phrase
267
: $phrase =~ /(?<!\\)"/ ? $phrase
270
push(@tmp, "<" . $addr . ">") if(defined $addr && length($addr));
254
273
push(@tmp, $addr) if(defined $addr && length($addr));
271
290
my $phrase = $me->phrase;
272
291
my $addr = $me->address;
274
293
$phrase = $me->comment unless(defined($phrase) && length($phrase));
275
294
my $name = $me->_extract_name($phrase);
277
296
# first.last@domain address
278
297
if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/o)
280
299
($name = $1) =~ s/[\._]+/ /go;
281
300
$name = _extract_name($name);
284
if($name eq '' && $addr =~ m#/g=#oi)
303
if($name eq '' && $addr =~ m#/g=#oi)
285
304
# X400 style address
287
306
my ($f) = $addr =~ m#g=([^/]*)#oi;
288
307
my ($l) = $addr =~ m#s=([^/]*)#io;
290
309
$name = _extract_name($f . " " . $l);
293
312
return length($name) ? $name : undef;
299
my $addr = $me->address;
318
my $addr = $me->address || '';
300
319
my $i = rindex($addr,'@');
302
321
my $host = ($i >= 0) ? substr($addr,$i+1) : undef;
340
359
use Mail::Address;
342
361
my @addrs = Mail::Address->parse($line);
344
363
foreach $addr (@addrs) {
345
364
print $addr->format,"\n";
348
367
=head1 DESCRIPTION
350
C<Mail::Address> extracts and manipulates RFC822 compilant email
351
addresses. As well as being able to create C<Mail::Address> objects
352
in the normal manner, C<Mail::Address> can extract addresses from
353
the To and Cc lines found in an email message.
369
C<Mail::Address> extracts and manipulates email addresses from a message
370
header. It cannot be used to extract addresses from some random text.
371
You can use this module to create RFC822 compliant fields.
373
Although C<Mail::Address> is a very popular subject for books, and is
374
used in many applications, it does a very poor job on the more complex
375
message fields. It does only handle simple address formats (which
376
covers about 95% of what can be found). Problems are with
382
no support for address groups, even not with the semi-colon as
383
separator between addresses
387
Limitted support for escapes in phrases and comments. There are
388
cases where it can get wrong.
392
You have to take care of most escaping when you create an address yourself:
393
C<Mail::Address> does not do that for you.
397
Often requests are made to improve this situation, but this is not a
398
good idea, where it will break zillions of existing applications. If
399
you wish for a fully RFC2822 compliant implementation you may take a look
400
at L<Mail::Message::Field::Full>, part of MailBox.
404
my $s = Mail::Message::Field::Full->parse($header);
405
# ref $s isa Mail::Message::Field::Addresses;
407
my @g = $s->groups; # all groups, at least one
408
# ref $g[0] isa Mail::Message::Field::AddrGroup;
409
my $ga = $g[0]->addresses; # group addresses
411
my @a = $s->addresses; # all addresses
412
# ref $a[0] isa Mail::Message::Field::Address;
355
414
=head1 CONSTRUCTORS
428
Copyright (c) 2002-2003 Mark Overmeer, 1995-2001 Graham Barr. All rights
487
Copyright (c) 2002-2005 Mark Overmeer, 1995-2001 Graham Barr. All rights
429
488
reserved. This program is free software; you can redistribute it and/or
430
489
modify it under the same terms as Perl itself.
added
removed
Kernel/cpan-lib/Mail/Address.pm
