File Coverage

blib/lib/Deeme.pm

Criterion	Covered	Total	%
statement	86	89	96.6
branch	26	28	92.8
condition	7	16	43.7
subroutine	16	17	94.1
pod	10	10	100.0
total	145	160	90.6

package Deeme;
use strict;
use 5.008_005;
our $VERSION = '0.04';
use Deeme::Obj -base;
use Carp 'croak';
has 'backend';
use Scalar::Util qw(blessed weaken);
use constant DEBUG => $ENV{DEEME_DEBUG} || 0;

sub new {
    my $self = shift;
    $self = $self->SUPER::new(@_);
    if ( !$self->backend ) {
        require Deeme::Backend::Memory;
        $self->backend( Deeme::Backend::Memory->new );
    }
    $self->backend->deeme($self);
    return $self;
}

sub catch { $_[0]->on( error => $_[1] ) and return $_[0] }

sub emit {
    my ( $self, $name ) = ( shift, shift );

    if ( my $s = $self->backend->events_get($name) ) {
        warn "-- Emit $name in @{[blessed $self]} (@{[scalar @$s]})\n"
            if DEBUG;
        my @onces = $self->backend->events_onces($name);
        my $i     = 0;
        for my $cb (@$s) {
            ( $onces[$i] == 1 )
                ? ( splice( @onces, $i, 1 )
                    and $self->_unsubscribe_index( $name => $i ) )
                : $i++;
            $self->$cb(@_);
        }
    }
    else {
        warn "-- Emit $name in @{[blessed $self]} (0)\n" if DEBUG;
        die "@{[blessed $self]}: $_[0]" if $name eq 'error';
    }

    return $self;
}

sub emit_safe {
    my ( $self, $name ) = ( shift, shift );

    if ( my $s = $self->backend->events_get($name) ) {
        warn "-- Emit $name in @{[blessed $self]} safely (@{[scalar @$s]})\n"
            if DEBUG;
        my @onces = $self->backend->events_onces($name);
        my $i     = 0;
        for my $cb (@$s) {
            $self->emit( error => qq{Event "$name" failed: $@} )
                unless eval {
                ( $onces[$i] == 1 )
                    ? ( splice( @onces, $i, 1 )
                        and $self->_unsubscribe_index( $name => $i ) )
                    : $i++;
                $self->$cb(@_);
                1;
                };
        }
    }
    else {
        warn "-- Emit $name in @{[blessed $self]} safely (0)\n" if DEBUG;
        die "@{[blessed $self]}: $_[0]" if $name eq 'error';
    }

    return $self;
}

sub has_subscribers { !!@{ shift->subscribers(shift) } }

sub on {
    my ( $self, $name, $cb ) = @_;
    warn "-- on $name in @{[blessed $self]}\n"
        if DEBUG;
    return $self->backend->event_add( $name, $cb ||= [], 0 );
}

sub once {
    my ( $self, $name, $cb ) = @_;
    warn "-- once $name in @{[blessed $self]}\n"
        if DEBUG;
    return $self->backend->event_add( $name, $cb ||= [], 1 );
}

sub subscribers { shift->backend->events_get( shift(), 0 ) || [] }

sub unsubscribe {
    my ( $self, $name, $cb ) = @_;

    # One
    if ($cb) {
        my @events = @{ $self->backend->events_get( $name, 0 ) };
        my @onces = $self->backend->events_onces($name);

        my ($index) = grep { $cb eq $events[$_] } 0 .. $#events;
        if ( defined $index ) {

            splice @events, $index, 1;
            splice @onces,  $index, 1;
            $self->backend->event_delete($name) and return $self
                unless @events;
            $self->backend->event_update( $name, \@events, 0 );
            $self->backend->once_update( $name, \@onces );
        }
    }

    # All
    else { $self->backend->event_delete($name); }

    return $self;
}

sub reset {
    my $self = shift;
    $self->backend->events_reset;
    return $self;
}

sub _unsubscribe_index {
    my ( $self, $name, $index ) = @_;

    my @events = @{ $self->backend->events_get( $name, 0 ) };
    my @onces = $self->backend->events_onces($name);

    splice @events, $index, 1;
    splice @onces,  $index, 1;
    $self->backend->event_delete($name) and return $self
        unless @events;
    $self->backend->event_update( $name, [@events], 0 );
    $self->backend->once_update( $name, \@onces );

    return $self;
}


1;
__END__