code/UserTag/email.tag

   1 # Copyright 2002-2010 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7
   8 UserTag email Order to subject reply from extra
   9 UserTag email hasEndTag
  10 UserTag email addAttr
  11 UserTag email Interpolate
  12 UserTag email Routine <<EOR
  13
  14 my $Have_mime_lite;
  15 BEGIN {
  16         eval {
  17                 require MIME::Lite;
  18                 $Have_mime_lite = 1;
  19         };
  20 }
  21
  22 sub utf8_to_other {
  23         my ($string, $encoding) = @_;
  24         return $string unless defined Encode::PERLQQ(); # nop if no Encode
  25
  26         unless(Encode::is_utf8($string)){
  27                 $string = Encode::decode('utf-8', $string);
  28         }
  29         return Encode::encode($encoding, $string);
  30 }
  31
  32 sub {
  33     my ($to, $subject, $reply, $from, $extra, $opt, $body) = @_;
  34     my $ok = 0;
  35     my ($cc, $bcc, @extra, $utf8);
  36
  37         use vars qw/ $Tag /;
  38
  39     $subject = '<no subject>' unless defined $subject && $subject;
  40
  41         if (! $from) {
  42                 $from = $Vend::Cfg->{MailOrderTo};
  43                 $from =~ s/,.*//;
  44         }
  45
  46         # Use local copy to avoid mangling with caller's data
  47         $cc = $opt->{cc};
  48         $bcc = $opt->{bcc};
  49
  50         # See if UTF-8 support is required
  51         $utf8 = $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};
  52
  53         # Prevent header injections from spammers' hostile content
  54         for ($to, $subject, $reply, $from, $cc, $bcc) {
  55                 # unfold valid RFC 2822 "2.2.3. Long Header Fields"
  56                 s/\r?\n([ \t]+)/$1/g;
  57                 # now remove any invalid extra lines left over
  58                 s/[\r\n](.*)//s
  59                         and ::logError("Header injection attempted in email tag: %s", $1);
  60         }
  61
  62
  63         for (grep /\S/, split /[\r\n]+/, $extra) {
  64                 # require header conformance with RFC 2822 section 2.2
  65                 push (@extra, $_), next if /^[\x21-\x39\x3b-\x7e]+:[\x00-\x09\x0b\x0c\x0e-\x7f]+$/;
  66                 ::logError("Invalid header given to email tag: %s", $_);
  67         }
  68         unshift @extra, "From: $from" if $from;
  69
  70         # force utf8 email through MIME as attachment
  71         unless (($opt->{attach} || $opt->{html}) && $utf8){
  72                 $opt->{body_mime} = $opt->{mimetype};
  73                 $body = utf8_to_other($body, 'utf-8');
  74         }
  75
  76         my $sent_with_attach = 0;
  77
  78         ATTACH: {
  79 #::logDebug("Checking for attachment");
  80                 last ATTACH unless $opt->{attach} || $opt->{html};
  81
  82                 unless ($Have_mime_lite) {
  83                         ::logError("email tag: attachment without MIME::Lite installed.");
  84                         last ATTACH;
  85                 }
  86
  87                 my $att1_format;
  88                 if($opt->{html}) {
  89                         $opt->{mimetype} ||= 'multipart/alternative';
  90                         $att1_format = 'flowed';
  91                 }
  92                 else {
  93                         $opt->{mimetype} ||= 'multipart/mixed';
  94                 }
  95
  96                 my $att = $opt->{attach};
  97                 my @attach;
  98                 my @extra_headers;
  99
 100                 # encode values if utf8 is supported
 101                 if($utf8){
 102                         $to = utf8_to_other($to, 'MIME-Header');
 103                         $from = utf8_to_other($from, 'MIME-Header');
 104                         $subject = utf8_to_other($subject, 'MIME-Header');
 105                         $cc = utf8_to_other($cc, 'MIME-Header');
 106                         $bcc = utf8_to_other($bcc, 'MIME-Header');
 107                         $reply = utf8_to_other($reply, 'MIME-Header');
 108                 }
 109
 110                 my $msg = new MIME::Lite
 111                                         To => $to,
 112                                         From => $from,
 113                                         Subject => $subject,
 114                                         Type => $opt->{mimetype},
 115                                         Cc => $cc,
 116                                         Bcc => $bcc,
 117                                         'Reply-To' => $reply,
 118                                 ;
 119
 120                 for(@extra) {
 121                         m{(.*?):\s+(.*)};
 122                         my $name = $1 or next;
 123                         next if lc($name) eq 'from';
 124                         my $content = $2 or next;
 125                         $name =~ s/[-_]+/-/g;
 126                         $name =~ s/\b(\w)/\U$1/g;
 127                         $msg->add($name, ($utf8 ? utf8_to_other($content, 'UTF-8')
 128                                                                         : $content))
 129                                 if $name && $content;
 130                 }
 131
 132                 $opt->{body_mime} ||= 'text/plain' . ($utf8 ? '; charset=UTF-8' : '');
 133                 $opt->{body_encoding} ||= 'quoted-printable';
 134                 $msg->attach(
 135                                 Type => $opt->{body_mime},
 136                                 Encoding => $opt->{body_encoding},
 137                                 Data => $body,
 138                                 Disposition => $opt->{body_disposition} || 'inline',
 139                                 Format => $opt->{body_format} || $att1_format,
 140                         );
 141
 142                 if(! ref($att) ) {
 143                         my $fn = $att;
 144                         $att = [ { path => $fn } ];
 145                 }
 146                 elsif(ref($att) eq 'HASH') {
 147                         $att = [ $att ];
 148                 }
 149                 elsif(ref($att) eq 'ARRAY') {
 150                         # turn array of file names into array of hash references
 151                         my $new_att = [];
 152
 153                         for (@$att) {
 154                                 if (ref($_)) {
 155                                         push (@$new_att, $_);
 156                                 }
 157                                 else {
 158                                         push (@$new_att, {path => $_});
 159                                 }
 160                         }
 161
 162                         $att = $new_att;
 163                 }
 164
 165                 $att ||= [];
 166
 167                 if($opt->{html}) {
 168                         unshift @$att, {type => 'text/html'
 169                                                         .($utf8 ? '; charset=UTF-8': ''),
 170                                                         data => ($utf8 ? utf8_to_other($opt->{html}, 'UTF-8') : $opt->{html}),
 171                                                         disposition => 'inline',
 172                                                         };
 173                 }
 174
 175                 my %encoding_types = (
 176                         'text/plain' => ($utf8 ? 'quoted-printable' : '8bit'),
 177                         'text/html' => 'quoted-printable',
 178                 );
 179
 180                 for my $ref (@$att) {
 181                         next unless $ref;
 182                         next unless $ref->{path} || $ref->{data};
 183                         unless ($ref->{filename}) {
 184                                 my $fn = $ref->{path};
 185                                 $fn =~ s:.*[\\/]::;
 186                                 $ref->{filename} = $fn;
 187                         }
 188
 189                         $ref->{type} ||= 'AUTO';
 190                         $ref->{disposition} ||= 'attachment';
 191
 192                         if(! $ref->{encoding}) {
 193                                 $ref->{encoding} = $encoding_types{$ref->{type}};
 194                         }
 195                         eval {
 196                                 $msg->attach(
 197                                         Type => $ref->{type},
 198                                         Path => $ref->{path},
 199                                         ReadNow => 1,
 200                                         Data => $ref->{data},
 201                                         Filename => $ref->{filename},
 202                                         Encoding => $ref->{encoding},
 203                                         Disposition => $ref->{disposition},
 204                                 );
 205                         };
 206                         if($@) {
 207                                 ::logError("email tag: failed to attach %s: %s", $ref->{path}, $@);
 208                                 $Tag->error({name => 'email',
 209                                         set => errmsg('Failed to attach %s', $ref->{path})});
 210                                 return;
 211                         }
 212                 }
 213
 214                 my $body = $msg->body_as_string;
 215                 my $header = $msg->header_as_string;
 216 #::logDebug("[email] Mail: \n$header\n$body");
 217                 if($opt->{test}) {
 218                         return "$header\n$body";
 219                 }
 220                 else {
 221                         last ATTACH unless $header;
 222                         my @head = split(/\r?\n/,$header);
 223                         $ok = send_mail(\@head,$body);
 224
 225                         $sent_with_attach = 1;
 226                 }
 227         }
 228
 229     $reply = '' unless defined $reply;
 230     $reply = "Reply-to: $reply\n" if $reply;
 231
 232         if ($cc) {
 233                 push(@extra, "Cc: $cc");
 234         }
 235
 236         if ($bcc) {
 237                 push(@extra, "Bcc: $bcc");
 238         }
 239
 240         if ($utf8 && ! $opt->{mimetype}) {
 241                 push(@extra, 'MIME-Version: 1.0');
 242                 push(@extra, 'Content-Type: text/plain; charset=UTF-8');
 243                 push(@extra, 'Content-Transfer-Encoding: 8bit');
 244         }
 245
 246         $ok = send_mail($to, $subject, $body, $reply, 0, @extra)
 247                         unless $sent_with_attach;
 248
 249     if (!$ok) {
 250         logError("Unable to send mail using $Vend::Cfg->{SendMailProgram}\n" .
 251             "To '$to'\n" .
 252             "From '$from'\n" .
 253             "With extra headers '$extra'\n" .
 254             "With reply-to '$reply'\n" .
 255             "With subject '$subject'\n" .
 256             "And body:\n$body");
 257     }
 258
 259         return $opt->{hide} ? '' : $ok;
 260 }
 261 EOR
 262