File Coverage

blib/lib/Mail/SRS/Daemon.pm

Criterion	Covered	Total	%
statement	35	84	41.6
branch	5	34	14.7
condition	1	6	16.6
subroutine	9	11	81.8
pod	2	2	100.0
total	52	137	37.9

package Mail::SRS::Daemon;

use strict;
use warnings;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $SRSSOCKET);
use Exporter;
use IO::Socket;
use IO::Select;
use Getopt::Long;
use Mail::SRS qw(:all);

@ISA = qw(Exporter);

@EXPORT_OK = qw($SRSSOCKET);
%EXPORT_TAGS = (
		all	=> \@EXPORT_OK,
			);

$SRSSOCKET = '/tmp/srsd';

sub new {
	my $class = shift;
	my $args = ($#_ == 0) ? %{ (shift) } : { @_ };

	my @secrets = ref($args->{Secret}) eq 'ARRAY'
					? @{ $args->{Secret} }
					: [ $args->{Secret} ];

	if (exists $args->{SecretFile} && defined $args->{SecretFile}) {
		my $secretfile = $args->{SecretFile};
		die "Secret file $secretfile not readable"
						unless -r $secretfile;
		local *FH;
		open(FH, "<$secretfile")
						or die "Cannot open $secretfile: $!";
		while () {
			next unless /\S/;
			next if /^#/;
			push(@secrets, $_);
		}
		close(FH);
	}

	die "No secret or secretfile given. Use --secret or --secretfile, ".
					"and ensure the secret file is not empty."
						unless @secrets;

	# Preserve the pertinent original arguments, mostly for fun.
	my $self = {
		Secret		=> $args->{Secret},
		SecretFile	=> $args->{SecretFile},
			};
	$self->{Socket} = delete $args->{Socket} if exists $args->{Socket};

	# An alternative pattern would be to inherit this, rather than
	# delegate to it.
	$args->{Secret} = \@secrets;
	# All other args are passed on verbatim.
	my $srs = new Mail::SRS($args);

	$self->{Instance} = $srs;

	return bless $self, $class;
}

sub run {
	my ($self) = @_;
	my $srs = $self->{Instance};

	print STDERR "Starting SRS daemon in PID $$\n";

	# Until we decide that forward() and reverse() can die, this will
	# allow us to trap the error messages from those subroutines.
	local $SIG{__WARN__} = sub { die @_; };

	my $listen = $self->{Socket};
	unless ($listen) {
		unlink($SRSSOCKET) if -e $SRSSOCKET;
		$listen ||= new IO::Socket::UNIX(
						Type	=> SOCK_STREAM,
						Local	=> $SRSSOCKET,
						Listen	=> 1,
							);
		die "Unable to create listen socket: $!" unless $listen;
	}

	my $select = new IO::Select();
	$select->add($listen);

	while (my @socks = $select->can_read) {
		foreach my $sock (@socks) {
			if ($sock == $listen) {
				# print "Accept on $sock\n";
				$select->add($listen->accept());
			}
			else {
				my $line = <$sock>;
				if (defined($line)) {
					chomp($line);
					# print "Read '$line' on $sock\n";
					my @args = split(/\s+/, $line);
					my $cmd = uc shift @args;
					eval {
						if ($cmd eq 'FORWARD') {
							$sock->print($srs->forward(@args), "\n");
						}
						elsif ($cmd eq 'REVERSE') {
							$sock->print($srs->reverse(@args), "\n");
						}
						else {
							die "Invalid command $cmd";
						}
					};
					if ($@) {
						$sock->print("ERROR: $@");
						$select->remove($sock);
						$sock->close();
					}
				}

				# Exim requires that we unconditionally close the socket
				# print "Close on $sock\n";
				$select->remove($sock);
				$sock->flush();
				$sock->close();
				undef $sock;
			}
		}
		my @exc = $select->has_exception(0);
		foreach my $sock (@exc) {
			# print "Exception on $sock\n";
			$select->remove($sock);
			$sock->close();
		}
	}
}

__END__