#------------------------------------------------------------
# sub sendmail()
#
# send/fake email around the world ...
#
# Version : 1.21
# Environment: Hip Perl Build 105 NT 3.51 Server SP4
# Environment: Hip Perl Build 110 NT 4.00
#
# arguments:
#
# $from email address of sender
# $reply email address for replying mails
# $to email address of reciever
# (multiple recievers can be given separated with space)
# $smtp name of smtp server (name or IP)
# $subject subject line
# $message (multiline) message
# $hostname (added by frank@ansto.gov.au)
#
# return codes:
#
# 1 success
# -1 $smtphost unknown
# -2 socket() failed
# -3 connect() failed
# -4 service not available
# -5 unspecified communication error
# -6 local user $to unknown on host $smtp
# -7 transmission of message failed
# -8 argument $to empty
#
# usage examples:
#
# print
# sendmail("Alice <alice\@company.com>",
# "alice\@company.com",
# "joe\@agency.com charlie\@agency.com",
# $smtp, $subject, $message );
#
# or
#
# print
# sendmail($from, $reply, $to, $smtp, $subject, $message, $hostname );
#
# (sub changes $_)
#
# $Header: /export/home/mohlerb/syssumm/remote/RCS/Sendmail.pm,v 1.3 2000/04/04 02:37:31 mohlerb Exp mohlerb $
# 
# $Revision: 1.3 $
#
# $Log: Sendmail.pm,v $
# Revision 1.3  2000/04/04 02:37:31  mohlerb
# changes from Frank Crawford including:
# BSD/OS has something broken in perl5's connect, and this
# fixes it in Sendmail.pm
#
# Revision 1.2  2000/01/12 18:11:21  mohlerb
# changes from Frank Crawford including:
# minor patch to work on BSD/OS (it is a painful, stupid bug)
#
# Revision 1.1  2000/01/05 18:25:33  mohlerb
# Initial revision
#
#------------------------------------------------------------

package Sendmail;

use Socket;

sub main::sendmail
{	my ($from, $reply, $to, $smtp, $subject, $message, $hostname) = @_;

	# The following definitions are setup for errors
	%Result = (
		1 => "success",
		-1 => "host \"$smtp\" unknown",
		-2 => "socket() failed",
		-3 => "connect() failed",
		-4 => "service not available",
		-5 => "unspecified communication error",
		-6 => "local user \"$to\" unknown on host \"$smtp\"",
		-7 => "transmission of message failed",
		-8 => "argument \$to empty"
	); 
	
	my ($fromaddr) = $from;
	my ($replyaddr) = $reply;
	
	$to =~ s/[ \t]+/, /g; # pack spaces and add comma
	$fromaddr =~ s/.*<([^\s]*?)>/$1/; # get from email address
	$replyaddr =~ s/.*<([^\s]*?)>/$1/; # get reply email address
	$replyaddr =~ s/^([^\s]+).*/$1/; # use first address
	$message =~ s/^\./\.\./gm; # handle . as first character
	$message =~ s/\015\012/\n/g; # handle line ending
	$message =~ s/\n/\015\012/g;
	$smtp =~ s/^\s+//g; # remove spaces around $smtp
	$smtp =~ s/\s+$//g;
	$hostname = 'localhost' unless $hostname;
	
	if (!$to) { return -8; }
	
	my($proto) = (getprotobyname('tcp'))[2];
	my($port) = (getservbyname('smtp', 'tcp'))[2];
	
	my($smtpaddr) = ($smtp =~
	/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/)
	? pack('C4',$1,$2,$3,$4)
	: (gethostbyname($smtp))[4];
	
	if (!defined($smtpaddr)) { return -1; }
	
	if (!socket(S, AF_INET, SOCK_STREAM, $proto)) { return -2; }
	# This is broken on BSD/OS!!! - something about IPV6 compatibility
	my($sockaddr) = ($^O eq 'bsdos') ? 'x C n a4 x8' : 'S n a4 x8';
	if (!connect(S, pack($sockaddr, AF_INET, $port, $smtpaddr))) { return -3; }
	
	my($oldfh) = select(S); $| = 1; select($oldfh);
	
	$_ = <S>; if (/^[45]/) { close S; return -4; }
	
	print S "helo $hostname\015\012";
	$_ = <S>; if (/^[45]/) { close S; return -5; }
	
	print S "mail from: <$fromaddr>\015\012";
	$_ = <S>; if (/^[45]/) { close S; return -5; }
	
	foreach (split(/, /, $to)) {
		print S "rcpt to: <$_>\015\012";
		$_ = <S>; if (/^[45]/) { close S; return -6; }
	}
	
	print S "data\015\012";
	$_ = <S>; if (/^[45]/) { close S; return -5; }
	
	print S "To: $to\015\012";
	print S "From: $from\015\012";
	print S "Reply-to: $replyaddr\015\012" if $replyaddr;
	print S "X-Mailer: Perl Sendmail Version 1.21 Christian Mallwitz Germany\015\012";
	print S "Subject: $subject\015\012\015\012";
	print S "$message";
	print S "\015\012.\015\012";
	
	$_ = <S>;
	if (/^[45]/) {
		close S;
		return -7;
	}
	
	print S "quit\015\012";
	$_ = <S>;
	
	close S;
	return 1;
}

1;
