#!/usr/bin/perl -Tw
##########################################################################
my $progname = "odmrd v0.9rc10";
my $scriptname = "odmrd";
#
# A RFC 2645 compliant ODMR server
# written in Perl (tested with 5.6.0, 5.8.3)
#
# http://www.plonk.de/sw/odmr/
#
# (C) 2002 by Jakob Hirsch (odmrd@plonk.de)
#
# 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.
#
# [http://www.fsf.org/licenses/gpl.txt]
#
#
# Warning: operational but still in beta status!
#
# odmrd.pl takes two command line options:
# -c /path/to/conf.file specifies the location of the configuration file
# -d debug mode - turns on verbose logging
#
##########################################################################
#
# you should normally not need to change anything in here
# just create your /etc/odmrd.conf and be happy
#
##########################################################################
use strict;
use warnings;
use Unix::Syslog qw(:macros :subs);  # Syslog macros and functions
use Getopt::Std;

my %opts;
getopts('c:dv', \%opts);
if ($opts{'v'}) {
	print "$progname\n";
	exit 0;
}

# open syslog - you can change facility and options if you like
openlog("odmrd", LOG_PID, LOG_MAIL);

# log levels: LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, LOG_NOTICE, LOG_INFO, LOG_DEBUG

############################################################
# You usually don't have to change anything below this line
############################################################
my (%config, $peer);
my $user = "";
my ($fh_in, $fh_out); # the IO handles we need later

$SIG{__WARN__} = sub {
	syslog(LOG_WARNING, "warning: %s", $_[0]);
};
$SIG{__DIE__}  = sub {
	syslog(LOG_ERR, "error: %s", $_[0]);
	myprint ("421 server error - closing transmission channel") if $fh_out;
	&end_prog;
};
$SIG{ALRM} = sub {
	my $log = "connection timed out (";
	$log .= $user ? $user : "unknown";
	$log .= "\@$peer)";
	syslog(LOG_NOTICE, $log);
	myprint("421 command timeout, closing connection");
	&end_prog;
};
$SIG{PIPE} = sub {
	syslog(LOG_NOTICE, "connection lost (SIGPIPE)");
	&end_prog;
};
my $child;
$SIG{TERM} = sub {
	if (! $child) {
		syslog(LOG_NOTICE, "Server shutdown (SIGTERM).");
		unlink $config{pidfile};
	}
	&end_prog;
};
$SIG{INT} = $SIG{TERM};
$SIG{HUP} = sub {
	syslog(LOG_WARNING, "received SIGHUP - reloading config (not yet implemented!)");
	#config_defaults();
	#config_read();
};

#
use strict;
use MIME::Base64;
use Digest::HMAC_MD5 qw(hmac_md5_hex);
use Socket;

use POSIX qw(setsid setuid setgid);
use IO::Handle;
use IO::Socket;
use IO::Select;

# read defaults - put your settings into /etc/ordmrd.conf!
config_defaults();

# Make %ENV safer (satisfy taint mode)
delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};

$config{debug} = 1 if $opts{'d'};
$config{conf_file} = $opts{'c'} if $opts{'c'};

syslog(LOG_DEBUG, "$progname startup");

# include user settings if file is readable
syslog(LOG_INFO, "Reading configuration from %s", $config{conf_file}) if $config{debug};
config_read();

# use sendfile if activated
if ($config{use_sendfile}) {
	local $SIG{__DIE__};
	eval "use IO::sendfile2 qw(sendfile)";
	if ($@) {
		$config{use_sendfile} = 0;
		warn "sendfile disabled, module IO::sendfile2 is not installed\n";
	}
}

##
# connection handling

if ($config{standalone}) { # standalone mode
	daemonize() if $config{daemon};	# become a background daemon

	# returns the socket handle of the forked child
	$fh_in = standalone();	
	$fh_out = $fh_in;
} else { # superserver (inetd) or interactive mode
	open($fh_in, "<&=".fileno(STDIN))   or die "dup STDIN failed ($!)\n";
	open($fh_out, ">&=".fileno(STDOUT)) or die "dup STDOUT failed ($!)\n";
}

# flush outputs immediatly
$fh_out->autoflush(1);

# reset traffic counter
my $b_in = 0;
my $b_out = 0;

# get own hostname
if ( ! $config{hostname} ) {
	# get the address of the local end
	my $localsockaddr = getsockname($fh_in);

	# check that $fh_in is a socket (getsockname returned no errors)
	# and that it is in the INET address family before running sockaddr_in
	# (note that getsockname returns a UNIX address family address when
	# odmrd runs as a child of an SSH connection)

	# ideally, we'd do this using sockaddr_family, but that's not available
	# in the version of Socket.pm which ships with perl 5.6.1; instead, we'll
	# have to content ourselves with catching the croak() from sockaddr_in.

	my $localaddr;
	if ( $localsockaddr ) {
		eval {
			local $SIG{'__DIE__'};
			(undef,$localaddr) = sockaddr_in($localsockaddr);
		};
		$localaddr=undef if $@;
	}

	if($localaddr) {
		$config{hostname} = my_gethostbyaddr($localaddr);
	} else {
		$config{hostname} = "localhost";
	}

}
syslog(LOG_INFO, "Using hostname '%s'" , $config{hostname}) if $config{debug};

# get peer information. See notes above regarding address families.
my ($peerip, $peerhost, $peername, $peerport);

if ( getpeername($fh_in) ) {
	eval {
		local $SIG{'__DIE__'};
		($peerport, $peerip) = sockaddr_in(getpeername($fh_in));
	};
	$peerip = undef if $@;
}

if( $peerip ) {
	$peerhost = inet_ntoa($peerip);
	$peername = my_gethostbyaddr($peerip);
	syslog(LOG_INFO, "Connection from: %s [%s:%i]",
			$peername, $peerhost, $peerport) if $config{debug};
} else {
	$peerhost = "0.0.0.0";
	$peerport = 0;
	$peername = "local";
	syslog(LOG_INFO, "Connection from: local") if $config{debug};
}

$peer = $peername;

# startup greeting
myprint("220 $config{hostname} $progname ODMR service ready");

# initial state (sorry for global vars)
my $gothelo = 0;
my $mails_waiting = 0;
my $mails_sent = 0;
my $invalid_cmds = 0;
my $invalid_auth = 0;
#my $user = "";
my %capa = ();
my $dbh;

