File Coverage

blib/lib/MooX/CaptainHook.pm

Criterion	Covered	Total	%
statement	76	91	83.5
branch	17	30	56.6
condition	7	20	35.0
subroutine	20	22	90.9
pod	3	3	100.0
total	123	166	74.1

package MooX::CaptainHook;

use 5.008;
use strict;
use warnings;

use Exporter::Shiny qw/ on_application on_inflation is_role /;

BEGIN {
	no warnings 'once';
	$MooX::CaptainHook::AUTHORITY = 'cpan:TOBYINK';
	$MooX::CaptainHook::VERSION   = '0.011';
}

our %on_application;
our %on_inflation;

sub is_role
{
	my $package = shift;
	require Role::Tiny;
	return !!1 if exists $Role::Tiny::INFO{$package};
	return !!0 if exists $Moo::MAKERS{$package};
	if ($INC{'Class/MOP.pm'} and my $classof = 'Class::MOP'->can('class_of')) {
		my $meta = $classof->($package);
		return !!1 if $meta && $meta->isa('Moose::Meta::Role');
	}
	return !!0;
}

{
	my %already;
	sub _fire
	{
		my (undef, $callbacks, $key, $args) = @_;
		return if defined $key && $already{$key}++;
		return unless $callbacks;
		for my $cb (@$callbacks)
		{
			$cb->($args) for $args->[0];  # local $_ aliasing
		}
	}
}

use constant ON_APPLICATION => do {
	package MooX::CaptainHook::OnApplication;
	BEGIN {
		no warnings 'once';
		$MooX::CaptainHook::OnApplication::AUTHORITY = 'cpan:TOBYINK';
		$MooX::CaptainHook::OnApplication::VERSION   = '0.011';
	}
	use Moo::Role;
	after apply_roles_to_package => sub
	{
		my ($toolage, $package, @roles) = @_;

		for my $role (@roles)
		{
			'MooX::CaptainHook'->_fire(
				$on_application{$role},
				"OnApplication: $package $role",
				[ $package, $role ],
			);

			# This stuff is for internals...
			push @{ $on_application{$package} ||= [] }, @{ $on_application{$role} || [] }
				if MooX::CaptainHook::is_role($package);
			push @{ $on_inflation{$package} ||= [] }, @{ $on_inflation{$role} || [] };
		}
	};
	__PACKAGE__;
};

# This sub makes sure that when a role which has an on_application hook
# gets inflated to a full Moose role (as will happen if the role is
# consumed by a Moose class!) then the generated metarole object will
# have a trait that still triggers the on_application hook.
#
# There are probably numerous edge cases not catered for, but my simple
# tests seem to work.
#
sub _inflated
{
	my $args = shift;
	my $meta = $args->[0];
	return unless $meta->isa('Moose::Meta::Role');
	require Moose::Util::MetaRole;
	$args->[0] = $meta = Moose::Util::MetaRole::apply_metaroles(
		for            => $meta->name,
		role_metaroles => {
			role => eval q{
				package MooX::CaptainHook::OnApplication::Moose;
				BEGIN {
					no warnings 'once';
					$MooX::CaptainHook::OnApplication::Moose::AUTHORITY = 'cpan:TOBYINK';
					$MooX::CaptainHook::OnApplication::Moose::VERSION   = '0.011';
				}
				use Moose::Role;
				after apply => sub {
					my $role    = $_[0]->name;
					my $package = $_[1]->name;

					'MooX::CaptainHook'->_fire(
						$on_application{$role},
						"OnApplication: $package $role",
						[ $package, $role ],
					);

					# This stuff is for internals...
					if (MooX::CaptainHook::is_role($_[1]->name)) {
						push @{ $on_application{$package} ||= [] }, @{ $on_application{$role} || [] };
						Moose::Util::MetaRole::apply_metaroles(
							for            => $package,
							role_metaroles => {
								role => [__PACKAGE__],
							},
						);
					}
				};
				[__PACKAGE__];
			},
		},
	);
}

sub on_application (&;$)
{
	my ($code, $role) = @_;
	$role = caller unless defined $role;
	push @{$on_application{$role}||=[]}, $code;

	'Moo::Role'->apply_single_role_to_package('Moo::Role', ON_APPLICATION)
		unless Role::Tiny::does_role('Moo::Role', ON_APPLICATION);

	return;
}

use constant ON_INFLATION => do {
	package MooX::CaptainHook::OnInflation;
	BEGIN {
		no warnings 'once';
		$MooX::CaptainHook::OnInflation::AUTHORITY = 'cpan:TOBYINK';
		$MooX::CaptainHook::OnInflation::VERSION   = '0.011';
	}
	use Moo::Role;
	around inject_real_metaclass_for => sub
	{
		my ($orig, $pkg) = @_;
		my $args = [ scalar $orig->($pkg) ];
		'MooX::CaptainHook'->_fire(
			[
				'MooX::CaptainHook'->can('_inflated'),
				@{$on_inflation{$pkg}||[]}
			],
			undef,
			$args,
		);
		return $args->[0];
	};
	__PACKAGE__;
};

sub on_inflation (&;$)
{
	my ($code, $pkg) = @_;
	$pkg = caller unless defined $pkg;
	push @{$on_inflation{$pkg}||=[]}, $_[0];

	return;
}

{
	package MooX::CaptainHook::HandleMoose::Hack;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.011';
	use overload qw[bool] => sub { 0 };
	sub DESTROY {
		'Moo::Role'->apply_single_role_to_package('Moo::HandleMoose', MooX::CaptainHook::ON_INFLATION)
			if Moo::HandleMoose->can('inject_real_metaclass_for')
			&& !Role::Tiny::does_role('Moo::HandleMoose', MooX::CaptainHook::ON_INFLATION);
	}
	if ($Moo::HandleMoose::SETUP_DONE)
		{ __PACKAGE__->DESTROY }
	else
		{ $Moo::HandleMoose::SETUP_DONE ||= bless [] }
}

1;

__END__