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.10';
  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
 415             # check if it is a generated accessor ...
 416             (!$method->isa('Class::MOP::Method::Accessor'))
 417                 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
 418                            "to be implemented by '" . $other->name . "', the method is only an attribute accessor";
 419
 420             # NOTE:
 421             # All other tests here have been removed, they were tests
 422             # for overriden methods and before/after/around modifiers.
 423             # But we realized that for classes any overriden or modified
 424             # methods would be backed by a real method of that name
 425             # (and therefore meet the requirement). And for roles, the
 426             # overriden and modified methods are "in statis" and so would
 427             # not show up in this test anyway (and as a side-effect they
 428             # would not fufill the requirement, which is exactly what we
 429             # want them to do anyway).
 430             # - SL
 431         }
 432     }
 433 }
 434
 435 sub _apply_attributes {
 436     my ($self, $other) = @_;
 437     foreach my $attribute_name ($self->get_attribute_list) {
 438         # it if it has one already
 439         if ($other->has_attribute($attribute_name) &&
 440             # make sure we haven't seen this one already too
 441             $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
 442             # see if we are being composed
 443             # into a role or not
 444             if ($other->isa('Moose::Meta::Role')) {
 445                 # all attribute conflicts between roles
 446                 # result in an immediate fatal error
 447                 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
 448                         "during composition. This is fatal error and cannot be disambiguated.";
 449             }
 450             else {
 451                 # but if this is a class, we
 452                 # can safely skip adding the
 453                 # attribute to the class
 454                 next;
 455             }
 456         }
 457         else {
 458             # NOTE:
 459             # this is kinda ugly ...
 460             if ($other->isa('Moose::Meta::Class')) {
 461                 $other->_process_attribute(
 462                     $attribute_name,
 463                     %{$self->get_attribute($attribute_name)}
 464                 );
 465             }
 466             else {
 467                 $other->add_attribute(
 468                     $attribute_name,
 469                     $self->get_attribute($attribute_name)
 470                 );
 471             }
 472         }
 473     }
 474 }
 475
 476 sub _apply_methods {
 477     my ($self, $other) = @_;
 478     foreach my $method_name ($self->get_method_list) {
 479         # it if it has one already
 480         if ($other->has_method($method_name) &&
 481             # and if they are not the same thing ...
 482             $other->get_method($method_name)->body != $self->get_method($method_name)->body) {
 483             # see if we are composing into a role
 484             if ($other->isa('Moose::Meta::Role')) {
 485                 # method conflicts between roles result
 486                 # in the method becoming a requirement
 487                 $other->add_required_methods($method_name);
 488                 # NOTE:
 489                 # we have to remove the method from our
 490                 # role, if this is being called from combine()
 491                 # which means the meta is an anon class
 492                 # this *may* cause problems later, but it
 493                 # is probably fairly safe to assume that
 494                 # anon classes will only be used internally
 495                 # or by people who know what they are doing
 496                 $other->Moose::Meta::Class::remove_method($method_name)
 497                     if $other->name =~ /__COMPOSITE_ROLE_SANDBOX__/;
 498             }
 499             else {
 500                 next;
 501             }
 502         }
 503         else {
 504             # add it, although it could be overriden
 505             $other->alias_method(
 506                 $method_name,
 507                 $self->get_method($method_name)
 508             );
 509         }
 510     }
 511 }
 512
 513 sub _apply_override_method_modifiers {
 514     my ($self, $other) = @_;
 515     foreach my $method_name ($self->get_method_modifier_list('override')) {
 516         # it if it has one already then ...
 517         if ($other->has_method($method_name)) {
 518             # if it is being composed into another role
 519             # we have a conflict here, because you cannot
 520             # combine an overriden method with a locally
 521             # defined one
 522             if ($other->isa('Moose::Meta::Role')) {
 523                 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
 524                         "during composition (A local method of the same name as been found). This " .
 525                         "is fatal error.";
 526             }
 527             else {
 528                 # if it is a class, then we
 529                 # just ignore this here ...
 530                 next;
 531             }
 532         }
 533         else {
 534             # if no local method is found, then we
 535             # must check if we are a role or class
 536             if ($other->isa('Moose::Meta::Role')) {
 537                 # if we are a role, we need to make sure
 538                 # we dont have a conflict with the role
 539                 # we are composing into
 540                 if ($other->has_override_method_modifier($method_name) &&
 541                     $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
 542                     confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
 543                             "during composition (Two 'override' methods of the same name encountered). " .
 544                             "This is fatal error.";
 545                 }
 546                 else {
 547                     # if there is no conflict,
 548                     # just add it to the role
 549                     $other->add_override_method_modifier(
 550                         $method_name,
 551                         $self->get_override_method_modifier($method_name)
 552                     );
 553                 }
 554             }
 555             else {
 556                 # if this is not a role, then we need to
 557                 # find the original package of the method
 558                 # so that we can tell the class were to
 559                 # find the right super() method
 560                 my $method = $self->get_override_method_modifier($method_name);
 561                 my $package = svref_2object($method)->GV->STASH->NAME;
 562                 # if it is a class, we just add it
 563                 $other->add_override_method_modifier($method_name, $method, $package);
 564             }
 565         }
 566     }
 567 }
 568
 569 sub _apply_method_modifiers {
 570     my ($self, $modifier_type, $other) = @_;
 571     my $add = "add_${modifier_type}_method_modifier";
 572     my $get = "get_${modifier_type}_method_modifiers";
 573     foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
 574         $other->$add(
 575             $method_name,
 576             $_
 577         ) foreach $self->$get($method_name);
 578     }
 579 }
 580
 581 sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
 582 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
 583 sub _apply_after_method_modifiers  { (shift)->_apply_method_modifiers('after'  => @_) }
 584
 585 1;
 586
 587 __END__
 588
 589 =pod
 590
 591 =head1 NAME
 592
 593 Moose::Meta::Role - The Moose Role metaclass
 594
 595 =head1 DESCRIPTION
 596
 597 Please see L<Moose::Role> for more information about roles.
 598 For the most part, this has no user-serviceable parts inside
 599 this module. It's API is still subject to some change (although
 600 probably not that much really).
 601
 602 =head1 METHODS
 603
 604 =over 4
 605
 606 =item B<meta>
 607
 608 =item B<new>
 609
 610 =item B<apply>
 611
 612 =item B<combine>
 613
 614 =back
 615
 616 =over 4
 617
 618 =item B<name>
 619
 620 =item B<version>
 621
 622 =item B<role_meta>
 623
 624 =back
 625
 626 =over 4
 627
 628 =item B<get_roles>
 629
 630 =item B<add_role>
 631
 632 =item B<does_role>
 633
 634 =back
 635
 636 =over 4
 637
 638 =item B<add_excluded_roles>
 639
 640 =item B<excludes_role>
 641
 642 =item B<get_excluded_roles_list>
 643
 644 =item B<get_excluded_roles_map>
 645
 646 =item B<calculate_all_roles>
 647
 648 =back
 649
 650 =over 4
 651
 652 =item B<method_metaclass>
 653
 654 =item B<find_method_by_name>
 655
 656 =item B<get_method>
 657
 658 =item B<has_method>
 659
 660 =item B<alias_method>
 661
 662 =item B<get_method_list>
 663
 664 =item B<get_method_map>
 665
 666 =back
 667
 668 =over 4
 669
 670 =item B<add_attribute>
 671
 672 =item B<has_attribute>
 673
 674 =item B<get_attribute>
 675
 676 =item B<get_attribute_list>
 677
 678 =item B<get_attribute_map>
 679
 680 =item B<remove_attribute>
 681
 682 =back
 683
 684 =over 4
 685
 686 =item B<add_required_methods>
 687
 688 =item B<remove_required_methods>
 689
 690 =item B<get_required_method_list>
 691
 692 =item B<get_required_methods_map>
 693
 694 =item B<requires_method>
 695
 696 =back
 697
 698 =over 4
 699
 700 =item B<add_after_method_modifier>
 701
 702 =item B<add_around_method_modifier>
 703
 704 =item B<add_before_method_modifier>
 705
 706 =item B<add_override_method_modifier>
 707
 708 =over 4
 709
 710 =back
 711
 712 =item B<has_after_method_modifiers>
 713
 714 =item B<has_around_method_modifiers>
 715
 716 =item B<has_before_method_modifiers>
 717
 718 =item B<has_override_method_modifier>
 719
 720 =over 4
 721
 722 =back
 723
 724 =item B<get_after_method_modifiers>
 725
 726 =item B<get_around_method_modifiers>
 727
 728 =item B<get_before_method_modifiers>
 729
 730 =item B<get_method_modifier_list>
 731
 732 =over 4
 733
 734 =back
 735
 736 =item B<get_override_method_modifier>
 737
 738 =item B<get_after_method_modifiers_map>
 739
 740 =item B<get_around_method_modifiers_map>
 741
 742 =item B<get_before_method_modifiers_map>
 743
 744 =item B<get_override_method_modifiers_map>
 745
 746 =back
 747
 748 =head1 BUGS
 749
 750 All complex software has bugs lurking in it, and this module is no
 751 exception. If you find a bug please either email me, or add the bug
 752 to cpan-RT.
 753
 754 =head1 AUTHOR
 755
 756 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 757
 758 =head1 COPYRIGHT AND LICENSE
 759
 760 Copyright 2006, 2007 by Infinity Interactive, Inc.
 761
 762 L<http://www.iinteractive.com>
 763
 764 This library is free software; you can redistribute it and/or modify
 765 it under the same terms as Perl itself.
 766
 767 =cut