# Vend::Email - Handle Interchange email functions

#

# Copyright (C) 2007 Interchange Development Group

#

# This program was originally based on Vend 0.2 and 0.3

# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>

#

# This program is free software; you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# the Free Software Foundation; either version 2 of the License, or

# (at your option) any later version.

#

# This program is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

# GNU General Public License for more details.

#

# You should have received a copy of the GNU General Public

# License along with this program; if not, write to the Free

# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,

# MA 02111-1307 USA.

#

# This module consists of the main e-mail sending function

# (tag_mime_lite_email) and wrappers which preserve compatibility and

# make traditional Interchange's mail functions use it, instead of

# sending mail in the old way(s).

#

# Copies of some of the old functions are also included (and modified

# to fit the picture), to be called when no useful wrapper code

# can be made.

#

# TODO:

# Header Word-encoding

#

package Vend::Email;

my $Have_MIME_Lite;

BEGIN {

eval {

require MIME::Lite;

$Have_MIME_Lite = 1;

};

}

use Mail::Address qw//;

use MIME::QuotedPrint qw//; # Used by default

use MIME::Base64 qw//; # For user-specified encodings

use Vend::Util qw/logError logDebug uneval/;

require Exporter;

@ISA = qw(Exporter);

@EXPORT = qw (

);

use strict;

use warnings;

use vars qw/$VERSION/;

$VERSION = '1.11';

###########################################################################

# Direct functions

#

#

# The main mail-sending function. You will mostly use it through

# sub send_mail() and tag email, but you can also call it directly:

#

# tag_mime_lite_email({

# option-name => option-val, ...,

# hdr-name => hdr-val, ...,

#

# data => $body, OR

# body => $body, OR

# }, $body);

#

# Valid options are:

# interpolate, reparse, intercept, header_encoding, encoding, type

#

# Data (message body) can be specified as one of:

# $opt->{data} || $opt->{body} || $_[1] (arg 2)

#

