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