File Coverage

blib/lib/Future/PP.pm
Criterion Covered Total %
statement 563 573 98.2
branch 284 320 88.7
condition 135 165 81.8
subroutine 74 74 100.0
pod 0 48 0.0
total 1056 1180 89.4


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2011-2022 -- leonerd@leonerd.org.uk
5              
6             package Future::PP;
7              
8 33     33   393 use v5.10;
  33         128  
9 33     33   222 use strict;
  33         71  
  33         653  
10 33     33   160 use warnings;
  33         66  
  33         955  
11 33     33   216 no warnings 'recursion'; # Disable the "deep recursion" warning
  33         81  
  33         2142  
12              
13             our $VERSION = '0.50';
14             our @ISA = qw( Future::_base );
15              
16 33     33   246 use Carp qw(); # don't import croak
  33         92  
  33         1010  
17 33     33   193 use Scalar::Util qw( weaken blessed reftype );
  33         75  
  33         2100  
18 33     33   221 use Time::HiRes qw( gettimeofday );
  33         80  
  33         384  
19              
20             our @CARP_NOT = qw( Future Future::_base Future::Utils );
21              
22 33     33   5495 use constant DEBUG => !!$ENV{PERL_FUTURE_DEBUG};
  33         80  
  33         2639  
23              
24 33     33   244 use constant STRICT => !!$ENV{PERL_FUTURE_STRICT};
  33         69  
  33         3170  
25              
26             # Callback flags
27             use constant {
28 33         4638 CB_DONE => 1<<0, # Execute callback on done
29             CB_FAIL => 1<<1, # Execute callback on fail
30             CB_CANCEL => 1<<2, # Execute callback on cancellation
31              
32             CB_SELF => 1<<3, # Pass $self as first argument
33             CB_RESULT => 1<<4, # Pass result/failure as a list
34              
35             CB_SEQ_ONDONE => 1<<5, # Sequencing on success (->then)
36             CB_SEQ_ONFAIL => 1<<6, # Sequencing on failure (->else)
37              
38             CB_SEQ_IMDONE => 1<<7, # $code is in fact immediate ->done result
39             CB_SEQ_IMFAIL => 1<<8, # $code is in fact immediate ->fail result
40              
41             CB_SEQ_STRICT => 1<<9, # Complain if $code didn't return a Future
42 33     33   246 };
  33         64  
43              
44 33     33   244 use constant CB_ALWAYS => CB_DONE|CB_FAIL|CB_CANCEL;
  33         80  
  33         234371  
