The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl

use strict;
use warnings;

use lib 't/lib';
use Promises qw(deferred);
use Test::More;

BEGIN {
    use_ok('Promises');
}

my @out;

my $then = Dummy::Then->new( \@out );

deferred->resolve->then(
    sub {
        push @out, 'Resolve';
        return $then;
    }
    )->then(
    sub { push @out, 'Resolve'; push @out, @_ },
    sub { push @out, 'Error' }
    );

$then->resolve('bar');

test( 'Resolve thenable', [ 'Resolve', 'Then resolved', 'Resolve', 'bar' ] );

@out = ();
deferred->resolve->then(
    sub {
        push @out, 'Resolve';
        return $then;
    }
    )->then(
    sub { push @out, 'Error' },
    sub { push @out, 'Reject'; push @out, @_; }
    );

$then->reject('bar');

test( 'Reject thenable', [ 'Resolve', 'Then rejected', 'Reject', 'bar' ] );

@out = ();
deferred->resolve->then(
    sub {
        push @out, 'Resolve';
        return $then;
    }
    )->finally( sub { push @out, 'Finally'; push @out, @_; } )->then(
    sub { push @out, 'Reject'; push @out, @_ },
    sub { push @out, 'Error' }
    );

$then->resolve('bar');
test( 'Finally resolve thenable',
    [ 'Resolve', 'Then resolved', 'Finally', 'bar', 'Reject', 'bar' ] );

@out = ();
@out = ();
deferred->resolve->then(
    sub {
        push @out, 'Resolve';
        return $then;
    }
    )->finally( sub { push @out, 'Finally'; push @out, @_ } )->then(
    sub { push @out, 'Error' },
    sub { push @out, 'Reject'; push @out, @_; }
    );

$then->reject('bar');

test( 'Finally reject thenable',
    [ 'Resolve', 'Then rejected', 'Finally', 'bar', 'Reject', 'bar' ] );

done_testing;

#===================================
sub test {
#===================================
    my ( $name, $expect ) = @_;

    #        diag "";
    #        diag "$name";
    #        diag "Expect: @$expect";
    #        diag "Got: @out";
    no warnings 'uninitialized';
    return fail $name unless @out == @$expect;
    for ( 0 .. @out ) {
        return fail $name unless $out[$_] eq $expect->[$_];
    }
    pass $name;

}

package Dummy::Then;

sub new {
    my ( $class, $out ) = @_;
    bless { out => $out }, $class;
}

sub then {
    my ( $self, $cb, $err ) = @_;
    $self->{cb}  = $cb;
    $self->{err} = $err;
    return ();
}

sub resolve {
    my $self = shift;
    push @{ $self->{out} }, 'Then resolved';
    $self->{cb}->(@_);
}

sub reject {
    my $self = shift;
    push @{ $self->{out} }, 'Then rejected';
    $self->{err}->(@_);
}

1