lib/Moose/Meta/Role/Application/ToClass.pm

   1 package Moose::Meta::Role::Application::ToClass;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 use List::MoreUtils 'firstval';
   8 use Moose::Util  'english_list';
   9 use Scalar::Util 'weaken', 'blessed';
  10
  11 use base 'Moose::Meta::Role::Application';
  12
  13 __PACKAGE__->meta->add_attribute('role' => (
  14     reader => 'role',
  15     Class::MOP::_definition_context(),
  16 ));
  17
  18 __PACKAGE__->meta->add_attribute('class' => (
  19     accessor => 'class',
  20     Class::MOP::_definition_context(),
  21 ));
  22
  23 sub apply {
  24     my ($self, $role, $class) = @_;
  25
  26     # We need weak_ref in CMOP :(
  27     weaken($self->{role}  = $role);
  28     weaken($self->{class} = $class);
  29
  30     $self->SUPER::apply($role, $class);
  31
  32     $class->add_role($role);
  33     $class->add_role_application($self);
  34 }
  35
  36 sub check_role_exclusions {
  37     my ($self, $role, $class) = @_;
  38     if ($class->excludes_role($role->name)) {
  39         $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
  40     }
  41     foreach my $excluded_role_name ($role->get_excluded_roles_list) {
  42         if ($class->does_role($excluded_role_name)) {
  43             $class->throw_error("The class " . $class->name . " does the excluded role '$excluded_role_name'");
  44         }
  45     }
  46 }
  47
  48 sub check_required_methods {
  49     my ($self, $role, $class) = @_;
  50
  51     my @missing;
  52     my @is_attr;
  53
  54     # NOTE:
  55     # we might need to move this down below the
  56     # the attributes so that we can require any
  57     # attribute accessors. However I am thinking
  58     # that maybe those are somehow exempt from
  59     # the require methods stuff.
  60     foreach my $required_method ($role->get_required_method_list) {
  61         my $required_method_name = $required_method->name;
  62
  63         if (!$class->find_method_by_name($required_method_name)) {
  64
  65             next if $self->is_aliased_method($required_method_name);
  66
  67             push @missing, $required_method;
  68         }
  69     }
  70
  71     return unless @missing;
  72
  73     my $error = '';
  74
  75     @missing = sort { $a->name cmp $b->name } @missing;
  76     my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing;
  77
  78     if (@conflicts) {
  79         my $conflict = $conflicts[0];
  80         my $roles = $conflict->roles_as_english_list;
  81
  82         my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts;
  83
  84         if (@same_role_conflicts == 1) {
  85             $error
  86                 .= "Due to a method name conflict in roles "
  87                 .  $roles
  88                 . ", the method '"
  89                 . $conflict->name
  90                 . "' must be implemented or excluded by '"
  91                 . $class->name
  92                 . q{'};
  93         }
  94         else {
  95             my $methods
  96                 = Moose::Util::english_list( map { q{'} . $_->name . q{'} } @same_role_conflicts );
  97
  98             $error
  99                 .= "Due to method name conflicts in roles "
 100                 .  $roles
 101                 . ", the methods "
 102                 . $methods
 103                 . " must be implemented or excluded by '"
 104                 . $class->name
 105                 . q{'};
 106         }
 107     }
 108     elsif (@missing) {
 109         my $noun = @missing == 1 ? 'method' : 'methods';
 110
 111         my $list
 112             = Moose::Util::english_list( map { q{'} . $_ . q{'} } @missing );
 113
 114         $error
 115             .= q{'}
 116             . $role->name
 117             . "' requires the $noun $list "
 118             . "to be implemented by '"
 119             . $class->name . q{'};
 120
 121         if (my $meth = firstval { $class->name->can($_) } @missing) {
 122             $error .= ". If you imported functions intending to use them as "
 123                     . "methods, you need to explicitly mark them as such, via "
 124                     . $class->name . "->meta->add_method($meth => \\\&$meth)";
 125         }
 126     }
 127
 128     $class->throw_error($error);
 129 }
 130
 131 sub check_required_attributes {
 132
 133 }
 134
 135 sub apply_attributes {
 136     my ($self, $role, $class) = @_;
 137
 138     foreach my $attribute_name ($role->get_attribute_list) {
 139         # it if it has one already
 140         if ($class->has_attribute($attribute_name) &&
 141             # make sure we haven't seen this one already too
 142             $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) {
 143             next;
 144         }
 145         else {
 146             $class->add_attribute(
 147                 $role->get_attribute($attribute_name)->attribute_for_class
 148             );
 149         }
 150     }
 151 }
 152
 153 sub apply_methods {
 154     my ( $self, $role, $class ) = @_;
 155
 156     foreach my $method ( $role->_get_local_methods ) {
 157         my $method_name = $method->name;
 158
 159         next if $method->isa('Class::MOP::Method::Meta');
 160
 161         unless ( $self->is_method_excluded($method_name) ) {
 162
 163             my $class_method = $class->get_method($method_name);
 164
 165             next if $class_method && $class_method->body != $method->body;
 166
 167             $class->add_method(
 168                 $method_name,
 169                 $method,
 170             );
 171         }
 172
 173         next unless $self->is_method_aliased($method_name);
 174
 175         my $aliased_method_name = $self->get_method_aliases->{$method_name};
 176
 177         my $class_method = $class->get_method($aliased_method_name);
 178
 179         if ( $class_method && $class_method->body != $method->body ) {
 180             $class->throw_error(
 181                 "Cannot create a method alias if a local method of the same name exists"
 182             );
 183         }
 184
 185         $class->add_method(
 186             $aliased_method_name,
 187             $method,
 188         );
 189     }
 190
 191     # we must reset the cache here since
 192     # we are just aliasing methods, otherwise
 193     # the modifiers go wonky.
 194     $class->reset_package_cache_flag;
 195 }
 196
 197 sub apply_override_method_modifiers {
 198     my ($self, $role, $class) = @_;
 199     foreach my $method_name ($role->get_method_modifier_list('override')) {
 200         # it if it has one already then ...
 201         if ($class->has_method($method_name)) {
 202             next;
 203         }
 204         else {
 205             # if this is not a role, then we need to
 206             # find the original package of the method
 207             # so that we can tell the class were to
 208             # find the right super() method
 209             my $method = $role->get_override_method_modifier($method_name);
 210             my ($package) = Class::MOP::get_code_info($method);
 211             # if it is a class, we just add it
 212             $class->add_override_method_modifier($method_name, $method, $package);
 213         }
 214     }
 215 }
 216
 217 sub apply_method_modifiers {
 218     my ($self, $modifier_type, $role, $class) = @_;
 219     my $add = "add_${modifier_type}_method_modifier";
 220     my $get = "get_${modifier_type}_method_modifiers";
 221     foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
 222         $class->$add(
 223             $method_name,
 224             $_
 225         ) foreach $role->$get($method_name);
 226     }
 227 }
 228
 229 1;
 230
 231 # ABSTRACT: Compose a role into a class
 232
 233 __END__
 234
 235 =pod
 236
 237 =head1 DESCRIPTION
 238
 239 =head2 METHODS
 240
 241 =over 4
 242
 243 =item B<new>
 244
 245 =item B<meta>
 246
 247 =item B<apply>
 248
 249 =item B<check_role_exclusions>
 250
 251 =item B<check_required_methods>
 252
 253 =item B<check_required_attributes>
 254
 255 =item B<apply_attributes>
 256
 257 =item B<apply_methods>
 258
 259 =item B<apply_method_modifiers>
 260
 261 =item B<apply_override_method_modifiers>
 262
 263 =back
 264
 265 =head1 BUGS
 266
 267 See L<Moose/BUGS> for details on reporting bugs.
 268
 269 =cut
 270