File Coverage

blib/lib/Contextual/Return/Wrapper.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Contextual::Return::Wrapper;

use 5.008009;
use strict;
use warnings;

our $VERSION = '0.01';

use Class::ISA ;
use List::Util qw( first ) ;

my $function_code_ref ;
my $behavior_of ;

$behavior_of->{Listify}{CODE} = sub {
	my ( $ref, $symbol_name, @context ) = @_ ;

	return sub { @{ [ $ref->( @_ ) ] }[0..$#_] } ;
	} ;

$behavior_of->{ReturnContext}{CODE} = sub {
	my ( $ref, $symbol_name, @context ) = @_ ;

	my %behavior = map { $_->[1] => $_->[3] } @context ;
	$behavior{requires} ||= {} ;

	return sub {
		my $context = wantarray ?
				$behavior{requires}{void}
				  || $behavior{requires}{scalar}
				: defined wantarray
				  ? $behavior{requires}{array}
				    || $behavior{requires}{void}
				    || $behavior{scalar}
				  : $behavior{requires}{array}
				    || $behavior{requires}{scalar}
				    || $behavior{void} ;

		return ( $context || sub { shift ; @_ }
				)->( $symbol_name, $ref->( @_ ) ) ;
		} ;
	} ;

$behavior_of->{ReturnContext}{requires}{array} = { array => sub {
	carp( "$_[0]() requires array context" ) ;
	shift ;	@_ ;
	} } ;
$behavior_of->{ReturnContext}{requires}{scalar} = { scalar => sub {
	carp( "$_[0]() requires scalar context" ) ;
	shift ;	@_ ;
	} } ;
$behavior_of->{ReturnContext}{requires}{void} = { void => sub {
	carp( "$_[0]() requires void context" ) ;
	shift ;	@_ ;
	} } ;

$behavior_of->{ReturnContext}{scalar}{first} = sub { shift ; $_[0] } ;
$behavior_of->{ReturnContext}{scalar}{last} = sub { shift ; $_[-1] } ;
$behavior_of->{ReturnContext}{scalar}{count} = sub { shift ; @_ } ;
$behavior_of->{ReturnContext}{scalar}{arrayref} = sub { shift ; [ @_ ] } ;
$behavior_of->{ReturnContext}{scalar}{array_ref} = sub { shift ; [ @_ ] } ;
$behavior_of->{ReturnContext}{scalar}{warn} = sub {
	carp( "$_[0]() called in scalar context" ) ;
	shift ;	@_ ;
	} ;

$behavior_of->{ReturnContext}{void}{warn} = sub {
	carp( "$_[0]() called in void context" ) ;
	shift ;	@_ ;
	} ;

sub carp {
	printf STDERR "Warning: %s at %s line %d.\n",
			$_[0], @{ [ caller( 2 ) ] }[ 1, 2 ] ;
	}

sub usage {
	my ( $package, $symbol, $referent, $attr, $behave_how_arg,
			$phase, @debug ) = @_ ;
			$attr, @debug

	}

sub MODIFY_CODE_ATTRIBUTES {
	my( $package, $ref, $symbol_name, @args ) = @_ ;
	my $bad_argument = $symbol_name ;

	if ( $symbol_name =~ s{ ( \(.*?\) ) \Z }{}msx ) {
		@args = eval( $1 ) ;
		return $bad_argument unless defined $args[0] ;
		}

	my %behavior_args = @args == 0
			? ('') x2
			: ( @args, ( @args %2 ? ('') : () ) ) ;

	return ( $symbol_name )
			unless exists $behavior_of->{$symbol_name}->{CODE} ;

	my @closure_inputs = map { [ @$_, _value_of( $behavior_of, @$_ ) ] }
			map { [ $symbol_name,
			  ( $_ ? ( $_ => $behavior_args{$_} ) : () )
			  ] }
			keys %behavior_args ;

	my $bad = first { ! $_->[-1] } @closure_inputs ;
	return sprintf qq[%s( %s => '%s' )], @$bad if $bad ;

	$function_code_ref->{$ref} = [ @closure_inputs ] ;
	return () ;
	}

sub import {
	my ( $package ) = @_ ;

	no strict qw( refs ) ;
	no warnings qw( redefine ) ;

	do {
		my @context = @{ $function_code_ref->{ $_->[2] } } ;
		*{"$_->[0]"} = $behavior_of->{ $context[0][0] }->{CODE}->(
				$_->[2], $_->[1], @context ) ;
		} foreach
		grep $_->[2] && $function_code_ref->{ $_->[2] },
		map { [ $_, *{"$_"}{NAME}, *{"$_"}{CODE} ] }
		map {"${package}::$_"}
		keys %{"${package}::"} ;

	goto &export ;
	}

sub export {
	my ( $package ) = @_ ;

	my ( $match, $super ) ;
	my @super = Class::ISA::super_path( $package ) ;
	my @siblings = @super ;

	while ( @siblings && ! ( $match = __PACKAGE__ eq shift @siblings )
			) {} ;
	## See perlmonks node 1047054
	first { $super = $_->can('import') } $match ? @siblings : @super ;
	goto &$super if $super ;
	return ;
	}

sub _value_of {
	my ( $ref, $key, @more ) = @_ ;
	return @more && exists $ref->{$key}
			? _value_of( $ref->{$key}, @more )
			: $ref->{$key} ;
	}

1;
__END__