File Coverage

blib/lib/MooX/Role/Parameterized.pm

Criterion	Covered	Total	%
statement	89	95	93.6
branch	27	34	79.4
condition	14	21	66.6
subroutine	17	18	94.4
pod	5	6	83.3
total	152	174	87.3

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};
    }

    return $INFO{$role}{parameter_definition_klass};
}

sub _create_parameters_klass {
    my ( $package, $parameters_definition ) = @_;

    my $klass = "${package}::__MOOX_ROLE_PARAMETERIZED_PARAMS__";

    return $klass if $klass->isa("Moo::Object");

    my @klass_definition = ( extends => "Moo::Object" );

    foreach my $parameter_definition ( @{$parameters_definition} ) {
        push @klass_definition, has => $parameter_definition;
    }

    BuildClass $klass => @klass_definition;

    return $klass;
}

1;
__END__