# Bugs encountered were reported to bug-Danga-Socket@rt.cpan.org,
# fixed in Danga::Socket 1.62 and visible at:
# https://rt.cpan.org/Public/Dist/Display.html?Name=Danga-Socket
+#
+# fields:
+# sock: underlying socket
+# rbuf: scalarref, usually undef
+# wbuf: arrayref of coderefs or tmpio (autovivified))
+# (tmpio = [ GLOB, offset, [ length ] ])
package PublicInbox::DS;
use strict;
+use v5.10.1;
+use parent qw(Exporter);
use bytes;
use POSIX qw(WNOHANG);
use IO::Handle qw();
use Fcntl qw(SEEK_SET :DEFAULT O_APPEND);
use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
-use parent qw(Exporter);
-our @EXPORT_OK = qw(now msg_more);
-use warnings;
-use 5.010_001;
use Scalar::Util qw(blessed);
-
use PublicInbox::Syscall qw(:epoll);
use PublicInbox::Tmpfile;
-
-use fields ('sock', # underlying socket
- 'rbuf', # scalarref, usually undef
- 'wbuf', # arrayref of coderefs or tmpio (autovivified))
- # (tmpio = [ GLOB, offset, [ length ] ])
- );
-
use Errno qw(EAGAIN EINVAL);
use Carp qw(confess carp);
+our @EXPORT_OK = qw(now msg_more dwaitpid);
my $nextq; # queue for next_tick
my $wait_pids; # list of [ pid, callback, callback_arg ]
my $later_queue; # list of callbacks to run at some later interval
my $EXPMAP; # fd -> idle_time
our $EXPTIME = 180; # 3 minutes
-my ($later_timer, $reap_timer, $exp_timer);
+my ($later_timer, $reap_armed, $exp_timer);
my $ToClose; # sockets to close when event loop is done
our (
%DescriptorMap, # fd (num) -> PublicInbox::DS object
$PostLoopCallback, # subref to call at the end of each loop, if defined (global)
$LoopTimeout, # timeout of event loop in milliseconds
- $DoneInit, # if we've done the one-time module init yet
@Timers, # timers
$in_loop,
);
=cut
sub Reset {
+ $in_loop = undef; # first in case DESTROY callbacks use this
%DescriptorMap = ();
- $wait_pids = $later_queue = undef;
+ $wait_pids = $later_queue = $reap_armed = undef;
$EXPMAP = {};
- $nextq = $ToClose = $reap_timer = $later_timer = $exp_timer = undef;
+ $nextq = $ToClose = $later_timer = $exp_timer = undef;
$LoopTimeout = -1; # no timeout by default
@Timers = ();
$PostLoopCallback = undef;
- $DoneInit = 0;
$_io = undef; # closes real $Epoll FD
$Epoll = undef; # may call DSKQXS::DESTROY
-
- *EventLoop = *FirstTimeEventLoop;
}
=head2 C<< CLASS->SetLoopTimeout( $timeout ) >>
immediately.
=cut
-sub SetLoopTimeout {
- return $LoopTimeout = $_[1] + 0;
-}
+sub SetLoopTimeout { $LoopTimeout = $_[1] + 0 }
-=head2 C<< PublicInbox::DS::add_timer( $seconds, $coderef ) >>
+=head2 C<< PublicInbox::DS::add_timer( $seconds, $coderef, $arg) >>
Add a timer to occur $seconds from now. $seconds may be fractional, but timers
are not guaranteed to fire at the exact time you ask for.
=cut
-sub add_timer ($$) {
- my ($secs, $coderef) = @_;
+sub add_timer ($$;$) {
+ my ($secs, $coderef, $arg) = @_;
my $fire_time = now() + $secs;
- my $timer = [$fire_time, $coderef];
+ my $timer = [$fire_time, $coderef, $arg];
if (!@Timers || $fire_time >= $Timers[-1][0]) {
push @Timers, $timer;
fcntl($_io, F_SETFD, $fl | FD_CLOEXEC);
}
+# caller sets return value to $Epoll
sub _InitPoller
{
- return if $DoneInit;
- $DoneInit = 1;
-
if (PublicInbox::Syscall::epoll_defined()) {
- $Epoll = epoll_create();
- set_cloexec($Epoll) if (defined($Epoll) && $Epoll >= 0);
+ my $fd = epoll_create();
+ set_cloexec($fd) if (defined($fd) && $fd >= 0);
+ $fd;
} else {
my $cls;
for (qw(DSKQXS DSPoll)) {
last if eval "require $cls";
}
$cls->import(qw(epoll_ctl epoll_wait));
- $Epoll = $cls->new;
+ $cls->new;
}
- *EventLoop = *EpollEventLoop;
}
=head2 C<< CLASS->EventLoop() >>
C<PostLoopCallback> below for how to exit the loop.
=cut
-sub FirstTimeEventLoop {
- my $class = shift;
-
- _InitPoller();
-
- EventLoop($class);
-}
sub now () { clock_gettime(CLOCK_MONOTONIC) }
# Run expired timers
while (@Timers && $Timers[0][0] <= $now) {
my $to_run = shift(@Timers);
- $to_run->[1]->($now) if $to_run->[1];
+ $to_run->[1]->($to_run->[2]);
}
# timers may enqueue into nextq:
my $timeout = int(($Timers[0][0] - $now) * 1000) + 1;
# -1 is an infinite timeout, so prefer a real timeout
- return $timeout if $LoopTimeout == -1;
-
- # otherwise pick the lower of our regular timeout and time until
- # the next timer
- return $LoopTimeout if $LoopTimeout < $timeout;
- return $timeout;
+ ($LoopTimeout < 0 || $LoopTimeout >= $timeout) ? $timeout : $LoopTimeout;
}
# We can't use waitpid(-1) safely here since it can hit ``, system(),
# and other things. So we scan the $wait_pids list, which is hopefully
# not too big. We keep $wait_pids small by not calling dwaitpid()
# until we've hit EOF when reading the stdout of the child.
+
sub reap_pids {
- my $tmp = $wait_pids or return;
- $wait_pids = $reap_timer = undef;
- foreach my $ary (@$tmp) {
- my ($pid, $cb, $arg) = @$ary;
- my $ret = waitpid($pid, WNOHANG);
- if ($ret == 0) {
- push @$wait_pids, $ary; # autovivifies @$wait_pids
- } elsif ($cb) {
- eval { $cb->($arg, $pid) };
- }
- }
- # we may not be done, yet, and could've missed/masked a SIGCHLD:
- $reap_timer = add_timer(1, \&reap_pids) if $wait_pids;
+ $reap_armed = undef;
+ my $tmp = $wait_pids or return;
+ $wait_pids = undef;
+ foreach my $ary (@$tmp) {
+ my ($pid, $cb, $arg) = @$ary;
+ my $ret = waitpid($pid, WNOHANG);
+ if ($ret == 0) {
+ push @$wait_pids, $ary; # autovivifies @$wait_pids
+ } elsif ($ret == $pid) {
+ if ($cb) {
+ eval { $cb->($arg, $pid) };
+ warn "E: dwaitpid($pid) in_loop: $@" if $@;
+ }
+ } else {
+ warn "waitpid($pid, WNOHANG) = $ret, \$!=$!, \$?=$?";
+ }
+ }
+ # we may not be done, yet, and could've missed/masked a SIGCHLD:
+ $reap_armed //= requeue(\&reap_pids) if $wait_pids;
}
# reentrant SIGCHLD handler (since reap_pids is not reentrant)
-sub enqueue_reap ($) { push @$nextq, \&reap_pids }; # autovivifies
+sub enqueue_reap () { $reap_armed //= requeue(\&reap_pids) }
sub in_loop () { $in_loop }
$PostLoopCallback ? $PostLoopCallback->(\%DescriptorMap) : 1;
}
-sub EpollEventLoop {
+sub EventLoop {
+ $Epoll //= _InitPoller();
local $in_loop = 1;
+ my @events;
do {
- my @events;
- my $i;
my $timeout = RunTimers();
# get up to 1000 events
- my $evcount = epoll_wait($Epoll, 1000, $timeout, \@events);
- for ($i=0; $i<$evcount; $i++) {
+ epoll_wait($Epoll, 1000, $timeout, \@events);
+ for my $fd (@events) {
# it's possible epoll_wait returned many events, including some at the end
# that ones in the front triggered unregister-interest actions. if we
# can't find the %sock entry, it's because we're no longer interested
# in that event.
- $DescriptorMap{$events[$i]->[0]}->event_step;
+ $DescriptorMap{$fd}->event_step;
}
} while (PostEventLoop());
_run_later();
=cut
sub new {
my ($self, $sock, $ev) = @_;
- $self = fields::new($self) unless ref $self;
-
$self->{sock} = $sock;
my $fd = fileno($sock);
- _InitPoller();
-
+ $Epoll //= _InitPoller();
+retry:
if (epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, $ev)) {
if ($! == EINVAL && ($ev & EPOLLEXCLUSIVE)) {
$ev &= ~EPOLLEXCLUSIVE;
sub send_tmpio ($$) {
my ($sock, $tmpio) = @_;
- seek($tmpio->[0], $tmpio->[1], SEEK_SET) or return;
+ sysseek($tmpio->[0], $tmpio->[1], SEEK_SET) or return;
my $n = $tmpio->[2] // 65536;
$n = 65536 if $n > 65536;
- defined(my $to_write = read($tmpio->[0], my $buf, $n)) or return;
+ defined(my $to_write = sysread($tmpio->[0], my $buf, $n)) or return;
my $written = 0;
while ($to_write > 0) {
if (defined(my $w = syswrite($sock, $buf, $to_write, $written))) {
}
sub epbit ($$) { # (sock, default)
- ref($_[0]) eq 'IO::Socket::SSL' ? PublicInbox::TLS::epollbit() : $_[1];
+ $_[0]->can('stop_SSL') ? PublicInbox::TLS::epollbit() : $_[1];
}
# returns 1 if done, 0 if incomplete
sub flush_write ($) {
my ($self) = @_;
+ my $sock = $self->{sock} or return;
my $wbuf = $self->{wbuf} or return 1;
- my $sock = $self->{sock};
next_buf:
while (my $bref = $wbuf->[0]) {
goto next_buf;
}
} elsif ($! == EAGAIN) {
- epwait($sock, epbit($sock, EPOLLOUT) | EPOLLONESHOT);
+ my $ev = epbit($sock, EPOLLOUT) or return $self->close;
+ epwait($sock, $ev | EPOLLONESHOT);
return 0;
} else {
return $self->close;
# common for clients to break connections without warning,
# would be too noisy to log here:
if ($! == EAGAIN) {
- epwait($sock, epbit($sock, EPOLLIN) | EPOLLONESHOT);
+ my $ev = epbit($sock, EPOLLIN) or return $self->close;
+ epwait($sock, $ev | EPOLLONESHOT);
rbuf_idle($self, $rbuf);
0;
} else {
return 1 if $written == $to_write;
requeue($self); # runs: event_step -> flush_write
} elsif ($! == EAGAIN) {
- epwait($sock, epbit($sock, EPOLLOUT) | EPOLLONESHOT);
+ my $ev = epbit($sock, EPOLLOUT) or return $self->close;
+ epwait($sock, $ev | EPOLLONESHOT);
$written = 0;
} else {
return $self->close;
my $wbuf = $self->{wbuf};
if (MSG_MORE && (!defined($wbuf) || !scalar(@$wbuf)) &&
- ref($sock) ne 'IO::Socket::SSL') {
+ !$sock->can('stop_SSL')) {
my $n = send($sock, $_[1], MSG_MORE);
if (defined $n) {
my $nlen = bytes::length($_[1]) - $n;
my $sock = $self->{sock} or return;
return 1 if $sock->accept_SSL;
return $self->close if $! != EAGAIN;
- epwait($sock, PublicInbox::TLS::epollbit() | EPOLLONESHOT);
+ my $ev = PublicInbox::TLS::epollbit() or return $self->close;
+ epwait($sock, $ev | EPOLLONESHOT);
unshift(@{$self->{wbuf}}, \&accept_tls_step); # autovivifies
0;
}
my $sock = $self->{sock} or return;
return $self->close if $sock->stop_SSL(SSL_fast_shutdown => 1);
return $self->close if $! != EAGAIN;
- epwait($sock, PublicInbox::TLS::epollbit() | EPOLLONESHOT);
+ my $ev = PublicInbox::TLS::epollbit() or return $self->close;
+ epwait($sock, $ev | EPOLLONESHOT);
unshift(@{$self->{wbuf}}, \&shutdn_tls_step); # autovivifies
0;
}
# don't bother with shutdown($sock, 2), we don't fork+exec w/o CLOEXEC
-# or fork w/o exec, so no inadvertant socket sharing
+# or fork w/o exec, so no inadvertent socket sharing
sub shutdn ($) {
my ($self) = @_;
my $sock = $self->{sock} or return;
- if (ref($sock) eq 'IO::Socket::SSL') {
+ if ($sock->can('stop_SSL')) {
shutdn_tls_step($self);
} else {
$self->close;
}
}
-# must be called with eval, PublicInbox::DS may not be loaded (see t/qspawn.t)
-sub dwaitpid ($$$) {
- die "Not in EventLoop\n" unless $in_loop;
- push @$wait_pids, [ @_ ]; # [ $pid, $cb, $arg ]
-
- # We could've just missed our SIGCHLD, cover it, here:
- requeue(\&reap_pids);
+sub dwaitpid ($;$$) {
+ my ($pid, $cb, $arg) = @_;
+ if ($in_loop) {
+ push @$wait_pids, [ $pid, $cb, $arg ];
+ # We could've just missed our SIGCHLD, cover it, here:
+ enqueue_reap();
+ } else {
+ my $ret = waitpid($pid, 0);
+ if ($ret == $pid) {
+ if ($cb) {
+ eval { $cb->($arg, $pid) };
+ carp "E: dwaitpid($pid) !in_loop: $@" if $@;
+ }
+ } else {
+ carp "waitpid($pid, 0) = $ret, \$!=$!, \$?=$?";
+ }
+ }
}
sub _run_later () {