sub tag_mime_lite_email {

my ($optin, $body) = @_;

my ($opt);

#::logDebug('mime_lite_email invoked, OPT=' .uneval($optin) . ' BODY=' . $body);

local $_;

#

# See if we'll be sending this email, don't waste time if not.

#

my $using = $Vend::Cfg->{SendMailProgram};

if ($using =~ /^none$/i ) {

::logError('Unable to send email, config option SendMailProgram=none.');

return;

}

#

# Copy option hash to avoid messing with caller's data

#

%$opt = %$optin;

#

# Quickly make sure that all options and header names satisfy basic rules.

# (We need to do this in any case, so let's do it up-front). Also turn

# them all to lowercase. (Mime-Lite does proper reformatting before sending).

# And also weed out hash keys with empty values.

#

for my $key ( keys %$opt ) {

my $lckey = lc $key;

# Remove empty options/headers and lowercase options/headers

# that should be preserved.

if (!defined $opt->{$key} or !length( $opt->{$key} )) {

delete $opt->{$key};

next;

} elsif ( $lckey eq $key ) {

next;

} else {

$opt->{$lckey} = $opt->{$key};

delete $opt->{$key};

}

}

#

# Deal with tag-specific options that are not to be understood as headers.

# (Save them to variables and delete them from $opt so that after this

# block, only headers are left in $opt).

#

# This also includes the extra_headers= option, which must process here

# if we want to allow its values to influence the to/from/subject/reply-to

# options. Normally this does not happen since those fields are specified

# standalone as options to tag_mime_lite_email, but for compatibility

# it is useful that those values can come from @extra_headers as well.

# (Values from @extra_headers are included only if standalone options

# are empty, otherwise a warning in error log is produced).

#

my $intercept;

my $hdr_encoding;

my ($interpolate, $reparse, $hide);

my ($data, $encoding, $type, $charset);

my @extra_headers;

# Intercept

if ( $_ = delete $opt->{intercept} ) {

$intercept = $_;

}

# XXX Header word-encoding: currently inactive block.

# All e-mail headers need to be Word-Encoded if they contain non-ASCII.

# Field names themselves must not be encoded, they're always in English.

# Header_encoding can be 1|y|none|q|b|a|s:

# - '1' and 'y' are our special synonyms for 'q'.

# - 'none' is our special value for no encoding

# - the rest are actual supported values by MIME::EncWords.

#if ( $_ = delete $opt->{'header_encoding'} ) {

# $hdr_encoding = $_;

#}

#if (! $hdr_encoding or $hdr_encoding =~ /1|y/i ) {

# $hdr_encoding = 'q';

#}

#$hdr_encoding eq 'none' and $hdr_encoding = '';

# Interpolate/reparse

($interpolate, $reparse, $hide) = (

delete $opt->{interpolate},

delete $opt->{reparse},

delete $opt->{hide},

);

# Data (msg body), encoding and type

($data, $encoding, $type, $charset) = (

delete $opt->{data},

delete $opt->{encoding},

delete $opt->{type},

delete $opt->{charset},

);

$data ||= $opt->{body} || $body; delete $opt->{body};

$encoding ||= 'quoted-printable';

$type ||= 'text/plain';

$charset ||= $::Variable->{MV_EMAIL_CHARSET} || $Global::Variable->{MV_EMAIL_CHARSET};

if ($charset) {

$type .= "; charset=$charset";

}

!(ref $data or ref $encoding or ref $type) or do {

::logError('Only scalar value accepted for options '.

'"data" ("body"), "encoding" and "type".');

return;

};

# Extra e-mail headers. Turn them into array first.

if ( $_ = delete $opt->{extra_headers} ) {

if (! ref ) {

for (grep /\S/, split /[\r\n]+/, $_) {

push @extra_headers, $_

}

} elsif ( ref eq 'ARRAY' ) {

@extra_headers = @$_

} else {

::logError('Only a scalar or an array reference accepted as '.

'extra_headers value.');

return;

}

}

# Then perform general sanity checks.

for ( my $i =0; $i < @extra_headers; $i++ ) {

$_ = $extra_headers[$i];

# require header conformance with RFC 2822 section 2.2

unless ( /^([\x21-\x39\x3b-\x7e]+):[\x00-\x09\x0b\x0c\x0e-\x7f]+$/ ) {

::logError("Invalid header given to tag_mime_lite_email: %s", $_);

return;

}

# Allow the four specific headers to influence values which

# are usually passed as standalone options, outside of text headers.

if ( $1 =~ /^(to|from|subject|reply-to)$/i ) {

my $lchdr = lc $1; $lchdr =~ s/-/_/g;

if (! $opt->{$lchdr} ) {

$opt->{$lchdr} = $_;

} else {

::logError("Value for '$lchdr' already provided (= %s). " .

'Ignoring new value %s.', $opt->{$lchdr}, $_);

}

}

}

#

# Let's see specified headers now, check them and/or associate defaults.

# Headers can be specified as array (to.0=person1, to.1=person2), or

# simply as to=person1. (Some can be multi-value, some can't. Sensible

# check is performed.)

#

# Convert scalars to array refs (to=person1 -> to.0=person1) where allowed.

for my $key (keys %$opt ) {

# For options or header names that can only be scalars, make

# sure they are scalars.

if ( $key =~ /^(subject|from)$/ ) {

! ref $opt->{$key} or do {

::logError('Only scalar value accepted for option or '.

'header name "%s"', $key);

return;

};

next;

}

# While for others that can be arrays, make sure they are

# arrays by converting them from scalars if needed.

if ( ! ref $opt->{$key} ) {

$opt->{$key} = [ $opt->{$key} ];

} elsif (ref $opt->{$key} ne 'ARRAY' ) {

::logError('Only scalars or array refs supported as options ' .

'to tag_mime_lite_email().');

return;

}

}

#

# Now check specific headers for specific values, and/or give defaults.

# TO

if (!( $opt->{to} and @{ $opt->{to} } )) {

::logError('mime_lite_email called without the required to= option.');

return;

}

# FROM

if (! $opt->{from} ) {

$opt->{from} =

$::Variable->{MV_MAILFROM} ||

$Global::Variable->{MV_MAILFROM} ||

$Vend::Cfg->{MailOrderTo};

}

$opt->{from} or do {

::logError('Cannot find value for From: header. Make sure ' .

'that MailOrderTo config directive or MV_MAILFROM variable ' .

'is specified.');

};

# SUBJECT

if (! $opt->{subject} ) {

$opt->{subject} = '<no subject>';

}

# REPLY

if (!( $opt->{reply_to} and @{ $opt->{reply_to} } )) {

$opt->{reply_to} = [$::Values->{email}];

if (ref($opt->{reply})) {

$opt->{reply_to} = $opt->{reply};

} elsif ($opt->{reply}) {

$opt->{reply_to} = [$opt->{reply}];

}

}

delete $opt->{reply};

#

# Now let's work on adjusting headers to adhere to e-mail standards.

#

# Prevent header injections from spammers' hostile content

for ( @{ $opt->{to} }, @{ $opt->{reply_to} },

$opt->{subject}, $opt->{from} ) {

# unfold valid RFC 2822 "2.2.3. Long Header Fields"

s/\r?\n([ \t]+)/$1/g;

# now remove any invalid extra lines left over

s/[\r\n](.*)//s and do {

::logError("Header injection attempted in tag_mime_lite_email: %s", $1);

return;

};

}

