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 @ISA @EXPORT);
  22
  23 # ===================
  24 # Funktionsexport
  25 # ===================
  26
  27 require Exporter;
  28 @ISA = qw(Exporter);
  29 @EXPORT = qw(is_mail_address send_mail);
  30
  31 ########################################
  32 # EXPORT
  33 # sub is_mail_address
  34 #
  35 # Funktion:
  36 #      Ueberpruefen der Syntax einer
  37 #      Email-Adresse
  38 #
  39 # Rueckgabe
  40 #      true/false
  41 ########################################
  42
  43 sub is_mail_address ($) {
  44   return ($_[0] =~ /$mailbox/);
  45 }
  46
  47 ########################################
  48 # EXPORT
  49 # sub send_mail
  50 #
  51 # Funktion:
  52 #      Senden der Nachricht
  53 #      ueber open-print-close
  54 #      $Mail::mailprog enthaelt
  55 #      den vollstaendigen string fuer
  56 #      open, dass heisst, es kann
  57 #      auch ein Dateiname sein.
  58 #
  59 # Rueckgabe:
  60 #      true/false
  61 ########################################
  62
  63 sub send_mail {
  64   my $param=shift;
  65   local *MAIL;
  66
  67   open MAIL,$mailprog or return 0;
  68     print MAIL &as_string ($param);
  69   close MAIL and return 1;
  70
  71   # Hier muss irgendwas schiefgelaufen sein
  72   0;
  73 }
  74
  75 ##########################################
  76 # PRIVAT
  77 # sub as_string
  78 #
  79 # Funktion:
  80 #      Bereitstellung der gesamten Mail
  81 #      als String.
  82 #
  83 # Rueckgabe:
  84 #      String
  85 ##########################################
  86
  87 sub as_string {
  88   my $param=shift;
  89
  90   my $header=&header_as_string ($param);
  91   my $body=&body_as_string ($param);
  92
  93   # Rueckgabe
  94   "$header\n$body\n";
  95 }
  96
  97 ##########################################
  98 # PRIVAT
  99 # sub body_as_string
 100 #
 101 # Funktion:
 102 #      Bereitstellung des Bodys
 103 #      als (qp-codierten) String.
 104 #
 105 # Rueckgabe:
 106 #      String
 107 ##########################################
 108
 109 sub body_as_string {
 110   my $param=shift;
 111
 112   &encode_qp($param->{body});
 113 }
 114
 115 ##########################################
 116 # PRIVAT
 117 # sub header_as_string
 118 #
 119 # Funktion:
 120 #      Bereitstellung des Headers
 121 #      als String.
 122 #
 123 # Rueckgabe:
 124 #      String
 125 ##########################################
 126
 127 sub header_as_string {
 128   my $param=shift;
 129
 130   my $string="Content-Disposition: inline\n";
 131      $string.="MIME-Version: 1.0\n";
 132      $string.="Content-Transfer-Encoding: quoted-printable\n";
 133      $string.="Content-Type: text/plain\n";
 134      $string.="Date: ".&rfc822_date(time)."\n";
 135      $string.="From: ".$param->{'from'}."\n";
 136      $string.=&get_list('To',$param->{'to'});
 137      $string.=&get_list('Cc',$param->{'cc'});
 138      $string.=&get_list('Bcc',$param->{'bcc'});
 139      $string.="Subject: ".encode_qp($param->{'subject'})."\n";
 140
 141   # Rueckgabe
 142   $string;
 143 }
 144
 145 #######################################
 146 # PRIVAT
 147 # sub encode_qp
 148 #
 149 # C&P aus dem Modul MIME::QuotedPrint
 150 # Thanx for that
 151 #######################################
 152
 153 sub encode_qp ($)
 154 {
 155     my $res = shift;
 156     $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
 157     $res =~ s/([ \t]+)$/
 158       join('', map { sprintf("=%02X", ord($_)) }
 159                    split('', $1)
 160       )/egm;                        # rule #3 (encode whitespace at eol)
 161
 162     # rule #5 (lines must be shorter than 76 chars, but we are not allowed
 163     # to break =XX escapes.  This makes things complicated :-( )
 164     my $brokenlines = "";
 165     $brokenlines .= "$1=\n"
 166         while $res =~ s/(.*?^[^\n]{73} (?:
 167                  [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
 168                 |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
 169                 |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
 170             ))//xsm;
 171
 172     "$brokenlines$res";
 173 }
 174
 175 ##############################################
 176 # PRIVAT
 177 # sub get_list
 178 #
 179 # Funktion:
 180 #      Aufbereitung einer Liste oder eines
 181 #      Strings fuer den Header (To, Cc, Bcc)
 182 #
 183 # Rueckgabe:
 184 #      Ergebnis oder nichts
 185 ##############################################
 186
 187 sub get_list ($$) {
 188   my ($start,$list)=splice @_;
 189   my $string="";
 190
 191   return "" unless (length($list));
 192   if (ref($list)) {
 193     return "" unless (@$list);
 194     foreach (@$list) {
 195       $string.="$start: $_\n";}}
 196   else {
 197     $string="$start: $list\n";}
 198
 199   # Rueckgabe
 200   $string;
 201 }
 202
 203 ##############################################
 204 # PRIVAT
 205 # sub rfc822_date
 206 #
 207 # Funktion:
 208 #      Bereitstellung eines RFC-konformen
 209 #      Datumstrings
 210 #
 211 # Rueckgabe:
 212 #      Datumstring
 213 ##############################################
 214
 215 sub rfc822_date ($) {
 216   my ($sek, $min, $std, $mtag, $mon, $jahr, $wtag) = gmtime (+shift);
 217
 218   sprintf ('%s, %02d %s %04d %02d:%02d:%02d GMT',
 219              (qw(Sun Mon Tue Wed Thu Fri Sat))[$wtag],
 220              $mtag,
 221              (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon],
 222              $jahr+1900, $std, $min, $sek);
 223 }
 224
 225 ##############################################
 226 # Modulinitialisierung
 227 # BEGIN
 228 #
 229 # Funktion:
 230 #      Bereitstellung des Regexps und des
 231 #      Mailprogs
 232 ##############################################
 233
 234 BEGIN {
 235     # Standard-Mailprogramm
 236
 237     # Dieser String wird so, wie er ist, an die open-Anweisung geschickt,
 238     # -t  = tainted(?),der Header (=alles bis zur ersten Leerzeile)
 239     #       wird nach To:, Cc: und evtl. Bcc: abgesucht.
 240     # -oi = damit wird verhindert, dass sendmail, ein Zeile, wo nur ein
 241     #       Punkt drinsteht, als Mailende erkennt( waere Standard ).
 242     # ===================================================================
 243
 244     $mailprog = '|/usr/lib/sendmail -t -oi';
 245
 246     # Thanx to J. Friedl for this regex:
 247
 248     my ($address,$route_addr,$phrase,$addr_spec,$X,$phrase_char,$quoted_str,$comment,$word,$phrase_ctrl,$NonASCII,
 249         $CloseBR,$OpenBR,$esc,$route,$domain,$local_part,$Period,$sub_domain,$domain_lit,$domain_ref,$quoted_pair,
 250         $dtext,$atom,$qtext,$atom_char,$ctrl,$space,$tab,$CloseParen,$ctext,$Cnested,$OpenParen,$CRlist);
 251
 252     $esc        = '\\\\';
 253     $Period      = '\.';
 254     $space      = '\040';
 255     $tab         = '\t';
 256     $OpenBR     = '\[';
 257     $CloseBR     = '\]';
 258     $OpenParen  = '\(';
 259     $CloseParen  = '\)';
 260     $NonASCII   = '\x80-\xff';
 261     $ctrl        = '\000-\037';
 262     $CRlist     = '\n\015';
 263     $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
 264     $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
 265     $quoted_pair = qq< $esc [^$NonASCII] >;
 266     $ctext   = qq< [^$esc$NonASCII$CRlist()] >;
 267     $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
 268     $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
 269     $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
 270     $atom_char   = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
 271     $atom = qq< $atom_char+ (?!$atom_char) >;
 272     $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
 273     $word = qq< (?: $atom | $quoted_str ) >;
 274     $domain_ref  = $atom;
 275     $domain_lit  = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
 276     $sub_domain  = qq< (?: $domain_ref | $domain_lit ) $X >;
 277     $domain = qq< $sub_domain (?: $Period $X $sub_domain )* >;
 278     $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
 279     $local_part = qq< $word $X (?: $Period $X $word $X )* >;
 280     $addr_spec  = qq< $local_part \@ $X $domain >;
 281     $route_addr = qq[ < $X (?: $route )? $addr_spec > ];
 282     $phrase_ctrl = '\000-\010\012-\037';
 283     $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
 284     $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
 285     $mailbox = qq< $X (?: $addr_spec | $phrase  $route_addr ) >;
 286     $mailbox = qr ~^$mailbox$~x;
 287 }
 288
 289 # making 'require' happy
 290 1;
 291
 292 #####################
 293 # end of Mail
 294 #####################