File Coverage

blib/lib/Sendmail/PMilter.pm
Criterion Covered Total %
statement 222 506 43.8
branch 6 144 4.1
condition 3 44 6.8
subroutine 72 95 75.7
pod 18 19 94.7
total 321 808 39.7


line stmt bran cond sub pod time code
1             =pod
2              
3             =head1 LICENCE
4              
5             Copyright (c) 2016-2019 G.W. Haywood. All rights reserved.
6             With thanks to all those who have trodden these paths before,
7             including
8             Copyright (c) 2002-2004 Todd Vierling. All rights reserved.
9              
10             Redistribution and use in source and binary forms, with or without
11             modification, are permitted provided that the following conditions are met:
12              
13             1. Redistributions of source code must retain the above copyright notices,
14             this list of conditions and the following disclaimer.
15              
16             2. Redistributions in binary form must reproduce the above copyright
17             notices, this list of conditions and the following disclaimer in the
18             documentation and/or other materials provided with the distribution.
19              
20             3. Neither the name of the author nor the names of contributors may be used
21             to endorse or promote products derived from this software without specific
22             prior written permission. In the case of G.W. Haywood this permission is
23             hereby now granted.
24              
25             THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
26             AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
27             IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
28             ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
29             LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
30             CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
31             SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
32             INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
33             CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
34             ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
35             POSSIBILITY OF SUCH DAMAGE.
36              
37             =cut
38              
39             package Sendmail::PMilter;
40              
41 1     1   59188 use 5.014; # Don't use 5.016 yet. That would enable feature 'unicode_strings', and we
  1         3  
42             # probably aren't quite ready for that. We're counting *characters* passed
43             # between us and Sendmail, and Sendmail thinks that they're *bytes*.
44 1     1   372 use parent 'Exporter';
  1         264  
  1         4  
45              
46 1     1   48 use strict;
  1         2  
  1         15  
47 1     1   4 use warnings;
  1         2  
  1         25  
48              
49 1     1   6 use Carp;
  1         1  
  1         47  
50 1     1   392 use Errno;
  1         1092  
  1         38  
51 1     1   398 use IO::Select;
  1         1383  
  1         39  
52 1     1   405 use POSIX;
  1         5166  
  1         5  
53 1     1   2899 use Socket;
  1         3151  
  1         331  
54 1     1   373 use Symbol;
  1         551  
  1         49  
55 1     1   480 use UNIVERSAL;
  1         11  
  1         3  
56              
57             our $VERSION = '1.20_01';
58             $VERSION = eval $VERSION;
59              
60             our $DEBUG = 0;
61              
62             =pod
63              
64             =head1 NAME
65              
66             Sendmail::PMilter - Perl binding of Sendmail Milter protocol
67              
68             =head1 SYNOPSIS
69              
70             use Sendmail::PMilter;
71              
72             my $milter = new Sendmail::PMilter;
73              
74             $milter->auto_setconn(NAME);
75             $milter->register(NAME, { CALLBACKS }[, FLAGS]);
76             $milter->main();
77              
78             =head1 DESCRIPTION
79              
80             Sendmail::PMilter is a mail filtering API implementing the Sendmail
81             Milter Protocol in Perl. This allows the administrator of Sendmail
82             (and perhaps other MTAs which implement the Milter Protocol) to use
83             pure Perl code to filter and modify mail during an SMTP connection.
84              
85             Over the years, the protocol which governs the communication between
86             qSendmail and its milters has passed through a number of revisions.
87              
88             This documentation is for Sendmail::PMilter versions 1.20 and later,
89             which now supports Milter Protocol Version 6. This is a substantial
90             upgrade from earlier versions, which at best supported up to Milter
91             Protocol Version 2 - this was first seen in Sendmail version 8.14.0
92             which was released on January 31st 2007.
93              
94             Sendmail::PMilter now uses neither the original Sendmail::Milter (it
95             is obsolete, badly flawed and unmaintained) nor the Sendmail::Milter
96             which was packaged with earlier versions of Sendmail::PMilter as a
97             temporary workaround for the broken original.
98              
99             For communications between the MTA and the milter, a 'dispatcher' acts
100             as a go-between. This must be chosen when the milter is initialized,
101             before it serves requests. Several dispatchers are provided within
102             the Sendmail::PMilter module, but in versions before 1.20 all the
103             dispatchers suffered from issues of varying gravity. The 'prefork'
104             dispatcher (see DISPATCHERS below) has now been extensively exercised
105             by the current maintainer, but although the others have been patched
106             from issue reports going back more than a decade from the time of
107             writing (June 2019) THEY HAVE NOT BEEN TESTED. Feedback via the CPAN
108             issue tracking system is encouraged. If you have developed your own
109             dispatcher you can either pass a code reference to set_dispatcher() or
110             set an environment variable to point to it. Sendmail::PMilter will
111             then use it instead of a built-in dispatcher.
112              
113             =head1 METHODS
114              
115             =cut
116              
117             ##### Protocol constants
118             # The SMFIS_* values here are not the same as those used in the Sendmail sources
119             # (see mfapi.h) so that hopefully "0" and "1" won't be used as response codes by
120             # mistake. The other protocol constants below are unchanged from those used in
121             # the Sendmail sources.
122              
123 1     1   67 use constant SMFIS_CONTINUE => 100;
  1         2  
  1         79  
124 1     1   5 use constant SMFIS_REJECT => 101;
  1         2  
  1         38  
125 1     1   5 use constant SMFIS_DISCARD => 102;
  1         1  
  1         32  
126 1     1   5 use constant SMFIS_ACCEPT => 103;
  1         1  
  1         32  
127 1     1   4 use constant SMFIS_TEMPFAIL => 104;
  1         2  
  1         31  
128 1     1   5 use constant SMFIS_ALL_OPTS => 110;
  1         2  
  1         32  
129              
130             # Milter progessing 'places' (see mfapi.h, values are the same).
131 1     1   4 use constant SMFIM_CONNECT => 0; # connect
  1         2  
  1         31  
132 1     1   5 use constant SMFIM_HELO => 1; # HELO/EHLO
  1         1  
  1         30  
133 1     1   4 use constant SMFIM_ENVFROM => 2; # MAIL FROM
  1         1  
  1         40  
134 1     1   5 use constant SMFIM_ENVRCPT => 3; # RCPT TO
  1         2  
  1         39  