#

# Support e-mail interception (re-writing to/cc/bcc to specified

# address(es)).

#

$intercept ||= $::Variable->{MV_EMAIL_INTERCEPT} ||

$Global::Variable->{MV_EMAIL_INTERCEPT};

if ( $intercept && $Have_MIME_Lite) {

for my $field (qw/to cc bcc/) {

if ( $opt->{$field} ) {

for $_ ( @{ $opt->{$field} } ) {

::logError('Intercepting outgoing email (%s: %s) ' .

'and instead sending to "%s"',

$field, $_, $intercept);

$opt->{$field} = $intercept;

push @{ $opt->{"x-intercepted-$field"} }, $_;

}

}

}

}

#

# Deal with attachments

# (For the moment, only attach= option is supported, which should be

# either a scalar (filename), or a hashref (data for one attachment),

# or an arrayref (list of hashrefs - multiple attachments). Internally,

# whatever you pass will be converted to a list of hashrefs.

#

my $att = $opt->{attach};

if ( $att ) {

# Make sure $att is list of hashrefs

if(! ref($att) ) {

my $fn = $att;

$att = [ { path => $fn } ];

}

elsif( ref($att) eq 'HASH' ) {

$att = [ $att ];

}

$att ||= [];

my %encoding_types = (

'text/plain' => '8bit',

'text/html' => 'quoted-printable',

);

# Now each hashref is suitable to be passed to $msg->attach(...).

for (my $i = 0; $i < @$att; $i++) {

my $ref = $$att[$i];

if (! $ref ) {

delete $$att[$i];

next;

};

unless ( $ref->{path} or $ref->{data} ) {

::logError('Attachment specified without path or data. Skipping.');

delete $$att[$i];

next;

};

unless ($ref->{filename}) {

my $fn = $ref->{path};

$fn =~ s:.*[\\/]::;

$ref->{filename} = $fn;

}

$ref->{type} ||= 'AUTO';

$ref->{disposition} ||= 'attachment';

$ref->{encoding} ||= $encoding_types{$ref->{type}};

}

}

unless ($Have_MIME_Lite) {

my ($to, $subject, $reply_to, @extra, $header);

$to = delete $opt->{to};

$subject = delete $opt->{subject};

$reply_to = delete $opt->{reply_to};

for (keys %$opt) {

$header = ucfirst($_);

if (ref($opt->{$_}) eq 'ARRAY') {

push(@extra, "$header: " . join(',', @{$opt->{$_}}));

} else {

push(@extra, "$header: $opt->{$_}");

}

}

return send_mail_legacy(join(',', @$to),

$subject,

$data,

join(',', @$reply_to),

0,

@extra);

}

#

# Prepare for sending the message

#

# Configure Net::SMTP sending if that is requested..

if ( $using =~ /^Net::SMTP$/i ) {

# Unlike in previous implementations in IC, MV_SMTPHOST is not required.

# (Net::SMTP gets to figure out the host).

my $smtphost = $::Variable->{MV_SMTPHOST} ||

$Global::Variable->{MV_SMTPHOST};

my $timeout = $::Variable->{MV_SMTP_TIMEOUT} ||

$Global::Variable->{MV_SMTP_TIMEOUT} || 60;

MIME::Lite->send('smtp', $smtphost ?

($smtphost, $timeout) :

($timeout) );

} else { # (We know we're sending using sendmail now).

# (-t was implicitly added for sendmail in all variants of this function

# in IC, so let's keep this behavior here too).

MIME::Lite->send('sendmail', $using . ' -t');

}

#::logDebug('mime_lite_email will invoke MIME::Lite with ' .uneval($opt));

#

# Create message just with body, and add headers later.

my $msg = new MIME::Lite (

Data => $data,

Encoding => $encoding,

Type => $type,

) or do {

::logError("Can't create MIME::Lite mail ($!).");

return;

};

