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 send {
  45   $main::lxdebug->enter_sub();
  46
  47   my ($self, $out) = @_;
  48
  49   my $boundary = time;
  50   $boundary = "SL-$self->{version}-$boundary";
  51   my $domain = $self->{from};
  52   $domain =~ s/(.*?\@|>)//g;
  53   my $msgid = "$boundary\@$domain";
  54
  55   $self->{charset} = "ISO-8859-1" unless $self->{charset};
  56
  57   if ($out) {
  58     if (!open(OUT, $out)) {
  59       $main::lxdebug->leave_sub();
  60       return "$out : $!";
  61     }
  62   } else {
  63     if (!open(OUT, ">-")) {
  64       $main::lxdebug->leave_sub();
  65       return "STDOUT : $!";
  66     }
  67   }
  68
  69   $self->{contenttype} = "text/plain" unless $self->{contenttype};
  70
  71   my ($cc, $bcc);
  72   $cc  = "Cc: $self->{cc}\n"   if $self->{cc};
  73   $bcc = "Bcc: $self->{bcc}\n" if $self->{bcc};
  74
  75   foreach my $item (qw(to cc bcc)) {
  76     $self->{$item} =~ s/\&lt;/</g;
  77     $self->{$item} =~ s/\$<\$/</g;
  78     $self->{$item} =~ s/\&gt;/>/g;
  79     $self->{$item} =~ s/\$>\$/>/g;
  80   }
  81
  82   print OUT qq|From: $self->{from}
  83 To: $self->{to}
  84 ${cc}${bcc}Subject: $self->{subject}
  85 Message-ID: <$msgid>
  86 X-Mailer: SQL-Ledger $self->{version}
  87 MIME-Version: 1.0
  88 |;
  89
  90   if ($self->{attachments}) {
  91     print OUT qq|Content-Type: multipart/mixed; boundary="$boundary"
  92
  93 |;
  94     if ($self->{message}) {
  95       print OUT qq|--${boundary}
  96 Content-Type: $self->{contenttype}; charset="$self->{charset}"
  97
  98 $self->{message}
  99
 100 |;
 101     }
 102
 103     foreach my $attachment (@{ $self->{attachments} }) {
 104
 105       my $application =
 106         ($attachment =~ /(^\w+$)|\.(html|text|txt|sql)$/)
 107         ? "text"
 108         : "application";
 109
 110       open(IN, $attachment);
 111       if ($?) {
 112         close(OUT);
 113         $main::lxdebug->leave_sub();
 114         return "$attachment : $!";
 115       }
 116
 117       my $filename = $attachment;
 118
 119       # strip path
 120       $filename =~ s/(.*\/|$self->{fileid})//g;
 121
 122       print OUT qq|--${boundary}
 123 Content-Type: $application/$self->{format}; name="$filename"; charset="$self->{charset}"
 124 Content-Transfer-Encoding: BASE64
 125 Content-Disposition: attachment; filename="$filename"\n\n|;
 126
 127       my $msg = "";
 128       while (<IN>) {
 129         ;
 130         $msg .= $_;
 131       }
 132       print OUT &encode_base64($msg);
 133
 134       close(IN);
 135
 136     }
 137     print OUT qq|--${boundary}--\n|;
 138
 139   } else {
 140     print OUT qq|Content-Type: $self->{contenttype}; charset="$self->{charset}"
 141
 142 $self->{message}
 143 |;
 144   }
 145
 146   close(OUT);
 147
 148   $main::lxdebug->leave_sub();
 149
 150   return "";
 151 }
 152
 153 sub encode_base64 ($;$) {
 154   $main::lxdebug->enter_sub();
 155
 156   # this code is from the MIME-Base64-2.12 package
 157   # Copyright 1995-1999,2001 Gisle Aas <gisle@ActiveState.com>
 158
 159   my $res = "";
 160   my $eol = $_[1];
 161   $eol = "\n" unless defined $eol;
 162   pos($_[0]) = 0;    # ensure start at the beginning
 163
 164   $res = join '', map(pack('u', $_) =~ /^.(\S*)/, ($_[0] =~ /(.{1,45})/gs));
 165
 166   $res =~ tr|` -_|AA-Za-z0-9+/|;    # `# help emacs
 167                                     # fix padding at the end
 168   my $padding = (3 - length($_[0]) % 3) % 3;
 169   $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
 170
 171   # break encoded string into lines of no more than 60 characters each
 172   if (length $eol) {
 173     $res =~ s/(.{1,60})/$1$eol/g;
 174   }
 175
 176   $main::lxdebug->leave_sub();
 177
 178   return $res;
 179 }
 180
 181 1;
 182