[libsendmail-milter-perl] 01/02: Imported Upstream version 0.18
Hilko Bengen
bengen at moszumanska.debian.org
Sun Sep 27 18:37:34 UTC 2015
This is an automated email from the git hooks/post-receive script.
bengen pushed a commit to annotated tag debian/0.18-7
in repository libsendmail-milter-perl.
commit 4316ee915eabfda36fcfb9de5c4e2007bd99952b
Author: Hilko Bengen <bengen at debian.org>
Date: Sun Sep 27 20:35:23 2015 +0200
Imported Upstream version 0.18
---
Changes | 29 +++
LICENSE | 79 ++++++
MANIFEST | 15 ++
Makefile.PL | 87 +++++++
Milter.pm | 837 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Milter.xs | 468 +++++++++++++++++++++++++++++++++
README | 105 ++++++++
TODO | 10 +
callbacks.c | 768 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
callbacks.h | 15 ++
intpools.c | 527 ++++++++++++++++++++++++++++++++++++++
intpools.h | 57 +++++
sample.pl | 258 +++++++++++++++++++
test.pl | 81 ++++++
typemap | 18 ++
15 files changed, 3354 insertions(+)
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..75f5384
--- /dev/null
+++ b/Changes
@@ -0,0 +1,29 @@
+Revision history for Perl extension Sendmail::Milter.
+
+0.18 Tue Oct 9 21:38:09 2001
+ - Patches to properly link with sendmail 8.12.1. Fixed
+ auto_setconn to support abbreviated T= syntax. Thanks to
+ Derek J. Balling of Yahoo, Inc.
+ - Updates to documentation to reflect sendmail 8.12.1.
+0.17 Sat Jul 29 09:55:02 2000
+ - Fixed build to properly link on Solaris. Thanks to
+ Claus Assmann of Sendmail, Inc.
+0.16 Mon Jul 24 05:37:59 2000
+ - Fixed bug in detecting no F= flags in auto_getconn().
+0.15 Wed Jul 19 19:15:49 2000
+ - Tested against sendmail 8.11.0 release.
+ - Updated README against released sendmail 8.11.0.
+0.14 Tue Jul 18 08:28:00 2000
+ - Now store code refs in globals to avoid sv_dup.
+ - Update README with SourceForge information.
+0.12 Thu Jul 13 11:16:17 2000
+ - Include sendmail's LICENSE file.
+0.11 Thu Jul 6 22:46:26 2000
+ - Now block for locking interpreters with condition variables.
+ - Successfully support code references and function names.
+ - Now support sendmail-8.11.0
+ - Fixed idiotic bug where all callbacks were going through
+ one interpreter.
+
+0.10 Tue Jul 4 23:22:51 2000
+ - Never released, only for internal testing.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..89b12f5
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,79 @@
+ SENDMAIL LICENSE
+
+The following license terms and conditions apply, unless a different
+license is obtained from Sendmail, Inc., 6425 Christie Ave, Fourth Floor,
+Emeryville, CA 94608, or by electronic mail at license at sendmail.com.
+
+License Terms:
+
+Use, Modification and Redistribution (including distribution of any
+modified or derived work) in source and binary forms is permitted only if
+each of the following conditions is met:
+
+1. Redistributions qualify as "freeware" or "Open Source Software" under
+ one of the following terms:
+
+ (a) Redistributions are made at no charge beyond the reasonable cost of
+ materials and delivery.
+
+ (b) Redistributions are accompanied by a copy of the Source Code or by an
+ irrevocable offer to provide a copy of the Source Code for up to three
+ years at the cost of materials and delivery. Such redistributions
+ must allow further use, modification, and redistribution of the Source
+ Code under substantially the same terms as this license. For the
+ purposes of redistribution "Source Code" means the complete compilable
+ and linkable source code of sendmail including all modifications.
+
+2. Redistributions of source code must retain the copyright notices as they
+ appear in each source code file, these license terms, and the
+ disclaimer/limitation of liability set forth as paragraph 6 below.
+
+3. Redistributions in binary form must reproduce the Copyright Notice,
+ these license terms, and the disclaimer/limitation of liability set
+ forth as paragraph 6 below, in the documentation and/or other materials
+ provided with the distribution. For the purposes of binary distribution
+ the "Copyright Notice" refers to the following language:
+ "Copyright (c) 1998-2000 Sendmail, Inc. All rights reserved."
+
+4. Neither the name of Sendmail, Inc. nor the University of California nor
+ the names of their contributors may be used to endorse or promote
+ products derived from this software without specific prior written
+ permission. The name "sendmail" is a trademark of Sendmail, Inc.
+
+5. All redistributions must comply with the conditions imposed by the
+ University of California on certain embedded code, whose copyright
+ notice and conditions for redistribution are as follows:
+
+ (a) Copyright (c) 1988, 1993 The Regents of the University of
+ California. All rights reserved.
+
+ (b) Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ (i) Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ (ii) Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ (iii) Neither the name of the University nor the names of its
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+6. Disclaimer/Limitation of Liability: THIS SOFTWARE IS PROVIDED BY
+ SENDMAIL, INC. AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED
+ WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
+ NO EVENT SHALL SENDMAIL, INC., THE REGENTS OF THE UNIVERSITY OF
+ CALIFORNIA OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+ USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+$Revision: 1.1.1.1 $, Last updated $Date: 2000/07/14 05:46:15 $
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..363d9e5
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,15 @@
+Changes
+LICENSE
+MANIFEST
+README
+TODO
+Makefile.PL
+Milter.pm
+Milter.xs
+intpools.c
+intpools.h
+callbacks.c
+callbacks.h
+typemap
+sample.pl
+test.pl
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..bd827fb
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,87 @@
+use 5.006;
+
+use strict;
+
+use ExtUtils::MakeMaker;
+use Config;
+
+if ((not $ARGV[0]) or (not $ARGV[1]))
+{
+ print "Usage: perl Makefile.PL <path-to-sendmail-source> <path-to-sendmail-obj.dir>\n";
+ print "(e.g. 'perl Makefile.PL ../sendmail ../sendmail/obj.FreeBSD.4.0-RELEASE.i386')\n";
+ print "\n";
+ exit;
+}
+
+if (not $Config{usethreads})
+{
+ print "To use this module, your perl interpreter must have been compiled with\n";
+ print "\t-Dusethreads.\n";
+ print "\n";
+ exit;
+}
+
+my $SENDMAIL_PATH = MM->canonpath($ARGV[0]);
+my $SENDMAIL_OBJ_PATH = MM->canonpath($ARGV[1]);
+
+my $MILTER_LIB = MM->catdir($SENDMAIL_OBJ_PATH, "libmilter");
+my $SMUTIL_LIB = MM->catdir($SENDMAIL_OBJ_PATH, "libsmutil");
+my $SM_LIB = MM->catdir($SENDMAIL_OBJ_PATH, "libsm");
+my $MILTER_INCLUDE = MM->catdir($SENDMAIL_PATH, "include");
+my $SENDMAIL_INCLUDE = MM->catdir($SENDMAIL_PATH, "sendmail");
+
+sub milter_configure
+{
+ my $hash_ref = {};
+ my $libs;
+ my $ccflags;
+
+ # Standard milter libraries
+ $libs = "-L$MILTER_LIB -L$SMUTIL_LIB -L$SM_LIB -lmilter -lsmutil -lsm";
+
+ # POSIX threads support.
+ if ($Config{libs} =~ /-lpthread/)
+ {
+ $libs .= " -lpthread";
+ }
+ else
+ {
+ $ccflags = '-pthread';
+ }
+
+ # Solaris 2.6 -lsocket -lnsl support.
+ if ($Config{libs} =~ /-lsocket/)
+ {
+ $libs .= " -lsocket";
+ }
+ if ($Config{libs} =~ /-lnsl/)
+ {
+ $libs .= " -lnsl";
+ }
+
+ # Solaris and inet_aton / inet_pton functions.
+ if (($^O eq 'solaris') && (not $Config{d_inetaton}))
+ {
+ $libs .= " -lresolv";
+ }
+
+ # Only set the CCFLAGS variable if there's something.
+ if ($ccflags)
+ {
+ $hash_ref->{'CCFLAGS'} = $ccflags;
+ }
+
+ $hash_ref->{'LIBS'} = [ "$libs" ];
+
+ return $hash_ref;
+}
+
+WriteMakefile(
+ 'NAME' => 'Sendmail::Milter',
+ 'VERSION_FROM' => 'Milter.pm',
+ 'CONFIGURE' => \&milter_configure,
+ 'OBJECT' => '$(BASEEXT)$(OBJ_EXT) intpools$(OBJ_EXT) callbacks$(OBJ_EXT)',
+ 'DEFINE' => '',
+ 'INC' => "-I$SENDMAIL_INCLUDE -I$MILTER_INCLUDE",
+);
+
diff --git a/Milter.pm b/Milter.pm
new file mode 100644
index 0000000..81cf8b8
--- /dev/null
+++ b/Milter.pm
@@ -0,0 +1,837 @@
+#
+# Copyright (c) 2000-2001 Charles Ying. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as sendmail itself.
+#
+
+package Sendmail::Milter;
+
+use 5.006;
+
+use strict;
+use warnings;
+use Carp;
+
+require Exporter;
+require DynaLoader;
+use AutoLoader;
+
+our @ISA = qw(Exporter DynaLoader);
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration use Sendmail::Milter ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ SMFIF_ADDHDRS
+ SMFIF_ADDRCPT
+ SMFIF_CHGBODY
+ SMFIF_CHGHDRS
+ SMFIF_DELRCPT
+ SMFIF_MODBODY
+ SMFIS_ACCEPT
+ SMFIS_CONTINUE
+ SMFIS_DISCARD
+ SMFIS_REJECT
+ SMFIS_TEMPFAIL
+ SMFI_CURR_ACTS
+ SMFI_V1_ACTS
+ SMFI_V2_ACTS
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+ SMFIF_ADDHDRS
+ SMFIF_ADDRCPT
+ SMFIF_CHGBODY
+ SMFIF_CHGHDRS
+ SMFIF_DELRCPT
+ SMFIF_MODBODY
+ SMFIS_ACCEPT
+ SMFIS_CONTINUE
+ SMFIS_DISCARD
+ SMFIS_REJECT
+ SMFIS_TEMPFAIL
+ SMFI_CURR_ACTS
+ SMFI_V1_ACTS
+ SMFI_V2_ACTS
+);
+
+our $VERSION = '0.18';
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my $constname;
+ our $AUTOLOAD;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ croak "& not defined" if $constname eq 'constant';
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/ || $!{EINVAL}) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined Sendmail::Milter macro $constname";
+ }
+ }
+ {
+ no strict 'refs';
+
+ *$AUTOLOAD = sub { $val };
+ }
+ goto &$AUTOLOAD;
+}
+
+bootstrap Sendmail::Milter $VERSION;
+
+# Preloaded methods go here.
+
+our %DEFAULT_CALLBACKS =
+(
+ 'connect' => 'connect_callback',
+ 'helo' => 'helo_callback',
+ 'envfrom' => 'envfrom_callback',
+ 'envrcpt' => 'envrcpt_callback',
+ 'header' => 'header_callback',
+ 'eoh' => 'eoh_callback',
+ 'body' => 'body_callback',
+ 'eom' => 'eom_callback',
+ 'abort' => 'abort_callback',
+ 'close' => 'close_callback',
+);
+
+
+sub auto_setconn
+{
+ my $name = shift;
+ my $cf_filename = shift || undef;
+
+ my $conn_info = Sendmail::Milter::auto_getconn($name, $cf_filename);
+
+ if ($conn_info)
+ {
+ Sendmail::Milter::setconn($conn_info);
+ return 1;
+ }
+
+ return 0;
+}
+
+sub auto_getconn
+{
+ my $name = shift;
+ my $cf_filename = shift || '/etc/mail/sendmail.cf';
+ my $raw_file;
+
+ my $current_name;
+ my $conn_info;
+
+ open(CF_FILE, $cf_filename) || die "Can't open '$cf_filename' for reading: $!";
+
+ $raw_file = join('', <CF_FILE>);
+ $raw_file =~ s/\n[ \t]/ /g;
+
+ close(CF_FILE);
+
+ foreach my $line (split(/\n/, $raw_file))
+ {
+ chomp $line;
+
+ # Just ignore rest of line in case it's F=T, T=blah...
+ # Or just T=blah...
+
+ if ($line =~ /^X(.+),\s*S\=(.+),\s*[FT]\=(.)/)
+ {
+ $current_name = $1;
+ $conn_info = $2;
+
+ if ($current_name eq $name)
+ {
+ return $conn_info;
+ }
+ }
+ elsif ($line =~ /^X(.+),\s*S\=(.+)/)
+ {
+ $current_name = $1;
+ $conn_info = $2;
+
+ if ($current_name eq $name)
+ {
+ return $conn_info;
+ }
+ }
+ }
+
+ return undef;
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Sendmail::Milter - Interface to sendmail's Mail Filter API
+
+=head1 SYNOPSIS
+
+ use Sendmail::Milter;
+
+ my %my_milter_callbacks =
+ (
+ 'connect' => \&my_connect_callback,
+ 'helo' => \&my_helo_callback,
+ 'envfrom' => \&my_envfrom_callback,
+ 'envrcpt' => \&my_envrcpt_callback,
+ 'header' => \&my_header_callback,
+ 'eoh' => \&my_eoh_callback,
+ 'body' => \&my_body_callback,
+ 'eom' => \&my_eom_callback,
+ 'abort' => \&my_abort_callback,
+ 'close' => \&my_close_callback,
+ );
+
+ sub my_connect_callback;
+ sub my_helo_callback;
+ sub my_envfrom_callback;
+ sub my_envrcpt_callback;
+ sub my_header_callback;
+ sub my_eoh_callback;
+ sub my_body_callback;
+ sub my_eom_callback;
+ sub my_abort_callback;
+ sub my_close_callback;
+
+
+ BEGIN:
+ {
+ # Get myfilter's connection information
+ # from /etc/mail/sendmail.cf
+
+ Sendmail::Milter::auto_setconn("myfilter");
+ Sendmail::Milter::register("myfilter",
+ \%my_milter_callbacks, SMFI_CURR_ACTS);
+
+ Sendmail::Milter::main();
+
+ # Never reaches here, callbacks are called from Milter.
+ }
+
+=head1 DESCRIPTION
+
+B<Sendmail::Milter> is a Perl extension to sendmail's Mail Filter API (Milter).
+
+B<Note:> You need to have a Perl 5.6 or later interpreter built with
+B<-Dusethreads>.
+
+=head1 FUNCTIONS
+
+Portions of this document come from comments in the B<libmilter/mfapi.h> header
+file.
+
+=head2 Main Functions
+
+B<Note:> No functions are exported. You must call these functions explicitly
+from the B<Sendmail::Milter> package.
+
+=over 4
+
+=item register NAME, CALLBACKS [, FLAGS]
+
+Registers a mail filter NAME with hash reference CALLBACKS callbacks, and
+optional capability flags FLAGS. NAME is the same filter name that you would
+pass to B<auto_setconn>. CALLBACKS is a hash reference that can contain any of
+the following keys:
+
+ connect
+ helo
+ envfrom
+ envrcpt
+ header
+ eoh
+ body
+ eom
+ abort
+ close
+
+The values for these keys indicate the callback routine that is associated with
+each Milter callback. The values must be either function names, code references
+or closures.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+B<%Sendmail::Milter::DEFAULT_CALLBACKS> is a hash with default function names
+for all of the Milter callbacks. The default callback function names are:
+
+B<connect_callback>, B<helo_callback>, B<envfrom_callback>,
+B<envrcpt_callback>, B<header_callback>, B<eoh_callback>, B<body_callback>,
+B<eom_callback>, B<abort_callback>, B<close_callback>.
+
+See the section B<Writing Milter Callbacks> for more information on writing
+the callbacks themselves.
+
+For more information on capability flags, see the section B<Capability Flags>
+in the B<@EXPORT> section.
+
+=item main [MAX_INTERPRETERS] [, MAX_REQUESTS]
+
+Starts the mail filter. If successful, this function never returns. Instead, it
+launches the Milter engine which will call each of the callback routines as
+appropriate.
+
+MAX_INTERPRETERS sets the limit on the maximum number of interpreters that
+B<Sendmail::Milter> is allowed to create. These interpreters will only be
+created as the need arises and are not all created at startup. The default
+value is 0. (No maximum limit)
+
+MAX_REQUESTS sets the limit on the maximum number of requests an interpreter
+will process before being recycled. The default value is 0. (Don't recycle
+interpreters)
+
+This function returns nonzero on success (if a kill was signaled or something),
+the undefined value otherwise.
+
+B<Note:> You should have at least registered a callback and set the connection
+information string before calling this function.
+
+
+=item setconn CONNECTION_INFO
+
+Sets the connection information string for the filter. The format of this
+string is identical to that found in the Milter documentation. Some examples
+are C<local:/var/run/f1.sock>, C<inet6:999 at localhost>, C<inet:3333 at localhost>.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item auto_setconn NAME [, SENDMAIL_CF_FILENAME]
+
+This function automatically sets the connection information by parsing the
+sendmail .cf file for the appropriate X line containing the connection
+information for the NAME mail filter and calling B<setconn> if it was
+successful. It is provided as a helper function and does not exist in the
+current Milter library.
+
+B<Note:> This connection information isn't useful for implementing a Milter
+that resides on a machine that is remote to the machine running sendmail. In
+those cases, you will want to set the connection information manually with
+B<setconn>.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+SENDMAIL_CF_FILENAME defaults to C</etc/mail/sendmail.cf> if not specified.
+
+
+=item auto_getconn NAME [, SENDMAIL_CF_FILENAME]
+
+Similar to B<auto_setconn>, this function parses the sendmail .cf file for the
+appropriate X line containing the connection information for NAME. It does not,
+however, call B<setconn>. It only retrieves the connection information.
+
+This function returns the connection information string for NAME, or undef on
+failure.
+
+SENDMAIL_CF_FILENAME defaults to C</etc/mail/sendmail.cf> if not specified.
+
+
+=item settimeout TIMEOUT
+
+Sets the timeout for reads/writes in the Milter engine.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item setdbg LEVEL
+
+Sets the debug level for the Milter engine.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=back
+
+
+
+=head2 Writing Milter Callbacks
+
+Writing Milter callbacks is pretty easy when you're doing simple text
+processing.
+
+But remember one thing: Each Milter callback could quite possibly run in a
+different instance of the Perl interpreter.
+
+B<Sendmail::Milter> launches multiple persistent Perl interpreters to increase
+performance (so it doesn't have to startup and shutdown the interpreters
+constantly). Thus, you can't rely on setting external package variables, global
+variables, or even running other modules which rely on such things. This will
+continue to be true while interpreter thread support in Perl is experimental.
+For more information, see L<perlfork>. Most of that information applies here.
+
+Remember to return one of the B<SMFIS_*> result codes from the callback
+routine. Remember there can be multiple message body chunks. And remember that
+only B<eom_callback> is allowed to manipulate the headers, recipients, message
+body, etc.
+
+See the B<@EXPORT> section for information on the B<SMFIS_*> result codes.
+
+Here is an example of a B<connect_callback> routine:
+
+ # External modules are OK, but note the caveats above.
+ use Socket;
+
+ sub connect_callback
+ {
+ my $ctx = shift; # The Milter context object.
+ my $hostname = shift; # The connection's host name.
+ my $sockaddr_in = shift;
+ my ($port, $iaddr) = sockaddr_in($sockaddr_in);
+
+ print "Hostname is: " . $hostname . "\n";
+
+ # Cool, a printable IP address.
+ print "IP Address is: " . inet_ntoa($iaddr) . "\n";
+
+ return SMFIS_CONTINUE; # Returning a value is important!
+ }
+
+B<Note:> The $ctx Milter context object is not a true Perl object. It's really
+a blessed reference to an opaque C structure. Only use the Milter context
+functions (described in a later section) with this object. (Don't touch it,
+it's evil.)
+
+=head2 Milter Callback Interfaces
+
+These interfaces closely mirror their Milter callback counterparts, however
+there are some differences that take advantage of Perl's syntactic sugar.
+
+B<Note:> Each callback receives a Milter context object as the first
+argument. This context object is used in making Milter Context function
+calls. See B<Milter Context Functions> for more details.
+
+=over 4
+
+=item B<connect_callback> CTX, HOSTNAME, SOCKADDR_IN
+
+Invoked on each connection. HOSTNAME is the host domain name, as determined by
+a reverse lookup on the host address. SOCKADDR_IN is the AF_INET portion of the
+host address, as determined by a B<getpeername(2)> syscall on the SMTP
+socket. You can use B<Socket::unpack_sockaddr_in()> to unpack it into a port
+and IP address.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<helo_callback> CTX, HELOHOST
+
+Invoked on SMTP HELO/EHLO command. HELOHOST is the value passed to HELO/EHLO
+command, which should be the domain name of the sending host (but is, in
+practice, anything the sending host wants to send).
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<envfrom_callback> CTX, ARG1, ARG2, ..., ARGn
+
+Invoked on envelope from. ARG1, ARG2, ... ARGn are SMTP command arguments. ARG1
+is guaranteed to be the sender address. Later arguments are the ESMTP
+arguments.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<envrcpt_callback> CTX, ARG1, ARG2, ..., ARGn
+
+Invoked on each envelope recipient. ARG1, ARG2, ... ARGn are SMTP command
+arguments. ARG1 is guaranteed to be the recipient address. Later arguments are
+the ESMTP arguments.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<header_callback> CTX, FIELD, VALUE
+
+Invoked on each message header. The content of the header may have folded white
+space (that is, multiple lines with following white space) included. FIELD is
+the header field name, VALUE is the header field value.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<eoh_callback> CTX
+
+Invoked at end of header.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<body_callback> CTX, BODY, LEN
+
+Invoked for each body chunk. There may be multiple body chunks passed to the
+filter. End-of-lines are represented as received from SMTP (normally
+Carriage-Return/Line-Feed). BODY contains the body data, LEN contains the
+length of the body data.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<eom_callback> CTX
+
+Invoked at end of message. This routine can perform special operations such as
+modifying the message header, body, or envelope. See the section on
+B<eom_callback> in B<Milter Context Functions>.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<abort_callback> CTX
+
+Invoked if message is aborted outside of the control of the filter, for
+example, if the SMTP sender issues an RSET command. If B<abort_callback> is
+called, B<eom_callback> will not be called and vice versa.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=item B<close_callback> CTX
+
+Invoked at end of the connection. This is called on close even if the previous
+mail transaction was aborted.
+
+This callback should return one of the B<SMFIS_*> result codes.
+
+
+=back
+
+
+
+=head2 Milter Context Functions
+
+These routines are object methods that are part of the
+B<Sendmail::Milter::Context> pseudo-package for use by B<Sendmail::Milter>
+callback functions. Any attempts to use them without a properly blessed Milter
+context object will fail miserably. Please see restrictions on when these
+routines may be called.
+
+B<Context routines available to all Milter callback functions:>
+
+These functions are available to all types of Milter callback functions. It is
+worth noting that passing connection-private data by reference is probably more
+efficient than passing by value.
+
+=over 4
+
+=item B<$ctx>-E<gt>setpriv DATA
+
+Each B<$ctx> can contain connection-private data (specific to an SMTP
+connection). This routine can be used to allocate this private data. Calling
+this function with DATA set to the undefined value will clear Milter's pointer
+to this private data. You should always do this to decrement the private data's
+reference count.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item B<$ctx>-E<gt>getpriv
+
+Each B<$ctx> can contain connection-private data (specific to an SMTP
+connection). This routine can be used to retrieve this private data.
+
+This function returns a scalar containing B<$ctx>'s private data.
+
+
+=item B<$ctx>-E<gt>getsymval SYMNAME
+
+Additional information is passed in to the vendor filter routines using
+symbols. Symbols correspond closely to sendmail macros. The symbols defined
+depend on the context. SYMNAME is the name of the symbol to access.
+
+This function returns the value of the symbol name SYMNAME.
+
+
+=item B<$ctx>-E<gt>setreply RCODE, XCODE, MESSAGE
+
+Set the specific reply code to be used in response to the active command. If
+not specified, a generic reply code is used.
+RCODE is the three-digit (B<RFC 821>) SMTP reply code to be returned, e.g. C<551>.
+XCODE is the extended (B<RFC 2034>) reply code, e.g., C<5.7.6>.
+MESSAGE is the text part of the SMTP reply.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+=back
+
+
+B<Context routines available only to the eom_callback function:>
+
+The B<eom_callback> Milter callback is called at the end of a message
+(essentially, after the final DATA dot). This routine can call some special
+routines to modify the envelope, header, or body of the message before the
+message is enqueued. These routines must not be called from any vendor routine
+other than B<eom_callback>.
+
+=over 4
+
+=item B<$ctx>-E<gt>addheader FIELD, VALUE
+
+Add a header to the message. FIELD is the header field name. VALUE is the
+header field value. This header is not passed to other filters. It is not
+checked for standards compliance; the mail filter must ensure that no protocols
+are violated as a result of adding this header.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item B<$ctx>-E<gt>chgheader FIELD, INDEX, VALUE
+
+Change/delete a header in the message. FIELD is the header field name. INDEX is
+the Nth occurence of the header field name. VALUE is the new header field value
+(empty for delete header). It is not checked for standards compliance; the mail
+filter must ensure that no protocols are violated as a result of adding this
+header.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item B<$ctx>-E<gt>addrcpt RCPT
+
+Add a recipient to the envelope. RCPT is the recipient to be added.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item B<$ctx>-E<gt>delrcpt RCPT
+
+Delete a recipient from the envelope. RCPT is the envelope recipient to be
+deleted. This should be in exactly the same form passed to B<envrcpt_callback>
+or the address may not be deleted.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=item B<$ctx>-E<gt>replacebody DATA
+
+Replace the body of the message. DATA is the scalar containing the block of
+message body information to insert. This routine may be called multiple times
+if the body is longer than convenient to send in one call. End of line should
+be represented as Carriage-Return/Line Feed.
+
+This function returns nonzero upon success, the undefined value otherwise.
+
+
+=back
+
+
+
+=head1 @EXPORT
+
+B<Sendmail::Milter> exports the following constants:
+
+=head2 Callback Result Codes
+
+These are the possible result codes that may be returned by the Milter callback
+functions. If you do not specify a return value, B<Sendmail::Milter> will send
+a default result code of B<SMFIS_CONTINUE> back to Milter.
+
+=over 4
+
+=item SMFIS_CONTINUE
+
+Continue processing message/connection
+
+=item SMFIS_REJECT
+
+Reject the message/connection. No further routines will be called for this
+message (or connection, if returned from a connection-oriented routine).
+
+=item SMFIS_DISCARD
+
+Accept the message, but silently discard the message. No further routines will
+be called for this message. This is only meaningful from message-oriented
+routines.
+
+=item SMFIS_ACCEPT
+
+Accept the message/connection. No further routines will be called for this
+message (or connection, if returned from a connection-oriented routine; in this
+case, it causes all messages on this connection to be accepted without
+filtering).
+
+=item SMFIS_TEMPFAIL
+
+Return a temporary failure, i.e., the corresponding SMTP command will return a
+4xx status code. In some cases this may prevent further routines from being
+called on this message or connection, although in other cases (e.g., when
+processing an envelope recipient) processing of the message will continue.
+
+=back
+
+=head2 Capability Flags
+
+These are possible capability flags for what a mail filter can do.
+Normally, you should specify each capability explicitly as needed.
+
+=over 4
+
+=item SMFIF_ADDHDRS
+
+Allows a mail filter to add headers.
+
+=item SMFIF_CHGBODY
+
+Allows a mail filter to change the message body.
+
+=item SMFIF_ADDRCPT
+
+Allows a mail filter to add recipients.
+
+=item SMFIF_DELRCPT
+
+Allows a mail filter to delete recipients.
+
+=item SMFIF_CHGHDRS
+
+Allows a mail filter to change headers.
+
+=item SMFIF_MODBODY
+
+Allows a mail filter to change the message body. (Provided only for backwards
+compatibility)
+
+=back
+
+
+=head2 Capability Flag Sets
+
+These provide sets of capability flags that indicate all of the capabilities in
+a particular version of Milter. B<SMFI_CURR_ACTS> is set to the capabilities in
+the current version of Milter.
+
+=over 4
+
+=item SMFI_CURR_ACTS
+
+Enables the set of capabilities available to mail filters in the current
+version of Milter.
+
+=item SMFI_V1_ACTS
+
+Enables the set of capabilities available to mail filters in V1 of Milter.
+
+=item SMFI_V2_ACTS
+
+Enables the set of capabilities available to mail filters in V2 of Milter.
+
+=back
+
+
+=head1 EXAMPLES
+
+=head2 Appending a line to the message body
+
+ use Sendmail::Milter;
+
+ my %my_milter_callbacks =
+ (
+ 'eoh' => \&my_eoh_callback,
+ 'body' => \&my_body_callback,
+ 'eom' => \&my_eom_callback,
+ 'abort' => \&my_abort_callback,
+ );
+
+ sub my_eoh_callback
+ {
+ my $ctx = shift;
+ my $body = "";
+
+ $ctx->setpriv(\$body);
+
+ return SMFIS_CONTINUE;
+ }
+
+ sub my_body_callback
+ {
+ my $ctx = shift;
+ my $body_chunk = shift;
+ my $body_ref = $ctx->getpriv();
+
+ ${$body_ref} .= $body_chunk;
+
+ # This is crucial, the reference to the body may have
+ # changed.
+
+ $ctx->setpriv($body_ref);
+
+ return SMFIS_CONTINUE;
+ }
+
+ sub my_eom_callback
+ {
+ my $ctx = shift;
+ my $body_ref = $ctx->getpriv();
+
+ # Note: This doesn't support messages with MIME data.
+
+ ${$body_ref} .= "---> Append me to this message body!\n";
+
+ $ctx->replacebody(${$body_ref});
+
+ $ctx->setpriv(undef);
+
+ return SMFIS_ACCEPT;
+ }
+
+ sub my_abort_callback
+ {
+ my $ctx = shift;
+
+ $ctx->setpriv(undef);
+
+ return SMFIS_CONTINUE;
+ }
+
+
+ # The following code does not necessarily need to be in a
+ # BEGIN block. It just looks funny without it. :)
+
+ BEGIN:
+ {
+ Sendmail::Milter::auto_setconn("myfilter");
+ Sendmail::Milter::register("myfilter",
+ \%my_milter_callbacks, SMFI_CURR_ACTS);
+
+ Sendmail::Milter::main();
+
+ # Never reaches here, callbacks are called from Milter.
+ }
+
+
+See the B<test.pl> sample test case for more callback examples.
+
+=head1 AUTHOR
+
+Charles Ying, cying at cpan.org.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000-2001 Charles Ying. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same terms
+as sendmail itself.
+
+The interpreter pools portion (found in the intpools.c, intpools.h, and test.pl
+files) of this code is also available under the same terms as perl itself.
+
+=head1 SEE ALSO
+
+perl(1), sendmail(8).
+
+=cut
diff --git a/Milter.xs b/Milter.xs
new file mode 100644
index 0000000..60d4de6
--- /dev/null
+++ b/Milter.xs
@@ -0,0 +1,468 @@
+/*
+ * Copyright (c) 2000 Charles Ying. All rights reserved.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the same terms as sendmail itself.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "intpools.h"
+
+#include "libmilter/mfapi.h"
+#include "callbacks.h"
+
+
+/* Conversion for an easier interface to the milter API. */
+#define MI_BOOL_CVT(mi_bool) (((mi_bool) == MI_SUCCESS) ? TRUE : FALSE)
+
+typedef SMFICTX *Sendmail_Milter_Context;
+
+
+/* Wrapper functions to do some real work. */
+
+int milter_register(pTHX_ char *name, SV *milter_desc_ref, int flags)
+{
+ HV *milter_desc = (HV *)NULL;
+ struct smfiDesc filter_desc;
+
+ if (!SvROK(milter_desc_ref) &&
+ (SvTYPE(SvRV(milter_desc_ref)) != SVt_PVHV))
+ croak("expected reference to hash for milter descriptor.");
+
+ milter_desc = (HV *)SvRV(milter_desc_ref);
+
+ register_callbacks(&filter_desc, name, milter_desc, flags);
+
+ return smfi_register(filter_desc);
+}
+
+int milter_main(int max_interpreters, int max_requests)
+{
+ init_callbacks(max_interpreters, max_requests);
+
+ return smfi_main();
+}
+
+
+/* Constants from libmilter/mfapi.h */
+
+static int
+not_here(char *s)
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static double
+constant_SMFIF_A(char *name, int len, int arg)
+{
+ if (7 + 2 >= len ) {
+ errno = EINVAL;
+ return 0;
+ }
+ switch (name[7 + 2]) {
+ case 'H':
+ if (strEQ(name + 7, "DDHDRS")) { /* SMFIF_A removed */
+#ifdef SMFIF_ADDHDRS
+ return SMFIF_ADDHDRS;
+#else
+ goto not_there;
+#endif
+ }
+ case 'R':
+ if (strEQ(name + 7, "DDRCPT")) { /* SMFIF_A removed */
+#ifdef SMFIF_ADDRCPT
+ return SMFIF_ADDRCPT;
+#else
+ goto not_there;
+#endif
+ }
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+static double
+constant_SMFIF_C(char *name, int len, int arg)
+{
+ if (7 + 2 >= len ) {
+ errno = EINVAL;
+ return 0;
+ }
+ switch (name[7 + 2]) {
+ case 'B':
+ if (strEQ(name + 7, "HGBODY")) { /* SMFIF_C removed */
+#ifdef SMFIF_CHGBODY
+ return SMFIF_CHGBODY;
+#else
+ goto not_there;
+#endif
+ }
+ case 'H':
+ if (strEQ(name + 7, "HGHDRS")) { /* SMFIF_C removed */
+#ifdef SMFIF_CHGHDRS
+ return SMFIF_CHGHDRS;
+#else
+ goto not_there;
+#endif
+ }
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+static double
+constant_SMFIF(char *name, int len, int arg)
+{
+ if (5 + 1 >= len ) {
+ errno = EINVAL;
+ return 0;
+ }
+ switch (name[5 + 1]) {
+ case 'A':
+ if (!strnEQ(name + 5,"_", 1))
+ break;
+ return constant_SMFIF_A(name, len, arg);
+ case 'C':
+ if (!strnEQ(name + 5,"_", 1))
+ break;
+ return constant_SMFIF_C(name, len, arg);
+ case 'D':
+ if (strEQ(name + 5, "_DELRCPT")) { /* SMFIF removed */
+#ifdef SMFIF_DELRCPT
+ return SMFIF_DELRCPT;
+#else
+ goto not_there;
+#endif
+ }
+ case 'M':
+ if (strEQ(name + 5, "_MODBODY")) { /* SMFIF removed */
+#ifdef SMFIF_MODBODY
+ return SMFIF_MODBODY;
+#else
+ goto not_there;
+#endif
+ }
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+static double
+constant_SMFI_V(char *name, int len, int arg)
+{
+ switch (name[6 + 0]) {
+ case '1':
+ if (strEQ(name + 6, "1_ACTS")) { /* SMFI_V removed */
+#ifdef SMFI_V1_ACTS
+ return SMFI_V1_ACTS;
+#else
+ goto not_there;
+#endif
+ }
+ case '2':
+ if (strEQ(name + 6, "2_ACTS")) { /* SMFI_V removed */
+#ifdef SMFI_V2_ACTS
+ return SMFI_V2_ACTS;
+#else
+ goto not_there;
+#endif
+ }
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+static double
+constant_SMFI_(char *name, int len, int arg)
+{
+ switch (name[5 + 0]) {
+ case 'C':
+ if (strEQ(name + 5, "CURR_ACTS")) { /* SMFI_ removed */
+#ifdef SMFI_CURR_ACTS
+ return SMFI_CURR_ACTS;
+#else
+ goto not_there;
+#endif
+ }
+ case 'V':
+ return constant_SMFI_V(name, len, arg);
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+static double
+constant_SMFIS(char *name, int len, int arg)
+{
+ if (5 + 1 >= len ) {
+ errno = EINVAL;
+ return 0;
+ }
+ switch (name[5 + 1]) {
+ case 'A':
+ if (strEQ(name + 5, "_ACCEPT")) { /* SMFIS removed */
+#ifdef SMFIS_ACCEPT
+ return SMFIS_ACCEPT;
+#else
+ goto not_there;
+#endif
+ }
+ case 'C':
+ if (strEQ(name + 5, "_CONTINUE")) { /* SMFIS removed */
+#ifdef SMFIS_CONTINUE
+ return SMFIS_CONTINUE;
+#else
+ goto not_there;
+#endif
+ }
+ case 'D':
+ if (strEQ(name + 5, "_DISCARD")) { /* SMFIS removed */
+#ifdef SMFIS_DISCARD
+ return SMFIS_DISCARD;
+#else
+ goto not_there;
+#endif
+ }
+ case 'R':
+ if (strEQ(name + 5, "_REJECT")) { /* SMFIS removed */
+#ifdef SMFIS_REJECT
+ return SMFIS_REJECT;
+#else
+ goto not_there;
+#endif
+ }
+ case 'T':
+ if (strEQ(name + 5, "_TEMPFAIL")) { /* SMFIS removed */
+#ifdef SMFIS_TEMPFAIL
+ return SMFIS_TEMPFAIL;
+#else
+ goto not_there;
+#endif
+ }
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+static double
+constant(char *name, int len, int arg)
+{
+ errno = 0;
+ if (0 + 4 >= len ) {
+ errno = EINVAL;
+ return 0;
+ }
+ switch (name[0 + 4]) {
+ case 'F':
+ if (!strnEQ(name + 0,"SMFI", 4))
+ break;
+ return constant_SMFIF(name, len, arg);
+ case 'S':
+ if (!strnEQ(name + 0,"SMFI", 4))
+ break;
+ return constant_SMFIS(name, len, arg);
+ case '_':
+ if (!strnEQ(name + 0,"SMFI", 4))
+ break;
+ return constant_SMFI_(name, len, arg);
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+
+MODULE = Sendmail::Milter PACKAGE = Sendmail::Milter PREFIX = smfi_
+
+PROTOTYPES: DISABLE
+
+double
+constant(sv,arg)
+ PREINIT:
+ STRLEN len;
+ INPUT:
+ SV * sv
+ char * s = SvPV(sv, len);
+ int arg
+ CODE:
+ RETVAL = constant(s,len,arg);
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_register(name, milter_desc_ref, flags=0)
+ char* name;
+ SV* milter_desc_ref;
+ int flags;
+ CODE:
+ RETVAL = MI_BOOL_CVT(milter_register(aTHX_ name, milter_desc_ref,
+ flags));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_main(max_interpreters=0, max_requests=0)
+ int max_interpreters;
+ int max_requests;
+ CODE:
+ RETVAL = MI_BOOL_CVT(milter_main(max_interpreters, max_requests));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_setdbg(dbg)
+ int dbg;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_setdbg(dbg));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_setconn(conn)
+ char* conn;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_setconn(conn));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_settimeout(timeout)
+ int timeout;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_settimeout(timeout));
+ OUTPUT:
+ RETVAL
+
+int
+test_intpools(max_interp, max_requests, i_max, j_max, callback)
+ int max_interp;
+ int max_requests;
+ int i_max;
+ int j_max;
+ SV* callback;
+ CODE:
+ RETVAL = test_intpools(aTHX_ max_interp, max_requests, i_max, j_max,
+ callback);
+ OUTPUT:
+ RETVAL
+
+
+MODULE = Sendmail::Milter PACKAGE = Sendmail::Milter::Context PREFIX = smfi_
+
+char *
+smfi_getsymval(Sendmail_Milter_Context ctx, char* symname)
+
+bool
+smfi_setreply(ctx, rcode, xcode, message)
+ Sendmail_Milter_Context ctx;
+ char* rcode;
+ char* xcode;
+ char* message;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_setreply(ctx, rcode, xcode, message));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_addheader(ctx, headerf, headerv)
+ Sendmail_Milter_Context ctx;
+ char* headerf;
+ char* headerv;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_addheader(ctx, headerf, headerv));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_chgheader(ctx, headerf, index, headerv)
+ Sendmail_Milter_Context ctx;
+ char* headerf;
+ int index;
+ char* headerv;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_chgheader(ctx, headerf, index, headerv));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_addrcpt(ctx, rcpt)
+ Sendmail_Milter_Context ctx;
+ char* rcpt;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_addrcpt(ctx, rcpt));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_delrcpt(ctx, rcpt)
+ Sendmail_Milter_Context ctx;
+ char* rcpt;
+ CODE:
+ RETVAL = MI_BOOL_CVT(smfi_delrcpt(ctx, rcpt));
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_replacebody(ctx, body_data)
+ Sendmail_Milter_Context ctx;
+ SV* body_data;
+ PREINIT:
+ u_char *bodyp;
+ int len;
+ CODE:
+ bodyp = SvPV(body_data, len);
+ RETVAL = MI_BOOL_CVT(smfi_replacebody(ctx, bodyp, len));;
+ OUTPUT:
+ RETVAL
+
+bool
+smfi_setpriv(ctx, data)
+ Sendmail_Milter_Context ctx;
+ SV* data;
+ CODE:
+ if (SvTRUE(data))
+ RETVAL = MI_BOOL_CVT(smfi_setpriv(ctx, (void *)newSVsv(data)));
+ else
+ RETVAL = MI_BOOL_CVT(smfi_setpriv(ctx, NULL));
+ OUTPUT:
+ RETVAL
+
+SV *
+smfi_getpriv(ctx)
+ Sendmail_Milter_Context ctx;
+ CODE:
+ RETVAL = (SV *) smfi_getpriv(ctx);
+ OUTPUT:
+ RETVAL
diff --git a/README b/README
new file mode 100644
index 0000000..24d04ba
--- /dev/null
+++ b/README
@@ -0,0 +1,105 @@
+Sendmail::Milter - Perl interface to sendmail's Mail Filter API
+===============================================================
+
+Copyright Notice
+----------------
+
+Copyright (c) 2000-2001 Charles Ying. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same terms
+as sendmail itself.
+
+The interpreter pools portion (found in the intpools.c, intpools.h, and test.pl
+files) of this code is also available under the same terms as perl itself.
+
+
+About Sendmail::Milter
+----------------------
+
+Sendmail::Milter provides users with the ability to write mail filters in Perl
+that tightly integrate with sendmail's mail filter API.
+
+With this module, you can define and register Perl callbacks with the Milter
+engine. This module calls your perl callbacks using interpreters from a
+threaded persistent interpreter pool. Milter contexts are presented using an
+object-oriented style interface for performing operations on a Milter context.
+
+The main project web page for this module is:
+
+ http://sourceforge.net/projects/sendmail-milter/
+
+
+Prerequisites
+-------------
+
+Sendmail::Milter has been tested with the following:
+
+ sendmail 8.12.1 built with -DMILTER
+ perl 5.6.1 built with -Dusethreads
+
+You can find the latest version of sendmail from:
+
+ ftp://ftp.sendmail.org/pub/sendmail/
+
+You can try this module out with newer versions of Perl, hopefully interpreter
+threads support will come out of its experimental state in the future.
+
+You'll also need to have an operating system with a viable POSIX threads
+implementation.
+
+This module has only been tested on FreeBSD 4.0-RELEASE. Your mileage may vary.
+
+Sendmail::Milter uses the new perl_clone() call in 5.6.0 to make copies of the
+Perl interpreter for its interpreter pools (see intpools.c and intpools.h). See
+the perldelta manpage for more information on this feature.
+
+
+Before You Begin
+----------------
+
+Read the libmilter/README file that comes with the sendmail source
+distribution to find out how to build sendmail with the Mail Filter API.
+
+
+Building Sendmail::Milter
+-------------------------
+
+Begin by building sendmail, libmilter, and perl with -Dusethreads. Next,
+perform the following commands:
+
+% perl Makefile.PL ../sendmail ../sendmail/obj.FreeBSD.4.0-RELEASE.i386
+% make
+% make install
+
+The paths ../sendmail and ../sendmail/obj.FreeBSD.4.0-RELEASE.i386 should point
+to the sendmail source tree and the sendmail build directory, respectively.
+
+
+Using Sendmail::Milter
+----------------------
+
+See the pod documentation for complete information on writing your own mail
+filters with this module.
+
+
+Testing the sample sample.pl mail filter
+----------------------------------------
+
+sample.pl, a sample test case has been provided. You can run it by using the
+following command:
+
+% perl sample.pl myfilter /etc/mail/sendmail.cf
+
+But before you do that, add a line similar to:
+
+INPUT_MAIL_FILTER(`myfilter', `S=local:/var/run/perl.sock')dnl
+
+to your .mc file. sample.pl isn't terribly interesting, but should give you a
+good feel for how mail filters are written with Sendmail::Milter.
+
+
+Mailing List
+------------
+
+You can subscribe to the sendmail-milter-users at lists.sourceforge.net mailing
+list. Instructions on how to do so can be found off the Sendmail::Milter
+project page.
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..0241c77
--- /dev/null
+++ b/TODO
@@ -0,0 +1,10 @@
+TODO
+----
+o Init several interpreters at startup.
+
+o Interpreter pool manager that cleans up the number of interpreters back down
+ to the minimum if the system is idle.
+
+o Forking interpreters with IPC instead of threaded. (Since perlthreads are
+ becoming more stable, this should become less relevant down the road)
+
diff --git a/callbacks.c b/callbacks.c
new file mode 100644
index 0000000..5980829
--- /dev/null
+++ b/callbacks.c
@@ -0,0 +1,768 @@
+/*
+ * Copyright (c) 2000 Charles Ying. All rights reserved.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the same terms as sendmail itself.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <pthread.h>
+
+#include "intpools.h"
+
+#include "libmilter/mfapi.h"
+
+/* Keys for each callback for the register callback hash */
+
+#define KEY_CONNECT newSVpv("connect", 0)
+#define KEY_HELO newSVpv("helo", 0)
+#define KEY_ENVFROM newSVpv("envfrom", 0)
+#define KEY_ENVRCPT newSVpv("envrcpt", 0)
+#define KEY_HEADER newSVpv("header", 0)
+#define KEY_EOH newSVpv("eoh", 0)
+#define KEY_BODY newSVpv("body", 0)
+#define KEY_EOM newSVpv("eom", 0)
+#define KEY_ABORT newSVpv("abort", 0)
+#define KEY_CLOSE newSVpv("close", 0)
+
+/* Macro for pushing the SMFICTX * argument */
+
+#define XPUSHs_Sendmail_Milter_Context \
+ (XPUSHs(sv_2mortal(sv_setref_iv(NEWSV(25, 0), \
+ "Sendmail::Milter::Context", (IV) ctx))))
+
+/* Global callback variable names */
+
+#define GLOBAL_CONNECT "Sendmail::Milter::Callbacks::_xxfi_connect"
+#define GLOBAL_HELO "Sendmail::Milter::Callbacks::_xxfi_helo"
+#define GLOBAL_ENVFROM "Sendmail::Milter::Callbacks::_xxfi_envfrom"
+#define GLOBAL_ENVRCPT "Sendmail::Milter::Callbacks::_xxfi_envrcpt"
+#define GLOBAL_HEADER "Sendmail::Milter::Callbacks::_xxfi_header"
+#define GLOBAL_EOH "Sendmail::Milter::Callbacks::_xxfi_eoh"
+#define GLOBAL_BODY "Sendmail::Milter::Callbacks::_xxfi_body"
+#define GLOBAL_EOM "Sendmail::Milter::Callbacks::_xxfi_eom"
+#define GLOBAL_ABORT "Sendmail::Milter::Callbacks::_xxfi_abort"
+#define GLOBAL_CLOSE "Sendmail::Milter::Callbacks::_xxfi_close"
+
+
+/* Callback prototypes for first-level callback wrappers. */
+
+sfsistat hook_connect(SMFICTX *, char *, _SOCK_ADDR *);
+sfsistat hook_helo(SMFICTX *, char *);
+sfsistat hook_envfrom(SMFICTX *, char **);
+sfsistat hook_envrcpt(SMFICTX *, char **);
+sfsistat hook_header(SMFICTX *, char *, char *);
+sfsistat hook_eoh(SMFICTX *);
+sfsistat hook_body(SMFICTX *, u_char *, size_t);
+sfsistat hook_eom(SMFICTX *);
+sfsistat hook_abort(SMFICTX *);
+sfsistat hook_close(SMFICTX *);
+
+
+/* A structure for housing callbacks and their mutexes. */
+
+struct callback_cache_t
+{
+ SV *xxfi_connect;
+ SV *xxfi_helo;
+ SV *xxfi_envfrom;
+ SV *xxfi_envrcpt;
+ SV *xxfi_header;
+ SV *xxfi_eoh;
+ SV *xxfi_body;
+ SV *xxfi_eom;
+ SV *xxfi_abort;
+ SV *xxfi_close;
+};
+
+typedef struct callback_cache_t callback_cache_t;
+
+
+/* The Milter perl interpreter pool */
+
+static intpool_t I_pool;
+
+
+/* Routines for managing callback caches */
+
+void
+init_callback_cache(pTHX_ interp_t *interp)
+{
+ callback_cache_t *cache_ptr;
+
+ if (interp->cache != NULL)
+ return;
+
+ alloc_interpreter_cache(interp, sizeof(callback_cache_t));
+
+ cache_ptr = (callback_cache_t *)interp->cache;
+
+ cache_ptr->xxfi_connect = get_sv(GLOBAL_CONNECT, FALSE);
+ cache_ptr->xxfi_helo = get_sv(GLOBAL_HELO, FALSE);
+ cache_ptr->xxfi_envfrom = get_sv(GLOBAL_ENVFROM, FALSE);
+ cache_ptr->xxfi_envrcpt = get_sv(GLOBAL_ENVRCPT, FALSE);
+ cache_ptr->xxfi_header = get_sv(GLOBAL_HEADER, FALSE);
+ cache_ptr->xxfi_eoh = get_sv(GLOBAL_EOH, FALSE);
+ cache_ptr->xxfi_body = get_sv(GLOBAL_BODY, FALSE);
+ cache_ptr->xxfi_eom = get_sv(GLOBAL_EOM, FALSE);
+ cache_ptr->xxfi_abort = get_sv(GLOBAL_ABORT, FALSE);
+ cache_ptr->xxfi_close = get_sv(GLOBAL_CLOSE, FALSE);
+}
+
+
+/* Set global variables in the parent interpreter. */
+
+void
+init_callback(char *var_name, SV *parent_callback)
+{
+ SV *new_sv;
+
+ new_sv = get_sv(var_name, TRUE);
+ sv_setsv(new_sv, parent_callback);
+}
+
+
+/* Main interfaces. */
+
+void
+init_callbacks(max_interpreters, max_requests)
+ int max_interpreters;
+ int max_requests;
+{
+ init_interpreters(&I_pool, max_interpreters, max_requests);
+}
+
+
+SV *
+get_callback(perl_desc, key)
+ HV *perl_desc;
+ SV *key;
+{
+ HE *entry;
+
+ entry = hv_fetch_ent(perl_desc, key, 0, 0);
+
+ if (entry == NULL)
+ croak("couldn't fetch callback symbol from descriptor.");
+
+ return newSVsv(HeVAL(entry));
+}
+
+
+void
+register_callbacks(desc, name, my_callback_table, flags)
+ struct smfiDesc *desc;
+ char *name;
+ HV *my_callback_table;
+ int flags;
+{
+ memset(desc, '\0', sizeof(struct smfiDesc));
+
+ desc->xxfi_name = strdup(name);
+ desc->xxfi_version = SMFI_VERSION;
+ desc->xxfi_flags = flags;
+
+ if (hv_exists_ent(my_callback_table, KEY_CONNECT, 0))
+ {
+ init_callback(GLOBAL_CONNECT,
+ get_callback(my_callback_table, KEY_CONNECT));
+
+ desc->xxfi_connect = hook_connect;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_HELO, 0))
+ {
+ init_callback(GLOBAL_HELO,
+ get_callback(my_callback_table, KEY_HELO));
+
+ desc->xxfi_helo = hook_helo;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_ENVFROM, 0))
+ {
+ init_callback(GLOBAL_ENVFROM,
+ get_callback(my_callback_table, KEY_ENVFROM));
+
+ desc->xxfi_envfrom = hook_envfrom;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_ENVRCPT, 0))
+ {
+ init_callback(GLOBAL_ENVRCPT,
+ get_callback(my_callback_table, KEY_ENVRCPT));
+
+ desc->xxfi_envrcpt = hook_envrcpt;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_HEADER, 0))
+ {
+ init_callback(GLOBAL_HEADER,
+ get_callback(my_callback_table, KEY_HEADER));
+
+ desc->xxfi_header = hook_header;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_EOH, 0))
+ {
+ init_callback(GLOBAL_EOH,
+ get_callback(my_callback_table, KEY_EOH));
+
+ desc->xxfi_eoh = hook_eoh;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_BODY, 0))
+ {
+ init_callback(GLOBAL_BODY,
+ get_callback(my_callback_table, KEY_BODY));
+
+ desc->xxfi_body = hook_body;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_EOM, 0))
+ {
+ init_callback(GLOBAL_EOM,
+ get_callback(my_callback_table, KEY_EOM));
+
+ desc->xxfi_eom = hook_eom;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_ABORT, 0))
+ {
+ init_callback(GLOBAL_ABORT,
+ get_callback(my_callback_table, KEY_ABORT));
+
+ desc->xxfi_abort = hook_abort;
+ }
+
+ if (hv_exists_ent(my_callback_table, KEY_CLOSE, 0))
+ {
+ init_callback(GLOBAL_CLOSE,
+ get_callback(my_callback_table, KEY_CLOSE));
+
+ desc->xxfi_close = hook_close;
+ }
+}
+
+
+/* Second-layer callbacks. These do the actual work. */
+
+sfsistat
+callback_noargs(pTHX_ SV *callback, SMFICTX *ctx)
+{
+ int n;
+ sfsistat retval;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs_Sendmail_Milter_Context;
+
+ PUTBACK;
+
+ n = call_sv(callback, G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ /* Check the eval first. */
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ retval = SMFIS_TEMPFAIL;
+ }
+ else if (n == 1)
+ {
+ retval = (sfsistat) POPi;
+ }
+ else
+ {
+ retval = SMFIS_CONTINUE;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+sfsistat
+callback_s(pTHX_ SV *callback, SMFICTX *ctx, char *arg1)
+{
+ int n;
+ sfsistat retval;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs_Sendmail_Milter_Context;
+ XPUSHs(sv_2mortal(newSVpv(arg1, 0)));
+
+ PUTBACK;
+
+ n = call_sv(callback, G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ /* Check the eval first. */
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ retval = SMFIS_TEMPFAIL;
+ }
+ else if (n == 1)
+ {
+ retval = (sfsistat) POPi;
+ }
+ else
+ {
+ retval = SMFIS_CONTINUE;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+sfsistat
+callback_body(pTHX_ SV *callback, SMFICTX *ctx,
+ u_char *arg1, size_t arg2)
+{
+ int n;
+ sfsistat retval;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs_Sendmail_Milter_Context;
+ XPUSHs(sv_2mortal(newSVpvn(arg1, arg2)));
+ XPUSHs(sv_2mortal(newSViv((IV) arg2)));
+
+ PUTBACK;
+
+ n = call_sv(callback, G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ /* Check the eval first. */
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ retval = SMFIS_TEMPFAIL;
+ }
+ else if (n == 1)
+ {
+ retval = (sfsistat) POPi;
+ }
+ else
+ {
+ retval = SMFIS_CONTINUE;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+sfsistat
+callback_argv(pTHX_ SV *callback, SMFICTX *ctx, char **arg1)
+{
+ int n;
+ sfsistat retval;
+ char **iter = arg1;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs_Sendmail_Milter_Context;
+
+ while(iter != NULL)
+ {
+ if (*iter == NULL)
+ break;
+
+ XPUSHs(sv_2mortal(newSVpv(*iter, 0)));
+ iter++;
+ }
+
+ PUTBACK;
+
+ n = call_sv(callback, G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ /* Check the eval first. */
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ retval = SMFIS_TEMPFAIL;
+ }
+ else if (n == 1)
+ {
+ retval = (sfsistat) POPi;
+ }
+ else
+ {
+ retval = SMFIS_CONTINUE;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+sfsistat
+callback_ss(pTHX_ SV *callback, SMFICTX *ctx, char *arg1, char *arg2)
+{
+ int n;
+ sfsistat retval;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs_Sendmail_Milter_Context;
+ XPUSHs(sv_2mortal(newSVpv(arg1, 0)));
+ XPUSHs(sv_2mortal(newSVpv(arg2, 0)));
+
+ PUTBACK;
+
+ n = call_sv(callback, G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ /* Check the eval first. */
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ retval = SMFIS_TEMPFAIL;
+ }
+ else if (n == 1)
+ {
+ retval = (sfsistat) POPi;
+ }
+ else
+ {
+ retval = SMFIS_CONTINUE;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+sfsistat
+callback_ssockaddr(pTHX_ SV *callback, SMFICTX *ctx, char *arg1,
+ _SOCK_ADDR *arg_sa)
+{
+ int n;
+ sfsistat retval;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs_Sendmail_Milter_Context;
+
+ XPUSHs(sv_2mortal(newSVpv(arg1, 0)));
+
+ /* A Perl sockaddr_in is all we handle right now. */
+ if (arg_sa == NULL)
+ {
+ XPUSHs(sv_2mortal(newSVsv(&PL_sv_undef)));
+ }
+ else if (arg_sa->sa_family == AF_INET)
+ {
+ XPUSHs(sv_2mortal(newSVpvn((char *)arg_sa,
+ sizeof(_SOCK_ADDR))));
+ }
+ else
+ {
+ XPUSHs(sv_2mortal(newSVsv(&PL_sv_undef)));
+ }
+
+ PUTBACK;
+
+ n = call_sv(callback, G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ /* Check the eval first. */
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ retval = SMFIS_TEMPFAIL;
+ }
+ else if (n == 1)
+ {
+ retval = (sfsistat) POPi;
+ }
+ else
+ {
+ retval = SMFIS_CONTINUE;
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+
+/* First-layer callbacks */
+
+sfsistat
+hook_connect(ctx, hostname, hostaddr)
+ SMFICTX *ctx;
+ char *hostname;
+ _SOCK_ADDR *hostaddr;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_connect;
+
+ retval = callback_ssockaddr(aTHX_ callback, ctx,
+ hostname, hostaddr);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_helo(ctx, helohost)
+ SMFICTX *ctx;
+ char *helohost;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_helo;
+
+ retval = callback_s(aTHX_ callback, ctx, helohost);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_envfrom(ctx, argv)
+ SMFICTX *ctx;
+ char **argv;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_envfrom;
+
+ retval = callback_argv(aTHX_ callback, ctx, argv);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_envrcpt(ctx, argv)
+ SMFICTX *ctx;
+ char **argv;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_envrcpt;
+
+ retval = callback_argv(aTHX_ callback, ctx, argv);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_header(ctx, headerf, headerv)
+ SMFICTX *ctx;
+ char *headerf;
+ char *headerv;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_header;
+
+ retval = callback_ss(aTHX_ callback, ctx, headerf, headerv);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_eoh(ctx)
+ SMFICTX *ctx;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_eoh;
+
+ retval = callback_noargs(aTHX_ callback, ctx);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_body(ctx, bodyp, bodylen)
+ SMFICTX *ctx;
+ u_char *bodyp;
+ size_t bodylen;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_body;
+
+ retval = callback_body(aTHX_ callback, ctx, bodyp, bodylen);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_eom(ctx)
+ SMFICTX *ctx;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_eom;
+
+ retval = callback_noargs(aTHX_ callback, ctx);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_abort(ctx)
+ SMFICTX *ctx;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_abort;
+
+ retval = callback_noargs(aTHX_ callback, ctx);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
+sfsistat
+hook_close(ctx)
+ SMFICTX *ctx;
+{
+ interp_t *interp;
+ sfsistat retval;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&I_pool)) == NULL)
+ croak("could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ init_callback_cache(aTHX_ interp);
+ callback = ((callback_cache_t *)(interp->cache))->xxfi_close;
+
+ retval = callback_noargs(aTHX_ callback, ctx);
+
+ unlock_interpreter(&I_pool, interp);
+
+ return retval;
+}
+
diff --git a/callbacks.h b/callbacks.h
new file mode 100644
index 0000000..1caf521
--- /dev/null
+++ b/callbacks.h
@@ -0,0 +1,15 @@
+/*
+ * Copyright (c) 2000 Charles Ying. All rights reserved.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the same terms as sendmail itself.
+ *
+ */
+
+#ifndef __CALLBACKS_H_
+#define __CALLBACKS_H_
+
+extern void init_callbacks(int, int);
+extern void register_callbacks(struct smfiDesc *, char *, HV *, int);
+
+#endif /* __CALLBACKS_H_ */
diff --git a/intpools.c b/intpools.c
new file mode 100644
index 0000000..72677dc
--- /dev/null
+++ b/intpools.c
@@ -0,0 +1,527 @@
+/*
+ * Copyright (c) 2000 Charles Ying. All rights reserved.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the same terms as perl itself.
+ *
+ * Please note that this code falls under a different license than the
+ * other code found in Sendmail::Milter.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <pthread.h>
+
+#include "intpools.h"
+
+/*
+** INIT_INTERPRETERS -- initialize the interpreter pool
+**
+** Parameters:
+** ipool -- interpreter pool
+** max_interp -- the maximum limit on interpreters allowed.
+** max_requests -- the maximum limit on requests perinterpreter.
+**
+** Returns:
+** none.
+**
+** Side Effects:
+** Sets up the global variables for the interpreter pool.
+*/
+
+void
+init_interpreters(ipool, max_interp, max_requests)
+ intpool_t *ipool;
+ int max_interp;
+ int max_requests;
+{
+ int error;
+
+ memset(ipool, 0, sizeof(intpool_t));
+
+ /* Initialize the mutex */
+ if ((error = pthread_mutex_init(&(ipool->ip_mutex), NULL)) != 0)
+ croak("intpool pthread_mutex_init failed: %d", error);
+
+ /* Initialize the condition variable */
+ if ((error = pthread_cond_init(&(ipool->ip_cond), NULL)) != 0)
+ croak("intpool pthread_cond_init() failed: %d", error);
+
+ /* Lock interpreter table */
+ if ((error = pthread_mutex_lock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_lock() failed: %d", error);
+
+ /* Critical section */
+
+ /* Initialize the max number of interpreters */
+ ipool->ip_max = max_interp;
+ ipool->ip_retire = max_requests;
+
+ /* Initialize the free table */
+ ipool->ip_freequeue = (AV*) newAV();
+
+ /* Set the number of busy interpreters to zero. */
+ ipool->ip_busycount = 0;
+
+ /* This is the global interpreter that thread wrappers will clone .*/
+ ipool->ip_parent = PERL_GET_CONTEXT;
+
+ /* End critical section */
+
+ /* Unlock interpreter table */
+ if ((error = pthread_mutex_unlock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_unlock() failed: %d", error);
+}
+
+
+/*
+** ALLOC_INTERPRETER_CACHE -- Allocate memory for interpreter cache.
+**
+** Parameters:
+** interp -- Interpreter to allocate cache for.
+** size -- Size of cache to allocate.
+**
+** Returns:
+** none.
+**
+** Warning:
+** This routine is not thread-safe.
+*/
+
+void
+alloc_interpreter_cache(interp_t *interp, size_t size)
+{
+ if ((interp->cache = malloc(size)) == NULL)
+ croak("failed to allocate memory for interpreter cache.");
+}
+
+/*
+** FREE_INTERPRETER_CACHE -- Free memory used by interpreter cache.
+**
+** Parameters:
+** interp -- Interpreter to free cache for.
+**
+** Returns:
+** none.
+**
+** Warning:
+** This routine is not thread-safe.
+*/
+
+void
+free_interpreter_cache(interp_t *interp)
+{
+ free(interp->cache);
+ interp->cache = NULL;
+}
+
+
+/*
+** CREATE_INTERPRETER -- create an interpreter from the parent.
+**
+** Parameters:
+** ipool -- interpreter pool
+**
+** Returns:
+** An interpreter context cloned off the parent.
+**
+** Warning:
+** This routine is not thread-safe.
+*/
+
+interp_t *
+create_interpreter(ipool)
+ intpool_t *ipool;
+{
+ interp_t *new_interp;
+
+ /* Clone the reference interpreter and use that. */
+ new_interp = (interp_t *) malloc(sizeof(interp_t));
+
+ new_interp->perl = perl_clone(ipool->ip_parent, FALSE);
+ new_interp->requests = 1;
+ new_interp->cache = NULL;
+
+ {
+ /* Hack from modperl until Perl 5.6.1 */
+ dTHXa(new_interp->perl);
+ if (PL_scopestack_ix == 0)
+ {
+ /* ENTER could expand. A lot. */
+ ENTER;
+ }
+ }
+
+ /* Restore the parent interpreter after a perl_clone() */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ return new_interp;
+}
+
+
+/*
+** CLEANUP_INTERPRETER -- destroy an interpreter
+**
+** Parameters:
+** ipool -- interpreter pool
+** del_interp - the interp_t to destroy.
+**
+** Returns:
+** none.
+**
+** Warning:
+** This routine is not thread-safe.
+*/
+
+void
+cleanup_interpreter(ipool, del_interp)
+ intpool_t *ipool;
+ interp_t *del_interp;
+{
+ perl_destruct(del_interp->perl);
+ perl_free(del_interp->perl);
+
+ free_interpreter_cache(del_interp);
+
+ free(del_interp);
+}
+
+
+/*
+** LOCK_INTERPRETER -- lock and retrieve a perl interpreter
+**
+** Parameters:
+** ipool -- interpreter pool
+**
+** Returns:
+** An interpreter context out of the interpreter pool.
+**
+** Side Effects:
+** The caller has exclusive rights to the interpreter
+** until the caller unlocks the interpreter.
+**
+** Warning:
+** This routine will block until a free interpreter
+** is available.
+**
+** (A timeout might be implemented in the future)
+*/
+
+interp_t *
+lock_interpreter(ipool)
+ intpool_t *ipool;
+{
+ int error;
+ SV *sv_value;
+ interp_t *new_interp;
+
+ /* Lock interpreter table */
+ if ((error = pthread_mutex_lock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_lock() failed: %d", error);
+
+ /* Critical section */
+
+ /*
+ ** Predicate: Any available interpreters? (Free or createable)
+ **
+ ** ASSERT: ipool->ip_busycount always contains the number of
+ ** interpreters that are locked in the system.
+ */
+
+ while ( !((ipool->ip_max == 0) ||
+ (ipool->ip_busycount < ipool->ip_max)) )
+ {
+ /* No. */
+
+ /* P(): Lock on the condition variable. */
+ if ((error = pthread_cond_wait( &(ipool->ip_cond),
+ &(ipool->ip_mutex) )) != 0)
+ {
+ croak("cond_wait failed waiting for interpreter: %d",
+ error);
+ }
+
+ /* When we wake up again, we might get a new interpreter. */
+ }
+
+ /* Restore the parent interpreter context */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ /* Any free interpreters on the queue? */
+ if (av_len(ipool->ip_freequeue) != -1)
+ {
+ /* Reuse an old interpreter */
+ sv_value = av_shift(ipool->ip_freequeue);
+
+ new_interp = (interp_t *) SvIV(sv_value);
+
+ /* Decrement the reference count. */
+ (void) SvREFCNT_dec(sv_value);
+
+ /* Increase the number of requests. */
+ new_interp->requests++;
+
+ /* Increment the number of busy interpreters */
+ ipool->ip_busycount++;
+ }
+ else /* No, there aren't, but we can still create one. */
+ {
+ new_interp = create_interpreter(ipool);
+
+ /* Increment the number of busy interpreters */
+ ipool->ip_busycount++;
+ }
+
+ /* End critical section */
+
+ /* Restore the parent interpreter context. */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ /* Unlock interpreter table */
+ if ((error = pthread_mutex_unlock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_unlock() failed: %d", error);
+
+ return new_interp;
+}
+
+
+/*
+** UNLOCK_INTERPRETER -- unlock a perl interpreter
+**
+** Parameters:
+** ipool -- interpreter pool
+** busy_interp -- the interpreter context to unlock.
+**
+** Returns:
+** none.
+**
+** Side Effects:
+** The interpreter is placed back in the interpreter pool
+** and the caller should immediately discard its pointer
+** to the interpreter.
+*/
+
+void
+unlock_interpreter(ipool, busy_interp)
+ intpool_t *ipool;
+ interp_t *busy_interp;
+{
+ int error;
+
+ /* Lock interpreter table */
+ if ((error = pthread_mutex_lock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_lock() failed: %d", error);
+
+ /* Critical section */
+
+ /* Restore the parent interpreter context. */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ /* ASSERT(ipool->ip_busycount > 0)
+ if (ipool->ip_busycount <= 0)
+ croak("internal error: busy_count reached zero unexpectedly.");
+
+ /* Decrement the number of busy interpreters */
+ ipool->ip_busycount--;
+
+ if ((ipool->ip_retire != 0) &&
+ (busy_interp->requests > ipool->ip_retire))
+ {
+ /* Interpreter is too old, recycle it. */
+ cleanup_interpreter(ipool, busy_interp);
+
+ busy_interp = create_interpreter(ipool);
+ }
+
+ /* Stick busy_interp in the free table */
+ (void) av_push(ipool->ip_freequeue, newSViv((IV) busy_interp));
+
+ /* V(): Signal a thread that a new interpreter is available. */
+ if ((error = pthread_cond_signal(&(ipool->ip_cond))) != 0)
+ {
+ croak("cond_signal failed to signal a free interpreter: %d",
+ error);
+ }
+
+ /* Restore the parent interpreter context. */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ /* End critical section */
+
+ /* Unlock interpreter table */
+ if ((error = pthread_mutex_unlock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_unlock() failed: %d", error);
+}
+
+
+/*
+** CLEANUP_INTERPRETERS -- clean up the interpreter pool
+**
+** Parameters:
+** ipool -- interpreter pool
+**
+** Returns:
+** none.
+**
+** Side Effects:
+** Shuts down and cleans up the interpreter pool.
+**
+** Warning:
+** All interpreters should be unlocked before
+** calling this routine.
+*/
+
+void
+cleanup_interpreters(ipool)
+ intpool_t *ipool;
+{
+ int error;
+ SV *sv_value;
+ interp_t *del_interp;
+
+ /* Lock interpreter table */
+ if ((error = pthread_mutex_lock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_lock() failed: %d", error);
+
+ /* Critical section */
+
+ /* Restore the original interpreter context. */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ /* At some point, we really should V() all of the waiting threads. */
+ while (av_len(ipool->ip_freequeue) != -1)
+ {
+ /* Reuse an old interpreter */
+ sv_value = av_shift(ipool->ip_freequeue);
+
+ del_interp = (interp_t *) SvIV(sv_value);
+
+ /* Decrement the reference count. */
+ (void) SvREFCNT_dec(sv_value);
+
+ cleanup_interpreter(ipool, del_interp);
+ }
+
+ av_undef(ipool->ip_freequeue);
+ ipool->ip_freequeue = NULL;
+
+ /* Restore the original interpreter context. */
+ PERL_SET_CONTEXT(ipool->ip_parent);
+
+ /* End critical section */
+
+ /* Unlock interpreter table */
+ if ((error = pthread_mutex_unlock(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_unlock() failed: %d", error);
+
+ /* Destroy the condition variable */
+ if ((error = pthread_cond_destroy(&(ipool->ip_cond))) != 0)
+ croak("intpool pthread_cond_destroy() failed: %d", error);
+
+ /* Destroy the intpool mutex */
+ if ((error = pthread_mutex_destroy(&(ipool->ip_mutex))) != 0)
+ croak("intpool pthread_mutex_destroy() failed: %d", error);
+}
+
+
+/* ---+ Interpreter pools test code. -------------------------------------- */
+
+typedef void *(*test_callback_ptr)(void *);
+
+static intpool_t T_pool;
+
+#define GLOBAL_TEST "Sendmail::Milter::Callbacks::_test_callback"
+
+void
+test_run_callback(pTHX_ SV *callback)
+{
+ int error;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ XPUSHs(sv_2mortal(newSViv((IV) aTHX)));
+
+ PUTBACK;
+
+ printf("test_wrapper: Analysing callback...\n");
+
+ if (SvROK(callback) && (SvTYPE(SvRV(callback)) == SVt_PVCV))
+ {
+ printf("test_wrapper: It's a code reference to: 0x%08x\n",
+ SvRV(callback));
+ }
+
+ if (SvPOK(callback))
+ {
+ int len;
+ printf("test_wrapper: pointer to string... string is '%s'\n",
+ SvPV(callback, len));
+ }
+
+ printf("test_wrapper: Calling callback 0x%08x from aTHX 0x%08x.\n",
+ callback, aTHX);
+
+ call_sv(callback, G_DISCARD);
+
+ SPAGAIN;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+}
+
+void *
+test_callback_wrapper(void *arg)
+{
+ interp_t *interp;
+ SV *callback;
+
+ if ((interp = lock_interpreter(&T_pool)) == NULL)
+ croak("test_wrapper: could not lock a new perl interpreter.");
+
+ PERL_SET_CONTEXT(interp->perl);
+
+ callback = get_sv(GLOBAL_TEST, FALSE);
+
+ test_run_callback(aTHX_ callback);
+
+ unlock_interpreter(&T_pool, interp);
+
+ return NULL;
+}
+
+int
+test_intpools(pTHX_ int max_interp, int max_requests, int i_max, int j_max,
+ SV* callback)
+{
+ int i;
+ int j;
+ pthread_t thread_id;
+ SV *global_callback;
+
+ printf("test_wrapper: Original interpreter cloned: 0x%08x\n", aTHX);
+
+ init_interpreters(&T_pool, max_interp, max_requests);
+
+ global_callback = get_sv(GLOBAL_TEST, TRUE);
+
+ sv_setsv(global_callback, callback);
+
+ for (i = 0; i < i_max; i++)
+ {
+ for (j = 0; j < j_max; j++)
+ pthread_create(&thread_id, NULL,
+ (test_callback_ptr) test_callback_wrapper,
+ (void *)NULL);
+
+ pthread_join(thread_id, NULL);
+ }
+
+ cleanup_interpreters(&T_pool);
+
+ return 1;
+}
diff --git a/intpools.h b/intpools.h
new file mode 100644
index 0000000..79015e8
--- /dev/null
+++ b/intpools.h
@@ -0,0 +1,57 @@
+/*
+ * Copyright (c) 2000 Charles Ying. All rights reserved.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the same terms as perl itself.
+ *
+ * Please note that this code falls under a different license than the
+ * other code found in Sendmail::Milter.
+ *
+ */
+
+#ifndef __INTPOOLS_H_
+#define __INTPOOLS_H_
+
+struct interp_t
+{
+ PerlInterpreter *perl;
+ void *cache;
+ int requests;
+};
+
+typedef struct interp_t interp_t;
+
+struct intpool_t
+{
+ pthread_mutex_t ip_mutex;
+ pthread_cond_t ip_cond;
+
+ PerlInterpreter *ip_parent;
+
+ int ip_max;
+ int ip_retire;
+
+ int ip_busycount;
+
+ AV* ip_freequeue;
+};
+
+typedef struct intpool_t intpool_t;
+
+
+extern void init_interpreters(intpool_t *, int, int);
+extern void cleanup_interpreters(intpool_t *);
+
+extern interp_t *lock_interpreter(intpool_t *);
+extern void unlock_interpreter(intpool_t *, interp_t *);
+
+extern interp_t *create_interpreter(intpool_t *);
+extern void cleanup_interpreter(intpool_t *, interp_t *);
+
+extern void alloc_interpreter_cache(interp_t *interp, size_t size);
+extern void free_interpreter_cache(interp_t *interp);
+
+extern int test_intpools(pTHX_ int, int, int, int, SV*);
+
+#endif /* __INTPOOLS_H_ */
+
diff --git a/sample.pl b/sample.pl
new file mode 100644
index 0000000..7385d3d
--- /dev/null
+++ b/sample.pl
@@ -0,0 +1,258 @@
+use ExtUtils::testlib;
+
+use Sendmail::Milter;
+use Socket;
+
+#
+# Each of these callbacks is actually called with a first argument
+# that is blessed into the pseudo-package Sendmail::Milter::Context. You can
+# use them like object methods of package Sendmail::Milter::Context.
+#
+# $ctx is a blessed reference of package Sendmail::Milter::Context to something
+# yucky, but the Mail Filter API routines are available as object methods
+# (sans the smfi_ prefix) from this
+#
+
+sub connect_callback
+{
+ my $ctx = shift; # Some people think of this as $self
+ my $hostname = shift;
+ my $sockaddr_in = shift;
+ my ($port, $iaddr);
+
+ print "my_connect:\n";
+ print " + hostname: '$hostname'\n";
+
+ if (defined $sockaddr_in)
+ {
+ ($port, $iaddr) = sockaddr_in($sockaddr_in);
+ print " + port: '$port'\n";
+ print " + iaddr: '" . inet_ntoa($iaddr) . "'\n";
+ }
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub helo_callback
+{
+ my $ctx = shift;
+ my $helohost = shift;
+
+ print "my_helo:\n";
+ print " + helohost: '$helohost'\n";
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub envfrom_callback
+{
+ my $ctx = shift;
+ my @args = @_;
+ my $message = "";
+
+ print "my_envfrom:\n";
+ print " + args: '" . join(', ', @args) . "'\n";
+
+ $ctx->setpriv(\$message);
+ print " + private data allocated.\n";
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub envrcpt_callback
+{
+ my $ctx = shift;
+ my @args = @_;
+
+ print "my_envrcpt:\n";
+ print " + args: '" . join(', ', @args) . "'\n";
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub header_callback
+{
+ my $ctx = shift;
+ my $headerf = shift;
+ my $headerv = shift;
+
+ print "my_header:\n";
+ print " + field: '$headerf'\n";
+ print " + value: '$headerv'\n";
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub eoh_callback
+{
+ my $ctx = shift;
+
+ print "my_eoh:\n";
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub body_callback
+{
+ my $ctx = shift;
+ my $body_chunk = shift;
+ my $len = shift;
+ my $message_ref = $ctx->getpriv();
+
+ # Note: You don't need $len to have a good time.
+ # But it's there if you like.
+
+ print "my_body:\n";
+ print " + chunk len: $len\n";
+
+ ${$message_ref} .= $body_chunk;
+
+ $ctx->setpriv($message_ref);
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub eom_callback
+{
+ my $ctx = shift;
+ my $message_ref = $ctx->getpriv();
+ my $chunk;
+
+ print "my_eom:\n";
+ print " + adding line to message body...\n";
+
+ # Let's have some fun...
+ # Note: This doesn't support messages with MIME data.
+
+ # Pig-Latin, Babelfish, Double dutch, soo many possibilities!
+ # But we're boring...
+
+ ${$message_ref} .= "---> Append me to this message body!\r\n";
+
+ if (not $ctx->replacebody(${$message_ref}))
+ {
+ print " - write error!\n";
+ last;
+ }
+
+ $ctx->setpriv(undef);
+ print " + private data cleared.\n";
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub abort_callback
+{
+ my $ctx = shift;
+
+ print "my_abort:\n";
+
+ $ctx->setpriv(undef);
+ print " + private data cleared.\n";
+
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+sub close_callback
+{
+ my $ctx = shift;
+
+ print "my_close:\n";
+ print " + callback completed.\n";
+
+ return SMFIS_CONTINUE;
+}
+
+my %my_callbacks =
+(
+ 'connect' => \&connect_callback,
+ 'helo' => \&helo_callback,
+ 'envfrom' => \&envfrom_callback,
+ 'envrcpt' => \&envrcpt_callback,
+ 'header' => \&header_callback,
+ 'eoh' => \&eoh_callback,
+ 'body' => \&body_callback,
+ 'eom' => \&eom_callback,
+ 'abort' => \&abort_callback,
+ 'close' => \&close_callback,
+);
+
+BEGIN:
+{
+ if (scalar(@ARGV) < 2)
+ {
+ print "Usage: perl $0 <name_of_filter> <path_to_sendmail.cf>\n";
+ exit;
+ }
+
+ my $conn = Sendmail::Milter::auto_getconn($ARGV[0], $ARGV[1]);
+
+ print "Found connection info for '$ARGV[0]': $conn\n";
+
+ if ($conn =~ /^local:(.+)$/)
+ {
+ my $unix_socket = $1;
+
+ if (-e $unix_socket)
+ {
+ print "Attempting to unlink UNIX socket '$conn' ... ";
+
+ if (unlink($unix_socket) == 0)
+ {
+ print "failed.\n";
+ exit;
+ }
+ print "successful.\n";
+ }
+ }
+
+ if (not Sendmail::Milter::auto_setconn($ARGV[0], $ARGV[1]))
+ {
+ print "Failed to detect connection information.\n";
+ exit;
+ }
+
+ #
+ # The flags parameter is optional. SMFI_CURR_ACTS sets all of the
+ # current version's filtering capabilities.
+ #
+ # %Sendmail::Milter::DEFAULT_CALLBACKS is provided for you in getting
+ # up to speed quickly. I highly recommend creating a callback table
+ # of your own with only the callbacks that you need.
+ #
+
+ if (not Sendmail::Milter::register($ARGV[0], \%my_callbacks,
+ SMFI_CURR_ACTS))
+ {
+ print "Failed to register callbacks for $ARGV[0].\n";
+ exit;
+ }
+
+ print "Starting Sendmail::Milter $Sendmail::Milter::VERSION engine.\n";
+
+ if (Sendmail::Milter::main())
+ {
+ print "Successful exit from the Sendmail::Milter engine.\n";
+ }
+ else
+ {
+ print "Unsuccessful exit from the Sendmail::Milter engine.\n";
+ }
+}
diff --git a/test.pl b/test.pl
new file mode 100644
index 0000000..b062709
--- /dev/null
+++ b/test.pl
@@ -0,0 +1,81 @@
+#
+# Copyright (c) 2000 Charles Ying. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as perl itself.
+#
+# Please note that this code falls under a different license than the
+# other code found in Sendmail::Milter.
+#
+
+use ExtUtils::testlib;
+
+use Sendmail::Milter;
+
+sub dottedline { '-' x 72 . "\n"; }
+
+sub perl_callback
+{
+ my $interp = shift;
+
+ printf "---> Starting callback from interpreter: [0x%08x].\n", $interp;
+ sleep 1;
+ printf "---> Finished callback from interpreter: [0x%08x].\n", $interp;
+}
+
+print dottedline;
+print "Interpreter pool tests. See sample.pl for a sample Milter.\n";
+print dottedline;
+print "Running starvation test... (Core dump indicates failure ;-)\n";
+print dottedline;
+
+Sendmail::Milter::test_intpools(1, 0, 2, 2, \&perl_callback);
+
+# If we didn't core-dump, we're good. :)
+
+print dottedline;
+print "Starvation test successful.\n";
+print dottedline;
+print "Running multiplicity test... (Core dump indicates failure ;-)\n";
+print dottedline;
+
+Sendmail::Milter::test_intpools(0, 0, 2, 4, \&perl_callback);
+
+# If we didn't core-dump, we're good. :)
+
+print dottedline;
+print "Multiplicity test successful.\n";
+print dottedline;
+print "Running scalar function name test... (Core dump indicates failure ;-)\n";
+print dottedline;
+
+Sendmail::Milter::test_intpools(0, 0, 2, 2, 'perl_callback');
+
+print dottedline;
+print "Scalar function name test successful.\n";
+print dottedline;
+print "Running closure test... (Core dump indicates failure ;-)\n";
+print dottedline;
+
+Sendmail::Milter::test_intpools(0, 0, 2, 2, sub
+{
+ my $interp = shift;
+
+ printf "---> Starting callback from interpreter: [0x%08x].\n", $interp;
+ sleep 1;
+ printf "---> Finished callback from interpreter: [0x%08x].\n", $interp;
+});
+
+print dottedline;
+print "Closure test successful.\n";
+print dottedline;
+print "Running recycle test... (Core dump indicates failure ;-)\n";
+print dottedline;
+
+Sendmail::Milter::test_intpools(0, 1, 2, 4, \&perl_callback);
+
+print dottedline;
+print "Recycle test successful.\n";
+print dottedline;
+print "All tests finished successfully.\n";
+print dottedline;
diff --git a/typemap b/typemap
new file mode 100644
index 0000000..c7d3518
--- /dev/null
+++ b/typemap
@@ -0,0 +1,18 @@
+TYPEMAP
+Sendmail_Milter_Context T_PTROBJ_SPECIAL
+u_char * T_PV
+
+INPUT
+T_PTROBJ_SPECIAL
+ if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\"))
+ {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not of type ${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\")
+
+OUTPUT
+T_PTROBJ_SPECIAL
+ sv_setref_pv($arg, \"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\", (void*)$var);
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libsendmail-milter-perl.git
More information about the Pkg-perl-cvs-commits
mailing list