| line | stmt | bran | cond | sub | pod | time | code | 
| 1 | 10 |  |  | 10 |  | 357574 | use strict; | 
|  | 10 |  |  |  |  | 76 |  | 
|  | 10 |  |  |  |  | 259 |  | 
| 2 | 10 |  |  | 10 |  | 46 | use warnings; | 
|  | 10 |  |  |  |  | 14 |  | 
|  | 10 |  |  |  |  | 9823 |  | 
| 3 |  |  |  |  |  |  | package Email::Address; | 
| 4 |  |  |  |  |  |  | # ABSTRACT: (DEPRECATED) RFC 2822 Address Parsing and Creation | 
| 5 |  |  |  |  |  |  | $Email::Address::VERSION = '1.911'; | 
| 6 |  |  |  |  |  |  | our $COMMENT_NEST_LEVEL ||= 1; | 
| 7 |  |  |  |  |  |  | our $STRINGIFY          ||= 'format'; | 
| 8 |  |  |  |  |  |  | our $COLLAPSE_SPACES      = 1 unless defined $COLLAPSE_SPACES; # I miss //= | 
| 9 |  |  |  |  |  |  |  | 
| 10 |  |  |  |  |  |  | #pod =head1 SYNOPSIS | 
| 11 |  |  |  |  |  |  | #pod | 
| 12 |  |  |  |  |  |  | #pod   use Email::Address; | 
| 13 |  |  |  |  |  |  | #pod | 
| 14 |  |  |  |  |  |  | #pod   my @addresses = Email::Address->parse($line); | 
| 15 |  |  |  |  |  |  | #pod   my $address   = Email::Address->new(Casey => 'casey@localhost'); | 
| 16 |  |  |  |  |  |  | #pod | 
| 17 |  |  |  |  |  |  | #pod   print $address->format; | 
| 18 |  |  |  |  |  |  | #pod | 
| 19 |  |  |  |  |  |  | #pod =head1 DESCRIPTION | 
| 20 |  |  |  |  |  |  | #pod | 
| 21 |  |  |  |  |  |  | #pod B This module has a vulnerability | 
| 22 |  |  |  |  |  |  | #pod (L) | 
| 23 |  |  |  |  |  |  | #pod which allows remote attackers to cause denial of service.   In other words, | 
| 24 |  |  |  |  |  |  | #pod sometimes it takes way too long to process certain kinds of input.  Maybe | 
| 25 |  |  |  |  |  |  | #pod someday this will be fixed.  Until then, use | 
| 26 |  |  |  |  |  |  | #pod L|Email::Address::XS> instead which has backward | 
| 27 |  |  |  |  |  |  | #pod compatible API. | 
| 28 |  |  |  |  |  |  | #pod | 
| 29 |  |  |  |  |  |  | #pod This class implements a regex-based RFC 2822 parser that locates email | 
| 30 |  |  |  |  |  |  | #pod addresses in strings and returns a list of C objects found. | 
| 31 |  |  |  |  |  |  | #pod Alternatively you may construct objects manually. The goal of this software is | 
| 32 |  |  |  |  |  |  | #pod to be correct, and very very fast. | 
| 33 |  |  |  |  |  |  | #pod | 
| 34 |  |  |  |  |  |  | #pod =cut | 
| 35 |  |  |  |  |  |  |  | 
| 36 |  |  |  |  |  |  | my $CTL            = q{\x00-\x1F\x7F}; | 
| 37 |  |  |  |  |  |  | my $special        = q{()<>\\[\\]:;@\\\\,."}; | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | my $text           = qr/[^\x0A\x0D]/; | 
| 40 |  |  |  |  |  |  |  | 
| 41 |  |  |  |  |  |  | my $quoted_pair    = qr/\\$text/; | 
| 42 |  |  |  |  |  |  |  | 
| 43 |  |  |  |  |  |  | my $ctext          = qr/(?>[^()\\]+)/; | 
| 44 |  |  |  |  |  |  | my ($ccontent, $comment) = (q{})x2; | 
| 45 |  |  |  |  |  |  | for (1 .. $COMMENT_NEST_LEVEL) { | 
| 46 |  |  |  |  |  |  | $ccontent = qr/$ctext|$quoted_pair|$comment/; | 
| 47 |  |  |  |  |  |  | $comment  = qr/(?>\s*\((?:\s*$ccontent)*\s*\)\s*)/; | 
| 48 |  |  |  |  |  |  | } | 
| 49 |  |  |  |  |  |  | my $cfws           = qr/$comment|(?>\s+)/; | 
| 50 |  |  |  |  |  |  |  | 
| 51 |  |  |  |  |  |  | my $atext          = qq/[^$CTL$special\\s]/; | 
| 52 |  |  |  |  |  |  | my $atom           = qr/(?>$cfws*$atext+$cfws*)/; | 
| 53 |  |  |  |  |  |  | my $dot_atom_text  = qr/(?>$atext+(?:\.$atext+)*)/; | 
| 54 |  |  |  |  |  |  | my $dot_atom       = qr/(?>$cfws*$dot_atom_text$cfws*)/; | 
| 55 |  |  |  |  |  |  |  | 
| 56 |  |  |  |  |  |  | my $qtext          = qr/[^\\"]/; | 
| 57 |  |  |  |  |  |  | my $qcontent       = qr/$qtext|$quoted_pair/; | 
| 58 |  |  |  |  |  |  | my $quoted_string  = qr/(?>$cfws*"$qcontent*"$cfws*)/; | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | my $word           = qr/$atom|$quoted_string/; | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  | # XXX: This ($phrase) used to just be: my $phrase = qr/$word+/; It was changed | 
| 63 |  |  |  |  |  |  | # to resolve bug 22991, creating a significant slowdown.  Given current speed | 
| 64 |  |  |  |  |  |  | # problems.  Once 16320 is resolved, this section should be dealt with. | 
| 65 |  |  |  |  |  |  | # -- rjbs, 2006-11-11 | 
| 66 |  |  |  |  |  |  | #my $obs_phrase     = qr/$word(?:$word|\.|$cfws)*/; | 
| 67 |  |  |  |  |  |  |  | 
| 68 |  |  |  |  |  |  | # XXX: ...and the above solution caused endless problems (never returned) when | 
| 69 |  |  |  |  |  |  | # examining this address, now in a test: | 
| 70 |  |  |  |  |  |  | #   admin+=E6=96=B0=E5=8A=A0=E5=9D=A1_Weblog-- ATAT --test.socialtext.com | 
| 71 |  |  |  |  |  |  | # So we disallow the hateful CFWS in this context for now.  Of modern mail | 
| 72 |  |  |  |  |  |  | # agents, only Apple Web Mail 2.0 is known to produce obs-phrase. | 
| 73 |  |  |  |  |  |  | # -- rjbs, 2006-11-19 | 
| 74 |  |  |  |  |  |  | my $simple_word    = qr/(?>$atom|\.|\s*"$qcontent+"\s*)/; | 
| 75 |  |  |  |  |  |  | my $obs_phrase     = qr/(?>$simple_word+)/; | 
| 76 |  |  |  |  |  |  |  | 
| 77 |  |  |  |  |  |  | my $phrase         = qr/$obs_phrase|(?>$word+)/; | 
| 78 |  |  |  |  |  |  |  | 
| 79 |  |  |  |  |  |  | my $local_part     = qr/$dot_atom|$quoted_string/; | 
| 80 |  |  |  |  |  |  | my $dtext          = qr/[^\[\]\\]/; | 
| 81 |  |  |  |  |  |  | my $dcontent       = qr/$dtext|$quoted_pair/; | 
| 82 |  |  |  |  |  |  | my $domain_literal = qr/(?>$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*)/; | 
| 83 |  |  |  |  |  |  | my $domain         = qr/$dot_atom|$domain_literal/; | 
| 84 |  |  |  |  |  |  |  | 
| 85 |  |  |  |  |  |  | my $display_name   = $phrase; | 
| 86 |  |  |  |  |  |  |  | 
| 87 |  |  |  |  |  |  | #pod =head2 Package Variables | 
| 88 |  |  |  |  |  |  | #pod | 
| 89 |  |  |  |  |  |  | #pod B  Email isn't easy (if even possible) to parse with a regex, I | 
| 90 |  |  |  |  |  |  | #pod least> if you're on a C prior to 5.10.0.  Providing regular expressions | 
| 91 |  |  |  |  |  |  | #pod for use by other programs isn't a great idea, because it makes it hard to | 
| 92 |  |  |  |  |  |  | #pod improve the parser without breaking the "it's a regex" feature.  Using these | 
| 93 |  |  |  |  |  |  | #pod regular expressions is not encouraged, and methods like C<< | 
| 94 |  |  |  |  |  |  | #pod Email::Address->is_addr_spec >> should be provided in the future. | 
| 95 |  |  |  |  |  |  | #pod | 
| 96 |  |  |  |  |  |  | #pod Several regular expressions used in this package are useful to others. | 
| 97 |  |  |  |  |  |  | #pod For convenience, these variables are declared as package variables that | 
| 98 |  |  |  |  |  |  | #pod you may access from your program. | 
| 99 |  |  |  |  |  |  | #pod | 
| 100 |  |  |  |  |  |  | #pod These regular expressions conform to the rules specified in RFC 2822. | 
| 101 |  |  |  |  |  |  | #pod | 
| 102 |  |  |  |  |  |  | #pod You can access these variables using the full namespace. If you want | 
| 103 |  |  |  |  |  |  | #pod short names, define them yourself. | 
| 104 |  |  |  |  |  |  | #pod | 
| 105 |  |  |  |  |  |  | #pod   my $addr_spec = $Email::Address::addr_spec; | 
| 106 |  |  |  |  |  |  | #pod | 
| 107 |  |  |  |  |  |  | #pod =over 4 | 
| 108 |  |  |  |  |  |  | #pod | 
| 109 |  |  |  |  |  |  | #pod =item $Email::Address::addr_spec | 
| 110 |  |  |  |  |  |  | #pod | 
| 111 |  |  |  |  |  |  | #pod This regular expression defined what an email address is allowed to | 
| 112 |  |  |  |  |  |  | #pod look like. | 
| 113 |  |  |  |  |  |  | #pod | 
| 114 |  |  |  |  |  |  | #pod =item $Email::Address::angle_addr | 
| 115 |  |  |  |  |  |  | #pod | 
| 116 |  |  |  |  |  |  | #pod This regular expression defines an C<$addr_spec> wrapped in angle | 
| 117 |  |  |  |  |  |  | #pod brackets. | 
| 118 |  |  |  |  |  |  | #pod | 
| 119 |  |  |  |  |  |  | #pod =item $Email::Address::name_addr | 
| 120 |  |  |  |  |  |  | #pod | 
| 121 |  |  |  |  |  |  | #pod This regular expression defines what an email address can look like | 
| 122 |  |  |  |  |  |  | #pod with an optional preceding display name, also known as the C. | 
| 123 |  |  |  |  |  |  | #pod | 
| 124 |  |  |  |  |  |  | #pod =item $Email::Address::mailbox | 
| 125 |  |  |  |  |  |  | #pod | 
| 126 |  |  |  |  |  |  | #pod This is the complete regular expression defining an RFC 2822 email | 
| 127 |  |  |  |  |  |  | #pod address with an optional preceding display name and optional | 
| 128 |  |  |  |  |  |  | #pod following comment. | 
| 129 |  |  |  |  |  |  | #pod | 
| 130 |  |  |  |  |  |  | #pod =back | 
| 131 |  |  |  |  |  |  | #pod | 
| 132 |  |  |  |  |  |  | #pod =cut | 
| 133 |  |  |  |  |  |  |  | 
| 134 |  |  |  |  |  |  | our $addr_spec  = qr/$local_part\@$domain/; | 
| 135 |  |  |  |  |  |  | our $angle_addr = qr/(?>$cfws*<$addr_spec>$cfws*)/; | 
| 136 |  |  |  |  |  |  | our $name_addr  = qr/(?>$display_name?)$angle_addr/; | 
| 137 |  |  |  |  |  |  | our $mailbox    = qr/(?:$name_addr|$addr_spec)(?>$comment*)/; | 
| 138 |  |  |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | sub _PHRASE   () { 0 } | 
| 140 |  |  |  |  |  |  | sub _ADDRESS  () { 1 } | 
| 141 |  |  |  |  |  |  | sub _COMMENT  () { 2 } | 
| 142 |  |  |  |  |  |  | sub _ORIGINAL () { 3 } | 
| 143 |  |  |  |  |  |  | sub _IN_CACHE () { 4 } | 
| 144 |  |  |  |  |  |  |  | 
| 145 |  |  |  |  |  |  | sub __dump { | 
| 146 |  |  |  |  |  |  | return { | 
| 147 | 0 |  |  | 0 |  | 0 | phrase   => $_[0][_PHRASE], | 
| 148 |  |  |  |  |  |  | address  => $_[0][_ADDRESS], | 
| 149 |  |  |  |  |  |  | comment  => $_[0][_COMMENT], | 
| 150 |  |  |  |  |  |  | original => $_[0][_ORIGINAL], | 
| 151 |  |  |  |  |  |  | } | 
| 152 |  |  |  |  |  |  | } | 
| 153 |  |  |  |  |  |  |  | 
| 154 |  |  |  |  |  |  | #pod =head2 Class Methods | 
| 155 |  |  |  |  |  |  | #pod | 
| 156 |  |  |  |  |  |  | #pod =over | 
| 157 |  |  |  |  |  |  | #pod | 
| 158 |  |  |  |  |  |  | #pod =item parse | 
| 159 |  |  |  |  |  |  | #pod | 
| 160 |  |  |  |  |  |  | #pod   my @addrs = Email::Address->parse( | 
| 161 |  |  |  |  |  |  | #pod     q[me@local, Casey , "Casey"  (West)] | 
| 162 |  |  |  |  |  |  | #pod   ); | 
| 163 |  |  |  |  |  |  | #pod | 
| 164 |  |  |  |  |  |  | #pod B This is where that vulnerability mentioned above lies.  Do not use | 
| 165 |  |  |  |  |  |  | #pod this method with untrusted user input. | 
| 166 |  |  |  |  |  |  | #pod | 
| 167 |  |  |  |  |  |  | #pod Use method L | 
| 168 |  |  |  |  |  |  | #pod instead. | 
| 169 |  |  |  |  |  |  | #pod | 
| 170 |  |  |  |  |  |  | #pod This method returns a list of C objects it finds in the input | 
| 171 |  |  |  |  |  |  | #pod string.  B that it returns a list, and expects that it may find | 
| 172 |  |  |  |  |  |  | #pod multiple addresses.  The behavior in scalar context is undefined. | 
| 173 |  |  |  |  |  |  | #pod | 
| 174 |  |  |  |  |  |  | #pod The specification for an email address allows for infinitely nestable comments. | 
| 175 |  |  |  |  |  |  | #pod That's nice in theory, but a little over done.  By default this module allows | 
| 176 |  |  |  |  |  |  | #pod for one (C<1>) level of nested comments. If you think you need more, modify the | 
| 177 |  |  |  |  |  |  | #pod C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow more. | 
| 178 |  |  |  |  |  |  | #pod | 
| 179 |  |  |  |  |  |  | #pod   $Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep | 
| 180 |  |  |  |  |  |  | #pod | 
| 181 |  |  |  |  |  |  | #pod The reason for this hardly-limiting limitation is simple: efficiency. | 
| 182 |  |  |  |  |  |  | #pod | 
| 183 |  |  |  |  |  |  | #pod Long strings of whitespace can be problematic for this module to parse, a bug | 
| 184 |  |  |  |  |  |  | #pod which has not yet been adequately addressed.  The default behavior is now to | 
| 185 |  |  |  |  |  |  | #pod collapse multiple spaces into a single space, which avoids this problem.  To | 
| 186 |  |  |  |  |  |  | #pod prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero.  This | 
| 187 |  |  |  |  |  |  | #pod variable will go away when the bug is resolved properly. | 
| 188 |  |  |  |  |  |  | #pod | 
| 189 |  |  |  |  |  |  | #pod In accordance with RFC 822 and its descendants, this module demands that email | 
| 190 |  |  |  |  |  |  | #pod addresses be ASCII only.  Any non-ASCII content in the parsed addresses will | 
| 191 |  |  |  |  |  |  | #pod cause the parser to return no results. | 
| 192 |  |  |  |  |  |  | #pod | 
| 193 |  |  |  |  |  |  | #pod =cut | 
| 194 |  |  |  |  |  |  |  | 
| 195 |  |  |  |  |  |  | our (%PARSE_CACHE, %FORMAT_CACHE, %NAME_CACHE); | 
| 196 |  |  |  |  |  |  | my $NOCACHE; | 
| 197 |  |  |  |  |  |  |  | 
| 198 |  |  |  |  |  |  | sub __get_cached_parse { | 
| 199 | 118 | 50 |  | 118 |  | 251 | return if $NOCACHE; | 
| 200 |  |  |  |  |  |  |  | 
| 201 | 118 |  |  |  |  | 229 | my ($class, $line) = @_; | 
| 202 |  |  |  |  |  |  |  | 
| 203 | 118 | 100 |  |  |  | 334 | return @{$PARSE_CACHE{$line}} if exists $PARSE_CACHE{$line}; | 
|  | 2 |  |  |  |  | 7 |  | 
| 204 | 116 |  |  |  |  | 337 | return; | 
| 205 |  |  |  |  |  |  | } | 
| 206 |  |  |  |  |  |  |  | 
| 207 |  |  |  |  |  |  | sub __cache_parse { | 
| 208 | 116 | 50 |  | 116 |  | 241 | return if $NOCACHE; | 
| 209 |  |  |  |  |  |  |  | 
| 210 | 116 |  |  |  |  | 215 | my ($class, $line, $addrs) = @_; | 
| 211 |  |  |  |  |  |  |  | 
| 212 | 116 |  |  |  |  | 310 | $PARSE_CACHE{$line} = $addrs; | 
| 213 |  |  |  |  |  |  | } | 
| 214 |  |  |  |  |  |  |  | 
| 215 |  |  |  |  |  |  | sub parse { | 
| 216 | 119 |  |  | 119 | 1 | 322421 | my ($class, $line) = @_; | 
| 217 | 119 | 100 |  |  |  | 397 | return unless $line; | 
| 218 |  |  |  |  |  |  |  | 
| 219 | 118 | 50 |  |  |  | 825 | $line =~ s/[ \t]+/ /g if $COLLAPSE_SPACES; | 
| 220 |  |  |  |  |  |  |  | 
| 221 | 118 | 100 |  |  |  | 418 | if (my @cached = $class->__get_cached_parse($line)) { | 
| 222 | 2 |  |  |  |  | 6 | return @cached; | 
| 223 |  |  |  |  |  |  | } | 
| 224 |  |  |  |  |  |  |  | 
| 225 | 116 |  |  |  |  | 186 | my %mailboxes; | 
| 226 | 116 |  |  |  |  | 207 | my $str = $line; | 
| 227 | 116 | 100 |  |  |  | 6657 | $str =~ s!($name_addr(?>$comment*))!$mailboxes{pos($str)} = $1; ',' x length $1!ego | 
|  | 198 |  |  |  |  | 678 |  | 
|  | 198 |  |  |  |  | 1472 |  | 
| 228 |  |  |  |  |  |  | if $str =~ /$angle_addr/; | 
| 229 | 116 |  |  |  |  | 3209 | $str =~ s!($addr_spec(?>$comment*))!$mailboxes{pos($str)} = $1; ',' x length $1!ego; | 
|  | 46 |  |  |  |  | 143 |  | 
|  | 46 |  |  |  |  | 233 |  | 
| 230 | 116 |  |  |  |  | 527 | my @mailboxes = map { $mailboxes{$_} } sort { $a <=> $b } keys %mailboxes; | 
|  | 244 |  |  |  |  | 520 |  | 
|  | 195 |  |  |  |  | 449 |  | 
| 231 |  |  |  |  |  |  |  | 
| 232 | 116 |  |  |  |  | 184 | my @addrs; | 
| 233 | 116 |  |  |  |  | 233 | foreach (@mailboxes) { | 
| 234 | 244 |  |  |  |  | 319 | my $original = $_; | 
| 235 |  |  |  |  |  |  |  | 
| 236 | 244 |  |  |  |  | 650 | my @comments = /($comment)/go; | 
| 237 | 244 | 100 |  |  |  | 456 | s/$comment//go if @comments; | 
| 238 |  |  |  |  |  |  |  | 
| 239 | 244 |  |  |  |  | 362 | my ($user, $host, $com); | 
| 240 | 244 | 100 |  |  |  | 3156 | ($user, $host) = ($1, $2) if s/<($local_part)\@($domain)>\s*\z//o; | 
| 241 | 244 | 100 | 66 |  |  | 967 | if (! defined($user) || ! defined($host)) { | 
| 242 | 46 |  |  |  |  | 1379 | s/($local_part)\@($domain)//o; | 
| 243 | 46 |  |  |  |  | 181 | ($user, $host) = ($1, $2); | 
| 244 |  |  |  |  |  |  | } | 
| 245 |  |  |  |  |  |  |  | 
| 246 | 10 | 100 |  | 10 |  | 5072 | next if $user =~ /\P{ASCII}/; | 
|  | 10 |  |  |  |  | 124 |  | 
|  | 10 |  |  |  |  | 131 |  | 
|  | 244 |  |  |  |  | 576 |  | 
| 247 | 240 | 100 |  |  |  | 461 | next if $host =~ /\P{ASCII}/; | 
| 248 |  |  |  |  |  |  |  | 
| 249 | 239 |  |  |  |  | 2643 | my ($phrase)       = /($display_name)/o; | 
| 250 |  |  |  |  |  |  |  | 
| 251 | 239 |  |  |  |  | 479 | for ( $phrase, $host, $user, @comments ) { | 
| 252 | 727 | 100 |  |  |  | 1095 | next unless defined $_; | 
| 253 | 651 |  |  |  |  | 1082 | s/^\s+//; | 
| 254 | 651 |  |  |  |  | 1167 | s/\s+$//; | 
| 255 | 651 | 50 |  |  |  | 1097 | $_ = undef unless length $_; | 
| 256 |  |  |  |  |  |  | } | 
| 257 |  |  |  |  |  |  |  | 
| 258 | 239 | 100 |  |  |  | 488 | $phrase =~ s/\\(.)/$1/g if $phrase; | 
| 259 |  |  |  |  |  |  |  | 
| 260 | 239 |  |  |  |  | 382 | my $new_comment = join q{ }, @comments; | 
| 261 | 239 |  |  |  |  | 766 | push @addrs, | 
| 262 |  |  |  |  |  |  | $class->new($phrase, "$user\@$host", $new_comment, $original); | 
| 263 | 239 |  |  |  |  | 958 | $addrs[-1]->[_IN_CACHE] = [ \$line, $#addrs ] | 
| 264 |  |  |  |  |  |  | } | 
| 265 |  |  |  |  |  |  |  | 
| 266 | 116 |  |  |  |  | 375 | $class->__cache_parse($line, \@addrs); | 
| 267 | 116 |  |  |  |  | 506 | return @addrs; | 
| 268 |  |  |  |  |  |  | } | 
| 269 |  |  |  |  |  |  |  | 
| 270 |  |  |  |  |  |  | #pod =item new | 
| 271 |  |  |  |  |  |  | #pod | 
| 272 |  |  |  |  |  |  | #pod   my $address = Email::Address->new(undef, 'casey@local'); | 
| 273 |  |  |  |  |  |  | #pod   my $address = Email::Address->new('Casey West', 'casey@local'); | 
| 274 |  |  |  |  |  |  | #pod   my $address = Email::Address->new(undef, 'casey@local', '(Casey)'); | 
| 275 |  |  |  |  |  |  | #pod | 
| 276 |  |  |  |  |  |  | #pod Constructs and returns a new C object. Takes four | 
| 277 |  |  |  |  |  |  | #pod positional arguments: phrase, email, and comment, and original string. | 
| 278 |  |  |  |  |  |  | #pod | 
| 279 |  |  |  |  |  |  | #pod The original string should only really be set using C. | 
| 280 |  |  |  |  |  |  | #pod | 
| 281 |  |  |  |  |  |  | #pod =cut | 
| 282 |  |  |  |  |  |  |  | 
| 283 |  |  |  |  |  |  | sub new { | 
| 284 | 693 |  |  | 693 | 1 | 259457 | my ($class, $phrase, $email, $comment, $orig) = @_; | 
| 285 | 693 | 100 |  |  |  | 1799 | $phrase =~ s/\A"(.+)"\z/$1/ if $phrase; | 
| 286 |  |  |  |  |  |  |  | 
| 287 | 693 |  |  |  |  | 2198 | bless [ $phrase, $email, $comment, $orig ] => $class; | 
| 288 |  |  |  |  |  |  | } | 
| 289 |  |  |  |  |  |  |  | 
| 290 |  |  |  |  |  |  | #pod =item purge_cache | 
| 291 |  |  |  |  |  |  | #pod | 
| 292 |  |  |  |  |  |  | #pod   Email::Address->purge_cache; | 
| 293 |  |  |  |  |  |  | #pod | 
| 294 |  |  |  |  |  |  | #pod One way this module stays fast is with internal caches. Caches live | 
| 295 |  |  |  |  |  |  | #pod in memory and there is the remote possibility that you will have a | 
| 296 |  |  |  |  |  |  | #pod memory problem. On the off chance that you think you're one of those | 
| 297 |  |  |  |  |  |  | #pod people, this class method will empty those caches. | 
| 298 |  |  |  |  |  |  | #pod | 
| 299 |  |  |  |  |  |  | #pod I've loaded over 12000 objects and not encountered a memory problem. | 
| 300 |  |  |  |  |  |  | #pod | 
| 301 |  |  |  |  |  |  | #pod =cut | 
| 302 |  |  |  |  |  |  |  | 
| 303 |  |  |  |  |  |  | sub purge_cache { | 
| 304 | 0 |  |  | 0 | 1 | 0 | %NAME_CACHE   = (); | 
| 305 | 0 |  |  |  |  | 0 | %FORMAT_CACHE = (); | 
| 306 | 0 |  |  |  |  | 0 | %PARSE_CACHE  = (); | 
| 307 |  |  |  |  |  |  | } | 
| 308 |  |  |  |  |  |  |  | 
| 309 |  |  |  |  |  |  | #pod =item disable_cache | 
| 310 |  |  |  |  |  |  | #pod | 
| 311 |  |  |  |  |  |  | #pod =item enable_cache | 
| 312 |  |  |  |  |  |  | #pod | 
| 313 |  |  |  |  |  |  | #pod   Email::Address->disable_cache if memory_low(); | 
| 314 |  |  |  |  |  |  | #pod | 
| 315 |  |  |  |  |  |  | #pod If you'd rather not cache address parses at all, you can disable (and | 
| 316 |  |  |  |  |  |  | #pod re-enable) the Email::Address cache with these methods.  The cache is enabled | 
| 317 |  |  |  |  |  |  | #pod by default. | 
| 318 |  |  |  |  |  |  | #pod | 
| 319 |  |  |  |  |  |  | #pod =cut | 
| 320 |  |  |  |  |  |  |  | 
| 321 |  |  |  |  |  |  | sub disable_cache { | 
| 322 | 0 |  |  | 0 | 1 | 0 | my ($class) = @_; | 
| 323 | 0 |  |  |  |  | 0 | $class->purge_cache; | 
| 324 | 0 |  |  |  |  | 0 | $NOCACHE = 1; | 
| 325 |  |  |  |  |  |  | } | 
| 326 |  |  |  |  |  |  |  | 
| 327 |  |  |  |  |  |  | sub enable_cache { | 
| 328 | 0 |  |  | 0 | 1 | 0 | $NOCACHE = undef; | 
| 329 |  |  |  |  |  |  | } | 
| 330 |  |  |  |  |  |  |  | 
| 331 |  |  |  |  |  |  | #pod =back | 
| 332 |  |  |  |  |  |  | #pod | 
| 333 |  |  |  |  |  |  | #pod =head2 Instance Methods | 
| 334 |  |  |  |  |  |  | #pod | 
| 335 |  |  |  |  |  |  | #pod =over 4 | 
| 336 |  |  |  |  |  |  | #pod | 
| 337 |  |  |  |  |  |  | #pod =item phrase | 
| 338 |  |  |  |  |  |  | #pod | 
| 339 |  |  |  |  |  |  | #pod   my $phrase = $address->phrase; | 
| 340 |  |  |  |  |  |  | #pod   $address->phrase( "Me oh my" ); | 
| 341 |  |  |  |  |  |  | #pod | 
| 342 |  |  |  |  |  |  | #pod Accessor and mutator for the phrase portion of an address. | 
| 343 |  |  |  |  |  |  | #pod | 
| 344 |  |  |  |  |  |  | #pod =item address | 
| 345 |  |  |  |  |  |  | #pod | 
| 346 |  |  |  |  |  |  | #pod   my $addr = $address->address; | 
| 347 |  |  |  |  |  |  | #pod   $addr->address( "me@PROTECTED.com" ); | 
| 348 |  |  |  |  |  |  | #pod | 
| 349 |  |  |  |  |  |  | #pod Accessor and mutator for the address portion of an address. | 
| 350 |  |  |  |  |  |  | #pod | 
| 351 |  |  |  |  |  |  | #pod =item comment | 
| 352 |  |  |  |  |  |  | #pod | 
| 353 |  |  |  |  |  |  | #pod   my $comment = $address->comment; | 
| 354 |  |  |  |  |  |  | #pod   $address->comment( "(Work address)" ); | 
| 355 |  |  |  |  |  |  | #pod | 
| 356 |  |  |  |  |  |  | #pod Accessor and mutator for the comment portion of an address. | 
| 357 |  |  |  |  |  |  | #pod | 
| 358 |  |  |  |  |  |  | #pod =item original | 
| 359 |  |  |  |  |  |  | #pod | 
| 360 |  |  |  |  |  |  | #pod   my $orig = $address->original; | 
| 361 |  |  |  |  |  |  | #pod | 
| 362 |  |  |  |  |  |  | #pod Accessor for the original address found when parsing, or passed | 
| 363 |  |  |  |  |  |  | #pod to C. | 
| 364 |  |  |  |  |  |  | #pod | 
| 365 |  |  |  |  |  |  | #pod =item host | 
| 366 |  |  |  |  |  |  | #pod | 
| 367 |  |  |  |  |  |  | #pod   my $host = $address->host; | 
| 368 |  |  |  |  |  |  | #pod | 
| 369 |  |  |  |  |  |  | #pod Accessor for the host portion of an address's address. | 
| 370 |  |  |  |  |  |  | #pod | 
| 371 |  |  |  |  |  |  | #pod =item user | 
| 372 |  |  |  |  |  |  | #pod | 
| 373 |  |  |  |  |  |  | #pod   my $user = $address->user; | 
| 374 |  |  |  |  |  |  | #pod | 
| 375 |  |  |  |  |  |  | #pod Accessor for the user portion of an address's address. | 
| 376 |  |  |  |  |  |  | #pod | 
| 377 |  |  |  |  |  |  | #pod =cut | 
| 378 |  |  |  |  |  |  |  | 
| 379 |  |  |  |  |  |  | BEGIN { | 
| 380 | 10 |  |  | 10 |  | 51 | my %_INDEX = ( | 
| 381 |  |  |  |  |  |  | phrase   => _PHRASE, | 
| 382 |  |  |  |  |  |  | address  => _ADDRESS, | 
| 383 |  |  |  |  |  |  | comment  => _COMMENT, | 
| 384 |  |  |  |  |  |  | original => _ORIGINAL, | 
| 385 |  |  |  |  |  |  | ); | 
| 386 |  |  |  |  |  |  |  | 
| 387 | 10 |  |  |  |  | 47 | for my $method (keys %_INDEX) { | 
| 388 | 10 |  |  | 10 |  | 183296 | no strict 'refs'; | 
|  | 10 |  |  |  |  | 22 |  | 
|  | 10 |  |  |  |  | 1377 |  | 
| 389 | 40 |  |  |  |  | 65 | my $index = $_INDEX{ $method }; | 
| 390 |  |  |  |  |  |  | *$method = sub { | 
| 391 | 229 | 100 |  | 229 |  | 145882 | if ($_[1]) { | 
| 392 | 1 | 50 |  |  |  | 5 | if ($_[0][_IN_CACHE]) { | 
| 393 | 1 |  |  |  |  | 2 | my $replicant = bless [ @{$_[0]} ] => ref $_[0]; | 
|  | 1 |  |  |  |  | 4 |  | 
| 394 | 1 |  |  |  |  | 4 | $PARSE_CACHE{ ${ $_[0][_IN_CACHE][0] } }[ $_[0][_IN_CACHE][1] ] | 
|  | 1 |  |  |  |  | 3 |  | 
| 395 |  |  |  |  |  |  | = $replicant; | 
| 396 | 1 |  |  |  |  | 3 | $_[0][_IN_CACHE] = undef; | 
| 397 |  |  |  |  |  |  | } | 
| 398 | 1 |  |  |  |  | 2 | $_[0]->[ $index ] = $_[1]; | 
| 399 |  |  |  |  |  |  | } else { | 
| 400 | 228 |  |  |  |  | 829 | $_[0]->[ $index ]; | 
| 401 |  |  |  |  |  |  | } | 
| 402 | 40 |  |  |  |  | 1033 | }; | 
| 403 |  |  |  |  |  |  | } | 
| 404 |  |  |  |  |  |  | } | 
| 405 |  |  |  |  |  |  |  | 
| 406 | 0 |  |  | 0 | 1 | 0 | sub host { ($_[0]->[_ADDRESS] =~ /\@($domain)/o)[0]     } | 
| 407 | 0 |  |  | 0 | 1 | 0 | sub user { ($_[0]->[_ADDRESS] =~ /($local_part)\@/o)[0] } | 
| 408 |  |  |  |  |  |  |  | 
| 409 |  |  |  |  |  |  | #pod =pod | 
| 410 |  |  |  |  |  |  | #pod | 
| 411 |  |  |  |  |  |  | #pod =item format | 
| 412 |  |  |  |  |  |  | #pod | 
| 413 |  |  |  |  |  |  | #pod   my $printable = $address->format; | 
| 414 |  |  |  |  |  |  | #pod | 
| 415 |  |  |  |  |  |  | #pod Returns a properly formatted RFC 2822 address representing the | 
| 416 |  |  |  |  |  |  | #pod object. | 
| 417 |  |  |  |  |  |  | #pod | 
| 418 |  |  |  |  |  |  | #pod =cut | 
| 419 |  |  |  |  |  |  |  | 
| 420 |  |  |  |  |  |  | sub format { | 
| 421 | 10 |  |  | 10 | 1 | 62 | my $cache_str = do { no warnings 'uninitialized'; "@{$_[0]}" }; | 
|  | 10 |  |  | 2014 |  | 19 |  | 
|  | 10 |  |  |  |  | 3561 |  | 
|  | 2014 |  |  |  |  | 466606 |  | 
|  | 2014 |  |  |  |  | 2179 |  | 
|  | 2014 |  |  |  |  | 5150 |  | 
| 422 | 2014 | 100 |  |  |  | 6939 | return $FORMAT_CACHE{$cache_str} if exists $FORMAT_CACHE{$cache_str}; | 
| 423 | 334 |  |  |  |  | 729 | $FORMAT_CACHE{$cache_str} = $_[0]->_format; | 
| 424 |  |  |  |  |  |  | } | 
| 425 |  |  |  |  |  |  |  | 
| 426 |  |  |  |  |  |  | sub _format { | 
| 427 | 334 |  |  | 334 |  | 520 | my ($self) = @_; | 
| 428 |  |  |  |  |  |  |  | 
| 429 | 334 | 100 | 100 |  |  | 1670 | unless ( | 
|  |  |  | 100 |  |  |  |  | 
|  |  |  | 100 |  |  |  |  | 
| 430 |  |  |  |  |  |  | defined $self->[_PHRASE] && length $self->[_PHRASE] | 
| 431 |  |  |  |  |  |  | || | 
| 432 |  |  |  |  |  |  | defined $self->[_COMMENT] && length $self->[_COMMENT] | 
| 433 |  |  |  |  |  |  | ) { | 
| 434 | 86 | 100 |  |  |  | 410 | return defined $self->[_ADDRESS] ? $self->[_ADDRESS] : ''; | 
| 435 |  |  |  |  |  |  | } | 
| 436 |  |  |  |  |  |  |  | 
| 437 | 248 | 100 |  |  |  | 632 | my $comment = defined $self->[_COMMENT] ? $self->[_COMMENT] : ''; | 
| 438 | 248 | 100 | 100 |  |  | 524 | $comment = "($comment)" if length $comment and $comment !~ /\A\(.*\)\z/; | 
| 439 |  |  |  |  |  |  |  | 
| 440 | 248 | 50 |  |  |  | 483 | my $format = sprintf q{%s <%s> %s}, | 
| 441 |  |  |  |  |  |  | $self->_enquoted_phrase, | 
| 442 |  |  |  |  |  |  | (defined $self->[_ADDRESS] ? $self->[_ADDRESS] : ''), | 
| 443 |  |  |  |  |  |  | $comment; | 
| 444 |  |  |  |  |  |  |  | 
| 445 | 248 |  |  |  |  | 600 | $format =~ s/^\s+//; | 
| 446 | 248 |  |  |  |  | 906 | $format =~ s/\s+$//; | 
| 447 |  |  |  |  |  |  |  | 
| 448 | 248 |  |  |  |  | 1011 | return $format; | 
| 449 |  |  |  |  |  |  | } | 
| 450 |  |  |  |  |  |  |  | 
| 451 |  |  |  |  |  |  | sub _enquoted_phrase { | 
| 452 | 248 |  |  | 248 |  | 350 | my ($self) = @_; | 
| 453 |  |  |  |  |  |  |  | 
| 454 | 248 |  |  |  |  | 379 | my $phrase = $self->[_PHRASE]; | 
| 455 |  |  |  |  |  |  |  | 
| 456 | 248 | 100 | 66 |  |  | 733 | return '' unless defined $phrase and length $phrase; | 
| 457 |  |  |  |  |  |  |  | 
| 458 |  |  |  |  |  |  | # if it's encoded -- rjbs, 2007-02-28 | 
| 459 | 247 | 100 |  |  |  | 605 | return $phrase if $phrase =~ /\A=\?.+\?=\z/; | 
| 460 |  |  |  |  |  |  |  | 
| 461 | 246 |  |  |  |  | 429 | $phrase =~ s/\A"(.+)"\z/$1/; | 
| 462 | 246 |  |  |  |  | 472 | $phrase =~ s/([\\"])/\\$1/g; | 
| 463 |  |  |  |  |  |  |  | 
| 464 | 246 |  |  |  |  | 1310 | return qq{"$phrase"}; | 
| 465 |  |  |  |  |  |  | } | 
| 466 |  |  |  |  |  |  |  | 
| 467 |  |  |  |  |  |  | #pod =item name | 
| 468 |  |  |  |  |  |  | #pod | 
| 469 |  |  |  |  |  |  | #pod   my $name = $address->name; | 
| 470 |  |  |  |  |  |  | #pod | 
| 471 |  |  |  |  |  |  | #pod This method tries very hard to determine the name belonging to the address. | 
| 472 |  |  |  |  |  |  | #pod First the C is checked. If that doesn't work out the C | 
| 473 |  |  |  |  |  |  | #pod is looked into. If that still doesn't work out, the C portion of | 
| 474 |  |  |  |  |  |  | #pod the C is returned. | 
| 475 |  |  |  |  |  |  | #pod | 
| 476 |  |  |  |  |  |  | #pod This method does B try to massage any name it identifies and instead | 
| 477 |  |  |  |  |  |  | #pod leaves that up to someone else. Who is it to decide if someone wants their | 
| 478 |  |  |  |  |  |  | #pod name capitalized, or if they're Irish? | 
| 479 |  |  |  |  |  |  | #pod | 
| 480 |  |  |  |  |  |  | #pod =cut | 
| 481 |  |  |  |  |  |  |  | 
| 482 |  |  |  |  |  |  | sub name { | 
| 483 | 10 |  |  | 10 | 1 | 70 | my $cache_str = do { no warnings 'uninitialized'; "@{$_[0]}" }; | 
|  | 10 |  |  | 663 |  | 19 |  | 
|  | 10 |  |  |  |  | 2595 |  | 
|  | 663 |  |  |  |  | 806 |  | 
|  | 663 |  |  |  |  | 775 |  | 
|  | 663 |  |  |  |  | 1584 |  | 
| 484 | 663 | 100 |  |  |  | 1946 | return $NAME_CACHE{$cache_str} if exists $NAME_CACHE{$cache_str}; | 
| 485 |  |  |  |  |  |  |  | 
| 486 | 314 |  |  |  |  | 464 | my ($self) = @_; | 
| 487 | 314 |  |  |  |  | 394 | my $name = q{}; | 
| 488 | 314 | 100 |  |  |  | 728 | if ( $name = $self->[_PHRASE] ) { | 
|  |  | 50 |  |  |  |  |  | 
| 489 | 233 |  |  |  |  | 416 | $name =~ s/^"//; | 
| 490 | 233 |  |  |  |  | 312 | $name =~ s/"$//; | 
| 491 | 233 |  |  |  |  | 398 | $name =~ s/($quoted_pair)/substr $1, -1/goe; | 
|  | 0 |  |  |  |  | 0 |  | 
| 492 |  |  |  |  |  |  | } elsif ( $name = $self->[_COMMENT] ) { | 
| 493 | 0 |  |  |  |  | 0 | $name =~ s/^\(//; | 
| 494 | 0 |  |  |  |  | 0 | $name =~ s/\)$//; | 
| 495 | 0 |  |  |  |  | 0 | $name =~ s/($quoted_pair)/substr $1, -1/goe; | 
|  | 0 |  |  |  |  | 0 |  | 
| 496 | 0 |  |  |  |  | 0 | $name =~ s/$comment/ /go; | 
| 497 |  |  |  |  |  |  | } else { | 
| 498 | 81 |  |  |  |  | 833 | ($name) = $self->[_ADDRESS] =~ /($local_part)\@/o; | 
| 499 |  |  |  |  |  |  | } | 
| 500 | 314 |  |  |  |  | 916 | $NAME_CACHE{$cache_str} = $name; | 
| 501 |  |  |  |  |  |  | } | 
| 502 |  |  |  |  |  |  |  | 
| 503 |  |  |  |  |  |  | #pod =back | 
| 504 |  |  |  |  |  |  | #pod | 
| 505 |  |  |  |  |  |  | #pod =head2 Overloaded Operators | 
| 506 |  |  |  |  |  |  | #pod | 
| 507 |  |  |  |  |  |  | #pod =over 4 | 
| 508 |  |  |  |  |  |  | #pod | 
| 509 |  |  |  |  |  |  | #pod =item stringify | 
| 510 |  |  |  |  |  |  | #pod | 
| 511 |  |  |  |  |  |  | #pod   print "I have your email address, $address."; | 
| 512 |  |  |  |  |  |  | #pod | 
| 513 |  |  |  |  |  |  | #pod Objects stringify to C by default. It's possible that you don't | 
| 514 |  |  |  |  |  |  | #pod like that idea. Okay, then, you can change it by modifying | 
| 515 |  |  |  |  |  |  | #pod C<$Email:Address::STRINGIFY>. Please consider modifying this package | 
| 516 |  |  |  |  |  |  | #pod variable using C. You might step on someone else's toes if you | 
| 517 |  |  |  |  |  |  | #pod don't. | 
| 518 |  |  |  |  |  |  | #pod | 
| 519 |  |  |  |  |  |  | #pod   { | 
| 520 |  |  |  |  |  |  | #pod     local $Email::Address::STRINGIFY = 'host'; | 
| 521 |  |  |  |  |  |  | #pod     print "I have your address, $address."; | 
| 522 |  |  |  |  |  |  | #pod     #   geeknest.com | 
| 523 |  |  |  |  |  |  | #pod   } | 
| 524 |  |  |  |  |  |  | #pod   print "I have your address, $address."; | 
| 525 |  |  |  |  |  |  | #pod   #   "Casey West" | 
| 526 |  |  |  |  |  |  | #pod | 
| 527 |  |  |  |  |  |  | #pod Modifying this package variable is now deprecated. Subclassing is now the | 
| 528 |  |  |  |  |  |  | #pod recommended approach. | 
| 529 |  |  |  |  |  |  | #pod | 
| 530 |  |  |  |  |  |  | #pod =cut | 
| 531 |  |  |  |  |  |  |  | 
| 532 |  |  |  |  |  |  | sub as_string { | 
| 533 | 669 | 50 |  | 669 | 0 | 3319 | warn 'altering $Email::Address::STRINGIFY is deprecated; subclass instead' | 
| 534 |  |  |  |  |  |  | if $STRINGIFY ne 'format'; | 
| 535 |  |  |  |  |  |  |  | 
| 536 | 669 |  |  |  |  | 1845 | $_[0]->can($STRINGIFY)->($_[0]); | 
| 537 |  |  |  |  |  |  | } | 
| 538 |  |  |  |  |  |  |  | 
| 539 | 10 |  |  | 10 |  | 6940 | use overload '""' => 'as_string', fallback => 1; | 
|  | 10 |  |  |  |  | 5177 |  | 
|  | 10 |  |  |  |  | 61 |  | 
| 540 |  |  |  |  |  |  |  | 
| 541 |  |  |  |  |  |  | #pod =pod | 
| 542 |  |  |  |  |  |  | #pod | 
| 543 |  |  |  |  |  |  | #pod =back | 
| 544 |  |  |  |  |  |  | #pod | 
| 545 |  |  |  |  |  |  | #pod =cut | 
| 546 |  |  |  |  |  |  |  | 
| 547 |  |  |  |  |  |  | 1; | 
| 548 |  |  |  |  |  |  |  | 
| 549 |  |  |  |  |  |  | =pod | 
| 550 |  |  |  |  |  |  |  | 
| 551 |  |  |  |  |  |  | =encoding UTF-8 | 
| 552 |  |  |  |  |  |  |  | 
| 553 |  |  |  |  |  |  | =head1 NAME | 
| 554 |  |  |  |  |  |  |  | 
| 555 |  |  |  |  |  |  | Email::Address - (DEPRECATED) RFC 2822 Address Parsing and Creation | 
| 556 |  |  |  |  |  |  |  | 
| 557 |  |  |  |  |  |  | =head1 VERSION | 
| 558 |  |  |  |  |  |  |  | 
| 559 |  |  |  |  |  |  | version 1.911 | 
| 560 |  |  |  |  |  |  |  | 
| 561 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 562 |  |  |  |  |  |  |  | 
| 563 |  |  |  |  |  |  | use Email::Address; | 
| 564 |  |  |  |  |  |  |  | 
| 565 |  |  |  |  |  |  | my @addresses = Email::Address->parse($line); | 
| 566 |  |  |  |  |  |  | my $address   = Email::Address->new(Casey => 'casey@localhost'); | 
| 567 |  |  |  |  |  |  |  | 
| 568 |  |  |  |  |  |  | print $address->format; | 
| 569 |  |  |  |  |  |  |  | 
| 570 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 571 |  |  |  |  |  |  |  | 
| 572 |  |  |  |  |  |  | B This module has a vulnerability | 
| 573 |  |  |  |  |  |  | (L) | 
| 574 |  |  |  |  |  |  | which allows remote attackers to cause denial of service.   In other words, | 
| 575 |  |  |  |  |  |  | sometimes it takes way too long to process certain kinds of input.  Maybe | 
| 576 |  |  |  |  |  |  | someday this will be fixed.  Until then, use | 
| 577 |  |  |  |  |  |  | L|Email::Address::XS> instead which has backward | 
| 578 |  |  |  |  |  |  | compatible API. | 
| 579 |  |  |  |  |  |  |  | 
| 580 |  |  |  |  |  |  | This class implements a regex-based RFC 2822 parser that locates email | 
| 581 |  |  |  |  |  |  | addresses in strings and returns a list of C objects found. | 
| 582 |  |  |  |  |  |  | Alternatively you may construct objects manually. The goal of this software is | 
| 583 |  |  |  |  |  |  | to be correct, and very very fast. | 
| 584 |  |  |  |  |  |  |  | 
| 585 |  |  |  |  |  |  | =head2 Package Variables | 
| 586 |  |  |  |  |  |  |  | 
| 587 |  |  |  |  |  |  | B  Email isn't easy (if even possible) to parse with a regex, I | 
| 588 |  |  |  |  |  |  | least> if you're on a C prior to 5.10.0.  Providing regular expressions | 
| 589 |  |  |  |  |  |  | for use by other programs isn't a great idea, because it makes it hard to | 
| 590 |  |  |  |  |  |  | improve the parser without breaking the "it's a regex" feature.  Using these | 
| 591 |  |  |  |  |  |  | regular expressions is not encouraged, and methods like C<< | 
| 592 |  |  |  |  |  |  | Email::Address->is_addr_spec >> should be provided in the future. | 
| 593 |  |  |  |  |  |  |  | 
| 594 |  |  |  |  |  |  | Several regular expressions used in this package are useful to others. | 
| 595 |  |  |  |  |  |  | For convenience, these variables are declared as package variables that | 
| 596 |  |  |  |  |  |  | you may access from your program. | 
| 597 |  |  |  |  |  |  |  | 
| 598 |  |  |  |  |  |  | These regular expressions conform to the rules specified in RFC 2822. | 
| 599 |  |  |  |  |  |  |  | 
| 600 |  |  |  |  |  |  | You can access these variables using the full namespace. If you want | 
| 601 |  |  |  |  |  |  | short names, define them yourself. | 
| 602 |  |  |  |  |  |  |  | 
| 603 |  |  |  |  |  |  | my $addr_spec = $Email::Address::addr_spec; | 
| 604 |  |  |  |  |  |  |  | 
| 605 |  |  |  |  |  |  | =over 4 | 
| 606 |  |  |  |  |  |  |  | 
| 607 |  |  |  |  |  |  | =item $Email::Address::addr_spec | 
| 608 |  |  |  |  |  |  |  | 
| 609 |  |  |  |  |  |  | This regular expression defined what an email address is allowed to | 
| 610 |  |  |  |  |  |  | look like. | 
| 611 |  |  |  |  |  |  |  | 
| 612 |  |  |  |  |  |  | =item $Email::Address::angle_addr | 
| 613 |  |  |  |  |  |  |  | 
| 614 |  |  |  |  |  |  | This regular expression defines an C<$addr_spec> wrapped in angle | 
| 615 |  |  |  |  |  |  | brackets. | 
| 616 |  |  |  |  |  |  |  | 
| 617 |  |  |  |  |  |  | =item $Email::Address::name_addr | 
| 618 |  |  |  |  |  |  |  | 
| 619 |  |  |  |  |  |  | This regular expression defines what an email address can look like | 
| 620 |  |  |  |  |  |  | with an optional preceding display name, also known as the C. | 
| 621 |  |  |  |  |  |  |  | 
| 622 |  |  |  |  |  |  | =item $Email::Address::mailbox | 
| 623 |  |  |  |  |  |  |  | 
| 624 |  |  |  |  |  |  | This is the complete regular expression defining an RFC 2822 email | 
| 625 |  |  |  |  |  |  | address with an optional preceding display name and optional | 
| 626 |  |  |  |  |  |  | following comment. | 
| 627 |  |  |  |  |  |  |  | 
| 628 |  |  |  |  |  |  | =back | 
| 629 |  |  |  |  |  |  |  | 
| 630 |  |  |  |  |  |  | =head2 Class Methods | 
| 631 |  |  |  |  |  |  |  | 
| 632 |  |  |  |  |  |  | =over | 
| 633 |  |  |  |  |  |  |  | 
| 634 |  |  |  |  |  |  | =item parse | 
| 635 |  |  |  |  |  |  |  | 
| 636 |  |  |  |  |  |  | my @addrs = Email::Address->parse( | 
| 637 |  |  |  |  |  |  | q[me@local, Casey , "Casey"  (West)] | 
| 638 |  |  |  |  |  |  | ); | 
| 639 |  |  |  |  |  |  |  | 
| 640 |  |  |  |  |  |  | B This is where that vulnerability mentioned above lies.  Do not use | 
| 641 |  |  |  |  |  |  | this method with untrusted user input. | 
| 642 |  |  |  |  |  |  |  | 
| 643 |  |  |  |  |  |  | Use method L | 
| 644 |  |  |  |  |  |  | instead. | 
| 645 |  |  |  |  |  |  |  | 
| 646 |  |  |  |  |  |  | This method returns a list of C objects it finds in the input | 
| 647 |  |  |  |  |  |  | string.  B that it returns a list, and expects that it may find | 
| 648 |  |  |  |  |  |  | multiple addresses.  The behavior in scalar context is undefined. | 
| 649 |  |  |  |  |  |  |  | 
| 650 |  |  |  |  |  |  | The specification for an email address allows for infinitely nestable comments. | 
| 651 |  |  |  |  |  |  | That's nice in theory, but a little over done.  By default this module allows | 
| 652 |  |  |  |  |  |  | for one (C<1>) level of nested comments. If you think you need more, modify the | 
| 653 |  |  |  |  |  |  | C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow more. | 
| 654 |  |  |  |  |  |  |  | 
| 655 |  |  |  |  |  |  | $Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep | 
| 656 |  |  |  |  |  |  |  | 
| 657 |  |  |  |  |  |  | The reason for this hardly-limiting limitation is simple: efficiency. | 
| 658 |  |  |  |  |  |  |  | 
| 659 |  |  |  |  |  |  | Long strings of whitespace can be problematic for this module to parse, a bug | 
| 660 |  |  |  |  |  |  | which has not yet been adequately addressed.  The default behavior is now to | 
| 661 |  |  |  |  |  |  | collapse multiple spaces into a single space, which avoids this problem.  To | 
| 662 |  |  |  |  |  |  | prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero.  This | 
| 663 |  |  |  |  |  |  | variable will go away when the bug is resolved properly. | 
| 664 |  |  |  |  |  |  |  | 
| 665 |  |  |  |  |  |  | In accordance with RFC 822 and its descendants, this module demands that email | 
| 666 |  |  |  |  |  |  | addresses be ASCII only.  Any non-ASCII content in the parsed addresses will | 
| 667 |  |  |  |  |  |  | cause the parser to return no results. | 
| 668 |  |  |  |  |  |  |  | 
| 669 |  |  |  |  |  |  | =item new | 
| 670 |  |  |  |  |  |  |  | 
| 671 |  |  |  |  |  |  | my $address = Email::Address->new(undef, 'casey@local'); | 
| 672 |  |  |  |  |  |  | my $address = Email::Address->new('Casey West', 'casey@local'); | 
| 673 |  |  |  |  |  |  | my $address = Email::Address->new(undef, 'casey@local', '(Casey)'); | 
| 674 |  |  |  |  |  |  |  | 
| 675 |  |  |  |  |  |  | Constructs and returns a new C object. Takes four | 
| 676 |  |  |  |  |  |  | positional arguments: phrase, email, and comment, and original string. | 
| 677 |  |  |  |  |  |  |  | 
| 678 |  |  |  |  |  |  | The original string should only really be set using C. | 
| 679 |  |  |  |  |  |  |  | 
| 680 |  |  |  |  |  |  | =item purge_cache | 
| 681 |  |  |  |  |  |  |  | 
| 682 |  |  |  |  |  |  | Email::Address->purge_cache; | 
| 683 |  |  |  |  |  |  |  | 
| 684 |  |  |  |  |  |  | One way this module stays fast is with internal caches. Caches live | 
| 685 |  |  |  |  |  |  | in memory and there is the remote possibility that you will have a | 
| 686 |  |  |  |  |  |  | memory problem. On the off chance that you think you're one of those | 
| 687 |  |  |  |  |  |  | people, this class method will empty those caches. | 
| 688 |  |  |  |  |  |  |  | 
| 689 |  |  |  |  |  |  | I've loaded over 12000 objects and not encountered a memory problem. | 
| 690 |  |  |  |  |  |  |  | 
| 691 |  |  |  |  |  |  | =item disable_cache | 
| 692 |  |  |  |  |  |  |  | 
| 693 |  |  |  |  |  |  | =item enable_cache | 
| 694 |  |  |  |  |  |  |  | 
| 695 |  |  |  |  |  |  | Email::Address->disable_cache if memory_low(); | 
| 696 |  |  |  |  |  |  |  | 
| 697 |  |  |  |  |  |  | If you'd rather not cache address parses at all, you can disable (and | 
| 698 |  |  |  |  |  |  | re-enable) the Email::Address cache with these methods.  The cache is enabled | 
| 699 |  |  |  |  |  |  | by default. | 
| 700 |  |  |  |  |  |  |  | 
| 701 |  |  |  |  |  |  | =back | 
| 702 |  |  |  |  |  |  |  | 
| 703 |  |  |  |  |  |  | =head2 Instance Methods | 
| 704 |  |  |  |  |  |  |  | 
| 705 |  |  |  |  |  |  | =over 4 | 
| 706 |  |  |  |  |  |  |  | 
| 707 |  |  |  |  |  |  | =item phrase | 
| 708 |  |  |  |  |  |  |  | 
| 709 |  |  |  |  |  |  | my $phrase = $address->phrase; | 
| 710 |  |  |  |  |  |  | $address->phrase( "Me oh my" ); | 
| 711 |  |  |  |  |  |  |  | 
| 712 |  |  |  |  |  |  | Accessor and mutator for the phrase portion of an address. | 
| 713 |  |  |  |  |  |  |  | 
| 714 |  |  |  |  |  |  | =item address | 
| 715 |  |  |  |  |  |  |  | 
| 716 |  |  |  |  |  |  | my $addr = $address->address; | 
| 717 |  |  |  |  |  |  | $addr->address( "me@PROTECTED.com" ); | 
| 718 |  |  |  |  |  |  |  | 
| 719 |  |  |  |  |  |  | Accessor and mutator for the address portion of an address. | 
| 720 |  |  |  |  |  |  |  | 
| 721 |  |  |  |  |  |  | =item comment | 
| 722 |  |  |  |  |  |  |  | 
| 723 |  |  |  |  |  |  | my $comment = $address->comment; | 
| 724 |  |  |  |  |  |  | $address->comment( "(Work address)" ); | 
| 725 |  |  |  |  |  |  |  | 
| 726 |  |  |  |  |  |  | Accessor and mutator for the comment portion of an address. | 
| 727 |  |  |  |  |  |  |  | 
| 728 |  |  |  |  |  |  | =item original | 
| 729 |  |  |  |  |  |  |  | 
| 730 |  |  |  |  |  |  | my $orig = $address->original; | 
| 731 |  |  |  |  |  |  |  | 
| 732 |  |  |  |  |  |  | Accessor for the original address found when parsing, or passed | 
| 733 |  |  |  |  |  |  | to C. | 
| 734 |  |  |  |  |  |  |  | 
| 735 |  |  |  |  |  |  | =item host | 
| 736 |  |  |  |  |  |  |  | 
| 737 |  |  |  |  |  |  | my $host = $address->host; | 
| 738 |  |  |  |  |  |  |  | 
| 739 |  |  |  |  |  |  | Accessor for the host portion of an address's address. | 
| 740 |  |  |  |  |  |  |  | 
| 741 |  |  |  |  |  |  | =item user | 
| 742 |  |  |  |  |  |  |  | 
| 743 |  |  |  |  |  |  | my $user = $address->user; | 
| 744 |  |  |  |  |  |  |  | 
| 745 |  |  |  |  |  |  | Accessor for the user portion of an address's address. | 
| 746 |  |  |  |  |  |  |  | 
| 747 |  |  |  |  |  |  | =item format | 
| 748 |  |  |  |  |  |  |  | 
| 749 |  |  |  |  |  |  | my $printable = $address->format; | 
| 750 |  |  |  |  |  |  |  | 
| 751 |  |  |  |  |  |  | Returns a properly formatted RFC 2822 address representing the | 
| 752 |  |  |  |  |  |  | object. | 
| 753 |  |  |  |  |  |  |  | 
| 754 |  |  |  |  |  |  | =item name | 
| 755 |  |  |  |  |  |  |  | 
| 756 |  |  |  |  |  |  | my $name = $address->name; | 
| 757 |  |  |  |  |  |  |  | 
| 758 |  |  |  |  |  |  | This method tries very hard to determine the name belonging to the address. | 
| 759 |  |  |  |  |  |  | First the C is checked. If that doesn't work out the C | 
| 760 |  |  |  |  |  |  | is looked into. If that still doesn't work out, the C portion of | 
| 761 |  |  |  |  |  |  | the C is returned. | 
| 762 |  |  |  |  |  |  |  | 
| 763 |  |  |  |  |  |  | This method does B try to massage any name it identifies and instead | 
| 764 |  |  |  |  |  |  | leaves that up to someone else. Who is it to decide if someone wants their | 
| 765 |  |  |  |  |  |  | name capitalized, or if they're Irish? | 
| 766 |  |  |  |  |  |  |  | 
| 767 |  |  |  |  |  |  | =back | 
| 768 |  |  |  |  |  |  |  | 
| 769 |  |  |  |  |  |  | =head2 Overloaded Operators | 
| 770 |  |  |  |  |  |  |  | 
| 771 |  |  |  |  |  |  | =over 4 | 
| 772 |  |  |  |  |  |  |  | 
| 773 |  |  |  |  |  |  | =item stringify | 
| 774 |  |  |  |  |  |  |  | 
| 775 |  |  |  |  |  |  | print "I have your email address, $address."; | 
| 776 |  |  |  |  |  |  |  | 
| 777 |  |  |  |  |  |  | Objects stringify to C by default. It's possible that you don't | 
| 778 |  |  |  |  |  |  | like that idea. Okay, then, you can change it by modifying | 
| 779 |  |  |  |  |  |  | C<$Email:Address::STRINGIFY>. Please consider modifying this package | 
| 780 |  |  |  |  |  |  | variable using C. You might step on someone else's toes if you | 
| 781 |  |  |  |  |  |  | don't. | 
| 782 |  |  |  |  |  |  |  | 
| 783 |  |  |  |  |  |  | { | 
| 784 |  |  |  |  |  |  | local $Email::Address::STRINGIFY = 'host'; | 
| 785 |  |  |  |  |  |  | print "I have your address, $address."; | 
| 786 |  |  |  |  |  |  | #   geeknest.com | 
| 787 |  |  |  |  |  |  | } | 
| 788 |  |  |  |  |  |  | print "I have your address, $address."; | 
| 789 |  |  |  |  |  |  | #   "Casey West" | 
| 790 |  |  |  |  |  |  |  | 
| 791 |  |  |  |  |  |  | Modifying this package variable is now deprecated. Subclassing is now the | 
| 792 |  |  |  |  |  |  | recommended approach. | 
| 793 |  |  |  |  |  |  |  | 
| 794 |  |  |  |  |  |  | =back | 
| 795 |  |  |  |  |  |  |  | 
| 796 |  |  |  |  |  |  | =head2 Did I Mention Fast? | 
| 797 |  |  |  |  |  |  |  | 
| 798 |  |  |  |  |  |  | On his 1.8GHz Apple MacBook, rjbs gets these results: | 
| 799 |  |  |  |  |  |  |  | 
| 800 |  |  |  |  |  |  | $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 5 | 
| 801 |  |  |  |  |  |  | Rate  Mail::Address Email::Address | 
| 802 |  |  |  |  |  |  | Mail::Address  2.59/s             --           -44% | 
| 803 |  |  |  |  |  |  | Email::Address 4.59/s            77%             -- | 
| 804 |  |  |  |  |  |  |  | 
| 805 |  |  |  |  |  |  | $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 25 | 
| 806 |  |  |  |  |  |  | Rate  Mail::Address Email::Address | 
| 807 |  |  |  |  |  |  | Mail::Address  2.58/s             --           -67% | 
| 808 |  |  |  |  |  |  | Email::Address 7.84/s           204%             -- | 
| 809 |  |  |  |  |  |  |  | 
| 810 |  |  |  |  |  |  | $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 50 | 
| 811 |  |  |  |  |  |  | Rate  Mail::Address Email::Address | 
| 812 |  |  |  |  |  |  | Mail::Address  2.57/s             --           -70% | 
| 813 |  |  |  |  |  |  | Email::Address 8.53/s           232%             -- | 
| 814 |  |  |  |  |  |  |  | 
| 815 |  |  |  |  |  |  | ...unfortunately, a known bug causes a loss of speed the string to parse has | 
| 816 |  |  |  |  |  |  | certain known characteristics, and disabling cache will also degrade | 
| 817 |  |  |  |  |  |  | performance. | 
| 818 |  |  |  |  |  |  |  | 
| 819 |  |  |  |  |  |  | =head1 ACKNOWLEDGEMENTS | 
| 820 |  |  |  |  |  |  |  | 
| 821 |  |  |  |  |  |  | Thanks to Kevin Riggle and Tatsuhiko Miyagawa for tests for annoying | 
| 822 |  |  |  |  |  |  | phrase-quoting bugs! | 
| 823 |  |  |  |  |  |  |  | 
| 824 |  |  |  |  |  |  | =head1 AUTHORS | 
| 825 |  |  |  |  |  |  |  | 
| 826 |  |  |  |  |  |  | =over 4 | 
| 827 |  |  |  |  |  |  |  | 
| 828 |  |  |  |  |  |  | =item * | 
| 829 |  |  |  |  |  |  |  | 
| 830 |  |  |  |  |  |  | Casey West | 
| 831 |  |  |  |  |  |  |  | 
| 832 |  |  |  |  |  |  | =item * | 
| 833 |  |  |  |  |  |  |  | 
| 834 |  |  |  |  |  |  | Ricardo SIGNES | 
| 835 |  |  |  |  |  |  |  | 
| 836 |  |  |  |  |  |  | =back | 
| 837 |  |  |  |  |  |  |  | 
| 838 |  |  |  |  |  |  | =head1 CONTRIBUTORS | 
| 839 |  |  |  |  |  |  |  | 
| 840 |  |  |  |  |  |  | =for stopwords Alex Vandiver David Golden Steinbrunner Glenn Fowler Kevin Falcone Pali Ruslan Zakirov sunnavy William Yardley | 
| 841 |  |  |  |  |  |  |  | 
| 842 |  |  |  |  |  |  | =over 4 | 
| 843 |  |  |  |  |  |  |  | 
| 844 |  |  |  |  |  |  | =item * | 
| 845 |  |  |  |  |  |  |  | 
| 846 |  |  |  |  |  |  | Alex Vandiver | 
| 847 |  |  |  |  |  |  |  | 
| 848 |  |  |  |  |  |  | =item * | 
| 849 |  |  |  |  |  |  |  | 
| 850 |  |  |  |  |  |  | David Golden | 
| 851 |  |  |  |  |  |  |  | 
| 852 |  |  |  |  |  |  | =item * | 
| 853 |  |  |  |  |  |  |  | 
| 854 |  |  |  |  |  |  | David Steinbrunner | 
| 855 |  |  |  |  |  |  |  | 
| 856 |  |  |  |  |  |  | =item * | 
| 857 |  |  |  |  |  |  |  | 
| 858 |  |  |  |  |  |  | Glenn Fowler | 
| 859 |  |  |  |  |  |  |  | 
| 860 |  |  |  |  |  |  | =item * | 
| 861 |  |  |  |  |  |  |  | 
| 862 |  |  |  |  |  |  | Kevin Falcone | 
| 863 |  |  |  |  |  |  |  | 
| 864 |  |  |  |  |  |  | =item * | 
| 865 |  |  |  |  |  |  |  | 
| 866 |  |  |  |  |  |  | Pali | 
| 867 |  |  |  |  |  |  |  | 
| 868 |  |  |  |  |  |  | =item * | 
| 869 |  |  |  |  |  |  |  | 
| 870 |  |  |  |  |  |  | Ruslan Zakirov | 
| 871 |  |  |  |  |  |  |  | 
| 872 |  |  |  |  |  |  | =item * | 
| 873 |  |  |  |  |  |  |  | 
| 874 |  |  |  |  |  |  | sunnavy | 
| 875 |  |  |  |  |  |  |  | 
| 876 |  |  |  |  |  |  | =item * | 
| 877 |  |  |  |  |  |  |  | 
| 878 |  |  |  |  |  |  | William Yardley | 
| 879 |  |  |  |  |  |  |  | 
| 880 |  |  |  |  |  |  | =back | 
| 881 |  |  |  |  |  |  |  | 
| 882 |  |  |  |  |  |  | =head1 COPYRIGHT AND LICENSE | 
| 883 |  |  |  |  |  |  |  | 
| 884 |  |  |  |  |  |  | This software is copyright (c) 2004 by Casey West. | 
| 885 |  |  |  |  |  |  |  | 
| 886 |  |  |  |  |  |  | This is free software; you can redistribute it and/or modify it under | 
| 887 |  |  |  |  |  |  | the same terms as the Perl 5 programming language system itself. | 
| 888 |  |  |  |  |  |  |  | 
| 889 |  |  |  |  |  |  | =cut | 
| 890 |  |  |  |  |  |  |  | 
| 891 |  |  |  |  |  |  | __END__ |