Sendmail-Milter-0.18/ 40755 1751 1751 0 7360750605 13072 5ustar cyingcyingSendmail-Milter-0.18/sample.pl100644 1751 1751 11522 7136243067 15026 0ustar cyingcyinguse 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 \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"; } } Sendmail-Milter-0.18/README100644 1751 1751 6346 7360732046 14057 0ustar cyingcyingSendmail::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@lists.sourceforge.net mailing list. Instructions on how to do so can be found off the Sendmail::Milter project page. Sendmail-Milter-0.18/LICENSE100644 1751 1751 10030 7133524447 14207 0ustar cyingcying 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@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 $ Sendmail-Milter-0.18/Milter.xs100644 1751 1751 20477 7133524451 15025 0ustar cyingcying/* * 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 Sendmail-Milter-0.18/MANIFEST100644 1751 1751 215 7150002621 14257 0ustar cyingcyingChanges LICENSE MANIFEST README TODO Makefile.PL Milter.pm Milter.xs intpools.c intpools.h callbacks.c callbacks.h typemap sample.pl test.pl Sendmail-Milter-0.18/callbacks.h100644 1751 1751 567 7133524452 15244 0ustar cyingcying/* * 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_ */ Sendmail-Milter-0.18/test.pl100644 1751 1751 4151 7135006101 14465 0ustar cyingcying# # 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; Sendmail-Milter-0.18/intpools.c100644 1751 1751 26541 7135243653 15232 0ustar cyingcying/* * 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 #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; } Sendmail-Milter-0.18/typemap100644 1751 1751 612 7133524453 14546 0ustar cyingcyingTYPEMAP 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); Sendmail-Milter-0.18/Changes100644 1751 1751 2220 7360750306 14454 0ustar cyingcyingRevision 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. Sendmail-Milter-0.18/Makefile.PL100644 1751 1751 3603 7352064171 15140 0ustar cyingcyinguse 5.006; use strict; use ExtUtils::MakeMaker; use Config; if ((not $ARGV[0]) or (not $ARGV[1])) { print "Usage: perl Makefile.PL \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", ); Sendmail-Milter-0.18/intpools.h100644 1751 1751 2261 7135006101 15171 0ustar cyingcying/* * 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_ */ Sendmail-Milter-0.18/Milter.pm100644 1751 1751 54001 7360746302 15000 0ustar cyingcying# # 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('', ); $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 is a Perl extension to sendmail's Mail Filter API (Milter). B 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 header file. =head2 Main Functions B No functions are exported. You must call these functions explicitly from the B 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. 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, B, B, B, B, B, B, B, B, B. See the section B for more information on writing the callbacks themselves. For more information on capability flags, see the section B 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 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 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, C, C. 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 if it was successful. It is provided as a helper function and does not exist in the current Milter library. B 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. This function returns nonzero upon success, the undefined value otherwise. SENDMAIL_CF_FILENAME defaults to C if not specified. =item auto_getconn NAME [, SENDMAIL_CF_FILENAME] Similar to B, this function parses the sendmail .cf file for the appropriate X line containing the connection information for NAME. It does not, however, call B. 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 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 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. Most of that information applies here. Remember to return one of the B result codes from the callback routine. Remember there can be multiple message body chunks. And remember that only B is allowed to manipulate the headers, recipients, message body, etc. See the B<@EXPORT> section for information on the B result codes. Here is an example of a B 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 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 Each callback receives a Milter context object as the first argument. This context object is used in making Milter Context function calls. See B for more details. =over 4 =item B 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 syscall on the SMTP socket. You can use B to unpack it into a port and IP address. This callback should return one of the B result codes. =item B 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 result codes. =item B 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 result codes. =item B 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 result codes. =item B 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 result codes. =item B CTX Invoked at end of header. This callback should return one of the B result codes. =item B 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 result codes. =item B 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 in B. This callback should return one of the B result codes. =item B 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 is called, B will not be called and vice versa. This callback should return one of the B result codes. =item B 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 result codes. =back =head2 Milter Context Functions These routines are object methods that are part of the B pseudo-package for use by B 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 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>-Esetpriv 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>-Egetpriv 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>-Egetsymval 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>-Esetreply 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) SMTP reply code to be returned, e.g. C<551>. XCODE is the extended (B) 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 The B 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. =over 4 =item B<$ctx>-Eaddheader 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>-Echgheader 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>-Eaddrcpt 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>-Edelrcpt 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 or the address may not be deleted. This function returns nonzero upon success, the undefined value otherwise. =item B<$ctx>-Ereplacebody 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 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 will send a default result code of B 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 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 sample test case for more callback examples. =head1 AUTHOR Charles Ying, cying@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 Sendmail-Milter-0.18/TODO100644 1751 1751 500 7133524451 13626 0ustar cyingcyingTODO ---- 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) Sendmail-Milter-0.18/callbacks.c100644 1751 1751 33716 7135244264 15303 0ustar cyingcying/* * 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 #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; }