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