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