135 1     1   5 use constant SMFIM_DATA => 4; # DATA
  1         1  
  1         44  
136 1     1   5 use constant SMFIM_EOM => 5; # END OF MESSAGE (final dot)
  1         2  
  1         34  
137 1     1   5 use constant SMFIM_EOH => 6; # END OF HEADER
  1         1  
  1         63  
138              
139             # Some of these things have been switched around from their order of
140             # presentation in the Sendmail sources but the values are the same.
141             ######################################################################
142             # Taken from .../sendmail-8.15.2/include/libmilter/mfdef.h
143             ######################################################################
144             #if _FFR_MDS_NEGOTIATE
145             # define MILTER_MDS_64K ((64 * 1024) - 1)
146             # define MILTER_MDS_256K ((256 * 1024) - 1)
147             # define MILTER_MDS_1M ((1024 * 1024) - 1)
148             #endif /* _FFR_MDS_NEGOTIATE */
149             ######################################################################
150             # These so-called 'protocols' apply to the SMFIP_* flags:
151             #define SMFI_V1_PROT 0x0000003FL The protocol of V1 filter. We won't bother with V1, it's obsolete.
152             #define SMFI_V2_PROT 0x0000007FL The protocol of V2 filter
153 1     1   5 use constant SMFI_V2_PROT => 0x0000007F; # The protocol flags available in Milter Protocol Version 2.
  1         1  
  1         55  
154             #use constant SMFI_V4_PROT => 0x000003FF; # The protocol flags available in Milter Protocol Version 4.
155 1     1   5 use constant SMFI_V6_PROT => 0x001FFFFF; # The protocol flags available in Milter Protocol Version 6.
  1         1  
  1         34  
156 1     1   4 use constant SMFI_CURR_PROT => 0x001FFFFF; # The protocol flags available in the current Milter Protocol Version (which at July 2019 is Version 6).
  1         2  
  1         41  
157             ######################################################################
158             # What the MTA can send/filter wants in protocol
159 1     1   5 use constant SMFIP_NOCONNECT => 0x00000001; # MTA should not send connect info
  1         1  
  1         42  
160 1     1   5 use constant SMFIP_NOHELO => 0x00000002; # MTA should not send HELO info
  1         2  
  1         39  
161 1     1   5 use constant SMFIP_NOMAIL => 0x00000004; # MTA should not send MAIL info
  1         2  
  1         36  
162 1     1   5 use constant SMFIP_NORCPT => 0x00000008; # MTA should not send RCPT info
  1         14  
  1         36  
163 1     1   5 use constant SMFIP_NOBODY => 0x00000010; # MTA should not send body
  1         2  
  1         47  
164 1     1   5 use constant SMFIP_NOHDRS => 0x00000020; # MTA should not send headers
  1         2  
  1         176  
165 1     1   6 use constant SMFIP_NOEOH => 0x00000040; # MTA should not send EOH
  1         2  
  1         42  
166 1     1   5 use constant SMFIP_NR_HDR => 0x00000080; # No reply for headers
  1         1  
  1         34  
167 1     1   4 use constant SMFIP_NOHREPL => 0x00000080; # No reply for headers (backward compatibility, do not use, same as SMFIP_NR_HDR)
  1         1  
  1         38  
168 1     1   5 use constant SMFIP_NOUNKNOWN => 0x00000100; # MTA should not send unknown commands
  1         2  
  1         32  
169 1     1   4 use constant SMFIP_NODATA => 0x00000200; # MTA should not send DATA
  1         1  
  1         40  
170 1     1   5 use constant SMFIP_SKIP => 0x00000400; # MTA understands SMFIS_SKIP called from EOM callback.
  1         2  
  1         39  
171 1     1   5 use constant SMFIP_RCPT_REJ => 0x00000800; # MTA should also send rejected RCPTs
  1         2  
  1         83  
172 1     1   6 use constant SMFIP_NR_CONN => 0x00001000; # No reply for connect
  1         1  
  1         44  
173 1     1   5 use constant SMFIP_NR_HELO => 0x00002000; # No reply for HELO
  1         2  
  1         41  
174 1     1   5 use constant SMFIP_NR_MAIL => 0x00004000; # No reply for MAIL
  1         1  
  1         109  
175 1     1   5 use constant SMFIP_NR_RCPT => 0x00008000; # No reply for RCPT
  1         2  
  1         49  
176 1     1   5 use constant SMFIP_NR_DATA => 0x00010000; # No reply for DATA
  1         2  
  1         32  
177 1     1   4 use constant SMFIP_NR_UNKN => 0x00020000; # No reply for UNKN
  1         1  
  1         38  
178 1     1   5 use constant SMFIP_NR_EOH => 0x00040000; # No reply for eoh
  1         1  
  1         38  
179 1     1   5 use constant SMFIP_NR_BODY => 0x00080000; # No reply for body chunk
  1         2  
  1         88  
180 1     1   5 use constant SMFIP_HDR_LEADSPC => 0x00100000; # header value leading space
  1         2  
  1         44  
181 1     1   5 use constant SMFIP_MDS_256K => 0x10000000; # MILTER_MAX_DATA_SIZE=256K
  1         2  
  1         47  
182 1     1   5 use constant SMFIP_MDS_1M => 0x20000000; # MILTER_MAX_DATA_SIZE=1M
  1         1  
  1         38  
183             ######################################################################
184             # Taken from .../sendmail-8.15.2/include/libmilter/mfapi.h, and
185             # reformatted a little.
186             ######################################################################
187             # These so-called 'actions' apply to the SMFIF_* flags:
188             #define SMFI_V1_ACTS 0x0000000FL The actions of V1 filter
189             #define SMFI_V2_ACTS 0x0000003FL The actions of V2 filter
190             #define SMFI_CURR_ACTS 0x000001FFL actions of current version
191             ######################################################################
192             #define SMFIF_NONE 0x00000000L no flags
193             #define SMFIF_ADDHDRS 0x00000001L filter may add headers
194             #define SMFIF_CHGBODY 0x00000002L filter may replace body
195             #define SMFIF_MODBODY SMFIF_CHGBODY backwards compatible
196             #define SMFIF_ADDRCPT 0x00000004L filter may add recipients
197             #define SMFIF_DELRCPT 0x00000008L filter may delete recipients
198             #define SMFIF_CHGHDRS 0x00000010L filter may change/delete headers
199             #define SMFIF_QUARANTINE 0x00000020L filter may quarantine envelope <<========= "envelope"???
200             #define SMFIF_CHGFROM 0x00000040L filter may change "from" (envelope sender)
201             #define SMFIF_ADDRCPT_PAR 0x00000080L add recipients incl. args
202             #define SMFIF_SETSYMLIST 0x00000100L filter can send set of symbols (macros) that it wants
203             ######################################################################
204             # Capability FLAG value Available in milter protocol version (*)
205 1     1   4 use constant SMFIF_NONE => 0x0000; # Unused (*) There's a bit of a muddle about V3,
  1         1  
  1         30  
