diff --git a/lib/Email/Address.pm b/lib/Email/Address.pm index a7e9d1a..1954c78 100644 --- a/lib/Email/Address.pm +++ b/lib/Email/Address.pm @@ -132,6 +132,11 @@ our $angle_addr = qr/$cfws*<$addr_spec>$cfws*/; our $name_addr = qr/$display_name?$angle_addr/; our $mailbox = qr/(?:$name_addr|$addr_spec)$comment*/; +our $addr_spec_domainless = qr/$local_part(?:\@$domain)?/; +our $angle_addr_domainless = qr/$cfws*<$addr_spec_domainless>$cfws*/; +our $name_addr_domainless = qr/$display_name?$angle_addr_domainless/; +our $mailbox_domainless = qr/(?:$name_addr_domainless|$addr_spec_domainless)$comment*/; + sub _PHRASE () { 0 } sub _ADDRESS () { 1 } sub _COMMENT () { 2 } @@ -171,6 +176,17 @@ In accordance with RFC 822 and its descendants, this module demands that email addresses be ASCII only. Any non-ASCII content in the parsed addresses will cause the parser to return no results. +=item parse_allow_domainless + + my @addrs = Email::Address->parse_allow_domainless( + q[me, Casey , "Casey" (West)] + ); + +This method returns a list of C objects it finds in the +input string; it differs from L in that it allows "domainless" +addresses, which lack an at-sign and domain name. The domain of the +addresses is presumed to be assumable by the calling code. + =cut our (%PARSE_CACHE, %FORMAT_CACHE, %NAME_CACHE); @@ -193,17 +209,19 @@ sub __cache_parse { $PARSE_CACHE{$line} = $addrs; } -sub parse { - my ($class, $line) = @_; +sub __parse { + my ($class, $line, $domainless) = @_; return unless $line; $line =~ s/[ \t]+/ /g if $COLLAPSE_SPACES; - if (my @cached = $class->__get_cached_parse($line)) { + my $key = "$domainless,$line"; + if (my @cached = $class->__get_cached_parse($key)) { return @cached; } - my (@mailboxes) = ($line =~ /$mailbox/go); + my (@mailboxes) = $domainless ? ($line =~ /$mailbox_domainless/go) + : ($line =~ /$mailbox/go); my @addrs; foreach (@mailboxes) { my $original = $_; @@ -212,14 +230,15 @@ sub parse { s/$comment//go if @comments; my ($user, $host, $com); - ($user, $host) = ($1, $2) if s/<($local_part)\@($domain)>//o; - if (! defined($user) || ! defined($host)) { - s/($local_part)\@($domain)//o; + ($user, $host) = ($1, $2) if s/<($local_part)(?:\@($domain))?>//o; + if (not defined($user) or (not defined($host) and $domainless)) { + s/($local_part)(?:\@($domain))?//o; ($user, $host) = ($1, $2); } + next unless $host or $domainless; next if $user =~ /\P{ASCII}/; - next if $host =~ /\P{ASCII}/; + next if defined $host and $host =~ /\P{ASCII}/; my ($phrase) = /($display_name)/o; @@ -232,14 +251,26 @@ sub parse { my $new_comment = join q{ }, @comments; push @addrs, - $class->new($phrase, "$user\@$host", $new_comment, $original); - $addrs[-1]->[_IN_CACHE] = [ \$line, $#addrs ] + $class->new($phrase, $host ? "$user\@$host" : $user, $new_comment, $original); + $addrs[-1]->[_IN_CACHE] = [ \$key, $#addrs ] } - $class->__cache_parse($line, \@addrs); + $class->__cache_parse($key, \@addrs); return @addrs; } +sub parse { + my $self = shift; + my ($line) = @_; + return $self->__parse($line, 0); +} + +sub parse_allow_domainless { + my $self = shift; + my ($line) = @_; + return $self->__parse($line, 1); +} + =item new my $address = Email::Address->new(undef, 'casey@local'); @@ -465,7 +496,7 @@ sub name { $name =~ s/($quoted_pair)/substr $1, -1/goe; $name =~ s/$comment/ /go; } else { - ($name) = $self->[_ADDRESS] =~ /($local_part)\@/o; + ($name) = $self->[_ADDRESS] =~ /($local_part)(?:\@|\Z)/o; } $NAME_CACHE{$cache_str} = $name; } diff --git a/t/patterns.t b/t/patterns.t index a85294c..fc2f9d1 100644 --- a/t/patterns.t +++ b/t/patterns.t @@ -39,10 +39,12 @@ my %tests = ( [ '"Richard Sonnen" ', 1 ], [ '"Richard Sonnen" (comments)', 1 ], [ '', 0 ], - [ 'foo', 0 ], [ 'foo bar@bar.com', 0 ], [ '@bar.com', 0 ], ], + mailbox_domainless => [ + [ 'foo', 1 ], + ], ); my $num_tests = scalar( map @{$_}, values %tests ); @@ -55,7 +57,7 @@ my %pats = map { my $pat; eval '$pat = $Email::Address::'.$_; ($_ => $pat); -} qw( addr_spec angle_addr name_addr mailbox ); +} qw( addr_spec angle_addr name_addr mailbox mailbox_domainless); for my $pattern_name (keys %tests) { for my $test (@{ $tests{$pattern_name} }) { diff --git a/t/tests.t b/t/tests.t index 12e4ba2..10af4ea 100644 --- a/t/tests.t +++ b/t/tests.t @@ -1584,16 +1584,16 @@ my @list = ( ] ] ], - [ - 'Jason W. May ', - [ - [ - 'Jason W. May', - 'jmay-- ATAT --x.example.com', - undef - ] - ] - ], + [ + 'Jason W. May ', + [ + [ + 'Jason W. May', + 'jmay-- ATAT --x.example.com', + undef + ] + ] + ], [ '"Jason W. May" , advocacy-- ATAT --p.example.org', [ @@ -1618,29 +1618,108 @@ my @list = ( undef, ], ], - ] + ], +); + +my @domain_list = (@list, + [ + 'jibsheet', + [], + ], + [ + 'alexmv@example.com, jibsheet, jesse@example.com', + [ + [ + undef, + 'alexmv-- ATAT --example.com', + undef, + ], + [ + undef, + 'jesse-- ATAT --example.com', + undef, + ], + ], + ], +); + +my @domainless_list = (@list, + [ + 'falcone', + [ + [ + undef, + 'falcone', + undef + ], + ] + ], + [ + 'falcone, alexmv', + [ + [ + undef, + 'falcone', + undef + ], + [ + undef, + 'alexmv', + undef + ], + ] + ], + [ + 'alexmv@example.com, jibsheet, jesse@example.com', + [ + [ + undef, + 'alexmv-- ATAT --example.com', + undef, + ], + [ + undef, + 'jibsheet', + undef, + ], + [ + undef, + 'jesse-- ATAT --example.com', + undef, + ], + ], + ], ); my $tests = 1; -$tests += @{ $_->[1] } * 5 for @list; +$tests += 1 + @{ $_->[1] } * 5 for @domain_list; +$tests += 1 + @{ $_->[1] } * 5 for @domainless_list; plan tests => $tests; use_ok 'Email::Address'; -for (@list) { - $_->[0] =~ s/-- ATAT --/@/g; - my @addrs = Email::Address->parse($_->[0]); - my @tests = - map { Email::Address->new(map { $_ ? do {s/-- ATAT --/@/g; $_} : $_ } @$_) } - @{$_->[1]}; +for ([parse => \@domain_list], [parse_allow_domainless => \@domainless_list]) { + my ($method,$list) = @$_; + for (@$list) { + my ($string, $expect) = @$_; + + $string =~ s/-- ATAT --/@/g; + my @addrs = Email::Address->$method($string); + + is(@addrs, @$expect, "got correct number of results from $method {$string}"); + + my @tests = + map { Email::Address->new(map { s/-- ATAT --/@/g if $_; $_ } @$_) } + @$expect; - foreach (@addrs) { - isa_ok($_, 'Email::Address'); - my $test = shift @tests; - is($_->format, $test->format, "format: " . $test->format); - is($_->as_string, $test->format, "format: " . $test->format); - is("$_", $test->format, "stringify: $_"); - is($_->name, $test->name, "name: " . $test->name); - } + foreach (@addrs) { + isa_ok($_, 'Email::Address'); + my $test = shift @tests; + is($_->format, $test->format, "format: " . $test->format); + is($_->as_string, $test->as_string, "as_string: " . $test->as_string); + is("$_", $test->format, "stringify: $_"); + is($_->name, $test->name, "name: " . $test->name); + } + } }