File Coverage

blib/lib/Future/Q.pm

Criterion	Covered	Total	%
statement	153	155	98.7
branch	59	68	86.7
condition	56	72	77.7
subroutine	37	37	100.0
pod	12	12	100.0
total	317	344	92.1

package Future::Q;
use strict;
use warnings;
use Future 0.29;
use parent "Future";
use Devel::GlobalDestruction;
use Scalar::Util qw(refaddr blessed weaken);
use Carp;
use Try::Tiny ();

our $VERSION = '0.100';

our @CARP_NOT = qw(Try::Tiny Future);

our $OnError = undef;

## ** lexical attributes to avoid collision of names.

my %failure_handled_for = ();

sub new {
    my ($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    my $id = refaddr $self;
    $failure_handled_for{$id} = 0;
    return $self;
}

sub _q_go_super_DESTROY {
    my ($self) = @_;
    my $super_destroy = $self->can("SUPER::DESTROY");
    goto $super_destroy if defined $super_destroy;
}

sub DESTROY {
    my ($self) = @_;
    if(in_global_destruction) {
        goto \&_q_go_super_DESTROY;
    }
    my $id = refaddr $self;
    if($self->is_ready && $self->failure && !$failure_handled_for{$id}) {
        $self->_q_warn_failure();
        my @failed_subfutures = Try::Tiny::try {
            $self->failed_futures;
        }Try::Tiny::catch {
            ();
        };
        foreach my $f (@failed_subfutures) {
            $f->_q_warn_failure(is_subfuture => 1) if blessed($f) && $f->can('_q_warn_failure');
        }
    }
    delete $failure_handled_for{$id};
    goto \&_q_go_super_DESTROY;
}

sub _q_set_failure_handled {
    my ($self) = @_;
    $failure_handled_for{refaddr $self} = 1;
}

sub _q_warn_failure {
    my ($self, %options) = @_;
    if($self->is_ready && $self->failure) {
        my $failure = $self->failure;
        my $message = Carp::shortmess($options{is_subfuture}
                                      ? "Failure of subfuture $self may not be handled: $failure  subfuture may be lost"
                                      : "Failure of $self is not handled: $failure  future is lost");
        if(defined($OnError) && ref($OnError) eq "CODE") {
            $OnError->($message);
        }else {
            warn $message;
        }
    }
}

sub try {
    my ($class, $func, @args) = @_;
    if(!defined($func) || ref($func) ne "CODE") {
        $func = sub {
            croak("func parameter for try() must be a code-ref");
        };
    }
    my $result_future = Try::Tiny::try {
        my @results = $func->(@args);
        if(scalar(@results) == 1 && blessed($results[0]) && $results[0]->isa('Future')) {
            return $results[0];
        }else {
            return $class->new->fulfill(@results);
        }
    } Try::Tiny::catch {
        my $e = shift;
        return $class->new->reject($e);
    };
    return $result_future;
}

sub fcall {
    goto $_[0]->can('try');
}

sub then {
    my ($self, $on_fulfilled, $on_rejected) = @_;
    if(defined($on_fulfilled) && ref($on_fulfilled) ne "CODE") {
        $on_fulfilled = undef;
    }
    if(defined($on_rejected) && ref($on_rejected) ne "CODE") {
        $on_rejected = undef;
    }
    my $class = ref($self);
    $self->_q_set_failure_handled();

    my $next_future = $self->new;
    $self->on_ready(sub {
        my $invo_future = shift;
        if($invo_future->is_cancelled) {
            $next_future->cancel() if $next_future->is_pending;
            return;
        }
        my $return_future = $invo_future;
        if($invo_future->is_rejected && defined($on_rejected)) {
            $return_future = $class->try($on_rejected, $invo_future->failure);
        }elsif($invo_future->is_fulfilled && defined($on_fulfilled)) {
            $return_future = $class->try($on_fulfilled, $invo_future->get);
        }
        $next_future->resolve($return_future);
    });
    if($next_future->is_pending && $self->is_pending) {
        weaken(my $invo_future = $self);
        $next_future->on_cancel(sub {
            if(defined($invo_future) && $invo_future->is_pending) {
                $invo_future->cancel();
            }
        });
    }
    return $next_future;
}

sub catch {
    my ($self, $on_rejected) = @_;
    @_ = ($self, undef, $on_rejected);
    goto $self->can('then');
}

sub fulfill {
    goto $_[0]->can('done');
}

sub resolve {
    my ($self, @result) = @_;
    if(not (@result == 1 && blessed($result[0]) && $result[0]->isa("Future"))) {
        goto $self->can("fulfill");
    }
    return $self if $self->is_cancelled;
    my $base_future = $result[0];

    ## Maybe we should check if $base_future is identical to
    ## $self. Promises/A+ spec v1.1 [1] states we should reject $self
    ## in that case. However, since Q v1.0.1 does not care that case,
    ## we also leave that case unchecked for now.
    ##
    ## [1]: https://github.com/promises-aplus/promises-spec/tree/1.1.0

    $base_future->on_ready(sub {
        my $base_future = shift;
        return if $self->is_ready;
        if($base_future->is_cancelled) {
            $self->cancel();
        }elsif($base_future->failure) {
            if($base_future->can("_q_set_failure_handled")) {
                $base_future->_q_set_failure_handled();
            }
            $self->reject($base_future->failure);
        }else {
            $self->fulfill($base_future->get);
        }
    });
    if(!$base_future->is_ready) {
        weaken(my $weak_base = $base_future);
        $self->on_cancel(sub {
            $weak_base->cancel() if defined($weak_base) && !$weak_base->is_ready;
        });
    }
    return $self;
}

sub reject {
    goto $_[0]->can('fail');
}

sub is_pending {
    my ($self) = @_;
    return !$self->is_ready;
}

sub is_fulfilled {
    my ($self) = @_;
    return (!$self->is_pending && !$self->is_cancelled && !$self->is_rejected);
}

sub is_rejected {
    my ($self) = @_;
    return ($self->is_ready && !!$self->failure);
}

foreach my $method (qw(wait_all wait_any needs_all needs_any)) {
    no strict "refs";
    my $supermethod_code = __PACKAGE__->can("SUPER::$method");
    *{$method} = sub {
        my ($self, @subfutures) = @_;
        foreach my $sub (@subfutures) {
            next if !blessed($sub) || !$sub->can('_q_set_failure_handled');
            $sub->_q_set_failure_handled();
        }
        goto $supermethod_code;
    };
}

sub finally {
    my ($self, $callback) = @_;
    my $class = ref($self);
    $self->_q_set_failure_handled();
    if(!defined($callback) || ref($callback) ne "CODE") {
        return $class->new->reject("Callback for finally() must be a code-ref");
    }
    my $next_future = $self->new;
    $self->on_ready(sub {
        my ($invo_future) = @_;
        if($invo_future->is_cancelled) {
            $next_future->cancel if $next_future->is_pending;
            return;
        }
        my $returned_future = $class->try($callback);
        $returned_future->on_ready(sub {
            my ($returned_future) = @_;
            if(!$returned_future->is_cancelled && $returned_future->failure) {
                $next_future->resolve($returned_future);
            }else {
                $next_future->resolve($invo_future);
            }
        });
        if(!$returned_future->is_ready) {
            weaken(my $weak_returned = $returned_future);
            $next_future->on_cancel(sub {
                $weak_returned->cancel if defined($weak_returned) && !$weak_returned->is_ready;
            });
        }
    });
    if(!$self->is_ready) {
        weaken(my $weak_invo = $self);
        $next_future->on_cancel(sub {
            $weak_invo->cancel if defined($weak_invo) && !$weak_invo->is_ready;

        });
    }
    return $next_future;
}

1;

__END__