selfforum-cgi/shared/Mail.pm

   1 # Mail.pm
   2
   3 ##############################################
   4 #                                            #
   5 # Autor: n.d.p. nd@o3media.de                #
   6 #                                            #
   7 # Letze Aenderung: n.d.p. / 2001-01-03       #
   8 #                                            #
   9 # ========================================== #
  10 #                                            #
  11 # Funktion:                                  #
  12 #      ganz simples Formatieren und Senden   #
  13 #      einer Mail im text/plain, qp-Format   #
  14 #                                            #
  15 ##############################################
  16
  17 use strict;
  18
  19 package Mail;
  20
  21 use vars qw($mailbox $mailprog @EXPORT);
  22
  23 use autouse 'CheckRFC' => qw(is_email($));
  24
  25 # ===================
  26 # Funktionsexport
  27 # ===================
  28
  29 use base qw(Exporter);
  30 @EXPORT = qw(is_mail_address send_mail);
  31
  32 ########################################
  33 # EXPORT
  34 # sub is_mail_address
  35 #
  36 # Funktion:
  37 #      Ueberpruefen der Syntax einer
  38 #      Email-Adresse
  39 #
  40 # Rueckgabe
  41 #      true/false
  42 ########################################
  43
  44 sub is_mail_address ($) {
  45   return is_email $_[0];
  46 }
  47
  48 ########################################
  49 # EXPORT
  50 # sub send_mail
  51 #
  52 # Funktion:
  53 #      Senden der Nachricht
  54 #      ueber open-print-close
  55 #      $Mail::mailprog enthaelt
  56 #      den vollstaendigen string fuer
  57 #      open, dass heisst, es kann
  58 #      auch ein Dateiname sein.
  59 #
  60 # Rueckgabe:
  61 #      true/false
  62 ########################################
  63
  64 sub send_mail {
  65   my $param=shift;
  66   local *MAIL;
  67
  68   open MAIL,$mailprog or return 0;
  69     print MAIL &as_string ($param);
  70   close MAIL and return 1;
  71
  72   # Hier muss irgendwas schiefgelaufen sein
  73   0;
  74 }
  75
  76 ##########################################
  77 # PRIVAT
  78 # sub as_string
  79 #
  80 # Funktion:
  81 #      Bereitstellung der gesamten Mail
  82 #      als String.
  83 #
  84 # Rueckgabe:
  85 #      String
  86 ##########################################
  87
  88 sub as_string {
  89   my $param=shift;
  90
  91   my $header=&header_as_string ($param);
  92   my $body=&body_as_string ($param);
  93
  94   # Rueckgabe
  95   "$header\n$body\n";
  96 }
  97
  98 ##########################################
  99 # PRIVAT
 100 # sub body_as_string
 101 #
 102 # Funktion:
 103 #      Bereitstellung des Bodys
 104 #      als (qp-codierten) String.
 105 #
 106 # Rueckgabe:
 107 #      String
 108 ##########################################
 109
 110 sub body_as_string {
 111   my $param=shift;
 112
 113   &encode_qp($param->{body});
 114 }
 115
 116 ##########################################
 117 # PRIVAT
 118 # sub header_as_string
 119 #
 120 # Funktion:
 121 #      Bereitstellung des Headers
 122 #      als String.
 123 #
 124 # Rueckgabe:
 125 #      String
 126 ##########################################
 127
 128 sub header_as_string {
 129   my $param=shift;
 130
 131   my $string="Content-Disposition: inline\n";
 132      $string.="MIME-Version: 1.0\n";
 133      $string.="Content-Transfer-Encoding: quoted-printable\n";
 134      $string.="Content-Type: text/plain\n";
 135      $string.="Date: ".&rfc822_date(time)."\n";
 136      $string.="From: ".$param->{'from'}."\n";
 137      $string.=&get_list('To',$param->{'to'});
 138      $string.=&get_list('Cc',$param->{'cc'});
 139      $string.=&get_list('Bcc',$param->{'bcc'});
 140      $string.="Subject: ".encode_qp($param->{'subject'})."\n";
 141
 142   # Rueckgabe
 143   $string;
 144 }
 145
 146 #######################################
 147 # PRIVAT
 148 # sub encode_qp
 149 #
 150 # C&P aus dem Modul MIME::QuotedPrint
 151 # Thanx for that
 152 #######################################
 153
 154 sub encode_qp ($)
 155 {
 156     my $res = shift;
 157     $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
 158     $res =~ s/([ \t]+)$/
 159       join('', map { sprintf("=%02X", ord($_)) }
 160                    split('', $1)
 161       )/egm;                        # rule #3 (encode whitespace at eol)
 162
 163     # rule #5 (lines must be shorter than 76 chars, but we are not allowed
 164     # to break =XX escapes.  This makes things complicated :-( )
 165     my $brokenlines = "";
 166     $brokenlines .= "$1=\n"
 167         while $res =~ s/(.*?^[^\n]{73} (?:
 168                  [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
 169                 |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
 170                 |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
 171             ))//xsm;
 172
 173     "$brokenlines$res";
 174 }
 175
 176 ##############################################
 177 # PRIVAT
 178 # sub get_list
 179 #
 180 # Funktion:
 181 #      Aufbereitung einer Liste oder eines
 182 #      Strings fuer den Header (To, Cc, Bcc)
 183 #
 184 # Rueckgabe:
 185 #      Ergebnis oder nichts
 186 ##############################################
 187
 188 sub get_list ($$) {
 189   my ($start,$list)=splice @_;
 190
 191   return $start . ': ' . $list . "\n" if (defined $list and not ref $list and length $list);
 192
 193   return $start . ': ' . join (', ',@$list) . "\n" if (ref $list);
 194
 195   '';
 196 }
 197
 198 ##############################################
 199 # PRIVAT
 200 # sub rfc822_date
 201 #
 202 # Funktion:
 203 #      Bereitstellung eines RFC-konformen
 204 #      Datumstrings
 205 #
 206 # Rueckgabe:
 207 #      Datumstring
 208 ##############################################
 209
 210 sub rfc822_date ($) {
 211   my ($sek, $min, $std, $mtag, $mon, $jahr, $wtag) = gmtime (+shift);
 212
 213   sprintf ('%s, %02d %s %04d %02d:%02d:%02d GMT',
 214              (qw(Sun Mon Tue Wed Thu Fri Sat))[$wtag],
 215              $mtag,
 216              (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon],
 217              $jahr+1900, $std, $min, $sek);
 218 }
 219
 220 ##############################################
 221 # Modulinitialisierung
 222 # BEGIN
 223 #
 224 # Funktion:
 225 #      Bereitstellung des Regexps und des
 226 #      Mailprogs
 227 ##############################################
 228
 229 BEGIN {
 230     # Standard-Mailprogramm
 231
 232     # Dieser String wird so, wie er ist, an die open-Anweisung geschickt,
 233     # -t  = tainted(?),der Header (=alles bis zur ersten Leerzeile)
 234     #       wird nach To:, Cc: und evtl. Bcc: abgesucht.
 235     # -oi = damit wird verhindert, dass sendmail, ein Zeile, wo nur ein
 236     #       Punkt drinsteht, als Mailende erkennt( waere Standard ).
 237     # ===================================================================
 238
 239     $mailprog = '|/usr/lib/sendmail -t -oi';
 240 }
 241
 242 # keeping require happy
 243 1;
 244
 245 #####################
 246 # end of Mail
 247 #####################