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 use B            'svref_2object';
  11
  12 use Moose::Meta::Class;
  13
  14 our $VERSION = '0.04';
  15
  16 use base 'Class::MOP::Module';
  17
  18 ## Attributes
  19
  20 ## roles
  21
  22 __PACKAGE__->meta->add_attribute('roles' => (
  23     reader  => 'get_roles',
  24     default => sub { [] }
  25 ));
  26
  27 ## excluded roles
  28
  29 __PACKAGE__->meta->add_attribute('excluded_roles_map' => (
  30     reader  => 'get_excluded_roles_map',
  31     default => sub { {} }
  32 ));
  33
  34 ## attributes
  35
  36 __PACKAGE__->meta->add_attribute('attribute_map' => (
  37     reader   => 'get_attribute_map',
  38     default  => sub { {} }
  39 ));
  40
  41 ## required methods
  42
  43 __PACKAGE__->meta->add_attribute('required_methods' => (
  44     reader  => 'get_required_methods_map',
  45     default => sub { {} }
  46 ));
  47
  48 ## method modifiers
  49
  50 __PACKAGE__->meta->add_attribute('before_method_modifiers' => (
  51     reader  => 'get_before_method_modifiers_map',
  52     default => sub { {} } # (<name> => [ (CODE) ])
  53 ));
  54
  55 __PACKAGE__->meta->add_attribute('after_method_modifiers' => (
  56     reader  => 'get_after_method_modifiers_map',
  57     default => sub { {} } # (<name> => [ (CODE) ])
  58 ));
  59
  60 __PACKAGE__->meta->add_attribute('around_method_modifiers' => (
  61     reader  => 'get_around_method_modifiers_map',
  62     default => sub { {} } # (<name> => [ (CODE) ])
  63 ));
  64
  65 __PACKAGE__->meta->add_attribute('override_method_modifiers' => (
  66     reader  => 'get_override_method_modifiers_map',
  67     default => sub { {} } # (<name> => CODE)
  68 ));
  69
  70 ## Methods
  71
  72 sub method_metaclass { 'Moose::Meta::Role::Method' }
  73
  74 ## subroles
  75
  76 sub add_role {
  77     my ($self, $role) = @_;
  78     (blessed($role) && $role->isa('Moose::Meta::Role'))
  79         || confess "Roles must be instances of Moose::Meta::Role";
  80     push @{$self->get_roles} => $role;
  81 }
  82
  83 sub calculate_all_roles {
  84     my $self = shift;
  85     my %seen;
  86     grep { !$seen{$_->name}++ } $self, map { $_->calculate_all_roles } @{ $self->get_roles };
  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 ## excluded roles
 103
 104 sub add_excluded_roles {
 105     my ($self, @excluded_role_names) = @_;
 106     $self->get_excluded_roles_map->{$_} = undef foreach @excluded_role_names;
 107 }
 108
 109 sub get_excluded_roles_list {
 110     my ($self) = @_;
 111     keys %{$self->get_excluded_roles_map};
 112 }
 113
 114 sub excludes_role {
 115     my ($self, $role_name) = @_;
 116     exists $self->get_excluded_roles_map->{$role_name} ? 1 : 0;
 117 }
 118
 119 ## required methods
 120
 121 sub add_required_methods {
 122     my ($self, @methods) = @_;
 123     $self->get_required_methods_map->{$_} = undef foreach @methods;
 124 }
 125
 126 sub remove_required_methods {
 127     my ($self, @methods) = @_;
 128     delete $self->get_required_methods_map->{$_} foreach @methods;
 129 }
 130
 131 sub get_required_method_list {
 132     my ($self) = @_;
 133     keys %{$self->get_required_methods_map};
 134 }
 135
 136 sub requires_method {
 137     my ($self, $method_name) = @_;
 138     exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
 139 }
 140
 141 sub _clean_up_required_methods {
 142     my $self = shift;
 143     foreach my $method ($self->get_required_method_list) {
 144         $self->remove_required_methods($method)
 145             if $self->has_method($method);
 146     }
 147 }
 148
 149 ## methods
 150
 151 sub get_method          { (shift)->Moose::Meta::Class::get_method(@_)          }
 152 sub find_method_by_name { (shift)->Moose::Meta::Class::find_method_by_name(@_) }
 153 sub has_method          { (shift)->Moose::Meta::Class::has_method(@_)          }
 154 sub alias_method        { (shift)->Moose::Meta::Class::alias_method(@_)        }
 155 sub get_method_list {
 156     my ($self) = @_;
 157     grep {
 158         # NOTE:
 159         # this is a kludge for now,... these functions
 160         # should not be showing up in the list at all,
 161         # but they do, so we need to switch Moose::Role
 162         # and Moose to use Sub::Exporter to prevent this
 163         !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/
 164     } $self->Moose::Meta::Class::get_method_list;
 165 }
 166
 167 # ... however the items in statis (attributes & method modifiers)
 168 # can be removed and added to through this API
 169
 170 # attributes
 171
 172 sub add_attribute {
 173     my $self = shift;
 174     my $name = shift;
 175     my $attr_desc;
 176     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
 177         $attr_desc = $_[0];
 178     }
 179     else {
 180         $attr_desc = { @_ };
 181     }
 182     $self->get_attribute_map->{$name} = $attr_desc;
 183 }
 184
 185 sub has_attribute {
 186     my ($self, $name) = @_;
 187     exists $self->get_attribute_map->{$name} ? 1 : 0;
 188 }
 189
 190 sub get_attribute {
 191     my ($self, $name) = @_;
 192     $self->get_attribute_map->{$name}
 193 }
 194
 195 sub remove_attribute {
 196     my ($self, $name) = @_;
 197     delete $self->get_attribute_map->{$name}
 198 }
 199
 200 sub get_attribute_list {
 201     my ($self) = @_;
 202     keys %{$self->get_attribute_map};
 203 }
 204
 205 # method modifiers
 206
 207 # mimic the metaclass API
 208 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
 209 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
 210 sub add_after_method_modifier  { (shift)->_add_method_modifier('after',  @_) }
 211
 212 sub _add_method_modifier {
 213     my ($self, $modifier_type, $method_name, $method) = @_;
 214     my $accessor = "get_${modifier_type}_method_modifiers_map";
 215     $self->$accessor->{$method_name} = []
 216         unless exists $self->$accessor->{$method_name};
 217     my $modifiers = $self->$accessor->{$method_name};
 218     # NOTE:
 219     # check to see that we aren't adding the
 220     # same code twice. We err in favor of the
 221     # first on here, this may not be as expected
 222     foreach my $modifier (@{$modifiers}) {
 223         return if $modifier == $method;
 224     }
 225     push @{$modifiers} => $method;
 226 }
 227
 228 sub add_override_method_modifier {
 229     my ($self, $method_name, $method) = @_;
 230     (!$self->has_method($method_name))
 231         || confess "Cannot add an override of method '$method_name' " .
 232                    "because there is a local version of '$method_name'";
 233     $self->get_override_method_modifiers_map->{$method_name} = $method;
 234 }
 235
 236 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
 237 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
 238 sub has_after_method_modifiers  { (shift)->_has_method_modifiers('after',  @_) }
 239
 240 # override just checks for one,..
 241 # but we can still re-use stuff
 242 sub has_override_method_modifier { (shift)->_has_method_modifiers('override',  @_) }
 243
 244 sub _has_method_modifiers {
 245     my ($self, $modifier_type, $method_name) = @_;
 246     my $accessor = "get_${modifier_type}_method_modifiers_map";
 247     # NOTE:
 248     # for now we assume that if it exists,..
 249     # it has at least one modifier in it
 250     (exists $self->$accessor->{$method_name}) ? 1 : 0;
 251 }
 252
 253 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
 254 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
 255 sub get_after_method_modifiers  { (shift)->_get_method_modifiers('after',  @_) }
 256
 257 sub _get_method_modifiers {
 258     my ($self, $modifier_type, $method_name) = @_;
 259     my $accessor = "get_${modifier_type}_method_modifiers_map";
 260     @{$self->$accessor->{$method_name}};
 261 }
 262
 263 sub get_override_method_modifier {
 264     my ($self, $method_name) = @_;
 265     $self->get_override_method_modifiers_map->{$method_name};
 266 }
 267
 268 sub get_method_modifier_list {
 269     my ($self, $modifier_type) = @_;
 270     my $accessor = "get_${modifier_type}_method_modifiers_map";
 271     keys %{$self->$accessor};
 272 }
 273
 274 ## applying a role to a class ...
 275
 276 sub _check_excluded_roles {
 277     my ($self, $other) = @_;
 278     if ($other->excludes_role($self->name)) {
 279         confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
 280     }
 281     foreach my $excluded_role_name ($self->get_excluded_roles_list) {
 282         if ($other->does_role($excluded_role_name)) {
 283             confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
 284         }
 285         else {
 286             if ($other->isa('Moose::Meta::Role')) {
 287                 $other->add_excluded_roles($excluded_role_name);
 288             }
 289             # else -> ignore it :)
 290         }
 291     }
 292 }
 293
 294 sub _check_required_methods {
 295     my ($self, $other) = @_;
 296     # NOTE:
 297     # we might need to move this down below the
 298     # the attributes so that we can require any
 299     # attribute accessors. However I am thinking
 300     # that maybe those are somehow exempt from
 301     # the require methods stuff.
 302     foreach my $required_method_name ($self->get_required_method_list) {
 303
 304         unless ($other->find_method_by_name($required_method_name)) {
 305             if ($other->isa('Moose::Meta::Role')) {
 306                 $other->add_required_methods($required_method_name);
 307             }
 308             else {
 309                 confess "'" . $self->name . "' requires the method '$required_method_name' " .
 310                         "to be implemented by '" . $other->name . "'";
 311             }
 312         }
 313         else {
 314             # NOTE:
 315             # we need to make sure that the method is
 316             # not a method modifier, because those do
 317             # not satisfy the requirements ...
 318             my $method = $other->get_method($required_method_name);
 319             # check if it is an override or a generated accessor ..
 320             (!$method->isa('Moose::Meta::Method::Overriden') &&
 321              !$method->isa('Class::MOP::Attribute::Accessor'))
 322                 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
 323                            "to be implemented by '" . $other->name . "', the method is only a method modifier";
 324             # before/after/around methods are a little trickier
 325             # since we wrap the original local method (if applicable)
 326             # so we need to check if the original wrapped method is
 327             # from the same package, and not a wrap of the super method
 328             if ($method->isa('Class::MOP::Method::Wrapped')) {
 329                 ($method->get_original_method->package_name eq $other->name)
 330                     || confess "'" . $self->name . "' requires the method '$required_method_name' " .
 331                                "to be implemented by '" . $other->name . "', the method is only a method modifier";
 332             }
 333         }
 334     }
 335 }
 336
 337 sub _apply_attributes {
 338     my ($self, $other) = @_;
 339     foreach my $attribute_name ($self->get_attribute_list) {
 340         # it if it has one already
 341         if ($other->has_attribute($attribute_name) &&
 342             # make sure we haven't seen this one already too
 343             $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
 344             # see if we are being composed
 345             # into a role or not
 346             if ($other->isa('Moose::Meta::Role')) {
 347                 # all attribute conflicts between roles
 348                 # result in an immediate fatal error
 349                 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
 350                         "during composition. This is fatal error and cannot be disambiguated.";
 351             }
 352             else {
 353                 # but if this is a class, we
 354                 # can safely skip adding the
 355                 # attribute to the class
 356                 next;
 357             }
 358         }
 359         else {
 360             $other->add_attribute(
 361                 $attribute_name,
 362                 $self->get_attribute($attribute_name)
 363             );
 364         }
 365     }
 366 }
 367
 368 sub _apply_methods {
 369     my ($self, $other) = @_;
 370     foreach my $method_name ($self->get_method_list) {
 371         # it if it has one already
 372         if ($other->has_method($method_name) &&
 373             # and if they are not the same thing ...
 374             $other->get_method($method_name) != $self->get_method($method_name)) {
 375             # see if we are composing into a role
 376             if ($other->isa('Moose::Meta::Role')) {
 377                 # method conflicts between roles result
 378                 # in the method becoming a requirement
 379                 $other->add_required_methods($method_name);
 380                 # NOTE:
 381                 # we have to remove the method from our
 382                 # role, if this is being called from combine()
 383                 # which means the meta is an anon class
 384                 # this *may* cause problems later, but it
 385                 # is probably fairly safe to assume that
 386                 # anon classes will only be used internally
 387                 # or by people who know what they are doing
 388                 $other->Moose::Meta::Class::remove_method($method_name)
 389                     if $other->name =~ /__ANON__/;
 390             }
 391             else {
 392                 next;
 393             }
 394         }
 395         else {
 396             # add it, although it could be overriden
 397             $other->alias_method(
 398                 $method_name,
 399                 $self->get_method($method_name)
 400             );
 401         }
 402     }
 403 }
 404
 405 sub _apply_override_method_modifiers {
 406     my ($self, $other) = @_;
 407     foreach my $method_name ($self->get_method_modifier_list('override')) {
 408         # it if it has one already then ...
 409         if ($other->has_method($method_name)) {
 410             # if it is being composed into another role
 411             # we have a conflict here, because you cannot
 412             # combine an overriden method with a locally
 413             # defined one
 414             if ($other->isa('Moose::Meta::Role')) {
 415                 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
 416                         "during composition (A local method of the same name as been found). This " .
 417                         "is fatal error.";
 418             }
 419             else {
 420                 # if it is a class, then we
 421                 # just ignore this here ...
 422                 next;
 423             }
 424         }
 425         else {
 426             # if no local method is found, then we
 427             # must check if we are a role or class
 428             if ($other->isa('Moose::Meta::Role')) {
 429                 # if we are a role, we need to make sure
 430                 # we dont have a conflict with the role
 431                 # we are composing into
 432                 if ($other->has_override_method_modifier($method_name) &&
 433                     $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
 434                     confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
 435                             "during composition (Two 'override' methods of the same name encountered). " .
 436                             "This is fatal error.";
 437                 }
 438                 else {
 439                     # if there is no conflict,
 440                     # just add it to the role
 441                     $other->add_override_method_modifier(
 442                         $method_name,
 443                         $self->get_override_method_modifier($method_name)
 444                     );
 445                 }
 446             }
 447             else {
 448                 # if this is not a role, then we need to
 449                 # find the original package of the method
 450                 # so that we can tell the class were to
 451                 # find the right super() method
 452                 my $method = $self->get_override_method_modifier($method_name);
 453                 my $package = svref_2object($method)->GV->STASH->NAME;
 454                 # if it is a class, we just add it
 455                 $other->add_override_method_modifier($method_name, $method, $package);
 456             }
 457         }
 458     }
 459 }
 460
 461 sub _apply_method_modifiers {
 462     my ($self, $modifier_type, $other) = @_;
 463     my $add = "add_${modifier_type}_method_modifier";
 464     my $get = "get_${modifier_type}_method_modifiers";
 465     foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
 466         $other->$add(
 467             $method_name,
 468             $_
 469         ) foreach $self->$get($method_name);
 470     }
 471 }
 472
 473 sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
 474 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
 475 sub _apply_after_method_modifiers  { (shift)->_apply_method_modifiers('after'  => @_) }
 476
 477 sub apply {
 478     my ($self, $other) = @_;
 479
 480     ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role'))
 481         || confess "You must apply a role to a metaclass, not ($other)";
 482
 483     $self->_check_excluded_roles($other);
 484     $self->_check_required_methods($other);
 485
 486     $self->_apply_attributes($other);
 487     $self->_apply_methods($other);
 488
 489     $self->_apply_override_method_modifiers($other);
 490     $self->_apply_before_method_modifiers($other);
 491     $self->_apply_around_method_modifiers($other);
 492     $self->_apply_after_method_modifiers($other);
 493
 494     $other->add_role($self);
 495 }
 496
 497 my $anon_counter = 0;
 498
 499 sub combine {
 500     my ($class, @roles) = @_;
 501
 502     my $pkg_name = __PACKAGE__ . "::__ANON__::" . $anon_counter++;
 503     eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
 504     die $@ if $@;
 505
 506     my $combined = $class->initialize($pkg_name);
 507
 508     foreach my $role (@roles) {
 509         $role->apply($combined);
 510     }
 511
 512     $combined->_clean_up_required_methods;
 513
 514     return $combined;
 515 }
 516
 517 package Moose::Meta::Role::Method;
 518
 519 use strict;
 520 use warnings;
 521
 522 our $VERSION = '0.01';
 523
 524 use base 'Class::MOP::Method';
 525
 526 1;
 527
 528 __END__
 529
 530 =pod
 531
 532 =head1 NAME
 533
 534 Moose::Meta::Role - The Moose Role metaclass
 535
 536 =head1 DESCRIPTION
 537
 538 Moose's Roles are being actively developed, please see L<Moose::Role>
 539 for more information. For the most part, this has no user-serviceable
 540 parts inside. It's API is still subject to some change (although
 541 probably not that much really).
 542
 543 =head1 METHODS
 544
 545 =over 4
 546
 547 =item B<meta>
 548
 549 =item B<new>
 550
 551 =item B<apply>
 552
 553 =item B<combine>
 554
 555 =back
 556
 557 =over 4
 558
 559 =item B<name>
 560
 561 =item B<version>
 562
 563 =item B<role_meta>
 564
 565 =back
 566
 567 =over 4
 568
 569 =item B<get_roles>
 570
 571 =item B<add_role>
 572
 573 =item B<does_role>
 574
 575 =back
 576
 577 =over 4
 578
 579 =item B<add_excluded_roles>
 580
 581 =item B<excludes_role>
 582
 583 =item B<get_excluded_roles_list>
 584
 585 =item B<get_excluded_roles_map>
 586
 587 =item B<calculate_all_roles>
 588
 589 =back
 590
 591 =over 4
 592
 593 =item B<method_metaclass>
 594
 595 =item B<find_method_by_name>
 596
 597 =item B<get_method>
 598
 599 =item B<has_method>
 600
 601 =item B<alias_method>
 602
 603 =item B<get_method_list>
 604
 605 =back
 606
 607 =over 4
 608
 609 =item B<add_attribute>
 610
 611 =item B<has_attribute>
 612
 613 =item B<get_attribute>
 614
 615 =item B<get_attribute_list>
 616
 617 =item B<get_attribute_map>
 618
 619 =item B<remove_attribute>
 620
 621 =back
 622
 623 =over 4
 624
 625 =item B<add_required_methods>
 626
 627 =item B<remove_required_methods>
 628
 629 =item B<get_required_method_list>
 630
 631 =item B<get_required_methods_map>
 632
 633 =item B<requires_method>
 634
 635 =back
 636
 637 =over 4
 638
 639 =item B<add_after_method_modifier>
 640
 641 =item B<add_around_method_modifier>
 642
 643 =item B<add_before_method_modifier>
 644
 645 =item B<add_override_method_modifier>
 646
 647 =over 4
 648
 649 =back
 650
 651 =item B<has_after_method_modifiers>
 652
 653 =item B<has_around_method_modifiers>
 654
 655 =item B<has_before_method_modifiers>
 656
 657 =item B<has_override_method_modifier>
 658
 659 =over 4
 660
 661 =back
 662
 663 =item B<get_after_method_modifiers>
 664
 665 =item B<get_around_method_modifiers>
 666
 667 =item B<get_before_method_modifiers>
 668
 669 =item B<get_method_modifier_list>
 670
 671 =over 4
 672
 673 =back
 674
 675 =item B<get_override_method_modifier>
 676
 677 =item B<get_after_method_modifiers_map>
 678
 679 =item B<get_around_method_modifiers_map>
 680
 681 =item B<get_before_method_modifiers_map>
 682
 683 =item B<get_override_method_modifiers_map>
 684
 685 =back
 686
 687 =head1 BUGS
 688
 689 All complex software has bugs lurking in it, and this module is no
 690 exception. If you find a bug please either email me, or add the bug
 691 to cpan-RT.
 692
 693 =head1 AUTHOR
 694
 695 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 696
 697 =head1 COPYRIGHT AND LICENSE
 698
 699 Copyright 2006 by Infinity Interactive, Inc.
 700
 701 L<http://www.iinteractive.com>
 702
 703 This library is free software; you can redistribute it and/or modify
 704 it under the same terms as Perl itself.
 705
 706 =cut