#

# Fill in @headers with [ hdr_name, value ], and append with

# @extra_headers

my @headers;

while (my($hdr,$values) = each %$opt ) {

next if $hdr eq 'attach';

if (! ref $values ) {

push @headers, [ $hdr, $values ];

} elsif ( ref $values eq 'ARRAY' ) {

for my $value (@$values ) { push @headers, [ $hdr, $value ] }

} else {

::logError('Only scalars and array refs supported as header values.');

return;

}

}

push @headers, @extra_headers;

#

# Add headers to $msg object

for my $hdr (@headers) {

# [0] is name, [1] is value.

$$hdr[0] =~ s/_/-/g;

# Finally, header can go in.

$msg->add($$hdr[0], $$hdr[1]);

}

#

# Add attachments to $msg object

for my $ref (@$att) {

$msg->attach(

Type => $ref->{type},

Path => $ref->{path},

Data => $ref->{data},

Filename => $ref->{filename},

Encoding => $ref->{encoding},

Disposition => $ref->{disposition},

);

}

#

# Finally, send the whole message.

#

$msg->send;

1;

}

###########################################################################

# Wrapper functions

#

# When send_mail is used normally, we can replace it with the new

# variant (tag_mime_lite_email). However, when headers are passed as

# text mixed with body, we don't want to deal with it. We call the original

# function to do the work, and issue a warning message to encourage

# reimplementation on client side.

#

sub send_mail {

# See if this is the type of message we don't provide

# any compatiblity for, and thus call the original implementation.

if ( ref $_[0] or

looks_like_email_header (\$_[1]) or

looks_like_email_header (\$_[2]) ) {

::logError('Using legacy send_mail() because manually- or ' .

'"tag op=mime"-generated headers were detected within message body.');

return send_mail_legacy( @_ );

}

# Good, this is the type we *can* rework.

my($to, $subject, $body, $reply) = @_;

tag_mime_lite_email({ to => $to, subject => $subject,

reply => $reply, extra_headers => $_[5] }, $body);

}

###########################################################################

# Old functions, preserved more or less as-is. To be called when no

# useful compatibility wrapper can be made.

#

# Vend::Util::send_mail

sub send_mail_legacy {

my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_;

if(ref $to) {

my $head = $to;

for(my $i = $#$head; $i > 0; $i--) {

if($head->[$i] =~ /^\s/) {

my $new = splice @$head, $i, 1;

$head->[$i - 1] .= "\n$new";

}

}

$body = $subject;

undef $subject;

for(@$head) {

s/\s+$//;

if (/^To:\s*(.+)/si) {

$to = $1;

}

elsif (/^Reply-to:\s*(.+)/si) {

$reply = $_;

}

elsif (/^subj(?:ect)?:\s*(.+)/si) {

$subject = $1;

}

elsif($_) {

push @extra_headers, $_;

}

}

}

# If configured, intercept all outgoing email and re-route

if (

my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}

|| $Global::Variable->{MV_EMAIL_INTERCEPT}

) {

my @info_headers;

$to = "To: $to";

for ($to, @extra_headers) {

next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si;

::logError(

"Intercepting outgoing email (%s: %s) and instead sending to '%s'",

$header, $value, $intercept

);

$_ = "$header: $intercept";

push @info_headers, "X-Intercepted-$header: $value";

}

$to =~ s/^To: //;

push @extra_headers, @info_headers;

}

my($ok);

#::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n");

unless (defined $use_mime) {

$use_mime = $::Instance->{MIME} || 0;

}

if(!defined $reply) {

$reply = $::Values->{mv_email}

? "Reply-To: $::Values->{mv_email}\n"

: '';

}

elsif ($reply) {

$reply = "Reply-To: $reply\n"

unless $reply =~ /^reply-to:/i;

$reply =~ s/\s+$/\n/;

}

$ok = 0;

my $none;

my $using = $Vend::Cfg->{SendMailProgram};

if($using =~ /^(none|Net::SMTP)$/i) {

$none = 1;

$ok = 1;

}

