#!/bin/perl
# Copyright (c) 2004 Charles Bryant. All rights reserved.
# This software is free software; you may copy and modify it under the
# terms of the GNU General Public Licence (see file LICENCE).

use Socket;


$| = 1;
setpriority(0, 0, 4);
@ARGV == 3 || die "Usage: pop2smtp username pop3-server smtpserver\n";
my $username = shift;
my $pop3server = shift;
my $smtpserver = shift;
my $password = <STDIN>;		# for bettwe secrecy
chomp($password);
$_ = &pop2smtp($smtpserver, "pop3relay", $pop3server, $username, $password);
die "pop2smtp failed: $_\n" if $_ ne '';

# pop2smtp(smtpserver, helo, pop3server, username, password)
# perform complete move of pop3 maildrop to SMTP
# where:
#	smtpserver is the local SMTP server to use
#	helo is string to send with HELO
#	pop3server is the remote server to use
#	username is the name to connect as
#	password is the passowrd to use
# returns:
#	error string if unsuccessful, empty string otherwise
sub pop2smtp {
	my ($smtpserver, $helo, $pop3server, $username, $password) = @_;
	my $ret = '';
	local(*SMTPSOCK);
	my $r = &opensmtp(\*SMTPSOCK, $smtpserver, $helo);
	return "Could not open SMTP connection: $r\n" if $r ne '';
	local(*POP3SOCK);
	$r = &openpop3(\*POP3SOCK, $pop3server, $username, $password);
	return "Could not open pop3 connection: $r\n" if $r;
		# in TRANSACTION state
	$r = &txrxpop3(\*POP3SOCK, "STAT");
	if ($r =~ /^\+OK ([0-9]+) ([0-9]+)/) {
		my ($nummsg, $msgsize) = ($1, $2);
		my $msg;
		for ($msg = 1; $msg <= $nummsg; $msg++) {
			$ret = &passmsg(\*SMTPSOCK, \*POP3SOCK, $msg);
				# NB: must not return here!
				# must ensure QUIT is sent to cause
				# deletions to be committed
			last if $ret ne '';
		}
	} else {
		return "Expected '+OK' after STAT, got '$r'\n";
	}
	$r = &txrxpop3(\*POP3SOCK, "QUIT");
	return "Expected '+OK' after QUIT, got '$r'\n" unless $r =~ /^\+OK/;
	$r = &txrxsmtp(\*SMTPSOCK, "QUIT");
	return "Expected positive response to QUIT got '$r'\n" if $r >= 400;
	return $ret;
}

# opensmtp(sock, smtpserver, helo)
# open SMTP connection and check response
# where:
#	sock is a reference to a file handle
#	smtpserver is the address of a server
#	helo is string to send with HELO
# returns
#	error string if failed, empty string otherwise
sub opensmtp {
	my ($sock, $smtpserver, $helo) = @_;
	my $r = &opensock($sock, $smtpserver, 25);
	select($sock);
	$| = 1;
	select(STDOUT);
	return "Can't open SMTP socket to $smtpserver: $r\n" if $r;
	$r = &rxsmtp($sock);
	return "Expected positive response at connect, got '$r'\n" if $r >= 400;
	$r = &txrxsmtp($sock, "HELO $helo");
	return "Expected positive response to HELO $helo got '$r'\n" if $r >= 400;
	return '';
}

# openpop3(sock, pop3server)
# open POP3 connection and check response
# where:
#	sock is a reference to a file handle
#	pop3server is the address of a server
#	username is the name to connect as
#	password is the passowrd to use
# returns
#	error string if failed, empty string otherwise
sub openpop3 {
	my ($sock, $pop3server, $username, $password) = @_;
	my $r = &opensock($sock, $pop3server, 110);
	select($sock);
	$| = 1;
	select(STDOUT);
	return "Can't open pop3 socket to $pop3server: $r\n" if $r;
		# in AUTHORIZATION state
	$r = &rxpop3($sock);
	return "Expected '+OK' at connect, got '$r'\n" unless $r =~ /^\+OK/;
	$r = &txrxpop3($sock, "USER $username");
	return "Expected '+OK' after USER, got '$r'\n" unless $r =~ /^\+OK/;
	$r = &txrxpop3($sock, "PASS $password");
	return "Expected '+OK' after PASS, got '$r'\n" unless $r =~ /^\+OK/;
	return '';
}

