File Coverage

blib/lib/Promises/Deferred/EV.pm

Criterion	Covered	Total	%
statement	29	33	87.8
branch	5	8	62.5
condition	2	3	66.6
subroutine	6	8	75.0
pod			n/a
total	42	52	80.7

package Promises::Deferred::EV;
our $AUTHORITY = 'cpan:YANICK';
# ABSTRACT: An implementation of Promises in Perl
$Promises::Deferred::EV::VERSION = '1.05';
use strict;
use warnings;

use EV;

use parent 'Promises::Deferred';

# Before the pipe-based approach used below, there was an EV::timer-based
# approach for _notify_backend. The current code is much more performant:

# Original code (on a laptop on battery power):
# Backend:  Promises::Deferred::EV
# Benchmark: running one, two for at least 10 CPU seconds...
# Benchmark: running one, two for at least 10 CPU seconds...
#        one: 67 wallclock secs @ 1755.16/s (n=17692)
#        two: 53 wallclock secs @ 770.03/s (n=7785)

# New approach:
# Backend:  Promises::Deferred::EV
# Benchmark: running one, two for at least 10 CPU seconds...
#        one: 10 wallclock secs @ 10949.19/s (n=115076)
#        two: 10 wallclock secs @ 3964.58/s (n=41747)


my ($socket_pid, $socket_send, $socket_recv, $socket_io,
    $read_buf, @io_callbacks);

sub _do_callbacks {
    my @cbs = @io_callbacks;
    @io_callbacks = ();
    sysread $socket_recv, $read_buf, 16;
    for my $cb_grp (@cbs) {
        my ($result, $cbs) = @$cb_grp;
        my @r = @$result;
        $_->(@r) for @$cbs;
    }
}

sub _notify_backend {
    if  (! $socket_pid || $socket_pid != $$) {
        $socket_pid = $$;
        close($socket_send) if defined $socket_send;
        close($socket_recv) if defined $socket_recv;
        pipe($socket_recv, $socket_send);
        $socket_io = EV::io($socket_recv, EV::READ, \&_do_callbacks);
        $socket_io->keepalive(0);
    }

    # skip signalling when there are callbacks already waiting
    if (not @io_callbacks) {
        syswrite $socket_send, ' ';
    }
    push @io_callbacks, [ $_[2], $_[1] ];
}

sub _timeout {
    my ( $self, $timeout, $callback ) = @_;

    my $id = EV::timer $timeout, 0, $callback;

    return sub { undef $id };
}

1;

__END__