File Coverage

blib/lib/Class/Method/ModifiersX/Augment.pm

Criterion	Covered	Total	%
statement	54	56	96.4
branch	5	8	62.5
condition			n/a
subroutine	13	13	100.0
pod	2	2	100.0
total	74	79	93.6

package Class::Method::ModifiersX::Augment;

use 5.008;
use strict;
use warnings;

BEGIN {
	$Class::Method::ModifiersX::Augment::AUTHORITY = 'cpan:TOBYINK';
	$Class::Method::ModifiersX::Augment::VERSION   = '0.001';
}

use base qw(Exporter);
our %EXPORT_TAGS = (
	all => [our @EXPORT_OK = our @EXPORT = qw( augment inner )],
);

use Class::Method::Modifiers qw( install_modifier );

use if ($] >= 5.010), 'mro';
use if ($] <  5.010), 'MRO::Compat';

our %INNER_BODY = ();
our %INNER_ARGS = ();

sub _mk_around
{
	my ($into, $code, $name) = @_;
	unless ($name)
	{
		require Carp;
		Carp::croak("need name");
	}

	my $super;
	my @isa = @{ mro::get_linear_isa($into) };
	shift @isa;
	SUPER: foreach my $pkg (@isa)
	{
		no strict qw(refs);
		if (exists &{"${pkg}::${name}"})
		{
			$super = $pkg and last SUPER;
		}
	}

	return sub {
		my $super_body = shift;
		local $INNER_ARGS{$super} = [ @_ ];
		local $INNER_BODY{$super} = $code;
		return $super_body->(@_);
	};
}

sub augment
{
	my $into = caller(0);
	my $code = pop;

	foreach my $name (@_)
	{
		my $sub = _mk_around($into, $code, $name);
		install_modifier($into, 'around', $name, $sub);
	}
}

sub inner ()
{
	my $pkg = caller;

	if (my $body = $INNER_BODY{$pkg}) {
		my @args = @{ $INNER_ARGS{$pkg} };
		local $INNER_ARGS{$pkg};
		local $INNER_BODY{$pkg};
		return $body->(@args);
	}

	return;
}



1;

__END__