lib/Moose/Meta/Role.pm

   1
   2 package Moose::Meta::Role;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Carp 'confess';
   9
  10 our $VERSION = '0.02';
  11
  12 __PACKAGE__->meta->add_attribute('role_meta' => (
  13     reader => 'role_meta'
  14 ));
  15
  16 __PACKAGE__->meta->add_attribute('attribute_map' => (
  17     reader   => 'get_attribute_map',
  18     default  => sub { {} }
  19 ));
  20
  21 __PACKAGE__->meta->add_attribute('method_modifier_map' => (
  22     reader  => 'get_method_modifier_map',
  23     default => sub {
  24         return {
  25             before   => {},
  26             after    => {},
  27             around   => {},
  28             override => {}
  29         };
  30     }
  31 ));
  32
  33 sub new {
  34     my $class   = shift;
  35     my %options = @_;
  36     $options{role_meta} = Class::MOP::Class->initialize(
  37         $options{role_name},
  38         ':method_metaclass' => 'Moose::Meta::Role::Method'
  39     );
  40     my $self = $class->meta->new_object(%options);
  41     return $self;
  42 }
  43
  44 sub apply {
  45     my ($self, $other) = @_;
  46
  47     foreach my $attribute_name ($self->get_attribute_list) {
  48         # skip it if it has one already
  49         next if $other->has_attribute($attribute_name);
  50         # add it, although it could be overriden
  51         $other->add_attribute(
  52             $attribute_name,
  53             %{$self->get_attribute($attribute_name)}
  54         );
  55     }
  56
  57     foreach my $method_name ($self->get_method_list) {
  58         # skip it if it has one already
  59         next if $other->has_method($method_name);
  60         # add it, although it could be overriden
  61         $other->alias_method(
  62             $method_name,
  63             $self->get_method($method_name)
  64         );
  65     }
  66
  67     foreach my $method_name ($self->get_method_modifier_list('override')) {
  68         # skip it if it has one already
  69         next if $other->has_method($method_name);
  70         # add it, although it could be overriden
  71         $other->add_override_method_modifier(
  72             $method_name,
  73             $self->get_method_modifier('override' => $method_name),
  74             $self->name
  75         );
  76     }
  77
  78     foreach my $method_name ($self->get_method_modifier_list('before')) {
  79         $other->add_before_method_modifier(
  80             $method_name,
  81             $self->get_method_modifier('before' => $method_name)
  82         );
  83     }
  84
  85     foreach my $method_name ($self->get_method_modifier_list('after')) {
  86         $other->add_after_method_modifier(
  87             $method_name,
  88             $self->get_method_modifier('after' => $method_name)
  89         );
  90     }
  91
  92     foreach my $method_name ($self->get_method_modifier_list('around')) {
  93         $other->add_around_method_modifier(
  94             $method_name,
  95             $self->get_method_modifier('around' => $method_name)
  96         );
  97     }
  98
  99     ## add the roles and set does()
 100
 101     $other->add_role($self);
 102
 103     # NOTE:
 104     # this will not replace a locally
 105     # defined does() method, those
 106     # should work as expected since
 107     # they are working off the same
 108     # metaclass.
 109     # It will override an inherited
 110     # does() method though, since
 111     # it needs to add this new metaclass
 112     # to the mix.
 113
 114     $other->add_method('does' => sub {
 115         my (undef, $role_name) = @_;
 116         (defined $role_name)
 117             || confess "You much supply a role name to does()";
 118         foreach my $class ($other->class_precedence_list) {
 119             return 1
 120                 if $other->initialize($class)->does_role($role_name);
 121         }
 122         return 0;
 123     }) unless $other->has_method('does');
 124 }
 125
 126 # NOTE:
 127 # we delegate to some role_meta methods for convience here
 128 # the Moose::Meta::Role is meant to be a read-only interface
 129 # to the underlying role package, if you want to manipulate
 130 # that, just use ->role_meta
 131
 132 sub name    { (shift)->role_meta->name    }
 133 sub version { (shift)->role_meta->version }
 134
 135 sub get_method      { (shift)->role_meta->get_method(@_)  }
 136 sub has_method      { (shift)->role_meta->has_method(@_)  }
 137 sub get_method_list {
 138     my ($self) = @_;
 139     # meta is not applicable in this context,
 140     # if you want to see it use the ->role_meta
 141     grep { !/^meta$/ } $self->role_meta->get_method_list;
 142 }
 143
 144 # ... however the items in statis (attributes & method modifiers)
 145 # can be removed and added to through this API
 146
 147 # attributes
 148
 149 sub add_attribute {
 150     my ($self, $name, %attr_desc) = @_;
 151     $self->get_attribute_map->{$name} = \%attr_desc;
 152 }
 153
 154 sub has_attribute {
 155     my ($self, $name) = @_;
 156     exists $self->get_attribute_map->{$name} ? 1 : 0;
 157 }
 158
 159 sub get_attribute {
 160     my ($self, $name) = @_;
 161     $self->get_attribute_map->{$name}
 162 }
 163
 164 sub remove_attribute {
 165     my ($self, $name) = @_;
 166     delete $self->get_attribute_map->{$name}
 167 }
 168
 169 sub get_attribute_list {
 170     my ($self) = @_;
 171     keys %{$self->get_attribute_map};
 172 }
 173
 174 # method modifiers
 175
 176 sub add_method_modifier {
 177     my ($self, $modifier_type, $method_name, $method) = @_;
 178     $self->get_method_modifier_map->{$modifier_type}->{$method_name} = $method;
 179 }
 180
 181 sub has_method_modifier {
 182     my ($self, $modifier_type, $method_name) = @_;
 183     exists $self->get_method_modifier_map->{$modifier_type}->{$method_name} ? 1 : 0
 184 }
 185
 186 sub get_method_modifier {
 187     my ($self, $modifier_type, $method_name) = @_;
 188     $self->get_method_modifier_map->{$modifier_type}->{$method_name};
 189 }
 190
 191 sub remove_method_modifier {
 192     my ($self, $modifier_type, $method_name) = @_;
 193     delete $self->get_method_modifier_map->{$modifier_type}->{$method_name};
 194 }
 195
 196 sub get_method_modifier_list {
 197     my ($self, $modifier_type) = @_;
 198     keys %{$self->get_method_modifier_map->{$modifier_type}};
 199 }
 200
 201 package Moose::Meta::Role::Method;
 202
 203 use strict;
 204 use warnings;
 205
 206 our $VERSION = '0.01';
 207
 208 use base 'Class::MOP::Method';
 209
 210 1;
 211
 212 __END__
 213
 214 =pod
 215
 216 =head1 NAME
 217
 218 Moose::Meta::Role - The Moose Role metaclass
 219
 220 =head1 DESCRIPTION
 221
 222 Moose's Roles are being actively developed, please see L<Moose::Role>
 223 for more information.
 224
 225 =head1 METHODS
 226
 227 =over 4
 228
 229 =item B<meta>
 230
 231 =item B<new>
 232
 233 =item B<apply>
 234
 235 =back
 236
 237 =over 4
 238
 239 =item B<name>
 240
 241 =item B<version>
 242
 243 =item B<role_meta>
 244
 245 =back
 246
 247 =over 4
 248
 249 =item B<get_method>
 250
 251 =item B<has_method>
 252
 253 =item B<get_method_list>
 254
 255 =back
 256
 257 =over 4
 258
 259 =item B<add_attribute>
 260
 261 =item B<has_attribute>
 262
 263 =item B<get_attribute>
 264
 265 =item B<get_attribute_list>
 266
 267 =item B<get_attribute_map>
 268
 269 =item B<remove_attribute>
 270
 271 =back
 272
 273 =over 4
 274
 275 =item B<add_method_modifier>
 276
 277 =item B<get_method_modifier>
 278
 279 =item B<has_method_modifier>
 280
 281 =item B<get_method_modifier_list>
 282
 283 =item B<get_method_modifier_map>
 284
 285 =item B<remove_method_modifier>
 286
 287 =back
 288
 289 =head1 BUGS
 290
 291 All complex software has bugs lurking in it, and this module is no
 292 exception. If you find a bug please either email me, or add the bug
 293 to cpan-RT.
 294
 295 =head1 AUTHOR
 296
 297 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 298
 299 =head1 COPYRIGHT AND LICENSE
 300
 301 Copyright 2006 by Infinity Interactive, Inc.
 302
 303 L<http://www.iinteractive.com>
 304
 305 This library is free software; you can redistribute it and/or modify
 306 it under the same terms as Perl itself.
 307
 308 =cut