SEND: {

#::logDebug("testing sendmail send none=$none");

last SEND if $none;

#::logDebug("in Sendmail send $using");

open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;

my $mime = '';

$mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;

print MVMAIL "To: $to\n", $reply, "Subject: $subject\n"

or last SEND;

for(@extra_headers) {

s/\s*$/\n/;

print MVMAIL $_

or last SEND;

}

$mime =~ s/\s*$/\n/;

print MVMAIL $mime

or last SEND;

print MVMAIL $body

or last SEND;

print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--'

if $use_mime;

print MVMAIL "\r\n\cZ" if $Global::Windows;

close MVMAIL or last SEND;

$ok = ($? == 0);

}

SMTP: {

my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST};

my $helo = $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME};

last SMTP unless $none and $mhost;

eval {

require Net::SMTP;

};

last SMTP if $@;

$ok = 0;

$using = "Net::SMTP (mail server $mhost)";

#::logDebug("using $using");

undef $none;

my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo);

#::logDebug("smtp object $smtp");

my $from = $::Variable->{MV_MAILFROM}

|| $Global::Variable->{MV_MAILFROM}

|| $Vend::Cfg->{MailOrderTo};

for(@extra_headers) {

s/\s*$/\n/;

next unless /^From:\s*(\S.+)$/mi;

$from = $1;

}

push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers);

push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers);

my $mime = '';

$mime = Vend::Interpolate::mime('header', {}, '') if $use_mime;

$smtp->mail($from)

or last SMTP;

#::logDebug("smtp accepted from=$from");

my @to;

my @addr = split /\s*,\s*/, $to;

for (@addr) {

if(/\s/) {

## Uh-oh. Try to handle

if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) {

push @to, $1

}

else {

::logError("Net::SMTP sender skipping unparsable address %s", $_);

}

}

else {

push @to, $_;

}

}

@addr = $smtp->recipient(@to, { SkipBad => 1 });

if(scalar(@addr) != scalar(@to)) {

::logError(

"Net::SMTP not able to send to all addresses of %s",

join(", ", @to),

);

}

#::logDebug("smtp accepted to=" . join(",", @addr));

$smtp->data();

push @extra_headers, $reply if $reply;

for ("To: $to", "Subject: $subject", @extra_headers) {

next unless $_;

s/\s*$/\n/;

#::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" });

$smtp->datasend($_)

or last SMTP;

}

if($use_mime) {

$mime =~ s/\s*$/\n/;

$smtp->datasend($mime)

or last SMTP;

}

$smtp->datasend("\n");

$smtp->datasend($body)

or last SMTP;

$smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--')

if $use_mime;

$smtp->dataend()

or last SMTP;

$ok = $smtp->quit();

}

if ($none or !$ok) {

::logError("NONE eq $none, OK eq $ok\n");

::logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s",

$using,

$to,

$subject,

$reply,

$body,

);

}

$ok;

}

# Vend::Interpolate::tag_mail

# This function does not need a wrapper like send_mail() above because

# it calls send_mail() in the end anyway, and no real sending work is done here.

sub tag_mail {

my($to, $opt, $body) = @_;

my($ok);

my @todo = (

qw/

From

To

Subject

Reply-To

Errors-To

/

);

my $abort;

my $check;

my $setsub = sub {

my $k = shift;

return if ! defined $CGI::values{"mv_email_$k"};

$abort = 1 if ! $::Scratch->{mv_email_enable};

$check = 1 if $::Scratch->{mv_email_enable};

return $CGI::values{"mv_email_$k"};

};

my @headers; # Will contain to/subject/reply_to

my @extra_headers; # Will contain from/errors_to + eventual manual headers..

my %found; # Hash in form of ( header_name => header_val )

unless($opt->{raw}) {

for my $header (@todo) {

::logError("invalid email header: %s", $header)

if $header =~ /[^-\w]/;

my $key = lc $header;

$key =~ tr/-/_/;

my $val = $opt->{$key} || $setsub->($key);

# Redundant: done in tag_mime_lite_email()

#if($key eq 'subject' and ! length($val) ) {

# $val = errmsg('<no subject>');

#}

next unless length $val;

$val =~ s/^\s+//;

$val =~ s/\s+$//;

$val =~ s/[\r\n]+\s*(\S)/\n\t$1/g;

$found{$key} = $val;

push @extra_headers, "$header: $val" if

$header =~ /^(from|errors_to)$/;

}

unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) {

return

error_opt($opt, "Refuse to send email message with no recipient.");

}

elsif (! $found{to}) {

$::Scratch->{mv_email_enable} =~ s/\s+/ /g;

$found{to} = $::Scratch->{mv_email_enable};

push @headers, "To: $::Scratch->{mv_email_enable}";

}

}

