File Coverage

blib/lib/coroutine0.pm

Criterion	Covered	Total	%
statement	58	65	89.2
branch	7	14	50.0
condition			n/a
subroutine	8	9	88.8
pod	0	3	0.0
total	73	91	80.2

package coroutine0;

use 5.000;
use strict;
use vars qw($VERSION @ISA %bodystrings);
@ISA = qw();

$VERSION = '0.02';

#my %bodystrings;
my $labname = 'corolab';

use Carp;

sub rewrite($){
	my $l = $labname++;
	<
	\$LABEL='$l';
	return $_[0];
	$l:
EOF
}

sub new{
	shift; # shift off the package name
	my %args = @_;
	#print stderr @_;
	my $body =
	$args{BODY} or croak "Need a BODY argument";

	my @vars = @{$args{VARS}||[]};
	unshift @vars, '$LABEL';

	my $varlist = join ";\nmy ",@vars;

	$body =~ s/\bYIELD\b(.*?);/rewrite $1/seg;

	my $callingpackage = caller;
	$body = <
package $callingpackage;
{
	my $varlist;
	\$LABEL = 'START';
	sub $args{PROTO} {
		$args{PRE}
		goto \$LABEL;
		START:
$body
	\$LABEL = 'START';
	undef;
	}
}
EOF

	my $coderef;
	# print stderr "BODY:\n$body\nEND_BODY\n";
	$args{DIE} and croak "BODY:\n$body\nEND_BODY\n";
	eval { $coderef = eval $body };
	$@ and croak $@;

	ref($coderef) or croak <
Failed to get coderef from evaluating:
$body
END_OF_BODY
EOF

	return $coderef if $args{TIDY};

	bless $coderef;
	$bodystrings{$coderef} = \$body;
	return $coderef;
};

sub copy{

	my $cr2;
	my $coderef = shift;
	eval { $cr2 = eval
		${$bodystrings{$coderef}}
	};
	$@ and croak $@;

	bless $cr2;
	$bodystrings{$cr2} = $bodystrings{$coderef} ;

	return $cr2;
};

sub DESTROY{
	delete $bodystrings{$_[0]};
};

1;
__END__