diff options
Diffstat (limited to 't')
| -rw-r--r-- | t/00use.t | 11 | ||||
| -rw-r--r-- | t/01future.t | 290 | ||||
| -rw-r--r-- | t/02cancel.t | 131 | ||||
| -rw-r--r-- | t/03then.t | 290 | ||||
| -rw-r--r-- | t/04else.t | 259 | ||||
| -rw-r--r-- | t/05then-else.t | 78 | ||||
| -rw-r--r-- | t/06followed_by.t | 197 | ||||
| -rw-r--r-- | t/09transform.t | 75 | ||||
| -rw-r--r-- | t/10wait_all.t | 160 | ||||
| -rw-r--r-- | t/11wait_any.t | 152 | ||||
| -rw-r--r-- | t/12needs_all.t | 147 | ||||
| -rw-r--r-- | t/13needs_any.t | 200 | ||||
| -rw-r--r-- | t/20subclass.t | 138 | ||||
| -rw-r--r-- | t/21debug.t | 83 | ||||
| -rw-r--r-- | t/22wrap_cb.t | 105 | ||||
| -rw-r--r-- | t/30utils-call.t | 44 | ||||
| -rw-r--r-- | t/31utils-call-with-escape.t | 70 | ||||
| -rw-r--r-- | t/32utils-repeat.t | 188 | ||||
| -rw-r--r-- | t/33utils-repeat-generate.t | 65 | ||||
| -rw-r--r-- | t/34utils-repeat-foreach.t | 152 | ||||
| -rw-r--r-- | t/35utils-map-void.t | 200 | ||||
| -rw-r--r-- | t/36utils-map.t | 65 | ||||
| -rw-r--r-- | t/50test-future.t | 87 | ||||
| -rw-r--r-- | t/99pod.t | 11 |
24 files changed, 3198 insertions, 0 deletions
diff --git a/t/00use.t b/t/00use.t new file mode 100644 index 0000000..dc88b8a --- /dev/null +++ b/t/00use.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use_ok( "Future" ); +use_ok( "Future::Utils" ); + +done_testing; diff --git a/t/01future.t b/t/01future.t new file mode 100644 index 0000000..03fb2db --- /dev/null +++ b/t/01future.t @@ -0,0 +1,290 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Identity; +use Test::Refcount; + +use Future; + +# done +{ + my $future = Future->new; + + ok( defined $future, '$future defined' ); + isa_ok( $future, "Future", '$future' ); + is_oneref( $future, '$future has refcount 1 initially' ); + + ok( !$future->is_ready, '$future not yet ready' ); + + my @on_ready_args; + identical( $future->on_ready( sub { @on_ready_args = @_ } ), $future, '->on_ready returns $future' ); + + my @on_done_args; + identical( $future->on_done( sub { @on_done_args = @_ } ), $future, '->on_done returns $future' ); + identical( $future->on_fail( sub { die "on_fail called for done future" } ), $future, '->on_fail returns $future' ); + + identical( $future->done( result => "here" ), $future, '->done returns $future' ); + + is( scalar @on_ready_args, 1, 'on_ready passed 1 argument' ); + identical( $on_ready_args[0], $future, 'Future passed to on_ready' ); + undef @on_ready_args; + + is_deeply( \@on_done_args, [ result => "here" ], 'Results passed to on_done' ); + + ok( $future->is_ready, '$future is now ready' ); + ok( $future->is_done, '$future is done' ); + ok( !$future->is_failed, '$future is not failed' ); + is_deeply( [ $future->get ], [ result => "here" ], 'Results from $future->get' ); + is( scalar $future->get, "result", 'Result from scalar $future->get' ); + + is_oneref( $future, '$future has refcount 1 at end of test' ); +} + +# wrap +{ + my $f = Future->new; + + my $future = Future->wrap( $f ); + + ok( defined $future, 'Future->wrap(Future) defined' ); + isa_ok( $future, "Future", 'Future->wrap(Future)' ); + + $f->done( "Wrapped Future" ); + is( scalar $future->get, "Wrapped Future", 'Future->wrap(Future)->get' ); + + $future = Future->wrap( "Plain string" ); + + ok( defined $future, 'Future->wrap(string) defined' ); + isa_ok( $future, "Future", 'Future->wrap(string)' ); + + is( scalar $future->get, "Plain string", 'Future->wrap(string)->get' ); +} + +# done_cb +{ + my $future = Future->new; + + my @on_done_args; + $future->on_done( sub { @on_done_args = @_ } ); + + my $done_cb = $future->done_cb; + is( ref $done_cb, "CODE", '->done_cb returns CODE reference' ); + + $done_cb->( result => "via cb" ); + is_deeply( \@on_done_args, [ result => "via cb" ], 'Results via ->done_cb' ); +} + +# done chaining +{ + my $future = Future->new; + + my $f1 = Future->new; + my $f2 = Future->new; + + $future->on_done( $f1 ); + $future->on_ready( $f2 ); + + my @on_done_args_1; + $f1->on_done( sub { @on_done_args_1 = @_ } ); + my @on_done_args_2; + $f2->on_done( sub { @on_done_args_2 = @_ } ); + + $future->done( chained => "result" ); + + is_deeply( \@on_done_args_1, [ chained => "result" ], 'Results chained via ->on_done( $f )' ); + is_deeply( \@on_done_args_2, [ chained => "result" ], 'Results chained via ->on_ready( $f )' ); +} + +# immediately done +{ + my $future = Future->done( already => "done" ); + + my @on_done_args; + identical( $future->on_done( sub { @on_done_args = @_; } ), $future, '->on_done returns future for immediate' ); + my $on_fail; + identical( $future->on_fail( sub { $on_fail++; } ), $future, '->on_fail returns future for immediate' ); + + is_deeply( \@on_done_args, [ already => "done" ], 'Results passed to on_done for immediate future' ); + ok( !$on_fail, 'on_fail not invoked for immediate future' ); + + my $f1 = Future->new; + my $f2 = Future->new; + + $future->on_done( $f1 ); + $future->on_ready( $f2 ); + + ok( $f1->is_ready, 'Chained ->on_done for immediate future' ); + ok( $f1->is_done, 'Chained ->on_done is done for immediate future' ); + is_deeply( [ $f1->get ], [ already => "done" ], 'Results from chained via ->on_done for immediate future' ); + ok( $f2->is_ready, 'Chained ->on_ready for immediate future' ); + ok( $f2->is_done, 'Chained ->on_ready is done for immediate future' ); + is_deeply( [ $f2->get ], [ already => "done" ], 'Results from chained via ->on_ready for immediate future' ); +} + +# fail +{ + my $future = Future->new; + + $future->on_done( sub { die "on_done called for failed future" } ); + my $failure; + $future->on_fail( sub { ( $failure ) = @_; } ); + + identical( $future->fail( "Something broke" ), $future, '->fail returns $future' ); + + ok( $future->is_ready, '$future->fail marks future ready' ); + ok( !$future->is_done, '$future->fail does not mark future done' ); + ok( $future->is_failed, '$future->fail marks future as failed' ); + + is( scalar $future->failure, "Something broke", '$future->failure yields exception' ); + my $file = __FILE__; + my $line = __LINE__ + 1; + like( exception { $future->get }, qr/^Something broke at \Q$file line $line\E\.?\n$/, '$future->get throws exception' ); + + is( $failure, "Something broke", 'Exception passed to on_fail' ); +} + +# fail_cb +{ + my $future = Future->new; + + my $failure; + $future->on_fail( sub { ( $failure ) = @_ } ); + + my $fail_cb = $future->fail_cb; + is( ref $fail_cb, "CODE", '->fail_cb returns CODE reference' ); + + $fail_cb->( "Failure by cb" ); + is( $failure, "Failure by cb", 'Failure via ->fail_cb' ); +} + +{ + my $future = Future->new; + + $future->fail( "Something broke", further => "details" ); + + ok( $future->is_ready, '$future->fail marks future ready' ); + + is( scalar $future->failure, "Something broke", '$future->failure yields exception' ); + is_deeply( [ $future->failure ], [ "Something broke", "further", "details" ], + '$future->failure yields details in list context' ); +} + +# fail chaining +{ + my $future = Future->new; + + my $f1 = Future->new; + my $f2 = Future->new; + + $future->on_fail( $f1 ); + $future->on_ready( $f2 ); + + my $failure_1; + $f1->on_fail( sub { ( $failure_1 ) = @_ } ); + my $failure_2; + $f2->on_fail( sub { ( $failure_2 ) = @_ } ); + + $future->fail( "Chained failure" ); + + is( $failure_1, "Chained failure", 'Failure chained via ->on_fail( $f )' ); + is( $failure_2, "Chained failure", 'Failure chained via ->on_ready( $f )' ); +} + +# immediately failed +{ + my $future = Future->fail( "Already broken" ); + + my $on_done; + identical( $future->on_done( sub { $on_done++; } ), $future, '->on_done returns future for immediate' ); + my $failure; + identical( $future->on_fail( sub { ( $failure ) = @_; } ), $future, '->on_fail returns future for immediate' ); + + is( $failure, "Already broken", 'Exception passed to on_fail for already-failed future' ); + ok( !$on_done, 'on_done not invoked for immediately-failed future' ); + + my $f1 = Future->new; + my $f2 = Future->new; + + $future->on_fail( $f1 ); + $future->on_ready( $f2 ); + + ok( $f1->is_ready, 'Chained ->on_done for immediate future' ); + is_deeply( [ $f1->failure ], [ "Already broken" ], 'Results from chained via ->on_done for immediate future' ); + ok( $f2->is_ready, 'Chained ->on_ready for immediate future' ); + is_deeply( [ $f2->failure ], [ "Already broken" ], 'Results from chained via ->on_ready for immediate future' ); +} + +# die +{ + my $future = Future->new; + + $future->on_done( sub { die "on_done called for failed future" } ); + my $failure; + $future->on_fail( sub { ( $failure ) = @_; } ); + + my $file = __FILE__; + my $line = __LINE__+1; + identical( $future->die( "Something broke" ), $future, '->die returns $future' ); + + ok( $future->is_ready, '$future->die marks future ready' ); + + is( scalar $future->failure, "Something broke at $file line $line\n", '$future->failure yields exception' ); + is( exception { $future->get }, "Something broke at $file line $line\n", '$future->get throws exception' ); + + is( $failure, "Something broke at $file line $line\n", 'Exception passed to on_fail' ); +} + +# call +{ + my $future; + + $future = Future->call( sub { Future->done( @_ ) }, 1, 2, 3 ); + + ok( $future->is_ready, '$future->is_ready from immediate Future->call' ); + is_deeply( [ $future->get ], [ 1, 2, 3 ], '$future->get from immediate Future->call' ); + + $future = Future->call( sub { die "argh!\n" } ); + + ok( $future->is_ready, '$future->is_ready from immediate exception of Future->call' ); + is( $future->failure, "argh!\n", '$future->failure from immediate exception of Future->call' ); + + $future = Future->call( sub { "non-future" } ); + + ok( $future->is_ready, '$future->is_ready from non-future returning Future->call' ); + like( $future->failure, qr/^Expected __ANON__.*\(\S+ line \d+\) to return a Future$/, + '$future->failure from non-future returning Future->call' ); +} + +# unwrap +{ + is_deeply( [ Future->unwrap( Future->done( 1, 2, 3 ) ) ], + [ 1, 2, 3 ], + 'Future->unwrap Future in list context' ); + is_deeply( [ Future->unwrap( 1, 2, 3 ) ], + [ 1, 2, 3 ], + 'Future->unwrap plain list in list context' ); + + is( scalar Future->unwrap( Future->done( qw( a b c ) ) ), + "a", + 'Future->unwrap Future in scalar context' ); + is( scalar Future->unwrap( qw( a b c ) ), + "a", + 'Future->unwrap plain list in scalar context' ); +} + +# label +{ + my $f = Future->new; + + identical( $f->set_label( "the label" ), $f, '->set_label returns $f' ); + + is( $f->label, "the label", '->label returns the label' ); + + $f->cancel; +} + +done_testing; diff --git a/t/02cancel.t b/t/02cancel.t new file mode 100644 index 0000000..bea0e3b --- /dev/null +++ b/t/02cancel.t @@ -0,0 +1,131 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Identity; + +use Future; + +# cancel +{ + my $future = Future->new; + + my $cancelled; + + identical( $future->on_cancel( sub { $cancelled .= "1" } ), $future, '->on_cancel returns $future' ); + $future->on_cancel( sub { $cancelled .= "2" } ); + + my $ready; + $future->on_ready( sub { $ready++ if shift->is_cancelled } ); + + $future->on_done( sub { die "on_done called for cancelled future" } ); + $future->on_fail( sub { die "on_fail called for cancelled future" } ); + + $future->on_ready( my $ready_f = Future->new ); + $future->on_done( my $done_f = Future->new ); + $future->on_fail( my $fail_f = Future->new ); + + $future->cancel; + + ok( $future->is_ready, '$future->cancel marks future ready' ); + + ok( $future->is_cancelled, '$future->cancelled now true' ); + is( $cancelled, "21", '$future cancel blocks called in reverse order' ); + + is( $ready, 1, '$future on_ready still called by cancel' ); + + ok( $ready_f->is_cancelled, 'on_ready chained future cnacelled after cancel' ); + ok( !$done_f->is_ready, 'on_done chained future not ready after cancel' ); + ok( !$fail_f->is_ready, 'on_fail chained future not ready after cancel' ); + + like( exception { $future->get }, qr/cancelled/, '$future->get throws exception by cancel' ); + + ok( !exception { $future->cancel }, '$future->cancel a second time is OK' ); + + $done_f->cancel; + $fail_f->cancel; +} + +# cancel_cb +{ + my $future = Future->new; + + my $cancelled; + $future->on_cancel( sub { $cancelled++ } ); + + my $cancel_cb = $future->cancel_cb; + is( ref $cancel_cb, "CODE", '->cancel_cb returns CODE reference' ); + + $cancel_cb->(); + is( $cancelled, 1, 'Cancellation via ->cancel_cb' ); +} + +# immediately cancelled +{ + my $future = Future->new; + $future->cancel; + + my $ready_called; + $future->on_ready( sub { $ready_called++ } ); + my $done_called; + $future->on_done( sub { $done_called++ } ); + my $fail_called; + $future->on_fail( sub { $fail_called++ } ); + + $future->on_ready( my $ready_f = Future->new ); + $future->on_done( my $done_f = Future->new ); + $future->on_fail( my $fail_f = Future->new ); + + is( $ready_called, 1, 'on_ready invoked for already-cancelled future' ); + ok( !$done_called, 'on_done not invoked for already-cancelled future' ); + ok( !$fail_called, 'on_fail not invoked for already-cancelled future' ); + + ok( $ready_f->is_cancelled, 'on_ready chained future cnacelled for already-cancelled future' ); + ok( !$done_f->is_ready, 'on_done chained future not ready for already-cancelled future' ); + ok( !$fail_f->is_ready, 'on_fail chained future not ready for already-cancelled future' ); + + $done_f->cancel; + $fail_f->cancel; +} + +# cancel chaining +{ + my $f1 = Future->new; + my $f2 = Future->new; + + $f1->on_cancel( $f2 ); + my $cancelled; + $f2->on_cancel( sub { $cancelled++ } ); + + $f1->cancel; + is( $cancelled, 1, 'Chained cancellation' ); +} + +# ->done on cancelled +{ + my $f = Future->new; + $f->cancel; + + ok( eval { $f->done( "ignored" ); 1 }, '->done on cancelled future is ignored' ); + ok( eval { $f->fail( "ignored" ); 1 }, '->fail on cancelled future is ignored' ); +} + +# without_cancel +{ + my $f1 = Future->new; + my $f2 = $f1->without_cancel; + + $f2->cancel; + ok( !$f1->is_cancelled, '$f1 not cancelled just because $f2 is' ); + + my $f3 = $f1->without_cancel; + $f1->done( "result" ); + + ok( $f3->is_ready, '$f3 ready when $f1 is' ); + is_deeply( [ $f3->get ], [ "result" ], 'result of $f3' ); +} + +done_testing; diff --git a/t/03then.t b/t/03then.t new file mode 100644 index 0000000..9daea09 --- /dev/null +++ b/t/03then.t @@ -0,0 +1,290 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; +use Test::Identity; + +use Future; + +# then success +{ + my $f1 = Future->new; + + my $f2; + my $fseq = $f1->then( + sub { + is( $_[0], "f1 result", 'then done block passed result of $f1' ); + return $f2 = Future->new; + } + ); + + ok( defined $fseq, '$fseq defined' ); + isa_ok( $fseq, "Future", '$fseq' ); + + is_oneref( $fseq, '$fseq has refcount 1 initially' ); + + ok( !$f2, '$f2 not yet defined before $f1 done' ); + + $f1->done( "f1 result" ); + + ok( defined $f2, '$f2 now defined after $f1 done' ); + + undef $f1; + is_oneref( $fseq, '$fseq has refcount 1 after $f1 done and dropped' ); + + ok( !$fseq->is_ready, '$fseq not yet done before $f2 done' ); + + $f2->done( results => "here" ); + + ok( $fseq->is_ready, '$fseq is done after $f2 done' ); + is_deeply( [ $fseq->get ], [ results => "here" ], '$fseq->get returns results' ); + + undef $f2; + is_oneref( $fseq, '$fseq has refcount 1 before EOF' ); +} + +# then failure in f1 +{ + my $f1 = Future->new; + + my $fseq = $f1->then( + sub { die "then of failed Future should not be invoked" } + ); + + $f1->fail( "A failure\n" ); + + ok( $fseq->is_ready, '$fseq is now ready after $f1 fail' ); + + is( scalar $fseq->failure, "A failure\n", '$fseq fails when $f1 fails' ); +} + +# then failure in f2 +{ + my $f1 = Future->new; + + my $f2; + my $fseq = $f1->then( + sub { return $f2 = Future->new } + ); + + $f1->done; + $f2->fail( "Another failure\n" ); + + ok( $fseq->is_ready, '$fseq is now ready after $f2 fail' ); + + is( scalar $fseq->failure, "Another failure\n", '$fseq fails when $f2 fails' ); +} + +# code dies +{ + my $f1 = Future->new; + + my $fseq = $f1->then( sub { + die "It fails\n"; + } ); + + ok( !defined exception { $f1->done }, 'exception not propagated from done call' ); + + ok( $fseq->is_ready, '$fseq is ready after code exception' ); + is( scalar $fseq->failure, "It fails\n", '$fseq->failure after code exception' ); +} + +# immediately done +{ + my $f1 = Future->done( "Result" ); + + my $f2; + my $fseq = $f1->then( + sub { return $f2 = Future->new } + ); + + ok( defined $f2, '$f2 defined for immediate done' ); + + $f2->done( "Final" ); + + ok( $fseq->is_ready, '$fseq already ready for immediate done' ); + is( scalar $fseq->get, "Final", '$fseq->get for immediate done' ); +} + +# immediately fail +{ + my $f1 = Future->fail( "Failure\n" ); + + my $fseq = $f1->then( + sub { die "then of immediately-failed future should not be invoked" } + ); + + ok( $fseq->is_ready, '$fseq already ready for immediate fail' ); + is( scalar $fseq->failure, "Failure\n", '$fseq->failure for immediate fail' ); +} + +# done fallthrough +{ + my $f1 = Future->new; + my $fseq = $f1->then; + + $f1->done( "fallthrough result" ); + + ok( $fseq->is_ready, '$fseq is ready' ); + is( scalar $fseq->get, "fallthrough result", '->then done fallthrough' ); +} + +# fail fallthrough +{ + my $f1 = Future->new; + my $fseq = $f1->then; + + $f1->fail( "fallthrough failure\n" ); + + ok( $fseq->is_ready, '$fseq is ready' ); + is( scalar $fseq->failure, "fallthrough failure\n", '->then fail fallthrough' ); +} + +# then cancel +{ + my $f1 = Future->new; + my $fseq = $f1->then( sub { die "then done of cancelled Future should not be invoked" } ); + + $fseq->cancel; + + ok( $f1->is_cancelled, '$f1 is cancelled by $fseq cancel' ); + + $f1 = Future->new; + my $f2; + $fseq = $f1->then( sub { return $f2 = Future->new } ); + + $f1->done; + $fseq->cancel; + + ok( $f2->is_cancelled, '$f2 cancelled by $fseq cancel' ); +} + +# then dropping $fseq doesn't fail ->done +{ + local $SIG{__WARN__} = sub {}; + + my $f1 = Future->new; + my $fseq = $f1->then( sub { return Future->done() } ); + + undef $fseq; + + is( exception { $f1->done; }, undef, + 'Dropping $fseq does not cause $f1->done to die' ); +} + +# Void context raises a warning +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; + + Future->done->then( + sub { Future->new } + ); + like( $warnings, + qr/^Calling ->then in void context /, + 'Warning in void context' ); +} + +# Non-Future return raises exception +{ + my $f1 = Future->new; + + my $file = __FILE__; + my $line = __LINE__+1; + my $fseq = $f1->then( sub {} ); + my $fseq2 = $f1->then( sub { Future->done } ); + + ok( !exception { $f1->done }, + '->done with non-Future return from ->then does not die' ); + + like( $fseq->failure, + qr/^Expected __ANON__\(\Q$file\E line $line\) to return a Future/, + 'Failure from non-Future return from ->then' ); + + ok( $fseq2->is_ready, '$fseq2 is ready after failure of $fseq' ); + + my $fseq3; + ok( !exception { $fseq3 = $f1->then( sub {} ) }, + 'non-Future return from ->then on immediate does not die' ); + + like( $fseq3->failure, + qr/^Expected __ANON__\(.*\) to return a Future/, + 'Failure from non-Future return from ->then on immediate' ); +} + +# then_with_f +{ + my $f1 = Future->new; + + my $f2; + my $fseq = $f1->then_with_f( + sub { + identical( $_[0], $f1, 'then_with_f block passed $f1' ); + is( $_[1], "f1 result", 'then_with_f block pased result of $f1' ); + return $f2 = Future->new; + } + ); + + ok( defined $fseq, '$fseq defined' ); + + $f1->done( "f1 result" ); + + ok( defined $f2, '$f2 defined after $f1->done' ); + + $f2->done( "f2 result" ); + + ok( $fseq->is_ready, '$fseq is done after $f2 done' ); + is( scalar $fseq->get, "f2 result", '$fseq->get returns results' ); +} + +# then_done +{ + my $f1 = Future->new; + + my $fseq = $f1->then_done( second => "result" ); + + $f1->done( first => ); + + ok( $fseq->is_ready, '$fseq done after $f1 done' ); + is_deeply( [ $fseq->get ], [ second => "result" ], '$fseq->get returns result for then_done' ); + + my $fseq2 = $f1->then_done( third => "result" ); + + ok( $fseq2->is_ready, '$fseq2 done after ->then_done on immediate' ); + is_deeply( [ $fseq2->get ], [ third => "result" ], '$fseq2->get returns result for then_done on immediate' ); + + my $f2 = Future->new; + $fseq = $f2->then_done( "result" ); + $f2->fail( "failure" ); + + is( scalar $fseq->failure, "failure", '->then_done ignores failure' ); +} + +# then_fail +{ + my $f1 = Future->new; + + my $fseq = $f1->then_fail( second => "result" ); + + $f1->done( first => ); + + ok( $fseq->is_ready, '$fseq done after $f1 done' ); + is_deeply( [ $fseq->failure ], [ second => "result" ], '$fseq->failure returns result for then_fail' ); + + my $fseq2 = $f1->then_fail( third => "result" ); + + ok( $fseq2->is_ready, '$fseq2 done after ->then_fail on immediate' ); + is_deeply( [ $fseq2->failure ], [ third => "result" ], '$fseq2->failure returns result for then_fail on immediate' ); + + my $f2 = Future->new; + $fseq = $f2->then_fail( "fail2" ); + $f2->fail( "failure" ); + + is( scalar $fseq->failure, "failure", '->then_fail ignores failure' ); +} + +done_testing; diff --git a/t/04else.t b/t/04else.t new file mode 100644 index 0000000..2cbc546 --- /dev/null +++ b/t/04else.t @@ -0,0 +1,259 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; +use Test::Identity; + +use Future; + +# else success +{ + my $f1 = Future->new; + + my $fseq = $f1->else( + sub { die "else of successful Future should not be invoked" } + ); + + ok( defined $fseq, '$fseq defined' ); + isa_ok( $fseq, "Future", '$fseq' ); + + is_oneref( $fseq, '$fseq has refcount 1 initially' ); + + $f1->done( results => "here" ); + + is_deeply( [ $fseq->get ], [ results => "here" ], '$fseq succeeds when $f1 succeeds' ); + + undef $f1; + is_oneref( $fseq, '$fseq has refcount 1 before EOF' ); +} + +# else failure +{ + my $f1 = Future->new; + + my $f2; + my $fseq = $f1->else( + sub { + is( $_[0], "f1 failure\n", 'then fail block passed result of $f1' ); + return $f2 = Future->new; + } + ); + + ok( defined $fseq, '$fseq defined' ); + isa_ok( $fseq, "Future", '$fseq' ); + + is_oneref( $fseq, '$fseq has refcount 1 initially' ); + + ok( !$f2, '$f2 not yet defined before $f1 fails' ); + + $f1->fail( "f1 failure\n" ); + + undef $f1; + is_oneref( $fseq, '$fseq has refcount 1 after $f1 fail and dropped' ); + + ok( defined $f2, '$f2 now defined after $f1 fails' ); + + ok( !$fseq->is_ready, '$fseq not yet done before $f2 done' ); + + $f2->done( results => "here" ); + + ok( $fseq->is_ready, '$fseq is done after $f2 done' ); + is_deeply( [ $fseq->get ], [ results => "here" ], '$fseq->get returns results' ); + + undef $f2; + is_oneref( $fseq, '$fseq has refcount 1 before EOF' ); +} + +# Double failure +{ + my $f1 = Future->new; + + my $f2; + my $fseq = $f1->else( + sub { return $f2 = Future->new } + ); + + $f1->fail( "First failure\n" ); + $f2->fail( "Another failure\n" ); + + is( scalar $fseq->failure, "Another failure\n", '$fseq fails when $f2 fails' ); +} + +# code dies +{ + my $f1 = Future->new; + + my $fseq = $f1->else( sub { + die "It fails\n"; + } ); + + ok( !defined exception { $f1->fail( "bork" ) }, 'exception not propagated from fail call' ); + + ok( $fseq->is_ready, '$fseq is ready after code exception' ); + is( scalar $fseq->failure, "It fails\n", '$fseq->failure after code exception' ); +} + +# immediate fail +{ + my $f1 = Future->fail( "Failure\n" ); + + my $f2; + my $fseq = $f1->else( + sub { return $f2 = Future->new } + ); + + ok( defined $f2, '$f2 defined for immediate fail' ); + + $f2->fail( "Another failure\n" ); + + ok( $fseq->is_ready, '$fseq already ready for immediate fail' ); + is( scalar $fseq->failure, "Another failure\n", '$fseq->failure for immediate fail' ); +} + +# immediate done +{ + my $f1 = Future->done( "It works" ); + + my $fseq = $f1->else( + sub { die "else block invoked for immediate done Future" } + ); + + ok( $fseq->is_ready, '$fseq already ready for immediate done' ); + is( scalar $fseq->get, "It works", '$fseq->get for immediate done' ); +} + +# else cancel +{ + my $f1 = Future->new; + my $fseq = $f1->else( sub { die "else of cancelled Future should not be invoked" } ); + + $fseq->cancel; + + ok( $f1->is_cancelled, '$f1 is cancelled by $fseq cancel' ); + + $f1 = Future->new; + my $f2; + $fseq = $f1->else( sub { return $f2 = Future->new } ); + + $f1->fail( "A failure\n" ); + $fseq->cancel; + + ok( $f2->is_cancelled, '$f2 cancelled by $fseq cancel' ); +} + +# Void context raises a warning +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; + + Future->done->else( + sub { Future->new } + ); + like( $warnings, + qr/^Calling ->else in void context /, + 'Warning in void context' ); +} + +# Non-Future return raises exception +{ + my $f1 = Future->new; + + my $file = __FILE__; + my $line = __LINE__+1; + my $fseq = $f1->else( sub {} ); + my $fseq2 = $f1->else( sub { Future->done } ); + + ok( !exception { $f1->fail( "failed\n" ) }, + '->fail with non-Future return from ->else does not die' ); + + like( $fseq->failure, + qr/^Expected __ANON__\(\Q$file\E line $line\) to return a Future/, + 'Failure from non-Future return from ->else' ); + + ok( $fseq2->is_ready, '$fseq2 is ready after failure of $fseq' ); + + my $fseq3; + ok( !exception { $fseq3 = $f1->else( sub {} ) }, + 'non-Future return from ->else on immediate does not die' ); + + like( $fseq3->failure, + qr/^Expected __ANON__\(.*\) to return a Future/, + 'Failure from non-Future return from ->else on immediate' ); +} + +# else_with_f +{ + my $f1 = Future->new; + + my $f2; + my $fseq = $f1->else_with_f( + sub { + identical( $_[0], $f1, 'else_with_f block passed $f1' ); + is( $_[1], "f1 failure\n", 'else_with_f block pased failure of $f1' ); + return $f2 = Future->new; + } + ); + + ok( defined $fseq, '$fseq defined' ); + + $f1->fail( "f1 failure\n" ); + + ok( defined $f2, '$f2 defined after $f1->fail' ); + + $f2->done( "f2 result" ); + + ok( $fseq->is_ready, '$fseq is done after $f2 done' ); + is( scalar $fseq->get, "f2 result", '$fseq->get returns results' ); +} + +# else_done +{ + my $f1 = Future->new; + + my $fseq = $f1->else_done( second => "result" ); + + $f1->fail( first => ); + + ok( $fseq->is_ready, '$fseq done after $f1 done' ); + is_deeply( [ $fseq->get ], [ second => "result" ], '$fseq->get returns result for else_done' ); + + my $fseq2 = $f1->else_done( third => "result" ); + + ok( $fseq2->is_ready, '$fseq2 done after ->else_done on immediate' ); + is_deeply( [ $fseq2->get ], [ third => "result" ], '$fseq2->get returns result for else_done on immediate' ); + + my $f2 = Future->new; + $fseq = $f2->else_done( "result2" ); + $f2->done( "result" ); + + is( scalar $fseq->get, "result", '->else_done ignores success' ); +} + +# else_fail +{ + my $f1 = Future->new; + + my $fseq = $f1->else_fail( second => "result" ); + + $f1->fail( first => ); + + ok( $fseq->is_ready, '$fseq done after $f1 done' ); + is_deeply( [ $fseq->failure ], [ second => "result" ], '$fseq->failure returns result for else_fail' ); + + my $fseq2 = $f1->else_fail( third => "result" ); + + ok( $fseq2->is_ready, '$fseq2 done after ->else_fail on immediate' ); + is_deeply( [ $fseq2->failure ], [ third => "result" ], '$fseq2->failure returns result for else_fail on immediate' ); + + my $f2 = Future->new; + $fseq = $f2->else_fail( "failure" ); + $f2->done( "result" ); + + is( scalar $fseq->get, "result", '->else_fail ignores success' ); +} + +done_testing; diff --git a/t/05then-else.t b/t/05then-else.t new file mode 100644 index 0000000..ff35ac7 --- /dev/null +++ b/t/05then-else.t @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Future; + +# then done +{ + my $f1 = Future->new; + + my $fdone; + my $fseq = $f1->then( + sub { + is( $_[0], "f1 result", '2-arg then done block passed result of $f1' ); + return $fdone = Future->new; + }, + sub { + die "then fail block should not be invoked"; + }, + ); + + $f1->done( "f1 result" ); + + ok( defined $fdone, '$fdone now defined after $f1 done' ); + + $fdone->done( results => "here" ); + + ok( $fseq->is_ready, '$fseq is done after $fdone done' ); + is_deeply( [ $fseq->get ], [ results => "here" ], '$fseq->get returns results' ); +} + +# then fail +{ + my $f1 = Future->new; + + my $ffail; + my $fseq = $f1->then( + sub { + die "then done block should not be invoked"; + }, + sub { + is( $_[0], "The failure\n", '2-arg then fail block passed failure of $f1' ); + return $ffail = Future->new; + }, + ); + + $f1->fail( "The failure\n" ); + + ok( defined $ffail, '$ffail now defined after $f1 fail' ); + + $ffail->done( fallback => "result" ); + + ok( $fseq->is_ready, '$fseq is done after $ffail fail' ); + is_deeply( [ $fseq->get ], [ fallback => "result" ], '$fseq->get returns results' ); +} + +# then done fails doesn't trigger fail block +{ + my $f1 = Future->new; + + my $fdone; + my $fseq = $f1->then( + sub { $fdone = Future->new; }, + sub { die "then fail block should not be invoked"; }, + ); + + $f1->done( "Done" ); + $fdone->fail( "The failure\n" ); + + ok( $fseq->is_ready, '$fseq is ready after $fdone fail' ); + ok( scalar $fseq->failure, '$fseq failed after $fdone fail' ); +} + +done_testing; diff --git a/t/06followed_by.t b/t/06followed_by.t new file mode 100644 index 0000000..3c9418d --- /dev/null +++ b/t/06followed_by.t @@ -0,0 +1,197 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Identity; +use Test::Refcount; + +use Future; + +{ + my $f1 = Future->new; + + my $called = 0; + my $fseq = $f1->followed_by( sub { + $called++; + identical( $_[0], $f1, 'followed_by block passed $f1' ); + return $_[0]; + } ); + + ok( defined $fseq, '$fseq defined' ); + isa_ok( $fseq, "Future", '$fseq' ); + + is_oneref( $fseq, '$fseq has refcount 1 initially' ); + # Two refs; one in lexical $f1, one in $fseq's cancellation closure + is_refcount( $f1, 2, '$f1 has refcount 2 initially' ); + + is( $called, 0, '$called before $f1 done' ); + + $f1->done( results => "here" ); + + is( $called, 1, '$called after $f1 done' ); + + ok( $fseq->is_ready, '$fseq is done after $f1 done' ); + is_deeply( [ $fseq->get ], [ results => "here" ], '$fseq->get returns results' ); + + is_oneref( $fseq, '$fseq has refcount 1 before EOF' ); + is_oneref( $f1, '$f1 has refcount 1 before EOF' ); +} + +{ + my $f1 = Future->new; + + my $called = 0; + my $fseq = $f1->followed_by( sub { + $called++; + identical( $_[0], $f1, 'followed_by block passed $f1' ); + return $_[0]; + } ); + + ok( defined $fseq, '$fseq defined' ); + isa_ok( $fseq, "Future", '$fseq' ); + + is_oneref( $fseq, '$fseq has refcount 1 initially' ); + + is( $called, 0, '$called before $f1 done' ); + + $f1->fail( "failure\n" ); + + is( $called, 1, '$called after $f1 failed' ); + + ok( $fseq->is_ready, '$fseq is ready after $f1 failed' ); + is_deeply( [ $fseq->failure ], [ "failure\n" ], '$fseq->get returns failure' ); + + is_oneref( $fseq, '$fseq has refcount 1 before EOF' ); +} + +# code dies +{ + my $f1 = Future->new; + + my $fseq = $f1->followed_by( sub { + die "It fails\n"; + } ); + + ok( !defined exception { $f1->done }, 'exception not propagated from code call' ); + + ok( $fseq->is_ready, '$fseq is ready after code exception' ); + is( scalar $fseq->failure, "It fails\n", '$fseq->failure after code exception' ); +} + +# Cancellation +{ + my $f1 = Future->new; + + my $fseq = $f1->followed_by( + sub { die "followed_by of cancelled Future should not be invoked" } + ); + + $fseq->cancel; + + ok( $f1->is_cancelled, '$f1 cancelled by $fseq->cancel' ); + + $f1 = Future->new; + my $f2 = Future->new; + + $fseq = $f1->followed_by( sub { $f2 } ); + + $f1->done; + $fseq->cancel; + + ok( $f2->is_cancelled, '$f2 cancelled by $fseq->cancel' ); + + $f1 = Future->done; + $f2 = Future->new; + + $fseq = $f1->followed_by( sub { $f2 } ); + + $fseq->cancel; + + ok( $f2->is_cancelled, '$f2 cancelled by $fseq->cancel on $f1 immediate' ); +} + +# immediately done +{ + my $f1 = Future->done; + + my $called = 0; + my $fseq = $f1->followed_by( + sub { $called++; return $_[0] } + ); + + is( $called, 1, 'followed_by block invoked immediately for already-done' ); +} + +# immediately done +{ + my $f1 = Future->fail("Failure\n"); + + my $called = 0; + my $fseq = $f1->followed_by( + sub { $called++; return $_[0] } + ); + + is( $called, 1, 'followed_by block invoked immediately for already-failed' ); +} + +# immediately code dies +{ + my $f1 = Future->done; + + my $fseq; + + ok( !defined exception { + $fseq = $f1->followed_by( sub { + die "It fails\n"; + } ); + }, 'exception not propagated from ->followed_by on immediate' ); + + ok( $fseq->is_ready, '$fseq is ready after code exception on immediate' ); + is( scalar $fseq->failure, "It fails\n", '$fseq->failure after code exception on immediate' ); +} + +# Void context raises a warning +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; + + Future->done->followed_by( + sub { Future->new } + ); + + like( $warnings, + qr/^Calling ->followed_by in void context at /, + 'Warning in void context' ); +} + +# Non-Future return raises exception +{ + my $f1 = Future->new; + + my $file = __FILE__; + my $line = __LINE__+1; + my $fseq = $f1->followed_by( sub {} ); + my $fseq2 = $f1->followed_by( sub { Future->done } ); + + ok( !exception { $f1->done }, + '->done with non-Future return from ->followed_by does not die' ); + + like( $fseq->failure, + qr/^Expected __ANON__\(\Q$file\E line $line\) to return a Future/, + 'Failure from non-Future return from ->followed_by' ); + + ok( $fseq2->is_ready, '$fseq2 is ready after failure of $fseq' ); + + my $fseq3; + ok( !exception { $fseq3 = $f1->followed_by( sub {} ) }, + 'non-Future return from ->followed_by on immediate does not die' ); + + like( $fseq3->failure, + qr/^Expected __ANON__\(.*\) to return a Future/, + 'Failure from non-Future return from ->followed_by on immediate' ); +} + +done_testing; diff --git a/t/09transform.t b/t/09transform.t new file mode 100644 index 0000000..67f7e25 --- /dev/null +++ b/t/09transform.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Future; + +# Result transformation +{ + my $f1 = Future->new; + + my $future = $f1->transform( + done => sub { result => @_ }, + ); + + $f1->done( 1, 2, 3 ); + + is_deeply( [ $future->get ], [ result => 1, 2, 3 ], '->transform result' ); +} + +# Failure transformation +{ + my $f1 = Future->new; + + my $future = $f1->transform( + fail => sub { "failure\n" => @_ }, + ); + + $f1->fail( "something failed\n" ); + + is_deeply( [ $future->failure ], [ "failure\n" => "something failed\n" ], '->transform failure' ); +} + +# code dies +{ + my $f1 = Future->new; + + my $future = $f1->transform( + done => sub { die "It fails\n" }, + ); + + $f1->done; + + is_deeply( [ $future->failure ], [ "It fails\n" ], '->transform catches exceptions' ); +} + +# Cancellation +{ + my $f1 = Future->new; + + my $cancelled; + $f1->on_cancel( sub { $cancelled++ } ); + + my $future = $f1->transform; + + $future->cancel; + is( $cancelled, 1, '->transform cancel' ); +} + +# Void context raises a warning +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; + + Future->done->transform( + done => sub { } + ); + like( $warnings, + qr/^Calling ->transform in void context at /, + 'Warning in void context' ); +} + +done_testing; diff --git a/t/10wait_all.t b/t/10wait_all.t new file mode 100644 index 0000000..9331b61 --- /dev/null +++ b/t/10wait_all.t @@ -0,0 +1,160 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use Test::Refcount; + +use Future; + +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->wait_all( $f1, $f2 ); + is_oneref( $future, '$future has refcount 1 initially' ); + + # Two refs; one lexical here, one in $future + is_refcount( $f1, 2, '$f1 has refcount 2 after adding to ->wait_all' ); + is_refcount( $f2, 2, '$f2 has refcount 2 after adding to ->wait_all' ); + + is_deeply( [ $future->pending_futures ], + [ $f1, $f2 ], + '$future->pending_futures before any ready' ); + + is_deeply( [ $future->ready_futures ], + [], + '$future->done_futures before any ready' ); + + my @on_ready_args; + $future->on_ready( sub { @on_ready_args = @_ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + is( scalar @on_ready_args, 0, 'on_ready not yet invoked' ); + + $f1->done( one => 1 ); + + is_deeply( [ $future->pending_futures ], + [ $f2 ], + '$future->pending_futures after $f1 ready' ); + + is_deeply( [ $future->ready_futures ], + [ $f1 ], + '$future->ready_futures after $f1 ready' ); + + is_deeply( [ $future->done_futures ], + [ $f1 ], + '$future->done_futures after $f1 ready' ); + + ok( !$future->is_ready, '$future still not yet ready after f1 ready' ); + is( scalar @on_ready_args, 0, 'on_ready not yet invoked' ); + + $f2->done( two => 2 ); + + is( scalar @on_ready_args, 1, 'on_ready passed 1 argument' ); + identical( $on_ready_args[0], $future, 'Future passed to on_ready' ); + undef @on_ready_args; + + ok( $future->is_ready, '$future now ready after f2 ready' ); + my @results = $future->get; + identical( $results[0], $f1, 'Results[0] from $future->get is f1' ); + identical( $results[1], $f2, 'Results[1] from $future->get is f2' ); + undef @results; + + is_deeply( [ $future->pending_futures ], + [], + '$future->pending_futures after $f2 ready' ); + + is_deeply( [ $future->ready_futures ], + [ $f1, $f2 ], + '$future->ready_futures after $f2 ready' ); + + is_deeply( [ $future->done_futures ], + [ $f1, $f2 ], + '$future->done_futures after $f2 ready' ); + + is_refcount( $future, 1, '$future has refcount 1 at end of test' ); + undef $future; + + is_refcount( $f1, 1, '$f1 has refcount 1 at end of test' ); + is_refcount( $f2, 1, '$f2 has refcount 1 at end of test' ); +} + +# immediately done +{ + my $f1 = Future->done; + + my $future = Future->wait_all( $f1 ); + + ok( $future->is_ready, '$future of already-ready sub already ready' ); + my @results = $future->get; + identical( $results[0], $f1, 'Results from $future->get of already ready' ); +} + +# one immediately done +{ + my $f1 = Future->done; + my $f2 = Future->new; + + my $future = Future->wait_all( $f1, $f2 ); + + ok( !$future->is_ready, '$future of partially-done subs not yet ready' ); + + $f2->done; + + ok( $future->is_ready, '$future of completely-done subs already ready' ); + my @results = $future->get; + identical( $results[0], $f1, 'Results from $future->get of already ready' ); +} + +# cancel propagation +{ + my $f1 = Future->new; + my $c1; + $f1->on_cancel( sub { $c1++ } ); + + my $f2 = Future->new; + my $c2; + $f2->on_cancel( sub { $c2++ } ); + + my $future = Future->wait_all( $f1, $f2 ); + + $f2->done; + + $future->cancel; + + is( $c1, 1, '$future->cancel marks subs cancelled' ); + is( $c2, undef, '$future->cancel ignores ready subs' ); +} + +# cancelled convergent +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->wait_all( $f1, $f2 ); + + $f1->done( "result" ); + $f2->cancel; + + ok( $future->is_ready, '$future of cancelled sub is ready after final cancellation' ); + + is_deeply( [ $future->done_futures ], + [ $f1 ], + '->done_futures with cancellation' ); + is_deeply( [ $future->cancelled_futures ], + [ $f2 ], + '->cancelled_futures with cancellation' ); +} + +# wait_all on none +{ + my $f = Future->wait_all( () ); + + ok( $f->is_ready, 'wait_all on no Futures already done' ); + is_deeply( [ $f->get ], [], '->get on empty wait_all is empty' ); +} + +done_testing; diff --git a/t/11wait_any.t b/t/11wait_any.t new file mode 100644 index 0000000..c72629e --- /dev/null +++ b/t/11wait_any.t @@ -0,0 +1,152 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Identity; +use Test::Refcount; + +use Future; + +# First done +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->wait_any( $f1, $f2 ); + is_oneref( $future, '$future has refcount 1 initially' ); + + # Two refs; one lexical here, one in $future + is_refcount( $f1, 2, '$f1 has refcount 2 after adding to ->wait_any' ); + is_refcount( $f2, 2, '$f2 has refcount 2 after adding to ->wait_any' ); + + is_deeply( [ $future->pending_futures ], + [ $f1, $f2 ], + '$future->pending_futures before any ready' ); + + is_deeply( [ $future->ready_futures ], + [], + '$future->done_futures before any ready' ); + + my @on_ready_args; + $future->on_ready( sub { @on_ready_args = @_ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + is( scalar @on_ready_args, 0, 'on_ready not yet invoked' ); + + $f1->done( one => 1 ); + + is_deeply( [ $future->pending_futures ], + [], + '$future->pending_futures after $f1 ready' ); + + is_deeply( [ $future->ready_futures ], + [ $f1, $f2 ], + '$future->ready_futures after $f1 ready' ); + + is_deeply( [ $future->done_futures ], + [ $f1 ], + '$future->done_futures after $f1 ready' ); + + is_deeply( [ $future->cancelled_futures ], + [ $f2 ], + '$future->cancelled_futures after $f1 ready' ); + + is( scalar @on_ready_args, 1, 'on_ready passed 1 argument' ); + identical( $on_ready_args[0], $future, 'Future passed to on_ready' ); + undef @on_ready_args; + + ok( $future->is_ready, '$future now ready after f1 ready' ); + is_deeply( [ $future->get ], [ one => 1 ], 'results from $future->get' ); + + is_refcount( $future, 1, '$future has refcount 1 at end of test' ); + undef $future; + + is_refcount( $f1, 1, '$f1 has refcount 1 at end of test' ); + is_refcount( $f2, 1, '$f2 has refcount 1 at end of test' ); +} + +# First fails +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->wait_any( $f1, $f2 ); + + $f1->fail( "It fails\n" ); + + ok( $future->is_ready, '$future now ready after a failure' ); + + is( $future->failure, "It fails\n", '$future->failure yields exception' ); + + is( exception { $future->get }, "It fails\n", '$future->get throws exception' ); + + ok( $f2->is_cancelled, '$f2 cancelled after a failure' ); +} + +# immediately done +{ + my $f1 = Future->done; + + my $future = Future->wait_any( $f1 ); + + ok( $future->is_ready, '$future of already-ready sub already ready' ); +} + +# cancel propagation +{ + my $f1 = Future->new; + my $c1; + $f1->on_cancel( sub { $c1++ } ); + + my $future = Future->wait_all( $f1 ); + + $future->cancel; + + is( $c1, 1, '$future->cancel marks subs cancelled' ); +} + +# cancelled convergent +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->wait_any( $f1, $f2 ); + + $f1->cancel; + + ok( !$future->is_ready, '$future not yet ready after first cancellation' ); + + $f2->done( "result" ); + + ok( $future->is_ready, '$future is ready' ); + + is_deeply( [ $future->done_futures ], + [ $f2 ], + '->done_futures with cancellation' ); + is_deeply( [ $future->cancelled_futures ], + [ $f1 ], + '->cancelled_futures with cancellation' ); + + my $f3 = Future->new; + $future = Future->wait_any( $f3 ); + + $f3->cancel; + + ok( $future->is_ready, '$future is ready after final cancellation' ); + + like( scalar $future->failure, qr/ cancelled/, 'Failure mentions cancelled' ); +} + +# wait_any on none +{ + my $f = Future->wait_any( () ); + + ok( $f->is_ready, 'wait_any on no Futures already done' ); + is( scalar $f->failure, "Cannot ->wait_any with no subfutures", + '->get on empty wait_any is empty' ); +} + +done_testing; diff --git a/t/12needs_all.t b/t/12needs_all.t new file mode 100644 index 0000000..fe9cd36 --- /dev/null +++ b/t/12needs_all.t @@ -0,0 +1,147 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +use Future; + +# All done +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->needs_all( $f1, $f2 ); + is_oneref( $future, '$future has refcount 1 initially' ); + + # Two refs; one lexical here, one in $future + is_refcount( $f1, 2, '$f1 has refcount 2 after adding to ->needs_all' ); + is_refcount( $f2, 2, '$f2 has refcount 2 after adding to ->needs_all' ); + + my $ready; + $future->on_ready( sub { $ready++ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + + $f1->done( one => 1 ); + $f2->done( two => 2 ); + + is( $ready, 1, '$future is now ready' ); + + ok( $future->is_ready, '$future now ready after f2 ready' ); + is_deeply( [ $future->get ], [ one => 1, two => 2 ], '$future->get after f2 ready' ); + + is_refcount( $future, 1, '$future has refcount 1 at end of test' ); + undef $future; + + is_refcount( $f1, 1, '$f1 has refcount 1 at end of test' ); + is_refcount( $f2, 1, '$f2 has refcount 1 at end of test' ); +} + +# One fails +{ + my $f1 = Future->new; + my $f2 = Future->new; + my $c2; + $f2->on_cancel( sub { $c2++ } ); + + my $future = Future->needs_all( $f1, $f2 ); + + my $ready; + $future->on_ready( sub { $ready++ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + + $f1->fail( "It fails" ); + + is( $ready, 1, '$future is now ready' ); + + ok( $future->is_ready, '$future now ready after f1 fails' ); + is( $future->failure, "It fails", '$future->failure yields exception' ); + my $file = __FILE__; + my $line = __LINE__ + 1; + like( exception { $future->get }, qr/^It fails at \Q$file line $line\E\.?\n$/, '$future->get throws exception' ); + + is( $c2, 1, 'Unfinished child future cancelled on failure' ); + + is_deeply( [ $future->pending_futures ], + [], + '$future->pending_futures after $f1 failure' ); + + is_deeply( [ $future->ready_futures ], + [ $f1, $f2 ], + '$future->ready_futures after $f1 failure' ); + + is_deeply( [ $future->done_futures ], + [], + '$future->done_futures after $f1 failure' ); + + is_deeply( [ $future->failed_futures ], + [ $f1 ], + '$future->failed_futures after $f1 failure' ); + + is_deeply( [ $future->cancelled_futures ], + [ $f2 ], + '$future->cancelled_futures after $f1 failure' ); +} + +# immediately done +{ + my $future = Future->needs_all( Future->done ); + + ok( $future->is_ready, '$future of already-done sub already ready' ); +} + +# immediately fails +{ + my $future = Future->needs_all( Future->fail("F1"), Future->done ); + + ok( $future->is_ready, '$future of already-failed sub already ready' ); +} + +# cancel propagation +{ + my $f1 = Future->new; + my $c1; + $f1->on_cancel( sub { $c1++ } ); + + my $f2 = Future->new; + my $c2; + $f2->on_cancel( sub { $c2++ } ); + + my $future = Future->needs_all( $f1, $f2 ); + + $f2->done; + + $future->cancel; + + is( $c1, 1, '$future->cancel marks subs cancelled' ); + is( $c2, undef, '$future->cancel ignores ready subs' ); +} + +# cancelled convergent +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->needs_all( $f1, $f2 ); + + $f1->cancel; + + ok( $future->is_ready, '$future of cancelled sub is ready after first cancellation' ); + + like( scalar $future->failure, qr/ cancelled/, 'Failure mentions cancelled' ); +} + +# needs_all on none +{ + my $f = Future->needs_all( () ); + + ok( $f->is_ready, 'needs_all on no Futures already done' ); + is_deeply( [ $f->get ], [], '->get on empty needs_all is empty' ); +} + +done_testing; diff --git a/t/13needs_any.t b/t/13needs_any.t new file mode 100644 index 0000000..b94a762 --- /dev/null +++ b/t/13needs_any.t @@ -0,0 +1,200 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +use Future; + +# One done +{ + my $f1 = Future->new; + my $f2 = Future->new; + my $c2; + $f2->on_cancel( sub { $c2++ } ); + + my $future = Future->needs_any( $f1, $f2 ); + is_oneref( $future, '$future has refcount 1 initially' ); + + # Two refs; one lexical here, one in $future + is_refcount( $f1, 2, '$f1 has refcount 2 after adding to ->needs_any' ); + is_refcount( $f2, 2, '$f2 has refcount 2 after adding to ->needs_any' ); + + my $ready; + $future->on_ready( sub { $ready++ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + + $f1->done( one => 1 ); + + is( $ready, 1, '$future is now ready' ); + + ok( $future->is_ready, '$future now ready after f1 ready' ); + is_deeply( [ $future->get ], [ one => 1 ], 'results from $future->get' ); + + is_deeply( [ $future->pending_futures ], + [], + '$future->pending_futures after $f1 done' ); + + is_deeply( [ $future->ready_futures ], + [ $f1, $f2 ], + '$future->ready_futures after $f1 done' ); + + is_deeply( [ $future->done_futures ], + [ $f1 ], + '$future->done_futures after $f1 done' ); + + is_deeply( [ $future->failed_futures ], + [], + '$future->failed_futures after $f1 done' ); + + is_deeply( [ $future->cancelled_futures ], + [ $f2 ], + '$future->cancelled_futures after $f1 done' ); + + is_refcount( $future, 1, '$future has refcount 1 at end of test' ); + undef $future; + + is_refcount( $f1, 1, '$f1 has refcount 1 at end of test' ); + is_refcount( $f2, 1, '$f2 has refcount 1 at end of test' ); + + is( $c2, 1, 'Unfinished child future cancelled on failure' ); +} + +# One fails +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->needs_any( $f1, $f2 ); + + my $ready; + $future->on_ready( sub { $ready++ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + + $f1->fail( "Partly fails" ); + + ok( !$future->is_ready, '$future not yet ready after $f1 fails' ); + + $f2->done( two => 2 ); + + ok( $future->is_ready, '$future now ready after $f2 done' ); + is_deeply( [ $future->get ], [ two => 2 ], '$future->get after $f2 done' ); + + is_deeply( [ $future->done_futures ], + [ $f2 ], + '$future->done_futures after $f2 done' ); + + is_deeply( [ $future->failed_futures ], + [ $f1 ], + '$future->failed_futures after $f2 done' ); +} + +# All fail +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->needs_any( $f1, $f2 ); + + my $ready; + $future->on_ready( sub { $ready++ } ); + + ok( !$future->is_ready, '$future not yet ready' ); + + $f1->fail( "Partly fails" ); + + $f2->fail( "It fails" ); + + is( $ready, 1, '$future is now ready' ); + + ok( $future->is_ready, '$future now ready after f2 fails' ); + is( $future->failure, "It fails", '$future->failure yields exception' ); + my $file = __FILE__; + my $line = __LINE__ + 1; + like( exception { $future->get }, qr/^It fails at \Q$file line $line\E\.?\n$/, '$future->get throws exception' ); + + is_deeply( [ $future->failed_futures ], + [ $f1, $f2 ], + '$future->failed_futures after all fail' ); +} + +# immediately done +{ + my $future = Future->needs_any( Future->fail("F1"), Future->done ); + + ok( $future->is_ready, '$future of already-done sub already ready' ); +} + +# immediately fails +{ + my $future = Future->needs_any( Future->fail("F1") ); + + ok( $future->is_ready, '$future of already-failed sub already ready' ); + $future->failure; +} + +# cancel propagation +{ + my $f1 = Future->new; + my $c1; + $f1->on_cancel( sub { $c1++ } ); + + my $f2 = Future->new; + my $c2; + $f2->on_cancel( sub { $c2++ } ); + + my $future = Future->needs_all( $f1, $f2 ); + + $f2->fail( "booo" ); + + $future->cancel; + + is( $c1, 1, '$future->cancel marks subs cancelled' ); + is( $c2, undef, '$future->cancel ignores ready subs' ); +} + +# cancelled convergent +{ + my $f1 = Future->new; + my $f2 = Future->new; + + my $future = Future->needs_any( $f1, $f2 ); + + $f1->cancel; + + ok( !$future->is_ready, '$future not yet ready after first cancellation' ); + + $f2->done( "result" ); + + is_deeply( [ $future->done_futures ], + [ $f2 ], + '->done_futures with cancellation' ); + is_deeply( [ $future->cancelled_futures ], + [ $f1 ], + '->cancelled_futures with cancellation' ); + + my $f3 = Future->new; + $future = Future->needs_any( $f3 ); + + $f3->cancel; + + ok( $future->is_ready, '$future is ready after final cancellation' ); + + like( scalar $future->failure, qr/ cancelled/, 'Failure mentions cancelled' ); +} + +# needs_any on none +{ + my $f = Future->needs_any( () ); + + ok( $f->is_ready, 'needs_any on no Futures already done' ); + is( scalar $f->failure, "Cannot ->needs_any with no subfutures", + '->get on empty needs_any is empty' ); +} + +done_testing; diff --git a/t/20subclass.t b/t/20subclass.t new file mode 100644 index 0000000..9d7103d --- /dev/null +++ b/t/20subclass.t @@ -0,0 +1,138 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; + +# subclass->... +{ + my $f = t::Future::Subclass->new; + my @seq; + + isa_ok( $seq[@seq] = $f->then( sub {} ), + "t::Future::Subclass", + '$f->then' ); + + isa_ok( $seq[@seq] = $f->else( sub {} ), + "t::Future::Subclass", + '$f->and_then' ); + + isa_ok( $seq[@seq] = $f->then_with_f( sub {} ), + "t::Future::Subclass", + '$f->then_with_f' ); + + isa_ok( $seq[@seq] = $f->else_with_f( sub {} ), + "t::Future::Subclass", + '$f->else_with_f' ); + + isa_ok( $seq[@seq] = $f->followed_by( sub {} ), + "t::Future::Subclass", + '$f->followed_by' ); + + isa_ok( $seq[@seq] = $f->transform(), + "t::Future::Subclass", + '$f->transform' ); + + $_->cancel for @seq; +} + +# immediate->followed_by( sub { subclass } ) +{ + my $f = t::Future::Subclass->new; + my $seq; + + isa_ok( $seq = Future->done->followed_by( sub { $f } ), + "t::Future::Subclass", + 'imm->followed_by $f' ); + + $seq->cancel; +} + +# convergents +{ + my $f = t::Future::Subclass->new; + my @seq; + + isa_ok( $seq[@seq] = Future->wait_all( $f ), + "t::Future::Subclass", + 'Future->wait_all( $f )' ); + + isa_ok( $seq[@seq] = Future->wait_any( $f ), + "t::Future::Subclass", + 'Future->wait_any( $f )' ); + + isa_ok( $seq[@seq] = Future->needs_all( $f ), + "t::Future::Subclass", + 'Future->needs_all( $f )' ); + + isa_ok( $seq[@seq] = Future->needs_any( $f ), + "t::Future::Subclass", + 'Future->needs_any( $f )' ); + + my $imm = Future->done; + + isa_ok( $seq[@seq] = Future->wait_all( $imm, $f ), + "t::Future::Subclass", + 'Future->wait_all( $imm, $f )' ); + + # Pick the more derived subclass even if all are pending + + isa_ok( $seq[@seq] = Future->wait_all( Future->new, $f ), + "t::Future::Subclass", + 'Future->wait_all( Future->new, $f' ); + + $_->cancel for @seq; +} + +# empty convergents (RT97537) +{ + my $f; + + isa_ok( $f = t::Future::Subclass->wait_all(), + "t::Future::Subclass", + 'subclass ->wait_all' ); + + isa_ok( $f = t::Future::Subclass->wait_any(), + "t::Future::Subclass", + 'subclass ->wait_any' ); + $f->failure; + + isa_ok( $f = t::Future::Subclass->needs_all(), + "t::Future::Subclass", + 'subclass ->needs_all' ); + + isa_ok( $f = t::Future::Subclass->needs_any(), + "t::Future::Subclass", + 'subclass ->needs_any' ); + $f->failure; +} + +my $f_await; +{ + my $f = t::Future::Subclass->new; + + my $count = 0; + $f_await = sub { + $count++; + identical( $_[0], $f, '->await is called on $f' ); + $_[0]->done( "Result here" ) if $count == 2; + }; + + is_deeply( [ $f->get ], + [ "Result here" ], + 'Result from ->get' ); + + is( $count, 2, '$f->await called twice' ); +} + +done_testing; + +package t::Future::Subclass; +use base qw( Future ); + +sub await +{ + $f_await->( @_ ); +} diff --git a/t/21debug.t b/t/21debug.t new file mode 100644 index 0000000..8ad5508 --- /dev/null +++ b/t/21debug.t @@ -0,0 +1,83 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PERL_FUTURE_DEBUG} = 1; +} + +use Future; + +use Time::HiRes qw( gettimeofday tv_interval ); + +my $LINE; +my $LOSTLINE; + +sub warnings(&) +{ + my $code = shift; + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= shift }; + $code->(); + $LOSTLINE = __LINE__; return $warnings; +} + +is( warnings { + my $f = Future->new; + $f->done; + }, "", 'Completed Future does not give warning' ); + +is( warnings { + my $f = Future->new; + $f->cancel; + }, "", 'Cancelled Future does not give warning' ); + +like( warnings { + $LINE = __LINE__; my $f = Future->new; + undef $f; + }, + qr/^Future=\S+ was constructed at \Q$0\E line $LINE and was lost near \Q$0\E line (?:$LOSTLINE|${\($LINE+1)}) before it was ready\.?$/, + 'Lost Future raises a warning' ); + +my $THENLINE; +my $SEQLINE; +like( warnings { + $LINE = __LINE__; my $f1 = Future->new; + $THENLINE = __LINE__; my $fseq = $f1->then( sub { } ); undef $fseq; + $SEQLINE = __LINE__; $f1->done; + }, + qr/^Future=\S+ was constructed at \Q$0\E line $THENLINE and was lost near \Q$0\E line (?:$SEQLINE|$THENLINE) before it was ready\.? +Future=\S+ \(constructed at \Q$0\E line $LINE\) lost a sequence Future at \Q$0\E line $SEQLINE\.?$/, + 'Lost sequence Future raises warning' ); + +like( warnings { + $LINE = __LINE__; my $f = Future->fail("Failed!"); + undef $f; + }, + qr/^Future=\S+ was constructed at \Q$0\E line $LINE and was lost near \Q$0\E line (?:$LOSTLINE|${\($LINE+1)}) with an unreported failure of: Failed!\.?/, + 'Destroyed failed future raises warning' ); + +{ + local $Future::TIMES = 1; + + my $before = [ gettimeofday ]; + + my $future = Future->new; + + ok( defined $future->btime, '$future has btime with $TIMES=1' ); + ok( tv_interval( $before, $future->btime ) >= 0, '$future btime is not earlier than $before' ); + + $future->done; + + ok( defined $future->rtime, '$future has rtime with $TIMES=1' ); + ok( tv_interval( $future->btime, $future->rtime ) >= 0, '$future rtime is not earlier than btime' ); + ok( tv_interval( $future->rtime ) >= 0, '$future rtime is not later than now' ); + + ok( defined $future->elapsed, '$future has ->elapsed time' ); + ok( $future->elapsed >= 0, '$future elapsed time >= 0' ); +} + +done_testing; diff --git a/t/22wrap_cb.t b/t/22wrap_cb.t new file mode 100644 index 0000000..cdd6a59 --- /dev/null +++ b/t/22wrap_cb.t @@ -0,0 +1,105 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Future; + +our $VAR = ""; +# around Future::wrap_cb => sub { ... } +{ + my $orig = Future->can( 'wrap_cb' ); + no warnings 'redefine'; + *Future::wrap_cb = sub { + my $cb = $orig->(@_); + my $saved_VAR = $VAR; + + return sub { + local $VAR = $saved_VAR; + $cb->(@_); + }; + }; +} + +# on_ready +{ + my $result; + my $f = Future->new; + + { + local $VAR = "inner"; + $f->on_ready( sub { $result = $VAR } ); + } + + $f->done; + + is( $result, "inner", 'on_ready wraps CB' ); +} + +# on_done +{ + my $result; + my $f = Future->new; + + { + local $VAR = "inner"; + $f->on_done( sub { $result = $VAR } ); + } + + $f->done; + + is( $result, "inner", 'on_done wraps CB' ); +} + +# on_fail +{ + my $result; + my $f = Future->new; + + { + local $VAR = "inner"; + $f->on_fail( sub { $result = $VAR } ); + } + + $f->fail( "Failed" ); + + is( $result, "inner", 'on_fail wraps CB' ); +} + +# then +{ + my $result; + my $f = Future->new; + + my $f2; + { + local $VAR = "inner"; + $f2 = $f->then( sub { $result = $VAR; Future->done } ); + } + + $f->done; + + is( $result, "inner", 'then wraps CB' ); +} + +# else +{ + my $result; + my $f = Future->new; + + my $f2; + { + local $VAR = "inner"; + $f2 = $f->else( sub { $result = $VAR; Future->done } ); + } + + $f->fail( "Failed" ); + + is( $result, "inner", 'else wraps CB' ); +} + +# Other sequence methods all use the same ->_sequence so all should be fine + +done_testing; diff --git a/t/30utils-call.t b/t/30utils-call.t new file mode 100644 index 0000000..221d302 --- /dev/null +++ b/t/30utils-call.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; + +use Future; +use Future::Utils qw( call ); + +# call returns future +{ + my $ret_f; + my $f = call { + return $ret_f = Future->new; + }; + + identical( $f, $ret_f, 'call() returns future returned from its code' ); + $f->cancel; +} + +# call returns immediate failure on die +{ + my $f = call { + die "argh!\n"; + }; + + ok( $f->is_ready, 'call() returns immediate future on die' ); + is( scalar $f->failure, "argh!\n", 'failure from immediate future on die' ); +} + +# call returns immediate failure on non-Future return +{ + my $f = call { + return "non-future"; + }; + + ok( $f->is_ready, 'call() returns immediate future on non-future return' ); + like( scalar $f->failure, qr/^Expected __ANON__.*\(\S+ line \d+\) to return a Future$/, + 'failure from immediate future on non-future return' ); +} + +done_testing; diff --git a/t/31utils-call-with-escape.t b/t/31utils-call-with-escape.t new file mode 100644 index 0000000..973900c --- /dev/null +++ b/t/31utils-call-with-escape.t @@ -0,0 +1,70 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; + +use Future; +use Future::Utils qw( call_with_escape ); + +# call_with_escape normal return +{ + my $ret_f; + my $f = call_with_escape { + return $ret_f = Future->new; + }; + + $ret_f->done( "result" ); + + ok( $f->is_ready, 'call_with_escape ready after returned future ready' ); + is( scalar $f->get, "result", 'result of call_with_escape' ); + + $f = call_with_escape { + return $ret_f = Future->new; + }; + + $ret_f->fail( "failure" ); + + ok( $f->is_ready, 'call_with_escape ready after returned future ready' ); + is( scalar $f->failure, "failure", 'result of call_with_escape' ); + + undef $ret_f; + is_oneref( $f, 'call_with_escape has refcount 1 before EOF' ); +} + +# call_with_escape synchronous escape +{ + my $f = call_with_escape { + my $escape = shift; + $escape->done( "escaped" ); + }; + + ok( $f->is_ready, 'call_with_escape ready after synchronous escape' ); + is( scalar $f->get, "escaped", 'result of call_with_escape' ); +} + +# call_with_escape delayed escape +{ + my $ret_f = Future->new; + my $inner_f; + + my $f = call_with_escape { + my $escape = shift; + return $inner_f = $ret_f->then( sub { + return $escape->done( "later escape" ); + }); + }; + + ok( !$f->is_ready, 'call_with_escape not yet ready before deferral' ); + + $ret_f->done; + + ok( $f->is_ready, 'call_with_escape ready after deferral' ); + is( scalar $f->get, "later escape", 'result of call_with_escape' ); + + ok( $inner_f->is_cancelled, 'code-returned future cancelled after escape' ); +} + +done_testing; diff --git a/t/32utils-repeat.t b/t/32utils-repeat.t new file mode 100644 index 0000000..4ee03ce --- /dev/null +++ b/t/32utils-repeat.t @@ -0,0 +1,188 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; + +use Future; +use Future::Utils qw( repeat try_repeat try_repeat_until_success ); + +{ + my $trial_f; + my $previous_trial; + my $arg; + my $again; + my $future = repeat { + $previous_trial = shift; + return $trial_f = Future->new + } while => sub { $arg = shift; $again }; + + ok( defined $future, '$future defined for repeat while' ); + + ok( defined $trial_f, 'An initial future is running' ); + + my $first_f = $trial_f; + + $again = 1; + $trial_f->done( "one" ); + + ok( defined $arg, '$arg defined for while test' ); + is( scalar $arg->get, "one", '$arg->get for first' ); + + identical( $previous_trial, $first_f, 'code block is passed previous trial' ); + + $again = 0; + $trial_f->done( "two" ); + + ok( $future->is_ready, '$future is now ready after second attempt ->done' ); + is( scalar $future->get, "two", '$future->get' ); +} + +# return keyword +{ + my $trial_f; + my $future = repeat { + return $trial_f = Future->new + } while => sub { 1 }, return => my $ret = Future->new; + + identical( $future, $ret, 'repeat with return yields correct instance' ); +} + +# cancellation +{ + my @running; my $i = 0; + my $future = repeat { + return $running[$i++] = Future->new + } while => sub { 1 }; + + ok( defined $future, '$future defined for repeat while' ); + + ok( defined $running[0], 'An initial future is running' ); + + $running[0]->done; + + $future->cancel; + + ok( !$running[0]->is_cancelled, 'previously running future not cancelled' ); + ok( $running[1]->is_cancelled, 'running future cancelled after eventual is cancelled' ); + ok( !$running[2], 'a third trial is not started' ); +} + +# until +{ + my $trial_f; + my $arg; + my $accept; + my $future = repeat { + return $trial_f = Future->new + } until => sub { $arg = shift; $accept }; + + ok( defined $future, '$future defined for repeat until' ); + + ok( defined $trial_f, 'An initial future is running' ); + + $accept = 0; + $trial_f->done( "three" ); + + ok( defined $arg, '$arg defined for while test' ); + is( scalar $arg->get, "three", '$arg->get for first' ); + + $accept = 1; + $trial_f->done( "four" ); + + ok( $future->is_ready, '$future is now ready after second attempt ->done' ); + is( scalar $future->get, "four", '$future->get' ); +} + +# body code dies +{ + my $future; + + $future = repeat { + die "It failed\n"; + } while => sub { !shift->failure }; + + is( $future->failure, "It failed\n", 'repeat while failure after code exception' ); + + $future = repeat { + die "It failed\n"; + } until => sub { shift->failure }; + + is( $future->failure, "It failed\n", 'repeat until failure after code exception' ); +} + +# condition code dies (RT100067) +{ + my $future = repeat { + Future->done(1); + } while => sub { die "it dies!\n" }; + + is( $future->failure, "it dies!\n", 'repeat while failure after condition exception' ); +} + +# Non-Future return fails +{ + my $future; + + $future = repeat { + "non-Future" + } while => sub { !shift->failure }; + + like( $future->failure, qr/^Expected __ANON__.*\(\S+ line \d+\) to return a Future$/, + 'repeat failure for non-Future return' ); +} + +# try_repeat catches failures +{ + my $attempt = 0; + my $future = try_repeat { + if( ++$attempt < 3 ) { + return FUture->new->fail( "Too low" ); + } + else { + return Future->done( $attempt ); + } + } while => sub { shift->failure }; + + ok( $future->is_ready, '$future is now ready for try_repeat' ); + is( scalar $future->get, 3, '$future->get' ); +} + +{ + my $attempt = 0; + my $future = try_repeat_until_success { + if( ++$attempt < 3 ) { + return Future->fail( "Too low" ); + } + else { + return Future->done( $attempt ); + } + }; + + ok( $future->is_ready, '$future is now ready for try_repeat_until_success' ); + is( scalar $future->get, 3, '$future->get' ); +} + +# repeat prints a warning if asked to retry a failure +{ + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + + my $attempt = 0; + my $future = repeat { + if( ++$attempt < 3 ) { + return Future->fail( "try again" ); + } + else { + return Future->done( "OK" ); + } + } while => sub { $_[0]->failure }; + + ok( $future->is_ready, '$future is now ready after repeat retries failures' ); + like( $warnings, qr/(?:^Using Future::Utils::repeat to retry a failure is deprecated; use try_repeat instead at \Q$0\E line \d+\.?$)+/m, + 'Warnings printing by repeat retries failures' ); +} + +done_testing; diff --git a/t/33utils-repeat-generate.t b/t/33utils-repeat-generate.t new file mode 100644 index 0000000..72410fb --- /dev/null +++ b/t/33utils-repeat-generate.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Future; +use Future::Utils qw( repeat ); + +# generate without otherwise +{ + my $trial_f; + my $arg; + + my $i = 0; + my $future = repeat { + $arg = shift; + return $trial_f = Future->new; + } generate => sub { $i < 3 ? ++$i : () }; + + is( $arg, 1, '$arg 1 for first iteration' ); + $trial_f->done; + + ok( !$future->is_ready, '$future not ready' ); + + is( $arg, 2, '$arg 2 for second iteratoin' ); + $trial_f->done( "not yet" ); + + ok( !$future->is_ready, '$future still not ready' ); + + is( $arg, 3, '$arg 3 for third iteration' ); + $trial_f->done( "result" ); + + ok( $future->is_ready, '$future now ready' ); + is( scalar $future->get, "result", '$future->get' ); +} + +# generate otherwise +{ + my $last_trial_f; + my $i = 0; + my $future = repeat { + Future->done( "ignore me $_[0]" ); + } generate => sub { $i < 3 ? ++$i : () }, + otherwise => sub { + $last_trial_f = shift; + return Future->fail( "Nothing succeeded\n" ); + }; + + is( scalar $future->failure, "Nothing succeeded\n", '$future returns otherwise failure' ); + is( scalar $last_trial_f->get, "ignore me 3", '$last_trial_f->get' ); + + $future = repeat { + Future->done( "ignore me" ); + } generate => sub { () }, + otherwise => sub { Future->fail( "Nothing to do\n" ) }; + + is( scalar $future->failure, "Nothing to do\n", '$future returns otherwise failure for empty generator' ); +} + +# Probably don't need much more testing since most combinations are test with +# foreach - while/until, die, etc.. + +done_testing; diff --git a/t/34utils-repeat-foreach.t b/t/34utils-repeat-foreach.t new file mode 100644 index 0000000..94d70d6 --- /dev/null +++ b/t/34utils-repeat-foreach.t @@ -0,0 +1,152 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Future; +use Future::Utils qw( repeat try_repeat try_repeat_until_success ); + +# foreach without otherwise +{ + my $trial_f; + my $arg; + my $future = repeat { + $arg = shift; + return $trial_f = Future->new; + } foreach => [qw( one two three )]; + + is( $arg, "one", '$arg one for first iteration' ); + $trial_f->done; + + ok( !$future->is_ready, '$future not ready' ); + + is( $arg, "two", '$arg two for second iteration' ); + $trial_f->done( "another" ); + + ok( !$future->is_ready, '$future not ready' ); + + is( $arg, "three", '$arg three for third iteration' ); + $trial_f->done( "result" ); + + ok( $future->is_ready, '$future now ready' ); + is( scalar $future->get, "result", '$future->get' ); +} + +# foreach otherwise +{ + my $last_trial_f; + my $future = repeat { + Future->done( "ignore me $_[0]" ); + } foreach => [qw( one two three )], + otherwise => sub { + $last_trial_f = shift; + return Future->fail( "Nothing succeeded\n" ); + }; + + is( scalar $future->failure, "Nothing succeeded\n", '$future returns otherwise failure' ); + is( scalar $last_trial_f->get, "ignore me three", '$last_trial_f->get' ); + + $future = repeat { + Future->done( "ignore me" ); + } foreach => [], + otherwise => sub { Future->fail( "Nothing to do\n" ) }; + + is( scalar $future->failure, "Nothing to do\n", '$future returns otherwise failure for empty list' ); +} + +# foreach on empty list +{ + my $future = repeat { die "Not invoked" } foreach => []; + + ok( $future->is_ready, 'repeat {} on empty foreach without otherwise already ready' ); + is_deeply( [ $future->get ], [], 'Result of empty future' ); + + $future = repeat { die "Not invoked" } foreach => [], + otherwise => sub { Future->done( 1, 2, 3 ) }; + + ok( $future->is_ready, 'repeat {} on empty foreach with otherwise already ready' ); + is_deeply( [ $future->get ], [ 1, 2, 3 ], 'Result of otherwise future' ); +} + +# foreach while +{ + my $future = try_repeat { + my $arg = shift; + if( $arg eq "bad" ) { + return Future->fail( "bad" ); + } + else { + return Future->done( $arg ); + } + } foreach => [qw( bad good not-attempted )], + while => sub { shift->failure }; + + is( scalar $future->get, "good", '$future->get returns correct result for foreach+while' ); +} + +# foreach until +{ + my $future = try_repeat { + my $arg = shift; + if( $arg eq "bad" ) { + return Future->fail( "bad" ); + } + else { + return Future->done( $arg ); + } + } foreach => [qw( bad good not-attempted )], + until => sub { !shift->failure }; + + is( scalar $future->get, "good", '$future->get returns correct result for foreach+until' ); +} + +# foreach while + otherwise +{ + my $future = repeat { + Future->done( $_[0] ); + } foreach => [ 1, 2, 3 ], + while => sub { $_[0]->get < 2 }, + otherwise => sub { Future->fail( "Failed to find 2" ) }; + + is( scalar $future->get, 2, '$future->get returns successful result from while + otherwise' ); +} + +# try_repeat_until_success foreach +{ + my $future = try_repeat_until_success { + my $arg = shift; + if( $arg eq "bad" ) { + return Future->fail( "bad" ); + } + else { + return Future->done( $arg ); + } + } foreach => [qw( bad good not-attempted )]; + + is( scalar $future->get, "good", '$future->get returns correct result for try_repeat_until_success' ); +} + +# main code dies +{ + my $future = try_repeat { + $_[1]->failure if @_ > 1; # absorb the previous failure + + die "It failed\n"; + } foreach => [ 1, 2, 3 ]; + + is( $future->failure, "It failed\n", 'repeat foreach failure after code exception' ); +} + +# otherwise code dies +{ + my $future = repeat { + Future->done; + } foreach => [], + otherwise => sub { die "It failed finally\n" }; + + is( $future->failure, "It failed finally\n", 'repeat foreach failure after otherwise exception' ); +} + +done_testing; diff --git a/t/35utils-map-void.t b/t/35utils-map-void.t new file mode 100644 index 0000000..3f62e5f --- /dev/null +++ b/t/35utils-map-void.t @@ -0,0 +1,200 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; + +use Future; +use Future::Utils qw( fmap_void ); + +# fmap_void from ARRAY, no concurrency +{ + my @subf; + my $future = fmap_void { + return $subf[$_[0]] = Future->new + } foreach => [ 0 .. 2 ]; + + ok( defined $future, '$future defined for fmap non-concurrent' ); + + ok( defined $subf[0], '$subf[0] defined' ); + ok( !defined $subf[1], '$subf[1] not yet defined' ); + + $subf[0]->done; + + ok( defined $subf[1], '$subf[1] defined after $subf[0] done' ); + + $subf[1]->done; + + $subf[2]->done; + + ok( $future->is_ready, '$future now ready after subs done' ); + is_deeply( [ $future->get ], [], '$future->get empty for fmap_void' ); +} + +# fmap_void from CODE +{ + my @subf; + my $future = fmap_void { + return $subf[$_[0]] = Future->new + } generate => do { my $count = 0; + sub { return unless $count < 3; $count++ } }; + + ok( defined $future, '$future defined for fmap non-concurrent from CODE' ); + + ok( defined $subf[0], '$subf[0] defined' ); + + $subf[0]->done; + $subf[1]->done; + $subf[2]->done; + + ok( $future->is_ready, '$future now ready after subs done from CODE' ); +} + +# fmap_void concurrent +{ + my @subf; + my $future = fmap_void { + return $subf[$_[0]] = Future->new + } foreach => [ 0 .. 4 ], + concurrent => 2; + + ok( defined $future, '$future defined for fmap concurrent=2' ); + + ok( defined $subf[0], '$subf[0] defined' ); + ok( defined $subf[1], '$subf[1] defined' ); + + $subf[0]->done; $subf[1]->done; + + ok( defined $subf[2], '$subf[2] defined' ); + ok( defined $subf[3], '$subf[3] defined' ); + + $subf[2]->done; $subf[3]->done; + + ok( defined $subf[4], '$subf[4] deifned' ); + ok( !$future->is_ready, '$future not yet ready while one sub remains' ); + + $subf[4]->done; + + ok( $future->is_ready, '$future now ready after concurrent subs done' ); +} + +# fmap_void late-addition concurrently +{ + my @items = ( 1, 2, 3 ); + my @subf; + my $future = fmap_void { + my $val = shift; + my $f = $subf[$val] = Future->new; + $f->on_done( sub { push @items, 4, 5, 6 } ) if $val == 3; + $f + } foreach => \@items, + concurrent => 4; + + ok( defined $future, '$future defined for fmap concurrent=3 late-add' ); + + ok( $subf[1] && $subf[2] && $subf[3], '3 subfutures initally ready' ); + + $subf[1]->done; + $subf[2]->done; + + ok( !$subf[4], 'No $subf[4] before $subf[3] done' ); + + $subf[3]->done; + + ok( $subf[4] && $subf[5] && $subf[6], '3 new subfutures now ready' ); + + $subf[4]->done; + $subf[5]->done; + $subf[6]->done; + + ok( $future->is_ready, '$future now ready after all 6 subfutures done' ); +} + +# fmap_void on immediates +{ + my $future = fmap_void { + return Future->done + } foreach => [ 0 .. 2 ]; + + ok( $future->is_ready, '$future already ready for fmap on immediates' ); +} + +# fmap_void on non/immediate mix +{ + my @item_f = ( my $item = Future->new, Future->done, Future->done ); + my $future = fmap_void { + return $_[0]; + } foreach => \@item_f, + concurrent => 2; + + ok( !$future->is_ready, '$future not yet ready before non-immediate done' ); + + $item->done; + ok( $future->is_ready, '$future now ready after non-immediate done' ); +} + +# fmap_void fail +{ + my @subf; + my $future = fmap_void { + return $subf[$_[0]] = Future->new; + } foreach => [ 0, 1, 2 ], + concurrent => 2; + + ok( !$subf[0]->is_cancelled, '$subf[0] not cancelled before failure' ); + + $subf[1]->fail( "failure" ); + + ok( $subf[0]->is_cancelled, '$subf[0] now cancelled after $subf[1] failure' ); + ok( $future->is_ready, '$future now ready after $sub[1] failure' ); + is( scalar $future->failure, "failure", '$future->failure after $sub[1] failure' ); + ok( !defined $subf[2], '$subf[2] was never started after $subf[1] failure' ); +} + +# fmap_void immediate fail +{ + my @subf; + my $future = fmap_void { + if( $_[0] eq "fail" ) { + return Future->fail( "failure" ); + } + else { + $subf[$_[0]] = Future->new; + } + } foreach => [ 0, "fail", 2 ], + concurrent => 3; + + ok( $future->is_ready, '$future is already ready' ); + is( scalar $future->failure, "failure", '$future->failure after immediate failure' ); + + ok( $subf[0]->is_cancelled, '$subf[0] is cancelled after immediate failure' ); + ok( !defined $subf[2], '$subf[2] was never started after immediate failure' ); +} + +# fmap_void cancel +{ + my @subf; + my $future = fmap_void { + return $subf[$_[0]] = Future->new; + } foreach => [ 0, 1, 2 ], + concurrent => 2; + + $future->cancel; + + ok( $subf[0]->is_cancelled, '$subf[0] now cancelled after ->cancel' ); + ok( $subf[1]->is_cancelled, '$subf[1] now cancelled after ->cancel' ); + ok( !defined $subf[2], '$subf[2] was never started after ->cancel' ); +} + +# fmap_void return +{ + my $future = fmap_void { + return Future->done; + } foreach => [ 0 ], return => my $ret = Future->new; + + identical( $future, $ret, 'repeat with return yields correct instance' ); +} + +done_testing; diff --git a/t/36utils-map.t b/t/36utils-map.t new file mode 100644 index 0000000..a19c43c --- /dev/null +++ b/t/36utils-map.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Future; +use Future::Utils qw( fmap_concat fmap_scalar ); + +# fmap_concat no concurrency +{ + my @subf; + my $future = fmap_concat { + return $subf[$_[0]] = Future->new + } foreach => [ 0 .. 2 ]; + + my @results; + $future->on_done( sub { @results = @_ }); + + $subf[0]->done( "A", "B" ); + $subf[1]->done( "C", "D", ); + $subf[2]->done( "E" ); + + ok( $future->is_ready, '$future now ready after subs done for fmap_concat' ); + is_deeply( [ $future->get ], [qw( A B C D E )], '$future->get for fmap_concat' ); + is_deeply( \@results, [qw( A B C D E )], '@results for fmap_concat' ); +} + +# fmap_concat concurrent +{ + my @subf; + my $future = fmap_concat { + return $subf[$_[0]] = Future->new + } foreach => [ 0 .. 2 ], + concurrent => 3; + + # complete out of order + $subf[0]->done( "A", "B" ); + $subf[2]->done( "E" ); + $subf[1]->done( "C", "D" ); + + is_deeply( [ $future->get ], [qw( A B C D E )], '$future->get for fmap_concat out of order' ); +} + +# fmap_scalar no concurrency +{ + my @subf; + my $future = fmap_scalar { + return $subf[$_[0]] = Future->new + } foreach => [ 0 .. 2 ]; + + my @results; + $future->on_done( sub { @results = @_ }); + + $subf[0]->done( "A" ); + $subf[1]->done( "B" ); + $subf[2]->done( "C" ); + + ok( $future->is_ready, '$future now ready after subs done for fmap_scalar' ); + is_deeply( [ $future->get ], [qw( A B C )], '$future->get for fmap_scalar' ); + is_deeply( \@results, [qw( A B C )], '@results for fmap_scalar' ); +} + +done_testing; diff --git a/t/50test-future.t b/t/50test-future.t new file mode 100644 index 0000000..326066e --- /dev/null +++ b/t/50test-future.t @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; +use Test::Builder::Tester; + +use Future; +use Test::Future; + +# pass +{ + test_out( "ok 1 - immediate Future" ); + + my $ran_code; + no_pending_futures { + $ran_code++; + Future->done(1,2,3); + } 'immediate Future'; + + test_test( "immediate Future passes" ); + ok( $ran_code, 'actually ran the code' ); +} + +# fail +{ + test_out( "not ok 1 - pending Future" ); + test_fail( +8 ); + test_err( "# The following Futures are still pending:" ); + test_err( qr/^# 0x[0-9a-f]+\n/ ); + test_err( qr/^# Writing heap dump to \S+\n/ ) if Test::Future::HAVE_DEVEL_MAT_DUMPER; + + my $f; + no_pending_futures { + $f = Future->new; + } 'pending Future'; + + test_test( "pending Future fails" ); + + $f->cancel; +} + +# does not retain Futures +{ + test_out( "ok 1 - refcount 2 before drop" ); + test_out( "ok 2 - refcount 1 after drop" ); + test_out( "ok 3 - retain" ); + + no_pending_futures { + my $arr = [1,2,3]; + my $f = Future->new; + $f->done( $arr ); + is_refcount( $arr, 2, 'refcount 2 before drop' ); + undef $f; + is_refcount( $arr, 1, 'refcount 1 after drop' ); + } 'retain'; + + test_test( "no_pending_futures does not retain completed Futures" ); +} + +# does not retain immedate Futures +{ + test_out( "ok 1 - refcount 2 before drop" ); + test_out( "ok 2 - refcount 1 after drop" ); + test_out( "ok 3 - retain" ); + + no_pending_futures { + my $arr = [1,2,3]; + my $f = Future->done( $arr ); + is_refcount( $arr, 2, 'refcount 2 before drop' ); + undef $f; + is_refcount( $arr, 1, 'refcount 1 after drop' ); + } 'retain'; + + test_test( "no_pending_futures does not retain immediate Futures" ); +} + +END { + # Clean up Devel::MAT dumpfile + my $pmat = $0; + $pmat =~ s/\.t$/-1.pmat/; + unlink $pmat if -f $pmat; +} + +done_testing; diff --git a/t/99pod.t b/t/99pod.t new file mode 100644 index 0000000..eb319fb --- /dev/null +++ b/t/99pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); |