projekt kivitendo

use Email::Address;

  my $boundary    = time() . "-$$-${num_sent}";

  $boundary       =  "LxOffice-$self->{version}-$boundary";

  my $domain      =  $self->{from};

  $domain         =~ s/(.*?\@|>)//g;

  my $msgid       =  "$boundary\@$domain";

  my $form        =  $main::form;

  my $myconfig    =  \%main::myconfig;

  my $email       =  $myconfig->{email};

  $email          =~ s/[^\w\.\-\+=@]//ig;

  my %temp_form   = ( %{ $form }, 'myconfig_email' => $email );

  my $template    = PlainTextTemplate->new(undef, \%temp_form, $myconfig);

  my $sendmail    = $template->parse_block($main::sendmail);

  $self->{charset}     ||= Common::DEFAULT_CHARSET;

  $self->{contenttype} ||= "text/plain";

    next unless ($self->{$item});

  my $headers = '';

  foreach my $item (qw(from to cc)) {

    next unless ($self->{$item});

    my (@addr_objects) = Email::Address->parse($self->{$item});

    next unless (scalar @addr_objects);

    foreach my $addr_obj (@addr_objects) {

      $addr_obj->phrase($self->mime_quote_text($addr_obj->phrase(), 60))   if ($addr_obj->phrase());

      $addr_obj->comment($self->mime_quote_text($addr_obj->comment(), 60)) if ($addr_obj->comment());

      $headers .= sprintf("%s: %s\n", ucfirst($item), $addr_obj->format());

    }

  }

  $headers .= sprintf("Subject: %s\n", $self->mime_quote_text($self->{subject}, 60));

  print OUT qq|${headers}Message-ID: <$msgid>

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.

Perl is distributed under your choice of the GNU General Public License or

the Artistic License.

The complete text of the GNU General Public License can be found in

/usr/share/common-licenses/GPL and the Artistic Licence can be found

in /usr/share/common-licenses/Artistic.

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<Email::Address> 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<phrase>.

=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 <me@local>, "Casey" <me@local> (West)]

  );

This method returns a list of C<Email::Address> 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<Email::Address> object. Takes four

positional arguments: phrase, email, and comment, and original string.

The original string should only really be set using C<parse>.

=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<new>.

=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<phrase> is checked. If that doesn't work out the C<comment>

is looked into. If that still doesn't work out, the C<user> portion of

the C<address> is returned.

This method does B<not> 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<format> 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<local>. 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" <casey@geeknest.com>

=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<http://emailproject.perl.org/wiki/Email::Address>

=head1 SEE ALSO

L<Email::Simple>, L<perl>.

=head1 AUTHOR

Originally by Casey West, <F<casey@geeknest.com>>.

Maintained, 2006-2007, Ricardo SIGNES <F<rjbs@cpan.org>>.

=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