File Coverage

blib/lib/IO/Async/Loop/Ppoll.pm

Criterion	Covered	Total	%
statement	75	75	100.0
branch	7	10	70.0
condition	7	11	63.6
subroutine	16	16	100.0
pod	4	4	100.0
total	109	116	93.9

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2007-2020 -- [e-mail]

package IO::Async::Loop::Ppoll;

use strict;
use warnings;

our $VERSION = '0.10';
use constant API_VERSION => '0.76';

use IO::Async::Loop::Poll 0.76;
use base qw( IO::Async::Loop::Poll );

use Carp;

use IO::Ppoll qw( POLLIN POLLOUT POLLHUP );

use POSIX qw( EINTR SIG_BLOCK SIG_UNBLOCK sigprocmask sigaction );

use constant _CAN_WATCHDOG => 1;
use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE;

=head1 NAME

C - use C with C

=head1 SYNOPSIS

   use IO::Async::Loop::Ppoll;

   my $loop = IO::Async::Loop::Ppoll->new();

   $loop->add( ... );

   $loop->add( IO::Async::Signal->new(
         name =< 'HUP',
         on_receipt => sub { ... },
   ) );

   $loop->run;

=head1 DESCRIPTION

This subclass of C uses an C object instead
of a C to perform read-ready and write-ready tests so that they can
be mixed with signal handling.

The C system call atomically switches the process's signal mask,
performs a wait exactly as C would, then switches it back. This allows
a process to block the signals it cares about, but switch in an empty signal
mask during the poll, allowing it to handle file IO and signals concurrently.

=head1 CONSTRUCTOR

=cut

=head2 new

   $loop = IO::Async::Loop::Ppoll->new( %args )

This function returns a new instance of a C object.
It takes the following named arguments:

=over 8

=item C

The C object to use for notification. Optional; if a value is not
given, a new C object will be constructed.

=back

=cut

sub new
{
   my $class = shift;
   my ( %args ) = @_;

   my $poll = delete $args{poll};

   $poll ||= IO::Ppoll->new();

   my $self = $class->SUPER::new( %args, poll => $poll );

   $self->{signals} = {};

   return $self;
}

=head1 METHODS

As this is a subclass of L, all of its methods are
inherited. Expect where noted below, all of the class's methods behave
identically to C.

=cut

sub DESTROY
{
   my $self = shift;

   foreach my $signal ( keys %{ $self->{signals} } ) {
      $self->unwatch_signal( $signal );
   }
}

=head2 loop_once

   $count = $loop->loop_once( $timeout )

This method calls the C method on the stored C object,
passing in the value of C<$timeout>, and processes the results of that call.
It returns the total number of C callbacks invoked, or
C if the underlying C method returned an error. If the
C was interrupted by a signal, then 0 is returned instead.

=cut

sub loop_once
{
   my $self = shift;
   my ( $timeout ) = @_;

   $self->_adjust_timeout( \$timeout );

   my $poll = $self->{poll};

   $self->pre_wait;
   my $pollret = $poll->poll( $timeout );
   $self->post_wait;

   return undef if ( !defined $pollret or $pollret == -1 ) and $! != EINTR;

   my $count = 0;

   alarm( IO::Async::Loop->WATCHDOG_INTERVAL ) if WATCHDOG_ENABLE;

   my $signals = $self->{signals};
   foreach my $sigslot ( values %$signals ) {
      if( $sigslot->[1] ) {
         $sigslot->[0]->();
         $sigslot->[1] = 0;
         $count++;
      }
   }

   return $count + $self->post_poll();
}

# override
sub watch_signal
{
   my $self = shift;
   my ( $signal, $code ) = @_;

   exists $SIG{$signal} or croak "Unrecognised signal name $signal";

   # We cannot simply set $SIG{$signal} = $code here, because of perl bug
   #   http://rt.perl.org/rt3/Ticket/Display.html?id=82040
   # Instead, we'll store a tiny piece of code that just sets a flag, and
   # check the flags on return from the epoll_pwait call.

   $self->{signals}{$signal} = [ $code, 0, $SIG{$signal} ];
   my $pending = \$self->{signals}{$signal}[1];

   my $signum = $self->signame2num( $signal );
   sigprocmask( SIG_BLOCK, POSIX::SigSet->new( $signum ) );

   # Note this is an unsafe signal handler, and as such it should do as little
   # as possible.
   my $sigaction = POSIX::SigAction->new( sub { $$pending = 1 } );
   sigaction( $signum, $sigaction ) or croak "Unable to sigaction - $!";
}

# override
sub unwatch_signal
{
   my $self = shift;
   my ( $signal ) = @_;

   exists $SIG{$signal} or croak "Unrecognised signal name $signal";

   # When we saved the original value, we might have got an undef. But %SIG
   # doesn't like having undef assigned back in, so we need to translate
   $SIG{$signal} = $self->{signals}{$signal}[2] || 'DEFAULT';

   delete $self->{signals}{$signal};

   my $signum = $self->signame2num( $signal );

   sigprocmask( SIG_UNBLOCK, POSIX::SigSet->new( $signum ) );
}

=head1 SEE ALSO

=over 4

=item *

L - Object interface to Linux's C call

=item *

L - a set using an C object

=back

=head1 AUTHOR

Paul Evans

=cut

0x55AA;