File Coverage

blib/lib/package/compute.pm

Criterion	Covered	Total	%
statement	54	56	96.4
branch	18	24	75.0
condition	6	8	75.0
subroutine	9	9	100.0
pod			n/a
total	87	97	89.6

package package::compute;

use 5.008;
use strict;
use warnings;

BEGIN {
	$package::compute::AUTHORITY = 'cpan:TOBYINK';
	$package::compute::VERSION   = '0.005';
}

use B::Hooks::Parser 0.08 qw();
use Carp qw(confess);

my $count = 0;

sub import
{
	my ($class, $name) = @_;

	my $caller = caller;
	my $pkg;

	if (not defined $name)
	{
		$pkg = $caller;
	}
	elsif (!ref $name and $name eq '-anon')
	{
		$pkg = sprintf('%s::__ANON__::%s', $class, ++$count);
	}
	elsif (!ref $name and $name eq '-filename')
	{
		# figure out where we're called from
		my (undef, $filename) = caller;

		# figure out where it got loaded via %INC.
		for my $k (sort keys %INC)
		{
			if ($INC{$k} eq $filename)
			{
				$pkg = $k;
				$pkg =~ s<[/\\]><::>g;
				$pkg =~ s<\.pm$><>i; # can this be uppercase on some platforms?
				last;
			}
		}
	}
	else
	{
		$pkg = __RPACKAGE__($name, $caller);
	}

	confess("package::compute could not determine package name, died")
		unless defined $pkg;

	B::Hooks::Parser::inject("; package $pkg;")
		unless $pkg eq $caller;

	no strict 'refs';
	*{"$pkg\::__RPACKAGE__"} = \&__RPACKAGE__;
}

sub __RPACKAGE__
{
	my ($name, $caller) = @_;
	$caller ||= scalar caller;
	return $caller unless defined $name;

	my $count;
	while (ref $name eq 'CODE')
		{ $name = $name->($caller); die "too deep" if ++$count > 7 }
	if ($name =~ /^[.]+(?:::|'|\/)/)
		{ $name = "$caller\::$name" }

	my @pkg = grep { length and $_ ne '.' } split /(?:::|'|\/)/, $name;
	my @final;
	foreach (@pkg)
	{
		push @final, $_;
		next unless /^([.]+)/;
		confess "invalid relative package path" if length $1 > @final;
		splice(@final, -(length $1));
	}

	return join q/::/, @final;
}

1;

__END__