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