view release on metacpan or  search on metacpan

lib/IO/Lambda.pm  view on Meta::CPAN

	my @ret;
	my @frame = get_frame();
	while ( 1) {
		push @ret, map { $_-> peek } grep { $_-> {stopped} } @objects;
		@objects = grep { not $_-> {stopped} } @objects;
		last unless @objects;
		yield;
	}
	set_frame(@frame);
	return @ret;
}

# wait for at least one lambda to stop, return those that stopped
sub wait_for_any
{
	my @objects = @_;
	return unless @objects;
	$_-> start for grep { $_-> is_passive } @objects;
	my @frame = get_frame();
	while ( 1) {
		my @n = grep { $_-> {stopped} } @objects;
		set_frame(@frame), return @n if @n;
		yield;
	}
	set_frame(@frame);
	return;
}

# run the event loop until no lambdas are left in the blocking state
sub run {
	my @frame = get_frame();
	do {} while yield;
	set_frame(@frame);
}

#
# Part II - Procedural interface to the lambda-style programming
#
#################################################################

sub _lambda_restart { die "lambda() is not restartable" }
sub lambda(&)
{
	my $cb  = _subname(lambda => $_[0]);
	my $l   = __PACKAGE__-> new( sub {
		# initial lambda code is usually executed by tail/tails inside another lambda,
		# so protect the upper-level context
		local *__ANON__ = "IO::Lambda::lambda::callback";
		local $THIS     = shift;
		local @CONTEXT  = ();
		local $CALLBACK = $cb;
		local $METHOD   = \&_lambda_restart;
		$cb ? $cb-> (@_) : @_;
	});
	if ( $DEBUG_CALLER) {
		if ( $DEBUG_CALLER > 1) {
			$l-> {caller} = Carp::longmess;
			chomp $l-> {caller};
			$l-> {caller} =~ s/^ at //;
		} else {
			$l-> {caller} = join(':', (caller)[1,2]);
		}
	}
	$l;
}

sub _subname
{
	subname(
		caller(1 + ($_[2] || 0)) .  '::_'.  $_[0], 
		$_[1]
	) if $DEBUG_CALLER and $_[1] and not $AGAIN; 
	return $_[1];
}

*io = \λ

# re-enter the latest (or other) frame
sub again
{
	if ( @_ ) {
		my $name = shift;
		Carp::carp("no such frame:$name") unless exists $THIS->{frames}->{$name};
		($METHOD, $CALLBACK, @CONTEXT) = @{ $THIS->{frames}->{$name} };
		@CONTEXT = @_ if @_;
	}
	local $AGAIN = 1;
	defined($METHOD) ?
		$METHOD-> ($CALLBACK) :
		confess "again() outside of a restartable call" 
}

# define context
sub this        { @_ ? ($THIS, @CONTEXT)    = @_ : $THIS }
sub context     { @_ ? (@CONTEXT)           = @_ : @CONTEXT }
sub set_frame   { ( $THIS, $METHOD, $CALLBACK, @CONTEXT) = @_ }
sub get_frame   { ( $THIS, $METHOD, $CALLBACK, @CONTEXT) }
sub swap_frame  { my @f = get_frame; set_frame(@_); @f }
sub clear       { set_frame(); undef $AGAIN; }
sub delete_frame { delete $THIS->{frames}->{$_[0]} }

END { ( $THIS, $METHOD, $CALLBACK, @CONTEXT) = (); }

sub state($)
{
	my $this = ($_[0] && ref($_[0])) ? shift(@_) : this;
	@_ ? $this-> {state} = $_[0] : return $this-> {state};
}

sub restartable
{
	my $name = @_ ? $_[0] : join(':', caller);
	$THIS->{frames}->{$name} = [ $METHOD, $CALLBACK, @CONTEXT ];
	return $name;
}

# exceptions and backtracing
sub catch(&$)
{
	my ( $cb, $event) = @_;
	my $who = (caller(1))[3];