File Coverage

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

Criterion	Covered	Total	%
statement	39	39	100.0
branch	3	6	50.0
condition	1	3	33.3
subroutine	12	12	100.0
pod	2	2	100.0
total	57	62	91.9

package Class::Method::ModifiersX::Override;

use 5.008;
use strict;
use warnings;
no warnings qw( once void uninitialized );

BEGIN {
	$Class::Method::ModifiersX::Override::AUTHORITY = 'cpan:TOBYINK';
	$Class::Method::ModifiersX::Override::VERSION   = '0.002';
}

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

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

our $SUPER_PACKAGE = undef;
our $SUPER_BODY    = undef;
our @SUPER_ARGS    = ();

sub _mk_around
{
	my ($into, $code) = @_;

	return sub {
		local $SUPER_PACKAGE = $into;
		local $SUPER_BODY    = shift;
		local @SUPER_ARGS    = @_;
		return $code->(@_);
	}
}

our %OVERRIDDEN;
sub override
{
	my $into = caller(0);
	my $code = pop;
	my @name = @_;

	for my $method (@name)
	{
		croak "Method '$method' in class '$into' overridden twice"
			if $OVERRIDDEN{$into}{$method}++;
	}

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

sub super ()
{
	return unless defined $SUPER_BODY;
	return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller;
	$SUPER_BODY->(@SUPER_ARGS);
}

1;

__END__