Warnung unterdrücken die den Test fehlschlagen lässt.
[kivitendo-erp.git] / SL / Mailer.pm
1 #=====================================================================
2 # LX-Office ERP
3 # Copyright (C) 2004
4 # Based on SQL-Ledger Version 2.1.9
5 # Web http://www.lx-office.org
6 #
7 #=====================================================================
8 #
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
13 #
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program; if not, write to the Free Software
20 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
21 #======================================================================
22
23 package Mailer;
24
25 use Email::Address;
26 use Email::MIME::Creator;
27 use File::Slurp;
28
29 use SL::Common;
30 use SL::MIME;
31 use SL::Template;
32
33 use strict;
34
35 my $num_sent = 0;
36
37 sub new {
38   my ($type, %params) = @_;
39   my $self = { %params };
40
41   bless $self, $type;
42 }
43
44 sub _create_driver {
45   my ($self) = @_;
46
47   my %params = (
48     mailer   => $self,
49     form     => $::form,
50     myconfig => \%::myconfig,
51   );
52
53   my $module = ($::lx_office_conf{mail_delivery}->{method} || 'smtp') ne 'smtp' ? 'SL::Mailer::Sendmail' : 'SL::Mailer::SMTP';
54   eval "require $module" or return undef;
55
56   return $module->new(%params);
57 }
58
59 sub _cleanup_addresses {
60   my ($self) = @_;
61
62   foreach my $item (qw(to cc bcc)) {
63     next unless $self->{$item};
64
65     $self->{$item} =~ s/\&lt;/</g;
66     $self->{$item} =~ s/\$<\$/</g;
67     $self->{$item} =~ s/\&gt;/>/g;
68     $self->{$item} =~ s/\$>\$/>/g;
69   }
70 }
71
72 sub _create_message_id {
73   my ($self) = @_;
74
75   $num_sent  +=  1;
76   my $domain  =  $self->{from};
77   $domain     =~ s/.*\@//;
78   $domain     =~ s/>.*//;
79
80   return  "kivitendo-$self->{version}-" . time() . "-${$}-${num_sent}\@$domain";
81 }
82
83 sub _create_address_headers {
84   my ($self) = @_;
85
86   $self->{addresses} = {};
87
88   foreach my $item (qw(from to cc bcc)) {
89     $self->{addresses}->{$item} = [];
90     next if !$self->{$item} || $self->{driver}->keep_from_header($item);
91
92     my @header_addresses;
93
94     foreach my $addr_obj (Email::Address->parse($self->{$item})) {
95       push @{ $self->{addresses}->{$item} }, $addr_obj->address;
96       my $phrase = $addr_obj->phrase();
97       if ($phrase) {
98         $phrase =~ s/^\"//;
99         $phrase =~ s/\"$//;
100         $addr_obj->phrase($phrase);
101       }
102
103       push @header_addresses, $addr_obj->format;
104     }
105
106     push @{ $self->{headers} }, ( ucfirst($item) => join(', ', @header_addresses) ) if @header_addresses;
107   }
108 }
109
110 sub _create_attachment_part {
111   my ($self, $attachment) = @_;
112
113   my $source_file_name;
114
115   my %attributes = (
116     disposition  => 'attachment',
117     encoding     => 'base64',
118   );
119
120   if (ref($attachment) eq "HASH") {
121     $attributes{filename} = $attachment->{name};
122     $source_file_name     = $attachment->{filename};
123
124   } else {
125     # strip path
126     $attributes{filename} =  $attachment;
127     $attributes{filename} =~ s:.*\Q$self->{fileid}\E:: if $self->{fileid};
128     $attributes{filename} =~ s:.*/::g;
129     $source_file_name     =  $attachment;
130   }
131
132   my $attachment_content = eval { read_file($source_file_name) };
133   return undef if !defined $attachment_content;
134
135   my $application             = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? 'text' : 'application';
136   $attributes{content_type}   = SL::MIME->mime_type_from_ext($attributes{filename});
137   $attributes{content_type} ||= "${application}/$self->{format}" if $self->{format};
138   $attributes{content_type} ||= 'application/octet-stream';
139   $attributes{charset}        = $self->{charset} if lc $application eq 'text' && $self->{charset};
140
141   return Email::MIME->create(
142     attributes => \%attributes,
143     body       => $attachment_content,
144   );
145 }
146
147 sub _create_message {
148   my ($self) = @_;
149
150   my @parts;
151
152   if ($self->{message}) {
153     push @parts, Email::MIME->create(
154       attributes => {
155         content_type => $self->{contenttype},
156         charset      => $self->{charset},
157         encoding     => 'quoted-printable',
158       },
159       body_str => $self->{message},
160     );
161
162     push @{ $self->{headers} }, (
163       'Content-Type' => qq|$self->{contenttype}; charset="$self->{charset}"|,
164     );
165   }
166
167   push @parts, grep { $_ } map { $self->_create_attachment_part($_) } @{ $self->{attachments} || [] };
168
169   return Email::MIME->create(
170     header_str => $self->{headers},
171     parts      => \@parts,
172   );
173 }
174
175 sub send {
176   my ($self) = @_;
177
178   # Create driver for delivery method (sendmail/SMTP)
179   $self->{driver} = eval { $self->_create_driver };
180   if (!$self->{driver}) {
181     $::lxdebug->leave_sub();
182     return "send email : $@";
183   }
184
185   # Set defaults & headers
186   $self->{charset}     ||=  Common::DEFAULT_CHARSET;
187   $self->{contenttype} ||=  "text/plain";
188   $self->{headers}       =  [
189     Subject              => $self->{subject},
190     'Message-ID'         => $self->_create_message_id,
191     'X-Mailer'           => "kivitendo $self->{version}",
192   ];
193
194   # Clean up To/Cc/Bcc address fields
195   $self->_cleanup_addresses;
196   $self->_create_address_headers;
197
198   my $email = $self->_create_message;
199
200   # $::lxdebug->message(0, "message: " . $email->as_string);
201   # return "boom";
202
203   $self->{driver}->start_mail(from => $self->{from}, to => [ map { @{ $self->{addresses}->{$_} } } qw(to cc bcc) ]);
204   $self->{driver}->print($email->as_string);
205   $self->{driver}->send;
206
207   return '';
208 }
209
210 1;