File Coverage

blib/lib/returning.pm

Criterion	Covered	Total	%
statement	55	59	93.2
branch	10	16	62.5
condition	1	3	33.3
subroutine	19	19	100.0
pod	1	1	100.0
total	86	98	87.7

package returning;

use 5.006;
use strict;
no warnings;

BEGIN {
	$returning::AUTHORITY = 'cpan:TOBYINK';
	$returning::VERSION   = '0.002';
}

use Carp            1.01    qw( croak );
use Scalar::Util    1.11    qw( set_prototype );
use Scope::Upper    0.16    qw( :all );
use Sub::Install    0.900   qw( install_sub reinstall_sub );
use Sub::Name       0.03    qw( subname );

sub import
{
	my $class = shift;
	my $default_target = caller;

	foreach my $arg (@_)
	{
		if (ref $arg eq 'HASH')
		{
			my $target = $arg->{-into} || $default_target;
			foreach my $func (keys %$arg)
			{
				next unless $func =~ /^[^\W\d]\w*$/;

				my $v    = $arg->{$func};
				my $code = ('CODE' eq ref $v) ? $v : sub(){$v if $]};

				install_sub {
					code  => subname("$target\::$func", $code),
					into  => $target,
					as    => $func,
				};

				$class->setup_for($target, $func);
			}
		}

		elsif ($arg =~ /^[^\W\d]\w*$/)
		{
			$class->setup_for($default_target, $arg);
		}

		else
		{
			croak "unrecognised import argument to returning: $arg";
		}
	}
}

sub setup_for
{
	my ($class, $target, $func) = @_;

	my $orig_code = do
	{
		no strict 'refs';
		\&{"$target\::$func"};
	};

	my $new_code = sub
	{
		my $cx   = SUB UP;
		my $want = want_at $cx;
		my @result;
		if ($want)
			{ @result = &uplevel($orig_code, @_, $cx) }
		elsif (defined $want)
			{ @result = scalar &uplevel($orig_code, @_, $cx) }
		else
			{ &uplevel($orig_code, @_, $cx); @result = undef }
		unwind @result => $cx;
	};

	&set_prototype(
		$new_code,
		prototype($orig_code),
	)
		if defined prototype($orig_code);

	reinstall_sub {
		code  => subname("$target\::$func", $new_code),
		into  => $target,
		as    => $func,
	};
}

__PACKAGE__
__END__