lib/Vend/Email.pm

   1 # Vend::Email - Handle Interchange email functions
   2 #
   3 # $Id: Email.pm,v 1.11 2007-12-28 11:47:51 racke Exp $
   4 #
   5 # Copyright (C) 2007 Interchange Development Group
   6 #
   7 # This program was originally based on Vend 0.2 and 0.3
   8 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   9 #
  10 # This program is free software; you can redistribute it and/or modify
  11 # it under the terms of the GNU General Public License as published by
  12 # the Free Software Foundation; either version 2 of the License, or
  13 # (at your option) any later version.
  14 #
  15 # This program is distributed in the hope that it will be useful,
  16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 # GNU General Public License for more details.
  19 #
  20 # You should have received a copy of the GNU General Public
  21 # License along with this program; if not, write to the Free
  22 # Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  23 # MA  02111-1307  USA.
  24
  25 #
  26 # This module consists of the main e-mail sending function
  27 # (tag_mime_lite_email) and wrappers which preserve compatibility and
  28 # make traditional Interchange's mail functions use it, instead of
  29 # sending mail in the old way(s).
  30 #
  31 # Copies of some of the old functions are also included (and modified
  32 # to fit the picture), to be called when no useful wrapper code
  33 # can be made.
  34 #
  35 # TODO:
  36 # Header Word-encoding
  37 #
  38
  39 package Vend::Email;
  40
  41 my $Have_MIME_Lite;
  42
  43 BEGIN {
  44         eval {
  45                 require MIME::Lite;
  46                 $Have_MIME_Lite = 1;
  47         };
  48 }
  49
  50 use Mail::Address     qw//;
  51 use MIME::QuotedPrint qw//; # Used by default
  52 use MIME::Base64      qw//; # For user-specified encodings
  53
  54 use Vend::Util        qw/logError logDebug uneval/;
  55
  56 require Exporter;
  57 @ISA = qw(Exporter);
  58 @EXPORT = qw (
  59                 );
  60
  61 use strict;
  62 use warnings;
  63
  64 use vars qw/$VERSION/;
  65
  66 $VERSION = substr(q$Revision: 1.11 $, 10);
  67
  68
  69 ###########################################################################
  70 # Direct functions
  71 #
  72
  73 #
  74 # The main mail-sending function. You will mostly use it through
  75 # sub send_mail() and tag email, but you can also call it directly:
  76 #
  77 # tag_mime_lite_email({
  78 #   option-name => option-val, ...,
  79 #   hdr-name => hdr-val, ...,
  80 #
  81 #   data => $body, OR
  82 #   body => $body, OR
  83 # }, $body);
  84 #
  85 # Valid options are:
  86 #   interpolate, reparse, intercept, header_encoding, encoding, type
  87 #
  88 # Data (message body) can be specified as one of:
  89 #   $opt->{data} || $opt->{body} || $_[1] (arg 2)
  90 #
  91 sub tag_mime_lite_email {
  92         my ($optin, $body) = @_;
  93         my ($opt);
  94
  95         #::logDebug('mime_lite_email invoked, OPT=' .uneval($optin) . ' BODY=' . $body);
  96
  97         local $_;
  98
  99         #
 100         # See if we'll be sending this email, don't waste time if not.
 101         #
 102         my $using = $Vend::Cfg->{SendMailProgram};
 103         if ($using =~ /^none$/i ) {
 104                 ::logError('Unable to send email, config option SendMailProgram=none.');
 105                 return;
 106         }
 107         #
 108         # Copy option hash to avoid messing with caller's data
 109         #
 110
 111         %$opt = %$optin;
 112
 113         #
 114         # Quickly make sure that all options and header names satisfy basic rules.
 115         # (We need to do this in any case, so let's do it up-front). Also turn
 116         # them all to lowercase. (Mime-Lite does proper reformatting before sending).
 117         # And also weed out hash keys with empty values.
 118         #
 119         for my $key ( keys %$opt ) {
 120                 my $lckey = lc $key;
 121
 122                 # Remove empty options/headers and lowercase options/headers
 123                 # that should be preserved.
 124                 if (!defined $opt->{$key} or !length( $opt->{$key} )) {
 125                         delete $opt->{$key};
 126                         next;
 127                 } elsif ( $lckey eq $key ) {
 128                         next;
 129                 } else {
 130                         $opt->{$lckey} = $opt->{$key};
 131                         delete $opt->{$key};
 132                 }
 133         }
 134
 135         #
 136         # Deal with tag-specific options that are not to be understood as headers.
 137         # (Save them to variables and delete them from $opt so that after this
 138         # block, only headers are left in $opt).
 139         #
 140         # This also includes the extra_headers= option, which must process here
 141         # if we want to allow its values to influence the to/from/subject/reply-to
 142         # options. Normally this does not happen since those fields are specified
 143         # standalone as options to tag_mime_lite_email, but for compatibility
 144         # it is useful that those values can come from @extra_headers as well.
 145         # (Values from @extra_headers are included only if standalone options
 146         # are empty, otherwise a warning in error log is produced).
 147         #
 148
 149         my $intercept;
 150         my $hdr_encoding;
 151         my ($interpolate, $reparse, $hide);
 152         my ($data, $encoding, $type, $charset);
 153         my @extra_headers;
 154
 155         # Intercept
 156         if ( $_ = delete $opt->{intercept} ) {
 157                 $intercept = $_;
 158         }
 159
 160         # XXX Header word-encoding: currently inactive block.
 161         # All e-mail headers need to be Word-Encoded if they contain non-ASCII.
 162         # Field names themselves must not be encoded, they're always in English.
 163         # Header_encoding can be 1|y|none|q|b|a|s:
 164         # - '1' and 'y' are our special synonyms for 'q'.
 165         # - 'none' is our special value for no encoding
 166         # - the rest are actual supported values by MIME::EncWords.
 167         #if ( $_ = delete $opt->{'header_encoding'} ) {
 168         #       $hdr_encoding = $_;
 169         #}
 170         #if (! $hdr_encoding or $hdr_encoding =~ /1|y/i ) {
 171         #       $hdr_encoding = 'q';
 172         #}
 173         #$hdr_encoding eq 'none' and $hdr_encoding = '';
 174
 175         # Interpolate/reparse
 176         ($interpolate, $reparse, $hide) = (
 177                 delete $opt->{interpolate},
 178                 delete $opt->{reparse},
 179                 delete $opt->{hide},
 180         );
 181
 182         # Data (msg body), encoding and type
 183         ($data, $encoding, $type, $charset) = (
 184                 delete $opt->{data},
 185                 delete $opt->{encoding},
 186                 delete $opt->{type},
 187                 delete $opt->{charset},
 188         );
 189         $data     ||= $opt->{body} || $body;    delete $opt->{body};
 190         $encoding ||= 'quoted-printable';
 191         $type     ||= 'text/plain';
 192         $charset  ||= $::Variable->{MV_EMAIL_CHARSET} || $Global::Variable->{MV_EMAIL_CHARSET};
 193
 194         if ($charset) {
 195                 $type .= "; charset=$charset";
 196         }
 197
 198         !(ref $data or ref $encoding or ref $type) or do {
 199                 ::logError('Only scalar value accepted for options '.
 200                                 '"data" ("body"), "encoding" and "type".');
 201                 return;
 202         };
 203
 204         # Extra e-mail headers. Turn them into array first.
 205         if ( $_ = delete $opt->{extra_headers} ) {
 206                 if (! ref ) {
 207                         for (grep /\S/, split /[\r\n]+/, $_) {
 208                                 push @extra_headers, $_
 209                         }
 210                 } elsif ( ref eq 'ARRAY' ) {
 211                         @extra_headers = @$_
 212                 } else {
 213                         ::logError('Only a scalar or an array reference accepted as '.
 214                                 'extra_headers value.');
 215                         return;
 216                 }
 217         }
 218
 219         # Then perform general sanity checks.
 220         for ( my $i =0; $i < @extra_headers; $i++ ) {
 221                 $_ = $extra_headers[$i];
 222
 223                 # require header conformance with RFC 2822 section 2.2
 224                 unless ( /^([\x21-\x39\x3b-\x7e]+):[\x00-\x09\x0b\x0c\x0e-\x7f]+$/ ) {
 225                         ::logError("Invalid header given to tag_mime_lite_email: %s", $_);
 226                         return;
 227                 }
 228
 229                 # Allow the four specific headers to influence values which
 230                 # are usually passed as standalone options, outside of text headers.
 231                 if ( $1 =~ /^(to|from|subject|reply-to)$/i ) {
 232                         my $lchdr = lc $1; $lchdr =~ s/-/_/g;
 233
 234                         if (! $opt->{$lchdr} ) {
 235                                 $opt->{$lchdr} = $_;
 236                         } else {
 237                                 ::logError("Value for '$lchdr' already provided (= %s). " .
 238                                         'Ignoring new value %s.', $opt->{$lchdr}, $_);
 239                         }
 240                 }
 241         }
 242
 243         #
 244         # Let's see specified headers now, check them and/or associate defaults.
 245         # Headers can be specified as array (to.0=person1, to.1=person2), or
 246         # simply as to=person1. (Some can be multi-value, some can't. Sensible
 247         # check is performed.)
 248         #
 249
 250         # Convert scalars to array refs (to=person1 -> to.0=person1) where allowed.
 251         for my $key (keys %$opt ) {
 252
 253                 # For options or header names that can only be scalars, make
 254                 # sure they are scalars.
 255                 if ( $key =~ /^(subject|from)$/ ) {
 256                         ! ref $opt->{$key} or do {
 257                                 ::logError('Only scalar value accepted for option or '.
 258                                         'header name "%s"', $key);
 259                                 return;
 260                         };
 261                         next;
 262                 }
 263
 264                 # While for others that can be arrays, make sure they are
 265                 # arrays by converting them from scalars if needed.
 266                 if ( ! ref $opt->{$key} ) {
 267                         $opt->{$key} = [ $opt->{$key} ];
 268                 } elsif (ref $opt->{$key} ne 'ARRAY' ) {
 269                         ::logError('Only scalars or array refs supported as options ' .
 270                                 'to tag_mime_lite_email().');
 271                         return;
 272                 }
 273         }
 274
 275         #
 276         # Now check specific headers for specific values, and/or give defaults.
 277
 278         # TO
 279         if (!( $opt->{to} and @{ $opt->{to} } )) {
 280                 ::logError('mime_lite_email called without the required to= option.');
 281                 return;
 282         }
 283
 284         # FROM
 285         if (! $opt->{from} ) {
 286                 $opt->{from} =
 287                         $::Variable->{MV_MAILFROM}       ||
 288                         $Global::Variable->{MV_MAILFROM} ||
 289                         $Vend::Cfg->{MailOrderTo};
 290         }
 291         $opt->{from} or do {
 292                 ::logError('Cannot find value for From: header. Make sure ' .
 293                         'that MailOrderTo config directive or MV_MAILFROM variable ' .
 294                         'is specified.');
 295         };
 296
 297         # SUBJECT
 298         if (! $opt->{subject} ) {
 299                 $opt->{subject} = '<no subject>';
 300         }
 301
 302         # REPLY
 303         if (!( $opt->{reply_to} and @{ $opt->{reply_to} } )) {
 304                 $opt->{reply_to} = [$::Values->{email}];
 305
 306                 if (ref($opt->{reply})) {
 307                         $opt->{reply_to} = $opt->{reply};
 308                 } elsif ($opt->{reply}) {
 309                         $opt->{reply_to} = [$opt->{reply}];
 310                 }
 311         }
 312         delete $opt->{reply};
 313
 314         #
 315         # Now let's work on adjusting headers to adhere to e-mail standards.
 316         #
 317
 318         # Prevent header injections from spammers' hostile content
 319         for ( @{ $opt->{to} }, @{ $opt->{reply_to} },
 320                           $opt->{subject}, $opt->{from}           ) {
 321
 322                 # unfold valid RFC 2822 "2.2.3. Long Header Fields"
 323                 s/\r?\n([ \t]+)/$1/g;
 324                 # now remove any invalid extra lines left over
 325                 s/[\r\n](.*)//s and do {
 326                         ::logError("Header injection attempted in tag_mime_lite_email: %s", $1);
 327                         return;
 328                 };
 329         }
 330
 331         #
 332         # Support e-mail interception (re-writing to/cc/bcc to specified
 333         # address(es)).
 334         #
 335         $intercept ||= $::Variable->{MV_EMAIL_INTERCEPT} ||
 336                 $Global::Variable->{MV_EMAIL_INTERCEPT};
 337
 338         if ( $intercept && $Have_MIME_Lite) {
 339                 for my $field (qw/to cc bcc/) {
 340                         if ( $opt->{$field} ) {
 341                                 for $_ ( @{ $opt->{$field} } ) {
 342                                         ::logError('Intercepting outgoing email (%s: %s) ' .
 343                                                         'and instead sending to "%s"',
 344                                                         $field, $_, $intercept);
 345
 346                                         $opt->{$field} = $intercept;
 347                                         push @{ $opt->{"x-intercepted-$field"} }, $_;
 348                                 }
 349                         }
 350                 }
 351         }
 352
 353         #
 354         # Deal with attachments
 355         # (For the moment, only attach= option is supported, which should be
 356         # either a scalar (filename), or a hashref (data for one attachment),
 357         # or an arrayref (list of hashrefs - multiple attachments). Internally,
 358         # whatever you pass will be converted to a list of hashrefs.
 359         #
 360
 361         my $att = $opt->{attach};
 362         if ( $att ) {
 363
 364                 # Make sure $att is list of hashrefs
 365                 if(! ref($att) ) {
 366                         my $fn = $att;
 367                         $att = [ { path => $fn } ];
 368                 }
 369                 elsif( ref($att) eq 'HASH' ) {
 370                         $att = [ $att ];
 371                 }
 372
 373                 $att ||= [];
 374
 375                 my %encoding_types = (
 376                         'text/plain' => '8bit',
 377                         'text/html' => 'quoted-printable',
 378                         );
 379
 380                 # Now each hashref is suitable to be passed to $msg->attach(...).
 381                 for (my $i = 0; $i < @$att; $i++) {
 382                         my $ref = $$att[$i];
 383
 384                         if (! $ref ) {
 385                                 delete $$att[$i];
 386                                 next;
 387                         };
 388
 389                         unless ( $ref->{path} or $ref->{data} ) {
 390                                 ::logError('Attachment specified without path or data. Skipping.');
 391                                 delete $$att[$i];
 392                                 next;
 393                         };
 394
 395                         unless ($ref->{filename}) {
 396                                 my $fn = $ref->{path};
 397                                 $fn =~ s:.*[\\/]::;
 398                                 $ref->{filename} = $fn;
 399                         }
 400
 401                         $ref->{type} ||= 'AUTO';
 402                         $ref->{disposition} ||= 'attachment';
 403                         $ref->{encoding} ||= $encoding_types{$ref->{type}};
 404                 }
 405         }
 406
 407         unless ($Have_MIME_Lite) {
 408                 my ($to, $subject, $reply_to, @extra, $header);
 409
 410                 $to = delete $opt->{to};
 411                 $subject = delete $opt->{subject};
 412                 $reply_to = delete $opt->{reply_to};
 413
 414                 for (keys %$opt) {
 415                         $header = ucfirst($_);
 416
 417                         if (ref($opt->{$_}) eq 'ARRAY') {
 418                                 push(@extra, "$header: " . join(',', @{$opt->{$_}}));
 419                         } else {
 420                                 push(@extra, "$header: $opt->{$_}");
 421                         }
 422                 }
 423
 424                 return send_mail_legacy(join(',', @$to),
 425                                                                 $subject,
 426                                                                 $data,
 427                                                                 join(',', @$reply_to),
 428                                                                 0,
 429                                                                 @extra);
 430         }
 431
 432         #
 433         # Prepare for sending the message
 434         #
 435
 436         # Configure Net::SMTP sending if that is requested..
 437         if ( $using =~ /^Net::SMTP$/i ) {
 438                 # Unlike in previous implementations in IC, MV_SMTPHOST is not required.
 439                 # (Net::SMTP gets to figure out the host).
 440                 my $smtphost = $::Variable->{MV_SMTPHOST} ||
 441                         $Global::Variable->{MV_SMTPHOST};
 442
 443                 my $timeout = $::Variable->{MV_SMTP_TIMEOUT} ||
 444                         $Global::Variable->{MV_SMTP_TIMEOUT} || 60;
 445
 446                 MIME::Lite->send('smtp', $smtphost ?
 447                                 ($smtphost, $timeout) :
 448                                 ($timeout) );
 449
 450         } else { # (We know we're sending using sendmail now).
 451
 452                 # (-t was implicitly added for sendmail in all variants of this function
 453                 # in IC, so let's keep this behavior here too).
 454                 MIME::Lite->send('sendmail', $using . ' -t');
 455         }
 456
 457         #::logDebug('mime_lite_email will invoke MIME::Lite with ' .uneval($opt));
 458
 459         #
 460         # Create message just with body, and add headers later.
 461         my $msg = new MIME::Lite (
 462                 Data     => $data,
 463                 Encoding => $encoding,
 464                 Type     => $type,
 465           ) or do {
 466
 467                 ::logError("Can't create MIME::Lite mail ($!).");
 468                 return;
 469         };
 470
 471         #
 472         # Fill in @headers with [ hdr_name, value ], and append with
 473         # @extra_headers
 474         my @headers;
 475         while (my($hdr,$values) = each %$opt ) {
 476                 next if $hdr eq 'attach';
 477
 478                 if (! ref $values ) {
 479                         push @headers, [ $hdr, $values ];
 480
 481                 } elsif ( ref $values eq 'ARRAY' ) {
 482                         for my $value (@$values ) { push @headers, [ $hdr, $value ] }
 483
 484                 } else {
 485                         ::logError('Only scalars and array refs supported as header values.');
 486                         return;
 487                 }
 488         }
 489         push @headers, @extra_headers;
 490
 491         #
 492         # Add headers to $msg object
 493         for my $hdr (@headers) {
 494
 495                 # [0] is name, [1] is value.
 496                 $$hdr[0] =~ s/_/-/g;
 497
 498                 # Finally, header can go in.
 499                 $msg->add($$hdr[0], $$hdr[1]);
 500         }
 501
 502         #
 503         # Add attachments to $msg object
 504         for my $ref (@$att) {
 505                 $msg->attach(
 506                         Type => $ref->{type},
 507                         Path => $ref->{path},
 508                         Data => $ref->{data},
 509                         Filename => $ref->{filename},
 510                         Encoding => $ref->{encoding},
 511                         Disposition => $ref->{disposition},
 512                 );
 513         }
 514
 515         #
 516         # Finally, send the whole message.
 517         #
 518
 519         $msg->send;
 520
 521         1;
 522 }
 523
 524 ###########################################################################
 525 # Wrapper functions
 526 #
 527
 528 # When send_mail is used normally, we can replace it with the new
 529 # variant (tag_mime_lite_email). However, when headers are passed as
 530 # text mixed with body, we don't want to deal with it. We call the original
 531 # function to do the work, and issue a warning message to encourage
 532 # reimplementation on client side.
 533 #
 534 sub send_mail {
 535
 536         # See if this is the type of message we don't provide
 537         # any compatiblity for, and thus call the original implementation.
 538         if ( ref $_[0] or
 539                         looks_like_email_header (\$_[1]) or
 540                         looks_like_email_header (\$_[2]) ) {
 541
 542                 ::logError('Using legacy send_mail() because manually- or ' .
 543                         '"tag op=mime"-generated headers were detected within message body.');
 544
 545                 return send_mail_legacy( @_ );
 546         }
 547
 548         # Good, this is the type we *can* rework.
 549         my($to, $subject, $body, $reply) = @_;
 550
 551         tag_mime_lite_email({ to => $to, subject => $subject,
 552                         reply => $reply, extra_headers => $_[5] }, $body);
 553 }
 554
 555 ###########################################################################
 556 # Old functions, preserved more or less as-is. To be called when no
 557 # useful compatibility wrapper can be made.
 558 #
 559
 560 # Vend::Util::send_mail
 561 sub send_mail_legacy {
 562         my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;
 563
 564         if(ref $to) {
 565                 my $head = $to;
 566
 567                 for(my $i = $#$head; $i > 0; $i--) {
 568                         if($head->[$i] =~ /^\s/) {
 569                                 my $new = splice @$head, $i, 1;
 570                                 $head->[$i - 1] .= "\n$new";
 571                         }
 572                 }
 573
 574                 $body = $subject;
 575                 undef $subject;
 576                 for(@$head) {
 577                         s/\s+$//;
 578                         if (/^To:\s*(.+)/si) {
 579                                 $to = $1;
 580                         }
 581                         elsif (/^Reply-to:\s*(.+)/si) {
 582                                 $reply = $_;
 583                         }
 584                         elsif (/^subj(?:ect)?:\s*(.+)/si) {
 585                                 $subject = $1;
 586                         }
 587                         elsif($_) {
 588                                 push @extra_headers, $_;
 589                         }
 590                 }
 591         }
 592
 593         # If configured, intercept all outgoing email and re-route
 594         if (
 595                 my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
 596                                 || $Global::Variable->{MV_EMAIL_INTERCEPT}
 597         ) {
 598                 my @info_headers;
 599                 $to = "To: $to";
 600                 for ($to, @extra_headers) {
 601                         next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;
 602                         ::logError(
 603                                 "Intercepting outgoing email (%s: %s) and instead sending to '%s'",
 604                                 $header, $value, $intercept
 605                         );
 606                         $_ = "$header: $intercept";
 607                         push @info_headers, "X-Intercepted-$header: $value";
 608                 }
 609                 $to =~ s/^To: //;
 610                 push @extra_headers, @info_headers;
 611         }
 612
 613         my($ok);
 614 #::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");
 615
 616         unless (defined $use_mime) {
 617                 $use_mime = $::Instance->{MIME} || 0;
 618         }
 619
 620         if(!defined $reply) {
 621                 $reply = $::Values->{mv_email}
 622                                 ?  "Reply-To: $::Values->{mv_email}\n"
 623                                 : '';
 624         }
 625         elsif ($reply) {
 626                 $reply = "Reply-To: $reply\n"
 627                         unless $reply =~ /^reply-to:/i;
 628                 $reply =~ s/\s+$/\n/;
 629         }
 630
 631         $ok = 0;
 632         my $none;
 633         my $using = $Vend::Cfg->{SendMailProgram};
 634
 635         if($using =~ /^(none|Net::SMTP)$/i) {
 636                 $none = 1;
 637                 $ok = 1;
 638         }
 639
 640         SEND: {
 641 #::logDebug("testing sendmail send none=$none");
 642                 last SEND if $none;
 643 #::logDebug("in Sendmail send $using");
 644                 open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
 645                 my $mime = '';
 646                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
 647                 print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"
 648                         or last SEND;
 649                 for(@extra_headers) {
 650                         s/\s*$/\n/;
 651                         print MVMAIL $_
 652                                 or last SEND;
 653                 }
 654                 $mime =~ s/\s*$/\n/;
 655                 print MVMAIL $mime
 656                         or last SEND;
 657                 print MVMAIL $body
 658                                 or last SEND;
 659                 print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'
 660                         if $use_mime;
 661                 print MVMAIL "\r\n\cZ" if $Global::Windows;
 662                 close MVMAIL or last SEND;
 663                 $ok = ($? == 0);
 664         }
 665
 666         SMTP: {
 667                 my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};
 668                 my $helo =  $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};
 669                 last SMTP unless $none and $mhost;
 670                 eval {
 671                         require Net::SMTP;
 672                 };
 673                 last SMTP if $@;
 674                 $ok = 0;
 675                 $using = "Net::SMTP (mail server $mhost)";
 676 #::logDebug("using $using");
 677                 undef $none;
 678
 679                 my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo);
 680 #::logDebug("smtp object $smtp");
 681
 682                 my $from = $::Variable->{MV_MAILFROM}
 683                                 || $Global::Variable->{MV_MAILFROM}
 684                                 || $Vend::Cfg->{MailOrderTo};
 685
 686                 for(@extra_headers) {
 687                         s/\s*$/\n/;
 688                         next unless /^From:\s*(\S.+)$/mi;
 689                         $from = $1;
 690                 }
 691                 push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);
 692                 push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);
 693
 694                 my $mime = '';
 695                 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;
 696                 $smtp->mail($from)
 697                         or last SMTP;
 698 #::logDebug("smtp accepted from=$from");
 699
 700                 my @to;
 701                 my @addr = split /\s*,\s*/, $to;
 702                 for (@addr) {
 703                         if(/\s/) {
 704                                 ## Uh-oh. Try to handle
 705                                 if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {
 706                                         push @to, $1
 707                                 }
 708                                 else {
 709                                         ::logError("Net::SMTP sender skipping unparsable address %s", $_);
 710                                 }
 711                         }
 712                         else {
 713                                 push @to, $_;
 714                         }
 715                 }
 716
 717                 @addr = $smtp->recipient(@to, { SkipBad => 1 });
 718                 if(scalar(@addr) != scalar(@to)) {
 719                         ::logError(
 720                                 "Net::SMTP not able to send to all addresses of %s",
 721                                 join(", ", @to),
 722                         );
 723                 }
 724
 725 #::logDebug("smtp accepted to=" . join(",", @addr));
 726
 727                 $smtp->data();
 728
 729                 push @extra_headers, $reply if $reply;
 730                 for ("To: $to", "Subject: $subject", @extra_headers) {
 731                         next unless $_;
 732                         s/\s*$/\n/;
 733 #::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });
 734                         $smtp->datasend($_)
 735                                 or last SMTP;
 736                 }
 737
 738                 if($use_mime) {
 739                         $mime =~ s/\s*$/\n/;
 740                         $smtp->datasend($mime)
 741                                 or last SMTP;
 742                 }
 743                 $smtp->datasend("\n");
 744                 $smtp->datasend($body)
 745                         or last SMTP;
 746                 $smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')
 747                         if $use_mime;
 748                 $smtp->dataend()
 749                         or last SMTP;
 750                 $ok = $smtp->quit();
 751         }
 752
 753         if ($none or !$ok) {
 754                 ::logError("NONE eq $none, OK eq $ok\n");
 755                 ::logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",
 756                                 $using,
 757                                 $to,
 758                                 $subject,
 759                                 $reply,
 760                                 $body,
 761                 );
 762         }
 763
 764         $ok;
 765 }
 766
 767 # Vend::Interpolate::tag_mail
 768 # This function does not need a wrapper like send_mail() above because
 769 # it calls send_mail() in the end anyway, and no real sending work is done here.
 770 sub tag_mail {
 771     my($to, $opt, $body) = @_;
 772     my($ok);
 773
 774         my @todo = (
 775                                         qw/
 776                                                 From
 777                                                 To
 778                                                 Subject
 779                                                 Reply-To
 780                                                 Errors-To
 781                                         /
 782         );
 783
 784         my $abort;
 785         my $check;
 786
 787         my $setsub = sub {
 788                 my $k = shift;
 789                 return if ! defined $CGI::values{"mv_email_$k"};
 790                 $abort = 1 if ! $::Scratch->{mv_email_enable};
 791                 $check = 1 if $::Scratch->{mv_email_enable};
 792                 return $CGI::values{"mv_email_$k"};
 793         };
 794
 795         my @headers; # Will contain to/subject/reply_to
 796         my @extra_headers; # Will contain from/errors_to + eventual manual headers..
 797         my %found;   # Hash in form of ( header_name => header_val )
 798
 799         unless($opt->{raw}) {
 800                 for my $header (@todo) {
 801                         ::logError("invalid email header: %s", $header)
 802                                 if $header =~ /[^-\w]/;
 803                         my $key = lc $header;
 804                         $key =~ tr/-/_/;
 805                         my $val = $opt->{$key} || $setsub->($key);
 806
 807                         # Redundant: done in tag_mime_lite_email()
 808                         #if($key eq 'subject' and ! length($val) ) {
 809                         #       $val = errmsg('<no subject>');
 810                         #}
 811
 812                         next unless length $val;
 813
 814                         $val =~ s/^\s+//;
 815                         $val =~ s/\s+$//;
 816                         $val =~ s/[\r\n]+\s*(\S)/\n\t$1/g;
 817
 818                         $found{$key} = $val;
 819
 820                         push @extra_headers, "$header: $val" if
 821                                 $header =~ /^(from|errors_to)$/;
 822                 }
 823                 unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) {
 824                         return
 825                                 error_opt($opt, "Refuse to send email message with no recipient.");
 826                 }
 827                 elsif (! $found{to}) {
 828                         $::Scratch->{mv_email_enable} =~ s/\s+/ /g;
 829                         $found{to} = $::Scratch->{mv_email_enable};
 830
 831                         push @headers, "To: $::Scratch->{mv_email_enable}";
 832                 }
 833         }
 834
 835         if($opt->{extra}) {
 836                 $opt->{extra} =~ s/^\s+//mg;
 837                 $opt->{extra} =~ s/\s+$//mg;
 838                 push @extra_headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra};
 839         }
 840
 841         $body ||= $setsub->('body');
 842         unless($body) {
 843                 return error_opt($opt, "Refuse to send email message with no body.");
 844         }
 845
 846         $body = format_auto_transmission($body) if ref $body;
 847
 848         return error_opt("mv_email_enable not set, required.") if $abort;
 849         if($check and $found{to} ne $::Scratch->{mv_email_enable}) {
 850                 return error_opt(
 851                                 "mv_email_enable to address (%s) doesn't match enable (%s)",
 852                                 $found{to},
 853                                 $::Scratch->{mv_email_enable},
 854                         );
 855         }
 856
 857     SEND: {
 858                 # This will use tag_mime_lite_email, unless $body contains headers.
 859                 $ok = send_mail_legacy(
 860                         $found{to}, $found{subject}, $body, $found{reply_to},
 861                         0, @extra_headers );
 862                 }
 863
 864     if (!$ok) {
 865                 close MVMAIL;
 866                 $body = substr($body, 0, 2000) if length($body) > 2000;
 867         return error_opt(
 868                                         "Unable to send mail using %s\n%s",
 869                                         $Vend::Cfg->{SendMailProgram},
 870                                         join("\n", @headers, @extra_headers, '', $body),
 871                                 );
 872         }
 873
 874         delete $::Scratch->{mv_email_enable} if $check;
 875         return if $opt->{hide};
 876         return join("\n", @headers, @extra_headers, '', $body) if $opt->{show};
 877         return ($opt->{success} || $ok);
 878 }
 879
 880 # code/UserTag/email.tag
 881 sub tag_email {
 882         my ($to, $subject, $reply, $from, $extra, $opt, $body) = @_;
 883         my $ok = 0;
 884         my @extra;
 885         my $att;
 886
 887         use vars qw/ $Tag /;
 888
 889         ATTACH: {
 890                 #::logDebug("Checking for attachment");
 891                 last ATTACH unless $opt->{attach} || $opt->{html};
 892
 893                 unless ($Have_MIME_Lite) {
 894                         ::logError("email tag: attachment without MIME::Lite installed.");
 895                         last ATTACH;
 896                 }
 897
 898                 if($opt->{html}) {
 899                         $opt->{mimetype} ||= 'multipart/alternative';
 900                 }
 901                 else {
 902                         $opt->{mimetype} ||= 'multipart/mixed';
 903                 }
 904
 905                 my $vtype = ref($opt->{attach});
 906
 907                 if ($vtype) {
 908                         if ($vtype eq 'HASH') {
 909                                 $att = [ $opt->{attach} ];
 910                         }
 911                         elsif ($vtype eq 'ARRAY') {
 912                                 $att = $opt->{attach};
 913                         }
 914                 }
 915                 else {
 916                         if ($opt->{attach}) {
 917                                 $att = [ { path => $opt->{attach} } ];
 918                         }
 919                 }
 920
 921                 $att ||= [];
 922
 923                 if($opt->{html}) {
 924                         unshift @$att, {
 925                                 type => 'text/html',
 926                                 data => $opt->{html},
 927                                 disposition => 'inline',
 928                         };
 929                 }
 930         }
 931
 932         $ok = tag_mime_lite_email({
 933                 to => $to,
 934                 from => $from || '',
 935                 subject => $subject || '',
 936                 cc => $opt->{cc} || '',
 937                 reply => $reply || '',
 938                 type => $opt->{body_mime} || 'text/plain',
 939                 charset => $opt->{charset},
 940                 extra_headers => \@extra || [],
 941                 encoding => $opt->{body_encoding} || '8bit',
 942                 attach => $att || ''
 943         }, $body);
 944
 945         if (!$ok) {
 946                 ::logError("Unable to send mail using tag_mime_lite_email\n" .
 947                                 "To '$to'\n" .
 948                                 "From '$from'\n" .
 949                                 "With extra headers '$extra'\n" .
 950                                 "With reply-to '$reply'\n" .
 951                                 "With subject '$subject'\n" .
 952                                 "And body:\n$body");
 953         }
 954
 955         return $opt->{hide} ? '' : $ok;
 956 }
 957
 958
 959 ###########################################################################
 960 # Helper functions
 961
 962 # Vend::Util::send_mail function used to sometimes receive body
 963 # which contains headers as well (usually coming as a result of
 964 # Vend::Interpolate::mime() processing). Figure out if this is the
 965 # case.
 966
 967 sub looks_like_email_header {
 968         if ( ${$_[0]} =~ /^\n*--[\w-]+?:=\d+\nContent-/s ) { return 1 }
 969         0;
 970 }
 971
 972 sub format_auto_transmission {
 973         my $ref = shift;
 974
 975 ## Auto-transmission from Vend::Data::update_data
 976 ## Looking for structure like:
 977 ##
 978 ##      [ '### BEGIN submission from', 'ckirk' ],
 979 ##      [ 'username', 'ckirk' ],
 980 ##      [ 'field2', 'value2' ],
 981 ##      [ 'field1', 'value1' ],
 982 ##      [ '### END submission from', 'ckirk' ],
 983 ##      [ 'mv_data_fields', [ username, field1, field2 ]],
 984 ##
 985
 986         return $ref unless ref($ref);
 987
 988         my $body = '';
 989         my %message;
 990         my $header  = shift @$ref;
 991         my $fields  = pop   @$ref;
 992         my $trailer = pop   @$ref;
 993
 994         $body .= "$header->[0]: $header->[1]\n";
 995
 996         for my $line (@$ref) {
 997                 $message{$line->[0]} = $line->[1];
 998         }
 999
1000         my @order;
1001         if(ref $fields->[1]) {
1002                 @order = @{$fields->[1]};
1003         }
1004         else {
1005                 @order = sort keys %message;
1006         }
1007
1008         for (@order) {
1009                 $body .= "$_: ";
1010                 if($message{$_} =~ s/\r?\n/\n/g) {
1011                         $body .= "\n$message{$_}\n";
1012                 }
1013                 else {
1014                         $body .= $message{$_};
1015                 }
1016                 $body .= "\n";
1017         }
1018
1019         $body .= "$trailer->[0]: $trailer->[1]\n";
1020         return $body;
1021 }
1022
1023 1;
1024