kivitendo/SL/Mailer.pm @ af131a46
| d319704a | Moritz Bunkus | #=====================================================================
|
||
# LX-Office ERP
|
||||
# Copyright (C) 2004
|
||||
# Based on SQL-Ledger Version 2.1.9
|
||||
# Web http://www.lx-office.org
|
||||
#
|
||||
#=====================================================================
|
||||
#
|
||||
# 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
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# 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
|
||||
| f7b15d43 | Christian Wittmer | # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
|
||
# MA 02110-1335, USA.
|
||||
| d319704a | Moritz Bunkus | #======================================================================
|
||
package Mailer;
|
||||
| 8f3ecba9 | Moritz Bunkus | use Email::Address;
|
||
| a40f0c2f | Martin Helmling | use MIME::Entity;
|
||
use MIME::Parser;
|
||||
use File::MimeInfo::Magic;
|
||||
| e8c2a3b8 | Moritz Bunkus | use File::Slurp;
|
||
| 24ab7ec0 | Moritz Bunkus | use List::UtilsBy qw(bundle_by);
|
||
| 8f3ecba9 | Moritz Bunkus | |||
| faef45c2 | Moritz Bunkus | use SL::Common;
|
||
| 24ab7ec0 | Moritz Bunkus | use SL::DB::EmailJournal;
|
||
use SL::DB::EmailJournalAttachment;
|
||||
use SL::DB::Employee;
|
||||
| 920fd369 | Moritz Bunkus | use SL::Template;
|
||
| faef45c2 | Moritz Bunkus | |||
| c510d88b | Sven Schöling | use strict;
|
||
| a40f0c2f | Martin Helmling | use Encode;
|
||
| c510d88b | Sven Schöling | |||
| ba36bef4 | Moritz Bunkus | my $num_sent = 0;
|
||
| a40f0c2f | Martin Helmling | my $parser;
|
||
| ba36bef4 | Moritz Bunkus | |||
| adbc100a | Sven Schöling | my %mail_delivery_modules = (
|
||
sendmail => 'SL::Mailer::Sendmail',
|
||||
smtp => 'SL::Mailer::SMTP',
|
||||
);
|
||||
| d319704a | Moritz Bunkus | sub new {
|
||
| 45c9cdd8 | Sven Schöling | my ($type, %params) = @_;
|
||
my $self = { %params };
|
||||
| a40f0c2f | Martin Helmling | $parser = new MIME::Parser;
|
||
$parser->output_under("users");
|
||||
| d319704a | Moritz Bunkus | |||
bless $self, $type;
|
||||
}
|
||||
| 5896d8bf | Moritz Bunkus | sub _create_driver {
|
||
my ($self) = @_;
|
||||
my %params = (
|
||||
mailer => $self,
|
||||
form => $::form,
|
||||
myconfig => \%::myconfig,
|
||||
);
|
||||
| adbc100a | Sven Schöling | my $module = $mail_delivery_modules{ $::lx_office_conf{mail_delivery}->{method} };
|
||
| 16cc4053 | Moritz Bunkus | eval "require $module" or return undef;
|
||
| 7734bb7c | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | return $module->new(%params);
|
||
}
|
||||
| 7734bb7c | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | sub _cleanup_addresses {
|
||
my ($self) = @_;
|
||||
| 7734bb7c | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | foreach my $item (qw(to cc bcc)) {
|
||
next unless $self->{$item};
|
||||
| 7734bb7c | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | $self->{$item} =~ s/\</</g;
|
||
$self->{$item} =~ s/\$<\$/</g;
|
||||
$self->{$item} =~ s/\>/>/g;
|
||||
$self->{$item} =~ s/\$>\$/>/g;
|
||||
| 7734bb7c | Moritz Bunkus | }
|
||
}
|
||||
| 16cc4053 | Moritz Bunkus | sub _create_message_id {
|
||
| 974b5d86 | Moritz Bunkus | my ($self) = @_;
|
||
| 16cc4053 | Moritz Bunkus | $num_sent += 1;
|
||
my $domain = $self->{from};
|
||||
$domain =~ s/.*\@//;
|
||||
$domain =~ s/>.*//;
|
||||
| 920fd369 | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | return "kivitendo-$self->{version}-" . time() . "-${$}-${num_sent}\@$domain";
|
||
}
|
||||
| d319704a | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | sub _create_address_headers {
|
||
my ($self) = @_;
|
||||
| d319704a | Moritz Bunkus | |||
| f8361ca6 | Moritz Bunkus | # $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).
|
||||
| 16cc4053 | Moritz Bunkus | $self->{addresses} = {};
|
||
| d319704a | Moritz Bunkus | |||
| 38c19bfd | Sven Schöling | foreach my $item (qw(from to cc bcc)) {
|
||
| 16cc4053 | Moritz Bunkus | $self->{addresses}->{$item} = [];
|
||
| f8361ca6 | Moritz Bunkus | next if !$self->{$item};
|
||
| 5896d8bf | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | my @header_addresses;
|
||
| 8f3ecba9 | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | foreach my $addr_obj (Email::Address->parse($self->{$item})) {
|
||
push @{ $self->{addresses}->{$item} }, $addr_obj->address;
|
||||
| f8361ca6 | Moritz Bunkus | next if $self->{driver}->keep_from_header($item);
|
||
| 77733865 | Moritz Bunkus | my $phrase = $addr_obj->phrase();
|
||
if ($phrase) {
|
||||
$phrase =~ s/^\"//;
|
||||
$phrase =~ s/\"$//;
|
||||
| 16cc4053 | Moritz Bunkus | $addr_obj->phrase($phrase);
|
||
| 77733865 | Moritz Bunkus | }
|
||
| 8f3ecba9 | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | push @header_addresses, encode('MIME-Header',$addr_obj->format);
|
||
| 8f3ecba9 | Moritz Bunkus | }
|
||
| 5896d8bf | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | push @{ $self->{headers} }, ( ucfirst($item) => join(', ', @header_addresses) ) if @header_addresses;
|
||
}
|
||||
}
|
||||
| d319704a | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | sub _create_attachment_part {
|
||
my ($self, $attachment) = @_;
|
||||
| d319704a | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | my %attributes = (
|
||
| a40f0c2f | Martin Helmling | Disposition => 'attachment',
|
||
Encoding => 'base64',
|
||||
| 16cc4053 | Moritz Bunkus | );
|
||
| 3d779763 | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | my $file_id = 0;
|
||
| 8fec2dc1 | Moritz Bunkus | my $attachment_content;
|
||
| a40f0c2f | Martin Helmling | my $email_journal = $::instance_conf->get_email_journal;
|
||
| 8fec2dc1 | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | $main::lxdebug->message(LXDebug->DEBUG2(), "mail5 att=".$attachment." email_journal=". $email_journal." id=".$attachment->{id});
|
||
| 16cc4053 | Moritz Bunkus | if (ref($attachment) eq "HASH") {
|
||
| a40f0c2f | Martin Helmling | $attributes{Path} = $attachment->{path} || $attachment->{filename};
|
||
$attributes{Filename} = $attachment->{name};
|
||||
$file_id = $attachment->{id} || '0';
|
||||
$attributes{Type} = $attachment->{type} || 'application/pdf';
|
||||
$attachment_content = eval { read_file($attachment->{path}) } if $email_journal > 1;
|
||||
| 3d779763 | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | } else {
|
||
# strip path
|
||||
| a40f0c2f | Martin Helmling | $attributes{Path} = $attachment;
|
||
$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{Type} = File::MimeInfo::Magic::magic($attachment);
|
||||
$attributes{Type} ||= "${application}/$self->{format}" if $self->{format};
|
||||
$attributes{Type} ||= 'application/octet-stream';
|
||||
$attachment_content = eval { read_file($attachment) } if $email_journal > 1;
|
||||
| 16cc4053 | Moritz Bunkus | }
|
||
| d319704a | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | return undef if $email_journal > 1 && !defined $attachment_content;
|
||
$attachment_content ||= ' ';
|
||||
$main::lxdebug->message(LXDebug->DEBUG2(), "mail6 mtype=".$attributes{Type}." path=".
|
||||
$attributes{Path}." filename=".$attributes{Filename});
|
||||
| 48399a5a | Sven Schöling | |||
| a40f0c2f | Martin Helmling | # $attributes{Charset} = $self->{charset} if lc $application eq 'text' && $self->{charset};
|
||
$attributes{Charset} = $self->{charset} if $self->{charset};
|
||||
| d319704a | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | my $ent;
|
||
if ( $attributes{Type} eq 'message/rfc822' ) {
|
||||
my $fh = IO::File->new($attributes{Path}, "r");
|
||||
if (! defined $fh) {
|
||||
return undef;
|
||||
}
|
||||
$ent = $parser->parse($fh);
|
||||
undef $fh;
|
||||
my $head = $ent->head;
|
||||
$head->replace('Content-disposition','attachment; filename='.$attributes{Filename});
|
||||
} else {
|
||||
$ent = MIME::Entity->build(%attributes);
|
||||
}
|
||||
push @{ $self->{mail_attachments}} , SL::DB::EmailJournalAttachment->new(
|
||||
name => $attributes{Filename},
|
||||
mime_type => $attributes{Type},
|
||||
content => ( $email_journal > 1 ? $attachment_content : ' '),
|
||||
file_id => $file_id,
|
||||
| 16cc4053 | Moritz Bunkus | );
|
||
| a40f0c2f | Martin Helmling | return $ent;
|
||
| 16cc4053 | Moritz Bunkus | }
|
||
| d319704a | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | sub _create_message {
|
||
my ($self) = @_;
|
||||
| d319704a | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | push @{ $self->{headers} }, ('Type' =>"multipart/mixed" );
|
||
my $top = MIME::Entity->build(@{$self->{headers}});
|
||||
| 16cc4053 | Moritz Bunkus | if ($self->{message}) {
|
||
| a40f0c2f | Martin Helmling | $top->attach(Data => encode($self->{charset},$self->{message}),
|
||
Charset => $self->{charset},
|
||||
Type => $self->{contenttype},
|
||||
Encoding => 'quoted-printable');
|
||||
| d319704a | Moritz Bunkus | }
|
||
| a40f0c2f | Martin Helmling | map { $top->add_part($self->_create_attachment_part($_)) } @{ $self->{attachments} || [] };
|
||
return $top;
|
||||
| d319704a | Moritz Bunkus | }
|
||
| 16cc4053 | Moritz Bunkus | sub send {
|
||
my ($self) = @_;
|
||||
| d319704a | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | # Create driver for delivery method (sendmail/SMTP)
|
||
$self->{driver} = eval { $self->_create_driver };
|
||||
if (!$self->{driver}) {
|
||||
| 24ab7ec0 | Moritz Bunkus | $self->_store_in_journal('failed', 'driver could not be created; check your configuration');
|
||
| 16cc4053 | Moritz Bunkus | return "send email : $@";
|
||
}
|
||||
| d319704a | Moritz Bunkus | |||
| 16cc4053 | Moritz Bunkus | # Set defaults & headers
|
||
| dbda14c2 | Moritz Bunkus | $self->{charset} = 'UTF-8';
|
||
| 16cc4053 | Moritz Bunkus | $self->{contenttype} ||= "text/plain";
|
||
$self->{headers} = [
|
||||
| a40f0c2f | Martin Helmling | Subject => encode('MIME-Header',$self->{subject}),
|
||
| bdb84974 | Rolf Eike Beer | 'Message-ID' => '<' . $self->_create_message_id . '>',
|
||
| 16cc4053 | Moritz Bunkus | 'X-Mailer' => "kivitendo $self->{version}",
|
||
];
|
||||
| a40f0c2f | Martin Helmling | $self->{mail_attachments} = [];
|
||
$self->{content_by_name} = $::instance_conf->get_email_journal == 1 && $::instance_conf->get_doc_files;
|
||||
| d319704a | Moritz Bunkus | |||
| 24ab7ec0 | Moritz Bunkus | my $error;
|
||
my $ok = eval {
|
||||
# Clean up To/Cc/Bcc address fields
|
||||
$self->_cleanup_addresses;
|
||||
$self->_create_address_headers;
|
||||
| d319704a | Moritz Bunkus | |||
| 24ab7ec0 | Moritz Bunkus | my $email = $self->_create_message;
|
||
| d319704a | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | #$::lxdebug->message(0, "message: " . $email->as_string);
|
||
| 24ab7ec0 | Moritz Bunkus | # return "boom";
|
||
| d319704a | Moritz Bunkus | |||
| a40f0c2f | Martin Helmling | $self->{driver}->start_mail(from => encode('MIME-Header',$self->{from}), to => [ $self->_all_recipients ]);
|
||
| 24ab7ec0 | Moritz Bunkus | $self->{driver}->print($email->as_string);
|
||
$self->{driver}->send;
|
||||
| d319704a | Moritz Bunkus | |||
| 24ab7ec0 | Moritz Bunkus | 1;
|
||
};
|
||||
$error = $@ if !$ok;
|
||||
| a40f0c2f | Martin Helmling | $self->{journalentry} = $self->_store_in_journal;
|
||
$parser->filer->purge;
|
||||
| 24ab7ec0 | Moritz Bunkus | |||
return $ok ? '' : "send email: $error";
|
||||
}
|
||||
sub _all_recipients {
|
||||
my ($self) = @_;
|
||||
$self->{addresses} ||= {};
|
||||
return map { @{ $self->{addresses}->{$_} || [] } } qw(to cc bcc);
|
||||
}
|
||||
sub _store_in_journal {
|
||||
my ($self, $status, $extended_status) = @_;
|
||||
| 687f2d96 | Martin Helmling | my $journal_enable = $::instance_conf->get_email_journal;
|
||
return if $journal_enable == 0;
|
||||
| 24ab7ec0 | Moritz Bunkus | $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} || [] });
|
||||
| a40f0c2f | Martin Helmling | my $jentry = SL::DB::EmailJournal->new(
|
||
| 24ab7ec0 | Moritz Bunkus | 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,
|
||||
| a40f0c2f | Martin Helmling | attachments => \@{ $self->{mail_attachments} },
|
||
| 24ab7ec0 | Moritz Bunkus | status => $status,
|
||
extended_status => $extended_status,
|
||||
)->save;
|
||||
| a40f0c2f | Martin Helmling | return $jentry->id;
|
||
| d319704a | Moritz Bunkus | }
|
||
1;
|