Attachments via File::Slurp einlesen, nicht manuell
[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 # SQL-Ledger Accounting
9 # Copyright (C) 2001
10 #
11 #  Author: Dieter Simader
12 #   Email: dsimader@sql-ledger.org
13 #     Web: http://www.sql-ledger.org
14 #
15 # Contributors:
16 #
17 # This program is free software; you can redistribute it and/or modify
18 # it under the terms of the GNU General Public License as published by
19 # the Free Software Foundation; either version 2 of the License, or
20 # (at your option) any later version.
21 #
22 # This program is distributed in the hope that it will be useful,
23 # but WITHOUT ANY WARRANTY; without even the implied warranty of
24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
25 # GNU General Public License for more details.
26 # You should have received a copy of the GNU General Public License
27 # along with this program; if not, write to the Free Software
28 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
29 #======================================================================
30
31 package Mailer;
32
33 use Email::Address;
34 use Encode;
35 use File::Slurp;
36
37 use SL::Common;
38 use SL::MIME;
39 use SL::Template;
40
41 use strict;
42
43 my $num_sent = 0;
44
45 sub new {
46   $main::lxdebug->enter_sub();
47
48   my ($type, %params) = @_;
49   my $self = { %params };
50
51   $main::lxdebug->leave_sub();
52
53   bless $self, $type;
54 }
55
56 sub _create_driver {
57   my ($self) = @_;
58
59   my %params = (
60     mailer   => $self,
61     form     => $::form,
62     myconfig => \%::myconfig,
63   );
64
65   my $cfg = $::lx_office_conf{mail_delivery};
66   if (($cfg->{method} || 'smtp') ne 'smtp') {
67     require SL::Mailer::Sendmail;
68     return SL::Mailer::Sendmail->new(%params);
69   } else {
70     require SL::Mailer::SMTP;
71     return SL::Mailer::SMTP->new(%params);
72   }
73 }
74
75 sub mime_quote_text {
76   $main::lxdebug->enter_sub();
77
78   my ($self, $text, $chars_left) = @_;
79
80   my $q_start = "=?$self->{charset}?Q?";
81   my $l_start = length($q_start);
82
83   my $new_text = "$q_start";
84   $chars_left -= $l_start if (defined $chars_left);
85
86   for (my $i = 0; $i < length($text); $i++) {
87     my $char = ord(substr($text, $i, 1));
88
89     if (($char < 32) || ($char > 127) || ($char == ord('?')) || ($char == ord('_'))) {
90       if ((defined $chars_left) && ($chars_left < 5)) {
91         $new_text .= "?=\n $q_start";
92         $chars_left = 75 - $l_start;
93       }
94
95       $new_text .= sprintf("=%02X", $char);
96       $chars_left -= 3 if (defined $chars_left);
97
98     } else {
99       $char = ord('_') if ($char == ord(' '));
100       if ((defined $chars_left) && ($chars_left < 5)) {
101         $new_text .= "?=\n $q_start";
102         $chars_left = 75 - $l_start;
103       }
104
105       $new_text .= chr($char);
106       $chars_left-- if (defined $chars_left);
107     }
108   }
109
110   $new_text .= "?=";
111
112   $main::lxdebug->leave_sub();
113
114   return $new_text;
115 }
116
117 sub send {
118   $main::lxdebug->enter_sub();
119
120   my ($self) = @_;
121
122   local (*IN);
123
124   $num_sent++;
125   my $boundary    = time() . "-$$-${num_sent}";
126   $boundary       =  "kivitendo-$self->{version}-$boundary";
127   my $domain      =  $self->recode($self->{from});
128   $domain         =~ s/(.*?\@|>)//g;
129   my $msgid       =  "$boundary\@$domain";
130
131   my $form        =  $main::form;
132   my $myconfig    =  \%main::myconfig;
133
134   my $driver = eval { $self->_create_driver };
135   if (!$driver) {
136     $main::lxdebug->leave_sub();
137     return "send email : $@";
138   }
139
140   $self->{charset}     ||= Common::DEFAULT_CHARSET;
141   $self->{contenttype} ||= "text/plain";
142
143   foreach my $item (qw(to cc bcc)) {
144     next unless ($self->{$item});
145     $self->{$item} =  $self->recode($self->{$item});
146     $self->{$item} =~ s/\&lt;/</g;
147     $self->{$item} =~ s/\$<\$/</g;
148     $self->{$item} =~ s/\&gt;/>/g;
149     $self->{$item} =~ s/\$>\$/>/g;
150   }
151
152   $self->{from} = $self->recode($self->{from});
153
154   my %addresses;
155   my $headers = '';
156   foreach my $item (qw(from to cc bcc)) {
157     $addresses{$item} = [];
158     next unless ($self->{$item});
159
160     my (@addr_objects) = Email::Address->parse($self->{$item});
161     next unless (scalar @addr_objects);
162
163     foreach my $addr_obj (@addr_objects) {
164       push @{ $addresses{$item} }, $addr_obj->address;
165       my $phrase = $addr_obj->phrase();
166       if ($phrase) {
167         $phrase =~ s/^\"//;
168         $phrase =~ s/\"$//;
169         $addr_obj->phrase($self->mime_quote_text($phrase));
170       }
171
172       $headers .= sprintf("%s: %s\n", ucfirst($item), $addr_obj->format()) unless $driver->keep_from_header($item);
173     }
174   }
175
176   $headers .= sprintf("Subject: %s\n", $self->mime_quote_text($self->recode($self->{subject}), 60));
177
178   $driver->start_mail(from => $self->{from}, to => [ map { @{ $addresses{$_} } } qw(to cc bcc) ]);
179
180   $driver->print(qq|${headers}Message-ID: <$msgid>
181 X-Mailer: kivitendo $self->{version}
182 MIME-Version: 1.0
183 |);
184
185   if ($self->{attachments}) {
186     $driver->print(qq|Content-Type: multipart/mixed; boundary="$boundary"\n\n|);
187     if ($self->{message}) {
188       $driver->print(qq|--${boundary}
189 Content-Type: $self->{contenttype}; charset="$self->{charset}"
190
191 | . $self->recode($self->{message}) . qq|
192
193 |);
194     }
195
196     foreach my $attachment (@{ $self->{attachments} }) {
197
198       my $filename;
199
200       if (ref($attachment) eq "HASH") {
201         $filename = $attachment->{"name"};
202         $attachment = $attachment->{"filename"};
203       } else {
204         $filename = $attachment;
205         # strip path
206         $filename =~ s/(.*\/|\Q$self->{fileid}\E)//g;
207       }
208
209       my $attachment_content = eval { read_file($attachment) };
210       if (!defined $attachment_content) {
211         $main::lxdebug->leave_sub();
212         return "$attachment : $!";
213       }
214
215       my $application    = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? "text" : "application";
216       my $content_type   = SL::MIME->mime_type_from_ext($filename);
217       $content_type      = "${application}/$self->{format}" if (!$content_type && $self->{format});
218       $content_type    ||= 'application/octet-stream';
219
220       # only set charset for attachements of type text. every other type should not have this field
221       # refer to bug 883 for detailed information
222       my $attachment_charset;
223       if (lc $application eq 'text' && $self->{charset}) {
224         $attachment_charset = qq|; charset="$self->{charset}" |;
225       }
226
227       $driver->print(qq|--${boundary}
228 Content-Type: ${content_type}; name="$filename"$attachment_charset
229 Content-Transfer-Encoding: BASE64
230 Content-Disposition: attachment; filename="$filename"\n\n|);
231
232       $driver->print(encode_base64($attachment_content));
233     }
234     $driver->print(qq|--${boundary}--\n|);
235
236   } else {
237     $driver->print(qq|Content-Type: $self->{contenttype}; charset="$self->{charset}"
238
239 | . $self->recode($self->{message}) . qq|
240 |);
241   }
242
243   $driver->send;
244
245   $main::lxdebug->leave_sub();
246
247   return "";
248 }
249
250 sub encode_base64 ($;$) {
251   $main::lxdebug->enter_sub();
252
253   # this code is from the MIME-Base64-2.12 package
254   # Copyright 1995-1999,2001 Gisle Aas <gisle@ActiveState.com>
255
256   my $res = "";
257   my $eol = $_[1];
258   $eol = "\n" unless defined $eol;
259   pos($_[0]) = 0;    # ensure start at the beginning
260
261   $res = join '', map(pack('u', $_) =~ /^.(\S*)/, ($_[0] =~ /(.{1,45})/gs));
262
263   $res =~ tr|` -_|AA-Za-z0-9+/|;    # `# help emacs
264                                     # fix padding at the end
265   my $padding = (3 - length($_[0]) % 3) % 3;
266   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
267
268   # break encoded string into lines of no more than 60 characters each
269   if (length $eol) {
270     $res =~ s/(.{1,60})/$1$eol/g;
271   }
272
273   $main::lxdebug->leave_sub();
274
275   return $res;
276 }
277
278 sub recode {
279   my $self = shift;
280   my $text = shift;
281
282   return $::locale->is_utf8 ? Encode::encode('utf-8-strict', $text) : $text;
283 }
284
285 1;