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
  36 use SL::Common;
  37 use SL::MIME;
  38 use SL::Template;
  39
  40 use strict;
  41
  42 my $num_sent = 0;
  43
  44 sub new {
  45   $main::lxdebug->enter_sub();
  46
  47   my ($type) = @_;
  48   my $self = {};
  49
  50   $main::lxdebug->leave_sub();
  51
  52   bless $self, $type;
  53 }
  54
  55 sub mime_quote_text {
  56   $main::lxdebug->enter_sub();
  57
  58   my ($self, $text, $chars_left) = @_;
  59
  60   my $q_start = "=?$self->{charset}?Q?";
  61   my $l_start = length($q_start);
  62
  63   my $new_text = "$q_start";
  64   $chars_left -= $l_start if (defined $chars_left);
  65
  66   for (my $i = 0; $i < length($text); $i++) {
  67     my $char = ord(substr($text, $i, 1));
  68
  69     if (($char < 32) || ($char > 127) || ($char == ord('?')) || ($char == ord('_'))) {
  70       if ((defined $chars_left) && ($chars_left < 5)) {
  71         $new_text .= "?=\n $q_start";
  72         $chars_left = 75 - $l_start;
  73       }
  74
  75       $new_text .= sprintf("=%02X", $char);
  76       $chars_left -= 3 if (defined $chars_left);
  77
  78     } else {
  79       $char = ord('_') if ($char == ord(' '));
  80       if ((defined $chars_left) && ($chars_left < 5)) {
  81         $new_text .= "?=\n $q_start";
  82         $chars_left = 75 - $l_start;
  83       }
  84
  85       $new_text .= chr($char);
  86       $chars_left-- if (defined $chars_left);
  87     }
  88   }
  89
  90   $new_text .= "?=";
  91
  92   $main::lxdebug->leave_sub();
  93
  94   return $new_text;
  95 }
  96
  97 sub send {
  98   $main::lxdebug->enter_sub();
  99
 100   my ($self) = @_;
 101
 102   local (*IN, *OUT);
 103
 104   $num_sent++;
 105   my $boundary    = time() . "-$$-${num_sent}";
 106   $boundary       =  "LxOffice-$self->{version}-$boundary";
 107   my $domain      =  $self->recode($self->{from});
 108   $domain         =~ s/(.*?\@|>)//g;
 109   my $msgid       =  "$boundary\@$domain";
 110
 111   my $form        =  $main::form;
 112   my $myconfig    =  \%main::myconfig;
 113
 114   my $email       =  $self->recode($myconfig->{email});
 115   $email          =~ s/[^\w\.\-\+=@]//ig;
 116
 117   my %temp_form   = ( %{ $form }, 'myconfig_email' => $email );
 118   my $template    = SL::Template::create(type => 'PlainText', form => \%temp_form);
 119   my $sendmail    = $template->parse_block($::lx_office_conf{applications}->{sendmail});
 120
 121   if (!open(OUT, "|$sendmail")) {
 122     $main::lxdebug->leave_sub();
 123     return "$sendmail : $!";
 124   }
 125
 126   $self->{charset}     ||= Common::DEFAULT_CHARSET;
 127   $self->{contenttype} ||= "text/plain";
 128
 129   foreach my $item (qw(to cc bcc)) {
 130     next unless ($self->{$item});
 131     $self->{$item} =  $self->recode($self->{$item});
 132     $self->{$item} =~ s/\&lt;/</g;
 133     $self->{$item} =~ s/\$<\$/</g;
 134     $self->{$item} =~ s/\&gt;/>/g;
 135     $self->{$item} =~ s/\$>\$/>/g;
 136   }
 137
 138   $self->{from} = $self->recode($self->{from});
 139
 140   my $headers = '';
 141   foreach my $item (qw(from to cc bcc)) {
 142     next unless ($self->{$item});
 143     my (@addr_objects) = Email::Address->parse($self->{$item});
 144     next unless (scalar @addr_objects);
 145
 146     foreach my $addr_obj (@addr_objects) {
 147       my $phrase = $addr_obj->phrase();
 148       if ($phrase) {
 149         $phrase =~ s/^\"//;
 150         $phrase =~ s/\"$//;
 151         $addr_obj->phrase($self->mime_quote_text($phrase));
 152       }
 153
 154       $headers .= sprintf("%s: %s\n", ucfirst($item), $addr_obj->format());
 155     }
 156   }
 157
 158   $headers .= sprintf("Subject: %s\n", $self->mime_quote_text($self->recode($self->{subject}), 60));
 159
 160   print OUT qq|${headers}Message-ID: <$msgid>
 161 X-Mailer: Lx-Office $self->{version}
 162 MIME-Version: 1.0
 163 |;
 164
 165   if ($self->{attachments}) {
 166     print OUT qq|Content-Type: multipart/mixed; boundary="$boundary"
 167
 168 |;
 169     if ($self->{message}) {
 170       print OUT qq|--${boundary}
 171 Content-Type: $self->{contenttype}; charset="$self->{charset}"
 172
 173 | . $self->recode($self->{message}) . qq|
 174
 175 |;
 176     }
 177
 178     foreach my $attachment (@{ $self->{attachments} }) {
 179
 180       my $filename;
 181
 182       if (ref($attachment) eq "HASH") {
 183         $filename = $attachment->{"name"};
 184         $attachment = $attachment->{"filename"};
 185       } else {
 186         $filename = $attachment;
 187         # strip path
 188         $filename =~ s/(.*\/|\Q$self->{fileid}\E)//g;
 189       }
 190
 191       my $application    = ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/) ? "text" : "application";
 192       my $content_type   = SL::MIME->mime_type_from_ext($filename);
 193       $content_type      = "${application}/$self->{format}" if (!$content_type && $self->{format});
 194       $content_type    ||= 'application/octet-stream';
 195
 196       open(IN, $attachment);
 197       if ($?) {
 198         close(OUT);
 199         $main::lxdebug->leave_sub();
 200         return "$attachment : $!";
 201       }
 202
 203       # only set charset for attachements of type text. every other type should not have this field
 204       # refer to bug 883 for detailed information
 205       my $attachment_charset;
 206       if (lc $application eq 'text' && $self->{charset}) {
 207         $attachment_charset = qq|; charset="$self->{charset}" |;
 208       }
 209
 210       print OUT qq|--${boundary}
 211 Content-Type: ${content_type}; name="$filename"$attachment_charset
 212 Content-Transfer-Encoding: BASE64
 213 Content-Disposition: attachment; filename="$filename"\n\n|;
 214
 215       my $msg = "";
 216       while (<IN>) {
 217         ;
 218         $msg .= $_;
 219       }
 220       print OUT &encode_base64($msg);
 221
 222       close(IN);
 223
 224     }
 225     print OUT qq|--${boundary}--\n|;
 226
 227   } else {
 228     print OUT qq|Content-Type: $self->{contenttype}; charset="$self->{charset}"
 229
 230 | . $self->recode($self->{message}) . qq|
 231 |;
 232   }
 233
 234   close(OUT);
 235
 236   $main::lxdebug->leave_sub();
 237
 238   return "";
 239 }
 240
 241 sub encode_base64 ($;$) {
 242   $main::lxdebug->enter_sub();
 243
 244   # this code is from the MIME-Base64-2.12 package
 245   # Copyright 1995-1999,2001 Gisle Aas <gisle@ActiveState.com>
 246
 247   my $res = "";
 248   my $eol = $_[1];
 249   $eol = "\n" unless defined $eol;
 250   pos($_[0]) = 0;    # ensure start at the beginning
 251
 252   $res = join '', map(pack('u', $_) =~ /^.(\S*)/, ($_[0] =~ /(.{1,45})/gs));
 253
 254   $res =~ tr|` -_|AA-Za-z0-9+/|;    # `# help emacs
 255                                     # fix padding at the end
 256   my $padding = (3 - length($_[0]) % 3) % 3;
 257   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
 258
 259   # break encoded string into lines of no more than 60 characters each
 260   if (length $eol) {
 261     $res =~ s/(.{1,60})/$1$eol/g;
 262   }
 263
 264   $main::lxdebug->leave_sub();
 265
 266   return $res;
 267 }
 268
 269 sub recode {
 270   my $self = shift;
 271   my $text = shift;
 272
 273   return $::locale->is_utf8 ? Encode::encode('utf-8-strict', $text) : $text;
 274 }
 275
 276 1;
 277