X-Git-Url: http://wagnertech.de/git?p=kivitendo-erp.git;a=blobdiff_plain;f=modules%2Ffallback%2FEmail%2FAddress.pm;fp=modules%2Ffallback%2FEmail%2FAddress.pm;h=0000000000000000000000000000000000000000;hp=5fb84e81548bfd6b54e39ad79be42ee75a675569;hb=53593baa211863fbf66540cf1bcc36c8fb37257f;hpb=deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44 diff --git a/modules/fallback/Email/Address.pm b/modules/fallback/Email/Address.pm deleted file mode 100644 index 5fb84e815..000000000 --- a/modules/fallback/Email/Address.pm +++ /dev/null @@ -1,564 +0,0 @@ -package Email::Address; -use strict; -## no critic RequireUseWarnings -# support pre-5.6 - -use vars qw[$VERSION $COMMENT_NEST_LEVEL $STRINGIFY - $COLLAPSE_SPACES - %PARSE_CACHE %FORMAT_CACHE %NAME_CACHE - $addr_spec $angle_addr $name_addr $mailbox]; - -my $NOCACHE; - -$VERSION = '1.888'; -$COMMENT_NEST_LEVEL ||= 2; -$STRINGIFY ||= 'format'; -$COLLAPSE_SPACES = 1 unless defined $COLLAPSE_SPACES; # who wants //=? me! - -=head1 NAME - -Email::Address - RFC 2822 Address Parsing and Creation - -=head1 SYNOPSIS - - use Email::Address; - - my @addresses = Email::Address->parse($line); - my $address = Email::Address->new(Casey => 'casey@localhost'); - - print $address->format; - -=head1 VERSION - -version 1.886 - - $Id: /my/pep/Email-Address/trunk/lib/Email/Address.pm 31900 2007-06-23T01:25:34.344997Z rjbs $ - -=head1 DESCRIPTION - -This class implements a regex-based RFC 2822 parser that locates email -addresses in strings and returns a list of C objects found. -Alternatley you may construct objects manually. The goal of this software is to -be correct, and very very fast. - -=cut - -my $CTL = q{\x00-\x1F\x7F}; -my $special = q{()<>\\[\\]:;@\\\\,."}; - -my $text = qr/[^\x0A\x0D]/; - -my $quoted_pair = qr/\\$text/; - -my $ctext = qr/(?>[^()\\]+)/; -my ($ccontent, $comment) = (q{})x2; -for (1 .. $COMMENT_NEST_LEVEL) { - $ccontent = qr/$ctext|$quoted_pair|$comment/; - $comment = qr/\s*\((?:\s*$ccontent)*\s*\)\s*/; -} -my $cfws = qr/$comment|\s+/; - -my $atext = qq/[^$CTL$special\\s]/; -my $atom = qr/$cfws*$atext+$cfws*/; -my $dot_atom_text = qr/$atext+(?:\.$atext+)*/; -my $dot_atom = qr/$cfws*$dot_atom_text$cfws*/; - -my $qtext = qr/[^\\"]/; -my $qcontent = qr/$qtext|$quoted_pair/; -my $quoted_string = qr/$cfws*"$qcontent+"$cfws*/; - -my $word = qr/$atom|$quoted_string/; - -# XXX: This ($phrase) used to just be: my $phrase = qr/$word+/; It was changed -# to resolve bug 22991, creating a significant slowdown. Given current speed -# problems. Once 16320 is resolved, this section should be dealt with. -# -- rjbs, 2006-11-11 -#my $obs_phrase = qr/$word(?:$word|\.|$cfws)*/; - -# XXX: ...and the above solution caused endless problems (never returned) when -# examining this address, now in a test: -# admin+=E6=96=B0=E5=8A=A0=E5=9D=A1_Weblog-- ATAT --test.socialtext.com -# So we disallow the hateful CFWS in this context for now. Of modern mail -# agents, only Apple Web Mail 2.0 is known to produce obs-phrase. -# -- rjbs, 2006-11-19 -my $simple_word = qr/$atom|\.|\s*"$qcontent+"\s*/; -my $obs_phrase = qr/$simple_word+/; - -my $phrase = qr/$obs_phrase|(?:$word+)/; - -my $local_part = qr/$dot_atom|$quoted_string/; -my $dtext = qr/[^\[\]\\]/; -my $dcontent = qr/$dtext|$quoted_pair/; -my $domain_literal = qr/$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*/; -my $domain = qr/$dot_atom|$domain_literal/; - -my $display_name = $phrase; - -=head2 Package Variables - -Several regular expressions used in this package are useful to others. -For convenience, these variables are declared as package variables that -you may access from your program. - -These regular expressions conform to the rules specified in RFC 2822. - -You can access these variables using the full namespace. If you want -short names, define them yourself. - - my $addr_spec = $Email::Address::addr_spec; - -=over 4 - -=item $Email::Address::addr_spec - -This regular expression defined what an email address is allowed to -look like. - -=item $Email::Address::angle_addr - -This regular expression defines an C<$addr_spec> wrapped in angle -brackets. - -=item $Email::Address::name_addr - -This regular expression defines what an email address can look like -with an optional preceeding display name, also known as the C. - -=item $Email::Address::mailbox - -This is the complete regular expression defining an RFC 2822 emial -address with an optional preceeding display name and optional -following comment. - -=back - -=cut - -$addr_spec = qr/$local_part\@$domain/; -$angle_addr = qr/$cfws*<$addr_spec>$cfws*/; -$name_addr = qr/$display_name?$angle_addr/; -$mailbox = qr/(?:$name_addr|$addr_spec)$comment*/; - -sub _PHRASE () { 0 } -sub _ADDRESS () { 1 } -sub _COMMENT () { 2 } -sub _ORIGINAL () { 3 } -sub _IN_CACHE () { 4 } - -=head2 Class Methods - -=over 4 - -=item parse - - my @addrs = Email::Address->parse( - q[me@local, Casey , "Casey" (West)] - ); - -This method returns a list of C objects it finds -in the input string. - -The specification for an email address allows for infinitley -nestable comments. That's nice in theory, but a little over done. -By default this module allows for two (C<2>) levels of nested -comments. If you think you need more, modify the -C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow -more. - - $Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep - -The reason for this hardly limiting limitation is simple: efficiency. - -Long strings of whitespace can be problematic for this module to parse, a bug -which has not yet been adequately addressed. The default behavior is now to -collapse multiple spaces into a single space, which avoids this problem. To -prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero. This -variable will go away when the bug is resolved properly. - -=cut - -sub __get_cached_parse { - return if $NOCACHE; - - my ($class, $line) = @_; - - return @{$PARSE_CACHE{$line}} if exists $PARSE_CACHE{$line}; - return; -} - -sub __cache_parse { - return if $NOCACHE; - - my ($class, $line, $addrs) = @_; - - $PARSE_CACHE{$line} = $addrs; -} - -sub parse { - my ($class, $line) = @_; - return unless $line; - - $line =~ s/[ \t]+/ /g if $COLLAPSE_SPACES; - - if (my @cached = $class->__get_cached_parse($line)) { - return @cached; - } - - my (@mailboxes) = ($line =~ /$mailbox/go); - my @addrs; - foreach (@mailboxes) { - my $original = $_; - - my @comments = /($comment)/go; - 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); - } - - my ($phrase) = /($display_name)/o; - - for ( $phrase, $host, $user, @comments ) { - next unless defined $_; - s/^\s+//; - s/\s+$//; - $_ = undef unless length $_; - } - - my $new_comment = join q{ }, @comments; - push @addrs, - $class->new($phrase, "$user\@$host", $new_comment, $original); - $addrs[-1]->[_IN_CACHE] = [ \$line, $#addrs ] - } - - $class->__cache_parse($line, \@addrs); - return @addrs; -} - -=pod - -=item new - - my $address = Email::Address->new(undef, 'casey@local'); - my $address = Email::Address->new('Casey West', 'casey@local'); - my $address = Email::Address->new(undef, 'casey@local', '(Casey)'); - -Constructs and returns a new C object. Takes four -positional arguments: phrase, email, and comment, and original string. - -The original string should only really be set using C. - -=cut - -sub new { bless [@_[1..4]], $_[0] } - -=pod - -=item purge_cache - - Email::Address->purge_cache; - -One way this module stays fast is with internal caches. Caches live -in memory and there is the remote possibility that you will have a -memory problem. In the off chance that you think you're one of those -people, this class method will empty those caches. - -I've loaded over 12000 objects and not encountered a memory problem. - -=cut - -sub purge_cache { - %NAME_CACHE = (); - %FORMAT_CACHE = (); - %PARSE_CACHE = (); -} - -=item disable_cache - -=item enable_cache - - Email::Address->disable_cache if memory_low(); - -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. - -=cut - -sub disable_cache { - my ($class) = @_; - $class->purge_cache; - $NOCACHE = 1; -} - -sub enable_cache { - $NOCACHE = undef; -} - -=pod - -=back - -=head2 Instance Methods - -=over 4 - -=item phrase - - my $phrase = $address->phrase; - $address->phrase( "Me oh my" ); - -Accessor and mutator for the phrase portion of an address. - -=item address - - my $addr = $address->address; - $addr->address( "me@PROTECTED.com" ); - -Accessor and mutator for the address portion of an address. - -=item comment - - my $comment = $address->comment; - $address->comment( "(Work address)" ); - -Accessor and mutator for the comment portion of an address. - -=item original - - my $orig = $address->original; - -Accessor for the original address found when parsing, or passed -to C. - -=item host - - my $host = $address->host; - -Accessor for the host portion of an address's address. - -=item user - - my $user = $address->user; - -Accessor for the user portion of an address's address. - -=cut - -BEGIN { - my %_INDEX = ( - phrase => _PHRASE, - address => _ADDRESS, - comment => _COMMENT, - original => _ORIGINAL, - ); - - for my $method (keys %_INDEX) { - no strict 'refs'; - my $index = $_INDEX{ $method }; - *$method = sub { - if ($_[1]) { - if ($_[0][_IN_CACHE]) { - my $replicant = bless [ @{$_[0]} ] => ref $_[0]; - $PARSE_CACHE{ ${ $_[0][_IN_CACHE][0] } }[ $_[0][_IN_CACHE][1] ] - = $replicant; - $_[0][_IN_CACHE] = undef; - } - $_[0]->[ $index ] = $_[1]; - } else { - $_[0]->[ $index ]; - } - }; - } -} - -sub host { ($_[0]->[_ADDRESS] =~ /\@($domain)/o)[0] } -sub user { ($_[0]->[_ADDRESS] =~ /($local_part)\@/o)[0] } - -=pod - -=item format - - my $printable = $address->format; - -Returns a properly formatted RFC 2822 address representing the -object. - -=cut - -sub format { - local $^W = 0; ## no critic - return $FORMAT_CACHE{"@{$_[0]}"} if exists $FORMAT_CACHE{"@{$_[0]}"}; - $FORMAT_CACHE{"@{$_[0]}"} = $_[0]->_format; -} - -sub _format { - my ($self) = @_; - - unless ( - defined $self->[_PHRASE] && length $self->[_PHRASE] - || - defined $self->[_COMMENT] && length $self->[_COMMENT] - ) { - return $self->[_ADDRESS]; - } - - my $format = sprintf q{%s <%s> %s}, - $self->_enquoted_phrase, $self->[_ADDRESS], $self->[_COMMENT]; - - $format =~ s/^\s+//; - $format =~ s/\s+$//; - - return $format; -} - -sub _enquoted_phrase { - my ($self) = @_; - - my $phrase = $self->[_PHRASE]; - - # if it's encoded -- rjbs, 2007-02-28 - return $phrase if $phrase =~ /\A=\?.+\?=\z/; - - $phrase =~ s/\A"(.+)"\z/$1/; - $phrase =~ s/\"/\\"/g; - - return qq{"$phrase"}; -} - -=pod - -=item name - - my $name = $address->name; - -This method tries very hard to determine the name belonging to the address. -First the C is checked. If that doesn't work out the C -is looked into. If that still doesn't work out, the C portion of -the C
is returned. - -This method does B try to massage any name it identifies and instead -leaves that up to someone else. Who is it to decide if someone wants their -name capitalized, or if they're Irish? - -=cut - -sub name { - local $^W = 0; - return $NAME_CACHE{"@{$_[0]}"} if exists $NAME_CACHE{"@{$_[0]}"}; - my ($self) = @_; - my $name = q{}; - if ( $name = $self->[_PHRASE] ) { - $name =~ s/^"//; - $name =~ s/"$//; - $name =~ s/($quoted_pair)/substr $1, -1/goe; - } elsif ( $name = $self->[_COMMENT] ) { - $name =~ s/^\(//; - $name =~ s/\)$//; - $name =~ s/($quoted_pair)/substr $1, -1/goe; - $name =~ s/$comment/ /go; - } else { - ($name) = $self->[_ADDRESS] =~ /($local_part)\@/o; - } - $NAME_CACHE{"@{$_[0]}"} = $name; -} - -=pod - -=back - -=head2 Overloaded Operators - -=over 4 - -=item stringify - - print "I have your email address, $address."; - -Objects stringify to C by default. It's possible that you don't -like that idea. Okay, then, you can change it by modifying -C<$Email:Address::STRINGIFY>. Please consider modifying this package -variable using C. You might step on someone else's toes if you -don't. - - { - local $Email::Address::STRINGIFY = 'address'; - print "I have your address, $address."; - # geeknest.com - } - print "I have your address, $address."; - # "Casey West" - -=cut - -sub as_string { - warn 'altering $Email::Address::STRINGIFY is deprecated; subclass instead' - if $STRINGIFY ne 'format'; - - $_[0]->can($STRINGIFY)->($_[0]); -} - -use overload '""' => 'as_string'; - -=pod - -=back - -=cut - -1; - -__END__ - -=head2 Did I Mention Fast? - -On his 1.8GHz Apple MacBook, rjbs gets these results: - - $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 5 - Rate Mail::Address Email::Address - Mail::Address 2.59/s -- -44% - Email::Address 4.59/s 77% -- - - $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 25 - Rate Mail::Address Email::Address - Mail::Address 2.58/s -- -67% - Email::Address 7.84/s 204% -- - - $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 50 - Rate Mail::Address Email::Address - Mail::Address 2.57/s -- -70% - Email::Address 8.53/s 232% -- - -...unfortunately, a known bug causes a loss of speed the string to parse has -certain known characteristics, and disabling cache will also degrade -performance. - -=head1 PERL EMAIL PROJECT - -This module is maintained by the Perl Email Project - -L - -=head1 SEE ALSO - -L, L. - -=head1 AUTHOR - -Originally by Casey West, >. - -Maintained, 2006-2007, Ricardo SIGNES >. - -=head1 ACKNOWLEDGEMENTS - -Thanks to Kevin Riggle and Tatsuhiko Miyagawa for tests for annoying phrase-quoting bugs! - -=head1 COPYRIGHT - -Copyright (c) 2004 Casey West. All rights reserved. This module is free -software; you can redistribute it and/or modify it under the same terms as Perl -itself. - -=cut -