File Coverage

blib/lib/Promises/Deferred.pm

Criterion	Covered	Total	%
statement	114	146	78.0
branch	25	42	59.5
condition	12	18	66.6
subroutine	30	42	71.4
pod	19	19	100.0
total	200	267	74.9

package Promises::Deferred;
our $AUTHORITY = 'cpan:YANICK';
$Promises::Deferred::VERSION = '1.04';
# ABSTRACT: An implementation of Promises in Perl

use strict;
use warnings;

use Scalar::Util qw[ blessed reftype ];
use Carp qw[ confess carp ];

use Promises::Promise;

use constant IN_PROGRESS => 'in progress';
use constant RESOLVED    => 'resolved';
use constant REJECTED    => 'rejected';

sub new {
    my $class = shift;

    my $caller = $Promises::WARN_ON_UNHANDLED_REJECT ? _trace() : undef ;

    bless {
        _caller => $caller,
        resolved => [],
        rejected => [],
        status   => IN_PROGRESS
    } => $class;
}

sub _trace {
    my $i = 0;

    while( my( $package, $filename, $line ) = caller($i++) ) {
        return [ $filename, $line ] unless $package =~ /^Promises/;
    }

    return
}

sub promise { Promises::Promise->new(shift) }
sub status  { (shift)->{'status'} }
sub result  { (shift)->{'result'} }

# predicates for all the status possibilities
sub is_in_progress { (shift)->{'status'} eq IN_PROGRESS }
sub is_resolved    { (shift)->{'status'} eq RESOLVED }
sub is_rejected    { (shift)->{'status'} eq REJECTED }
sub is_done        { ! $_[0]->is_in_progress }

# the three possible states according to the spec ...
sub is_unfulfilled { (shift)->is_in_progress }
sub is_fulfilled   { $_[0]->is_resolved }
sub is_failed      { $_[0]->is_rejected }

sub resolve {
    my $self = shift;

    die "Cannot resolve. Already  " . $self->status
        unless $self->is_in_progress;

    $self->{'result'} = [@_];
    $self->{'status'} = RESOLVED;
    $self->_notify;
    $self;
}

sub reject {
    my $self = shift;
    die "Cannot reject. Already  " . $self->status
        unless $self->is_in_progress;

    $self->{'result'} = [@_];
    $self->{'status'} = REJECTED;
    $self->_notify;
    $self;
}

sub then {
    my $self = shift;
    my ( $callback, $error ) = $self->_callable_or_undef(@_);

    my $d = ( ref $self )->new;
    push @{ $self->{'resolved'} } => $self->_wrap( $d, $callback, 'resolve' );
    push @{ $self->{'rejected'} } => $self->_wrap( $d, $error,    'reject' );

    $self->_notify unless $self->is_in_progress;
    $d->promise;
}

sub chain {
    my $self = shift;
    $self = $self->then($_) for @_;
    return $self;
}

sub catch {
    my $self = shift;
    $self->then( undef, @_ );
}

sub done {
    my $self = shift;
    my ( $callback, $error ) = $self->_callable_or_undef(@_);
    push @{ $self->{'resolved'} } => $callback if defined $callback;
    push @{ $self->{'rejected'} } => $error    if defined $error;

    $self->_notify unless $self->is_in_progress;
    ();
}

sub finally {
    my $self = shift;
    my ($callback) = $self->_callable_or_undef(@_);

    my $d = ( ref $self )->new;

    if (defined $callback) {
        my ( @result, $method );
        my $finish_d = sub { $d->$method(@result); () };

        my $f = sub {
            ( $method, @result ) = @_;
            local $@;
            my ($p) = eval { $callback->(@result) };
            if ( $p && blessed $p && $p->can('then') ) {
                return $p->then( $finish_d, $finish_d );
            }
            $finish_d->();
            ();
        };

        push @{ $self->{'resolved'} } => sub { $f->( 'resolve', @_ ) };
        push @{ $self->{'rejected'} } => sub { $f->( 'reject',  @_ ) };

        $self->_notify unless $self->is_in_progress;
    }
    $d->promise;

}

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

    unless( $self->can('_timeout') ) {
        carp "timeout mechanism not implemented for Promise backend ", ref $self;
        return $self->promise;
    }

    my $deferred = ref($self)->new;

    my $cancel = $deferred->_timeout($timeout, sub {
        return if $deferred->is_done;
        $deferred->reject( 'timeout' );
    } );

    $self->finally( $cancel )->then(
        sub { 'resolve', @_ },
        sub { 'reject',  @_ },
    )->then(sub {
        my( $action, @args ) = @_;
        $deferred->$action(@args) unless $deferred->is_done;
    });

    return $deferred->promise;
}

sub _wrap {
    my ( $self, $d, $f, $method ) = @_;

    return sub { $d->$method( @{ $self->result } ) }
        unless defined $f;

    return sub {
        local $@;
        my ( @results, $error );
        eval {
            @results = do { $f->(@_) };
            1;
        }
            || do { $error = defined $@ ? $@ : 'Unknown reason' };

        if ($error) {
            $d->reject($error);
        }
        elsif ( @results == 1
            and blessed $results[0]
            and $results[0]->can('then') )
        {
            $results[0]->then(
                sub { $d->resolve(@_); () },
                sub { $d->reject(@_);  () },
            );
        }
        else {
            $d->resolve(@results);
        }
        return;
    };
}

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

    my $cbs = $self->is_resolved ? $self->{resolved} : $self->{rejected};

    $self->{_reject_was_handled} = $self->is_rejected && @$cbs;

    $self->{'resolved'} = [];
    $self->{'rejected'} = [];

    return $self->_notify_backend( $cbs, $self->result );
}

sub _notify_backend {
    my ( $self, $cbs, $result ) = @_;
    $_->(@$result) foreach @$cbs;
}

sub _callable_or_undef {
    shift;
    map {
        # coderef or object overloaded as coderef
        ref && reftype $_ eq 'CODE' || blessed $_ && $_->can('()')
            ? $_
            : undef
    } @_;
}


1;

__END__