view release on metacpan or  search on metacpan

lib/Sendmail/PMilter.pm  view on Meta::CPAN

sub register ($$$;$) {
	my $this = shift;
	$this->{name} = shift;

	carp 'register: no name supplied' unless defined($this->{name});
	carp 'register: passed ref as name argument' if ref($this->{name});

	my $callbacks = shift;
	my $pkg = caller;

	croak 'register: callbacks is undef' unless defined($callbacks);
	croak 'register: callbacks not hash ref' unless UNIVERSAL::isa($callbacks, 'HASH');

	# make internal copy, and convert to code references
	$callbacks = { %$callbacks };

	foreach my $cbname (keys %DEFAULT_CALLBACKS) {
	    my $cb = $callbacks->{$cbname};
	    if (defined($cb) && !UNIVERSAL::isa($cb, 'CODE')) {
		$cb = qualify_to_ref($cb, $pkg);
		if (exists(&$cb)) {
		    $callbacks->{$cbname} = \&$cb;
		} else {
		    delete $callbacks->{$cbname};
		}
	    }
	}

	$this->{callbacks} = $callbacks;
	$this->{callback_flags} = shift || 0;
	# MILTER PROTOCOL VERSION
	$this->{'milter protocol version'} = ($this->{callback_flags} & ~0x3F) ? 6 : 2;
	1;
}

=pod

=item setconn(DESC[, PERMS])

Sets up the server socket with connection descriptor DESC.  This is
identical to the descriptor syntax used by the "X" milter configuration
lines in sendmail.cf (if using Sendmail).  This should be one of the
following:

=over 2

=item local:PATH

A local ("UNIX") socket on the filesystem, named PATH.  This has some smarts
that will auto-delete the pathname if it seems that the milter is not
currently running (but this currently contains a race condition that may not
be fixable; at worst, there could be two milters running with one never
receiving connections).

=item inet:PORT[@HOST]

An IPv4 socket, bound to address HOST (default INADDR_ANY), on port PORT.  
It is not recommended to open milter engines to the world, so the @HOST part
should be specified.

=item inet6:PORT[@HOST]

An IPv6 socket, bound to address HOST (default INADDR_ANY), on port PORT.  
This requires IPv6 support and the Perl IO::Socket::IP package to be installed.
It is not recommended to open milter engines to the world, so the @HOST part
SHOULD be specified.

=item PERMS

Optional permissions mask.

=back

Returns a true value on success, undef on failure.

=cut

sub setconn ($$) {
	my $this = shift;
	my $conn = shift;
	my $perms = shift;
	my $backlog = $this->{backlog} || 5;
	my $socket;

	croak "setconn: $conn: unspecified protocol"
		unless ($conn =~ /^([^:]+):([^:@]+)(?:@([^:@]+|\[[0-9a-f:\.]+\]))?$/);

	if ($1 eq 'local' || $1 eq 'unix') {
		require IO::Socket::UNIX;

		my $path = $2;
		my $addr = sockaddr_un($path);
		my $oldumask = umask;

		croak "setconn: $conn: path not absolute"
			unless ($path =~ m,^/,,);

		if ($perms)
		{
		    umask 0777 - $perms;
		} 

		if (-e $path && ! -S $path) { # exists, not a socket
			$! = Errno::EEXIST;
		} else {
			$socket = IO::Socket::UNIX->new(Type => SOCK_STREAM);
		}

		# Some systems require you to unlink an orphaned inode.
		# There's a race condition here, but it's unfortunately
		# not easily fixable.  Using an END{} block doesn't
		# always work, and that's too wonky with fork() anyway.

		if (defined($socket) && !$socket->bind($addr)) {
			if ($socket->connect($addr)) {
				close $socket;
				undef $socket;
				$! = Errno::EADDRINUSE;
			} else {
				unlink $path; # race condition
				$socket->bind($addr) || undef $socket;
			}
		}

		umask $oldumask;
		
		if (defined($socket)) {
			$socket->listen($backlog) || croak "setconn: listen $conn: $!";
		}
	} elsif ($1 eq 'inet') {
		require IO::Socket::INET;

		$socket = IO::Socket::INET->new(
			Proto => 'tcp',
			ReuseAddr => 1,
			Listen => $backlog,
			LocalPort => $2,
			LocalAddr => $3
		);
	} elsif ($1 eq 'inet6') {
		require IO::Socket::IP;

		$socket = IO::Socket::IP->new(
			Proto => 'tcp',
			ReuseAddr => 1,
			Listen => $backlog,
			LocalService => $2,
			LocalHost => $3
		);
	} else {
		croak "setconn: $conn: unknown protocol";
	}

	if (defined($socket)) {
		$this->set_socket($socket);
	} else {
		carp "setconn: $conn: $!";
		undef;
	}
}

=pod

=item set_dispatcher(CODEREF)

Sets the dispatcher used to accept socket connections and hand them off to
the protocol engine.  This allows pluggable resource allocation so that the
milter script may use fork, threads, or any other such means of handling
milter connections.  See C<DISPATCHERS> below for more information.

The subroutine (code) reference will be called by C<main()> when the
listening socket object is prepared and ready to accept connections.  It
will be passed the arguments:

    MILTER, LSOCKET, HANDLER

MILTER is the milter object currently running.  LSOCKET is a listening
socket (an instance of C<IO::Socket>), upon which C<accept()> should be
called.  HANDLER is a subroutine reference which should be called, passing
the socket object returned by C<< LSOCKET->accept() >>.

Note that the dispatcher may also be set from one of the off-the-shelf
dispatchers noted in this document by setting the PMILTER_DISPATCHER
environment variable.  See C<DISPATCHERS>, below.

=cut

sub set_dispatcher($&) {
	my $this = shift;

	$this->{dispatcher} = shift;
	1;
}

=pod

=item set_listen(BACKLOG)

Set the socket listen backlog to BACKLOG.  The default is 5 connections if
not set explicitly by this method.  Only useful before calling C<main()>.