lib/Moose/Meta/Class.pm

   1
   2 package Moose::Meta::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP;
   8
   9 use Carp         'confess';
  10 use Scalar::Util 'weaken', 'blessed', 'reftype';
  11
  12 our $VERSION   = '0.21';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Meta::Method::Overriden;
  16
  17 use base 'Class::MOP::Class';
  18
  19 __PACKAGE__->meta->add_attribute('roles' => (
  20     reader  => 'roles',
  21     default => sub { [] }
  22 ));
  23
  24 sub initialize {
  25     my $class = shift;
  26     my $pkg   = shift;
  27     $class->SUPER::initialize($pkg,
  28         'attribute_metaclass' => 'Moose::Meta::Attribute',
  29         'method_metaclass'    => 'Moose::Meta::Method',
  30         'instance_metaclass'  => 'Moose::Meta::Instance',
  31         @_);
  32 }
  33
  34 sub create {
  35     my ($self, $package_name, %options) = @_;
  36
  37     (ref $options{roles} eq 'ARRAY')
  38         || confess "You must pass an ARRAY ref of roles"
  39             if exists $options{roles};
  40
  41     my $class = $self->SUPER::create($package_name, %options);
  42
  43     if (exists $options{roles}) {
  44         Moose::Util::apply_all_roles($class, @{$options{roles}});
  45     }
  46
  47     return $class;
  48 }
  49
  50 my %ANON_CLASSES;
  51
  52 sub create_anon_class {
  53     my ($self, %options) = @_;
  54
  55     my $cache_ok = delete $options{cache};
  56
  57     my @superclasses = sort @{$options{superclasses} || []};
  58     my @roles        = sort @{$options{roles}        || []};
  59
  60     # something like Super::Class|Super::Class::2=Role|Role::1
  61     my $cache_key = join '=' => (
  62         join('|', @superclasses),
  63         join('|', @roles),
  64     );
  65
  66     if($cache_ok && defined $ANON_CLASSES{$cache_key}){
  67         return $ANON_CLASSES{$cache_key};
  68     }
  69
  70     my $new_class = $self->SUPER::create_anon_class(%options);
  71
  72     if($cache_ok){
  73         $ANON_CLASSES{$cache_key} = $new_class;
  74     }
  75
  76     return $new_class;
  77 }
  78
  79 sub add_role {
  80     my ($self, $role) = @_;
  81     (blessed($role) && $role->isa('Moose::Meta::Role'))
  82         || confess "Roles must be instances of Moose::Meta::Role";
  83     push @{$self->roles} => $role;
  84 }
  85
  86 sub calculate_all_roles {
  87     my $self = shift;
  88     my %seen;
  89     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
  90 }
  91
  92 sub does_role {
  93     my ($self, $role_name) = @_;
  94     (defined $role_name)
  95         || confess "You must supply a role name to look for";
  96     foreach my $class ($self->class_precedence_list) {
  97         next unless $class->can('meta');
  98         foreach my $role (@{$class->meta->roles}) {
  99             return 1 if $role->does_role($role_name);
 100         }
 101     }
 102     return 0;
 103 }
 104
 105 sub excludes_role {
 106     my ($self, $role_name) = @_;
 107     (defined $role_name)
 108         || confess "You must supply a role name to look for";
 109     foreach my $class ($self->class_precedence_list) {
 110         next unless $class->can('meta');
 111         # NOTE:
 112         # in the pretty rare instance when a Moose metaclass
 113         # is itself extended with a role, this check needs to
 114         # be done since some items in the class_precedence_list
 115         # might in fact be Class::MOP based still.
 116         next unless $class->meta->can('roles');
 117         foreach my $role (@{$class->meta->roles}) {
 118             return 1 if $role->excludes_role($role_name);
 119         }
 120     }
 121     return 0;
 122 }
 123
 124 sub new_object {
 125     my ($class, %params) = @_;
 126     my $self = $class->SUPER::new_object(%params);
 127     foreach my $attr ($class->compute_all_applicable_attributes()) {
 128         if ( defined( my $init_arg = $attr->init_arg ) ) {
 129             if ( exists($params{$init_arg}) && $attr->can('has_trigger') && $attr->has_trigger ) {
 130                 $attr->trigger->($self, $params{$init_arg}, $attr);
 131             }
 132         }
 133     }
 134     return $self;
 135 }
 136
 137 sub construct_instance {
 138     my ($class, %params) = @_;
 139     my $meta_instance = $class->get_meta_instance;
 140     # FIXME:
 141     # the code below is almost certainly incorrect
 142     # but this is foreign inheritence, so we might
 143     # have to kludge it in the end.
 144     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
 145     foreach my $attr ($class->compute_all_applicable_attributes()) {
 146         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
 147     }
 148     return $instance;
 149 }
 150
 151 # FIXME:
 152 # This is ugly
 153 sub get_method_map {
 154     my $self = shift;
 155
 156     if (defined $self->{'$!_package_cache_flag'} &&
 157                 $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->meta->name)) {
 158         return $self->{'%!methods'};
 159     }
 160
 161     my $map  = $self->{'%!methods'};
 162
 163     my $class_name       = $self->name;
 164     my $method_metaclass = $self->method_metaclass;
 165
 166     foreach my $symbol ($self->list_all_package_symbols('CODE')) {
 167
 168         my $code = $self->get_package_symbol('&' . $symbol);
 169
 170         next if exists  $map->{$symbol} &&
 171                 defined $map->{$symbol} &&
 172                         $map->{$symbol}->body == $code;
 173
 174         my ($pkg, $name) = Class::MOP::get_code_info($code);
 175
 176         if ($pkg->can('meta')
 177             # NOTE:
 178             # we don't know what ->meta we are calling
 179             # here, so we need to be careful cause it
 180             # just might blow up at us, or just complain
 181             # loudly (in the case of Curses.pm) so we
 182             # just be a little overly cautious here.
 183             # - SL
 184             && eval { no warnings; blessed($pkg->meta) }
 185             && $pkg->meta->isa('Moose::Meta::Role')) {
 186             #my $role = $pkg->meta->name;
 187             #next unless $self->does_role($role);
 188         }
 189         else {
 190             next if ($pkg  || '') ne $class_name &&
 191                     ($name || '') ne '__ANON__';
 192
 193         }
 194
 195         $map->{$symbol} = $method_metaclass->wrap($code);
 196     }
 197
 198     return $map;
 199 }
 200
 201 ### ---------------------------------------------
 202
 203 sub add_attribute {
 204     my $self = shift;
 205     $self->SUPER::add_attribute(
 206         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 207             ? $_[0]
 208             : $self->_process_attribute(@_))
 209     );
 210 }
 211
 212 sub add_override_method_modifier {
 213     my ($self, $name, $method, $_super_package) = @_;
 214     (!$self->has_method($name))
 215         || confess "Cannot add an override method if a local method is already present";
 216     # need this for roles ...
 217     $_super_package ||= $self->name;
 218     my $super = $self->find_next_method_by_name($name);
 219     (defined $super)
 220         || confess "You cannot override '$name' because it has no super method";
 221     $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
 222         my @args = @_;
 223         no warnings 'redefine';
 224         if ($Moose::SUPER_SLOT{$_super_package}) {
 225             local *{$Moose::SUPER_SLOT{$_super_package}} = sub { $super->body->(@args) };
 226             return $method->(@args);
 227         } else {
 228             confess "Trying to call override modifier'd method without super()";
 229         }
 230     }));
 231 }
 232
 233 sub add_augment_method_modifier {
 234     my ($self, $name, $method) = @_;
 235     (!$self->has_method($name))
 236         || confess "Cannot add an augment method if a local method is already present";
 237     my $super = $self->find_next_method_by_name($name);
 238     (defined $super)
 239         || confess "You cannot augment '$name' because it has no super method";
 240     my $_super_package = $super->package_name;
 241     # BUT!,... if this is an overriden method ....
 242     if ($super->isa('Moose::Meta::Method::Overriden')) {
 243         # we need to be sure that we actually
 244         # find the next method, which is not
 245         # an 'override' method, the reason is
 246         # that an 'override' method will not
 247         # be the one calling inner()
 248         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 249         $_super_package = $real_super->package_name;
 250     }
 251     $self->add_method($name => sub {
 252         my @args = @_;
 253         no warnings 'redefine';
 254         if ($Moose::INNER_SLOT{$_super_package}) {
 255             local *{$Moose::INNER_SLOT{$_super_package}} = sub {
 256                 local *{$Moose::INNER_SLOT{$_super_package}} = sub {};
 257                 $method->(@args);
 258             };
 259             return $super->body->(@args);
 260         }
 261         else {
 262             return $super->body->(@args);
 263         }
 264     });
 265 }
 266
 267 ## Private Utility methods ...
 268
 269 sub _find_next_method_by_name_which_is_not_overridden {
 270     my ($self, $name) = @_;
 271     foreach my $method ($self->find_all_methods_by_name($name)) {
 272         return $method->{code}
 273             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 274     }
 275     return undef;
 276 }
 277
 278 sub _fix_metaclass_incompatability {
 279     my ($self, @superclasses) = @_;
 280     foreach my $super (@superclasses) {
 281         # don't bother if it does not have a meta.
 282         next unless $super->can('meta');
 283         # get the name, make sure we take
 284         # immutable classes into account
 285         my $super_meta_name = ($super->meta->is_immutable
 286                                 ? $super->meta->get_mutable_metaclass_name
 287                                 : blessed($super->meta));
 288         # if it's meta is a vanilla Moose,
 289         # then we can safely ignore it.
 290         next if $super_meta_name eq 'Moose::Meta::Class';
 291         # but if we have anything else,
 292         # we need to check it out ...
 293         unless (# see if of our metaclass is incompatible
 294                 ($self->isa($super_meta_name) &&
 295                  # and see if our instance metaclass is incompatible
 296                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 297                 # ... and if we are just a vanilla Moose
 298                 $self->isa('Moose::Meta::Class')) {
 299             # re-initialize the meta ...
 300             my $super_meta = $super->meta;
 301             # NOTE:
 302             # We might want to consider actually
 303             # transfering any attributes from the
 304             # original meta into this one, but in
 305             # general you should not have any there
 306             # at this point anyway, so it's very
 307             # much an obscure edge case anyway
 308             $self = $super_meta->reinitialize($self->name => (
 309                 'attribute_metaclass' => $super_meta->attribute_metaclass,
 310                 'method_metaclass'    => $super_meta->method_metaclass,
 311                 'instance_metaclass'  => $super_meta->instance_metaclass,
 312             ));
 313         }
 314     }
 315     return $self;
 316 }
 317
 318 # NOTE:
 319 # this was crap anyway, see
 320 # Moose::Util::apply_all_roles
 321 # instead
 322 sub _apply_all_roles {
 323     die 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
 324 }
 325
 326 sub _process_attribute {
 327     my $self    = shift;
 328     my $name    = shift;
 329     my %options = ((scalar @_ == 1 && ref($_[0]) eq 'HASH') ? %{$_[0]} : @_);
 330
 331     if ($name =~ /^\+(.*)/) {
 332         return $self->_process_inherited_attribute($1, %options);
 333     }
 334     else {
 335         my $attr_metaclass_name;
 336         if ($options{metaclass}) {
 337             my $metaclass_name = $options{metaclass};
 338             eval {
 339                 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
 340                 Class::MOP::load_class($possible_full_name);
 341                 $metaclass_name = $possible_full_name->can('register_implementation')
 342                     ? $possible_full_name->register_implementation
 343                     : $possible_full_name;
 344             };
 345             if ($@) {
 346                 Class::MOP::load_class($metaclass_name);
 347             }
 348             $attr_metaclass_name = $metaclass_name;
 349         }
 350         else {
 351             $attr_metaclass_name = $self->attribute_metaclass;
 352         }
 353
 354         if ($options{traits}) {
 355             my @traits;
 356             foreach my $trait (@{$options{traits}}) {
 357                 eval {
 358                     my $possible_full_name = 'Moose::Meta::Attribute::Custom::Trait::' . $trait;
 359                     Class::MOP::load_class($possible_full_name);
 360                     push @traits => $possible_full_name->can('register_implementation')
 361                       ? $possible_full_name->register_implementation
 362                         : $possible_full_name;
 363                 };
 364                 if ($@) {
 365                     push @traits => $trait;
 366                 }
 367             }
 368
 369             my $class = Moose::Meta::Class->create_anon_class(
 370                 superclasses => [ $attr_metaclass_name ],
 371                 roles        => [ @traits ],
 372                 cache        => 1,
 373             );
 374
 375             $attr_metaclass_name = $class->name;
 376         }
 377
 378         return $attr_metaclass_name->new($name, %options);
 379     }
 380 }
 381
 382 sub _process_inherited_attribute {
 383     my ($self, $attr_name, %options) = @_;
 384     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 385     (defined $inherited_attr)
 386         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 387     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 388         return $inherited_attr->clone_and_inherit_options(%options);
 389     }
 390     else {
 391         # NOTE:
 392         # kind of a kludge to handle Class::MOP::Attributes
 393         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 394     }
 395 }
 396
 397 ## -------------------------------------------------
 398
 399 use Moose::Meta::Method::Constructor;
 400 use Moose::Meta::Method::Destructor;
 401
 402 # This could be done by using SUPER and altering ->options
 403 # I am keeping it this way to make it more explicit.
 404 sub create_immutable_transformer {
 405     my $self = shift;
 406     my $class = Class::MOP::Immutable->new($self, {
 407        read_only   => [qw/superclasses/],
 408        cannot_call => [qw/
 409            add_method
 410            alias_method
 411            remove_method
 412            add_attribute
 413            remove_attribute
 414            add_package_symbol
 415            remove_package_symbol
 416            add_role
 417        /],
 418        memoize     => {
 419            class_precedence_list             => 'ARRAY',
 420            compute_all_applicable_attributes => 'ARRAY',
 421            get_meta_instance                 => 'SCALAR',
 422            get_method_map                    => 'SCALAR',
 423            # maybe ....
 424            calculate_all_roles               => 'ARRAY',
 425        }
 426     });
 427     return $class;
 428 }
 429
 430 sub make_immutable {
 431     my $self = shift;
 432     $self->SUPER::make_immutable
 433       (
 434        constructor_class => 'Moose::Meta::Method::Constructor',
 435        destructor_class  => 'Moose::Meta::Method::Destructor',
 436        inline_destructor => 1,
 437        # NOTE:
 438        # no need to do this,
 439        # Moose always does it
 440        inline_accessors  => 0,
 441        @_,
 442       );
 443 }
 444
 445 1;
 446
 447 __END__
 448
 449 =pod
 450
 451 =head1 NAME
 452
 453 Moose::Meta::Class - The Moose metaclass
 454
 455 =head1 DESCRIPTION
 456
 457 This is a subclass of L<Class::MOP::Class> with Moose specific
 458 extensions.
 459
 460 For the most part, the only time you will ever encounter an
 461 instance of this class is if you are doing some serious deep
 462 introspection. To really understand this class, you need to refer
 463 to the L<Class::MOP::Class> documentation.
 464
 465 =head1 METHODS
 466
 467 =over 4
 468
 469 =item B<initialize>
 470
 471 =item B<create>
 472
 473 Overrides original to accept a list of roles to apply to
 474 the created class.
 475
 476    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 477
 478 =item B<create_anon_class>
 479
 480 Overrides original to support roles and caching.
 481
 482    my $metaclass = Moose::Meta::Class->create_anon_class(
 483        superclasses => ['Foo'],
 484        roles        => [qw/Some Roles Go Here/],
 485        cache        => 1,
 486    );
 487
 488 =item B<make_immutable>
 489
 490 Override original to add default options for inlining destructor
 491 and altering the Constructor metaclass.
 492
 493 =item B<create_immutable_transformer>
 494
 495 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 496
 497 =item B<new_object>
 498
 499 We override this method to support the C<trigger> attribute option.
 500
 501 =item B<construct_instance>
 502
 503 This provides some Moose specific extensions to this method, you
 504 almost never call this method directly unless you really know what
 505 you are doing.
 506
 507 This method makes sure to handle the moose weak-ref, type-constraint
 508 and type coercion features.
 509
 510 =item B<get_method_map>
 511
 512 This accommodates Moose::Meta::Role::Method instances, which are
 513 aliased, instead of added, but still need to be counted as valid
 514 methods.
 515
 516 =item B<add_override_method_modifier ($name, $method)>
 517
 518 This will create an C<override> method modifier for you, and install
 519 it in the package.
 520
 521 =item B<add_augment_method_modifier ($name, $method)>
 522
 523 This will create an C<augment> method modifier for you, and install
 524 it in the package.
 525
 526 =item B<calculate_all_roles>
 527
 528 =item B<roles>
 529
 530 This will return an array of C<Moose::Meta::Role> instances which are
 531 attached to this class.
 532
 533 =item B<add_role ($role)>
 534
 535 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 536 to the list of associated roles.
 537
 538 =item B<does_role ($role_name)>
 539
 540 This will test if this class C<does> a given C<$role_name>. It will
 541 not only check it's local roles, but ask them as well in order to
 542 cascade down the role hierarchy.
 543
 544 =item B<excludes_role ($role_name)>
 545
 546 This will test if this class C<excludes> a given C<$role_name>. It will
 547 not only check it's local roles, but ask them as well in order to
 548 cascade down the role hierarchy.
 549
 550 =item B<add_attribute ($attr_name, %params|$params)>
 551
 552 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 553 support for taking the C<$params> as a HASH ref.
 554
 555 =back
 556
 557 =head1 BUGS
 558
 559 All complex software has bugs lurking in it, and this module is no
 560 exception. If you find a bug please either email me, or add the bug
 561 to cpan-RT.
 562
 563 =head1 AUTHOR
 564
 565 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 566
 567 =head1 COPYRIGHT AND LICENSE
 568
 569 Copyright 2006-2008 by Infinity Interactive, Inc.
 570
 571 L<http://www.iinteractive.com>
 572
 573 This library is free software; you can redistribute it and/or modify
 574 it under the same terms as Perl itself.
 575
 576 =cut
 577