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             if ( $class_method && $class_method->body != $method->body ) {
 166
 167                 if ( $self->is_shadowing_prohibited ) {
 168                     $class->throw_error(
 169                         "Shadowing is prohibited but both ".$class->name." and ".$role->name." have a method ${method_name}"
 170                     );
 171                 }
 172                 next;
 173             }
 174
 175             $class->add_method(
 176                 $method_name,
 177                 $method,
 178             );
 179         }
 180
 181         next unless $self->is_method_aliased($method_name);
 182
 183         my $aliased_method_name = $self->get_method_aliases->{$method_name};
 184
 185         my $class_method = $class->get_method($aliased_method_name);
 186
 187         if ( $class_method && $class_method->body != $method->body ) {
 188             $class->throw_error(
 189                 "Cannot create a method alias if a local method of the same name exists"
 190             );
 191         }
 192
 193         $class->add_method(
 194             $aliased_method_name,
 195             $method,
 196         );
 197     }
 198
 199     # we must reset the cache here since
 200     # we are just aliasing methods, otherwise
 201     # the modifiers go wonky.
 202     $class->reset_package_cache_flag;
 203 }
 204
 205 sub apply_override_method_modifiers {
 206     my ($self, $role, $class) = @_;
 207     foreach my $method_name ($role->get_method_modifier_list('override')) {
 208         # it if it has one already then ...
 209         if ($class->has_method($method_name)) {
 210             next;
 211         }
 212         else {
 213             # if this is not a role, then we need to
 214             # find the original package of the method
 215             # so that we can tell the class were to
 216             # find the right super() method
 217             my $method = $role->get_override_method_modifier($method_name);
 218             my ($package) = Class::MOP::get_code_info($method);
 219             # if it is a class, we just add it
 220             $class->add_override_method_modifier($method_name, $method, $package);
 221         }
 222     }
 223 }
 224
 225 sub apply_method_modifiers {
 226     my ($self, $modifier_type, $role, $class) = @_;
 227     my $add = "add_${modifier_type}_method_modifier";
 228     my $get = "get_${modifier_type}_method_modifiers";
 229     foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
 230         $class->$add(
 231             $method_name,
 232             $_
 233         ) foreach $role->$get($method_name);
 234     }
 235 }
 236
 237 1;
 238
 239 # ABSTRACT: Compose a role into a class
 240
 241 __END__
 242
 243 =pod
 244
 245 =head1 DESCRIPTION
 246
 247 =head2 METHODS
 248
 249 =over 4
 250
 251 =item B<new>
 252
 253 =item B<meta>
 254
 255 =item B<apply>
 256
 257 =item B<check_role_exclusions>
 258
 259 =item B<check_required_methods>
 260
 261 =item B<check_required_attributes>
 262
 263 =item B<apply_attributes>
 264
 265 =item B<apply_methods>
 266
 267 =item B<apply_method_modifiers>
 268
 269 =item B<apply_override_method_modifiers>
 270
 271 =back
 272
 273 =head1 BUGS
 274
 275 See L<Moose/BUGS> for details on reporting bugs.
 276
 277 =cut
 278