File Coverage

blib/lib/methods/import.pm

Criterion	Covered	Total	%
statement	89	101	88.1
branch	25	34	73.5
condition	13	19	68.4
subroutine	16	18	88.8
pod	0	6	0.0
total	143	178	80.3

use 5.008006;
use strict;
use warnings;

package methods::import;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.001';

use namespace::clean qw();
use Sub::Util qw();

sub import {
	my $caller = caller;
	my $class  = shift;
	return $class->import_into($caller, @_);
}

sub method_list {
	require Carp;
	Carp::croak("No methods listed to import");
}

{
	my %bools = (-keep => 1);
	sub _get_opt {
		my $class  = shift;
		my ($list) = @_;
		my $opts =
			ref($list->[0]) eq 'HASH'     ? shift @$list :
			ref($list->[0]) eq 'ARRAY' ? $class->_hashify(shift @$list) :
			{};
		while (@$list and !ref($list->[0]) and exists($bools{$list->[0]})) {
			my $thing = shift @$list;
			$opts->{$thing} = $bools{$thing};
		}
		return $opts;
	}
	sub _hashify {
		shift;
		@_ = @{+shift};
		my %r;
		while (@_) {
			my $thing  = shift;
			$r{$thing} = exists($bools{$thing}) ? 1 : shift;
		}
		\%r;
	}
}

sub import_into {
	my $class  = shift;
	my $caller = shift;
	my $using;

	@_ = $class->method_list unless @_;
	my $default_opts = $class->_get_opt(\@_);

	push @_, 'using' unless grep !ref && /^using$/, @_;

	while (@_) {
		my $method = shift;
		my $opts   = $class->_get_opt(\@_);
		if ($method =~ /=/) {
			($method, $opts->{-as}, $opts->{-prototype}) = split /=/, $method;
		}
		$opts = { %$default_opts, %$opts };
		$opts->{'-using'} ||= \$using;
		$class->import_method($caller, $method, $opts);
	}
	return;
}

sub import_method {
	my $class  = shift;
	my ($caller, $method, $opts) = @_;
	my $coderef = $class->make_coderef($method, $opts);
	$class->install_coderef($caller, $coderef, $method, $opts);
}

sub make_coderef {
	my $class  = shift;
	my ($method, $opts) = @_;
	my $curry = $opts->{'-curry'} || [];
	my $coderef;
	if ($method eq 'using') {
		$coderef = sub {
			return ${$opts->{'-using'}} unless @_;
			my ($object, $coderef) = @_;
			my $old = ${$opts->{'-using'}};
			${$opts->{'-using'}} = $object;
			return $old unless $coderef;
			my @r;
			if (wantarray) {
				@r = $coderef->();
			}
			elsif (defined wantarray) {
				$r[0] = $coderef->();
			}
			else {
				$coderef->(); 1;
			}
			${$opts->{'-using'}} = $old;
			wantarray ? @r : $r[0];
		};
	}
	else {
		$coderef = sub {
			defined(my $object = defined(${$opts->{'-using'}}) ? ${$opts->{'-using'}} : $_)
				or $class->croak_undefined($method, $opts);
			$object->$method(@$curry, @_);
		};
	}
	if (defined $opts->{-prototype}) {
		$coderef = Sub::Util::set_prototype($opts->{-prototype}, $coderef);
	}
	return $coderef;
}

sub install_coderef {
	my $class = shift;
	my ($caller, $coderef, $method, $opts) = @_;
	my $as = $opts->{'-as'} || $method;
	return if $as eq '-';
	$coderef = Sub::Util::set_subname("$caller\::$as", $coderef);
	do {
		no strict 'refs';
		*{"$caller\::$as"} = $coderef;
	};
	'namespace::clean'->import(-cleanee => $caller, $as)
		unless $opts->{'-keep'};
}

sub croak_undefined {
	my $class = shift;
	my ($method, $opts) = @_;
	my $as = $opts->{'-as'} || $method;
	require Carp;
	Carp::croak("Can't call method \"$method\" (via imported sub \"$as\") because \$_ is not defined");
}

1;

__END__