view release on metacpan or  search on metacpan

lib/App/mirai/Future.pm  view on Meta::CPAN

	# my $f = $destructor->(@_);
	$_->invoke_event(destroy => $f) for grep defined, @WATCHERS;
	my $entry = delete $FUTURE_MAP{$f};
	$f
}

=head2 Future::set_label

Pick up any label changes, since L<Future>s are created without them.

=cut

sub Future::set_label {
	my $f = shift;
	( $f->{label} ) = @_;
	$_->invoke_event(label => $f) for grep defined, @WATCHERS;
	return $f;
}
}

BEGIN {
	my $prep = sub {
		my $f = shift;

		# Grab the stacktrace first, so we know who started this
		my (undef, $file, $line) = caller(1);
		my $stack = do {
			my @stack;
			my $idx = 1;
			while(my @x = caller($idx++)) {
				unshift @stack, [ @x[0, 1, 2] ];
			}
			\@stack
		};

		# I don't know why this is here.
		if(exists $FUTURE_MAP{$f}) {
			$FUTURE_MAP{$f}{type} = (exists $f->{subs} ? 'dependent' : 'leaf');
			return $f;
		}

		# We don't use this either
		$f->{constructed_at} = do {
			my $at = Carp::shortmess( "constructed" );
			chomp $at; $at =~ s/\.$//;
			$at
		};

		# This is our record, we'll update it when we're marked as ready
		my $entry = {
			future        => $f,
			deps          => [ ],
			type          => (exists $f->{subs} ? 'dependent' : 'leaf'),
			created_at    => "$file:$line",
			creator_stack => $stack,
			status        => 'pending',
		};

		# ... but we don't want to hold on to the real Future and cause cycles,
		# memory isn't free
		Scalar::Util::weaken($entry->{future});

		my $name = "$f";
		$FUTURE_MAP{$name} = $entry;

		# Yes, this means we're modifying the callback list: if we later
		# add support for debugging the callbacks as well, we'd need to
		# take this into account.
		$f->on_ready(sub {
			my $f = shift;
			my (undef, $file, $line) = caller(2);
			$FUTURE_MAP{$f}->{status} = 
				  $f->{failure}
				? "failed"
				: $f->{cancelled}
				? "cancelled"
				: "done";
			$FUTURE_MAP{$f}->{ready_at} = "$file:$line";
			$FUTURE_MAP{$f}->{ready_stack} = do {
				my @stack;
				my $idx = 1;
				while(my @x = caller($idx++)) {
					unshift @stack, [ @x[0,1,2] ];
				}
				\@stack
			};

			# who's in charge of picking names around here? do we not have
			# any interest in consistency?
			$_->invoke_event(on_ready => $f) for grep defined, @WATCHERS;
		});
	};

	my %map = (
		# Creating a leaf Future, or called via _new_dependent
		new => sub {
			my $constructor = shift;
			sub {
				my $f = $constructor->(@_);
				$prep->($f);
				# hahaha
				my ($sub) = (caller 1)[3];
				# no, seriously?
				unless($sub && ($sub eq 'Future::_new_dependent' or $sub eq 'Future::_new_convergent')) {
					$_->invoke_event(create => $f) for grep defined, @WATCHERS;
				}
				$f
			};
		},

		# ->needs_all, ->want_any, etc.
		_new_dependent => sub {
			my $constructor = shift;
			sub {
				my @subs = @{$_[1]};
				my $f = $constructor->(@_);
				$prep->($f);
				my $entry = $FUTURE_MAP{$f};
				$entry->{subs} = \@subs;
				# Inform subs that they have a new parent
				for(@subs) {
					die "missing future map entry for $_?" unless exists $FUTURE_MAP{$_};
					push @{$FUTURE_MAP{$_}{deps}}, $f;
					Scalar::Util::weaken($FUTURE_MAP{$_}{deps}[-1]);
				}
				$_->invoke_event(create => $f) for grep defined, @WATCHERS;
				$f
			};
		},
	);
	# Changed in Future 0.30, I believe
	$map{_new_convergent} = $map{_new_dependent};

	for my $k (keys %map) {
		my $orig = Future->can($k);
		my $code = $map{$k}->($orig);
		{
			no strict 'refs';
			no warnings 'redefine';
			*{'Future::' . $k} = $code;
		}
	}
}

1;

__END__

=head1 AUTHOR

Tom Molesworth <cpan@perlsite.co.uk>

=head1 LICENSE

Copyright Tom Molesworth 2014-2015. Licensed under the same terms as Perl itself.