[interchange-cvs] interchange - docelic modified lib/Vend/Email.pm
interchange-cvs at icdevgroup.org
interchange-cvs at icdevgroup.org
Fri May 4 05:43:27 EDT 2007
User: docelic
Date: 2007-05-04 09:43:27 GMT
Modified: lib/Vend Email.pm
Log:
* Working Email.pm.
* Compatibility functions for send_mail(), mail() and tag email.
* Should be a drop-in replacement.
There is another part of this commit, that I will add later today or
tomorrow. (Re-directions from traditional send_mail, mail and tag email
to code in this module).
I'd like to give you a chance for peer review or comments before we
actually switch to Email.pm.
Cya folks
-doc
Revision Changes Path
1.3 +695 -71 interchange/lib/Vend/Email.pm
rev 1.3, prev_rev 1.2
Index: Email.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Email.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Email.pm 9 Apr 2007 21:39:49 -0000 1.2
+++ Email.pm 4 May 2007 09:43:26 -0000 1.3
@@ -1,6 +1,6 @@
# Vend::Email - Handle Interchange email functions
#
-# $Id: Email.pm,v 1.2 2007/04/09 21:39:49 docelic Exp $
+# $Id: Email.pm,v 1.3 2007/05/04 09:43:26 docelic Exp $
#
# Copyright (C) 2007 Interchange Development Group
#
@@ -22,13 +22,27 @@
# 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;
use MIME::Lite qw//; # Main module
use MIME::Types qw//;
use Mail::Address qw//;
use MIME::QuotedPrint qw//; # Used by default
-use MIME::Base64 qw//; # For user specified encodings
+use MIME::Base64 qw//; # For user-specified encodings
#use MIME::EncWords qw//; # Word-encode mail headers when non-ascii
#use MIME::Charset qw//; # Needed for EncWords
@@ -44,30 +58,34 @@
use vars qw/$VERSION/;
-$VERSION = substr(q$Revision: 1.2 $, 10);
-
-my @accepted_headers = (qw/
- to cc bcc
- sender from subject reply\-to
- content\-[a-z-]+ x\-[a-z-]+
- approved encrypted received
- references keywords comments
- message\-id mime\-version return\-path
- date organization
- resent\-[a-z-]+
-/);
+$VERSION = substr(q$Revision: 1.3 $, 10);
###########################################################################
# Direct functions
#
-# Pass input as options (data + headers) to create MIME::Lite object and send.
-# Work to do here is filling unspecified fields with defaults, and making
-# sure that all given options are valid.
+#
+# 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 ($opt, $body) = @_;
- #logDebug('mime_lite_email invoked, OPT=' .uneval($opt) . ' BODY=' . $body);
+ #::logDebug('mime_lite_email invoked, OPT=' .uneval($opt) . ' BODY=' . $body);
local $_;
@@ -76,20 +94,30 @@
#
my $using = $Vend::Cfg->{SendMailProgram};
if ($using =~ /^none$/i ) {
- logError('Unable to send email, config option SendMailProgram=none.');
+ ::logError('Unable to send email, config option SendMailProgram=none.');
return;
}
#
- # Quickly make sure that all options and header names satisfy basic regex.
- # (We need to do this in any case, so let's do it up-front.)
+ # 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 ) {
- $key = lc $key; # MIME::Lite does proper uppercasing later
- $key =~ /^[a-z-]+$/ or do {
- logError('Header name passed that does not match /^[a-zA-Z_-]+$/');
- return;
- };
+ 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};
+ }
}
#
@@ -97,35 +125,46 @@
# (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);
+ my ($interpolate, $reparse, $hide);
my ($data, $encoding, $type);
+ 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 = '';
+ #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) = (
+ ($interpolate, $reparse, $hide) = (
delete $opt->{interpolate},
delete $opt->{reparse},
+ delete $opt->{hide},
);
# Data (msg body), encoding and type
@@ -139,13 +178,52 @@
$type ||= 'text/plain';
!(ref $data or ref $encoding or ref $type) or do {
- logError('Only scalar value accepted for options '.
- 'data (body), encoding and type.');
+ ::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, check them and/or associate defaults.
+ # 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.)
@@ -158,7 +236,7 @@
# sure they are scalars.
if ( $key =~ /^(subject|from)$/ ) {
! ref $opt->{$key} or do {
- logError('Only scalar value accepted for option or '.
+ ::logError('Only scalar value accepted for option or '.
'header name "%s"', $key);
return;
};
@@ -170,7 +248,7 @@
if ( ! ref $opt->{$key} ) {
$opt->{$key} = [ $opt->{$key} ];
} elsif (ref $opt->{$key} ne 'ARRAY' ) {
- logError('Only scalars or array refs supported as options ' .
+ ::logError('Only scalars or array refs supported as options ' .
'to tag_mime_lite_email().');
return;
}
@@ -181,7 +259,7 @@
# TO
if (!( $opt->{to} and @{ $opt->{to} } )) {
- logError('mime_lite_email called without the required to= option.');
+ ::logError('mime_lite_email called without the required to= option.');
return;
}
@@ -193,7 +271,7 @@
$Vend::Cfg->{MailOrderTo};
}
$opt->{from} or do {
- logError('Cannot find value for From: header. Make sure ' .
+ ::logError('Cannot find value for From: header. Make sure ' .
'that MailOrderTo config directive or MV_MAILFROM variable ' .
'is specified.');
};
@@ -212,6 +290,23 @@
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)).
#
@@ -222,7 +317,7 @@
for my $field (qw/to cc bcc/) {
if ( $opt->{$field} ) {
for $_ ( @{ $opt->{$field} } ) {
- logDebug('Intercepting outgoing email (%s: %s) ' .
+ ::logError('Intercepting outgoing email (%s: %s) ' .
'and instead sending to "%s"',
$field, $_, $intercept);
@@ -234,21 +329,67 @@
}
#
- # Now let's work on adjusting fields to adhere to e-mail standards.
- #
-
- #
# 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}};
+ }
+ }
+
#
# 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 any more.
+ # 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};
@@ -266,7 +407,7 @@
MIME::Lite->send('sendmail', $using . ' -t');
}
- #logDebug('mime_lite_email will invoke MIME::Lite with ' .uneval($opt));
+ #::logDebug('mime_lite_email will invoke MIME::Lite with ' .uneval($opt));
#
# Create message just with body, and add headers later.
@@ -276,12 +417,13 @@
Type => $type,
) or do {
- logError("Can't create MIME::Lite mail ($!).");
+ ::logError("Can't create MIME::Lite mail ($!).");
return;
};
#
- # Fill in @headers with [ hdr_name, value ]
+ # Fill in @headers with [ hdr_name, value ], and append with
+ # @extra_headers
my @headers;
while (my($hdr,$values) = each %$opt ) {
if (! ref $values ) {
@@ -291,37 +433,37 @@
for my $value (@$values ) { push @headers, [ $hdr, $value ] }
} else {
- logError('Only scalars and array refs supported as header values.');
+ ::logError('Only scalars and array refs supported as header values.');
return;
}
}
+ push @headers, @extra_headers;
#
- # Sanitize headers and add them to $msg object
+ # Add headers to $msg object
for my $hdr (@headers) {
- # [0] is name, [1] is value. Let's first work on header names
+ # [0] is name, [1] is value.
$$hdr[0] =~ s/_/-/g;
- for my $template ( @accepted_headers ) {
- if ( $$hdr[0] =~ /^$template$/ ) {
- goto HEADER_NAME_VERIFIED;
- }
- }
-
- logError('Unknown email header name passed: ' . $$hdr[0]);
- return;
-
- # We jump here if header name is valid
- HEADER_NAME_VERIFIED:
-
- # Now work on header value
-
# 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.
#
@@ -331,11 +473,493 @@
}
###########################################################################
+# 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;
+
+ use vars qw/ $Tag /;
+
+
+ my $att = $opt->{attach};
+ ATTACH: {
+
+ my %att_hash;
+
+ #::logDebug("Checking for attachment");
+ last ATTACH unless $opt->{attach} || $opt->{html};
+
+ if($opt->{html}) {
+ $opt->{mimetype} ||= 'multipart/alternative';
+ }
+ else {
+ $opt->{mimetype} ||= 'multipart/mixed';
+ }
+
+ if(! ref($att) ) {
+ my $fn = $att;
+ $att = [ { path => $fn } ];
+ }
+ elsif(ref($att) eq 'HASH') {
+ $att = [ $att ];
+ }
+
+ $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',
+ 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;
-# TODO:
-# Attachments
-# Header Word-encoding
-# Compatibility functions
More information about the interchange-cvs
mailing list