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