File Coverage

blib/lib/Sub/Context.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	18	18	100.0
condition	3	3	100.0
subroutine	16	16	100.0
pod			n/a
total	107	107	100.0

package Sub::Context;

use strict;
use Scalar::Util 'reftype';

use vars '$VERSION';
$VERSION = '1.00';

sub import
{
	my ($class, %args) = @_;
	my $pkg            = caller();

	while (my ($subname, $args) = each %args)
	{
		my $sub = $class->_qualify_sub( $pkg, $subname );
		$class->_wrap_sub( $sub, $args );
	}
}

sub _qualify_sub
{
	my ($class, $package, $subname) = @_;

	return $subname if index( $subname, '::' ) > 0;
	return $package . '::' . $subname;
}

sub _wrap_sub
{
	my ($class, $subname, $contexts) = @_;

	# may croak()
	$class->_validate_contexts( $contexts );
	$class->_generate_contexts( $subname, $contexts );

	my $glob                         = $class->_fetch_glob( $subname );
	$class->_apply_contexts( $glob, $contexts );
}

sub _generate_contexts
{
	my ($class, $subname, $contexts) = @_;

	for my $context ( $class->_contexts() )
	{
		next if ref      $contexts->{$context}
		     && reftype( $contexts->{$context} ) eq 'CODE';

		my $message = exists $contexts->{$context} ?
			': ' . delete $contexts->{$context} :
			'';

		$contexts->{$context} = $class->_default_sub(
			$subname, $context, $message
		);
	}
}

sub _default_sub
{
	my ($class, $subname, $context, $message) = @_;

	# don't look at this
	my $sub = \&{ $subname };
	return $sub if defined &$sub;

	return sub
	{
		require Carp;
		Carp::croak( "No sub for $context context$message")
	};
}

sub _apply_contexts
{
	my ($class, $glob, $contexts) = @_;

	*$glob = sub
	{
		my $context = wantarray();
		$context    = defined $context ?
			( $context ? 'list' : 'scalar' ) :
			'void';
		goto &{ $contexts->{$context} };
	};
}

sub _contexts
{
	qw( void scalar list );
}

sub _validate_contexts
{
	my ($class, $contexts) = @_;
	my %allowed            = map { $_ => 1 } $class->_contexts();

	for my $provided ( keys %$contexts )
	{
		unless ( exists $allowed{$provided} )
		{
			require Carp;
			Carp::croak( "Context type '$provided' not allowed!" );
		}
	}
}

sub _fetch_glob
{
	my ($class, $globname) = @_;
	my $glob               = $class->_find_glob( $globname );

	return $glob unless defined &$globname;

	local *NEWGLOB;

	no strict 'refs';

	for my $slot (qw ( SCALAR ARRAY FORMAT IO HASH ))
	{
		*NEWGLOB = *{$glob}{$slot} if defined *{$glob}{$slot};
	}

	*{$glob} = *NEWGLOB;
	return $glob;
}

sub _find_glob
{
	my ($class, $name) = @_;
	my $glob           = \%main::;
	my @package        = split( '::', $name );
	my $subroutine     = pop @package;

	for my $package ( @package )
	{
		$glob = $glob->{$package . '::'};
	}

	$glob = \$glob->{$subroutine};
	return $glob;
}

'your message here, contact $AUTHOR for rates';

__END__