[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