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