lib/Mouse/Meta/Role/Application.pm

   1 package Mouse::Meta::Role::Application;
   2 use Mouse::Util qw(:meta);
   3
   4 sub new {
   5     my $class = shift;
   6     my $args = $class->Mouse::Object::BUILDARGS(@_);
   7
   8     if(exists $args->{exclude} or exists $args->{alias}) {
   9         warnings::warnif(deprecated =>
  10               'The alias and excludes options for role application have been'
  11             . ' renamed -alias and -exclude');
  12
  13         if($args->{alias} && !exists $args->{-alias}){
  14             $args->{-alias} = $args->{alias};
  15         }
  16         if($args->{excludes} && !exists $args->{-excludes}){
  17             $args->{-excludes} = $args->{excludes};
  18         }
  19     }
  20
  21     $args->{aliased_methods} = {};
  22     if(my $alias = $args->{-alias}){
  23         @{$args->{aliased_methods}}{ values %{$alias} } = ();
  24     }
  25
  26     if(my $excludes = $args->{-excludes}){
  27         $args->{-excludes} = {}; # replace with a hash ref
  28         if(ref $excludes){
  29             %{$args->{-excludes}} = (map{ $_ => undef } @{$excludes});
  30         }
  31         else{
  32             $args->{-excludes}{$excludes} = undef;
  33         }
  34     }
  35     my $self = bless $args, $class;
  36     if($class ne __PACKAGE__){
  37         $self->meta->_initialize_object($self, $args);
  38     }
  39     return $self;
  40 }
  41
  42 sub apply {
  43     my($self, $role, $consumer, @extra) = @_;
  44     my $instance;
  45
  46     if(Mouse::Util::is_a_metaclass($consumer)) {   # Application::ToClass
  47         $self->{_to} = 'class';
  48     }
  49     elsif(Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole
  50         $self->{_to} = 'role';
  51     }
  52     else {                                         # Appplication::ToInstance
  53         $self->{_to} = 'instance';
  54         $instance  = $consumer;
  55
  56         $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')
  57             ->create_anon_class(
  58                 superclasses => [ref $instance],
  59                 cache        => 1,
  60             );
  61     }
  62
  63     #$self->check_role_exclusions($role, $consumer, @extra);
  64     $self->check_required_methods($role, $consumer, @extra);
  65     #$self->check_required_attributes($role, $consumer, @extra);
  66
  67     $self->apply_attributes($role, $consumer, @extra);
  68     $self->apply_methods($role, $consumer, @extra);
  69     #$self->apply_override_method_modifiers($role, $consumer, @extra);
  70     #$self->apply_before_method_modifiers($role, $consumer, @extra);
  71     #$self->apply_around_method_modifiers($role, $consumer, @extra);
  72     #$self->apply_after_method_modifiers($role, $consumer, @extra);
  73     $self->apply_modifiers($role, $consumer, @extra);
  74
  75     $self->_append_roles($role, $consumer);
  76
  77     if(defined $instance){ # Application::ToInstance
  78         # rebless instance
  79         bless $instance, $consumer->name;
  80         $consumer->_initialize_object($instance, $instance, 1);
  81     }
  82
  83     return;
  84 }
  85
  86 sub check_required_methods {
  87     my($self, $role, $consumer) = @_;
  88
  89     if($self->{_to} eq 'role'){
  90         $consumer->add_required_methods($role->get_required_method_list);
  91     }
  92     else{ # to class or instance
  93         my $consumer_class_name = $consumer->name;
  94
  95         my @missing;
  96         foreach my $method_name(@{$role->{required_methods}}){
  97             next if exists $self->{aliased_methods}{$method_name};
  98             next if exists $role->{methods}{$method_name};
  99             next if $consumer_class_name->can($method_name);
 100
 101             push @missing, $method_name;
 102         }
 103         if(@missing){
 104             $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
 105                 $role->name,
 106                 (@missing == 1 ? '' : 's'), # method or methods
 107                 Mouse::Util::quoted_english_list(@missing),
 108                 $consumer_class_name);
 109         }
 110     }
 111
 112     return;
 113 }
 114
 115 sub apply_methods {
 116     my($self, $role, $consumer) = @_;
 117
 118     my $alias    = $self->{-alias};
 119     my $excludes = $self->{-excludes};
 120
 121     foreach my $method_name($role->get_method_list){
 122         next if $method_name eq 'meta';
 123
 124         my $code = $role->get_method_body($method_name);
 125
 126         if(!exists $excludes->{$method_name}){
 127             if(!$consumer->has_method($method_name)){
 128                 # The third argument $role is used in Role::Composite
 129                 $consumer->add_method($method_name => $code, $role);
 130             }
 131         }
 132
 133         if(exists $alias->{$method_name}){
 134             my $dstname = $alias->{$method_name};
 135
 136             my $dstcode = $consumer->get_method_body($dstname);
 137
 138             if(defined($dstcode) && $dstcode != $code){
 139                 $role->throw_error("Cannot create a method alias if a local method of the same name exists");
 140             }
 141             else{
 142                 $consumer->add_method($dstname => $code, $role);
 143             }
 144         }
 145     }
 146
 147     return;
 148 }
 149
 150 sub apply_attributes {
 151     my($self, $role, $consumer) = @_;
 152
 153     for my $attr_name ($role->get_attribute_list) {
 154         next if $consumer->has_attribute($attr_name);
 155
 156         $consumer->add_attribute($attr_name
 157             => $role->get_attribute($attr_name));
 158     }
 159     return;
 160 }
 161
 162 sub apply_modifiers {
 163     my($self, $role, $consumer) = @_;
 164
 165     if(my $modifiers = $role->{override_method_modifiers}){
 166         foreach my $method_name (keys %{$modifiers}){
 167             $consumer->add_override_method_modifier(
 168                 $method_name => $modifiers->{$method_name});
 169         }
 170     }
 171
 172     for my $modifier_type (qw/before around after/) {
 173         my $table = $role->{"${modifier_type}_method_modifiers"}
 174             or next;
 175
 176         my $add_modifier = "add_${modifier_type}_method_modifier";
 177
 178         while(my($method_name, $modifiers) = each %{$table}){
 179             foreach my $code(@{ $modifiers }) {
 180                 # skip if the modifier is already applied
 181                 next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++;
 182                 $consumer->$add_modifier($method_name => $code);
 183             }
 184         }
 185     }
 186     return;
 187 }
 188
 189 sub _append_roles {
 190     my($self, $role, $metaclass_or_role) = @_;
 191
 192     my $roles = $metaclass_or_role->{roles};
 193     foreach my $r($role, @{$role->get_roles}){
 194         if(!$metaclass_or_role->does_role($r)){
 195             push @{$roles}, $r;
 196         }
 197     }
 198     return;
 199 }
 200 1;
 201 __END__
 202
 203 =head1 NAME
 204
 205 Mouse::Meta::Role::Application - The Mouse role application class
 206
 207 =head1 SEE ALSO
 208
 209 L<Moose::Role::Application>
 210
 211 L<Moose::Role::Application::ToClass>
 212
 213 L<Moose::Role::Application::ToRole>
 214
 215 L<Moose::Role::Application::ToInstance>
 216