File Coverage

blib/lib/Linux/Perl/epoll.pm

Criterion	Covered	Total	%
statement	90	91	98.9
branch	15	20	75.0
condition	9	17	52.9
subroutine	17	17	100.0
pod	5	5	100.0
total	136	150	90.6

package Linux::Perl::epoll;

use strict;
use warnings;

=encoding utf-8

=head1 NAME

Linux::Perl::epoll

=head1 SYNOPSIS

    my $epl = Linux::Perl::epoll->new();

    $epl->add( $fh, events => ['IN', 'ET'] );

    my @events = $epl->wait(
        maxevents => 3,
        timeout => 2,   #seconds
        sigmask => ['INT', 'TERM'], #optional
    );

    $epl->delete($fh);

=head1 DESCRIPTION

An interface to Linux’s “epoll” feature.

Note that older kernel versions may not support all of the functionality
documented here. Check your system’s epoll documentation (i.e.,
C and the various system calls’ pages) for full details.

=cut

use Linux::Perl;
use Linux::Perl::Constants::Fcntl;
use Linux::Perl::EasyPack;
use Linux::Perl::ParseFlags;
use Linux::Perl::SigSet;

*_flag_CLOEXEC = \*Linux::Perl::Constants::Fcntl::flag_CLOEXEC;

=head1 METHODS

=head2 I->new( %OPTS )

Creates a new epoll instance. %OPTS are:

=over

=item * C - Currently only C is recognized.

=item * C - Optional, and only useful on pre-2.6.8 kernels.
See C for more details.

=back

=cut

sub new {
    my ($class, %opts) = @_;

    local ($!, $^E);

    my $arch_module = $class->can('NR_epoll_create') && $class;
    $arch_module ||= do {
        require Linux::Perl::ArchLoader;
        Linux::Perl::ArchLoader::get_arch_module($class);
    };

    my $flags = Linux::Perl::ParseFlags::parse( $class, $opts{'flags'} );

    my $call_name = 'NR_epoll_create';

    my $fd;

    if ($flags) {
        $call_name .= '1';

        $fd = Linux::Perl::call( $arch_module->$call_name(), 0 + $flags );
    }
    else {
        $opts{'size'} ||= 1;

        $fd = Linux::Perl::call( $arch_module->$call_name(), 0 + $opts{'size'} );
    }

    # Force the CLOEXEC behavior that Perl imposes on its file handles
    # unless the CLOEXEC flag was given explicitly.
    my $fh;

    if ( !($flags & _flag_CLOEXEC()) ) {
        open $fh, '+<&=' . $fd;
    }

    # NB: tests access the filehandle directly.
    return bless [$fd, $fh], $arch_module;
}

sub DESTROY {
    my ($self) = @_;

    # Create a Perl filehandle for the file descriptor so
    # that we get a close() when the filehandle object goes away.
    $self->[1] || do {
        local $^F = 1 + $self->[0];
        open my $temp_fh, '+<&=' . $self->[0];
    };

    return;
}

my ($epoll_event_keys_ar, $epoll_event_pack);

BEGIN {
    my $arch_is_64bit = (8 == length pack 'L!');

    my @_epoll_event_src = (
        events => 'L',  #uint32_t
        (
            $arch_is_64bit
                ? ( data => 'Q' )
                : (
                    q<> => 'xxxx',
                    data   => 'L!',  #uint64_t
                ),
        ),
    );

    ($epoll_event_keys_ar, $epoll_event_pack) = Linux::Perl::EasyPack::split_pack_list(@_epoll_event_src);
}

#----------------------------------------------------------------------

=head2 I->EVENT_NUMBER()

Returns a (constant) hash reference that cross-references event names
and their numbers. This is useful, e.g., for parsing events from the return
of C.

The recognized event names are C, C, C, C, C,
and C.

=cut

use constant {
    EVENT_NUMBER => {
        IN => 1,
        OUT => 4,
        RDHUP => 0x2000,
        PRI => 2,
        ERR => 8,
        HUP => 16,
    },

    _EPOLL_CTL_ADD => 1,
    _EPOLL_CTL_DEL => 2,
    _EPOLL_CTL_MOD => 3,

    _EVENT_FLAGS => {
        ET => (1 << 31),
        ONESHOT => (1 << 30),
        WAKEUP => (1 << 29),
        EXCLUSIVE => (1 << 28),
    },
};

#----------------------------------------------------------------------

=head2 I->add( $FD_OR_FH, %OPTS )

Adds a listener to the epoll instance. $FD_OR_FH is either a
Perl filehandle or a file descriptor number. %OPTS are:

