File Coverage

blib/lib/Exporter/LexicalVars.pm

Criterion	Covered	Total	%
statement	62	67	92.5
branch	18	26	69.2
condition	8	13	61.5
subroutine	14	14	100.0
pod			n/a
total	102	120	85.0

use 5.008003;
use strict;
use warnings;

package Exporter::LexicalVars;

use B qw();
use B::Hooks::Parser qw();
use Carp qw(croak);
use Exporter::Shiny qw(import);

BEGIN {
	eval {
		require List::MoreUtils;
		'List::MoreUtils'->import('uniq');
		1;
	}
	or *uniq = sub {
		my %already;
		grep !$already{$_}++, @_;
	};
};

our $AUTHORITY   = 'cpan:TOBYINK';
our $VERSION     = '0.001';
our %EXPORT_TAGS = ( setup => [qw(import)] );
our @INIT;

sub _generate_import
{
	my $me = shift;
	my ($name, $args, $globals) = @_;
	my $caller = $globals->{into};

	(my $nominal_file = $caller) =~ s(::)(/)g;
	$INC{"$nominal_file\.pm"} ||= __FILE__;

	my (%inject, @vars, @tags);
	for (sort keys %$args)
	{
		/\A[\$\@\%][^\W0-9]\w*\z/ ? push(@vars, $_) :
		/\A[:-](\w*)\z/           ? push(@tags, ":$1") :
		croak("Not a legal name for a lexical variable or tag: '$_'");
	}

	$inject{$_} = $me->_setup_lexical_variable($args, $_) for @vars;
	$inject{$_} = $me->_setup_tag($args, $_) for @tags;
	$inject{":all"} ||= [sort @vars];

	return sub { $me->_handle_inject(\%inject, @_) };
}

sub _handle_inject
{
	my $me      = shift;
	my $inject  = shift;
	my $package = shift;

	# Handle tag expansion
	@_ = @{ $inject->{':default'} or $inject->{':all'} or [] } unless @_;
	@_ = uniq map {
		/\A[:-](\w*)\z/
			? @{ $inject->{":$1"} or croak("Tag $1 not exported by $package") }
			: $_
	} @_;

	my @code = map {
		$inject->{$_} or croak("Variable $_ not exported by $package")
	} @_;
	B::Hooks::Parser::inject(join(';', '', @code));
}

sub _setup_lexical_variable
{
	my $me = shift;
	my ($args, $var) = @_;
	my $value = $args->{$var};

	if ($var =~ /\A[\@\%]/ and defined($value) and not ref($value))
	{
		croak("Cannot initialize $var from a scalar value");
	}

	if (!ref($value))
	{
		return sprintf(
			'my(%s)=(%s);',
			$var,
			defined($value) ? B::perlstring($value) : '',
		);
	}

	if (ref($value) eq q(CODE))
	{
		push @INIT, $value;
		return sprintf(
			'my(%s);$%s::INIT[%d]->(\\%s, %s);',
			$var,
			__PACKAGE__,
			$#INIT,
			$var,
			B::perlstring($var),
		);
	}

	croak("Cannot setup variable $var from reference of type " . ref($value));
}

sub _setup_tag
{
	my $me = shift;
	my ($args, $var) = @_;
	my $value = $args->{$var};

	return $value if ref($value) eq q(ARRAY);

	croak("Cannot setup tag $var from reference of type " . ref($value));
}

1;

__END__