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