lib/Mouse/Meta/Role/Composite.pm

   1 package Mouse::Meta::Role::Composite;
   2 use Mouse::Util; # enables strict and warnings
   3 use Mouse::Meta::Role;
   4 use Mouse::Meta::Role::Application;
   5 our @ISA = qw(Mouse::Meta::Role);
   6
   7 sub new {
   8     my $class = shift;
   9     my $args  = $class->Mouse::Object::BUILDARGS(@_);
  10     my $roles = delete $args->{roles};
  11     my $self  = $class->create_anon_role(%{$args});
  12     foreach my $role_spec(@{$roles}) {
  13         my($role, $args) = ref($role_spec) eq 'ARRAY'
  14             ? @{$role_spec}
  15             : ($role_spec, {});
  16         $role->apply($self, %{$args});
  17     }
  18     return $self;
  19 }
  20
  21 sub apply_params {
  22     #my($self, $role_params) = @_;
  23     # TODO
  24     return $_[0];
  25 }
  26
  27 sub get_method_list {
  28     my($self) = @_;
  29     return keys %{ $self->{methods} };
  30 }
  31
  32 sub add_method {
  33     my($self, $method_name, $code, $role) = @_;
  34
  35     if( ($self->{methods}{$method_name} || 0) == $code){
  36         # This role already has the same method.
  37         return;
  38     }
  39
  40     if($method_name eq 'meta'){
  41         $self->SUPER::add_method($method_name => $code);
  42     }
  43     else{
  44         # no need to add a subroutine to the stash
  45         my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
  46         push @{$roles}, $role;
  47         if(@{$roles} > 1){
  48             $self->{conflicting_methods}{$method_name}++;
  49         }
  50         $self->{methods}{$method_name} = $code;
  51     }
  52     return;
  53 }
  54
  55 sub get_method_body {
  56     my($self, $method_name) = @_;
  57     return $self->{methods}{$method_name};
  58 }
  59
  60 sub has_method {
  61     # my($self, $method_name) = @_;
  62     return 0; # to fool apply_methods() in combine()
  63 }
  64
  65 sub has_attribute {
  66     # my($self, $method_name) = @_;
  67     return 0; # to fool appply_attributes() in combine()
  68 }
  69
  70 sub has_override_method_modifier {
  71     # my($self, $method_name) = @_;
  72     return 0; # to fool apply_modifiers() in combine()
  73 }
  74
  75 sub add_attribute {
  76     my $self      = shift;
  77     my $attr_name = shift;
  78     my $spec      = (@_ == 1 ? $_[0] : {@_});
  79
  80     my $existing = $self->{attributes}{$attr_name};
  81     if($existing && $existing != $spec){
  82         $self->throw_error("We have encountered an attribute conflict with '$attr_name' "
  83                          . "during composition. This is fatal error and cannot be disambiguated.");
  84     }
  85     $self->SUPER::add_attribute($attr_name, $spec);
  86     return;
  87 }
  88
  89 sub add_override_method_modifier {
  90     my($self, $method_name, $code) = @_;
  91
  92     my $existing = $self->{override_method_modifiers}{$method_name};
  93     if($existing && $existing != $code){
  94         $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
  95                           . "composition (Two 'override' methods of the same name encountered). "
  96                           . "This is fatal error.")
  97     }
  98     $self->SUPER::add_override_method_modifier($method_name, $code);
  99     return;
 100 }
 101
 102 sub apply {
 103     my $self     = shift;
 104     my $consumer = shift;
 105
 106     Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer);
 107     return;
 108 }
 109
 110 package Mouse::Meta::Role::Application::RoleSummation;
 111 our @ISA = qw(Mouse::Meta::Role::Application);
 112
 113 sub apply_methods {
 114     my($self, $role, $consumer, @extra) = @_;
 115
 116     if(exists $role->{conflicting_methods}){
 117         my $consumer_class_name = $consumer->name;
 118
 119         my @conflicting = grep{ !$consumer_class_name->can($_) }
 120             keys %{ $role->{conflicting_methods} };
 121
 122         if(@conflicting) {
 123             my $method_name_conflict = (@conflicting == 1
 124                 ? 'a method name conflict'
 125                 : 'method name conflicts');
 126
 127             my %seen;
 128             my $roles = Mouse::Util::quoted_english_list(
 129                 grep{ !$seen{$_}++ } # uniq
 130                 map { $_->name }
 131                 map { @{$_} }
 132                 @{ $role->{composed_roles_by_method} }{@conflicting}
 133             );
 134
 135             $self->throw_error(sprintf
 136                   q{Due to %s in roles %s,}
 137                 . q{ the method%s %s must be implemented or excluded by '%s'},
 138                     $method_name_conflict,
 139                     $roles,
 140                     (@conflicting > 1 ? 's' : ''),
 141                     Mouse::Util::quoted_english_list(@conflicting),
 142                     $consumer_class_name);
 143         }
 144     }
 145
 146     $self->SUPER::apply_methods($role, $consumer, @extra);
 147     return;
 148 }
 149
 150 package Mouse::Meta::Role::Composite;
 151 1;
 152 __END__
 153
 154 =head1 NAME
 155
 156 Mouse::Meta::Role::Composite - An object to represent the set of roles
 157
 158 =head1 VERSION
 159
 160 This document describes Mouse version 0.71
 161
 162 =head1 SEE ALSO
 163
 164 L<Moose::Meta::Role::Composite>
 165
 166 =cut