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