[Greylist-users] is alarm() thread-safe?

[Akihiro KAYAMA]

In article <200406250537.i5P5b72a006925 at cs.utexas.edu>,
"Fletcher Mattox" <fletcher at cs.utexas.edu> writes:

fletcher> Someone recently suggested auto whitelisting peers which have a server
fletcher> listening on port 25.  This seemed like a good idea to me, so I wrote
fletcher> some code to do it.  In envrcpt_callback(), I have something like this:
fletcher> 
fletcher>   my $ret = 0;
fletcher>   eval {
fletcher>     alarm 1;
fletcher>     $ret = &connect_to_server($server);		# does a connect()
fletcher>     alarm 0;
fletcher>   };
fletcher> 
fletcher> and I have set a handler in the startup code like this:
fletcher> 
fletcher>   $SIG{ALRM} = sub { die "timeout" };
fletcher> 
fletcher> This mostly works, but perl occasionally segfaults in the signal handler
fletcher> called from libthread.  Does this mean alarm() is not thread-safe?
fletcher> If so, how can I timeout the connect() to my smtp peer?
fletcher> 
fletcher> I'm using perl 5.8.4 with sendmail 8.13.0 on Solaris 9.

Although I'm not familiar with perl, it might be dangerous to mix
multithreading and signal in POSIX environment. Using non-blocking I/O
instead is safe.

My sample script is here. Code fragments are copied from perlfunc(1).

--
#!/usr/local/bin/perl

use Socket;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);

$remote = shift;
$port = 25;

$paddr = sockaddr_in($port, inet_aton($remote));
$proto = getprotobyname('tcp');

socket(SOCK, PF_INET, SOCK_STREAM, $proto);
$flags = fcntl(SOCK, F_GETFL, 0)
    or die "Can't get flags for the socket: $!\n";
$flags = fcntl(SOCK, F_SETFL, $flags | O_NONBLOCK)
    or die "Can't set flags for the socket: $!\n";

connect(SOCK, $paddr);
$rin = $win = $ein = '';
vec($rin,fileno(SOCK),1) = 1;
$timeout = 1;  # sec
($nfound,$timeleft) =
    select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
$line = "connection timeout";
if ($nfound > 0) {
    $line = <SOCK>;
    $line =~ tr/\r\n//d;
} 
close (SOCK);

if ($line =~ /^220/) {
    print "OK: $line\n";
} else {
    print "NG: $line\n";
}

-- kayama