File Coverage

blib/lib/Promises.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	16	20	80.0
condition	8	11	72.7
subroutine	18	18	100.0
pod	5	5	100.0
total	109	116	93.9

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

use strict;
use warnings;

use Scalar::Util qw[ blessed ];
use Promises::Deferred;
our $Backend = 'Promises::Deferred';

our $WARN_ON_UNHANDLED_REJECT = 0;

use Sub::Exporter -setup => {

    collectors => [
        'backend' => \'_set_backend',
        'warn_on_unhandled_reject' => \'_set_warn_on_unhandled_reject',
    ],
    exports    => [qw[
        deferred resolved rejected
        collect collect_hash
    ]]
};

sub _set_warn_on_unhandled_reject {
    my( undef, $arg ) = @_;

    if( $WARN_ON_UNHANDLED_REJECT = $arg->[0] ) {
        # only brings the big guns if asked for

        *Promises::Deferred::DESTROY = sub {

            return unless $WARN_ON_UNHANDLED_REJECT;

            my $self = shift;

            return unless
                $self->is_rejected and not $self->{_reject_was_handled};

            require Data::Dumper;

            my $dump =
                Data::Dumper->new([$self->result])->Terse(1)->Dump;

            chomp $dump;
            $dump =~ s/\n\s*/ /g;

            warn "Promise's rejection ", $dump,
                " was not handled",
                ($self->{_caller} ? ( ' at ', join ' line ', @{$self->{_caller}} ) : ()) , "\n";
        };
    }
}

sub _set_backend {
    my ( undef, $arg ) = @_;
    my $backend = $arg->[0] or return;

    unless ( $backend =~ s/^\+// ) {
        $backend = 'Promises::Deferred::' . $backend;
    }
    require Module::Runtime;
    $Backend = Module::Runtime::use_module($backend) || return;
    return 1;

}

sub deferred(;&) {
    my $promise = $Backend->new;

    if ( my $code = shift ) {
        $promise->resolve;
        return $promise->then(sub{
            $code->($promise);
        });
    }

    return $promise;
}

sub resolved { deferred->resolve(@_) }
sub rejected { deferred->reject(@_)  }

sub collect_hash {
    collect(@_)->then( sub {
    map {
        my @values = @$_;
        die "'collect_hash' promise returned more than one value: [@{[ join ', ', @values ]} ]\n"
            if @values > 1;

        @values == 1 ? $values[0] : undef;
    } @_ })
}

sub collect {
    my @promises = @_;

    my $all_done = resolved();

    my @results;
    for my $p ( @promises ) {
        if ( $p && blessed $p && $p->can('then') ) {
            $all_done = $all_done->then( sub {
                $p->then( sub {
                    push @results, [ @_ ];
                    return;
                } )
            } );
        } else {
            # not actually a promise; collect directly
            $all_done = $all_done->then( sub {
                push @results, [ $p ];
                return;
            } );
        }
    }

    return $all_done->then( sub { @results } );
}

1;

__END__