MooX-Role-Parameterized
view release on metacpan or search on metacpan
lib/MooX/Role/Parameterized.pm view on Meta::CPAN
package MooX::Role::Parameterized;
use v5.12;
use strict;
use warnings;
our $VERSION = '0.701'; # VERSION
# ABSTRACT: roles with composition parameters
use Module::Runtime qw(use_module);
use Carp qw(carp croak);
use Exporter qw(import);
use Moo::Role qw();
use MooX::BuildClass;
use MooX::Role::Parameterized::Mop;
our @EXPORT = qw(parameter role apply apply_roles_to_target);
our $VERBOSE = 0;
our %INFO;
sub apply {
carp "apply method is deprecated, please use 'apply_roles_to_target'"
if $VERBOSE;
goto &apply_roles_to_target;
}
sub apply_roles_to_target {
my ( $role, $args, %extra ) = @_;
croak
"unable to apply parameterized role: not an MooX::Role::Parameterized"
if !__PACKAGE__->is_role($role);
$args = [$args] if ref($args) ne ref( [] );
my $target = defined( $extra{target} ) ? $extra{target} : (caller)[0];
if ( exists $INFO{$role}
&& exists $INFO{$role}{code_for}
&& ref $INFO{$role}{code_for} eq "CODE" )
{
my $mop = MooX::Role::Parameterized::Mop->new(
target => $target,
role => $role
);
my $parameter_definition_klass =
_fetch_parameter_definition_klass($role);
foreach my $params ( @{$args} ) {
if ( defined $parameter_definition_klass ) {
eval { $params = $parameter_definition_klass->new($params); };
croak(
"unable to apply parameterized role '${role}' to '${target}': $@"
) if $@;
}
$INFO{$role}{code_for}->( $params, $mop );
}
}
Moo::Role->apply_roles_to_package( $target, $role );
}
sub role(&) { ##no critic (Subroutines::ProhibitSubroutinePrototypes)
my $package = (caller)[0];
$INFO{$package} ||= { is_role => 1 };
croak "role subroutine called multiple times on '$package'"
if exists $INFO{$package}{code_for};
$INFO{$package}{code_for} = shift;
}
sub parameter {
my $package = (caller)[0];
$INFO{$package} ||= { is_role => 1 };
push @{ $INFO{$package}{parameters_definition} ||= [] }, \@_;
}
sub is_role {
my ( $klass, $role ) = @_;
return !!( $INFO{$role} && $INFO{$role}->{is_role} );
}
sub build_apply_roles_to_package {
my ( $klass, $orig ) = @_;
return sub {
my $target = (caller)[0];
while (@_) {
my $role = shift;
eval { use_module($role) };
if ( MooX::Role::Parameterized->is_role($role) ) {
my $params = [ {} ];
if ( @_ && ref $_[0] ) {
$params = shift;
$params = [$params] if ref($params) ne ref( [] );
}
foreach my $args ( @{$params} ) {
$role->apply_roles_to_target( $args, target => $target );
}
next;
}
if ( defined $orig && ref $orig eq 'CODE' ) {
$orig->($role);
next;
}
if ( Moo::Role->is_role($role) ) {
Moo::Role->apply_roles_to_package( $target, $role );
eval {
Moo::Role->_maybe_reset_handlemoose($target); ##no critic(Subroutines::ProtectPrivateSubs)
};
next;
}
croak "Can't apply role to '${target}' - '${role}' is neither a "
. "MooX::Role::Parameterized, Moo::Role or Role::Tiny role";
}
};
}
sub _fetch_parameter_definition_klass {
my $role = shift;
return if !exists $INFO{$role};
if ( !exists $INFO{$role}{parameter_definition_klass} ) {
return if !exists $INFO{$role}{parameters_definition};
my $parameters_definition = $INFO{$role}{parameters_definition};
$INFO{$role}{parameter_definition_klass} =
_create_parameters_klass( $role, $parameters_definition );
delete $INFO{$role}{parameters_definition};
}
( run in 1.079 second using v1.01-cache-2.11-cpan-ff9377addf4 )