[gitmo/Moose.git] / lib / Moose / Meta / Role / Application / RoleSummation.pm

package Moose::Meta::Role::Application::RoleSummation;

use strict;
use warnings;
use metaclass;

use Scalar::Util    'blessed';

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

our $VERSION   = '0.72_01';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

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

__PACKAGE__->meta->add_attribute('role_params' => (
    reader  => 'role_params',
    default => sub { {} }
));

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

sub get_method_aliases_for_role {
    my ($self, $role) = @_;
    $role = $role->name if blessed $role;
    if ($self->role_params->{$role} && defined $self->role_params->{$role}->{alias}) {
        return $self->role_params->{$role}->{alias};
    }
    return {};    
}

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

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

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

# stolen from List::MoreUtils ...
my $uniq = sub { my %h; map { $h{$_}++ == 0 ? $_ : () } @_ };

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

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

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

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

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

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

    $c->add_excluded_roles(keys %excluded_roles);
}

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

    my %all_required_methods = map { $_ => undef } $uniq->(map {
        $_->get_required_method_list
    } @{$c->get_roles});

    foreach my $role (@{$c->get_roles}) {
        foreach my $required (keys %all_required_methods) {
            
            delete $all_required_methods{$required}
                if $role->has_method($required)
                || $self->is_aliased_method($role, $required);
        }
    }

    $c->add_required_methods(keys %all_required_methods);
}

sub check_required_attributes {
    
}

sub apply_attributes {
    my ($self, $c) = @_;
    
    my @all_attributes = map {
        my $role = $_;
        map { 
            +{ 
                name => $_,
                attr => $role->get_attribute($_),
            }
        } $role->get_attribute_list
    } @{$c->get_roles};
    
    my %seen;
    foreach my $attr (@all_attributes) {
        if (exists $seen{$attr->{name}}) {
            if ( $seen{$attr->{name}} != $attr->{attr} ) {
                require Moose;
                Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' " 
                                   . "during composition. This is fatal error and cannot be disambiguated.")
            }
        }
        $seen{$attr->{name}} = $attr->{attr};
    }

    foreach my $attr (@all_attributes) {    
        $c->add_attribute($attr->{name}, $attr->{attr});
    }
}

