From: Moritz Bunkus Date: Fri, 4 Jul 2008 12:58:10 +0000 (+0000) Subject: Beim Verschicken von Emails müssen die Absender- und Empfängeradressen MIME-Encodiert... X-Git-Tag: release-2.6.0beta1~90 X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=8f3ecba98c0f85f2b48735c1ac110c3c9d957100;p=kivitendo-erp.git Beim Verschicken von Emails müssen die Absender- und Empfängeradressen MIME-Encodiert werden. --- diff --git a/SL/Mailer.pm b/SL/Mailer.pm index 234b6a784..52691e277 100644 --- a/SL/Mailer.pm +++ b/SL/Mailer.pm @@ -30,6 +30,8 @@ package Mailer; +use Email::Address; + use SL::Common; use SL::Template; @@ -97,49 +99,55 @@ sub send { local (*IN, *OUT); $num_sent++; - 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 $boundary = time() . "-$$-${num_sent}"; + $boundary = "LxOffice-$self->{version}-$boundary"; + my $domain = $self->{from}; + $domain =~ s/(.*?\@|>)//g; + my $msgid = "$boundary\@$domain"; - $form->{myconfig_email} = $email; + my $form = $main::form; + my $myconfig = \%main::myconfig; - my $template = PlainTextTemplate->new(undef, $form, $myconfig); - my $sendmail = $template->parse_block($main::sendmail); + my $email = $myconfig->{email}; + $email =~ s/[^\w\.\-\+=@]//ig; - $self->{charset} = Common::DEFAULT_CHARSET unless $self->{charset}; + my %temp_form = ( %{ $form }, 'myconfig_email' => $email ); + my $template = PlainTextTemplate->new(undef, \%temp_form, $myconfig); + my $sendmail = $template->parse_block($main::sendmail); if (!open(OUT, $sendmail)) { $main::lxdebug->leave_sub(); return "$sendmail : $!"; } - $self->{contenttype} = "text/plain" unless $self->{contenttype}; - - my ($cc, $bcc); - $cc = "Cc: $self->{cc}\n" if $self->{cc}; - $bcc = "Bcc: $self->{bcc}\n" if $self->{bcc}; + $self->{charset} ||= Common::DEFAULT_CHARSET; + $self->{contenttype} ||= "text/plain"; foreach my $item (qw(to cc bcc)) { + next unless ($self->{$item}); $self->{$item} =~ s/\</{$item} =~ s/\$<\$/{$item} =~ s/\>/>/g; $self->{$item} =~ s/\$>\$/>/g; } - my $subject = $self->mime_quote_text($self->{subject}, 60); + 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|From: $self->{from} -To: $self->{to} -${cc}${bcc}Subject: $subject -Message-ID: <$msgid> + print OUT qq|${headers}Message-ID: <$msgid> X-Mailer: Lx-Office $self->{version} MIME-Version: 1.0 |; diff --git a/doc/modules/LICENSE.Email-Address b/doc/modules/LICENSE.Email-Address new file mode 100644 index 000000000..8d3892735 --- /dev/null +++ b/doc/modules/LICENSE.Email-Address @@ -0,0 +1,11 @@ +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. diff --git a/modules/fallback/Email/Address.pm b/modules/fallback/Email/Address.pm new file mode 100644 index 000000000..5fb84e815 --- /dev/null +++ b/modules/fallback/Email/Address.pm @@ -0,0 +1,564 @@ +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 +