view release on metacpan or  search on metacpan

lib/Sub/Block.pm  view on Meta::CPAN

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 = {};