File Coverage

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

Criterion	Covered	Total	%
statement	34	34	100.0
branch	2	4	50.0
condition	1	3	33.3
subroutine	11	11	100.0
pod	2	2	100.0
total	50	54	92.5

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.001';
}

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

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->(@_);
	}
}

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

	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__