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                 roles        => [$role],
  60                 cache        => 1,
  61
  62                 in_application_to_instance => 1, # suppress to apply roles
  63             );
  64     }
  65
  66     #$self->check_role_exclusions($role, $consumer, @extra);
  67     $self->check_required_methods($role, $consumer, @extra);
  68     #$self->check_required_attributes($role, $consumer, @extra);
  69
  70     $self->apply_attributes($role, $consumer, @extra);
  71     $self->apply_methods($role, $consumer, @extra);
  72     #$self->apply_override_method_modifiers($role, $consumer, @extra);
  73     #$self->apply_before_method_modifiers($role, $consumer, @extra);
  74     #$self->apply_around_method_modifiers($role, $consumer, @extra);
  75     #$self->apply_after_method_modifiers($role, $consumer, @extra);
  76     $self->apply_modifiers($role, $consumer, @extra);
  77
  78     $self->_append_roles($role, $consumer);
  79
  80     if(defined $instance){ # Application::ToInstance
  81         # rebless instance
  82         bless $instance, $consumer->name;
  83         $consumer->_initialize_object($instance, $instance, 1);
  84     }
  85
  86     return;
  87 }
  88
  89 sub check_required_methods {
  90     my($self, $role, $consumer) = @_;
  91
  92     if($self->{_to} eq 'role'){
  93         $consumer->add_required_methods($role->get_required_method_list);
  94     }
  95     else{ # to class or instance
  96         my $consumer_class_name = $consumer->name;
  97
  98         my @missing;
  99         foreach my $method_name(@{$role->{required_methods}}){
 100             next if exists $self->{aliased_methods}{$method_name};
 101             next if exists $role->{methods}{$method_name};
 102             next if $consumer_class_name->can($method_name);
 103
 104             push @missing, $method_name;
 105         }
 106         if(@missing){
 107             $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
 108                 $role->name,
 109                 (@missing == 1 ? '' : 's'), # method or methods
 110                 Mouse::Util::quoted_english_list(@missing),
 111                 $consumer_class_name);
 112         }
 113     }
 114
 115     return;
 116 }
 117
 118 sub apply_methods {
 119     my($self, $role, $consumer) = @_;
 120
 121     my $alias    = $self->{-alias};
 122     my $excludes = $self->{-excludes};
 123
 124     foreach my $method_name($role->get_method_list){
 125         next if $method_name eq 'meta';
 126
 127         my $code = $role->get_method_body($method_name);
 128
 129         if(!exists $excludes->{$method_name}){
 130             if(!$consumer->has_method($method_name)){
 131                 # The third argument $role is used in Role::Composite
 132                 $consumer->add_method($method_name => $code, $role);
 133             }
 134         }
 135
 136         if(exists $alias->{$method_name}){
 137             my $dstname = $alias->{$method_name};
 138
 139             my $dstcode = $consumer->get_method_body($dstname);
 140
 141             if(defined($dstcode) && $dstcode != $code){
 142                 $role->throw_error("Cannot create a method alias if a local method of the same name exists");
 143             }
 144             else{
 145                 $consumer->add_method($dstname => $code, $role);
 146             }
 147         }
 148     }
 149
 150     return;
 151 }
 152
 153 sub apply_attributes {
 154     my($self, $role, $consumer) = @_;
 155
 156     for my $attr_name ($role->get_attribute_list) {
 157         next if $consumer->has_attribute($attr_name);
 158
 159         $consumer->add_attribute($attr_name
 160             => $role->get_attribute($attr_name));
 161     }
 162     return;
 163 }
 164
 165 sub apply_modifiers {
 166     my($self, $role, $consumer) = @_;
 167
 168     if(my $modifiers = $role->{override_method_modifiers}){
 169         foreach my $method_name (keys %{$modifiers}){
 170             $consumer->add_override_method_modifier(
 171                 $method_name => $modifiers->{$method_name});
 172         }
 173     }
 174
 175     for my $modifier_type (qw/before around after/) {
 176         my $table = $role->{"${modifier_type}_method_modifiers"}
 177             or next;
 178
 179         my $add_modifier = "add_${modifier_type}_method_modifier";
 180
 181         while(my($method_name, $modifiers) = each %{$table}){
 182             foreach my $code(@{ $modifiers }) {
 183                 # skip if the modifier is already applied
 184                 next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++;
 185                 $consumer->$add_modifier($method_name => $code);
 186             }
 187         }
 188     }
 189     return;
 190 }
 191
 192 sub _append_roles {
 193     my($self, $role, $metaclass_or_role) = @_;
 194
 195     my $roles = $metaclass_or_role->{roles};
 196     foreach my $r($role, @{$role->get_roles}){
 197         if(!$metaclass_or_role->does_role($r)){
 198             push @{$roles}, $r;
 199         }
 200     }
 201     return;
 202 }
 203 1;
 204 __END__
 205
 206 =head1 NAME
 207
 208 Mouse::Meta::Role::Application - The Mouse role application class
 209
 210 =head1 VERSION
 211
 212 This document describes Mouse version 0.93
 213
 214 =head1 SEE ALSO
 215
 216 L<Moose::Role::Application>
 217
 218 L<Moose::Role::Application::ToClass>
 219
 220 L<Moose::Role::Application::ToRole>
 221
 222 L<Moose::Role::Application::ToInstance>
 223
 224 =cut
 225