Payment-Helfer: Rechnen mit undefinierten Werten vermeiden
[kivitendo-erp.git] / 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