45              
46             sub _shortmess
47             {
48 6     6   669 my $at = Carp::shortmess( $_[0] );
49 6         96 chomp $at; $at =~ s/\.$//;
  6         28  
50 6         16 return $at;
51             }
52              
53             sub _callable
54             {
55 454     454   718 my ( $cb ) = @_;
56 454 50 33     2620 defined $cb and ( reftype($cb) eq 'CODE' || overload::Method($cb, '&{}') );
57             }
58              
59             sub new
60             {
61 706     706 0 102635 my $proto = shift;
62             return bless {
63             ready => 0,
64             callbacks => [], # [] = [$type, ...]
65             ( DEBUG ?
66 706 100 66     4065 ( do { my $at = Carp::shortmess( "constructed" );
67             chomp $at; $at =~ s/\.$//;
68             constructed_at => $at } )
69             : () ),
70             ( $Future::TIMES ?
71             ( btime => [ gettimeofday ] )
72             : () ),
73             }, ( ref $proto || $proto );
74             }
75              
76             sub __selfstr
77             {
78 16     8   972 my $self = shift;
79 16 50       1009 return "$self" unless defined $self->{label};
80 8         35 return "$self (\"$self->{label}\")";
81             }
82              
83             my $GLOBAL_END;
84 33     33   60491 END { $GLOBAL_END = 1; }
85              
86             sub DESTROY_debug {
87 16     8 0 468 my $self = shift;
88 8 50       17 return if $GLOBAL_END;
89 8 100 66     48 return if $self->{ready} and ( $self->{reported} or !$self->{failure} );
      100        
90              
91 3         11 my $lost_at = join " line ", (caller)[1,2];
92             # We can't actually know the real line where the last reference was lost;
93             # a variable set to 'undef' or close of scope, because caller can't see it;
94             # the current op has already been updated. The best we can do is indicate
95             # 'near'.
96              
97 3 100 66     18 if( $self->{ready} and $self->{failure} ) {
    50          
98 1         3 warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at with an unreported failure of: " .
99 1         2 $self->{failure}[0] . "\n";
100             }
101             elsif( !$self->{ready} ) {
102 2         3 warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at before it was ready.\n";
  2         8  
103             }
104             }
105             *DESTROY = \&DESTROY_debug if DEBUG;
106              
107             sub is_ready
108             {
109 477     477 0 12248 my $self = shift;
110 477         1510 return $self->{ready};
111             }
112              
113             sub is_done
114             {
115 75     75 0 151 my $self = shift;
116 75   66     641 return $self->{ready} && !$self->{failure} && !$self->{cancelled};
117             }
118              
119             sub is_failed
120             {
121 9     9 0 39 my $self = shift;
122 9   100     67 return $self->{ready} && !!$self->{failure}; # boolify
123             }
124              
125             sub is_cancelled
126             {
127 42     42 0 1748 my $self = shift;
128 42         187 return $self->{cancelled};
129             }
130              
131             sub state
132             {
133 4     4 0 11 my $self = shift;
134             return !$self->{ready} ? "pending" :
135             DEBUG ? $self->{ready_at} :
136             $self->{failure} ? "failed" :
137 4 100       34 $self->{cancelled} ? "cancelled" :
    100          
    100          
138             "done";
139             }
140              
141             sub _mark_ready
142             {
143 548     548   776 my $self = shift;
144 548         756 $self->{ready} = 1;
145 548         777 $self->{ready_at} = _shortmess $_[0] if DEBUG;
146              
147 548 100       984 if( $Future::TIMES ) {
148 4         14 $self->{rtime} = [ gettimeofday ];
149             }
150              
151 548         1000 delete $self->{on_cancel};
152 548   66     668 $_->[0] and $_->[0]->_revoke_on_cancel( $_->[1] ) for @{ $self->{revoke_when_ready} };
  548         1534  
153 548         997 delete $self->{revoke_when_ready};
154              
155 548 100       1186 my $callbacks = delete $self->{callbacks} or return;
156              
157 543         831 my $cancelled = $self->{cancelled};
158 543         849 my $fail = defined $self->{failure};
159 543   100     1631 my $done = !$fail && !$cancelled;
160              
161 334         665 my @result = $done ? @{ $self->{result} } :
162 543 100       1120 $fail ? @{ $self->{failure} } :
  98 100       242  
163             ();
164              
165 543         1281 foreach my $cb ( @$callbacks ) {
166 335         575 my ( $flags, $code ) = @$cb;
167 335   66     987 my $is_future = blessed( $code ) && $code->isa( "Future" );
168              
169 335 100 100     1165 next if $done and not( $flags & CB_DONE );
170 295 100 100     696 next if $fail and not( $flags & CB_FAIL );
171 292 100 100     812 next if $cancelled and not( $flags & CB_CANCEL );
172              
173 260 100       481 $self->{reported} = 1 if $fail;
174              
175 260 100       599 if( $is_future ) {
    100          
176 23 100       108 $done ? $code->done( @result ) :
    100          
177             $fail ? $code->fail( @result ) :
178             $code->cancel;
179             }
180             elsif( $flags & (CB_SEQ_ONDONE|CB_SEQ_ONFAIL) ) {
181 60         111 my ( undef, undef, $fseq ) = @$cb;
182 60 100       136 if( !$fseq ) { # weaken()ed; it might be gone now
183             # This warning should always be printed, even not in DEBUG mode.
184             # It's always an indication of a bug
185 2         3 Carp::carp +(DEBUG ? "${\$self->__selfstr} ($self->{constructed_at})"
186 2         27 : "${\$self->__selfstr} $self" ) .
187             " lost a sequence Future";
188 2         80 next;
189             }
190              
191 58         78 my $f2;
192 58 100 100     293 if( $done and $flags & CB_SEQ_ONDONE or
      100        
      100        
193             $fail and $flags & CB_SEQ_ONFAIL ) {
194              
195 52 100       140 if( $flags & CB_SEQ_IMDONE ) {
    100          
196 2         8 $fseq->done( @$code );
197 2         7 next;
198             }
199             elsif( $flags & CB_SEQ_IMFAIL ) {
200 2         10 $fseq->fail( @$code );
201 2         6 next;
202             }
203              
204 48 100       151 my @args = (
    100          
205             ( $flags & CB_SELF ? $self : () ),
206             ( $flags & CB_RESULT ? @result : () ),
207             );
208              
209 48 100       76 unless( eval { $f2 = $code->( @args ); 1 } ) {
  48         112  
  44         915  
210 4         42 $fseq->fail( $@ );
211 4         26 next;
212             }
213              
214 44 100 66     295 unless( blessed $f2 and $f2->isa( "Future" ) ) {
215             # Upgrade a non-Future result, or complain in strict mode
216 3 50       14 if( $flags & CB_SEQ_STRICT ) {
217 0         0 $fseq->fail( "Expected " . Future::CvNAME_FILE_LINE($code) . " to return a Future" );
218 0         0 next;
219             }
220 3         9 $f2 = Future->done( $f2 );
221             }
222              
223 44         112 $fseq->on_cancel( $f2 );
224             }
225             else {
226 6         18 $f2 = $self;
227             }
228              
229 50 100       131 if( $f2->is_ready ) {
230 30 50       127 $f2->on_ready( $fseq ) if !$f2->{cancelled};
231             }
232             else {
233 20         42 push @{ $f2->{callbacks} }, [ CB_DONE|CB_FAIL, $fseq ];
  20         48  
234 20         147 weaken( $f2->{callbacks}[-1][1] );
235             }
236             }
237             else {
238 177 100       613 $code->(
    100          
239             ( $flags & CB_SELF ? $self : () ),
240             ( $flags & CB_RESULT ? @result : () ),
241             );
242             }
243             }
244             }
245              
246             sub done
247             {
248 400     400 0 84064 my $self = shift;
249              
250 400 100       888 if( ref $self ) {
251 309 100       694 $self->{cancelled} and return $self;
252 306 50       606 $self->{ready} and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->done";
  0         0  
253 306 50       560 $self->{subs} and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->done";
  0         0  
254 306         642 $self->{result} = [ @_ ];
255 306         833 $self->_mark_ready( "done" );
256             }
257             else {
258 91         224 $self = $self->new;
259 91         193 $self->{ready} = 1;
260 91         130 $self->{ready_at} = _shortmess "done" if DEBUG;
261 91         264 $self->{result} = [ @_ ];
262 91 100       239 if( $Future::TIMES ) {
263 1         3 $self->{rtime} = [ gettimeofday ];
264             }
265             }
266              
267 397         969 return $self;
268             }
269              
270             sub fail
271             {
272 140     140 0 24949 my $self = shift;
273 140         311 my ( $exception, @more ) = @_;
274              
275 140 100       375 if( ref $exception eq "Future::Exception" ) {
276 2         6 @more = ( $exception->category, $exception->details );
277 2         5 $exception = $exception->message;
278             }
279              
280 140 50       377 $exception or Carp::croak "$self ->fail requires an exception that is true";
281              
282 140 100       297 if( ref $self ) {
283 82 100       252 $self->{cancelled} and return $self;
284 81 50       179 $self->{ready} and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->fail'ed";
  0         0  
285 81 50       194 $self->{subs} and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->fail'ed";
  0         0  
286 81         211 $self->{failure} = [ $exception, @more ];
287 81         191 $self->_mark_ready( "failed" );
288             }
289             else {
290 58         180 $self = $self->new;
291 58         137 $self->{ready} = 1;
292 58         153 $self->{ready_at} = _shortmess "failed" if DEBUG;
293 58         150 $self->{failure} = [ $exception, @more ];
294 58 100       178 if( $Future::TIMES ) {
295 1         5 $self->{rtime} = [ gettimeofday ];
296             }
297             }
298              
299 139         434 return $self;
300             }
301              
302             sub on_cancel
303             {
304 326     326 0 1189 my $self = shift;
305 326         482 my ( $code ) = @_;
306              
307 326   66     1290 my $is_future = blessed( $code ) && $code->isa( "Future" );
308 326 50 66     829 $is_future or _callable( $code ) or
309             Carp::croak "Expected \$code to be callable or a Future in ->on_cancel";
310              
311 326 100       710 $self->{ready} and return $self;
312              
313 303         381 push @{ $self->{on_cancel} }, $code;
  303         660  
314 303 100       588 if( $is_future ) {
315 219         258 push @{ $code->{revoke_when_ready} }, my $r = [ $self, \$self->{on_cancel}[-1] ];
  219         658  
316 219         619 weaken( $r->[0] );
317 219         471 weaken( $r->[1] );
318             }
319              
320 303         515 return $self;
321             }
322              
323             # An optimised version for Awaitable role
324             sub AWAIT_ON_CANCEL
325             {
326 1     1 0 11 my $self = shift;
327 1         3 my ( $code ) = @_;
328              
329 1         1 push @{ $self->{on_cancel} }, $code;
  1         3  
330             }
331              
332             sub AWAIT_CHAIN_CANCEL
333             {
334 1     1 0 8 my $self = shift;
335 1         2 my ( $f2 ) = @_;
336              
337 1         2 push @{ $self->{on_cancel} }, $f2;
  1         3  
338 1         1 push @{ $f2->{revoke_when_ready} }, my $r = [ $self, \$self->{on_cancel}[-1] ];
  1         4  
339 1         4 weaken( $r->[0] );
340 1         4 weaken( $r->[1] );
341             }
342              
343             sub _revoke_on_cancel
344             {
345 193     193   284 my $self = shift;
346 193         311 my ( $ref ) = @_;
347              
348 193         301 undef $$ref;
349 193         289 $self->{empty_on_cancel_slots}++;
350              
351 193 100       391 my $on_cancel = $self->{on_cancel} or return;
352              
353             # If the list is nontrivally large and over half-empty / under half-full, compact it
354 172 100 100     600 if( @$on_cancel >= 8 and $self->{empty_on_cancel_slots} >= 0.5 * @$on_cancel ) {
355             # We can't grep { defined } because that will break all the existing SCALAR refs
356 3         7 my $idx = 0;
357 3         9 while( $idx < @$on_cancel ) {
358 175 100       259 defined $on_cancel->[$idx] and $idx++, next;
359 88         174 splice @$on_cancel, $idx, 1, ();
360             }
361 3         7 $self->{empty_on_cancel_slots} = 0;
362             }
363             }
364              
365             sub on_ready
366             {
367 165     165 0 13175 my $self = shift;
368 165         283 my ( $code ) = @_;
369              
370 165   66     561 my $is_future = blessed( $code ) && $code->isa( "Future" );
371 165 50 66     462 $is_future or _callable( $code ) or
372             Carp::croak "Expected \$code to be callable or a Future in ->on_ready";
373              
374 165 100       444 if( $self->{ready} ) {
375 40         79 my $fail = defined $self->{failure};
376 40   100     179 my $done = !$fail && !$self->{cancelled};
377              
378 40 100       125 $self->{reported} = 1 if $fail;
379              
380 24         83 $is_future ? ( $done ? $code->done( @{ $self->{result} } ) :
381 40 100       167 $fail ? $code->fail( @{ $self->{failure} } ) :
  8 100       30  
    100          
382             $code->cancel )
383             : $code->( $self );
384             }
385             else {
386 125         173 push @{ $self->{callbacks} }, [ CB_ALWAYS|CB_SELF, $self->wrap_cb( on_ready => $code ) ];
  125         380  
387             }
388              
389 165         526 return $self;
390             }
391              
392             # An optimised version for Awaitable role
393             sub AWAIT_ON_READY
394             {
395 1     1 0 17 my $self = shift;
396 1         2 my ( $code ) = @_;
397 1         2 push @{ $self->{callbacks} }, [ CB_ALWAYS|CB_SELF, $self->wrap_cb( on_ready => $code ) ];
  1         4  
398             }
399              
400             sub result
401             {
402 96     96 0 3591 my $self = shift;
403             $self->{ready} or
404 96 100       276 Carp::croak( "${\$self->__selfstr} is not yet ready" );
  1         9  
405 95 100       256 if( my $failure = $self->{failure} ) {
406 11         26 $self->{reported} = 1;
407 11         33 my $exception = $failure->[0];
408 11 100       42 $exception = Future::Exception->new( @$failure ) if @$failure > 1;
409 11 100 100     1388 !ref $exception && $exception =~ m/\n$/ ? CORE::die $exception : Carp::croak $exception;
410             }
411 84 100       200 $self->{cancelled} and Carp::croak "${\$self->__selfstr} was cancelled";
  2         10  
412 82 100       354 return $self->{result}->[0] unless wantarray;
413 38         60 return @{ $self->{result} };
  38         279  
414             }
415              
416             sub get
417             {
418 10     10 0 104 my $self = shift;
419 10 100       46 $self->await unless $self->{ready};
420 9         31 return $self->result;
421             }
422              
423             sub await
424             {
425 4     4 0 17 my $self = shift;
426 4 100       15 return $self if $self->{ready};
427 1         100 Carp::croak "$self is not yet complete and does not provide ->await";
428             }
429              
430             sub on_done
431             {
432 89     89 0 496 my $self = shift;
433 89         141 my ( $code ) = @_;
434              
435 89   66     296 my $is_future = blessed( $code ) && $code->isa( "Future" );
436 89 50 66     225 $is_future or _callable( $code ) or
437             Carp::croak "Expected \$code to be callable or a Future in ->on_done";
438              
439 89 100       238 if( $self->{ready} ) {
440 27 100 100     156 return $self if $self->{failure} or $self->{cancelled};
441              
442 14         63 $is_future ? $code->done( @{ $self->{result} } )
443 15 100       37 : $code->( @{ $self->{result} } );
  1         14  
444             }
445             else {
446 62         80 push @{ $self->{callbacks} }, [ CB_DONE|CB_RESULT, $self->wrap_cb( on_done => $code ) ];
  62         169  
447             }
448              
449 77         184 return $self;
450             }
451              
452             sub failure
453             {
454 144     144 0 665 my $self = shift;
455 144 100       388 $self->await unless $self->{ready};
456 144 100       393 return unless $self->{failure};
457 86         146 $self->{reported} = 1;
458 86 100       413 return $self->{failure}->[0] if !wantarray;
459 16         26 return @{ $self->{failure} };
  16         106  
460             }
461              
462             sub on_fail
463             {
464 88     88 0 426 my $self = shift;
465 88         138 my ( $code ) = @_;
466              
467 88   66     414 my $is_future = blessed( $code ) && $code->isa( "Future" );
468 88 50 66     237 $is_future or _callable( $code ) or
469             Carp::croak "Expected \$code to be callable or a Future in ->on_fail";
470              
471 88 100       510 if( $self->{ready} ) {
472 30 100       85 return $self if not $self->{failure};
473 12         20 $self->{reported} = 1;
474              
475 10         28 $is_future ? $code->fail( @{ $self->{failure} } )
476 12 100       31 : $code->( @{ $self->{failure} } );
  2         16  
477             }
478             else {
479 58         79 push @{ $self->{callbacks} }, [ CB_FAIL|CB_RESULT, $self->wrap_cb( on_fail => $code ) ];
  58         139  
480             }
481              
482 70         165 return $self;
483             }
484              
485             sub cancel
486             {
487 120     120 0 9422 my $self = shift;
488              
489 120 100       318 return $self if $self->{ready};
490              
491 112         196 $self->{cancelled}++;
492 112         191 my $on_cancel = delete $self->{on_cancel};
493 112 100       295 foreach my $code ( $on_cancel ? reverse @$on_cancel : () ) {
494 57 100       137 defined $code or next;
495 44   66     194 my $is_future = blessed( $code ) && $code->isa( "Future" );
496 44 100       176 $is_future ? $code->cancel
497             : $code->( $self );
498             }
499 112         393 $self->_mark_ready( "cancel" );
500              
501 112         305 return $self;
502             }
503              
504             my $make_donecatchfail_sub = sub {
505             my ( $with_f, $done_code, $fail_code, @catch_list ) = @_;
506              
507             my $func = (caller 1)[3];
508             $func =~ s/^.*:://;
509              
510             !$done_code or _callable( $done_code ) or
511             Carp::croak "Expected \$done_code to be callable in ->$func";
512             !$fail_code or _callable( $fail_code ) or
513             Carp::croak "Expected \$fail_code to be callable in ->$func";
514              
515             my %catch_handlers = @catch_list;
516             _callable( $catch_handlers{$_} ) or
517             Carp::croak "Expected catch handler for '$_' to be callable in ->$func"
518             for keys %catch_handlers;
519              
520             sub {
521             my $self = shift;
522             my @maybe_self = $with_f ? ( $self ) : ();
523              
524             if( !$self->{failure} ) {
525             return $self unless $done_code;
526             return $done_code->( @maybe_self, @{ $self->{result} } );
527             }
528             else {
529             my $name = $self->{failure}[1];
530             if( defined $name and $catch_handlers{$name} ) {
531             return $catch_handlers{$name}->( @maybe_self, @{ $self->{failure} } );
532             }
533             return $self unless $fail_code;
534             return $fail_code->( @maybe_self, @{ $self->{failure} } );
535             }
536             };
537             };
538              
539             sub _sequence
540             {
541 111     111   177 my $f1 = shift;
542 111         180 my ( $code, $flags ) = @_;
543              
544 111         138 $flags |= CB_SEQ_STRICT if STRICT;
545              
546             # For later, we might want to know where we were called from
547 111         147 my $level = 1;
548 111         764 $level++ while (caller $level)[0] eq "Future::_base";
549 111         455 my $func = (caller $level)[3];
550 111         677 $func =~ s/^.*:://;
551              
552 111 50 66     401 $flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL) or _callable( $code ) or
553             Carp::croak "Expected \$code to be callable in ->$func";
554              
555 111 100       300 if( !defined wantarray ) {
556 4         890 Carp::carp "Calling ->$func in void context";
557             }
558              
559 111 100       521 if( $f1->is_ready ) {
560             # Take a shortcut
561             return $f1 if $f1->is_done and not( $flags & CB_SEQ_ONDONE ) or
562 38 100 100     116 $f1->{failure} and not( $flags & CB_SEQ_ONFAIL );
      100        
      100        
563              
564 35 100       115 if( $flags & CB_SEQ_IMDONE ) {
    100          
565 2         10 return Future->done( @$code );
566             }
567             elsif( $flags & CB_SEQ_IMFAIL ) {
568 2         11 return Future->fail( @$code );
569             }
570              
571             my @args = (
572             ( $flags & CB_SELF ? $f1 : () ),
573 16         30 ( $flags & CB_RESULT ? $f1->is_done ? @{ $f1->{result} } :
574 31 100       100 $f1->{failure} ? @{ $f1->{failure} } :
  4 50       11  
    100          
    100          
575             () : () ),
576             );
577              
578 31         52 my $fseq;
579 31 100       78 unless( eval { $fseq = $code->( @args ); 1 } ) {
  31         78  
  29         117  
580 2         21 return Future->fail( $@ );
581             }
582              
583 29 100 66     206 unless( blessed $fseq and $fseq->isa( "Future" ) ) {
584             # Upgrade a non-Future result, or complain in strict mode
585 8 50       36 $flags & CB_SEQ_STRICT and
586             return Future->fail( "Expected " . Future::CvNAME_FILE_LINE($code) . " to return a Future" );
587              
588 8         20 $fseq = $f1->new->done( $fseq );
589             }
590              
591 29         148 return $fseq;
592             }
593              
594 73         159 my $fseq = $f1->new;
595 73         240 $fseq->on_cancel( $f1 );
596              
597             # TODO: if anyone cares about the op name, we might have to synthesize it
598             # from $flags
599 73 100       296 $code = $f1->wrap_cb( sequence => $code ) unless $flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL);
600              
601 73         119 push @{ $f1->{callbacks} }, [ CB_DONE|CB_FAIL|$flags, $code, $fseq ];
  73         191  
