Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1022 lines (861 sloc) 24.9 KB
# 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]};
}
else {
@order = sort keys %message;
}
for (@order) {
$body .= "$_: ";
if($message{$_} =~ s/\r?\n/\n/g) {
$body .= "\n$message{$_}\n";
}
else {
$body .= $message{$_};
}
$body .= "\n";
}
$body .= "$trailer->[0]: $trailer->[1]\n";
return $body;
}
1;
You can’t perform that action at this time.