X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FMailer.pm;h=f242120a964c89ec1593303556a7b49431ff46c4;hb=2a0cbd885790174fa0f212e6661b30362650a42c;hp=b04af08ddf5943ee4d7df2753080048571881c9d;hpb=5896d8bf4393add9948ca688ae0ed7c75c04a287;p=kivitendo-erp.git diff --git a/SL/Mailer.pm b/SL/Mailer.pm index b04af08dd..f242120a9 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 @@ -25,30 +17,55 @@ # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +# MA 02110-1335, USA. #====================================================================== package Mailer; use Email::Address; +use Email::MIME::Creator; use Encode; +use File::MimeInfo::Magic; +use File::Slurp; +use List::UtilsBy qw(bundle_by); +use List::Util qw(sum); use SL::Common; -use SL::MIME; +use SL::DB::EmailJournal; +use SL::DB::EmailJournalAttachment; +use SL::DB::Employee; +use SL::Locale::String qw(t8); use SL::Template; +use SL::Version; use strict; my $num_sent = 0; -sub new { - $main::lxdebug->enter_sub(); +my %mail_delivery_modules = ( + sendmail => 'SL::Mailer::Sendmail', + smtp => 'SL::Mailer::SMTP', +); + +my %type_to_table = ( + sales_quotation => 'oe', + request_quotation => 'oe', + sales_order => 'oe', + purchase_order => 'oe', + invoice => 'ar', + credit_note => 'ar', + purchase_invoice => 'ap', + letter => 'letter', + purchase_delivery_order => 'delivery_orders', + sales_delivery_order => 'delivery_orders', + dunning => 'dunning', +); +sub new { my ($type, %params) = @_; my $self = { %params }; - $main::lxdebug->leave_sub(); - bless $self, $type; } @@ -61,232 +78,379 @@ 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); + my $module = $mail_delivery_modules{ $::lx_office_conf{mail_delivery}->{method} }; + eval "require $module" or return undef; + + return $module->new(%params); +} + +sub _cleanup_addresses { + 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; } } -sub mime_quote_text { - $main::lxdebug->enter_sub(); +sub _create_message_id { + my ($self) = @_; - my ($self, $text, $chars_left) = @_; + $num_sent += 1; + my $domain = $self->{from}; + $domain =~ s/.*\@//; + $domain =~ s/>.*//; - my $q_start = "=?$self->{charset}?Q?"; - my $l_start = length($q_start); + return "kivitendo-" . SL::Version->get_version . "-" . time() . "-${$}-${num_sent}\@$domain"; +} - my $new_text = "$q_start"; - $chars_left -= $l_start if (defined $chars_left); +sub _create_address_headers { + my ($self) = @_; - for (my $i = 0; $i < length($text); $i++) { - my $char = ord(substr($text, $i, 1)); + # $self->{addresses} collects the recipients for use in e.g. the + # SMTP 'RCPT TO:' envelope command. $self->{headers} collects the + # headers that make up the actual email. 'BCC' should not be + # included there for certain transportation methods (SMTP). - 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; - } + $self->{addresses} = {}; + + foreach my $item (qw(from to cc bcc)) { + $self->{addresses}->{$item} = []; + next if !$self->{$item}; + + my @header_addresses; + my @addresses = Email::Address->parse($self->{$item}); + + # if either no address was parsed or + # there are more than 3 characters per parsed email extra, assume the the user has entered bunk + if (!@addresses) { + die t8('"#1" seems to be a faulty list of email addresses. No addresses could be extracted.', + $self->{$item}, + ); + } elsif ((length($self->{$item}) - sum map { length $_->original } @addresses) / @addresses > 3) { + die t8('"#1" seems to be a faulty list of email addresses. After extracing addresses (#2) too many characters are left.', + $self->{$item}, join ', ', map { $_->original } @addresses, + ); + } - $new_text .= sprintf("=%02X", $char); - $chars_left -= 3 if (defined $chars_left); + foreach my $addr_obj (@addresses) { + push @{ $self->{addresses}->{$item} }, $addr_obj->address; + next if $self->{driver}->keep_from_header($item); - } else { - $char = ord('_') if ($char == ord(' ')); - if ((defined $chars_left) && ($chars_left < 5)) { - $new_text .= "?=\n $q_start"; - $chars_left = 75 - $l_start; + my $phrase = $addr_obj->phrase(); + if ($phrase) { + $phrase =~ s/^\"//; + $phrase =~ s/\"$//; + $addr_obj->phrase($phrase); } - $new_text .= chr($char); - $chars_left-- if (defined $chars_left); + push @header_addresses, $addr_obj->format; } + + push @{ $self->{headers} }, ( ucfirst($item) => join(', ', @header_addresses) ) if @header_addresses; + } +} + +sub _create_attachment_part { + my ($self, $attachment) = @_; + + my %attributes = ( + disposition => 'attachment', + encoding => 'base64', + ); + + my $attachment_content; + my $file_id = 0; + my $email_journal = $::instance_conf->get_email_journal; + + if (ref($attachment) eq "HASH") { + $attributes{filename} = $attachment->{name}; + $file_id = $attachment->{id} || '0'; + $attributes{content_type} = $attachment->{type} || 'application/pdf'; + $attachment_content = $attachment->{content}; + $attachment_content = eval { read_file($attachment->{path}) } if !$attachment_content; + + } else { + $attributes{filename} = $attachment; + $attributes{filename} =~ s:.*\Q$self->{fileid}\E:: if $self->{fileid}; + $attributes{filename} =~ s:.*/::g; + + my $application = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? 'text' : 'application'; + $attributes{content_type} = File::MimeInfo::Magic::magic($attachment); + $attributes{content_type} ||= "${application}/$self->{format}" if $self->{format}; + $attributes{content_type} ||= 'application/octet-stream'; + $attachment_content = eval { read_file($attachment) }; + } + + return undef if $email_journal > 1 && !defined $attachment_content; + + $attachment_content ||= ' '; + $attributes{charset} = $self->{charset} if $self->{charset} && ($attributes{content_type} =~ m{^text/}); + + my $ent; + if ( $attributes{content_type} eq 'message/rfc822' ) { + $ent = Email::MIME->new($attachment_content); + } else { + $ent = Email::MIME->create( + attributes => \%attributes, + body => $attachment_content, + ); } - $new_text .= "?="; + # Due to a bug in Email::MIME it's not enough to hand over the encoded file name in the "attributes" hash in the + # "create" call. Email::MIME iterates over the keys in the hash, and depending on which key it has already seen during + # the iteration it might revert the encoding. As Perl's hash key order is randomized for each Perl run, this means + # that the file name stays unencoded sometimes. + # Setting the header manually after the "create" call circumvents this problem. + $ent->header_set('Content-disposition' => 'attachment; filename="' . encode('MIME-Q', $attributes{filename}) . '"'); + + push @{ $self->{mail_attachments}} , SL::DB::EmailJournalAttachment->new( + name => $attributes{filename}, + mime_type => $attributes{content_type}, + content => ( $email_journal > 1 ? $attachment_content : ' '), + file_id => $file_id, + ); - $main::lxdebug->leave_sub(); + return $ent; +} - return $new_text; +sub _create_message { + my ($self) = @_; + + my @parts; + + if ($self->{message}) { + push @parts, Email::MIME->create( + attributes => { + content_type => $self->{content_type}, + charset => $self->{charset}, + encoding => 'quoted-printable', + }, + body_str => $self->{message}, + ); + + push @{ $self->{headers} }, ( + 'Content-Type' => qq|$self->{content_type}; charset="$self->{charset}"|, + ); + } + + push @parts, grep { $_ } map { $self->_create_attachment_part($_) } @{ $self->{attachments} || [] }; + + return Email::MIME->create( + header_str => $self->{headers}, + parts => \@parts, + ); } sub send { - $main::lxdebug->enter_sub(); + my ($self) = @_; + # Create driver for delivery method (sendmail/SMTP) + $self->{driver} = eval { $self->_create_driver }; + if (!$self->{driver}) { + my $error = $@; + $self->_store_in_journal('failed', 'driver could not be created; check your configuration & log files'); + $::lxdebug->message(LXDebug::WARN(), "Mailer error during 'send': $error"); + + return $error; + } + + # Set defaults & headers + $self->{charset} = 'UTF-8'; + $self->{content_type} ||= "text/plain"; + $self->{headers} ||= []; + push @{ $self->{headers} }, ( + Subject => $self->{subject}, + 'Message-ID' => '<' . $self->_create_message_id . '>', + 'X-Mailer' => "kivitendo " . SL::Version->get_version, + ); + $self->{mail_attachments} = []; + + my $error; + my $ok = eval { + # Clean up To/Cc/Bcc address fields + $self->_cleanup_addresses; + $self->_create_address_headers; + + my $email = $self->_create_message; + + my $from_obj = (Email::Address->parse($self->{from}))[0]; + + $self->{driver}->start_mail(from => $from_obj->address, to => [ $self->_all_recipients ]); + $self->{driver}->print($email->as_string); + $self->{driver}->send; + + 1; + }; + + $error = $@ if !$ok; + + # create journal and link to record + $self->{journalentry} = $self->_store_in_journal; + $self->_create_record_link if $self->{journalentry}; + + return $ok ? '' : ($error || "undefined error"); +} + +sub _all_recipients { my ($self) = @_; + $self->{addresses} ||= {}; + return map { @{ $self->{addresses}->{$_} || [] } } qw(to cc bcc); +} - local (*IN); +sub _store_in_journal { + my ($self, $status, $extended_status) = @_; + + my $journal_enable = $::instance_conf->get_email_journal; + + return if $journal_enable == 0; + + $status //= $self->{driver}->status if $self->{driver}; + $status //= 'failed'; + $extended_status //= $self->{driver}->extended_status if $self->{driver}; + $extended_status //= 'unknown error'; + + my $headers = join "\r\n", (bundle_by { join(': ', @_) } 2, @{ $self->{headers} || [] }); + + my $jentry = SL::DB::EmailJournal->new( + sender => SL::DB::Manager::Employee->current, + from => $self->{from} // '', + recipients => join(', ', $self->_all_recipients), + subject => $self->{subject} // '', + headers => $headers, + body => $self->{message} // '', + sent_on => DateTime->now_local, + attachments => \@{ $self->{mail_attachments} }, + status => $status, + extended_status => $extended_status, + )->save; + return $jentry->id; +} - $num_sent++; - my $boundary = time() . "-$$-${num_sent}"; - $boundary = "LxOffice-$self->{version}-$boundary"; - my $domain = $self->recode($self->{from}); - $domain =~ s/(.*?\@|>)//g; - my $msgid = "$boundary\@$domain"; - my $form = $main::form; - my $myconfig = \%main::myconfig; +sub _create_record_link { + my ($self) = @_; - my $driver = eval { $self->_create_driver }; - if (!$driver) { - $main::lxdebug->leave_sub(); - return "send email : $@"; + # check for custom/overloaded types and ids (form != controller) + my $record_type = $self->{record_type} || $::form->{type}; + my $record_id = $self->{record_id} || $::form->{id}; + + # you may send mails for unsaved objects (no record_id => unlinkable case) + if ($self->{journalentry} && $record_id && exists($type_to_table{$record_type})) { + RecordLinks->create_links( + mode => 'ids', + from_table => $type_to_table{$record_type}, + from_ids => $record_id, + to_table => 'email_journal', + to_id => $self->{journalentry}, + ); } +} - $self->{charset} ||= Common::DEFAULT_CHARSET; - $self->{contenttype} ||= "text/plain"; +1; - foreach my $item (qw(to cc bcc)) { - next unless ($self->{$item}); - $self->{$item} = $self->recode($self->{$item}); - $self->{$item} =~ s/\</{$item} =~ s/\$<\$/{$item} =~ s/\>/>/g; - $self->{$item} =~ s/\$>\$/>/g; - } - $self->{from} = $self->recode($self->{from}); +__END__ - my %addresses; - my $headers = ''; - foreach my $item (qw(from to cc bcc)) { - $addresses{$item} = []; - next unless ($self->{$item}); +=pod - my (@addr_objects) = Email::Address->parse($self->{$item}); - next unless (scalar @addr_objects); +=encoding utf8 - foreach my $addr_obj (@addr_objects) { - push @{ $addresses{$item} }, $addr_obj->address; - my $phrase = $addr_obj->phrase(); - if ($phrase) { - $phrase =~ s/^\"//; - $phrase =~ s/\"$//; - $addr_obj->phrase($self->mime_quote_text($phrase)); - } +=head1 NAME - $headers .= sprintf("%s: %s\n", ucfirst($item), $addr_obj->format()) unless $driver->keep_from_header($item); - } - } +SL::Mailer - Base class for sending mails from kivitendo - $headers .= sprintf("Subject: %s\n", $self->mime_quote_text($self->recode($self->{subject}), 60)); +=head1 SYNOPSIS - $driver->start_mail(from => $self->{from}, to => [ map { @{ $addresses{$_} } } qw(to cc bcc) ]); + package SL::BackgroundJob::CreatePeriodicInvoices; - $driver->print(qq|${headers}Message-ID: <$msgid> -X-Mailer: Lx-Office $self->{version} -MIME-Version: 1.0 -|); + use SL::Mailer; - 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}" + my $mail = Mailer->new; + $mail->{from} = $config{periodic_invoices}->{email_from}; + $mail->{to} = $email; + $mail->{subject} = $config{periodic_invoices}->{email_subject}; + $mail->{content_type} = $filename =~ m/.html$/ ? 'text/html' : 'text/plain'; + $mail->{message} = $output; -| . $self->recode($self->{message}) . qq| + $mail->send; -|); - } +=head1 OVERVIEW - foreach my $attachment (@{ $self->{attachments} }) { +Mail can be sent from kivitendo via the sendmail command or the smtp protocol. - my $filename; - if (ref($attachment) eq "HASH") { - $filename = $attachment->{"name"}; - $attachment = $attachment->{"filename"}; - } else { - $filename = $attachment; - # strip path - $filename =~ s/(.*\/|\Q$self->{fileid}\E)//g; - } +=head1 INTERNAL DATA TYPES - 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'; - open(IN, $attachment); - if ($?) { - $main::lxdebug->leave_sub(); - return "$attachment : $!"; - } +=over 2 - # 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}" |; - } +=item C<%mail_delivery_modules> - $driver->print(qq|--${boundary} -Content-Type: ${content_type}; name="$filename"$attachment_charset -Content-Transfer-Encoding: BASE64 -Content-Disposition: attachment; filename="$filename"\n\n|); + Currently two modules are supported: smtp or sendmail. - my $msg = ""; - while () { - ; - $msg .= $_; - } - $driver->print(encode_base64($msg)); +=item C<%type_to_table> - close(IN); + Due to the lack of a single global mapping for $form->{type}, + type is mapped to the corresponding database table. All types which + implement a mail action are currently mapped and should be mapped. + Type is either the value of the old form or the newer controller + based object type. - } - $driver->print(qq|--${boundary}--\n|); +=back - } else { - $driver->print(qq|Content-Type: $self->{contenttype}; charset="$self->{charset}" +=head1 FUNCTIONS -| . $self->recode($self->{message}) . qq| -|); - } +=over 4 - $driver->send; +=item C - $main::lxdebug->leave_sub(); +=item C<_create_driver> - return ""; -} +=item C<_cleanup_addresses> -sub encode_base64 ($;$) { - $main::lxdebug->enter_sub(); +=item C<_create_address_headers> - # this code is from the MIME-Base64-2.12 package - # Copyright 1995-1999,2001 Gisle Aas +=item C<_create_message_id> - my $res = ""; - my $eol = $_[1]; - $eol = "\n" unless defined $eol; - pos($_[0]) = 0; # ensure start at the beginning +=item C<_create_attachment_part> - $res = join '', map(pack('u', $_) =~ /^.(\S*)/, ($_[0] =~ /(.{1,45})/gs)); +=item C<_create_message> - $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; +=item C - # break encoded string into lines of no more than 60 characters each - if (length $eol) { - $res =~ s/(.{1,60})/$1$eol/g; - } + If a mail was sent successfully the internal function _store_in_journal + is called if email journaling is enabled. If _store_in_journal was executed + successfully and the calling form is already persistent (database id) a + record_link will be created. - $main::lxdebug->leave_sub(); +=item C<_all_recipients> - return $res; -} +=item C<_store_in_journal> -sub recode { - my $self = shift; - my $text = shift; +=item C<_create_record_link $self->{journalentry}, $::form->{id}, $self->{record_id}> - return $::locale->is_utf8 ? Encode::encode('utf-8-strict', $text) : $text; -} -1; + If $self->{journalentry} and either $self->{record_id} or $::form->{id} (checked in + this order) exist a record link from record to email journal is created. + It is possible to provide an array reference with more than one id in + $self->{record_id} or $::form->{id}. In this case all records are linked to + the mail. + Will fail silently if record_link creation wasn't successful (same behaviour as + _store_in_journal). + +=item C + +=back + +=head1 BUGS + +Nothing here yet. + +=head1 AUTHOR + +=cut