602 73         234 weaken( $f1->{callbacks}[-1][2] );
603              
604 73         250 return $fseq;
605             }
606              
607             sub then
608             {
609 49     49 0 243 my $self = shift;
610 49         69 my $done_code = shift;
611 49 100       167 my $fail_code = ( @_ % 2 ) ? pop : undef;
612 49         85 my @catch_list = @_;
613              
614 49 100 100     261 if( $done_code and !@catch_list and !$fail_code ) {
      100        
615 43         145 return $self->_sequence( $done_code, CB_SEQ_ONDONE|CB_RESULT );
616             }
617              
618             # Complex
619 6         22 return $self->_sequence( $make_donecatchfail_sub->(
620             0, $done_code, $fail_code, @catch_list,
621             ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
622             }
623              
624             sub then_done
625             {
626 3     3 0 16 my $self = shift;
627 3         9 my ( @result ) = @_;
628 3         11 return $self->_sequence( \@result, CB_SEQ_ONDONE|CB_SEQ_IMDONE );
629             }
630              
631             sub then_fail
632             {
633 3     3 0 16 my $self = shift;
634 3         7 my ( @failure ) = @_;
635 3         12 return $self->_sequence( \@failure, CB_SEQ_ONDONE|CB_SEQ_IMFAIL );
636             }
637              
638             sub else
639             {
640 15     15 0 98 my $self = shift;
641 15         25 my ( $fail_code ) = @_;
642              
643 15         37 return $self->_sequence( $fail_code, CB_SEQ_ONFAIL|CB_RESULT );
644             }
645              
646             sub else_done
647             {
648 3     3 0 14 my $self = shift;
649 3         7 my ( @result ) = @_;
650 3         13 return $self->_sequence( \@result, CB_SEQ_ONFAIL|CB_SEQ_IMDONE );
651             }
652              
653             sub else_fail
654             {
655 3     3 0 20 my $self = shift;
656 3         7 my ( @failure ) = @_;
657 3         13 return $self->_sequence( \@failure, CB_SEQ_ONFAIL|CB_SEQ_IMFAIL );
658             }
659              
660             sub catch
661             {
662 4     4 0 24 my $self = shift;
663 4 100       12 my $fail_code = ( @_ % 2 ) ? pop : undef;
664 4         9 my @catch_list = @_;
665              
666 4         9 return $self->_sequence( $make_donecatchfail_sub->(
667             0, undef, $fail_code, @catch_list,
668             ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
669             }
670              
671             sub then_with_f
672             {
673 11     11 0 50 my $self = shift;
674 11         22 my $done_code = shift;
675 11 100       37 my $fail_code = ( @_ % 2 ) ? pop : undef;
676 11         26 my @catch_list = @_;
677              
678 11 100 66     71 if( $done_code and !@catch_list and !$fail_code ) {
      100        
679 3         10 return $self->_sequence( $done_code, CB_SEQ_ONDONE|CB_SELF|CB_RESULT );
680             }
681              
682 8         21 return $self->_sequence( $make_donecatchfail_sub->(
683             1, $done_code, $fail_code, @catch_list,
684             ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
685             }
686              
687             sub else_with_f
688             {
689 3     3 0 18 my $self = shift;
690 3         7 my ( $fail_code ) = @_;
691              
692 3         8 return $self->_sequence( $fail_code, CB_SEQ_ONFAIL|CB_SELF|CB_RESULT );
693             }
694              
695             sub catch_with_f
696             {
697 1     1 0 10 my $self = shift;
698 1 50       4 my $fail_code = ( @_ % 2 ) ? pop : undef;
699 1         2 my @catch_list = @_;
700              
701 1         5 return $self->_sequence( $make_donecatchfail_sub->(
702             1, undef, $fail_code, @catch_list,
703             ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
704             }
705              
706             sub followed_by
707             {
708 16     16 0 122 my $self = shift;
709 16         28 my ( $code ) = @_;
710              
711 16         46 return $self->_sequence( $code, CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
712             }
713              
714             sub without_cancel
715             {
716 3     3 0 268 my $self = shift;
717 3         7 my $new = $self->new;
718              
719             $self->on_ready( sub {
720 3     3   4 my $self = shift;
721 3 100       8 if( $self->{cancelled} ) {
    50          
722 1         9 $new->cancel;
723             }
724             elsif( $self->{failure} ) {
725 0         0 $new->fail( @{ $self->{failure} } );
  0         0  
726             }
727             else {
728 2         3 $new->done( @{ $self->{result} } );
  2         6  
729             }
730 3         18 });
731              
732 3         5 $new->{orig} = $self; # just to strongref it - RT122920
733 3     3   13 $new->on_ready( sub { undef $_[0]->{orig} } );
  3         16  
734              
735 3         6 return $new;
736             }
737              
738             sub _new_convergent
739             {
740 49     49   78 shift; # ignore this class
741 49         79 my ( $subs ) = @_;
742              
743 49         100 foreach my $sub ( @$subs ) {
744 89 50 33     530 blessed $sub and $sub->isa( "Future" ) or Carp::croak "Expected a Future, got $sub";
745             }
746              
747             # Find the best prototype. Ideally anything derived if we can find one.
748 49         80 my $self;
749 49   66     213 ref($_) eq "Future" or $self = $_->new, last for @$subs;
750              
751             # No derived ones; just have to be a basic class then
752 49   66     166 $self ||= Future->new;
753              
754 49         101 $self->{subs} = $subs;
755              
756             # This might be called by a DESTROY during global destruction so it should
757             # be as defensive as possible (see RT88967)
758             $self->on_cancel( sub {
759 5     5   9 foreach my $sub ( @$subs ) {
760 8 100 66     61 $sub->cancel if $sub and !$sub->{ready};
761             }
762 49         254 } );
763              
764 49         79 return $self;
765             }
766              
767             sub wait_all
768             {
769 13     13 0 1036 my $class = shift;
770 13         36 my @subs = @_;
771              
772 13 100       34 unless( @subs ) {
773 2         7 my $self = $class->done;
774 2         5 $self->{subs} = [];
775 2         9 return $self;
776             }
777              
778 11         48 my $self = Future->_new_convergent( \@subs );
779              
780 11         20 my $pending = 0;
781 11   66     39 $_->{ready} or $pending++ for @subs;
782              
783             # Look for immediate ready
784 11 100       27 if( !$pending ) {
785 1         3 $self->{result} = [ @subs ];
786 1         5 $self->_mark_ready( "wait_all" );
787 1         4 return $self;
788             }
789              
790 10         32 weaken( my $weakself = $self );
791             my $sub_on_ready = sub {
792 15 50   15   42 return unless my $self = $weakself;
793              
794 15         20 $pending--;
795 15 100       54 $pending and return;
796              
797 10         26 $self->{result} = [ @subs ];
798 10         38 $self->_mark_ready( "wait_all" );
799 10         25 };
800              
801 10         22 foreach my $sub ( @subs ) {
802 18 100       60 $sub->{ready} or $sub->on_ready( $sub_on_ready );
803             }
804              
805 10         31 return $self;
806             }
807              
808             sub wait_any
809             {
810 15     15 0 520 my $class = shift;
811 15         31 my @subs = @_;
812              
813 15 100       39 unless( @subs ) {
814 2         6 my $self = $class->fail( "Cannot ->wait_any with no subfutures" );
815 2         5 $self->{subs} = [];
816 2         35 return $self;
817             }
818              
819 13         39 my $self = Future->_new_convergent( \@subs );
820              
821             # Look for immediate ready
822 13         19 my $immediate_ready;
823 13         23 foreach my $sub ( @subs ) {
824 22 100 100     103 $sub->{ready} and !$sub->{cancelled} and $immediate_ready = $sub, last;
825             }
826              
827 13 100       28 if( $immediate_ready ) {
828 2         6 foreach my $sub ( @subs ) {
829 3 50       9 $sub->{ready} or $sub->cancel;
830             }
831              
832 2 50       7 if( $immediate_ready->{failure} ) {
833 0         0 $self->{failure} = [ @{ $immediate_ready->{failure} } ];
  0         0  
834             }
835             else {
836 2         4 $self->{result} = [ @{ $immediate_ready->{result} } ];
  2         6  
837             }
838 2         7 $self->_mark_ready( "wait_any" );
839 2         6 return $self;
840             }
841              
842 11         30 my $pending = 0;
843              
844 11         36 weaken( my $weakself = $self );
845             my $sub_on_ready = sub {
846 19 50   19   43 return unless my $self = $weakself;
847 19 100 100     69 return if $self->{result} or $self->{failure}; # don't recurse on child ->cancel
848              
849 13 100 100     46 return if --$pending and $_[0]->{cancelled};
850              
851 11 100       35 if( $_[0]->{cancelled} ) {
    100          
852 2         5 $self->{failure} = [ "All component futures were cancelled" ];
853             }
854             elsif( $_[0]->{failure} ) {
855 2         4 $self->{failure} = [ @{ $_[0]->{failure} } ];
  2         5  
856             }
857             else {
858 7         8 $self->{result} = [ @{ $_[0]->{result} } ];
  7         17  
859             }
860              
861 11         23 foreach my $sub ( @subs ) {
862 20 100       66 $sub->{ready} or $sub->cancel;
863             }
864              
865 11         25 $self->_mark_ready( "wait_any" );
866 11         34 };
867              
868 11         19 foreach my $sub ( @subs ) {
869             # No need to test $sub->{ready} since we know none of them are
870 20 100       43 next if $sub->{cancelled};
871 19         52 $sub->on_ready( $sub_on_ready );
872 19         23 $pending++;
873             }
874              
875 11         40 return $self;
876             }
877              
878             sub needs_all
879             {
880 16     16 0 480 my $class = shift;
881 16         36 my @subs = @_;
882              
883 16 100       60 unless( @subs ) {
884 2         7 my $self = $class->done;
885 2         6 $self->{subs} = [];
886 2         8 return $self;
887             }
888              
889 14         53 my $self = Future->_new_convergent( \@subs );
890              
891             # Look for immediate fail
892 14         21 my $immediate_failure;
893 14         26 foreach my $sub ( @subs ) {
894 27 100       60 $sub->{cancelled} and $immediate_failure = [ "A component future was cancelled" ], last;
895 26 100 100     63 $sub->{ready} and $sub->{failure} and $immediate_failure = $sub->{failure}, last;
896             }
897              
898 14 100       31 if( $immediate_failure ) {
899 2         4 foreach my $sub ( @subs ) {
900 4 100       14 $sub->{ready} or $sub->cancel;
901             }
902              
903 2         4 $self->{failure} = [ @$immediate_failure ];
904 2         5 $self->_mark_ready( "needs_all" );
905 2         6 return $self;
906             }
907              
908 12         17 my $pending = 0;
909 12   66     55 $_->{ready} or $pending++ for @subs;
910              
911             # Look for immediate done
912 12 100       38 if( !$pending ) {
913 1         2 $self->{result} = [ map { @{ $_->{result} } } @subs ];
  1         2  
  1         2  
914 1         5 $self->_mark_ready( "needs_all" );
915 1         3 return $self;
916             }
917              
918 11         42 weaken( my $weakself = $self );
919             my $sub_on_ready = sub {
920 23 50   23   55 return unless my $self = $weakself;
921 23 100 66     100 return if $self->{result} or $self->{failure}; # don't recurse on child ->cancel
922              
923 18 100       49 if( $_[0]->{cancelled} ) {
    100          
924 4         15 $self->{failure} = [ "A component future was cancelled" ];
925 4         11 foreach my $sub ( @subs ) {
926 7 100       19 $sub->cancel if !$sub->{ready};
927             }
928 4         7 $self->_mark_ready( "needs_all" );
929             }
930             elsif( $_[0]->{failure} ) {
931 3         5 $self->{failure} = [ @{ $_[0]->{failure} } ];
  3         9  
932 3         23 foreach my $sub ( @subs ) {
933 6 100       25 $sub->cancel if !$sub->{ready};
934             }
935 3         9 $self->_mark_ready( "needs_all" );
936             }
937             else {
938 11         16 $pending--;
939 11 100       44 $pending and return;
940              
941 4         9 $self->{result} = [ map { @{ $_->{result} } } @subs ];
  10         13  
  10         24  
942 4         37 $self->_mark_ready( "needs_all" );
943             }
944 11         64 };
945              
946 11         26 foreach my $sub ( @subs ) {
947 23 50       63 $sub->{ready} or $sub->on_ready( $sub_on_ready );
948             }
949              
950 11         34 return $self;
951             }
952              
953             sub needs_any
954             {
955 13     13 0 416 my $class = shift;
956 13         26 my @subs = @_;
957              
958 13 100       27 unless( @subs ) {
959 2         7 my $self = $class->fail( "Cannot ->needs_any with no subfutures" );
960 2         6 $self->{subs} = [];
961 2         8 return $self;
962             }
963              
964 11         31 my $self = Future->_new_convergent( \@subs );
965              
966             # Look for immediate done
967 11         19 my $immediate_done;
968 11         16 my $pending = 0;
969 11         21 foreach my $sub ( @subs ) {
970 19 100 100     53 $sub->{ready} and !$sub->{failure} and !$sub->{cancelled} and $immediate_done = $sub, last;
      100        
971 18 100       38 $sub->{ready} or $pending++;
972             }
973              
974 11 100       20 if( $immediate_done ) {
975 1         3 foreach my $sub ( @subs ) {
976 2 50       6 $sub->{ready} ? $sub->{reported} = 1 : $sub->cancel;
977             }
978              
979 1         2 $self->{result} = [ @{ $immediate_done->{result} } ];
  1         3  
980 1         5 $self->_mark_ready( "needs_any" );
981 1         3 return $self;
982             }
983              
984             # Look for immediate fail
985 10         15 my $immediate_fail = 1;
986 10         14 foreach my $sub ( @subs ) {
987 10 100       23 $sub->{ready} or $immediate_fail = 0, last;
988             }
989              
990 10 100       39 if( $immediate_fail ) {
991 1         8 $_->{reported} = 1 for @subs;
992             # For consistency we'll pick the last one for the failure
993 1         3 $self->{failure} = [ $subs[-1]->{failure} ];
994 1         3 $self->_mark_ready( "needs_any" );
995 1         3 return $self;
996             }
997              
998 9         27 weaken( my $weakself = $self );
999             my $sub_on_ready = sub {
1000 15 50   15   32 return unless my $self = $weakself;
1001 15 100 66     54 return if $self->{result} or $self->{failure}; # don't recurse on child ->cancel
1002              
1003 13 100 100     37 return if --$pending and $_[0]->{cancelled};
1004              
1005 11 100       28 if( $_[0]->{cancelled} ) {
    100          
1006 2         6 $self->{failure} = [ "All component futures were cancelled" ];
1007 2         6 $self->_mark_ready( "needs_any" );
1008             }
1009             elsif( $_[0]->{failure} ) {
1010 3 100       11 $pending and return;
1011              
1012 1         3 $self->{failure} = [ @{ $_[0]->{failure} } ];
  1         3  
1013 1         3 $self->_mark_ready( "needs_any" );
1014             }
1015             else {
1016 6         9 $self->{result} = [ @{ $_[0]->{result} } ];
  6         13  
1017 6         20 foreach my $sub ( @subs ) {
1018 12 100       41 $sub->cancel if !$sub->{ready};
1019             }
1020 6         13 $self->_mark_ready( "needs_any" );
1021             }
1022 9         30 };
1023              
1024 9         16 foreach my $sub ( @subs ) {
1025 16 100       63 $sub->{ready} or $sub->on_ready( $sub_on_ready );
1026             }
1027              
1028 9         30 return $self;
1029             }
1030              
1031             sub pending_futures
1032             {
1033 7     7 0 15976 my $self = shift;
1034 7 50       25 $self->{subs} or Carp::croak "Cannot call ->pending_futures on a non-convergent Future";
1035 7         13 return grep { not $_->{ready} } @{ $self->{subs} };
  14         58  
  7         21  
1036             }
1037              
1038             sub ready_futures
1039             {
1040 7     7 0 18 my $self = shift;
1041 7 50       27 $self->{subs} or Carp::croak "Cannot call ->ready_futures on a non-convergent Future";
1042 7         12 return grep { $_->{ready} } @{ $self->{subs} };
  14         53  
  7         17  
1043             }
1044              
1045             sub done_futures
1046             {
1047 9     9 0 22 my $self = shift;
1048 9 50       33 $self->{subs} or Carp::croak "Cannot call ->done_futures on a non-convergent Future";
1049 9 100 100     13 return grep { $_->{ready} and not $_->{failure} and not $_->{cancelled} } @{ $self->{subs} };
  18         148  
  9         23  
1050             }
1051              
1052             sub failed_futures
1053             {
1054 4     4 0 572 my $self = shift;
1055 4 50       14 $self->{subs} or Carp::croak "Cannot call ->failed_futures on a non-convergent Future";
1056 4 50       7 return grep { $_->{ready} and $_->{failure} } @{ $self->{subs} };
  8         58  
  4         9  
1057             }
1058              
1059             sub cancelled_futures
1060             {
1061 6     6 0 18 my $self = shift;
1062 6 50       23 $self->{subs} or Carp::croak "Cannot call ->cancelled_futures on a non-convergent Future";
1063 6 50       10 return grep { $_->{ready} and $_->{cancelled} } @{ $self->{subs} };
  12         94  
  6         16  
1064             }
1065              
1066             sub btime
1067             {
1068 11     11 0 24 my $self = shift;
1069 11         45 return $self->{btime};
1070             }
1071              
1072             sub rtime
1073             {
1074 12     12 0 391 my $self = shift;
1075 12         40 return $self->{rtime};
1076             }
1077              
1078             sub set_label
1079             {
1080 3     3 0 10 my $self = shift;
1081 3         12 ( $self->{label} ) = @_;
1082 3         13 return $self;
1083             }
1084              
1085             sub label
1086             {
1087 1     1 0 3 my $self = shift;
1088 1         6 return $self->{label};
1089             }
1090              
1091             sub set_udata
1092             {
1093 1     1 0 8 my $self = shift;
1094 1         3 my ( $name, $value ) = @_;
1095 1         7 $self->{"u_$name"} = $value;
1096 1         6 return $self;
1097             }
1098              
1099             sub udata
1100             {
1101 1     1 0 4 my $self = shift;
1102 1         2 my ( $name ) = @_;
1103 1         5 return $self->{"u_$name"};
1104             }
1105              
1106             0x55AA;