=over

=item * C - An array reference of events/switches. Each member
is either a key from C or one of the following
switches: C, C, C, C. Your kernel
may not support all of those; check C for details.

=item * C - Optional, an arbitrary number to store with the file
descriptor. This defaults to the file descriptor because this is the obvious
way to correlate an event with its filehandle; however, you can set your own
numeric value here if you’d rather.

=back

=cut

sub add {
    my ($self, $fd_or_fh, @opts_kv) = @_;

    return $self->_add_or_modify( _EPOLL_CTL_ADD(), $fd_or_fh, @opts_kv );
}

=head2 I->modify( $FD_OR_FH, %OPTS )

Same arguments as C; use this to update an existing epoll listener.

=cut

sub modify {
    my ($self, $fd_or_fh, @opts_kv) = @_;

    return $self->_add_or_modify( _EPOLL_CTL_MOD(), $fd_or_fh, @opts_kv );
}

sub _opts_to_event {
    my ($opts_hr) = @_;

    if (!$opts_hr->{'events'} || !@{ $opts_hr->{'events'} }) {
        die 'Need events!';
    }

    my $events = 0;
    for my $evtname ( @{ $opts_hr->{'events'} } ) {
        $events |= EVENT_NUMBER()->{$evtname} || _EVENT_FLAGS()->{$evtname} || do {
            die "Unknown event '$evtname'";
        };
    }

    return pack $epoll_event_pack, $events, $opts_hr->{'data'};
}

sub _add_or_modify {
    my ($self, $op, $fd_or_fh, %opts) = @_;

    my $fd = ref($fd_or_fh) ? fileno($fd_or_fh) : $fd_or_fh;

    if (!defined $opts{'data'}) {
        $opts{'data'} = $fd;
    }

    my $event_packed = _opts_to_event(\%opts);

    Linux::Perl::call(
        $self->NR_epoll_ctl(),
        0 + $self->[0],
        0 + $op,
        0 + $fd,
        $event_packed,
    );

    return $self;
}

#----------------------------------------------------------------------

=head2 I->delete( $FD_OR_FH )

Removes an epoll listener.

=cut

sub delete {
    my ($self, $fd_or_fh) = @_;

    my $fd = ref($fd_or_fh) ? fileno($fd_or_fh) : $fd_or_fh;

    Linux::Perl::call(
        $self->NR_epoll_ctl(),
        0 + $self->[0],
        0 + _EPOLL_CTL_DEL(),
        0 + $fd,
        (pack $epoll_event_pack),   #accommodate pre-2.6.9 kernels
    );

    return $self;
}

#----------------------------------------------------------------------

=head2 @events = I->wait( %OPTS )

Waits for one or more events on the epoll. %OPTS are:

=over

=item * C - The number of events to listen for.

=item * C - in seconds

=item * C - Optional, an array of signals to block. The signals
can be specified either as names (e.g., C) or as numbers.
See C for why you might want to do this. (Note that Perl
doesn’t really expect you to block signals directly, so this may screw
things up for you in weird ways. If in doubt, avoid this option.)

=back

The return is a list of hash references, one for each received event.
Each hash reference is:

=over

=item * C - The same number given in C—or, if you didn’t
set a custom C value, the file descriptor associated with the event.

=item * C - Corresponds to the same-named array given in C,
but to optimize performance this is returned as a single number. Check
for specific events by iterating through the C hash
reference.

=back

=cut

sub wait {
    my ($self, %opts) = @_;

    my $sigmask;

    my $call_name = 'NR_epoll_';
    if ($opts{'sigmask'}) {
        $call_name .= 'pwait';
        $sigmask = Linux::Perl::SigSet::from_list( @{$opts{'sigmask'}} );
    }
    else {
        $call_name .= 'wait';
    }

    my $blank_event = pack $epoll_event_pack;
    my $buf = $blank_event x $opts{'maxevents'};

    my $timeout = int(1000 * $opts{'timeout'});

    my $count = Linux::Perl::call(
        $self->$call_name(),
        0 + $self->[0],
        $buf,
        0 + $opts{'maxevents'},
        0 + $timeout,
        ( (defined($sigmask) && length($sigmask))
            ? ( $sigmask, length $sigmask )
            : (),
        ),
    );

    my @events;
    for (1 .. $count) {
        my ($events_num, $data) = unpack( $epoll_event_pack, substr( $buf, 0, length($blank_event), q<> ) );

        push @events, {
            events => $events_num,
            data => $data,
        };
    }

    return @events;
}

1;