use strict;
use v5.10.1;
use parent qw(Exporter);
-use bytes;
+use bytes qw(length substr); # FIXME(?): needed for PublicInbox::NNTP
use POSIX qw(WNOHANG sigprocmask SIG_SETMASK);
-use IO::Handle qw();
use Fcntl qw(SEEK_SET :DEFAULT O_APPEND);
use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
use Scalar::Util qw(blessed);
use PublicInbox::Syscall qw(:epoll);
use PublicInbox::Tmpfile;
use Errno qw(EAGAIN EINVAL);
-use Carp qw(carp);
-our @EXPORT_OK = qw(now msg_more dwaitpid);
+use Carp qw(carp croak);
+our @EXPORT_OK = qw(now msg_more dwaitpid add_timer add_uniq_timer);
+my %Stack;
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_armed, $exp_timer);
+my $reap_armed;
my $ToClose; # sockets to close when event loop is done
our (
%DescriptorMap, # fd (num) -> PublicInbox::DS object
$Epoll, # Global epoll fd (or DSKQXS ref)
- $_io, # IO::Handle for Epoll
+ $ep_io, # IO::Handle for Epoll
$PostLoopCallback, # subref to call at the end of each loop, if defined (global)
$LoopTimeout, # timeout of event loop in milliseconds
@Timers, # timers
+ %UniqTimer,
$in_loop,
);
=cut
sub Reset {
- $in_loop = undef; # first in case DESTROY callbacks use this
- %DescriptorMap = ();
- $wait_pids = $later_queue = $reap_armed = undef;
- $EXPMAP = {};
- $nextq = $ToClose = $later_timer = $exp_timer = undef;
- $LoopTimeout = -1; # no timeout by default
- @Timers = ();
-
- $PostLoopCallback = undef;
-
- $_io = undef; # closes real $Epoll FD
- $Epoll = undef; # may call DSKQXS::DESTROY
+ do {
+ $in_loop = undef; # first in case DESTROY callbacks use this
+ %DescriptorMap = ();
+ @Timers = ();
+ %UniqTimer = ();
+ $PostLoopCallback = undef;
+
+ # we may be iterating inside one of these on our stack
+ my @q = delete @Stack{keys %Stack};
+ for my $q (@q) { @$q = () }
+ $wait_pids = $nextq = $ToClose = undef;
+ $ep_io = undef; # closes real $Epoll FD
+ $Epoll = undef; # may call DSKQXS::DESTROY
+ } while (@Timers || keys(%Stack) || $nextq || $wait_pids ||
+ $ToClose || keys(%DescriptorMap) ||
+ $PostLoopCallback || keys(%UniqTimer));
+
+ $reap_armed = undef;
+ $LoopTimeout = -1; # no timeout by default
}
=head2 C<< CLASS->SetLoopTimeout( $timeout ) >>
=cut
sub SetLoopTimeout { $LoopTimeout = $_[1] + 0 }
-=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, $arg) = @_;
-
- my $fire_time = now() + $secs;
-
- my $timer = [$fire_time, $coderef, $arg];
-
- if (!@Timers || $fire_time >= $Timers[-1][0]) {
- push @Timers, $timer;
- return $timer;
- }
+sub _add_named_timer {
+ my ($name, $secs, $coderef, @args) = @_;
+ my $fire_time = now() + $secs;
+ my $timer = [$fire_time, $name, $coderef, @args];
- # Now, where do we insert? (NOTE: this appears slow, algorithm-wise,
- # but it was compared against calendar queues, heaps, naive push/sort,
- # and a bunch of other versions, and found to be fastest with a large
- # variety of datasets.)
- for (my $i = 0; $i < @Timers; $i++) {
- if ($Timers[$i][0] > $fire_time) {
- splice(@Timers, $i, 0, $timer);
- return $timer;
- }
- }
+ if (!@Timers || $fire_time >= $Timers[-1][0]) {
+ push @Timers, $timer;
+ return $timer;
+ }
- die "Shouldn't get here.";
+ # Now, where do we insert? (NOTE: this appears slow, algorithm-wise,
+ # but it was compared against calendar queues, heaps, naive push/sort,
+ # and a bunch of other versions, and found to be fastest with a large
+ # variety of datasets.)
+ for (my $i = 0; $i < @Timers; $i++) {
+ if ($Timers[$i][0] > $fire_time) {
+ splice(@Timers, $i, 0, $timer);
+ return $timer;
+ }
+ }
+ die "Shouldn't get here.";
}
-# keeping this around in case we support other FD types for now,
-# epoll_create1(EPOLL_CLOEXEC) requires Linux 2.6.27+...
-sub set_cloexec ($) {
- my ($fd) = @_;
+sub add_timer { _add_named_timer(undef, @_) }
- $_io = IO::Handle->new_from_fd($fd, 'r+') or return;
- defined(my $fl = fcntl($_io, F_GETFD, 0)) or return;
- fcntl($_io, F_SETFD, $fl | FD_CLOEXEC);
+sub add_uniq_timer { # ($name, $secs, $coderef, @args) = @_;
+ $UniqTimer{$_[0]} //= _add_named_timer(@_);
}
# caller sets return value to $Epoll
-sub _InitPoller
-{
- if (PublicInbox::Syscall::epoll_defined()) {
- my $fd = epoll_create();
- set_cloexec($fd) if (defined($fd) && $fd >= 0);
- $fd;
- } else {
- my $cls;
- for (qw(DSKQXS DSPoll)) {
- $cls = "PublicInbox::$_";
- last if eval "require $cls";
- }
- $cls->import(qw(epoll_ctl epoll_wait));
- $cls->new;
- }
+sub _InitPoller () {
+ if (defined $PublicInbox::Syscall::SYS_epoll_create) {
+ my $fd = epoll_create();
+ die "epoll_create: $!" if $fd < 0;
+ open($ep_io, '+<&=', $fd) or return;
+ fcntl($ep_io, F_SETFD, FD_CLOEXEC);
+ $fd;
+ } else {
+ my $cls;
+ for (qw(DSKQXS DSPoll)) {
+ $cls = "PublicInbox::$_";
+ last if eval "require $cls";
+ }
+ $cls->import(qw(epoll_ctl epoll_wait));
+ $cls->new;
+ }
}
-=head2 C<< CLASS->EventLoop() >>
-
-Start processing IO events. In most daemon programs this never exits. See
-C<PostLoopCallback> below for how to exit the loop.
-
-=cut
-
sub now () { clock_gettime(CLOCK_MONOTONIC) }
sub next_tick () {
- my $q = $nextq or return;
- $nextq = undef;
- for my $obj (@$q) {
- # we avoid "ref" on blessed refs to workaround a Perl 5.16.3 leak:
- # https://rt.perl.org/Public/Bug/Display.html?id=114340
- if (blessed($obj)) {
- $obj->event_step;
- } else {
- $obj->();
- }
- }
+ my $q = $nextq or return;
+ $nextq = undef;
+ $Stack{cur_runq} = $q;
+ for my $obj (@$q) {
+ # avoid "ref" on blessed refs to workaround a Perl 5.16.3 leak:
+ # https://rt.perl.org/Public/Bug/Display.html?id=114340
+ if (blessed($obj)) {
+ $obj->event_step;
+ } else {
+ $obj->();
+ }
+ }
+ delete $Stack{cur_runq};
}
# runs timers and returns milliseconds for next one, or next event loop
sub RunTimers {
- next_tick();
+ next_tick();
- return (($nextq || $ToClose) ? 0 : $LoopTimeout) unless @Timers;
+ return (($nextq || $ToClose) ? 0 : $LoopTimeout) unless @Timers;
- my $now = now();
+ my $now = now();
- # Run expired timers
- while (@Timers && $Timers[0][0] <= $now) {
- my $to_run = shift(@Timers);
- $to_run->[1]->($to_run->[2]);
- }
+ # Run expired timers
+ while (@Timers && $Timers[0][0] <= $now) {
+ my $to_run = shift(@Timers);
+ delete $UniqTimer{$to_run->[1] // ''};
+ $to_run->[2]->(@$to_run[3..$#$to_run]);
+ }
- # timers may enqueue into nextq:
- return 0 if ($nextq || $ToClose);
+ # timers may enqueue into nextq:
+ return 0 if ($nextq || $ToClose);
- return $LoopTimeout unless @Timers;
+ return $LoopTimeout unless @Timers;
- # convert time to an even number of milliseconds, adding 1
- # extra, otherwise floating point fun can occur and we'll
- # call RunTimers like 20-30 times, each returning a timeout
- # of 0.0000212 seconds
- my $timeout = int(($Timers[0][0] - $now) * 1000) + 1;
+ # convert time to an even number of milliseconds, adding 1
+ # extra, otherwise floating point fun can occur and we'll
+ # call RunTimers like 20-30 times, each returning a timeout
+ # of 0.0000212 seconds
+ my $timeout = int(($Timers[0][0] - $now) * 1000) + 1;
- # -1 is an infinite timeout, so prefer a real timeout
- ($LoopTimeout < 0 || $LoopTimeout >= $timeout) ? $timeout : $LoopTimeout;
+ # -1 is an infinite timeout, so prefer a real timeout
+ ($LoopTimeout < 0 || $LoopTimeout >= $timeout) ? $timeout : $LoopTimeout
}
sub sig_setmask { sigprocmask(SIG_SETMASK, @_) or die "sigprocmask: $!" }
$reap_armed = undef;
my $tmp = $wait_pids or return;
$wait_pids = undef;
+ $Stack{reap_runq} = $tmp;
my $oldset = block_signals();
foreach my $ary (@$tmp) {
my ($pid, $cb, $arg) = @$ary;
}
}
sig_setmask($oldset);
+ delete $Stack{reap_runq};
}
# reentrant SIGCHLD handler (since reap_pids is not reentrant)
$ToClose = undef; # will be autovivified on push
@$close_now = map { fileno($_) } @$close_now;
- # order matters, destroy expiry times, first:
- delete @$EXPMAP{@$close_now};
-
# ->DESTROY methods may populate ToClose
delete @DescriptorMap{@$close_now};
}
$PostLoopCallback ? $PostLoopCallback->(\%DescriptorMap) : 1;
}
-sub EventLoop {
- $Epoll //= _InitPoller();
- local $in_loop = 1;
- my @events;
- my $obj; # guard stack-not-refcounted w/ Carp + @DB::args
- do {
- my $timeout = RunTimers();
-
- # get up to 1000 events
- 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.
- $obj = $DescriptorMap{$fd};
- $obj->event_step;
- }
- } while (PostEventLoop());
- _run_later();
+# Start processing IO events. In most daemon programs this never exits. See
+# C<PostLoopCallback> for how to exit the loop.
+sub event_loop (;$$) {
+ my ($sig, $oldset) = @_;
+ $Epoll //= _InitPoller();
+ require PublicInbox::Sigfd if $sig;
+ my $sigfd = PublicInbox::Sigfd->new($sig, 1) if $sig;
+ local @SIG{keys %$sig} = values(%$sig) if $sig && !$sigfd;
+ local $SIG{PIPE} = 'IGNORE';
+ if (!$sigfd && $sig) {
+ # wake up every second to accept signals if we don't
+ # have signalfd or IO::KQueue:
+ sig_setmask($oldset);
+ PublicInbox::DS->SetLoopTimeout(1000);
+ }
+ $_[0] = $sigfd = $sig = undef; # $_[0] == sig
+ local $in_loop = 1;
+ my @events;
+ do {
+ my $timeout = RunTimers();
+
+ # get up to 1000 events
+ 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.
+
+ # guard stack-not-refcounted w/ Carp + @DB::args
+ my $obj = $DescriptorMap{$fd};
+ $obj->event_step;
+ }
+ } while (PostEventLoop());
}
=head2 C<< CLASS->SetPostLoopCallback( CODEREF ) >>
=head2 C<< CLASS->new( $socket ) >>
Create a new PublicInbox::DS subclass object for the given I<socket> which will
-react to events on it during the C<EventLoop>.
+react to events on it during the C<event_loop>.
This is normally (always?) called from your subclass via:
$DescriptorMap{$fd} = $self;
}
+# for IMAP, NNTP, and POP3 which greet clients upon connect
+sub greet {
+ my ($self, $sock) = @_;
+ my $ev = EPOLLIN;
+ my $wbuf;
+ if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
+ return CORE::close($sock) if $! != EAGAIN;
+ $ev = PublicInbox::TLS::epollbit() or return CORE::close($sock);
+ $wbuf = [ \&accept_tls_step, $self->can('do_greet')];
+ }
+ new($self, $sock, $ev | EPOLLONESHOT);
+ if ($wbuf) {
+ $self->{wbuf} = $wbuf;
+ } else {
+ $self->do_greet;
+ }
+ $self;
+}
#####################################################################
### I N S T A N C E M E T H O D S
$self->close;
}
-# n.b.: use ->write/->read for this buffer to allow compatibility with
-# PerlIO::mmap or PerlIO::scalar if needed
sub tmpio ($$$) {
- my ($self, $bref, $off) = @_;
- my $fh = tmpfile('wbuf', $self->{sock}, O_APPEND) or
- return drop($self, "tmpfile $!");
- $fh->autoflush(1);
- my $len = bytes::length($$bref) - $off;
- $fh->write($$bref, $len, $off) or return drop($self, "write ($len): $!");
- [ $fh, 0 ] # [1] = offset, [2] = length, not set by us
+ my ($self, $bref, $off) = @_;
+ my $fh = tmpfile('wbuf', $self->{sock}, O_APPEND) or
+ return drop($self, "tmpfile $!");
+ $fh->autoflush(1);
+ my $len = length($$bref) - $off;
+ my $n = syswrite($fh, $$bref, $len, $off) //
+ return drop($self, "write ($len): $!");
+ $n == $len or return drop($self, "wrote $n < $len bytes");
+ [ $fh, 0 ] # [1] = offset, [2] = length, not set by us
}
=head2 C<< $obj->write( $data ) >>
$bref->($self);
return 1;
} else {
- my $to_write = bytes::length($$bref);
+ my $to_write = length($$bref);
my $written = syswrite($sock, $$bref, $to_write);
if (defined $written) {
!$sock->can('stop_SSL')) {
my $n = send($sock, $_[1], MSG_MORE);
if (defined $n) {
- my $nlen = bytes::length($_[1]) - $n;
+ my $nlen = length($_[1]) - $n;
return 1 if $nlen == 0; # all done!
# queue up the unwritten substring:
my $tmpio = tmpio($self, \($_[1]), $n) or return 0;
}
}
+sub dflush {} # overridden by DSdeflate
+sub compressed {} # overridden by DSdeflate
+sub long_response_done {} # overridden by Net::NNTP
+
+sub long_step {
+ my ($self) = @_;
+ # wbuf is unset or empty, here; {long} may add to it
+ my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
+ my $more = eval { $cb->($self, @args) };
+ if ($@ || !$self->{sock}) { # something bad happened...
+ delete $self->{long_cb};
+ my $elapsed = now() - $t0;
+ $@ and warn("$@ during long response[$fd] - ",
+ sprintf('%0.6f', $elapsed),"\n");
+ $self->out(" deferred[$fd] aborted - %0.6f", $elapsed);
+ $self->close;
+ } elsif ($more) { # $self->{wbuf}:
+ # control passed to ibx_async_cat if $more == \undef
+ requeue_once($self) if !ref($more);
+ } else { # all done!
+ delete $self->{long_cb};
+ $self->long_response_done;
+ my $elapsed = now() - $t0;
+ my $fd = fileno($self->{sock});
+ $self->out(" deferred[$fd] done - %0.6f", $elapsed);
+ my $wbuf = $self->{wbuf}; # do NOT autovivify
+ requeue($self) unless $wbuf && @$wbuf;
+ }
+}
+
+sub requeue_once {
+ my ($self) = @_;
+ # COMPRESS users all share the same DEFLATE context.
+ # Flush it here to ensure clients don't see each other's data
+ $self->dflush;
+
+ # no recursion, schedule another call ASAP,
+ # but only after all pending writes are done.
+ # autovivify wbuf. wbuf may be populated by $cb,
+ # no need to rearm if so: (push returns new size of array)
+ $self->requeue if push(@{$self->{wbuf}}, \&long_step) == 1;
+}
+
+sub long_response ($$;@) {
+ my ($self, $cb, @args) = @_; # cb returns true if more, false if done
+ my $sock = $self->{sock} or return;
+ # make sure we disable reading during a long response,
+ # clients should not be sending us stuff and making us do more
+ # work while we are stream a response to them
+ $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
+ long_step($self); # kick off!
+ undef;
+}
+
sub dwaitpid ($;$$) {
my ($pid, $cb, $arg) = @_;
if ($in_loop) {
}
}
-sub _run_later () {
- my $run = $later_queue or return;
- $later_timer = $later_queue = undef;
- $_->() for @$run;
-}
-
-sub later ($) {
- push @$later_queue, $_[0]; # autovivifies @$later_queue
- $later_timer //= add_timer(60, \&_run_later);
-}
-
-sub expire_old () {
- my $now = now();
- my $exp = $EXPTIME;
- my $old = $now - $exp;
- my %new;
- while (my ($fd, $idle_at) = each %$EXPMAP) {
- if ($idle_at < $old) {
- my $ds_obj = $DescriptorMap{$fd};
- $new{$fd} = $idle_at if !$ds_obj->shutdn;
- } else {
- $new{$fd} = $idle_at;
- }
- }
- $EXPMAP = \%new;
- $exp_timer = scalar(keys %new) ? later(\&expire_old) : undef;
-}
-
-sub update_idle_time {
- my ($self) = @_;
- my $sock = $self->{sock} or return;
- $EXPMAP->{fileno($sock)} = now();
- $exp_timer //= later(\&expire_old);
-}
-
-sub not_idle_long {
- my ($self, $now) = @_;
- my $sock = $self->{sock} or return;
- my $idle_at = $EXPMAP->{fileno($sock)} or return;
- ($idle_at + $EXPTIME) > $now;
-}
-
1;
=head1 AUTHORS (Danga::Socket)