if($opt->{extra}) {

$opt->{extra} =~ s/^\s+//mg;

$opt->{extra} =~ s/\s+$//mg;

push @extra_headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra};

}

$body ||= $setsub->('body');

unless($body) {

return error_opt($opt, "Refuse to send email message with no body.");

}

$body = format_auto_transmission($body) if ref $body;

return error_opt("mv_email_enable not set, required.") if $abort;

if($check and $found{to} ne $::Scratch->{mv_email_enable}) {

return error_opt(

"mv_email_enable to address (%s) doesn't match enable (%s)",

$found{to},

$::Scratch->{mv_email_enable},

);

}

SEND: {

# This will use tag_mime_lite_email, unless $body contains headers.

$ok = send_mail_legacy(

$found{to}, $found{subject}, $body, $found{reply_to},

0, @extra_headers );

}

if (!$ok) {

close MVMAIL;

$body = substr($body, 0, 2000) if length($body) > 2000;

return error_opt(

"Unable to send mail using %s\n%s",

$Vend::Cfg->{SendMailProgram},

join("\n", @headers, @extra_headers, '', $body),

);

}

delete $::Scratch->{mv_email_enable} if $check;

return if $opt->{hide};

return join("\n", @headers, @extra_headers, '', $body) if $opt->{show};

return ($opt->{success} || $ok);

}

# code/UserTag/email.tag

sub tag_email {

my ($to, $subject, $reply, $from, $extra, $opt, $body) = @_;

my $ok = 0;

my @extra;

my $att;

use vars qw/ $Tag /;

ATTACH: {

#::logDebug("Checking for attachment");

last ATTACH unless $opt->{attach} || $opt->{html};

unless ($Have_MIME_Lite) {

::logError("email tag: attachment without MIME::Lite installed.");

last ATTACH;

}

if($opt->{html}) {

$opt->{mimetype} ||= 'multipart/alternative';

}

else {

$opt->{mimetype} ||= 'multipart/mixed';

}

my $vtype = ref($opt->{attach});

if ($vtype) {

if ($vtype eq 'HASH') {

$att = [ $opt->{attach} ];

}

elsif ($vtype eq 'ARRAY') {

$att = $opt->{attach};

}

}

else {

if ($opt->{attach}) {

$att = [ { path => $opt->{attach} } ];

}

}

$att ||= [];

if($opt->{html}) {

unshift @$att, {

type => 'text/html',

data => $opt->{html},

disposition => 'inline',

};

}

}

$ok = tag_mime_lite_email({

to => $to,

from => $from || '',

subject => $subject || '',

cc => $opt->{cc} || '',

reply => $reply || '',

type => $opt->{body_mime} || 'text/plain',

charset => $opt->{charset},

extra_headers => \@extra || [],

encoding => $opt->{body_encoding} || '8bit',

attach => $att || ''

}, $body);

if (!$ok) {

::logError("Unable to send mail using tag_mime_lite_email\n" .

"To '$to'\n" .

"From '$from'\n" .

"With extra headers '$extra'\n" .

"With reply-to '$reply'\n" .

"With subject '$subject'\n" .

"And body:\n$body");

}

return $opt->{hide} ? '' : $ok;

}

###########################################################################

# Helper functions

# Vend::Util::send_mail function used to sometimes receive body

# which contains headers as well (usually coming as a result of

# Vend::Interpolate::mime() processing). Figure out if this is the

# case.

sub looks_like_email_header {

if ( ${$_[0]} =~ /^\n*--[\w-]+?:=\d+\nContent-/s ) { return 1 }

0;

}

sub format_auto_transmission {

my $ref = shift;

## Auto-transmission from Vend::Data::update_data

## Looking for structure like:

##

## [ '### BEGIN submission from', 'ckirk' ],

## [ 'username', 'ckirk' ],

## [ 'field2', 'value2' ],

## [ 'field1', 'value1' ],

## [ '### END submission from', 'ckirk' ],

## [ 'mv_data_fields', [ username, field1, field2 ]],

##

return $ref unless ref($ref);

my $body = '';

my %message;

my $header = shift @$ref;

my $fields = pop @$ref;

my $trailer = pop @$ref;

$body .= "$header->[0]: $header->[1]\n";

for my $line (@$ref) {

$message{$line->[0]} = $line->[1];

}

my @order;

if(ref $fields->[1]) {

@order = @{$fields->[1]};