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 <ben...@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 lice...@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@localhost>, C<inet:3333@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, cy...@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-us...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits