<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Moose::Meta::Role::Application::RoleSummation;
BEGIN {
  $Moose::Meta::Role::Application::RoleSummation::AUTHORITY = 'cpan:STEVAN';
}
{
  $Moose::Meta::Role::Application::RoleSummation::VERSION = '2.0603';
}

use strict;
use warnings;
use metaclass;

use Scalar::Util 'blessed';

use Moose::Meta::Role::Composite;

use base 'Moose::Meta::Role::Application';

__PACKAGE__-&gt;meta-&gt;add_attribute('role_params' =&gt; (
    reader  =&gt; 'role_params',
    default =&gt; sub { {} },
    Class::MOP::_definition_context(),
));

sub get_exclusions_for_role {
    my ($self, $role) = @_;
    $role = $role-&gt;name if blessed $role;
    my $excludes_key = exists $self-&gt;role_params-&gt;{$role}-&gt;{'-excludes'} ?
                           '-excludes' : 'excludes';
    if ($self-&gt;role_params-&gt;{$role} &amp;&amp; defined $self-&gt;role_params-&gt;{$role}-&gt;{$excludes_key}) {
        if (ref $self-&gt;role_params-&gt;{$role}-&gt;{$excludes_key} eq 'ARRAY') {
            return $self-&gt;role_params-&gt;{$role}-&gt;{$excludes_key};
        }
        return [ $self-&gt;role_params-&gt;{$role}-&gt;{$excludes_key} ];
    }
    return [];
}

sub get_method_aliases_for_role {
    my ($self, $role) = @_;
    $role = $role-&gt;name if blessed $role;
    my $alias_key = exists $self-&gt;role_params-&gt;{$role}-&gt;{'-alias'} ?
                        '-alias' : 'alias';
    if ($self-&gt;role_params-&gt;{$role} &amp;&amp; defined $self-&gt;role_params-&gt;{$role}-&gt;{$alias_key}) {
        return $self-&gt;role_params-&gt;{$role}-&gt;{$alias_key};
    }
    return {};
}

sub is_method_excluded {
    my ($self, $role, $method_name) = @_;
    foreach ($self-&gt;get_exclusions_for_role($role-&gt;name)) {
        return 1 if $_ eq $method_name;
    }
    return 0;
}

sub is_method_aliased {
    my ($self, $role, $method_name) = @_;
    exists $self-&gt;get_method_aliases_for_role($role-&gt;name)-&gt;{$method_name} ? 1 : 0
}

sub is_aliased_method {
    my ($self, $role, $method_name) = @_;
    my %aliased_names = reverse %{$self-&gt;get_method_aliases_for_role($role-&gt;name)};
    exists $aliased_names{$method_name} ? 1 : 0;
}

sub check_role_exclusions {
    my ($self, $c) = @_;

    my %excluded_roles;
    for my $role (@{ $c-&gt;get_roles }) {
        my $name = $role-&gt;name;

        for my $excluded ($role-&gt;get_excluded_roles_list) {
            push @{ $excluded_roles{$excluded} }, $name;
        }
    }

    foreach my $role (@{$c-&gt;get_roles}) {
        foreach my $excluded (keys %excluded_roles) {
            next unless $role-&gt;does_role($excluded);

            my @excluding = @{ $excluded_roles{$excluded} };

            require Moose;
            Moose-&gt;throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded);
        }
    }

    $c-&gt;add_excluded_roles(keys %excluded_roles);
}

sub check_required_methods {
    my ($self, $c) = @_;

    my %all_required_methods =
        map { $_-&gt;name =&gt; $_ }
        map { $_-&gt;get_required_method_list }
        @{$c-&gt;get_roles};

    foreach my $role (@{$c-&gt;get_roles}) {
        foreach my $required (keys %all_required_methods) {

            delete $all_required_methods{$required}
                if $role-&gt;has_method($required)
                || $self-&gt;is_aliased_method($role, $required);
        }
    }

    $c-&gt;add_required_methods(values %all_required_methods);
}

sub check_required_attributes {

}

sub apply_attributes {
    my ($self, $c) = @_;

    my @all_attributes;

    for my $role ( @{ $c-&gt;get_roles } ) {
        push @all_attributes,
            map { $role-&gt;get_attribute($_) } $role-&gt;get_attribute_list;
    }

    my %seen;
    foreach my $attr (@all_attributes) {
        my $name = $attr-&gt;name;

        if ( exists $seen{$name} ) {
            next if $seen{$name}-&gt;is_same_as($attr);

            my $role1 = $seen{$name}-&gt;associated_role-&gt;name;
            my $role2 = $attr-&gt;associated_role-&gt;name;

            require Moose;
            Moose-&gt;throw_error(
                "We have encountered an attribute conflict with '$name' "
                    . "during role composition. "
                    . " This attribute is defined in both $role1 and $role2."
                    . " This is a fatal error and cannot be disambiguated." );
        }

        $seen{$name} = $attr;
    }

    foreach my $attr (@all_attributes) {
        $c-&gt;add_attribute( $attr-&gt;clone );
    }
}

