File Coverage

blib/lib/Sub/Talisman.pm

Criterion	Covered	Total	%
statement	95	98	96.9
branch	7	12	58.3
condition			n/a
subroutine	27	28	96.4
pod	4	4	100.0
total	133	142	93.6

package Sub::Talisman;

use 5.008;
use strict;
use warnings;

BEGIN {
	$Sub::Talisman::AUTHORITY = 'cpan:TOBYINK';
	$Sub::Talisman::VERSION   = '0.004';
}

use Attribute::Handlers;
use Sub::Identify qw( get_code_info );
use Sub::Name     qw( subname );
use Scalar::Does  qw( does -constants );
use Scalar::Util  qw( refaddr );

sub _identify
{
	my $sub = shift;
	if (does $sub, CODE)
	{
		my ($p, $n) = get_code_info($sub);
		$n .= sprintf('(%d)', refaddr($sub)) if $n eq '__ANON__';
		return ($p, $n);
	}
	elsif ($sub =~ /::/)
	{
		my ($p, $n) = ($sub =~ /^(.*)::(\w+)$/);
		$p = 'main' if $p eq q();
		return ($p, $n);
	}
	else
	{
		return ($_[0], $sub);
	}
}

use namespace::clean;
my (%TALI, %FETCH);

sub setup_for
{
	my ($class, $caller, $opts) = @_;
	my $atr = $opts->{attribute};
	eval qq{
		package $caller;
		sub $atr :ATTR(CODE)
		{
			unshift \@_, q[$class], q[$caller];
			my \$callback = "$class"->can("_callback");
			goto \$callback;
		}
	};
	namespace::clean->import(
		-cleanee => $caller,
		$opts->{attribute},
	);
	unless ($FETCH{$caller})
	{
		no strict 'refs';
		my $subname = "$caller\::FETCH_CODE_ATTRIBUTES";
		*$subname = subname $subname, sub {
			my ($class, $sub) = @_;
			return map { /(\w+)$/ ? $1 : () }
				__PACKAGE__->get_attributes($sub);
		};
		$FETCH{$caller} = 1;
	}
}

sub import
{
	my $class  = shift;
	my $caller = caller;
	foreach my $atr (@_)
	{
		$class->setup_for($caller, { attribute => $atr });
	}
}

sub _process_params
{
	my ($class, $attr, $params) = @_;
	return $params;
}

sub _callback
{
	my ($class, $installation_pkg, $caller_pkg, $glob, $ref, $attr, $params, $step, $file, $line) = @_;
	my ($p, $n)   = _identify($ref, scalar caller);
	my $full_attr = join q[::], $installation_pkg, $attr;
	my $obj       = $class->_process_params($full_attr, $params);
	$TALI{$p}{$n}{$full_attr} = $obj;
}

sub get_attributes
{
	my ($class, $sub) = @_;
	my ($p, $n) = _identify($sub, scalar caller);
	my %hash = %{ $TALI{$p}{$n} || {} };
	return sort keys %hash;
}

sub get_attribute_parameters
{
	my ($class, $sub, $attr) = @_;
	$attr = scalar(caller).'::'.$attr unless $attr =~ /::/;
	my ($p, $n) = _identify($sub, scalar caller);
	return unless exists $TALI{$p}{$n}{$attr};
	return $TALI{$p}{$n}{$attr};
}

sub get_subs
{
	my ($class, $attr) = @_;
	$attr = scalar(caller).'::'.$attr unless $attr =~ /::/;
	my @subs;
	foreach my $pkg (keys %TALI)
	{
		push @subs,
			map  { "$pkg\::$_" }
			grep { exists $TALI{$pkg}{$_}{$attr} }
			grep { not /^__ANON__\([0-9]+\)$/ }
			keys %{ $TALI{$pkg} };
	}
	return @subs;
}

1;

__END__