view release on metacpan or  search on metacpan

local/lib/perl5/Future.pm  view on Meta::CPAN

   CB_SEQ_ONFAIL => 1<<6, # Sequencing on failure (->else)

   CB_SEQ_IMDONE => 1<<7, # $code is in fact immediate ->done result
   CB_SEQ_IMFAIL => 1<<8, # $code is in fact immediate ->fail result
};

use constant CB_ALWAYS => CB_DONE|CB_FAIL|CB_CANCEL;

# Useful for identifying CODE references
sub CvNAME_FILE_LINE
{
   my ( $code ) = @_;
   my $cv = svref_2object( $code );

   my $name = join "::", $cv->STASH->NAME, $cv->GV->NAME;
   return $name unless $cv->GV->NAME eq "__ANON__";

   # $cv->GV->LINE isn't reliable, as outside of perl -d mode all anon CODE
   # in the same file actually shares the same GV. :(
   # Walk the optree looking for the first COP
   my $cop = $cv->START;
   $cop = $cop->next while $cop and ref $cop ne "B::COP";

   sprintf "%s(%s line %d)", $cv->GV->NAME, $cop->file, $cop->line;
}

sub _callable
{
   my ( $cb ) = @_;
   defined $cb and ( reftype($cb) eq 'CODE' || overload::Method($cb, '&{}') );
}

sub new
{
   my $proto = shift;
   return bless {
      ready     => 0,
      callbacks => [], # [] = [$type, ...]
      ( DEBUG ?
         ( do { my $at = Carp::shortmess( "constructed" );
                chomp $at; $at =~ s/\.$//;
                constructed_at => $at } )
         : () ),
      ( $TIMES ?
         ( btime => [ gettimeofday ] )
         : () ),
   }, ( ref $proto || $proto );
}

my $GLOBAL_END;
END { $GLOBAL_END = 1; }

sub DESTROY_debug {
   my $self = shift;
   return if $GLOBAL_END;
   return if $self->{ready} and ( $self->{reported} or !$self->{failure} );

   my $lost_at = join " line ", (caller)[1,2];
   # We can't actually know the real line where the last reference was lost; 
   # a variable set to 'undef' or close of scope, because caller can't see it;
   # the current op has already been updated. The best we can do is indicate
   # 'near'.

   if( $self->{ready} and $self->{failure} ) {
      warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at with an unreported failure of: " .
         $self->{failure}[0] . "\n";
   }
   elsif( !$self->{ready} ) {
      warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at before it was ready.\n";
   }
}
*DESTROY = \&DESTROY_debug if DEBUG;

=head2 done I<(class method)>

=head2 fail I<(class method)>

   $future = Future->done( @values )

   $future = Future->fail( $exception, @details )

I<Since version 0.26.>

Shortcut wrappers around creating a new C<Future> then immediately marking it
as done or failed.

=head2 wrap

   $future = Future->wrap( @values )

I<Since version 0.14.>

If given a single argument which is already a C<Future> reference, this will
be returned unmodified. Otherwise, returns a new C<Future> instance that is
already complete, and will yield the given values.

This will ensure that an incoming argument is definitely a C<Future>, and may
be useful in such cases as adapting synchronous code to fit asynchronous
libraries driven by C<Future>.

=cut

sub wrap
{
   my $class = shift;
   my @values = @_;

   if( @values == 1 and blessed $values[0] and $values[0]->isa( __PACKAGE__ ) ) {
      return $values[0];
   }
   else {
      return $class->done( @values );
   }
}

=head2 call

   $future = Future->call( \&code, @args )

I<Since version 0.15.>

local/lib/perl5/Future.pm  view on Meta::CPAN

sub followed_by
{
   my $self = shift;
   my ( $code ) = @_;

   return $self->_sequence( $code, CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
}

=head2 without_cancel

   $future = $f1->without_cancel

I<Since version 0.30.>

Returns a new sequencing C<Future> that will complete with the success or
failure of the original future, but if cancelled, will not cancel the
original. This may be useful if the original future represents an operation
that is being shared among multiple sequences; cancelling one should not
prevent the others from running too.

=cut

sub without_cancel
{
   my $self = shift;
   my $new = $self->new;

   $self->on_ready( sub {
      my $self = shift;
      if( $self->failure ) {
         $new->fail( $self->failure );
      }
      else {
         $new->done( $self->get );
      }
   });

   return $new;
}

=head1 CONVERGENT FUTURES

The following constructors all take a list of component futures, and return a
new future whose readiness somehow depends on the readiness of those
components. The first derived class component future will be used as the
prototype for constructing the return value, so it respects subclassing
correctly, or failing that a plain C<Future>.

=cut

sub _new_convergent
{
   shift; # ignore this class
   my ( $subs ) = @_;

   foreach my $sub ( @$subs ) {
      blessed $sub and $sub->isa( "Future" ) or Carp::croak "Expected a Future, got $_";
   }

   # Find the best prototype. Ideally anything derived if we can find one.
   my $self;
   ref($_) eq "Future" or $self = $_->new, last for @$subs;

   # No derived ones; just have to be a basic class then
   $self ||= Future->new;

   $self->{subs} = $subs;

   # This might be called by a DESTROY during global destruction so it should
   # be as defensive as possible (see RT88967)
   $self->on_cancel( sub {
      foreach my $sub ( @$subs ) {
         $sub->cancel if $sub and !$sub->{ready};
      }
   } );

   return $self;
}

=head2 wait_all

   $future = Future->wait_all( @subfutures )

Returns a new C<Future> instance that will indicate it is ready once all of
the sub future objects given to it indicate that they are ready, either by
success, failure or cancellation. Its result will be a list of its component
futures.

When given an empty list this constructor returns a new immediately-done
future.

This constructor would primarily be used by users of asynchronous interfaces.

=cut

sub wait_all
{
   my $class = shift;
   my @subs = @_;

   unless( @subs ) {
      my $self = $class->done;
      $self->{subs} = [];
      return $self;
   }

   my $self = Future->_new_convergent( \@subs );

   my $pending = 0;
   $_->{ready} or $pending++ for @subs;

   # Look for immediate ready
   if( !$pending ) {
      $self->{result} = [ @subs ];
      $self->_mark_ready( "wait_all" );
      return $self;
   }

   weaken( my $weakself = $self );
   my $sub_on_ready = sub {