modules/fallback/Email/Address.pm

   1 package Email::Address;
   2 use strict;
   3 ## no critic RequireUseWarnings
   4 # support pre-5.6
   5
   6 use vars qw[$VERSION $COMMENT_NEST_LEVEL $STRINGIFY
   7             $COLLAPSE_SPACES
   8             %PARSE_CACHE %FORMAT_CACHE %NAME_CACHE
   9             $addr_spec $angle_addr $name_addr $mailbox];
  10
  11 my $NOCACHE;
  12
  13 $VERSION              = '1.888';
  14 $COMMENT_NEST_LEVEL ||= 2;
  15 $STRINGIFY          ||= 'format';
  16 $COLLAPSE_SPACES      = 1 unless defined $COLLAPSE_SPACES; # who wants //=? me!
  17
  18 =head1 NAME
  19
  20 Email::Address - RFC 2822 Address Parsing and Creation
  21
  22 =head1 SYNOPSIS
  23
  24   use Email::Address;
  25
  26   my @addresses = Email::Address->parse($line);
  27   my $address   = Email::Address->new(Casey => 'casey@localhost');
  28
  29   print $address->format;
  30
  31 =head1 VERSION
  32
  33 version 1.886
  34
  35  $Id: /my/pep/Email-Address/trunk/lib/Email/Address.pm 31900 2007-06-23T01:25:34.344997Z rjbs  $
  36
  37 =head1 DESCRIPTION
  38
  39 This class implements a regex-based RFC 2822 parser that locates email
  40 addresses in strings and returns a list of C<Email::Address> objects found.
  41 Alternatley you may construct objects manually. The goal of this software is to
  42 be correct, and very very fast.
  43
  44 =cut
  45
  46 my $CTL            = q{\x00-\x1F\x7F};
  47 my $special        = q{()<>\\[\\]:;@\\\\,."};
  48
  49 my $text           = qr/[^\x0A\x0D]/;
  50
  51 my $quoted_pair    = qr/\\$text/;
  52
  53 my $ctext          = qr/(?>[^()\\]+)/;
  54 my ($ccontent, $comment) = (q{})x2;
  55 for (1 .. $COMMENT_NEST_LEVEL) {
  56   $ccontent = qr/$ctext|$quoted_pair|$comment/;
  57   $comment  = qr/\s*\((?:\s*$ccontent)*\s*\)\s*/;
  58 }
  59 my $cfws           = qr/$comment|\s+/;
  60
  61 my $atext          = qq/[^$CTL$special\\s]/;
  62 my $atom           = qr/$cfws*$atext+$cfws*/;
  63 my $dot_atom_text  = qr/$atext+(?:\.$atext+)*/;
  64 my $dot_atom       = qr/$cfws*$dot_atom_text$cfws*/;
  65
  66 my $qtext          = qr/[^\\"]/;
  67 my $qcontent       = qr/$qtext|$quoted_pair/;
  68 my $quoted_string  = qr/$cfws*"$qcontent+"$cfws*/;
  69
  70 my $word           = qr/$atom|$quoted_string/;
  71
  72 # XXX: This ($phrase) used to just be: my $phrase = qr/$word+/; It was changed
  73 # to resolve bug 22991, creating a significant slowdown.  Given current speed
  74 # problems.  Once 16320 is resolved, this section should be dealt with.
  75 # -- rjbs, 2006-11-11
  76 #my $obs_phrase     = qr/$word(?:$word|\.|$cfws)*/;
  77
  78 # XXX: ...and the above solution caused endless problems (never returned) when
  79 # examining this address, now in a test:
  80 #   admin+=E6=96=B0=E5=8A=A0=E5=9D=A1_Weblog-- ATAT --test.socialtext.com
  81 # So we disallow the hateful CFWS in this context for now.  Of modern mail
  82 # agents, only Apple Web Mail 2.0 is known to produce obs-phrase.
  83 # -- rjbs, 2006-11-19
  84 my $simple_word    = qr/$atom|\.|\s*"$qcontent+"\s*/;
  85 my $obs_phrase     = qr/$simple_word+/;
  86
  87 my $phrase         = qr/$obs_phrase|(?:$word+)/;
  88
  89 my $local_part     = qr/$dot_atom|$quoted_string/;
  90 my $dtext          = qr/[^\[\]\\]/;
  91 my $dcontent       = qr/$dtext|$quoted_pair/;
  92 my $domain_literal = qr/$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*/;
  93 my $domain         = qr/$dot_atom|$domain_literal/;
  94
  95 my $display_name   = $phrase;
  96
  97 =head2 Package Variables
  98
  99 Several regular expressions used in this package are useful to others.
 100 For convenience, these variables are declared as package variables that
 101 you may access from your program.
 102
 103 These regular expressions conform to the rules specified in RFC 2822.
 104
 105 You can access these variables using the full namespace. If you want
 106 short names, define them yourself.
 107
 108   my $addr_spec = $Email::Address::addr_spec;
 109
 110 =over 4
 111
 112 =item $Email::Address::addr_spec
 113
 114 This regular expression defined what an email address is allowed to
 115 look like.
 116
 117 =item $Email::Address::angle_addr
 118
 119 This regular expression defines an C<$addr_spec> wrapped in angle
 120 brackets.
 121
 122 =item $Email::Address::name_addr
 123
 124 This regular expression defines what an email address can look like
 125 with an optional preceeding display name, also known as the C<phrase>.
 126
 127 =item $Email::Address::mailbox
 128
 129 This is the complete regular expression defining an RFC 2822 emial
 130 address with an optional preceeding display name and optional
 131 following comment.
 132
 133 =back
 134
 135 =cut
 136
 137 $addr_spec  = qr/$local_part\@$domain/;
 138 $angle_addr = qr/$cfws*<$addr_spec>$cfws*/;
 139 $name_addr  = qr/$display_name?$angle_addr/;
 140 $mailbox    = qr/(?:$name_addr|$addr_spec)$comment*/;
 141
 142 sub _PHRASE   () { 0 }
 143 sub _ADDRESS  () { 1 }
 144 sub _COMMENT  () { 2 }
 145 sub _ORIGINAL () { 3 }
 146 sub _IN_CACHE () { 4 }
 147
 148 =head2 Class Methods
 149
 150 =over 4
 151
 152 =item parse
 153
 154   my @addrs = Email::Address->parse(
 155     q[me@local, Casey <me@local>, "Casey" <me@local> (West)]
 156   );
 157
 158 This method returns a list of C<Email::Address> objects it finds
 159 in the input string.
 160
 161 The specification for an email address allows for infinitley
 162 nestable comments. That's nice in theory, but a little over done.
 163 By default this module allows for two (C<2>) levels of nested
 164 comments. If you think you need more, modify the
 165 C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow
 166 more.
 167
 168   $Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep
 169
 170 The reason for this hardly limiting limitation is simple: efficiency.
 171
 172 Long strings of whitespace can be problematic for this module to parse, a bug
 173 which has not yet been adequately addressed.  The default behavior is now to
 174 collapse multiple spaces into a single space, which avoids this problem.  To
 175 prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero.  This
 176 variable will go away when the bug is resolved properly.
 177
 178 =cut
 179
 180 sub __get_cached_parse {
 181     return if $NOCACHE;
 182
 183     my ($class, $line) = @_;
 184
 185     return @{$PARSE_CACHE{$line}} if exists $PARSE_CACHE{$line};
 186     return;
 187 }
 188
 189 sub __cache_parse {
 190     return if $NOCACHE;
 191
 192     my ($class, $line, $addrs) = @_;
 193
 194     $PARSE_CACHE{$line} = $addrs;
 195 }
 196
 197 sub parse {
 198     my ($class, $line) = @_;
 199     return unless $line;
 200
 201     $line =~ s/[ \t]+/ /g if $COLLAPSE_SPACES;
 202
 203     if (my @cached = $class->__get_cached_parse($line)) {
 204         return @cached;
 205     }
 206
 207     my (@mailboxes) = ($line =~ /$mailbox/go);
 208     my @addrs;
 209     foreach (@mailboxes) {
 210       my $original = $_;
 211
 212       my @comments = /($comment)/go;
 213       s/$comment//go if @comments;
 214
 215       my ($user, $host, $com);
 216       ($user, $host) = ($1, $2) if s/<($local_part)\@($domain)>//o;
 217       if (! defined($user) || ! defined($host)) {
 218           s/($local_part)\@($domain)//o;
 219           ($user, $host) = ($1, $2);
 220       }
 221
 222       my ($phrase)       = /($display_name)/o;
 223
 224       for ( $phrase, $host, $user, @comments ) {
 225         next unless defined $_;
 226         s/^\s+//;
 227         s/\s+$//;
 228         $_ = undef unless length $_;
 229       }
 230
 231       my $new_comment = join q{ }, @comments;
 232       push @addrs,
 233         $class->new($phrase, "$user\@$host", $new_comment, $original);
 234       $addrs[-1]->[_IN_CACHE] = [ \$line, $#addrs ]
 235     }
 236
 237     $class->__cache_parse($line, \@addrs);
 238     return @addrs;
 239 }
 240
 241 =pod
 242
 243 =item new
 244
 245   my $address = Email::Address->new(undef, 'casey@local');
 246   my $address = Email::Address->new('Casey West', 'casey@local');
 247   my $address = Email::Address->new(undef, 'casey@local', '(Casey)');
 248
 249 Constructs and returns a new C<Email::Address> object. Takes four
 250 positional arguments: phrase, email, and comment, and original string.
 251
 252 The original string should only really be set using C<parse>.
 253
 254 =cut
 255
 256 sub new { bless [@_[1..4]], $_[0] }
 257
 258 =pod
 259
 260 =item purge_cache
 261
 262   Email::Address->purge_cache;
 263
 264 One way this module stays fast is with internal caches. Caches live
 265 in memory and there is the remote possibility that you will have a
 266 memory problem. In the off chance that you think you're one of those
 267 people, this class method will empty those caches.
 268
 269 I've loaded over 12000 objects and not encountered a memory problem.
 270
 271 =cut
 272
 273 sub purge_cache {
 274     %NAME_CACHE   = ();
 275     %FORMAT_CACHE = ();
 276     %PARSE_CACHE  = ();
 277 }
 278
 279 =item disable_cache
 280
 281 =item enable_cache
 282
 283   Email::Address->disable_cache if memory_low();
 284
 285 If you'd rather not cache address parses at all, you can disable (and reenable) the Email::Address cache with these methods.  The cache is enabled by default.
 286
 287 =cut
 288
 289 sub disable_cache {
 290   my ($class) = @_;
 291   $class->purge_cache;
 292   $NOCACHE = 1;
 293 }
 294
 295 sub enable_cache {
 296   $NOCACHE = undef;
 297 }
 298
 299 =pod
 300
 301 =back
 302
 303 =head2 Instance Methods
 304
 305 =over 4
 306
 307 =item phrase
 308
 309   my $phrase = $address->phrase;
 310   $address->phrase( "Me oh my" );
 311
 312 Accessor and mutator for the phrase portion of an address.
 313
 314 =item address
 315
 316   my $addr = $address->address;
 317   $addr->address( "me@PROTECTED.com" );
 318
 319 Accessor and mutator for the address portion of an address.
 320
 321 =item comment
 322
 323   my $comment = $address->comment;
 324   $address->comment( "(Work address)" );
 325
 326 Accessor and mutator for the comment portion of an address.
 327
 328 =item original
 329
 330   my $orig = $address->original;
 331
 332 Accessor for the original address found when parsing, or passed
 333 to C<new>.
 334
 335 =item host
 336
 337   my $host = $address->host;
 338
 339 Accessor for the host portion of an address's address.
 340
 341 =item user
 342
 343   my $user = $address->user;
 344
 345 Accessor for the user portion of an address's address.
 346
 347 =cut
 348
 349 BEGIN {
 350   my %_INDEX = (
 351     phrase   => _PHRASE,
 352     address  => _ADDRESS,
 353     comment  => _COMMENT,
 354     original => _ORIGINAL,
 355   );
 356
 357   for my $method (keys %_INDEX) {
 358     no strict 'refs';
 359     my $index = $_INDEX{ $method };
 360     *$method = sub {
 361       if ($_[1]) {
 362         if ($_[0][_IN_CACHE]) {
 363           my $replicant = bless [ @{$_[0]} ] => ref $_[0];
 364           $PARSE_CACHE{ ${ $_[0][_IN_CACHE][0] } }[ $_[0][_IN_CACHE][1] ]
 365             = $replicant;
 366           $_[0][_IN_CACHE] = undef;
 367         }
 368         $_[0]->[ $index ] = $_[1];
 369       } else {
 370         $_[0]->[ $index ];
 371       }
 372     };
 373   }
 374 }
 375
 376 sub host { ($_[0]->[_ADDRESS] =~ /\@($domain)/o)[0]     }
 377 sub user { ($_[0]->[_ADDRESS] =~ /($local_part)\@/o)[0] }
 378
 379 =pod
 380
 381 =item format
 382
 383   my $printable = $address->format;
 384
 385 Returns a properly formatted RFC 2822 address representing the
 386 object.
 387
 388 =cut
 389
 390 sub format {
 391     local $^W = 0; ## no critic
 392     return $FORMAT_CACHE{"@{$_[0]}"} if exists $FORMAT_CACHE{"@{$_[0]}"};
 393     $FORMAT_CACHE{"@{$_[0]}"} = $_[0]->_format;
 394 }
 395
 396 sub _format {
 397     my ($self) = @_;
 398
 399     unless (
 400       defined $self->[_PHRASE] && length $self->[_PHRASE]
 401       ||
 402       defined $self->[_COMMENT] && length $self->[_COMMENT]
 403     ) {
 404         return $self->[_ADDRESS];
 405     }
 406
 407     my $format = sprintf q{%s <%s> %s},
 408                  $self->_enquoted_phrase, $self->[_ADDRESS], $self->[_COMMENT];
 409
 410     $format =~ s/^\s+//;
 411     $format =~ s/\s+$//;
 412
 413     return $format;
 414 }
 415
 416 sub _enquoted_phrase {
 417   my ($self) = @_;
 418
 419   my $phrase = $self->[_PHRASE];
 420
 421   # if it's encoded -- rjbs, 2007-02-28
 422   return $phrase if $phrase =~ /\A=\?.+\?=\z/;
 423
 424   $phrase =~ s/\A"(.+)"\z/$1/;
 425   $phrase =~ s/\"/\\"/g;
 426
 427   return qq{"$phrase"};
 428 }
 429
 430 =pod
 431
 432 =item name
 433
 434   my $name = $address->name;
 435
 436 This method tries very hard to determine the name belonging to the address.
 437 First the C<phrase> is checked. If that doesn't work out the C<comment>
 438 is looked into. If that still doesn't work out, the C<user> portion of
 439 the C<address> is returned.
 440
 441 This method does B<not> try to massage any name it identifies and instead
 442 leaves that up to someone else. Who is it to decide if someone wants their
 443 name capitalized, or if they're Irish?
 444
 445 =cut
 446
 447 sub name {
 448     local $^W = 0;
 449     return $NAME_CACHE{"@{$_[0]}"} if exists $NAME_CACHE{"@{$_[0]}"};
 450     my ($self) = @_;
 451     my $name = q{};
 452     if ( $name = $self->[_PHRASE] ) {
 453         $name =~ s/^"//;
 454         $name =~ s/"$//;
 455         $name =~ s/($quoted_pair)/substr $1, -1/goe;
 456     } elsif ( $name = $self->[_COMMENT] ) {
 457         $name =~ s/^\(//;
 458         $name =~ s/\)$//;
 459         $name =~ s/($quoted_pair)/substr $1, -1/goe;
 460         $name =~ s/$comment/ /go;
 461     } else {
 462         ($name) = $self->[_ADDRESS] =~ /($local_part)\@/o;
 463     }
 464     $NAME_CACHE{"@{$_[0]}"} = $name;
 465 }
 466
 467 =pod
 468
 469 =back
 470
 471 =head2 Overloaded Operators
 472
 473 =over 4
 474
 475 =item stringify
 476
 477   print "I have your email address, $address.";
 478
 479 Objects stringify to C<format> by default. It's possible that you don't
 480 like that idea. Okay, then, you can change it by modifying
 481 C<$Email:Address::STRINGIFY>. Please consider modifying this package
 482 variable using C<local>. You might step on someone else's toes if you
 483 don't.
 484
 485   {
 486     local $Email::Address::STRINGIFY = 'address';
 487     print "I have your address, $address.";
 488     #   geeknest.com
 489   }
 490   print "I have your address, $address.";
 491   #   "Casey West" <casey@geeknest.com>
 492
 493 =cut
 494
 495 sub as_string {
 496   warn 'altering $Email::Address::STRINGIFY is deprecated; subclass instead'
 497     if $STRINGIFY ne 'format';
 498
 499   $_[0]->can($STRINGIFY)->($_[0]);
 500 }
 501
 502 use overload '""' => 'as_string';
 503
 504 =pod
 505
 506 =back
 507
 508 =cut
 509
 510 1;
 511
 512 __END__
 513
 514 =head2 Did I Mention Fast?
 515
 516 On his 1.8GHz Apple MacBook, rjbs gets these results:
 517
 518   $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 5
 519                    Rate  Mail::Address Email::Address
 520   Mail::Address  2.59/s             --           -44%
 521   Email::Address 4.59/s            77%             --
 522
 523   $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 25
 524                    Rate  Mail::Address Email::Address
 525   Mail::Address  2.58/s             --           -67%
 526   Email::Address 7.84/s           204%             --
 527
 528   $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 50
 529                    Rate  Mail::Address Email::Address
 530   Mail::Address  2.57/s             --           -70%
 531   Email::Address 8.53/s           232%             --
 532
 533 ...unfortunately, a known bug causes a loss of speed the string to parse has
 534 certain known characteristics, and disabling cache will also degrade
 535 performance.
 536
 537 =head1 PERL EMAIL PROJECT
 538
 539 This module is maintained by the Perl Email Project
 540
 541 L<http://emailproject.perl.org/wiki/Email::Address>
 542
 543 =head1 SEE ALSO
 544
 545 L<Email::Simple>, L<perl>.
 546
 547 =head1 AUTHOR
 548
 549 Originally by Casey West, <F<casey@geeknest.com>>.
 550
 551 Maintained, 2006-2007, Ricardo SIGNES <F<rjbs@cpan.org>>.
 552
 553 =head1 ACKNOWLEDGEMENTS
 554
 555 Thanks to Kevin Riggle and Tatsuhiko Miyagawa for tests for annoying phrase-quoting bugs!
 556
 557 =head1 COPYRIGHT
 558
 559 Copyright (c) 2004 Casey West.  All rights reserved.  This module is free
 560 software; you can redistribute it and/or modify it under the same terms as Perl
 561 itself.
 562
 563 =cut
 564