From 16cc40534360c3c173d6928070bd2873abee8c0c Mon Sep 17 00:00:00 2001 From: Moritz Bunkus Date: Thu, 1 Nov 2012 11:05:29 +0100 Subject: [PATCH] Selbst geschriebenen E-Mail-Erstellungscode durch Verwendung von Email::MIME ersetzt Fixt #2035. --- SL/InstallationCheck.pm | 1 + SL/Mailer.pm | 285 ++++++++++++++++------------------------ 2 files changed, 111 insertions(+), 175 deletions(-) diff --git a/SL/InstallationCheck.pm b/SL/InstallationCheck.pm index 79a213a1a..37f276c80 100644 --- a/SL/InstallationCheck.pm +++ b/SL/InstallationCheck.pm @@ -17,6 +17,7 @@ BEGIN { { name => "DBI", version => '1.50', url => "http://search.cpan.org/~timb/", debian => 'libdbi-perl' }, { name => "DBD::Pg", version => '1.49', url => "http://search.cpan.org/~dbdpg/", debian => 'libdbd-pg-perl' }, { name => "Email::Address", url => "http://search.cpan.org/~rjbs/", debian => 'libemail-address-perl' }, + { name => "Email::MIME", url => "http://search.cpan.org/~rjbs/", debian => 'libemail-mime-perl' }, { name => "FCGI", version => '0.72', url => "http://search.cpan.org/~mstrout/", debian => 'libfcgi-perl' }, { name => "JSON", url => "http://search.cpan.org/~makamaka", debian => 'libjson-perl' }, { name => "List::MoreUtils", version => '0.21', url => "http://search.cpan.org/~vparseval/", debian => 'liblist-moreutils-perl' }, diff --git a/SL/Mailer.pm b/SL/Mailer.pm index 0880eecc7..2857e1c75 100644 --- a/SL/Mailer.pm +++ b/SL/Mailer.pm @@ -5,14 +5,6 @@ # Web http://www.lx-office.org # #===================================================================== -# SQL-Ledger Accounting -# Copyright (C) 2001 -# -# Author: Dieter Simader -# Email: dsimader@sql-ledger.org -# Web: http://www.sql-ledger.org -# -# Contributors: # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -31,7 +23,7 @@ package Mailer; use Email::Address; -use Encode; +use Email::MIME::Creator; use File::Slurp; use SL::Common; @@ -43,13 +35,9 @@ use strict; my $num_sent = 0; sub new { - $main::lxdebug->enter_sub(); - my ($type, %params) = @_; my $self = { %params }; - $main::lxdebug->leave_sub(); - bless $self, $type; } @@ -62,214 +50,161 @@ sub _create_driver { myconfig => \%::myconfig, ); - my $cfg = $::lx_office_conf{mail_delivery}; - if (($cfg->{method} || 'smtp') ne 'smtp') { - require SL::Mailer::Sendmail; - return SL::Mailer::Sendmail->new(%params); - } else { - require SL::Mailer::SMTP; - return SL::Mailer::SMTP->new(%params); - } -} - -sub mime_quote_text { - $main::lxdebug->enter_sub(); - - my ($self, $text, $chars_left) = @_; + my $module = ($::lx_office_conf{mail_delivery}->{method} || 'smtp') ne 'smtp' ? 'SL::Mailer::Sendmail' : 'SL::Mailer::SMTP'; + eval "require $module" or return undef; - my $q_start = "=?$self->{charset}?Q?"; - my $l_start = length($q_start); - - my $new_text = "$q_start"; - $chars_left -= $l_start if (defined $chars_left); - - for (my $i = 0; $i < length($text); $i++) { - my $char = ord(substr($text, $i, 1)); - - if (($char < 32) || ($char > 127) || ($char == ord('?')) || ($char == ord('_'))) { - if ((defined $chars_left) && ($chars_left < 5)) { - $new_text .= "?=\n $q_start"; - $chars_left = 75 - $l_start; - } + return $module->new(%params); +} - $new_text .= sprintf("=%02X", $char); - $chars_left -= 3 if (defined $chars_left); +sub _cleanup_addresses { + my ($self) = @_; - } else { - $char = ord('_') if ($char == ord(' ')); - if ((defined $chars_left) && ($chars_left < 5)) { - $new_text .= "?=\n $q_start"; - $chars_left = 75 - $l_start; - } + foreach my $item (qw(to cc bcc)) { + next unless $self->{$item}; - $new_text .= chr($char); - $chars_left-- if (defined $chars_left); - } + $self->{$item} =~ s/\</{$item} =~ s/\$<\$/{$item} =~ s/\>/>/g; + $self->{$item} =~ s/\$>\$/>/g; } - - $new_text .= "?="; - - $main::lxdebug->leave_sub(); - - return $new_text; } -sub send { - $main::lxdebug->enter_sub(); - +sub _create_message_id { my ($self) = @_; - local (*IN); - - $num_sent++; - my $boundary = time() . "-$$-${num_sent}"; - $boundary = "kivitendo-$self->{version}-$boundary"; - my $domain = $self->{from}; - $domain =~ s/(.*?\@|>)//g; - my $msgid = "$boundary\@$domain"; - - my $form = $main::form; - my $myconfig = \%main::myconfig; + $num_sent += 1; + my $domain = $self->{from}; + $domain =~ s/.*\@//; + $domain =~ s/>.*//; - my $driver = eval { $self->_create_driver }; - if (!$driver) { - $main::lxdebug->leave_sub(); - return "send email : $@"; - } + return "kivitendo-$self->{version}-" . time() . "-${$}-${num_sent}\@$domain"; +} - $self->{charset} ||= Common::DEFAULT_CHARSET; - $self->{contenttype} ||= "text/plain"; +sub _create_address_headers { + my ($self) = @_; - foreach my $item (qw(to cc bcc)) { - next unless ($self->{$item}); - $self->{$item} =~ s/\</{$item} =~ s/\$<\$/{$item} =~ s/\>/>/g; - $self->{$item} =~ s/\$>\$/>/g; - } + $self->{addresses} = {}; - my %addresses; - my $headers = ''; foreach my $item (qw(from to cc bcc)) { - $addresses{$item} = []; - next unless ($self->{$item}); + $self->{addresses}->{$item} = []; + next if !$self->{$item} || $self->{driver}->keep_from_header($item); - my (@addr_objects) = Email::Address->parse($self->{$item}); - next unless (scalar @addr_objects); + my @header_addresses; - foreach my $addr_obj (@addr_objects) { - push @{ $addresses{$item} }, $addr_obj->address; + foreach my $addr_obj (Email::Address->parse($self->{$item})) { + push @{ $self->{addresses}->{$item} }, $addr_obj->address; my $phrase = $addr_obj->phrase(); if ($phrase) { $phrase =~ s/^\"//; $phrase =~ s/\"$//; - $addr_obj->phrase($self->mime_quote_text($phrase)); + $addr_obj->phrase($phrase); } - $headers .= sprintf("%s: %s\n", ucfirst($item), $addr_obj->format()) unless $driver->keep_from_header($item); + push @header_addresses, $addr_obj->format; } - } - - $headers .= sprintf("Subject: %s\n", $self->mime_quote_text($self->{subject}, 60)); - - $driver->start_mail(from => $self->{from}, to => [ map { @{ $addresses{$_} } } qw(to cc bcc) ]); - $driver->print(qq|${headers}Message-ID: <$msgid> -X-Mailer: kivitendo $self->{version} -MIME-Version: 1.0 -|); - - if ($self->{attachments}) { - $driver->print(qq|Content-Type: multipart/mixed; boundary="$boundary"\n\n|); - if ($self->{message}) { - $driver->print(qq|--${boundary} -Content-Type: $self->{contenttype}; charset="$self->{charset}" - -$self->{message} + push @{ $self->{headers} }, ( ucfirst($item) => join(', ', @header_addresses) ) if @header_addresses; + } +} -|); - } +sub _create_attachment_part { + my ($self, $attachment) = @_; - foreach my $attachment (@{ $self->{attachments} }) { + my $source_file_name; - my $filename; + my %attributes = ( + disposition => 'attachment', + encoding => 'base64', + ); - if (ref($attachment) eq "HASH") { - $filename = $attachment->{"name"}; - $attachment = $attachment->{"filename"}; - } else { - $filename = $attachment; - # strip path - $filename =~ s/(.*\/|\Q$self->{fileid}\E)//g; - } + if (ref($attachment) eq "HASH") { + $attributes{filename} = $attachment->{name}; + $source_file_name = $attachment->{filename}; - my $attachment_content = eval { read_file($attachment) }; - if (!defined $attachment_content) { - $main::lxdebug->leave_sub(); - return "$attachment : $!"; - } - - my $application = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? "text" : "application"; - my $content_type = SL::MIME->mime_type_from_ext($filename); - $content_type = "${application}/$self->{format}" if (!$content_type && $self->{format}); - $content_type ||= 'application/octet-stream'; + } else { + # strip path + $attributes{filename} = $attachment; + $attributes{filename} =~ s:.*\Q$self->{fileid}\E:: if $self->{fileid}; + $attributes{filename} =~ s:.*/::g; + $source_file_name = $attachment; + } - # only set charset for attachements of type text. every other type should not have this field - # refer to bug 883 for detailed information - my $attachment_charset; - if (lc $application eq 'text' && $self->{charset}) { - $attachment_charset = qq|; charset="$self->{charset}" |; - } + my $attachment_content = eval { read_file($source_file_name) }; + return undef if !defined $attachment_content; - $driver->print(qq|--${boundary} -Content-Type: ${content_type}; name="$filename"$attachment_charset -Content-Transfer-Encoding: BASE64 -Content-Disposition: attachment; filename="$filename"\n\n|); + my $application = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? 'text' : 'application'; + $attributes{content_type} = SL::MIME->mime_type_from_ext($attributes{filename}); + $attributes{content_type} ||= "${application}/$self->{format}" if $self->{format}; + $attributes{content_type} ||= 'application/octet-stream'; + $attributes{charset} = $self->{charset} if lc $application eq 'text' && $self->{charset}; - $driver->print(encode_base64($attachment_content)); - } - $driver->print(qq|--${boundary}--\n|); + return Email::MIME->create( + attributes => \%attributes, + body => $attachment_content, + ); +} - } else { - $driver->print(qq|Content-Type: $self->{contenttype}; charset="$self->{charset}" +sub _create_message { + my ($self) = @_; -$self->{message} -|); + my @parts; + + if ($self->{message}) { + push @parts, Email::MIME->create( + attributes => { + content_type => $self->{contenttype}, + charset => $self->{charset}, + encoding => 'quoted-printable', + }, + body_str => $self->{message}, + ); + + push @{ $self->{headers} }, ( + 'Content-Type' => qq|$self->{contenttype}; charset="$self->{charset}"|, + ); } - $driver->send; - - $main::lxdebug->leave_sub(); + push @parts, grep { $_ } map { $self->_create_attachment_part($_) } @{ $self->{attachments} || [] }; - return ""; + return Email::MIME->create( + header_str => $self->{headers}, + parts => \@parts, + ); } -sub encode_base64 ($;$) { - $main::lxdebug->enter_sub(); +sub send { + my ($self) = @_; - # this code is from the MIME-Base64-2.12 package - # Copyright 1995-1999,2001 Gisle Aas + # Create driver for delivery method (sendmail/SMTP) + $self->{driver} = eval { $self->_create_driver }; + if (!$self->{driver}) { + $::lxdebug->leave_sub(); + return "send email : $@"; + } - my $res = ""; - my $eol = $_[1]; - $eol = "\n" unless defined $eol; - pos($_[0]) = 0; # ensure start at the beginning + # Set defaults & headers + $self->{charset} ||= Common::DEFAULT_CHARSET; + $self->{contenttype} ||= "text/plain"; + $self->{headers} = [ + Subject => $self->{subject}, + 'Message-ID' => $self->_create_message_id, + 'X-Mailer' => "kivitendo $self->{version}", + ]; - $res = join '', map(pack('u', $_) =~ /^.(\S*)/, ($_[0] =~ /(.{1,45})/gs)); + # Clean up To/Cc/Bcc address fields + $self->_cleanup_addresses; + $self->_create_address_headers; - $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs - # fix padding at the end - my $padding = (3 - length($_[0]) % 3) % 3; - $res =~ s/.{$padding}$/'=' x $padding/e if $padding; + my $email = $self->_create_message; - # break encoded string into lines of no more than 60 characters each - if (length $eol) { - $res =~ s/(.{1,60})/$1$eol/g; - } + # $::lxdebug->message(0, "message: " . $email->as_string); + # return "boom"; - $main::lxdebug->leave_sub(); + $self->{driver}->start_mail(from => $self->{from}, to => [ map { @{ $self->{addresses}->{$_} } } qw(to cc bcc) ]); + $self->{driver}->print($email->as_string); + $self->{driver}->send; - return $res; + return ''; } 1; -- 2.20.1