code/UserTag/email.tag

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