Very nice stuff, David.
Attached is a patch against 0.28-dev.
It only implements it in TcpServer, but that covers all thee major
uses, since SelectServer hasn't stabilized.
The one thing I'm wondering is if we've over-engineered this. At the
moment, we've only got TcpServer's loop and SelectServer's loop.
Maybe just using alarm() is acceptable. There's probably potential
for a leak, but we could store $self into a closure $SIG{ALRM} = sub {
$self->foo, $self->bar };
I do like the Timeout interface. It'll let us easily do things like
make sure plugins don't lock up.
I do see that TcpServer already has rudimentary timeout support -
it'll just exit -- and has for two years.
-R
Index: qpsmtpd-forkserver
===================================================================
RCS file: /cvs/public/qpsmtpd/qpsmtpd-forkserver,v
retrieving revision 1.3
diff -u -r1.3 qpsmtpd-forkserver
--- qpsmtpd-forkserver 15 Apr 2004 02:19:01 -0000 1.3
+++ qpsmtpd-forkserver 2 Jun 2004 05:12:13 -0000
@@ -45,7 +45,6 @@
or die "making socket: [EMAIL PROTECTED]";
# Drop priviledges
-my $user = 'mailfw';
my (undef, undef, $quid, $qgid) = getpwnam $USER or
die "unable to determine uid/gid for $USER\n";
$) = "";
Index: lib/Qpsmtpd/TcpServer.pm
===================================================================
RCS file: /cvs/public/qpsmtpd/lib/Qpsmtpd/TcpServer.pm,v
retrieving revision 1.9
diff -u -r1.9 TcpServer.pm
--- lib/Qpsmtpd/TcpServer.pm 5 Mar 2004 12:46:23 -0000 1.9
+++ lib/Qpsmtpd/TcpServer.pm 2 Jun 2004 05:12:13 -0000
@@ -1,6 +1,7 @@
package Qpsmtpd::TcpServer;
use Qpsmtpd::SMTP;
use Qpsmtpd::Constants;
+use Qpsmtpd::Timeout;
@ISA = qw(Qpsmtpd::SMTP);
use strict;
@@ -38,22 +39,29 @@
return if $rc != DONE;
# this should really be the loop and read_input should just get one line; I think
-
$self->read_input;
}
sub read_input {
my $self = shift;
-
+ set_timeout_handler { die "Timed Out" };
my $timeout = $self->config('timeout');
- alarm $timeout;
+ set_timeout $timeout;
+ enable_timeout;
+ eval {
while (<STDIN>) {
- alarm 0;
+ disable_timeout;
$_ =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGDEBUG, "dispatching $_");
defined $self->dispatch(split / +/, $_)
or $self->respond(502, "command unrecognized: '$_'");
- alarm $timeout;
+ enable_timeout;
+ }
+ };
+ if ($@ =~ /Timed Out/) {
+ $self->respond(421, "Session Timed Out. Click.");
+ $self->log(LOGERROR, "Timed Out. Disconnecting");
+ $self->disconnect();
}
}
Index: lib/Qpsmtpd/Timeout.pm
===================================================================
RCS file: lib/Qpsmtpd/Timeout.pm
diff -N lib/Qpsmtpd/Timeout.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ lib/Qpsmtpd/Timeout.pm 2 Jun 2004 05:12:13 -0000
@@ -0,0 +1,49 @@
+package Qpsmtpd::Timeout;
+
+my @EXPORT = qw(
+ set_timeout
+ enable_timeout
+ disable_timeout
+ set_timeout_handler
+ );
+
+sub import {
+ # quicky import routine for subs only
+ my ($pkg,$callpkg, $sym) = (shift,caller(0),undef);
+ no strict qw(refs);
+ *{"$callpkg\::$_"} = \&{"$pkg\::$_"} for (@EXPORT);
+}
+
+
+my $to; # timeout
+sub set_timeout($) { $to = shift }
+sub enable_timeout() { alarm($to) }
+sub disable_timeout() { alarm(0) }
+
+my $toh; # timeout handler
+$toh = sub { die "timed out\n" };
+
+sub set_timeout_handler(&){
+ $toh = shift;
+};
+$SIG{ALRM} = sub { &$toh };
+
+=head1 EXAMPLE
+
+ set_timeout $waiting_for_a_line;
+ enable_timeout;
+ undef($line); # what if the alarm goes off while
+ # we are disabling it?
+ set_timeout_handler { die "timed out XYZ" };
+ eval {
+ $line = <SOCK>;
+ disable_timeout;
+ };
+ if($@ && !$line){
+ if( $@ =~ /timed out XYZ/ ){
+ # wait longer? give up? i don't know
+ ...
+ }else{ die "readsock threw execption: $@" };
+ };
+
+=cut