# passmsg(smtpsock, pop3sock, $msg)
# retrieve message from POP3 and send to SMTP
# where:
#	smtpsock is a reference to a file handle open to SMTP server
#	pop3sock is a reference to a file handle open to POP3 server
#	msg is the POP3 message number
# returns
#	error string if failed, empty string otherwise
sub passmsg {
	my ($smtpsock, $pop3sock, $msg) = @_;
	my $r = &txrxpop3($pop3sock, "*ENV $msg");
	return "Expected '+OK' after *ENV $msg, got '$r'\n" unless $r =~ /^\+OK/;
		# lines: 'ok'/'rd', undef, from, to, ...undef
	my @enve = ();
	for (;;) {
		$r = &rxpop3($pop3sock);
		last if $r eq ".\n";
		chomp($r);
		push(@enve, $r);
	}
	$r = &txrxpop3($pop3sock, "RETR $msg");
	return "Expected '+OK' after RETR $msg, got '$r'\n" unless $r =~ /^\+OK/;
	$r = &smtpstartmsg($smtpsock, $enve[2], $enve[3]);
	return "Cannot start SMTP for message from $enve[2] to $enve[3]: $r\n"
		if $r ne '';
	for (;;) {
		alarm(600);
		my $x = <$pop3sock>;
		last if $x eq '';
		$x =~ s/\r\n$/\n/;
		chomp($x);
		alarm(600);
		print $smtpsock "$x\r\n";
		last if $x eq '.';
	}
	$r = &rxsmtp($smtpsock);
	return "Expected positive response after message, got '$r'\n" if $r >= 400;
	$r = &txrxpop3($pop3sock, "DELE $msg");
	return "Expected '+OK' after DELE $msg, got '$r'\n" unless $r =~ /^\+OK/;
	return '';
}

# smtpstartmsg(sock, sender, recipient)
# prepare to send a message over SMTP
# where:
#	sock is a reference to a file handle
#	sender is the envelope sender
#	recipient is the envelope recipient
# returns
#	error string if failed, empty string otherwise
sub smtpstartmsg {
	my ($sock, $sender, $recipient) = @_;
	my $r = &txrxsmtp($sock, "MAIL FROM:<$sender>");
	return "Expected positive response to MAIL FROM:<$sender> got '$r'\n" if $r >= 400;
	$r = &txrxsmtp($sock, "RCPT TO:<$recipient>");
	return "Expected positive response to RCPT TO:<$recipient> got '$r'\n" if $r >= 400;
	$r = &txrxsmtp($sock, "DATA");
	return "Expected positive response to DATA got '$r'\n" if $r >= 400;
	return '';
}

# opensock(sock, remname remport)
# open a socket
# where:
#	sock is a reference to a filehandle to be opened
#	remname is the name of the remote host
#	remport is the remote port
# returns:
#	error string on failure, otherwise an empty string
sub opensock {
	my ($sock, $remname, $remport) = @_;
	my ($sockaddr) = 'S n a4 x8';
	my ($name, $aliases, $proto, $type, $len);
	my ($thataddr, $that);
	my (@x);
	@x = getprotobyname('tcp');
	return "getprotobyname(tcp) failed: $!" if $#x == -1;
	($name, $aliases, $proto) = @x;
	if ($remport !~ /^\d+$/) {
		@x = getservbyname($remport, 'tcp');
		return "getservbyname($remport, tcp) failed: $!" if $#x == -1;
		($name, $aliases, $remport) = @x;
	}
	@x = gethostbyname($remname);
	return "gethostbyname($remname) failed: $!" if $#x == -1;
	($name, $aliases, $type, $len, $thataddr) = @x;
	$that = pack($sockaddr, &AF_INET, $remport, $thataddr);
	return "socket() error: $!"
		unless socket($sock, &PF_INET, &SOCK_STREAM, $proto);
	return "connect() error: $!" unless connect($sock, $that);
	return '';
}

# rxpop3(pop3sock)
# receive from remote (with logging) where:
# where:
#	pop3sock is a reference to a socket open to pop3 server
# returns:
#	string read from pop3 server
sub rxpop3 {
	my ($pop3sock) = @_;
	alarm(600);
	my $msg = <$pop3sock>;
	$msg =~ s/\r\n$/\n/;
	print "P>$msg";
	return $msg;
}

# txrxpop3(pop3sock, msg)
# send message and get response (with logging):
# where:
#	pop3sock is a reference to a socket open to pop3 server
#	msg is the message to send (excluding trailing CRLF)
# returns:
#	string read from pop3 server
sub txrxpop3 {
	my ($pop3sock, $msg) = @_;
	alarm(600);
	print "P<$msg\n";
	print $pop3sock "$msg\r\n";
	return &rxpop3($pop3sock);
}

# rxsmtp(smtpsock)
# receive complete smtp reply from SMTP server (with logging)
# where:
#	smtpsock is a reference to a socket open to SMTP server
# returns:
#	string read from remote
sub rxsmtp {
	my ($smtpsock) = @_;
	my $r = '';
	for (;;) {
		alarm(600);
		my $msg = <$smtpsock>;
		$msg =~ s/\r\n$/\n/;
		print "S>$msg";
		$r .= $msg;
		last unless $msg =~ /^[0-9][0-9][0-9]-/;
	}
	return $r;
}

# txsmtp(smtpsock, msg)
# send string to SMTP server (with logging)
# where:
#	smtpsock is a reference to a socket open to SMTP server
#	msg is the string to send
# returns:
#	error string on failure, otherwise an empty string
sub txsmtp {
	my ($smtpsock, $msg) = @_;
	alarm(600);
	print $smtpsock "$msg\r\n";
	print "S<$msg\n";
	return '';
}

# txrxsmtp(smtpsock, msg)
# send string to SMTP server (with logging) and receive reply
# where:
#	smtpsock is a reference to a socket open to SMTP server
#	msg is the string to send
# returns:
#	the reply
sub txrxsmtp {
	my ($smtpsock, $msg) = @_;
	&txsmtp($smtpsock, $msg);
	return &rxsmtp($smtpsock);
}