sub apply_methods {
    my ($self, $c) = @_;

    my @all_methods = map {
        my $role     = $_;
        my $aliases  = $self-&gt;get_method_aliases_for_role($role);
        my %excludes = map { $_ =&gt; undef } @{ $self-&gt;get_exclusions_for_role($role) };
        (
            (map {
                exists $excludes{$_} ? () :
                +{
                    role   =&gt; $role,
                    name   =&gt; $_,
                    method =&gt; $role-&gt;get_method($_),
                }
            } map { $_-&gt;name }
              grep { !$_-&gt;isa('Class::MOP::Method::Meta') }
                   $role-&gt;_get_local_methods),
            (map {
                +{
                    role   =&gt; $role,
                    name   =&gt; $aliases-&gt;{$_},
                    method =&gt; $role-&gt;get_method($_),
                }
            } keys %$aliases)
        );
    } @{$c-&gt;get_roles};

    my (%seen, %conflicts, %method_map);
    foreach my $method (@all_methods) {
        next if $conflicts{$method-&gt;{name}};
        my $seen = $seen{$method-&gt;{name}};

        if ($seen) {
            if ($seen-&gt;{method}-&gt;body != $method-&gt;{method}-&gt;body) {
                $c-&gt;add_conflicting_method(
                    name  =&gt; $method-&gt;{name},
                    roles =&gt; [$method-&gt;{role}-&gt;name, $seen-&gt;{role}-&gt;name],
                );

                delete $method_map{$method-&gt;{name}};
                $conflicts{$method-&gt;{name}} = 1;
                next;
            }
        }

        $seen{$method-&gt;{name}}       = $method;
        $method_map{$method-&gt;{name}} = $method-&gt;{method};
    }

    $c-&gt;add_method($_ =&gt; $method_map{$_}) for keys %method_map;
}

sub apply_override_method_modifiers {
    my ($self, $c) = @_;

    my @all_overrides = map {
        my $role = $_;
        map {
            +{
                name   =&gt; $_,
                method =&gt; $role-&gt;get_override_method_modifier($_),
            }
        } $role-&gt;get_method_modifier_list('override');
    } @{$c-&gt;get_roles};

    my %seen;
    foreach my $override (@all_overrides) {
        if ( $c-&gt;has_method($override-&gt;{name}) ){
            require Moose;
            Moose-&gt;throw_error( "Role '" . $c-&gt;name . "' has encountered an 'override' method conflict " .
                                "during composition (A local method of the same name as been found). This " .
                                "is fatal error." )
        }
        if (exists $seen{$override-&gt;{name}}) {
            if ( $seen{$override-&gt;{name}} != $override-&gt;{method} ) {
                require Moose;
                Moose-&gt;throw_error( "We have encountered an 'override' method conflict during " .
                                    "composition (Two 'override' methods of the same name encountered). " .
                                    "This is fatal error.")
            }
        }
        $seen{$override-&gt;{name}} = $override-&gt;{method};
    }

    $c-&gt;add_override_method_modifier(
        $_-&gt;{name}, $_-&gt;{method}
    ) for @all_overrides;

}

sub apply_method_modifiers {
    my ($self, $modifier_type, $c) = @_;
    my $add = "add_${modifier_type}_method_modifier";
    my $get = "get_${modifier_type}_method_modifiers";
    foreach my $role (@{$c-&gt;get_roles}) {
        foreach my $method_name ($role-&gt;get_method_modifier_list($modifier_type)) {
            $c-&gt;$add(
                $method_name,
                $_
            ) foreach $role-&gt;$get($method_name);
        }
    }
}

1;

# ABSTRACT: Combine two or more roles



=pod

=head1 NAME

Moose::Meta::Role::Application::RoleSummation - Combine two or more roles

=head1 VERSION

version 2.0603

=head1 DESCRIPTION

Summation composes two traits, forming the union of non-conflicting
bindings and 'disabling' the conflicting bindings

=head2 METHODS

=over 4

=item B&lt;new&gt;

=item B&lt;meta&gt;

=item B&lt;role_params&gt;

=item B&lt;get_exclusions_for_role&gt;

=item B&lt;get_method_aliases_for_role&gt;

=item B&lt;is_aliased_method&gt;

=item B&lt;is_method_aliased&gt;

=item B&lt;is_method_excluded&gt;

=item B&lt;apply&gt;

=item B&lt;check_role_exclusions&gt;

=item B&lt;check_required_methods&gt;

=item B&lt;check_required_attributes&gt;

=item B&lt;apply_attributes&gt;

=item B&lt;apply_methods&gt;

=item B&lt;apply_method_modifiers&gt;

=item B&lt;apply_override_method_modifiers&gt;

=back

=head1 BUGS

See L&lt;Moose/BUGS&gt; for details on reporting bugs.

=head1 AUTHOR

Moose is maintained by the Moose Cabal, along with the help of many contributors. See L&lt;Moose/CABAL&gt; and L&lt;Moose/CONTRIBUTORS&gt; for details.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 by Infinity Interactive, Inc..

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut


__END__


</pre></body></html>