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 use Scalar::Util 'blessed';
  10
  11 use Moose::Meta::Class;
  12
  13 our $VERSION = '0.02';
  14
  15 ## Attributes
  16
  17 ## the meta for the role package
  18
  19 __PACKAGE__->meta->add_attribute('_role_meta' => (
  20     reader   => '_role_meta',
  21     init_arg => ':role_meta'
  22 ));
  23
  24 ## roles
  25
  26 __PACKAGE__->meta->add_attribute('roles' => (
  27     reader  => 'get_roles',
  28     default => sub { [] }
  29 ));
  30
  31 ## attributes
  32
  33 __PACKAGE__->meta->add_attribute('attribute_map' => (
  34     reader   => 'get_attribute_map',
  35     default  => sub { {} }
  36 ));
  37
  38 ## required methods
  39
  40 __PACKAGE__->meta->add_attribute('required_methods' => (
  41     reader  => 'get_required_methods_map',
  42     default => sub { {} }
  43 ));
  44
  45 ## method modifiers
  46
  47 __PACKAGE__->meta->add_attribute('before_method_modifiers' => (
  48     reader  => 'get_before_method_modifiers_map',
  49     default => sub { {} } # (<name> => [ (CODE) ])
  50 ));
  51
  52 __PACKAGE__->meta->add_attribute('after_method_modifiers' => (
  53     reader  => 'get_after_method_modifiers_map',
  54     default => sub { {} } # (<name> => [ (CODE) ])
  55 ));
  56
  57 __PACKAGE__->meta->add_attribute('around_method_modifiers' => (
  58     reader  => 'get_around_method_modifiers_map',
  59     default => sub { {} } # (<name> => [ (CODE) ])
  60 ));
  61
  62 __PACKAGE__->meta->add_attribute('override_method_modifiers' => (
  63     reader  => 'get_override_method_modifiers_map',
  64     default => sub { {} } # (<name> => CODE)
  65 ));
  66
  67 ## Methods
  68
  69 sub new {
  70     my $class   = shift;
  71     my %options = @_;
  72     $options{':role_meta'} = Moose::Meta::Class->initialize(
  73         $options{role_name},
  74         ':method_metaclass' => 'Moose::Meta::Role::Method'
  75     );
  76     my $self = $class->meta->new_object(%options);
  77     return $self;
  78 }
  79
  80 ## subroles
  81
  82 sub add_role {
  83     my ($self, $role) = @_;
  84     (blessed($role) && $role->isa('Moose::Meta::Role'))
  85         || confess "Roles must be instances of Moose::Meta::Role";
  86     push @{$self->get_roles} => $role;
  87 }
  88
  89 sub does_role {
  90     my ($self, $role_name) = @_;
  91     (defined $role_name)
  92         || confess "You must supply a role name to look for";
  93     # if we are it,.. then return true
  94     return 1 if $role_name eq $self->name;
  95     # otherwise.. check our children
  96     foreach my $role (@{$self->get_roles}) {
  97         return 1 if $role->does_role($role_name);
  98     }
  99     return 0;
 100 }
 101
 102 ## required methods
 103
 104 sub add_required_methods {
 105     my ($self, @methods) = @_;
 106     $self->get_required_methods_map->{$_} = undef foreach @methods;
 107 }
 108
 109 sub get_required_method_list {
 110     my ($self) = @_;
 111     keys %{$self->get_required_methods_map};
 112 }
 113
 114 sub requires_method {
 115     my ($self, $method_name) = @_;
 116     exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
 117 }
 118
 119 ## methods
 120
 121 # NOTE:
 122 # we delegate to some role_meta methods for convience here
 123 # the Moose::Meta::Role is meant to be a read-only interface
 124 # to the underlying role package, if you want to manipulate
 125 # that, just use ->role_meta
 126
 127 sub name    { (shift)->_role_meta->name    }
 128 sub version { (shift)->_role_meta->version }
 129
 130 sub get_method      { (shift)->_role_meta->get_method(@_)   }
 131 sub has_method      { (shift)->_role_meta->has_method(@_)   }
 132 sub alias_method    { (shift)->_role_meta->alias_method(@_) }
 133 sub get_method_list {
 134     my ($self) = @_;
 135     grep {
 136         # NOTE:
 137         # this is a kludge for now,... these functions
 138         # should not be showing up in the list at all,
 139         # but they do, so we need to switch Moose::Role
 140         # and Moose to use Sub::Exporter to prevent this
 141         !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/
 142     } $self->_role_meta->get_method_list;
 143 }
 144
 145 # ... however the items in statis (attributes & method modifiers)
 146 # can be removed and added to through this API
 147
 148 # attributes
 149
 150 sub add_attribute {
 151     my ($self, $name, %attr_desc) = @_;
 152     $self->get_attribute_map->{$name} = \%attr_desc;
 153 }
 154
 155 sub has_attribute {
 156     my ($self, $name) = @_;
 157     exists $self->get_attribute_map->{$name} ? 1 : 0;
 158 }
 159
 160 sub get_attribute {
 161     my ($self, $name) = @_;
 162     $self->get_attribute_map->{$name}
 163 }
 164
 165 sub remove_attribute {
 166     my ($self, $name) = @_;
 167     delete $self->get_attribute_map->{$name}
 168 }
 169
 170 sub get_attribute_list {
 171     my ($self) = @_;
 172     keys %{$self->get_attribute_map};
 173 }
 174
 175 # method modifiers
 176
 177 # mimic the metaclass API
 178 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
 179 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
 180 sub add_after_method_modifier  { (shift)->_add_method_modifier('after',  @_) }
 181
 182 sub _add_method_modifier {
 183     my ($self, $modifier_type, $method_name, $method) = @_;
 184     my $accessor = "get_${modifier_type}_method_modifiers_map";
 185     $self->$accessor->{$method_name} = []
 186         unless exists $self->$accessor->{$method_name};
 187     push @{$self->$accessor->{$method_name}} => $method;
 188 }
 189
 190 sub add_override_method_modifier {
 191     my ($self, $method_name, $method) = @_;
 192     $self->get_override_method_modifiers_map->{$method_name} = $method;
 193 }
 194
 195 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
 196 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
 197 sub has_after_method_modifiers  { (shift)->_has_method_modifiers('after',  @_) }
 198
 199 # override just checks for one,..
 200 # but we can still re-use stuff
 201 sub has_override_method_modifier { (shift)->_has_method_modifiers('override',  @_) }
 202
 203 sub _has_method_modifiers {
 204     my ($self, $modifier_type, $method_name) = @_;
 205     my $accessor = "get_${modifier_type}_method_modifiers_map";
 206     # NOTE:
 207     # for now we assume that if it exists,..
 208     # it has at least one modifier in it
 209     (exists $self->$accessor->{$method_name}) ? 1 : 0;
 210 }
 211
 212 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
 213 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
 214 sub get_after_method_modifiers  { (shift)->_get_method_modifiers('after',  @_) }
 215
 216 sub _get_method_modifiers {
 217     my ($self, $modifier_type, $method_name) = @_;
 218     my $accessor = "get_${modifier_type}_method_modifiers_map";
 219     @{$self->$accessor->{$method_name}};
 220 }
 221
 222 sub get_override_method_modifier {
 223     my ($self, $method_name) = @_;
 224     $self->get_override_method_modifiers_map->{$method_name};
 225 }
 226
 227 sub get_method_modifier_list {
 228     my ($self, $modifier_type) = @_;
 229     my $accessor = "get_${modifier_type}_method_modifiers_map";
 230     keys %{$self->$accessor};
 231 }
 232
 233 ## applying a role to a class ...
 234
 235 sub apply {
 236     my ($self, $other) = @_;
 237
 238     # NOTE:
 239     # we might need to move this down below the
 240     # the attributes so that we can require any
 241     # attribute accessors. However I am thinking
 242     # that maybe those are somehow exempt from
 243     # the require methods stuff.
 244     foreach my $required_method_name ($self->get_required_method_list) {
 245         unless ($other->has_method($required_method_name)) {
 246             if ($other->isa('Moose::Meta::Role')) {
 247                 $other->add_required_methods($required_method_name);
 248             }
 249             else {
 250                 confess "'" . $self->name . "' requires the method '$required_method_name' " .
 251                         "to be implemented by '" . $other->name . "'";
 252             }
 253         }
 254     }
 255
 256     foreach my $attribute_name ($self->get_attribute_list) {
 257         # skip it if it has one already
 258         next if $other->has_attribute($attribute_name);
 259         # add it, although it could be overriden
 260         $other->add_attribute(
 261             $attribute_name,
 262             %{$self->get_attribute($attribute_name)}
 263         );
 264     }
 265
 266     foreach my $method_name ($self->get_method_list) {
 267         # skip it if it has one already
 268         next if $other->has_method($method_name);
 269         # add it, although it could be overriden
 270         $other->alias_method(
 271             $method_name,
 272             $self->get_method($method_name)
 273         );
 274     }
 275
 276     foreach my $method_name ($self->get_method_modifier_list('override')) {
 277         # skip it if it has one already
 278         next if $other->has_method($method_name);
 279         # add it, although it could be overriden
 280         $other->add_override_method_modifier(
 281             $method_name,
 282             $self->get_override_method_modifier($method_name),
 283             $self->name
 284         );
 285     }
 286
 287     foreach my $method_name ($self->get_method_modifier_list('before')) {
 288         $other->add_before_method_modifier(
 289             $method_name,
 290             $_
 291         ) foreach $self->get_before_method_modifiers($method_name);
 292     }
 293
 294     foreach my $method_name ($self->get_method_modifier_list('after')) {
 295         $other->add_after_method_modifier(
 296             $method_name,
 297             $_
 298         ) foreach $self->get_after_method_modifiers($method_name);
 299     }
 300
 301     foreach my $method_name ($self->get_method_modifier_list('around')) {
 302         $other->add_around_method_modifier(
 303             $method_name,
 304             $_
 305         ) foreach $self->get_around_method_modifiers($method_name);
 306     }
 307
 308     $other->add_role($self);
 309 }
 310
 311 package Moose::Meta::Role::Method;
 312
 313 use strict;
 314 use warnings;
 315
 316 our $VERSION = '0.01';
 317
 318 use base 'Class::MOP::Method';
 319
 320 1;
 321
 322 __END__
 323
 324 =pod
 325
 326 =head1 NAME
 327
 328 Moose::Meta::Role - The Moose Role metaclass
 329
 330 =head1 DESCRIPTION
 331
 332 Moose's Roles are being actively developed, please see L<Moose::Role>
 333 for more information. For the most part, this has no user-serviceable
 334 parts inside. It's API is still subject to some change (although
 335 probably not that much really).
 336
 337 =head1 METHODS
 338
 339 =over 4
 340
 341 =item B<meta>
 342
 343 =item B<new>
 344
 345 =item B<apply>
 346
 347 =back
 348
 349 =over 4
 350
 351 =item B<name>
 352
 353 =item B<version>
 354
 355 =item B<role_meta>
 356
 357 =back
 358
 359 =over 4
 360
 361 =item B<get_roles>
 362
 363 =item B<add_role>
 364
 365 =item B<does_role>
 366
 367 =back
 368
 369 =over 4
 370
 371 =item B<get_method>
 372
 373 =item B<has_method>
 374
 375 =item B<alias_method>
 376
 377 =item B<get_method_list>
 378
 379 =back
 380
 381 =over 4
 382
 383 =item B<add_attribute>
 384
 385 =item B<has_attribute>
 386
 387 =item B<get_attribute>
 388
 389 =item B<get_attribute_list>
 390
 391 =item B<get_attribute_map>
 392
 393 =item B<remove_attribute>
 394
 395 =back
 396
 397 =over 4
 398
 399 =item B<add_required_methods>
 400
 401 =item B<get_required_method_list>
 402
 403 =item B<get_required_methods_map>
 404
 405 =item B<requires_method>
 406
 407 =back
 408
 409 =over 4
 410
 411 =item B<add_after_method_modifier>
 412
 413 =item B<add_around_method_modifier>
 414
 415 =item B<add_before_method_modifier>
 416
 417 =item B<add_override_method_modifier>
 418
 419 =over 4
 420
 421 =back
 422
 423 =item B<has_after_method_modifiers>
 424
 425 =item B<has_around_method_modifiers>
 426
 427 =item B<has_before_method_modifiers>
 428
 429 =item B<has_override_method_modifier>
 430
 431 =over 4
 432
 433 =back
 434
 435 =item B<get_after_method_modifiers>
 436
 437 =item B<get_around_method_modifiers>
 438
 439 =item B<get_before_method_modifiers>
 440
 441 =item B<get_method_modifier_list>
 442
 443 =over 4
 444
 445 =back
 446
 447 =item B<get_override_method_modifier>
 448
 449 =item B<get_after_method_modifiers_map>
 450
 451 =item B<get_around_method_modifiers_map>
 452
 453 =item B<get_before_method_modifiers_map>
 454
 455 =item B<get_override_method_modifiers_map>
 456
 457 =back
 458
 459 =head1 BUGS
 460
 461 All complex software has bugs lurking in it, and this module is no
 462 exception. If you find a bug please either email me, or add the bug
 463 to cpan-RT.
 464
 465 =head1 AUTHOR
 466
 467 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 468
 469 =head1 COPYRIGHT AND LICENSE
 470
 471 Copyright 2006 by Infinity Interactive, Inc.
 472
 473 L<http://www.iinteractive.com>
 474
 475 This library is free software; you can redistribute it and/or modify
 476 it under the same terms as Perl itself.
 477
 478 =cut