File Coverage

blib/lib/Refinements/Package.pm

Criterion	Covered	Total	%
statement	37	37	100.0
branch	1	2	50.0
condition			n/a
subroutine	11	11	100.0
pod	4	4	100.0
total	53	54	98.1

use 5.010;
use strict;
use warnings;

{
	package Refinements::Package;

	use Exporter::Tiny ();
	use Method::Lexical ();
	use Module::Runtime qw( use_package_optimistically );

	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.001';
	our @ISA       = qw( Method::Lexical );

	sub add_refinement
	{
		my $class = shift;
		my ($fqname, $coderef) = @_;

		my ($package, $subname) = ($fqname =~ /^(.+)::(\w+)$/)
			or Exporter::Tiny::_croak('Could not split "%s" as a fully qualified sub name', $fqname);

		$Refinements::REFINEMENTS{$class}{$fqname} = $coderef;
	}

	sub get_refinement
	{
		my $class = shift;
		my ($fqname) = @_;
		$Refinements::REFINEMENTS{$class}{$fqname};
	}

	sub has_refinement
	{
		my $class = shift;
		my ($fqname) = @_;
		exists($Refinements::REFINEMENTS{$class}{$fqname});
	}

	sub get_refinement_names
	{
		my $class = shift;
		keys %{ $Refinements::REFINEMENTS{$class} };
	}

	my $wrap = sub
	{
		my $class = shift;
		my ($fqname, $coderef) = @_;
		my ($package, $subname) = ($fqname =~ /^(.+)::(\w+)$/);
		use_package_optimistically($package);
		my $orig = $package->can($subname);

		return sub
		{
			my $curr = $_[0]->can($subname);
			if ($curr == $orig)
			{
				unshift @_, $orig;
				goto $coderef;
			}
			goto $curr;
		};
	};

	sub import
	{
		my $class = shift;

		my @refinements = map {
			my $name = $_;
			my $code = $class->$wrap( $name, $class->get_refinement($name) );
			$name => $code;
		} $class->get_refinement_names;

		$class->SUPER::import(@refinements);
	}
}

1;

__END__