while ( defined($_ = myget()) ) {
	### QUIT
	if    (/^quit$/i)	{ quit_rcvd(); }
	### HELO is not allowed
	elsif (/^helo(\s+.*)?$/i) {
		myprint("502 please use EHLO");
	}
	### EHLO
	elsif (/^ehlo(\s+.*)?$/i) {
		if ( $gothelo ) { myprint("503 duplicate EHLO"); }
		else { ehlo(); $gothelo = 1; }
	}
	### AUTH <method>
	elsif (/^auth$/i) { myprint("504 no authentication method specified"); }
	elsif (/^auth\s+.*$/i)	{
		$invalid_auth++;
		if ($invalid_auth > $config{max_invalid_auth}) {
			myprint("421 too many authentication attempts, closing connection");
			syslog(LOG_NOTICE, "%s: closing connection after %s authentication attempts", $peer, $invalid_auth);
			&end_prog;
		}
		if ($user) { myprint("503 already authenticated"); }
		else {
			# open database connection
			if (! $dbh) {
				use DBD::mysql;
				$dbh = DBI->connect(
					"DBI:mysql:database=$config{mysql_db};$config{mysql}",
					$config{mysql_user}, $config{mysql_pass}, 
                                        { PrintError => 1, RaiseError => 0, AutoCommit => 1 });

				myprint("454 Temporary authentication failure") unless $dbh;
			}

			if ($dbh) { $user = auth($_, $dbh); }
		}
	}
	### ATRN [domains]
	elsif (/^atrn(\s+.*)?$/i) {
		if ($user) { atrn($user, $_, $dbh); }
		else { myprint("530 authentication required"); }
	}
	### RSET
	elsif (/^rset$/i)   {
		myprint("250 Reset OK");
	}
	### NOOP
	elsif (/^noop$/i)   {
		myprint("250 OK");
	}
	### invalid command
	else {
		$invalid_cmds++;
		if ($invalid_cmds > $config{max_invalid_cmds}) {
			syslog(LOG_NOTICE, "Closing connection from %s after %s invalid commands", $peer, $invalid_cmds);
			myprint("421 too many invalid commands, closing connection");
			&end_prog;
		}
		myprint("502 unknown command '$_'");
	}
}

syslog(LOG_NOTICE, "Lost connection from %s", $peer);
&end_prog;
exit;		# just to be sure...

#########################################################
#########################################################
sub standalone {

my @server;

# create socket for every server address
foreach my $server_ip (@{$config{server_ip}}) {
	my @server_ports;

	if ($server_ip =~ /(\d+\.\d+\.\d+\.\d+):(\d+)/o) {
		$server_ip = $1;
		@server_ports = ($2);
	} else {
		@server_ports = @{$config{server_port}};
	}

	foreach my $server_port (@server_ports) {
		my $server = IO::Socket::INET->new(
				LocalAddr => $server_ip,
				LocalPort => $server_port,
				Proto     => 'tcp',
				ReuseAddr => 1,
				Listen    => SOMAXCONN)
			or warn "Binding to $server_ip:$server_port: $@\n";
		if ($server) {
			binmode $server;
			push @server, $server;
			syslog(LOG_DEBUG, "now listening to %s:%s", $server_ip, $server_port);
		}
	}
}

die "no socket to listen to\n" unless @server;
syslog LOG_NOTICE, "%s server startup succeeded.", $progname;

# dropping privileges
if ($config{user} and $config{user} =~ /\D/) {
	my @pwnam = getpwnam($config{user}) or die "unknown user $config{user}\n";
	$config{user} = $pwnam[2];
	$config{group} = $pwnam[3] if ! $config{group};
}
if ($config{group} and $config{group} =~ /\D/) {
	(undef, undef, $config{group}) = getgrnam($config{group}) or die "unknown group $config{group}\n";
}
$) = $config{group}." ".$config{group};
setgid($config{group});
setuid($config{user});
syslog LOG_DEBUG, "privileges: %s, %s, %s, %s", $<, $>, $(, $);

# write PID
if (open(PIDFILE, ">$config{pidfile}")) {
	print PIDFILE $$;
	close PIDFILE;
} else { warn "could not create pidfile $config{pidfile} ($!)\n"; }

# optical tuning
$0 = "$scriptname [accepting connections]";

my $select = IO::Select->new(@server);
#$SIG{CHLD} = \&REAPER;	# todo: reap childs manually
$SIG{CHLD} = 'IGNORE';

while (1) {	# endless loop for the server
	foreach my $fh ($select->can_read) {	# wait for input (select)
		my $fh_client = $fh->accept;
		syslog(LOG_INFO, "connection from %s:%s to %s:%s",
				$fh_client->peerhost, $fh_client->peerport,
				$fh_client->sockhost, $fh_client->sockport
			) if $config{debug};

		my $pid = fork;
		if (! defined($pid)) {
			warn "$$ fork failed: $!";
			next;
		} elsif ($pid) {	# parent
			$fh_client->close; # the server does not need that
		} else {		# childs
			$fh->close;	# the child does not need that
			binmode $fh_client;
			$0 = "$scriptname [connection from ".$fh_client->peerhost."]";
			return $fh_client;
		}
	}
}
exit;
} # end of sub

#########################################################
#########################################################
sub ehlo
{
myprint("250-$config{hostname} Hello $peername [$peerhost:$peerport]");
myprint("250-AUTH CRAM-MD5" . ($config{allow_login} ? " LOGIN" : ""));
myprint("250 ATRN");
}