206 1     1   4 use constant SMFIF_ADDHDRS => 0x0001; # V1 Add headers but nobody's using it any more.
  1         2  
  1         29  
207 1     1   4 use constant SMFIF_MODBODY => 0x0002; # V1 Change body (for compatibility with old code, use SMFIF_CHGBODY in new code)
  1         2  
  1         41  
208 1     1   5 use constant SMFIF_CHGBODY => SMFIF_MODBODY; # V2 Change body
  1         2  
  1         41  
209 1     1   5 use constant SMFIF_ADDRCPT => 0x0004; # V1 Add recipient
  1         2  
  1         41  
210 1     1   5 use constant SMFIF_DELRCPT => 0x0008; # V1 Delete recipient
  1         1  
  1         38  
211 1     1   5 use constant SMFIF_CHGHDRS => 0x0010; # V2 Change headers
  1         1  
  1         40  
212 1     1   5 use constant SMFIF_QUARANTINE => 0x0020; # V2 quarantine entire message - last of the V2 flags
  1         2  
  1         41  
213 1     1   5 use constant SMFIF_CHGFROM => 0x0040; # V6 Change envelope sender
  1         2  
  1         131  
214 1     1   6 use constant SMFIF_ADDRCPT_PAR => 0x0080; # V6 Add recipients incl. args
  1         2  
  1         99  
215 1     1   5 use constant SMFIF_SETSYMLIST => 0x0100; # V6 Filter can send set of symbols (macros) that it wants
  1         2  
  1         53  
216              
217 1     1   6 use constant SMFI_V1_ACTS => SMFIF_ADDHDRS|SMFIF_CHGBODY|SMFIF_ADDRCPT|SMFIF_DELRCPT;
  1         6  
  1         55  
218 1     1   6 use constant SMFI_V2_ACTS => SMFI_V1_ACTS|SMFIF_CHGHDRS|SMFIF_QUARANTINE;
  1         2  
  1         50  
219 1     1   5 use constant SMFI_V6_ACTS => SMFI_V2_ACTS|SMFIF_CHGFROM|SMFIF_ADDRCPT_PAR|SMFIF_SETSYMLIST;
  1         2  
  1         122  
220 1     1   6 use constant SMFI_CURR_ACTS => SMFI_V6_ACTS; # All capabilities. See mfapi.h and mfdef.h
  1         2  
  1         38  
221              
222             # See libmilter/smfi.c
223 1     1   4 use constant MAXREPLYLEN => 980;
  1         2  
  1         42  
224 1     1   5 use constant MAXREPLIES => 32;
  1         2  
  1         2111  
