returning.pm

package returning;

use 5.008001;
use strict;

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

use Carp            0       qw( croak );
use Scope::Upper    0       qw( :all );
use Sub::Install    0.900   qw( install_sub reinstall_sub );
use Scalar::Util    0.02    qw( set_prototype );
 
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 $f (keys %$arg)
			{
				next unless $f =~ /^[^\W\d]\w*$/;
				
				my $v    = $arg->{$f};
				my $code = ('CODE' eq ref $v) ? $v : sub(){$v if $]};
				
				install_sub {
					code  => $code,
					into  => $target,
					as    => $f,
				};
				
				$class->setup_for($target, $f);
			}
		}
		
		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 = $orig_code->(@_) }
		elsif (defined $want)
			{ @result = scalar $orig_code->(@_) }
		else 
			{ $orig_code->(@_); @result = undef }
		unwind @result => $cx;
	};
	
	&set_prototype(
		$new_code,
		prototype($orig_code),
	)
		if defined prototype($orig_code);
	
	reinstall_sub {
		code  => $new_code,
		into  => $target,
		as    => $func,
	};
}

1;

test-returning.t

use Test::More tests => 4;

use returning {
	Affirmative   => !0,
	Negitive      => !1,
	ReturnNumber  => sub { 0+$_[0] },
	Ctx           => sub () { wantarray ? 'list' : 'scalar' },
};

sub test1
{
	Affirmative;
	Negitive;
}

sub test2
{
	ReturnNumber("2bad");
	die "failed!";
}

sub test3
{
	Ctx;
	die "failed!";
}

ok(
	test1(),
);

cmp_ok(
	test2(),
	'eq',
	'2'
);

is(
	[test3()]->[0],
	'list',
);

is(
	scalar test3(),
	'scalar',
);