lib/Moose/Meta/Role.pm

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