225              
226             ##### Symbols exported to the caller
227              
228             my @smflags = qw(
229             SMFIP_NOCONNECT
230             SMFIP_NOHELO
231             SMFIP_NOMAIL
232             SMFIP_NORCPT
233             SMFIP_NOBODY
234             SMFIP_NOHDRS
235             SMFIP_NOEOH
236             SMFIP_NOUNKNOWN
237             SMFIP_NODATA
238             SMFIP_RCPT_REJ
239             SMFIP_SKIP
240             SMFIP_NR_CONN
241             SMFIP_NR_HELO
242             SMFIP_NR_MAIL
243             SMFIP_NR_RCPT
244             SMFIP_NR_DATA
245             SMFIP_NR_HDR
246             SMFIP_NR_EOH
247             SMFIP_NR_BODY
248             SMFIP_NR_UNKN
249             SMFIP_HDR_LEADSPC
250             SMFIP_MDS_256K
251             SMFIP_MDS_1M
252              
253             SMFIM_CONNECT
254             SMFIM_HELO
255             SMFIM_ENVFROM
256             SMFIM_ENVRCPT
257             SMFIM_DATA
258             SMFIM_EOM
259             SMFIM_EOH
260              
261             SMFIS_CONTINUE
262             SMFIS_REJECT
263             SMFIS_DISCARD
264             SMFIS_ACCEPT
265             SMFIS_TEMPFAIL
266             SMFIS_ALL_OPTS
267              
268             SMFIF_NONE
269             SMFIF_ADDHDRS
270             SMFIF_CHGBODY
271             SMFIF_ADDRCPT
272             SMFIF_DELRCPT
273             SMFIF_CHGHDRS
274             SMFIF_QUARANTINE
275             SMFIF_CHGFROM
276             SMFIF_ADDRCPT_PAR
277             SMFIF_SETSYMLIST
278              
279             SMFI_V2_ACTS
280             SMFI_V6_ACTS
281             SMFI_CURR_ACTS
282              
283             SMFI_V2_PROT
284             SMFI_V6_PROT
285             SMFI_CURR_PROT
286              
287             MAXREPLYLEN
288             MAXREPLIES
289             );
290             our @EXPORT_OK = (@smflags, qw(
291             %DEFAULT_CALLBACKS
292             ));
293             our %EXPORT_TAGS = ( all => [ @smflags ] );
294             our $enable_chgfrom = 0;
295              
296             my @callback_names = qw(negotiate connect helo envfrom envrcpt data header eoh body eom close abort unknown);
297             our %DEFAULT_CALLBACKS = map { $_ => $_.'_callback' } @callback_names;
298              
299             ##### Methods
300              
301             sub new ($) {
302 1     1 0 859 bless {}, shift;
303             }
304              
305             =pod
306              
307             =over 4
308              
309             =item get_max_interpreters()
310              
311             Returns the maximum number of interpreters passed to C. This is
312             only useful when called from within the dispatcher, as it is not set before
313             C is called.
314              
315             =cut
316              
317             sub get_max_interpreters ($) {
318 0     0 1 0 my $this = shift;
319              
320 0 0       0 $this->{max_interpreters} || 0;
321             }
322              
323             =pod
324              
325             =item get_max_requests()
326              
327             Returns the maximum number of requests per interpreter passed to C.
328             This is only useful when called from within the dispatcher, as it is not set
329             before C is called.
330              
331             =cut
332              
333             sub get_max_requests ($) {
334 0     0 1 0 my $this = shift;
335              
336 0 0       0 $this->{max_requests} || 0;
337             }
338              
339             =pod
340              
341             =item main([MAXCHILDREN[, MAXREQ]])
342              
343             This is the last method called in the main block of a milter program. If
344             successful, this call never returns; the protocol engine is launched and
345             begins accepting connections.
346              
347             MAXCHILDREN (default 0, meaning unlimited) specifies the maximum number of
348             connections that may be serviced simultaneously. If a connection arrives
349             with the number of active connections above this limit, the milter will
350             immediately return a temporary failure condition and close the connection.
351             Passing a value for MAXCHILDREN is optional.
352              
353             MAXREQ (default 0, meaning unlimited) is the maximum number of requests that
354             a child may service before being recycled. It is not guaranteed that the
355             interpreter will service this many requests, only that it will not go over
356             the limit. MAXCHILDREN must be given if MAXREQ is to be set.
357              
358             Any callback which Cs will have its output sent to C, followed by
359             a clean shutdown of the milter connection. To catch any warnings generated
360             by the callbacks, and any error messages caused by a C, set
361             C<$SIG{__WARN__}> to a user-defined subroutine. (See L.)
362              
363             =cut
364              
365             sub main ($;$$$) {
366 0     0 1 0 require Sendmail::PMilter::Context;
367              
368 0         0 my $this = shift;
369 0 0       0 croak 'main: socket not bound' unless defined($this->{socket});
370 0 0       0 croak 'main: callbacks not registered' unless defined($this->{callbacks});
371 0 0       0 croak 'main: milter protocol version not defined' unless defined($this->{'milter protocol version'});
372              
373 0         0 my $max_interpreters = shift;
374 0         0 my $max_requests = shift;
375              
376 0 0 0     0 $this->{max_interpreters} = $max_interpreters if (defined($max_interpreters) && $max_interpreters =~ /^\d+$/); # This test doesn't permit an empty string.
377 0 0 0     0 $this->{max_requests} = $max_requests if (defined($max_requests) && $max_requests =~ /^\d+$/);
378              
379 0         0 my $dispatcher = $this->{dispatcher};
380              
381 0 0       0 unless (defined($dispatcher)) {
382 0   0     0 my $dispatcher_name = ($ENV{PMILTER_DISPATCHER} || 'postfork').'_dispatcher';
383 0         0 $dispatcher = &{\&{qualify_to_ref($dispatcher_name, 'Sendmail::PMilter')}};
  0         0  
  0         0  
384             }
385              
386             my $handler = sub {
387 0     0   0 my $ctx = new Sendmail::PMilter::Context(shift, $this->{callbacks}, $this->{callback_flags}, $this->{'milter protocol version'});
388              
389 0         0 $ctx->main();
390 0         0 };
391              
392 0         0 &$dispatcher($this, $this->{socket}, $handler);
393 0         0 undef;
394             }
395              
396             =pod
397              
398             =item register(NAME, CALLBACKS[, FLAGS])
399              
400             Sets up the main milter loop configuration.
401              
402             NAME is the name of the milter. This should be the same name as passed to
403             auto_getconn() or auto_setconn(), but this PMilter implementation does not
404             enforce this.
405              
406             CALLBACKS is a hash reference containing one or more callback subroutines.
407             For example
408              
409             my %callbacks =
410             (
411             'negotiate' => \&my_negotiate_callback,
412             'connect' => \&my_connect_callback,
413             'helo' => \&my_helo_callback,
414             'envfrom' => \&my_envfrom_callback,
415             'close' => \&my_close_callback,
416             'abort' => \&my_abort_callback,
417             );
418             $milter->register( $milter_name, \%callbacks );
419              
420             If a callback is not named in this hashref, the caller's package will be
421             searched for subroutines named "CALLBACK_callback", where CALLBACK is the
422             name of the callback function.
423              
424             FLAGS is accepted for backward compatibility with older versions of
425             this module. Consider it deprecated. Set it to SMFI_V6_PROT for all
426             available 'actions' in any recent (last few years) Sendmail version.
427              
428             If no C callback is registered, then by default the protocol
429             steps available are as described in .../libmilter/engine.c in the
430             Sendmail sources. This means all the registered CALLBACKS plus the
431             SKIP function call which is allowed in the End Of Message callback.
432             Note that SMFIP_RCPT_REJ is specifically not included.
433              
434             C must be called successfully exactly once. If called a second
435             time, the previously registered callbacks will be erased.
436              
437             Returns 1 on success, undef on failure.
438              
439             =cut
440              
441             sub register ($$$;$) {
442 0     0 1 0 my $this = shift;
443 0         0 $this->{name} = shift;
444              
445 0 0       0 carp 'register: no name supplied' unless defined($this->{name});
446 0 0       0 carp 'register: passed ref as name argument' if ref($this->{name});
447              
448 0         0 my $callbacks = shift;
449 0         0 my $pkg = caller;
450              
451 0 0       0 croak 'register: callbacks is undef' unless defined($callbacks);
452 0 0       0 croak 'register: callbacks not hash ref' unless UNIVERSAL::isa($callbacks, 'HASH');
453              
454             # make internal copy, and convert to code references
455 0         0 $callbacks = { %$callbacks };
456              
457 0         0 foreach my $cbname (keys %DEFAULT_CALLBACKS) {
458 0         0 my $cb = $callbacks->{$cbname};
459 0 0 0     0 if (defined($cb) && !UNIVERSAL::isa($cb, 'CODE')) {
460 0         0 $cb = qualify_to_ref($cb, $pkg);
461 0 0       0 if (exists(&$cb)) {
462 0         0 $callbacks->{$cbname} = \&$cb;
463             } else {
464 0         0 delete $callbacks->{$cbname};
465             }
466             }
467             }
468              
469 0         0 $this->{callbacks} = $callbacks;
470 0   0     0 $this->{callback_flags} = shift || 0;
471             # MILTER PROTOCOL VERSION
472 0 0       0 $this->{'milter protocol version'} = ($this->{callback_flags} & ~0x3F) ? 6 : 2;
473 0         0 1;
474             }
475              
476             =pod
477              
478             =item setconn(DESC)
479              
480             Sets up the server socket with connection descriptor DESC. This is
481             identical to the descriptor syntax used by the "X" milter configuration
482             lines in sendmail.cf (if using Sendmail). This should be one of the
483             following:
484              
485             =over 2
486              
487             =item local:PATH
488              
489             A local ("UNIX") socket on the filesystem, named PATH. This has some smarts
490             that will auto-delete the pathname if it seems that the milter is not
491             currently running (but this currently contains a race condition that may not
492             be fixable; at worst, there could be two milters running with one never
493             receiving connections).
494              
495             =item inet:PORT[@HOST]
496              
497             An IPv4 socket, bound to address HOST (default INADDR_ANY), on port PORT.
498             It is not recommended to open milter engines to the world, so the @HOST part
499             should be specified.
500              
501             =item inet6:PORT[@HOST]
502              
503             An IPv6 socket, bound to address HOST (default INADDR_ANY), on port PORT.
504             This requires IPv6 support and the Perl INET6 package to be installed.
505             It is not recommended to open milter engines to the world, so the @HOST part
506             should be specified.
507              
508             =back
509              
510             Returns a true value on success, undef on failure.
511              
512             =cut
513              
514             sub setconn ($$) {
515 0     0 1 0 my $this = shift;
516 0         0 my $conn = shift;
517 0   0     0 my $backlog = $this->{backlog} || 5;
518 0         0 my $socket;
519              
520 0 0       0 croak "setconn: $conn: unspecified protocol"
521             unless ($conn =~ /^([^:]+):([^:@]+)(?:@([^:@]+|\[[0-9a-f:\.]+\]))?$/);
522              
523 0 0 0     0 if ($1 eq 'local' || $1 eq 'unix') {
    0          
    0          
524 0         0 require IO::Socket::UNIX;
525              
526 0         0 my $path = $2;
527 0         0 my $addr = sockaddr_un($path);
528              
529 0 0       0 croak "setconn: $conn: path not absolute"
530             unless ($path =~ m,^/,,);
531              
532 0 0 0     0 if (-e $path && ! -S $path) { # exists, not a socket
533 0         0 $! = Errno::EEXIST;
534             } else {
535 0         0 $socket = IO::Socket::UNIX->new(Type => SOCK_STREAM);
536             }
537              
538             # Some systems require you to unlink an orphaned inode.
539             # There's a race condition here, but it's unfortunately
540             # not easily fixable. Using an END{} block doesn't
541             # always work, and that's too wonky with fork() anyway.
542              
543 0 0 0     0 if (defined($socket) && !$socket->bind($addr)) {
544 0 0       0 if ($socket->connect($addr)) {
545 0         0 close $socket;
546 0         0 undef $socket;
547 0         0 $! = Errno::EADDRINUSE;
548             } else {
549 0         0 unlink $path; # race condition
550 0 0       0 $socket->bind($addr) || undef $socket;
551             }
552             }
553              
554 0 0       0 if (defined($socket)) {
555 0 0       0 $socket->listen($backlog) || croak "setconn: listen $conn: $!";
556             }
557             } elsif ($1 eq 'inet') {
558 0         0 require IO::Socket::INET;
559              
560 0         0 $socket = IO::Socket::INET->new(
561             Proto => 'tcp',
562             ReuseAddr => 1,
563             Listen => $backlog,
564             LocalPort => $2,
565             LocalAddr => $3
566             );
567             } elsif ($1 eq 'inet6') {
568 0         0 require IO::Socket::INET6;
569              
570 0         0 $socket = IO::Socket::INET6->new(
571             Proto => 'tcp',
572             ReuseAddr => 1,
573             Listen => $backlog,
574             LocalPort => $2,
575             LocalAddr => $3
576             );
577             } else {
578 0         0 croak "setconn: $conn: unknown protocol";
579             }
580              
581 0 0       0 if (defined($socket)) {
582 0         0 $this->set_socket($socket);
583             } else {
584 0         0 carp "setconn: $conn: $!";
585 0         0 undef;
586             }
587             }
588              
589             =pod
590              
591             =item set_dispatcher(CODEREF)
592              
593             Sets the dispatcher used to accept socket connections and hand them off to
594             the protocol engine. This allows pluggable resource allocation so that the
595             milter script may use fork, threads, or any other such means of handling
596             milter connections. See C below for more information.
597              
598             The subroutine (code) reference will be called by C when the
599             listening socket object is prepared and ready to accept connections. It
600             will be passed the arguments:
601              
602             MILTER, LSOCKET, HANDLER
603              
604             MILTER is the milter object currently running. LSOCKET is a listening
605             socket (an instance of C), upon which C should be
606             called. HANDLER is a subroutine reference which should be called, passing
607             the socket object returned by C<< LSOCKET->accept() >>.
608              
609             Note that the dispatcher may also be set from one of the off-the-shelf
610             dispatchers noted in this document by setting the PMILTER_DISPATCHER
611             environment variable. See C, below.
612              
613             =cut
614              
615             sub set_dispatcher($&) {
616 0     0 1 0 my $this = shift;
617              
618 0         0 $this->{dispatcher} = shift;
619 0         0 1;
620             }
621              
622             =pod
623              
624             =item set_listen(BACKLOG)
625              
626             Set the socket listen backlog to BACKLOG. The default is 5 connections if
627             not set explicitly by this method. Only useful before calling C.
628              
629             =cut
630              
631             sub set_listen ($$) {
632 0     0 1 0 my $this = shift;
633 0         0 my $backlog = shift;
634              
635 0 0       0 croak 'set_listen: socket already bound' if defined($this->{socket});
636              
637 0         0 $this->{backlog} = $backlog;
638 0         0 1;
639             }
640              
641             =pod
642              
643             =item set_socket(SOCKET)
644              
645             Rather than calling C, this method may be called explicitly to
646             set the C instance used to accept inbound connections.
647              
648             =cut
649              
650             sub set_socket ($$) {
651 0     0 1 0 my $this = shift;
652 0         0 my $socket = shift;
653              
654 0 0       0 croak 'set_socket: socket already bound' if defined($this->{socket});
655 0 0       0 croak 'set_socket: not an IO::Socket instance' unless UNIVERSAL::isa($socket, 'IO::Socket');
656              
657 0         0 $this->{socket} = $socket;
658 0         0 1;
659             }
660              
661             =pod
662              
663             =back
664              
665             =head1 SENDMAIL-SPECIFIC METHODS
666              
667             The following methods are only useful if Sendmail is the MTA connecting to
668             this milter. Other MTAs likely don't use Sendmail's configuration file, so
669             these methods would not be useful with them.
670              
671             =over 4
672              
673             =item auto_getconn(NAME[, CONFIG])
674              
675             Returns the connection descriptor for milter NAME in Sendmail configuration
676             file CONFIG (default C or whatever was set by
677             C). This can then be passed to setconn(), below.
678              
679             Returns a true value on success, undef on failure.
680              
681             =cut
682              
683             sub auto_getconn ($$;$) {
684 5     5 1 8 my $this = shift;
685 5   100     15 my $milter = shift || die "milter name not supplied\n";
686 4   33     12 my $cf = shift || $this->get_sendmail_cf();
687 4         11 local *CF;
688              
689 4 50       115 open(CF, '<'.$cf) || die "open $cf: $!";
690              
691 4         65 while () {
692 4         30 s/\s+$//; # also trims newlines
693              
694 4 50       31 s/^X([^,\s]+),\s*// || next;
695 4 50       14 ($milter eq $1) || next;
696              
697 4         18 while (s/^(.)=([^,\s]+)(,\s*|\Z)//) {
698 4 50       10 if ($1 eq 'S') {
699 4         51 close(CF);
700 4         37 return $2;
701             }
702             }
703             }
704              
705 0         0 close(CF);
706 0         0 undef;
707             }
708              
709             =pod
710              
711             =item auto_setconn(NAME[, CONFIG])
712              
713             Creates the server connection socket for milter NAME in Sendmail
714             configuration file CONFIG.
715              
716             Essentially, does:
717              
718             $milter->setconn($milter->auto_getconn(NAME, CONFIG))
719              
720             Returns a true value on success, undef on failure.
721              
722             =cut
723              
724             sub auto_setconn ($$;$) {
725 0     0 1 0 my $this = shift;
726 0         0 my $name = shift;
727 0         0 my $conn = $this->auto_getconn($name, shift);
728              
729 0 0       0 if (defined($conn)) {
730 0         0 $this->setconn($conn);
731             } else {
732 0         0 carp "auto_setconn: no connection for $name found";
733 0         0 undef;
734             }
735             }
736              
737             =pod
738              
739             =item get_sendmail_cf()
740              
741             Returns the pathname of the Sendmail configuration file. If this has
742             been set by C, then that is the value returned.
743             Otherwise the default pathname C is returned.
744              
745             =cut
746              
747             sub get_sendmail_cf ($) {
748 7     7 1 424 my $this = shift;
749              
750 7 100       33 $this->{sendmail_cf} || '/etc/mail/sendmail.cf';
751             }
752              
753             =pod
754              
755             =item get_sendmail_class(CLASS[, CONFIG])
756              
757             Returns a list containing all members of the Sendmail class CLASS, in
758             Sendmail configuration file CONFIG (default C or
759             whatever is set by C). Typically this is used to look up
760             the entries in class "w", the local hostnames class.
761              
762             =cut
763              
764             sub get_sendmail_class ($$;$) {
765 0     0 1 0 my $this = shift;
766 0         0 my $class = shift;
767 0   0     0 my $cf = shift || $this->get_sendmail_cf();
768 0         0 my %entries;
769 0         0 local *CF;
770              
771 0 0       0 open(CF, '<'.$cf) || croak "get_sendmail_class: open $cf: $!";
772              
773 0         0 while () {
774 0         0 s/\s+$//; # also trims newlines
775              
776 0 0       0 if (s/^C\s*$class\s*//) {
    0          
777 0         0 foreach (split(/\s+/)) {
778 0         0 $entries{$_} = 1;
779             }
780             } elsif (s/^F\s*$class\s*(-o)?\s*//) {
781 0         0 my $required = !defined($1);
782 0         0 local *I;
783              
784 0 0       0 croak "get_sendmail_class: class $class lookup resulted in pipe: $_" if (/^\|/);
785              
786 0 0       0 if (open(I, '<'.$_)) {
    0          
787 0         0 while () {
788 0         0 s/#.*$//;
789 0         0 s/\s+$//;
790 0 0       0 next if /^$/;
791 0         0 $entries{$_} = 1;
792             }
793 0         0 close(I);
794             } elsif ($required) {
795 0         0 croak "get_sendmail_class: class $class lookup: $_: $!";
796             }
797             }
798             }
799              
800 0         0 close(CF);
801 0         0 keys %entries;
802             }
803              
804             =pod
805              
806             =item get_sendmail_option(OPTION[, CONFIG])
807              
808             Returns a list containing the first occurrence of Sendmail option
809             OPTION in Sendmail configuration file CONFIG (default C,
810             or whatever has been set by C). Returns the
811             value of the option or undef if it is not found. This can be used
812             to learn configuration parameters such as Milter.maxdatasize.
813              
814             =cut
815              
816             sub get_sendmail_option ($$;$) {
817 0     0 1 0 my $this = shift;
818 0         0 my $option = shift;
819 0   0     0 my $cf = shift || $this->get_sendmail_cf();
820 0         0 my %entries;
821 0         0 local *CF;
822 0 0       0 open(CF, '<'.$cf) || croak "get_sendmail_option: open $cf: $!";
823 0         0 while () {
824 0         0 s/\s+$//; # also trims newlines
825 0 0       0 if (/^O\s*$option=(\d+)/) { return $1; }
  0         0  
826             }
827 0         0 close(CF);
828 0         0 undef;
829             }
830              
831             =pod
832              
833             =item set_sendmail_cf(FILENAME)
834              
835             Set the default filename used by C, C, and
836             C to find Sendmail-specific configuration data. If not
837             explicitly set by this method, it defaults to C.
838             Returns 1.
839              
840             =cut
841              
842             sub set_sendmail_cf ($) {
843 7     7 1 2112 my $this = shift;
844              
845 7         15 $this->{sendmail_cf} = shift;
846 7         20 1;
847             }
848              
849             ### off-the-shelf dispatchers
850              
851             =pod
852              
853             =back
854              
855             =head1 DISPATCHERS
856              
857             Milter requests may be dispatched to the protocol handler in a pluggable
858             manner (see the description for the C method above).
859             C offers some off-the-shelf dispatchers that use
860             different methods of resource allocation.
861              
862             Each of these is referenced as a non-object function, and return a value
863             that may be passed directly to C.
864              
865             =over 4
866              
867             =item Sendmail::PMilter::ithread_dispatcher()
868              
869             =item (environment) PMILTER_DISPATCHER=ithread
870              
871             June 2019: This dispatcher has not been tested adequately.
872              
873             The C dispatcher spins up a new thread upon each connection to
874             the milter socket. This provides a thread-based model that may be more
875             resource efficient than the similar C dispatcher. This requires
876             that the Perl interpreter be compiled with C<-Duseithreads>, and uses the
877             C module (available on Perl 5.8 or later only).
878              
879             =cut
880              
881             sub ithread_dispatcher {
882 0     0 1   require threads;
883 0           require threads::shared;
884 0           require Thread::Semaphore;
885              
886 0           my $nchildren = 0;
887              
888 0           threads::shared::share($nchildren);
889              
890             sub {
891 0     0     my $this = shift;
892 0           my $lsocket = shift;
893 0           my $handler = shift;
894 0           my $maxchildren = $this->get_max_interpreters();
895 0           my $child_sem;
896              
897 0 0         if ($maxchildren) {
898 0           $child_sem = Thread::Semaphore->new($maxchildren);
899             }
900            
901 0 0         my $siginfo = exists($SIG{INFO}) ? 'INFO' : 'USR1';
902             local $SIG{$siginfo} = sub {
903 0           warn "Number of active children: $nchildren\n";
904 0           };
905              
906             my $child_sub = sub {
907 0           my $socket = shift;
908              
909 0           eval {
910 0           &$handler($socket);
911 0           $socket->close();
912             };
913 0           my $died = $@;
914              
915 0           lock($nchildren);
916 0           $nchildren--;
917 0 0         if ($child_sem) {
918 0           $child_sem->up();
919             }
920 0 0         warn $died if $died;
921 0           };
922              
923 0           while (1) {
924 0           my $socket = $lsocket->accept();
925 0 0         next if $!{EINTR};
926              
927 0 0         warn "$$: incoming connection\n" if ($DEBUG > 0);
928              
929 0 0 0       if ($child_sem and ! $child_sem->down_nb()) {
930 0           warn "pausing for high load: children $nchildren >= max $maxchildren";
931 0           my $start = time();
932 0           $child_sem->down();
933 0           my $end = time();
934 0           warn sprintf("paused for %.1f seconds due to high load", $end - $start);
935             }
936              
937             # scoping block for lock()
938             {
939 0           lock($nchildren);
  0            
940 0   0       my $t = threads->create($child_sub, $socket) || die "thread creation failed: $!\n";
941 0           $t->detach;
942 0           threads->yield();
943 0           $nchildren++;
944             }
945             }
946 0           };
947             }
948              
949             =pod
950              
951             =item Sendmail::PMilter::prefork_dispatcher([PARAMS])
952              
953             =item (environment) PMILTER_DISPATCHER=prefork
954              
955             June 2019: This dispatcher has been tested extensively by the maintainer.
956              
957             The C dispatcher forks the main Perl process before accepting
958             connections, and uses the main process to monitor the children. This
959             should be appropriate for steady traffic flow sites. Note that if
960             MAXINTERP is not set in the call to C or in PARAMS, an internal
961             default of 10 processes will be used; similarly, if MAXREQ is not set, 100
962             requests will be served per child.
963              
964             Currently the child process pool is fixed in size: discarded children will
965             be replaced immediately.
966              
967             PARAMS, if specified, is a hash of key-value pairs defining parameters for
968             the dispatcher. The available parameters that may be set are:
969              
970             =over 2
971              
972             =item child_init
973              
974             subroutine reference that will be called after each child process is forked.
975             It will be passed the C object.
976              
977             =item child_exit
978              
979             subroutine reference that will be called just before each child process
980             terminates. It will be passed the C object.
981              
982             =item max_children
983              
984             Maximum number of child processes active at any time. Equivalent to the
985             MAXINTERP option to main() -- if not set in the main() call, this value
986             will be used.
987              
988             =item max_requests_per_child
989              
990             Maximum number of requests a child process may service before being
991             recycled. Equivalent to the MAXREQ option to main() -- if not set in the
992             main() call, this value will be used.
993              
994             =back
995              
996             =cut
997              
998             sub prefork_dispatcher (@) {
999 0     0 1   my %params = @_;
1000 0           my %children;
1001              
1002             my $child_dispatcher = sub {
1003 0     0     my $this = shift;
1004 0           my $lsocket = shift;
1005 0           my $handler = shift;
1006 0   0       my $max_requests = $this->get_max_requests() || $params{max_requests_per_child} || 100;
1007 0           my $i = 0;
1008              
1009 0           local $SIG{PIPE} = 'IGNORE'; # so close_callback will be reached
1010              
1011 0 0         my $siginfo = exists($SIG{INFO}) ? 'INFO' : 'USR1';
1012             local $SIG{$siginfo} = sub {
1013 0           warn "$$: requests handled: $i\n";
1014 0           };
1015              
1016             # call child_init handler if present
1017 0 0         if (defined $params{child_init}) {
1018 0           my $method = $params{child_init};
1019 0           $this->$method();
1020             }
1021              
1022 0           while ($i < $max_requests) {
1023 0           my $socket = $lsocket->accept();
1024 0 0         next if $!{EINTR};
1025              
1026 0 0         warn "$$: incoming connection\n" if ($DEBUG > 0);
1027              
1028 0           $i++;
1029 0           &$handler($socket);
1030 0           $socket->close();
1031             }
1032              
1033             # call child_exit handler if present
1034 0 0         if (defined $params{child_exit}) {
1035 0           my $method = $params{child_exit};
1036 0           $this->$method();
1037             }
1038 0           };
1039              
1040             # Propagate some signals down to the entire process group.
1041             my $killall = sub {
1042 0     0     my $sig = shift;
1043              
1044 0           kill 'TERM', keys %children;
1045 0           exit 0;
1046 0           };
1047 0           local $SIG{INT} = $killall;
1048 0           local $SIG{QUIT} = $killall;
1049 0           local $SIG{TERM} = $killall;
1050              
1051 0           setpgrp();
1052              
1053             sub {
1054 0     0     my $this = $_[0];
1055 0   0       my $maxchildren = $this->get_max_interpreters() || $params{max_children} || 10;
1056              
1057 0           while (1) {
1058 0           while (scalar keys %children < $maxchildren) {
1059 0           my $pid = fork();
1060 0 0         die "fork: $!" unless defined($pid);
1061              
1062 0 0         if ($pid) {
1063             # Perl reset these to IGNORE. Restore them.
1064 0           $SIG{INT} = $killall;
1065 0           $SIG{QUIT} = $killall;
1066 0           $SIG{TERM} = $killall;
1067 0           $children{$pid} = 1;
1068             } else {
1069             # Perl reset these to IGNORE. Set to defaults.
1070 0           $SIG{INT} = 'DEFAULT';
1071 0           $SIG{QUIT} = 'DEFAULT';
1072 0           $SIG{TERM} = 'DEFAULT';
1073 0           &$child_dispatcher(@_);
1074 0           exit 0;
1075             }
1076             }
1077              
1078             # Wait for a pid to exit, then loop back up to fork.
1079 0           my $pid = wait();
1080 0 0         delete $children{$pid} if ($pid > 0);
1081             }
1082 0           };
1083             }
1084              
1085             =pod
1086              
1087             =item Sendmail::PMilter::postfork_dispatcher()
1088              
1089             =item (environment) PMILTER_DISPATCHER=postfork
1090              
1091             June 2019: This dispatcher has not been tested adequately.
1092              
1093             This is the default dispatcher for PMilter if no explicit dispatcher is set.
1094              
1095             The C dispatcher forks the main Perl process upon each connection
1096             to the milter socket. This is adequate for machines that get bursty but
1097             otherwise mostly idle mail traffic, as the idle-time resource consumption is
1098             very low.
1099              
1100             If the maximum number of interpreters is running when a new connection
1101             comes in, this dispatcher blocks until a slot becomes available for a
1102             new interpreter.
1103              
1104             =cut
1105              
1106             sub postfork_dispatcher () {
1107 0     0 1   my $nchildren = 0;
1108 0           my $sigchld;
1109              
1110             $sigchld = sub {
1111 0     0     my $pid;
1112 0           $nchildren-- while (($pid = waitpid(-1, WNOHANG)) > 0);
1113 0           $SIG{CHLD} = $sigchld;
1114 0           };
1115              
1116             sub {
1117 0     0     my $this = shift;
1118 0           my $lsocket = shift;
1119 0           my $handler = shift;
1120 0           my $maxchildren = $this->get_max_interpreters();
1121              
1122             # Decrement child count on child exit.
1123 0           local $SIG{CHLD} = $sigchld;
1124              
1125 0 0         my $siginfo = exists($SIG{INFO}) ? 'INFO' : 'USR1';
1126             local $SIG{$siginfo} = sub {
1127 0           warn "Number of active children: $nchildren\n";
1128 0           };
1129              
1130 0           while (1) {
1131 0           my $socket = $lsocket->accept();
1132 0 0         next if !$socket;
1133              
1134 0 0         warn "$$: incoming connection\n" if ($DEBUG > 0);
1135              
1136             # If the load's too high, fail and go back to top of loop.
1137 0           my $paused = undef;
1138 0           while ($maxchildren) {
1139 0           my $cnchildren = $nchildren; # make constant
1140              
1141 0 0         if ($cnchildren >= $maxchildren) {
1142 0           warn "pausing for high load: children $cnchildren >= max $maxchildren";
1143 0 0         if ( ! $paused ) { $paused = time(); }
  0            
1144 0           pause();
1145             }
1146             else {
1147 0           last;
1148             }
1149             }
1150 0 0         if ($paused) {
1151 0           warn sprintf( "paused for %.1f seconds due to high load", time() - $paused );
1152             }
1153              
1154 0           my $pid = fork();
1155              
1156 0 0         if ($pid < 0) {
    0          
1157 0           die "fork: $!\n";
1158             } elsif ($pid) {
1159 0           $nchildren++;
1160 0 0         $socket->close() if defined($socket);
1161             } else {
1162 0           $lsocket->close();
1163 0           undef $lsocket;
1164 0           undef $@;
1165 0           $SIG{PIPE} = 'IGNORE'; # so close_callback will be reached
1166 0           $SIG{CHLD} = 'DEFAULT';
1167 0           $SIG{$siginfo} = 'DEFAULT';
1168              
1169 0           &$handler($socket);
1170 0 0         $socket->close() if defined($socket);
1171 0           exit 0;
1172             }
1173             }
1174 0           };
1175             }
1176              
1177             =pod
1178              
1179             =item Sendmail::PMilter::sequential_dispatcher()
1180              
1181             =item (environment) PMILTER_DISPATCHER=sequential
1182              
1183             June 2019: This dispatcher has not been tested adequately.
1184              
1185             The C dispatcher forces one request to be served at a time,
1186             making other requests wait on the socket for the next pass through the loop.
1187             This is not suitable for most production installations, but may be quite
1188             useful for milter debugging or other software development purposes.
1189              
1190             Note that, because the default socket backlog is 5 connections, if you
1191             use this dispatcher it may be wise to increase this backlog by calling
1192             C before entering C.
1193              
1194             =cut
1195              
1196             sub sequential_dispatcher () {
1197             sub {
1198 0     0     my $this = shift;
1199 0           my $lsocket = shift;
1200 0           my $handler = shift;
1201 0           local $SIG{PIPE} = 'IGNORE'; # so close_callback will be reached
1202              
1203 0           while (1) {
1204 0           my $socket = $lsocket->accept();
1205 0 0         next if $!{EINTR};
1206              
1207 0 0         warn "$$: incoming connection\n" if ($DEBUG > 0);
1208              
1209 0           &$handler($socket);
1210 0           $socket->close();
1211             }
1212 0     0 1   };
1213             }
1214              
1215             1;
1216             __END__