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 Moose::Util  'english_list';
   8 use Scalar::Util 'blessed';
   9
  10 our $VERSION   = '0.77';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Moose::Meta::Role::Application';
  15
  16 __PACKAGE__->meta->add_attribute('role' => (
  17     reader => 'role',
  18     writer => 'set_role',
  19 ));
  20
  21 __PACKAGE__->meta->add_attribute('class' => (
  22     reader => 'class',
  23     writer => 'set_class',
  24 ));
  25
  26 sub apply {
  27     my ($self, $role, $class) = @_;
  28
  29     $self->set_role($role);
  30     $self->set_class($class);
  31
  32     $self->SUPER::apply($role, $class);
  33
  34     $class->add_role($role);
  35     $class->add_role_application($self);
  36 }
  37
  38 sub check_role_exclusions {
  39     my ($self, $role, $class) = @_;
  40     if ($class->excludes_role($role->name)) {
  41         $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
  42     }
  43     foreach my $excluded_role_name ($role->get_excluded_roles_list) {
  44         if ($class->does_role($excluded_role_name)) {
  45             $class->throw_error("The class " . $class->name . " does the excluded role '$excluded_role_name'");
  46         }
  47     }
  48 }
  49
  50 sub check_required_methods {
  51     my ($self, $role, $class) = @_;
  52
  53     my @missing;
  54     my @is_attr;
  55
  56     # NOTE:
  57     # we might need to move this down below the
  58     # the attributes so that we can require any
  59     # attribute accessors. However I am thinking
  60     # that maybe those are somehow exempt from
  61     # the require methods stuff.
  62     foreach my $required_method_name ($role->get_required_method_list) {
  63
  64         if (!$class->find_method_by_name($required_method_name)) {
  65
  66             next if $self->is_aliased_method($required_method_name);
  67
  68             push @missing, $required_method_name;
  69         }
  70     }
  71
  72     return unless @missing;
  73
  74     my $error = '';
  75
  76     if (@missing) {
  77         my $noun = @missing == 1 ? 'method' : 'methods';
  78
  79         my $list
  80             = Moose::Util::english_list( map { q{'} . $_ . q{'} } @missing );
  81
  82         $error
  83             .= q{'}
  84             . $role->name
  85             . "' requires the $noun $list "
  86             . "to be implemented by '"
  87             . $class->name . q{'};
  88     }
  89
  90     $class->throw_error($error);
  91 }
  92
  93 sub check_required_attributes {
  94
  95 }
  96
  97 sub apply_attributes {
  98     my ($self, $role, $class) = @_;
  99     foreach my $attribute_name ($role->get_attribute_list) {
 100         # it if it has one already
 101         if ($class->has_attribute($attribute_name) &&
 102             # make sure we haven't seen this one already too
 103             $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) {
 104             next;
 105         }
 106         else {
 107             $class->add_attribute(
 108                 $attribute_name,
 109                 $role->get_attribute($attribute_name)
 110             );
 111         }
 112     }
 113 }
 114
 115 sub apply_methods {
 116     my ($self, $role, $class) = @_;
 117     foreach my $method_name ($role->get_method_list) {
 118
 119         unless ($self->is_method_excluded($method_name)) {
 120             # it if it has one already
 121             if ($class->has_method($method_name) &&
 122                 # and if they are not the same thing ...
 123                 $class->get_method($method_name)->body != $role->get_method($method_name)->body) {
 124                 next;
 125             }
 126             else {
 127                 # add it, although it could be overridden
 128                 $class->add_method(
 129                     $method_name,
 130                     $role->get_method($method_name)
 131                 );
 132             }
 133         }
 134
 135         if ($self->is_method_aliased($method_name)) {
 136             my $aliased_method_name = $self->get_method_aliases->{$method_name};
 137             # it if it has one already
 138             if ($class->has_method($aliased_method_name) &&
 139                 # and if they are not the same thing ...
 140                 $class->get_method($aliased_method_name)->body != $role->get_method($method_name)->body) {
 141                 $class->throw_error("Cannot create a method alias if a local method of the same name exists");
 142             }
 143             $class->add_method(
 144                 $aliased_method_name,
 145                 $role->get_method($method_name)
 146             );
 147         }
 148     }
 149     # we must reset the cache here since
 150     # we are just aliasing methods, otherwise
 151     # the modifiers go wonky.
 152     $class->reset_package_cache_flag;
 153 }
 154
 155 sub apply_override_method_modifiers {
 156     my ($self, $role, $class) = @_;
 157     foreach my $method_name ($role->get_method_modifier_list('override')) {
 158         # it if it has one already then ...
 159         if ($class->has_method($method_name)) {
 160             next;
 161         }
 162         else {
 163             # if this is not a role, then we need to
 164             # find the original package of the method
 165             # so that we can tell the class were to
 166             # find the right super() method
 167             my $method = $role->get_override_method_modifier($method_name);
 168             my ($package) = Class::MOP::get_code_info($method);
 169             # if it is a class, we just add it
 170             $class->add_override_method_modifier($method_name, $method, $package);
 171         }
 172     }
 173 }
 174
 175 sub apply_method_modifiers {
 176     my ($self, $modifier_type, $role, $class) = @_;
 177     my $add = "add_${modifier_type}_method_modifier";
 178     my $get = "get_${modifier_type}_method_modifiers";
 179     foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
 180         $class->$add(
 181             $method_name,
 182             $_
 183         ) foreach $role->$get($method_name);
 184     }
 185 }
 186
 187 1;
 188
 189 __END__
 190
 191 =pod
 192
 193 =head1 NAME
 194
 195 Moose::Meta::Role::Application::ToClass - Compose a role into a class
 196
 197 =head1 DESCRIPTION
 198
 199 =head2 METHODS
 200
 201 =over 4
 202
 203 =item B<new>
 204
 205 =item B<meta>
 206
 207 =item B<apply>
 208
 209 =item B<check_role_exclusions>
 210
 211 =item B<check_required_methods>
 212
 213 =item B<check_required_attributes>
 214
 215 =item B<apply_attributes>
 216
 217 =item B<apply_methods>
 218
 219 =item B<apply_method_modifiers>
 220
 221 =item B<apply_override_method_modifiers>
 222
 223 =back
 224
 225 =head1 BUGS
 226
 227 All complex software has bugs lurking in it, and this module is no
 228 exception. If you find a bug please either email me, or add the bug
 229 to cpan-RT.
 230
 231 =head1 AUTHOR
 232
 233 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 234
 235 =head1 COPYRIGHT AND LICENSE
 236
 237 Copyright 2006-2009 by Infinity Interactive, Inc.
 238
 239 L<http://www.iinteractive.com>
 240
 241 This library is free software; you can redistribute it and/or modify
 242 it under the same terms as Perl itself.
 243
 244 =cut
 245