sub apply_methods {
    my ($self, $c) = @_;
    
    my @all_methods = map {
        my $role     = $_;
        my $aliases  = $self->get_method_aliases_for_role($role);
        my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
        (
            (map { 
                exists $excludes{$_} ? () :
                +{ 
                    role   => $role,
                    name   => $_,
                    method => $role->get_method($_),
                }
            } $role->get_method_list),
            (map { 
                +{ 
                    role   => $role,
                    name   => $aliases->{$_},
                    method => $role->get_method($_),
                }            
            } keys %$aliases)
        );
    } @{$c->get_roles};
    
    my (%seen, %method_map);
    foreach my $method (@all_methods) {
        if (exists $seen{$method->{name}}) {
            if ($seen{$method->{name}}->body != $method->{method}->body) {
                $c->add_required_methods($method->{name});
                delete $method_map{$method->{name}};
                next;
            }           
        }       
        
        $seen{$method->{name}}       = $method->{method};
        $method_map{$method->{name}} = $method->{method};
    }

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

sub apply_override_method_modifiers {
    my ($self, $c) = @_;
    
    my @all_overrides = map {
        my $role = $_;
        map { 
            +{ 
                name   => $_,
                method => $role->get_override_method_modifier($_),
            }
        } $role->get_method_modifier_list('override');
    } @{$c->get_roles};
    
    my %seen;
    foreach my $override (@all_overrides) {
        if ( $c->has_method($override->{name}) ){
            require Moose;
            Moose->throw_error( "Role '" . $c->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->{name}}) {
            if ( $seen{$override->{name}} != $override->{method} ) {
                require Moose;
                Moose->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->{name}} = $override->{method};
    }
        
    $c->add_override_method_modifier(
        $_->{name}, $_->{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->get_roles}) {
        foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
            $c->$add(
                $method_name,
                $_
            ) foreach $role->$get($method_name);
        }
    }
}

1;

__END__

=pod

=head1 NAME

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

=head1 DESCRIPTION

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

=head2 METHODS

=over 4

=item B<new>

=item B<meta>

=item B<role_params>

=item B<get_exclusions_for_role>

=item B<get_method_aliases_for_role>

=item B<is_aliased_method>

=item B<is_method_aliased>

=item B<is_method_excluded>

=item B<apply>

=item B<check_role_exclusions>

=item B<check_required_methods>

=item B<check_required_attributes>

=item B<apply_attributes>

=item B<apply_methods>

=item B<apply_method_modifiers>

=item B<apply_override_method_modifiers>

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 AUTHOR

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2009 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

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

=cut
Commit	Line	Data
fb1e11d5	1	package Moose::Meta::Role::Application::RoleSummation;
	2
	3	use strict;
	4	use warnings;
	5	use metaclass;
	6
fb1e11d5	7	use Scalar::Util 'blessed';
fb1e11d5	8
	9	use Moose::Meta::Role::Composite;
	10
baf46b9e	11	our $VERSION = '0.72_01';
e606ae5f	12	$VERSION = eval $VERSION;
fb1e11d5	13	our $AUTHORITY = 'cpan:STEVAN';
	14
	15	use base 'Moose::Meta::Role::Application';
	16
28412c0b	17	__PACKAGE__->meta->add_attribute('role_params' => (
	18	reader => 'role_params',
	19	default => sub { {} }
	20	));
	21
	22	sub get_exclusions_for_role {
	23	my ($self, $role) = @_;
	24	$role = $role->name if blessed $role;
	25	if ($self->role_params->{$role} && defined $self->role_params->{$role}->{excludes}) {
	26	if (ref $self->role_params->{$role}->{excludes} eq 'ARRAY') {
	27	return $self->role_params->{$role}->{excludes};
	28	}
	29	return [ $self->role_params->{$role}->{excludes} ];
	30	}
	31	return [];
	32	}
	33
	34	sub get_method_aliases_for_role {
	35	my ($self, $role) = @_;
	36	$role = $role->name if blessed $role;
	37	if ($self->role_params->{$role} && defined $self->role_params->{$role}->{alias}) {
	38	return $self->role_params->{$role}->{alias};
	39	}
	40	return {};
	41	}
	42
	43	sub is_method_excluded {
	44	my ($self, $role, $method_name) = @_;
	45	foreach ($self->get_exclusions_for_role($role->name)) {
	46	return 1 if $_ eq $method_name;
	47	}
	48	return 0;
	49	}
	50
	51	sub is_method_aliased {
	52	my ($self, $role, $method_name) = @_;
	53	exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
	54	}
	55
	56	sub is_aliased_method {
	57	my ($self, $role, $method_name) = @_;
	58	my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
	59	exists $aliased_names{$method_name} ? 1 : 0;
	60	}
	61
fb1e11d5	62	# stolen from List::MoreUtils ...
	63	my $uniq = sub { my %h; map { $h{$_}++ == 0 ? $_ : () } @_ };
	64
	65	sub check_role_exclusions {
	66	my ($self, $c) = @_;
	67
88cfb4cb	68	my %excluded_roles;
	69	for my $role (@{ $c->get_roles }) {
	70	my $name = $role->name;
	71
	72	for my $excluded ($role->get_excluded_roles_list) {
	73	push @{ $excluded_roles{$excluded} }, $name;
	74	}
	75	}
fb1e11d5	76
fb1e11d5	77	foreach my $role (@{$c->get_roles}) {
88cfb4cb	78	foreach my $excluded (keys %excluded_roles) {
	79	next unless $role->does_role($excluded);
	80
	81	my @excluding = @{ $excluded_roles{$excluded} };
70ea9161	82
70ea9161	83	require Moose;
5b5b7c12	84	Moose->throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded);
fb1e11d5	85	}
	86	}
	87
88cfb4cb	88	$c->add_excluded_roles(keys %excluded_roles);
fb1e11d5	89	}
	90
	91	sub check_required_methods {
	92	my ($self, $c) = @_;
	93
	94	my %all_required_methods = map { $_ => undef } $uniq->(map {
	95	$_->get_required_method_list
	96	} @{$c->get_roles});
	97
	98	foreach my $role (@{$c->get_roles}) {
	99	foreach my $required (keys %all_required_methods) {
28412c0b	100
fb1e11d5	101	delete $all_required_methods{$required}
28412c0b	102	if $role->has_method($required)
28412c0b	103	\|\| $self->is_aliased_method($role, $required);
fb1e11d5	104	}
	105	}
	106
	107	$c->add_required_methods(keys %all_required_methods);
	108	}
	109
709c321c	110	sub check_required_attributes {
	111
	112	}
	113