#########################################################
#########################################################
# -> "AUTH <data>", $dbh
# <- $user
sub auth
{
my $dbh = $_[1];
my $s = "";
my $user = "";
my $pass;
my $authmethod = "";
my $authdata = "";
my $authrc = 1;

(undef, $authmethod, $authdata, undef) = split /[ ,]/, $_;
$authmethod = lc($authmethod);

if ( $authmethod eq "cram-md5" ) {
	# CRAM-MD5
	my $chal = "<".rand(65536).".".$$.".".time."@".$config{hostname}.">";
	$s = encode_base64($chal, '');
	myprint("334 $s");

	$s = myget();
	if ( !($s) or $s eq "*" ) {
		myprint("501 authentication cancelled");
		return;
	}

	($user, $pass) = split / /, decode_base64($s);

	# check input for invalid characters
	if ($user =~ /^([-\w\._@!#]+)$/) {
		$user = $1;
	} else {
		syslog(LOG_NOTICE, "bad data from %s in username '%s'", $peer, $user);
		myprint("501 bad data in username");
		return;
	}

	my ($pass_real) = $dbh->selectrow_array($config{sql_pass}, undef, $user);
	$authrc = 1;			# default: password wrong or nonexisting user
	if ($dbh->err) { $authrc = 2; }					# db error
	elsif ( $pass_real && (hmac_md5_hex($chal, $pass_real) eq $pass) )
		{ $authrc = 0; }	# password ok
}
elsif ( $authmethod eq "login" and $config{allow_login}) {
	# LOGIN

	if ($authdata) {
		($user, $pass) = split /\000/, decode_base64($authdata);
	}

	# ask "Username:" if not given
	if (! $user) {
		myprint("334 VXNlcm5hbWU6"); # "Username:"
		$s = myget();
		
		if ($s ne "*") {
			($user, $pass) = split /\000/, decode_base64($s);
		}
	}

	# ask "Password:" if not given
	if (! $pass) {
		myprint("334 UGFzc3dvcmQ6"); # "Password:"
		$s = myget();

		if ($s ne "*") {
			$pass = decode_base64($s);
		}
	}
	

	# assume auth cancelled if no user and pass
	unless ($user and $pass) {
		$authrc = 4;

	} else {
		# check input for invalid characters
		if ($user =~ /^([-\w\._@!#]+)$/) {
			$user = $1;

		} else {
			syslog(LOG_NOTICE, "bad data from %s in username '%s'", $peer, $user);
			myprint("501 bad data in username");
			return;
		}

		my ($pass_real) = $dbh->selectrow_array($config{sql_pass}, undef, $user);
		$authrc = 1;			# default: password wrong or nonexisting user
		if ($dbh->err) { $authrc = 2; }		# db error
		elsif ($pass_real && ($pass eq $pass_real))
			{ $authrc = 0; }		# password ok
	}
} else {
	$authrc = 3;
}

# auth ok
if ( $authrc == 0 ) {
	# try to lock
	if ( (my $pid = lock_user($user)) )
	{
		myprint("454 User $user locked by another connection");
		syslog(LOG_NOTICE, "%s: authenticated %s, but locked by pid %s", $peer, $user, $pid);
		$user = "";
	} else {	# ok, go on
		myprint("235 authenticated $user");
		syslog(LOG_INFO, "%s\@%s: authenticated with %s", $user, $peer, uc($authmethod));
		$0 = "$scriptname [$user\@$peer]";
	}
}
# auth failed
elsif ( $authrc == 1 ) {
	myprint("535 authenticating '$user' failed");
	syslog(LOG_NOTICE, "%s: authenticating '%.30s' failed", $peer, $user);
	$user = "";

} elsif ( $authrc == 2 ) {	# db error
	myprint("454 Temporary authentication failure");
	syslog(LOG_WARNING, "%s: authenticating '%s' failed, db error %s: %s",
		$peer,  $user, $dbh->err, $dbh->errstr);
	$user = "";

} elsif ( $authrc == 3 ) {	# auth method unknown
	myprint("504 unsupported authentication method '$authmethod'");
	syslog(LOG_NOTICE, "%s: unknown authentication method '%.30s'", $peer, $authmethod);
	$user = "";

} elsif ( $authrc == 4 ) {	# cancelled
	myprint ("501 Authentication cancelled");
	syslog(LOG_NOTICE, "%s: authentication cancelled", $peer);
	$user = "";

} else {			# something else
	myprint("454 Temporary authentication failure");
	syslog(LOG_WARNING, "%s: authenticating '%s' failed, authrc = %s",
		$peer,  $user, $authrc);
	$user = "";
}

return $user;
}

#########################################################
#########################################################
# -> $user
# <- 0 (ok) or pid of locking process
sub lock_user
{
my $user = $_[0];
my $rc = 0;
my $t;
my $lockfile = $config{spool}."/".$user.$config{lockext};
my $locktemp = $lockfile .".". rand(65536) .".". $$ .".". time();

# check if lockfile exists
if (-f $lockfile) {
	$rc = 1;
} else {
	# create temporary file
	if ( open(LOCK, ">".$locktemp) ) {
		# write pid into lockfile
		print LOCK $$;
		close LOCK;

		# atomic locking: link lockfile and unlink locktemp
		if ( link ($locktemp, $lockfile) ) {
			syslog(LOG_WARNING, "%s: could not unlink temporary lock %s", $locktemp)
				if unlink ($locktemp) != 1;
		} else {
			syslog(LOG_WARNING, "%s: could not link lockfile to temporary lock %s", $locktemp);
			$rc = "LOCK_FAILURE";
		}

	} else {
		syslog(LOG_WARNING, "%s: could not create temporary lockfile %s", $peer, $locktemp);
		$rc = "LOCK_FAILURE";
	}
}

return $rc;
}

#########################################################
#########################################################
# -> $user
# <- 1 (ok), 0 (error)
sub unlock_user
{
my ($user) = @_;
my $rc = 1;
my $unlinkrc;
my $lockfile = $config{spool}."/".$user.$config{lockext};

$unlinkrc = unlink($lockfile);

if ( $unlinkrc == 1 ) {
	$rc = 1;
} else {
	syslog(LOG_WARNING, "%s: could not remove lockfile %s (%s)", $peer, $lockfile, $unlinkrc);
	$rc = 0;
}

return $rc;
}

#########################################################
#########################################################
# -> $user, "atrn <domains>", $dbh
sub atrn
{
my $user = $_[0];
my @domains = split /[ ,]/, $_[1];
shift @domains;
my $dbh = $_[2];

my @domnot = ();
my ($unlinked, $s, $msg, $domain);

if ( $#domains == -1 ) {
	@domains = @{ $dbh->selectcol_arrayref($config{sql_domainlist}, undef, $user) };
	if ( $#domains == -1 ) {
		if ($dbh->err) { syslog(LOG_ERR, "db error %s: %s", $dbh->err, $dbh->errstr); }
		else { syslog LOG_NOTICE, "%s\@%s: no domains in db", $user, $peer; }
	} else { syslog(LOG_INFO, "%s\@%s: domains: %s", $user, $peer, join(' ', @domains)) if $config{debug}; }
}
else {
	syslog(LOG_INFO, "%s\@%s: ATRN %s", $user, $peer, join(',', @domains));
	foreach (@domains) {
		if ($_ =~ /^([-\w\.]+)$/) {
			$_ = $1;             # $data now untainted
		} else {
			syslog (LOG_NOTICE, "%s@%s: skipping domain %s, contains bad characters", $user, $peer, $_);
			push(@domnot, $_);
			undef $_;
			next;
		}
		if ( $dbh->selectrow_array($config{sql_checkdomain}, undef, $user, $_) == 0 )
			{ push(@domnot, $_); }
	}
}

my $no_mail_waiting = 1;

if ( @domnot ) {
	syslog(LOG_NOTICE, "%s\@%s: not authorized for domain(s) %s", 
		$user, $peer, join(',', @domnot));
	myprint ("450 ATRN request refused. Not authorized for " . join(', ', @domnot));
	return;
} else {
	foreach my $dom (@domains) {
		next unless $dom;   # domains we undeffed because of bad characters
		my $dir = $config{spool}."/".$dom."/";
		opendir(DIR, $dir) || next;
		my @msgs = readdir(DIR);
		foreach $msg (@msgs) {
			syslog(LOG_DEBUG, "considering '%s'", $msg) if $config{debug};
			next if $msg =~ /^temp\./; # skip temporary files
			next if $msg =~ /^bad\./;  # skip bad files
			next unless -f $dir.$msg; # use only plain files

			if ($msg =~ /^([-\w\.]+)$/) {
				$msg = $1;
			} else {
				syslog (LOG_WARNING, "Unexpected characters in file name '%s'. File skipped", $msg);
				next;
			}

			$mails_waiting++;			# count messages

			if ($no_mail_waiting) {		# start ATRN
				$no_mail_waiting = 0;
				# smtp dialogue initialisation
				myprint("250 ok, turnaround now");
				while ( ($s = myget()) =~ /^\d{3}-/) { }	# multiline response
				if (!($s =~ /^220(\s+.*)?$/)) {
					syslog(LOG_NOTICE, "%s\@%s: rcvd '%s' (on turnaround)", $user, $peer, $s);
					quit_smtp();
				}

				# first try esmtp
				myprint("EHLO $config{hostname}");
				do {	# parse the multiline response for capabilities
					if ( ($s = myget()) =~ /^250(\s+|\-)SIZE/i ) { $capa{"size"} = 1; }
					#elsif ( $s =~ /^250(\s+|\-)PIPELINING/i ) { $capa{"pipelining"} = 1; } # maybe in a future release
				} until ( $s !~ /^250-/ );

				# no EHLO, so RSET and try HELO
				if ( $s !~ /^250(\s+.*)?$/ ) {
					myprint("RSET");
					# ignore response and try HELO
					while ( ($s = myget()) =~ /^\d{3}-/) { }	# multiline response
					myprint("HELO $config{hostname}");
					while ( ($s = myget()) =~ /^\d{3}-/) { }	# multiline response
					if ($s !~ /^250(\s+.*)?$/) {
						syslog(LOG_NOTICE, "%s\@%s: EHLO and HELO rejected (%s)", $user, $peer, $s);
						quit_smtp();
					}
				}
			}

			# send mail
			my $send_smtp_rc = send_smtp($dir, $msg, $dom);

			if ($send_smtp_rc == 0) {
				# message send ok -> delete message
				$mails_sent++;
				$unlinked = unlink($dir.$msg);
				syslog(LOG_WARNING, "%s\@%s: unlink %s%s = %s: %s",
						$user, $peer, $dir, $msg, $unlinked, $!)
					unless $unlinked == 1;

			} elsif ($send_smtp_rc == 1) {
				# temporary error, retry next time -> do nothing

			} elsif ($send_smtp_rc == 2) {
				# bad message or protocol error -> rename message
				my $renamed = rename($dir.$msg, $dir."bad.".$msg);
				syslog(LOG_WARNING, "%s\@%s: rename %s%s failed: %s", 
						$user, $peer, $dir, $msg, $!)
					unless $renamed;

			} else {
				# bad return code from smtp_send
				syslog(LOG_WARNING, "%s\@%s: bad send_smtp return code %s for %s%s",
					$user, $peer, $send_smtp_rc, $dir, $msg);
			}

			# "RSET"
			myprint("RSET");
			while ( ($s = myget()) =~ /^\d{3}-/) { }	# multiline response
			if (!($s =~ /^250(\s+.*)?$/)) {
				syslog(LOG_NOTICE, "%s\@%s: rcvd '%s' (on RSET)", $user, $peer, $s);
				quit_smtp();
			}
		}
		closedir(DIR);
	}
}

# no mail waiting, so return
if ($no_mail_waiting) {
	myprint("453 no mail waiting");
	syslog(LOG_DEBUG,"%s\@%s: no mail waiting", $user, $peer);
	return;
}

quit_smtp();
}

#########################################################
#########################################################
# -> $dir.$msg
# <- $rc ( 0: ok; 1: temp error; 2: error in msg / protocol error )
sub send_smtp
{
my ($dir, $msg, $dom) = @_;
my $file = $dir.$msg;

my ($s, $t, $m, $i);
my $rc = 0; # return code
my $recipients = 0;
my $valid_recipients = 0;
my %temp_rejected_recipients = ();
my %perm_rejected_recipients = ();
my @logbuf;
my $state = "mail";
my $sender = "";
my $err_msg = "";
my @all_rcpts = ();
my ($msg_size, $arr_date) = (stat($file))[7,9];

if (! defined($arr_date)) {
	syslog(LOG_WARNING, "%s/%s: stat = %s", $dom, $msg, $!);
	return 2;
}

my $msg_age = int((time() - $arr_date)/86400);
# my $msg_age = time() - $arr_date; # for debugging - allow me a short maximum age specified in seconds.
my %dsn_per_msg = (); #local %dsn_per_msg;
my %dsn_per_rcpt = (); #local %dsn_per_rcpt;

syslog(LOG_INFO, "%s\@%s: Msg_age=%s, max=%s", $user, $peer, $msg_age, $config{max_msg_age}) if $config{debug};

if (! open(MSG, $file)) {
	syslog(LOG_WARNING, "%s/%s: open:  %s", $dom, $msg, $!);
	return 2;
}

## send envelope ##########################################

# MAIL FROM #####################################
$m = <MSG>;
#if ( $m =~ /^MAIL FROM:(.*)$/i ) {
if ( $m =~ /^MAIL FROM:\s*<?([^>\s]*)>?/i ) { # extract sender
	$sender = $1;
	my $logsender = $sender;
	$logsender = "<>" unless $logsender;

	my $mailfrom = "MAIL FROM:<$sender>". ($capa{size}? " SIZE=$msg_size" : "");
	myprint($mailfrom);

	my ($resp, @resp);
	while ( ($resp = myget()) =~ /^\d{3}-/) { push @resp, $resp; }	# save multiline response
	push @resp, $resp;

	# check response
	if ($resp =~ /^250(\s+.*)?$/) {			# ok
		syslog(LOG_INFO, "%s/%s <= %s S=%s", $dom, $msg, $logsender, $msg_size);
		$state = "rcpt";

	} elsif ($resp =~ /^[45]\d\d(\s+.*)?$/) {	# error
		syslog(LOG_INFO, "%s/%s <* %s S=%s : %s", $dom, $msg, $logsender, $msg_size, join("\n", @resp));

		my $temperr = ($resp =~ /^4/) ? 1 : 0;

		if (! $temperr or ($config{max_msg_age} and $msg_age >= $config{max_msg_age})) {

			$err_msg = "A message that you sent could not be delivered";
			$err_msg .= " for $msg_age days" if $temperr;
			$err_msg .= ".\n\nDelivery failed to the following recipients:\n\n";

			while (my $ms = <MSG>) {
				last if ( $ms =~ /^DATA/i);	# last recipient?
				$ms =~ s/[\r\n]//g;
				if ( $ms =~ /^RCPT TO:\s*<(.*)>$/i ) {
					$err_msg .= "- $1\n";
					$dsn_per_rcpt{$1}{'action'} = 'failed';
					$dsn_per_rcpt{$1}{'status'} = $temperr ?
						'4.4.7 (Persistent transient failure: Delivery time expired)' :
						get_status($resp);
					$dsn_per_rcpt{$1}{'diagnostic'} = $resp;
				}
			}
		} else { # temporary error, retry next time
			$rc = 1; 
		}

	} else { # everything else is a protocol error
		syslog(LOG_NOTICE, "%s\@%s: protocol error - rcvd '%s' on %s",
			$user, $peer, substr(join("\n", @resp), 0, 512),
			substr($mailfrom, 0, 256));
		$rc = 2;
	}

} else {
	# no MAIL FROM in BSMTP file
	$rc = 2;
	$m =~ s/[\r\n]//g;
	syslog(LOG_WARNING, "BSMTP error in %s: '%s' should start 'MAIL FROM:'", $file, $m);
}

# RCPT TO #######################################
if ($state eq "rcpt") {
	while ($m = <MSG>) {
		$m =~ s/[\r\n]//g;
		last if ( $m =~ /^DATA$/i);			# last recipient?
		if ( $m =~ /^RCPT TO:\s*<?([^>\s]*)>?/i ) {	# match recipient
			$recipients++;
			my $rcpt = $1;	# untainted
			push @all_rcpts, $rcpt;

			myprint("RCPT TO:<$rcpt>");

			my ($resp, @resp);
			while ( ($resp = myget()) =~ /^\d{3}-/) { push @resp, $resp; }	# save multiline response
			push @resp, $resp;

			if ($resp) {

				if ($resp =~ /^25[01](\s+.*)?$/) {
					$valid_recipients++;

				} elsif ( $resp =~ /^4\d\d(\s+.*)?$/ ) {
					syslog(LOG_INFO, "%s/%s == %s : %s ",
						$dom, $msg, $rcpt, substr(join("\n", @resp), 0, 512) );
					$temp_rejected_recipients{$rcpt} = substr(join("\n", @resp), 0, 512);

				} elsif ( $resp =~ /^5\d\d(\s+.*)?$/ ) {
					syslog(LOG_INFO, "%s/%s ** %s : %s ", 
						$dom, $msg, $rcpt, substr(join("\n", @resp), 0, 512) );
					$perm_rejected_recipients{$rcpt} = substr(join("\n", @resp), 0, 512);
				} else { # everything else is a protocol error
					syslog(LOG_NOTICE, "%s\@%s: protocol error - rcvd '%s' RCPT TO:<%s>",
						$user, $peer, substr(join("\n", @resp), 0, 512),
						substr($rcpt, 0, 256));
					$rc = 2;
				}
			}
		} else {	# no RCPT TO
			$rc = 2;
			$m =~ s/[\r\n]//g;
			syslog(LOG_WARNING, "BSMTP error in %s: '%s' should start 'RCPT TO:'", $file, $m);
		}
	}
	$state = "data" if $valid_recipients and $rc == 0;
}

# DATA ##########################################
if ($state eq "data") {
	myprint("DATA");
	my ($resp, @resp);
	while ( ($resp = myget()) =~ /^\d{3}-/) { push @resp, $resp; }  # save multiline response
	push @resp, $resp;

	if ( $resp =~ /^354(\s+.*)?$/ ) {
		$state = "msg";

        } elsif ( $resp =~ /^[45]\d\d(\s+.*)?$/ ) {

		my $temperr = ($resp =~ /^4/) ? 1 : 0;

		if (! $temperr or ($config{max_msg_age} and $msg_age >= $config{max_msg_age})) {
			
			# they don't matter any more
			%perm_rejected_recipients = ();
			%temp_rejected_recipients = ();

			$err_msg = "A message that you sent could not be delivered";
			$err_msg .= " for $msg_age days" if $temperr;
			$err_msg .= ".\nThis is a permanent error.\n".
				"The remote server rejected the message.\n".
				"Delivery failed to the following recipients:\n\n";

			foreach my $r (@all_rcpts) {
				$err_msg .= "- $r\n";
				$dsn_per_rcpt{$r}{'action'} = 'failed';
				$dsn_per_rcpt{$r}{'status'} = $temperr ?
					'4.4.7 (Persistent transient failure: Delivery time expired)' :
					get_status($resp);
				$dsn_per_rcpt{$r}{'diagnostic'} = substr(join("\n", @resp), 0, 512);
			}

			$err_msg .= "\n\nCommunication excerpt:\n\n".
				"-> DATA\n".
				"<- ".substr(join("\n   ", @resp), 0, 512)."\n";

		} else {
			# temporary error, but max_msg_age not reached, so retry next time
			$rc = 1;
		}

	} else { # everything else is a protocol error

		syslog(LOG_NOTICE, "%s\@%s: protocol error - rcvd '%s' on DATA",
			$user, $peer, substr(join("\n", @resp), 0, 512));
		$rc = 2;
	}
}


# send message itself ###########################
if ($state eq "msg") {
	alarm $config{timeout_msg};

	# send message
	if ($config{use_sendfile}) { # with sendfile
		# no checks are done, so the message file must be ok!
		my $filepos = tell(MSG); # will be changed by sendfile
		my $sent = sendfile(fileno($fh_out), fileno(MSG), $filepos, $msg_size);
		if ( $sent == -1) {
			syslog(LOG_WARNING, "%s/%s: sendfile error (%s)", $dom, $msg, $!);
			return 1;
		}
		$b_out += $sent;

	} else { # fallback: the way it always works
		$fh_out->autoflush(0); # buffer output for less overhead
		# we don't use myprint here to speed up things a little
		while ( <MSG> ) {
			if (substr($_,-2,2) ne "\r\n") {
				s/[\r\n]$//og;
				print $fh_out $_, "\r\n";
			} else {
				print $fh_out $_;
			}
			$b_out += length($_);
		}
		$fh_out->autoflush(1); # back to unbuffered
	}

	# check if message was accepted
	my ($resp, @resp);
	while ( ($resp = myget()) =~ /^\d{3}-/) { push @resp, $resp; }  # save multiline response
	push @resp, $resp;
    
	if ($resp =~ /^250(\s+.*)?$/) {
		foreach (@all_rcpts) {
			syslog(LOG_INFO, "%s/%s => %s : %s ", 
					$dom, $msg, $_, substr(join("\n", @resp), 0, 512))
				unless ($temp_rejected_recipients{$_} 
					or $perm_rejected_recipients{$_});
		}

        } elsif ( $resp =~ /^[45]\d\d(\s+.*)?$/ ) {

		my $temperr = ($resp =~ /^4/) ? 1 : 0;

		if (! $temperr or ($config{max_msg_age} and $msg_age >= $config{max_msg_age})) {
			
			# they don't matter any more
			%perm_rejected_recipients = ();
			%temp_rejected_recipients = ();

			$err_msg = "A message that you sent could not be delivered";
			$err_msg .= " for $msg_age days" if $temperr;
			$err_msg .= ".\n\nDelivery failed to the following recipients:\n\n";

			foreach my $r (@all_rcpts) {
				$err_msg .= "- $r\n";
				$dsn_per_rcpt{$r}{'action'} = 'failed';
				$dsn_per_rcpt{$r}{'status'} = $temperr ?
					'4.4.7 (Persistent transient failure: Delivery time expired)' :
					get_status($resp);
				$dsn_per_rcpt{$r}{'diagnostic'} = substr(join("\n", @resp), 0, 512);
			}

			$err_msg .= "\n\nCommunication excerpt:\n\n".
				"-> .\n".
				"<- ".substr(join("\n   ", @resp), 0, 512)."\n";

		} else {
			# temporary error, but max_msg_age not reached, so retry next time
			$rc = 1;
		}

	} else { # everything else is a protocol error

		syslog(LOG_NOTICE, "%s\@%s: protocol error - rcvd '%s' on terminating dot",
			$user, $peer, substr(join("\n", @resp), 0, 512));
		$rc = 2;
	}
}

# now check if bouncing or rewriting is necessary #########

# rejected recipients ###########################
if ( $rc == 0 && (%perm_rejected_recipients || %temp_rejected_recipients) ) {
	if ( $valid_recipients || %perm_rejected_recipients ) {
		# write new message for tempory rejected recipients
		if ( %temp_rejected_recipients and (! $config{max_msg_age} or $msg_age < $config{max_msg_age}) ) {
			# skip envelope
			seek(MSG, 0, 0);
			$m = "";
			while ( $m ne "DATA" ) {
				$m = <MSG>;
				$m =~ s/[\r\n]//g;
			}

			# put message into a new file
			my $newfile = $msg;
			$newfile =~ s/\..*//;
			$newfile = $dir.$newfile;
			$newfile .= ".".time().".$$";
			if (! open(NEWMSG, ">$newfile") ) {
				syslog(LOG_ERR, "error writing %s (%s)", $newfile, $!);
				$rc = 1;
			}
			else {
				syslog(LOG_INFO, "writing %s for temporarily rejected recipients %s", $newfile,
					join(", ", keys %temp_rejected_recipients) ) if $config{debug};

				print NEWMSG "MAIL FROM:<$sender>\r\n";
				foreach (keys %temp_rejected_recipients)
					{ print NEWMSG "RCPT TO:<$_>\r\n"; }
				print NEWMSG "DATA\r\n";
				while (<MSG>) { print NEWMSG $_; }
				close(NEWMSG);
				# change the modification time back to its original value
				syslog(LOG_INFO, "Changing file modification date of $newfile to original arrival time") if $config{debug};
				if ($arr_date =~ /^([\d]+)$/) {$arr_date = $1;} #untaint $arr_date
				if ( (my $modchange = utime($arr_date, $arr_date, $newfile)) != 1) {
					syslog(LOG_WARNING, "error changing modification date of %s (%s): %s", $newfile, $modchange, $!);
				}
			}
		}
	} else {
		syslog(LOG_INFO, "%s/%s: all %s recipients were temporarily rejected", $recipients) if $config{debug};
		$rc = 1 if (! ($config{max_msg_age} and $msg_age < $config{max_msg_age}) );
	}

	# bounce for permanent rejected recipients or delivery timeout
	if (%perm_rejected_recipients or (
			%temp_rejected_recipients and
			$config{max_msg_age} and
			$msg_age >= $config{max_msg_age}
		))
	{
		$err_msg = "A message that you sent could not be delivered to one or more of its\n";
		$err_msg .= "recipients.\n\n";
		if ( %perm_rejected_recipients ) {
			foreach $s (keys %perm_rejected_recipients) {
				$err_msg .= "The following addresses had permanent failures:\n\n";
				$err_msg .= "- ".$s."\n  ".$perm_rejected_recipients{$s}."\n\n";
				$dsn_per_rcpt{$s}{'diagnostic'} = $perm_rejected_recipients{$s};
				$dsn_per_rcpt{$s}{'action'} = "failed";
				$dsn_per_rcpt{$s}{'status'} = get_status($perm_rejected_recipients{$s});
			}
		}
		if ( %temp_rejected_recipients and $config{max_msg_age} and $msg_age >= $config{max_msg_age} ) {
			$err_msg .= "The following addresses had transient failures and could not delivered\n";
			$err_msg .=  "after $msg_age days of trying. Delivery has been abandoned:\n\n";
			foreach $s (keys %temp_rejected_recipients) {
				$err_msg .= "- ".$s."\n  ".$temp_rejected_recipients{$s}."\n\n";
				$dsn_per_rcpt{$s}{'diagnostic'} = $temp_rejected_recipients{$s};
				$dsn_per_rcpt{$s}{'action'} = "failed";
				$dsn_per_rcpt{$s}{'status'} = "4.4.7 (Persistent transient failure: Delivery time expired)";
			}
		}
	}
}

# bounce message if we have bounce data ###################
if ($err_msg) {
	$dsn_per_msg{'arr_date'} = rfc822_date($arr_date);
	if (bounce_msg($sender, $err_msg, \%dsn_per_msg, \%dsn_per_rcpt)) {
		syslog(LOG_INFO, "%s/%s => %s : bounce", $dom, $msg, $sender);
	} else {
		$rc = 1;
	}
}

close(MSG);
return $rc;
}

#########################################################
#########################################################
# -> $sender, $err_msg
# <- $rc ( 0: failed; 1: ok )
sub bounce_msg
{
my $sender = shift;
my $err_msg  = shift;
my %dsn_per_msg = %{shift()};
my %dsn_per_rcpt = %{shift()};
my $m;
my $mimesep = "----=_odmrd_NextPart_".rand(65536)."_".$$."_".time."_".$config{hostname};

#syslog(LOG_INFO, "%s/%s => %s : bounce", $sender);

# skip message envelope
seek(MSG, 0, 0);
while (<MSG>) {
	last unless /^DATA/i;
}

if (! open(BOUNCE, "|$config{sendmail} -f '<>' '$sender'")) {
	warn "bounce_msg: pipe to sendmail ($!)\n";
	return 0;
}
# bounce headers
print BOUNCE "From: Mail Delivery System <Mailer-Daemon>\n";
print BOUNCE "To: $sender\n";
print BOUNCE "Subject: Mail delivery failed: returning message to sender\n";
print BOUNCE "MIME-Version: 1.0\n";
print BOUNCE "Content-type: multipart/report; report-type=delivery-status;\n\tboundary=\"$mimesep\"\n\n";
print BOUNCE "This is a MIME encoded Delivery Status Notification, more or less according to RFC 1894\n";

# bounce 'human readable'
print BOUNCE "--$mimesep\n";
print BOUNCE "Content-type: text/plain\n\n";
print BOUNCE $err_msg."\n";
print BOUNCE "The headers of your original message are attached\n";

# bounce delivery report
print BOUNCE "--$mimesep\n";
# per message
print BOUNCE "Content-Type: message/delivery-status\n\n";
print BOUNCE "Reporting-MTA: dns; $config{hostname}\n";
print BOUNCE "Arrival-Date: " . $dsn_per_msg{arr_date} . "\n\n";
# per recipient
foreach my $s (keys %dsn_per_rcpt) {
	print BOUNCE "Final-Recipient: rfc822; $s\n";
	print BOUNCE "Remote-MTA: dns; $peerhost\n";
	if (length($dsn_per_rcpt{$s}{'action'}) >0) {print BOUNCE "Action: " . $dsn_per_rcpt{$s}{'action'} . "\n";}
	if (length($dsn_per_rcpt{$s}{'status'}) >0) {print BOUNCE "Status: " . $dsn_per_rcpt{$s}{'status'} . "\n";}
	if (length($dsn_per_rcpt{$s}{'diagnostic'}) >0) {print BOUNCE "Diagnostic-Code: smtp; " . $dsn_per_rcpt{$s}{'diagnostic'} . "\n";}
	print BOUNCE "Last-Attempt-Date: " . rfc822_date(time()) . "\n";
	print BOUNCE "\n";
}

# bounce returned headers
print BOUNCE "--$mimesep\n";
print BOUNCE "Content-Type: text/rfc822-headers\n\n";

# headers (but not more than 1000 lines)
while( (($m = <MSG>) =~ s/[\r\n]//g) and $m and $. < 1000 )
	{ print BOUNCE $m."\n"; }

print BOUNCE "--$mimesep--\n";

close(BOUNCE);

return 1;
}

#########################################################
#########################################################
sub quit_rcvd
{
myprint("221 have a nice day");
my @times = times;
syslog(LOG_NOTICE, "%s: QUIT without authenticating", $peer) unless $user;
&end_prog;
}

###
sub quit_smtp
{
myprint("QUIT");
my ($resp, @resp);
while ( ($resp = myget()) =~ /^\d{3}-/) { push @resp, $resp; }  # save multiline response
push @resp, $resp;

my @times = times;
if ($resp !~ /^221(\s+.*)?$/) { myprint("421 Closing connection - sorry, could not quit cleanly"); }
syslog(LOG_INFO, "%s\@%s: sent QUIT, %i/%i mails sent, %i/%i bytes sent/rcvd, %is user, %is system",
	$user, $peer, $mails_sent, $mails_waiting, $b_out, $b_in, $times[0], $times[1]);
&end_prog;
}

###
sub end_prog
{
if ($user) {
	if ( $config{acct_mysql} and mysql_acct($user, $b_in, $b_out) )
		{ syslog(LOG_WARNING, "could not account to database: user '%s', ".
			"sent $b_out, rcvd $b_in", $user); }
	unlock_user($user);
}
syslog (LOG_NOTICE, "Terminating (end_prog)") if $config{debug};
closelog();

$dbh->disconnect if $dbh;

close $fh_in if $fh_in;
close $fh_out if $fh_out;
exit;
}

###
sub myprint
{
my $out = shift @_;

die "myprint: output handle undefined for '" . ($out ? $out : '<undefined>') . "'\n"
	unless $fh_out;

if (! $out) {
	warn "myprint: undefined output";
	return;
}

print $fh_out $out, "\015\012";
$b_out += length($out);

syslog (LOG_DEBUG, "-> %s", $out) if $config{debug};
}

###
sub myget
{
alarm $config{timeout_cmd};
my $s = <$fh_in>;
alarm 0;
if ($s) {
	$b_in += length($s);
	$s =~ s/[\r\n]//og;
} else {
	$s = "";
}
syslog(LOG_DEBUG, "<- %.120s", $s) if $config{debug};
return $s;
}

#########################################################
#########################################################
sub mysql_acct
{
my ( $user, $b_in, $b_out ) = @_;

my ( undef, undef, undef, $mday, $mon, $year, undef ) = localtime(time);
$mon++;
$year += 1900;
my $date = sprintf "%.4i%.2i%.2i", $year, $mon, $mday;

my ($rows) = $dbh->selectrow_array("SELECT count(*) FROM $config{sql_acct_table} WHERE user=? AND date=?",
	undef, $user, $date);
if ($dbh->err) {
	syslog(LOG_WARNING, "DB SELECT error %s: %s", $dbh->err, $dbh->errstr);
	return 1;
}

if ($rows == 0) { 		# no data for today yet
	$dbh->do("INSERT INTO $config{sql_acct_table} (user, date, b_in, b_out) VALUES (?,?,?,?)",
		undef, $user, $date, $b_in, $b_out);
	if ($dbh->err) {
		syslog(LOG_WARNING, "DB INSERT error %s: %s", $dbh->err, $dbh->errstr);
		return 1;
	}
}
elsif ($rows == 1) {	# update accounting data for today
	$dbh->do("UPDATE $config{sql_acct_table} SET b_in=b_in+?, b_out=b_out+? WHERE user=? AND date=?",
		undef, $b_in, $b_out, $user, $date);
	if ($dbh->err) {
		syslog(LOG_WARNING, "DB UPDATE error %s: %s", $dbh->err, $dbh->errstr);
		return 1;
	}
} else {				# more than one data for today??
	syslog(LOG_WARNING, "Warning! $rows entries of '%s' for '%s'!", $user, $date);
	 return 1;
}

return 0;
}

#########################################################
#########################################################
sub rfc822_date {
# --------------------------------------------------------
# Returns the date in the format "ddddddd, dd mmm yyyy hh:mm:ss +ZZZZ".

my $thisdate = $_[0];
my ($sec, $min, $hour, $day, $mon, $year, $dweek, $dyear, $daylight) = gmtime($thisdate);
my (@months) = qw!Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec!;
my (@days) = qw!Sun Mon Tue Wed Thu Fri Sat!;
($day < 10) and ($day = "0$day");
($sec < 10) and ($sec = "0$sec");
($min < 10) and ($min = "0$min");
($hour < 10) and ($hour = "0$hour");
$year = $year + 1900;

return "$days[$dweek], $day $months[$mon] $year $hour:$min:$sec -0000";
}

#########################################################
#########################################################
sub get_status {
my $status = '5.0.0';
my $in_code = $_[0];
my %rfc821_1893_map = (
    "421" => "4.3.2",
    "450" => "4.2.1",
    "451" => "4.5.0",
    "452" => "4.2.2",
    "454" => "4.7.0",
    "455" => "4.5.0",
    "500" => "5.5.2",
    "501" => "5.5.4",
    "502" => "5.5.1",
    "503" => "5.5.0",
    "504" => "5.5.4",
    "530" => "5.7.0",
    "534" => "5.7.0",
    "535" => "5.7.1",
    "538" => "5.7.0",
    "550" => "5.1.0",
    "551" => "5.1.6",
    "552" => "5.2.2",
    "553" => "5.1.3",
    "554" => "5.5.0",
    "555" => "5.5.4"
);


my %status_type = (
    "2" => "Success",
    "4" => "Persistent transient failure",
    "5" => "Permanent failure"
);

my %status_desc = (
    "0.0" => "Undefined",
    "1.0" => "Undefined addressing status",
    "1.1" => "Bad destination mailbox address",
    "1.2" => "Bad destination system address",
    "1.3" => "Bad destination mailbox address syntax",
    "1.4" => "Destination mailbox address ambiguous",
    "1.5" => "Destination mailbox address valid",
    "1.6" => "Mailbox has moved",
    "1.7" => "Bad sender's mailbox address syntax",
    "1.8" => "Bad sender's system address",
    "2.0" => "Undefined mailbox status",
    "2.1" => "Mailbox disabled, not accepting messages",
    "2.2" => "Mailbox full",
    "2.3" => "Message length exceeds administrative limit.",
    "2.4" => "Mailing list expansion problem",
    "3.0" => "Other or undefined mail system status",
    "3.1" => "Mail system full",
    "3.2" => "System not accepting network messages",
    "3.3" => "System not capable of selected features",
    "3.4" => "Message too big for system",
    "4.0" => "Undefined network or routing status",
    "4.1" => "No answer from host",
    "4.2" => "Bad connection",
    "4.3" => "Routing server failure",
    "4.4" => "Unable to route",
    "4.5" => "Network congestion",
    "4.6" => "Routing loop detected",
    "4.7" => "Delivery time expired",
    "5.0" => "Undefined protocol status",
    "5.1" => "Invalid command",
    "5.2" => "Syntax error",
    "5.3" => "Too many recipients",
    "5.4" => "Invalid command arguments",
    "5.5" => "Wrong protocol version",
    "6.0" => "Undefined content or media error",
    "6.1" => "Media not supported",
    "6.2" => "Conversion required and prohibited",
    "6.3" => "Conversion required but not supported",
    "6.4" => "Conversion with loss performed",
    "6.5" => "Conversion failed",
    "7.0" => "Undefined security status",
    "7.1" => "Delivery not authorized, message refused",
    "7.2" => "Mailing list expansion prohibited",
    "7.3" => "Security conversion required but not possible",
    "7.4" => "Security features not supported",
    "7.5" => "Cryptographic failure",
    "7.6" => "Cryptographic algorithm not supported",
    "7.7" => "Message integrity failure"
);

if ($in_code =~ /^\d\d\d\s*(\d\.\d\.\d)\s.*/) {
	$status = $1;
} elsif ($in_code =~ /^(\d\d\d)/) {
if ($rfc821_1893_map{$1}) {
	$status = $rfc821_1893_map{$1};
} elsif ($in_code =~ /^4/) {
	$status = '4.4.7';
}
}

my ($a, $b) = split (/\./, $status, 2);
my $comment = " (";
$comment .= $status_type{$a} if $status_type{$a};
$comment .= ": " . $status_desc{$b} if $status_desc{$b};
$comment .= ")";

return $status . $comment;
}

##########################################################################
##########################################################################
# apply config defaults
sub config_defaults {

$config{spool} = "/var/spool/odmr";
$config{hostname} = "";         # emtpy means we resolve interface name

$config{timeout_dns} = 15;
$config{timeout_cmd} = 120;     # 2min
$config{timeout_msg} = 1800;    # 30min
$config{max_invalid_cmds} = 3;
$config{max_invalid_auth} = 3;
$config{max_msg_age} = 0;       # in days
$config{allow_login} = 0;       # allow users to use AUTH LOGIN?

$config{lockext} = "..LCK";

# mysql db connection
$config{mysql_host} = "";       # defaults to the local socket
$config{mysql_port} = "";
$config{mysql_socket} = "";
$config{mysql_user} = "odmr";
$config{mysql_pass} = "xxxxxxxx";
$config{mysql_db}   = "odmr";
$config{acct_mysql} = 1;        # activate accounting to db

$config{debug} = 0;		# include additional debug messages in log?
				# may also be set with -d command line option

$config{use_sendfile} = 0;	# use Linux' sendfile for message sending

$config{pidfile} = "/var/run/odmrd/odmrd.pid";

$config{standalone} = 0;
$config{daemon} = 0;
$config{user} = "odmr";
$config{group} = "";

# path to sendmail
$config{sendmail} = "/usr/sbin/sendmail";

# sql statement to select user's password.
# bind_value format with ? as user
$config{sql_pass} = "SELECT pass FROM user WHERE user=?";

# sql statement to select list of domains for user.
# bind_value format with ? as user
$config{sql_domainlist} = "SELECT domain FROM domain WHERE user=?";

# sql statement to check given domain is OK for user.
# bind_value format with ?, ? for user, domain
$config{sql_checkdomain} = "SELECT count(*) FROM domain WHERE user=? AND domain=? LIMIT 1";

$config{sql_acct_table} = "acct";

# Configuration file. Can be over-ridden with command line option -c /path/to/conf.file
$config{conf_file} = "/etc/odmrd.conf";

} # end of sub

##########################################################################
##########################################################################
# read and evaluate configuration file
sub config_read {

if ($config{conf_file} !~ /^([-\/\w\.]+)$/) {
	myprint("421 Temporary error. Closing connection.");
	syslog (LOG_WARNING, "Unwanted characters found in value of conf_file: %s",
		$config{conf_file});
	&end_prog;
}

$config{conf_file} = $1;             # $data now untainted

my @confkeys = qw{
	spool hostname timeout_cmd timeout_msg max_invalid_cmds max_msg_age
	allow_login lockext mysql_host mysql_port mysql_socket mysql_user mysql_pass 
        mysql_db acct_mysql mysql
	debug use_sendfile standalone daemon user group sendmail conf_file
	sql_pass sql_domainlist sql_checkdomain sql_acct_table
	server_ip server_port timeout_dns};
my @confkeys_binary = qw{
	allow_login acct_mysql use_sendfile standalone daemon};
my %confkeys;
foreach (@confkeys) { $confkeys{$_} = 1; }
my %confkeys_binary;
foreach (@confkeys_binary) { $confkeys{$_} = 1; }

# read config file into hash
open(CONFIG, $config{conf_file})
	or die "could not open config file $config{conf_file} ($!)\n";

while (<CONFIG>) {
	#s/[\r\n]//og;
	next if /^#/ or /^$/ or /^;/ or /^\$/;
	/(\S+)\s+(\S+).*/o;
	next unless defined($2);
	my $key = lc($1);
	my $val = lc($2);
	syslog(LOG_DEBUG, "config file: %s = %s", $key, $val) if $config{debug} > 1;

	if (! $confkeys{$key}) {
		syslog(LOG_WARNING, "unknown config key %s", $key);
		
	} elsif ($key eq "server_ip" or $key eq "server_port") {
		# todo: check for valid ip 
		push @{$config{$key}}, $2;

	} else {
		# todo (sometime): check for duplicates

		if ($confkeys_binary{$key}) {
			if ($val eq "0" or $val eq "off" or $val eq "disabled"
                            or $val eq "false" or $val eq "no") {
				$config{$key} = 0;
			} elsif ($val eq "1" or $val eq "on" or $val eq "enabled"
			       or $val eq "true" or $val eq "yes") {
				$config{$key} = 1;
			} else {
				syslog(LOG_WARNING, "unknown value '%s' for config key '%s', using default", $val, $2);
			}
		} else {
			$config{$key} = $2;
		}
	}

} # while

close(CONFIG);

# special handling of multi-value options
$config{server_ip} = [qw{0.0.0.0}] unless $config{server_ip};
$config{server_port} = [qw{366}] unless $config{server_port};

# determine how we should connect to the database server
if ($config{mysql}) { 
	# use default (local socket)
} elsif ($config{mysql_socket}) {
	$config{mysql} = "mysql_socket=" . $config{mysql_socket};
} elsif ($config{mysql_host}) {
	$config{mysql} = "host=" . $config{mysql_host};
	$config{mysql} .= ";port=" . $config{mysql_port}
		if $config{mysql_port};
} else {
	$config{mysql} = "";
}

# repeat this in case $conf_file overrode it
$config{debug} = 1 if $opts{'d'};

# print config options
if ($config{debug} > 1) {
	foreach (@confkeys) {
		syslog(LOG_DEBUG, "Configuration: %s='%s'" , $_,
			ref $config{$_} ?
				join(", ", @{$config{$_}}) :
				$config{$_}
		);
	}
}

} # end of sub

##########################################################################
##########################################################################
sub daemonize {

chdir '/';

my $pid = fork;
die "Couldn't fork: $!" unless defined($pid);
if ($pid) {
        syslog LOG_INFO, "new pid: %s", $pid if $config{debug};
        exit;
}

# create new process group
setsid() or die "Can't start a new session: $!";

open STDIN, '/dev/null';
open STDOUT, '/dev/null';
open STDERR, '/dev/null';

} # end of sub

##########################################################################
##########################################################################
sub my_gethostbyaddr {

my $addr = shift;
my $host;

syslog(LOG_INFO, "trying to resolve %s", inet_ntoa($addr))
	if $config{debug};

eval {
	local $SIG{ALRM} = sub { die "timeout\n"; };
	alarm $config{timeout_dns};
	$host = scalar gethostbyaddr($addr, AF_INET);
	alarm 0;
};

if ($@ eq "timeout\n") {
	syslog(LOG_INFO, "could not resolve %s", inet_ntoa($addr))
		if $config{debug};
}

if ($host) {
	return $host;
} else {
	return inet_ntoa($addr);
}

} # end of sub

##########################################################################
##################### end ################################################
##########################################################################
__END__
