File Coverage

blib/lib/Sub/Block.pm

Criterion	Covered	Total	%
statement	81	85	95.2
branch	12	16	75.0
condition	11	15	73.3
subroutine	24	25	96.0
pod	6	6	100.0
total	134	147	91.1

use 5.008;
use strict;
use warnings;

package Sub::Block;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.002';

use Moo;

use Carp qw(carp croak);
use Exporter::Tiny qw();
use Scalar::Util qw(blessed refaddr);
use Sub::Quote qw();

use namespace::clean;

{
	our @ISA    = 'Exporter::Tiny';
	our @EXPORT = 'block';
	sub _generate_block {
		my $class = shift;
		sub (&) { $class->new(@_) };
	}
}

use overload (
	q[&{}]  => sub { $_[0]{sub} },
	q[>>]   => sub { __PACKAGE__->sequence($_[2] ? @_[1,0] : @_[0,1]) },
);

has sub => (is => 'ro', required => 1);
has [qw/ map grep /] => (is => 'lazy');

my $deparse;
sub BUILDARGS
{
	my $class = shift;

	if (@_ == 1 and ref($_[0]) eq q(HASH))
	{
		return $_[0];
	}
	elsif (@_ == 1 and ref($_[0]) eq q(CODE))
	{
		require B::Deparse;
		require PadWalker;
		$deparse ||= 'B::Deparse'->new;

		my $coderef = shift;
		$class->_check_coderef($coderef);

		my $closures = PadWalker::closed_over($coderef);
		my $perlcode = $deparse->coderef2text($coderef);

		$perlcode =~ s/(?:\A\{)|(?:\}\z)//g;
		return +{ sub => Sub::Quote::quote_sub($perlcode, $closures) }
	}
	else
	{
		return +{ sub => scalar Sub::Quote::quote_sub(@_) };
	}
}

sub _check_coderef
{
	require B;
	my $class = shift;
	my ($coderef) = @_;

	local *B::OP::__Sub_Block_callback = sub
	{
		my $name = $_[0]->name;
		return if $name ne 'return' && $name ne 'wantarray';
		local $Carp::CarpLevel = $Carp::CarpLevel + 2;
		carp("Coderef $coderef appears to contain an explicit `$name` statement; not suitable for inlining");
	};

	B::svref_2object($coderef)->ROOT->B::walkoptree('__Sub_Block_callback');
}

sub execute
{
	my $self = shift;
	my $sub = $self->{sub};
	goto $sub;
}

sub code
{
	Sub::Quote::quoted_from_sub( $_[0]->{sub} )->[1];
}

sub closures
{
	Sub::Quote::quoted_from_sub( $_[0]->{sub} )->[2];
}

sub inlinify
{
	my $self = shift;
	Sub::Quote::inlinify($self->code, join(q[,], @_), '', 1);
}

sub sequence
{
	my $class = __PACKAGE__;
	$class = shift if !ref $_[0];

	my @subs = map { blessed($_) ? $_ : $class->new($_) } @_;

	my $code = '';
	my $vars = {};

	for my $sub (@subs)
	{
		my $sub_closures = $sub->closures;
		for my $k (sort keys %$sub_closures)
		{
			next if exists($vars->{$k}) && refaddr($vars->{$k})==refaddr($sub_closures->{$k});
			croak "Attempted to close over two variables named $k" if exists($vars->{$k});
			$vars->{$k} = $sub_closures->{$k};
		}
		$code .= "\@_ = do { ${\ $sub->code } };\n"
	}

	$code .= 'eval { wantarray ? @_ : $_[-1] };'."\n";

	return $class->new($code, $vars);
}

sub _build_from_template
{
	my $self = shift;
	my $code = sprintf($_[0], $self->code);
	ref($self)->new($code, $self->closures);
}

sub _build_map
{
	shift->_build_from_template('map { local @_ = ($_); %s } @_');
}

sub _build_grep
{
	shift->_build_from_template('grep { local @_ = ($_); %s } @_');
}

1;

__END__