fb1e11d5	114	sub apply_attributes {
	115	my ($self, $c) = @_;
	116
	117	my @all_attributes = map {
	118	my $role = $_;
	119	map {
	120	+{
	121	name => $_,
	122	attr => $role->get_attribute($_),
	123	}
	124	} $role->get_attribute_list
	125	} @{$c->get_roles};
	126
	127	my %seen;
	128	foreach my $attr (@all_attributes) {
	129	if (exists $seen{$attr->{name}}) {
70ea9161	130	if ( $seen{$attr->{name}} != $attr->{attr} ) {
	131	require Moose;
	132	Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' "
	133	. "during composition. This is fatal error and cannot be disambiguated.")
	134	}
fb1e11d5	135	}
	136	$seen{$attr->{name}} = $attr->{attr};
	137	}
	138
	139	foreach my $attr (@all_attributes) {
	140	$c->add_attribute($attr->{name}, $attr->{attr});
	141	}
	142	}
	143
	144	sub apply_methods {
	145	my ($self, $c) = @_;
	146
	147	my @all_methods = map {
28412c0b	148	my $role = $_;
	149	my $aliases = $self->get_method_aliases_for_role($role);
	150	my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
	151	(
	152	(map {
	153	exists $excludes{$_} ? () :
	154	+{
	155	role => $role,
	156	name => $_,
	157	method => $role->get_method($_),
	158	}
	159	} $role->get_method_list),
	160	(map {
	161	+{
	162	role => $role,
	163	name => $aliases->{$_},
	164	method => $role->get_method($_),
	165	}
	166	} keys %$aliases)
	167	);
fb1e11d5	168	} @{$c->get_roles};
	169
	170	my (%seen, %method_map);
	171	foreach my $method (@all_methods) {
	172	if (exists $seen{$method->{name}}) {
	173	if ($seen{$method->{name}}->body != $method->{method}->body) {
	174	$c->add_required_methods($method->{name});
	175	delete $method_map{$method->{name}};
	176	next;
	177	}
28412c0b	178	}
28412c0b	179
fb1e11d5	180	$seen{$method->{name}} = $method->{method};
	181	$method_map{$method->{name}} = $method->{method};
	182	}
	183
87e63626	184	$c->add_method($_ => $method_map{$_}) for keys %method_map;
fb1e11d5	185	}
	186
	187	sub apply_override_method_modifiers {
	188	my ($self, $c) = @_;
	189
	190	my @all_overrides = map {
	191	my $role = $_;
	192	map {
	193	+{
	194	name => $_,
	195	method => $role->get_override_method_modifier($_),
	196	}
	197	} $role->get_method_modifier_list('override');
	198	} @{$c->get_roles};
	199
	200	my %seen;
	201	foreach my $override (@all_overrides) {
70ea9161	202	if ( $c->has_method($override->{name}) ){
	203	require Moose;
	204	Moose->throw_error( "Role '" . $c->name . "' has encountered an 'override' method conflict " .
	205	"during composition (A local method of the same name as been found). This " .
	206	"is fatal error." )
	207	}
fb1e11d5	208	if (exists $seen{$override->{name}}) {
70ea9161	209	if ( $seen{$override->{name}} != $override->{method} ) {
	210	require Moose;
	211	Moose->throw_error( "We have encountered an 'override' method conflict during " .
	212	"composition (Two 'override' methods of the same name encountered). " .
	213	"This is fatal error.")
	214	}
fb1e11d5	215	}
	216	$seen{$override->{name}} = $override->{method};
	217	}
	218
	219	$c->add_override_method_modifier(
	220	$_->{name}, $_->{method}
	221	) for @all_overrides;
	222
	223	}
	224
	225	sub apply_method_modifiers {
	226	my ($self, $modifier_type, $c) = @_;
	227	my $add = "add_${modifier_type}_method_modifier";
	228	my $get = "get_${modifier_type}_method_modifiers";
	229	foreach my $role (@{$c->get_roles}) {
	230	foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
	231	$c->$add(
	232	$method_name,
	233	$_
	234	) foreach $role->$get($method_name);
	235	}
	236	}
	237	}
	238
fb1e11d5	239	1;
	240
	241	__END__
	242
	243	=pod
	244
	245	=head1 NAME
	246
ab76842e	247	Moose::Meta::Role::Application::RoleSummation - Combine two or more roles
fb1e11d5	248
	249	=head1 DESCRIPTION
	250
	251	Summation composes two traits, forming the union of non-conflicting
	252	bindings and 'disabling' the conflicting bindings
	253
	254	=head2 METHODS
	255
	256	=over 4
	257
	258	=item B<new>
	259
	260	=item B<meta>
	261
28412c0b	262	=item B<role_params>
	263
	264	=item B<get_exclusions_for_role>
	265
	266	=item B<get_method_aliases_for_role>
	267
	268	=item B<is_aliased_method>
	269
	270	=item B<is_method_aliased>
	271
	272	=item B<is_method_excluded>
	273
fb1e11d5	274	=item B<apply>
fb1e11d5	275
709c321c	276	=item B<check_role_exclusions>
709c321c	277
fb1e11d5	278	=item B<check_required_methods>
fb1e11d5	279
709c321c	280	=item B<check_required_attributes>
fb1e11d5	281
	282	=item B<apply_attributes>
	283
	284	=item B<apply_methods>
	285
	286	=item B<apply_method_modifiers>
	287
fb1e11d5	288	=item B<apply_override_method_modifiers>
	289
	290	=back
	291
	292	=head1 BUGS
	293
	294	All complex software has bugs lurking in it, and this module is no
	295	exception. If you find a bug please either email me, or add the bug
	296	to cpan-RT.
	297
	298	=head1 AUTHOR
	299
	300	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	301
	302	=head1 COPYRIGHT AND LICENSE
	303
2840a3b2	304	Copyright 2006-2009 by Infinity Interactive, Inc.
fb1e11d5	305
	306	L<http://www.iinteractive.com>
	307
	308	This library is free software; you can redistribute it and/or modify
	309	it under the same terms as Perl itself.
	310
	311	=cut
	312