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.17';
  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     my $name = shift;
 162     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
 163         # NOTE:
 164         # if it is a HASH ref, we de-ref it.
 165         # this will usually mean that it is
 166         # coming from a role
 167         $self->SUPER::add_attribute($self->_process_attribute($name => %{$_[0]}));
 168     }
 169     else {
 170         # otherwise we just pass the args
 171         $self->SUPER::add_attribute($self->_process_attribute($name => @_));
 172     }
 173 }
 174
 175 sub add_override_method_modifier {
 176     my ($self, $name, $method, $_super_package) = @_;
 177     (!$self->has_method($name))
 178         || confess "Cannot add an override method if a local method is already present";
 179     # need this for roles ...
 180     $_super_package ||= $self->name;
 181     my $super = $self->find_next_method_by_name($name);
 182     (defined $super)
 183         || confess "You cannot override '$name' because it has no super method";
 184     $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
 185         my @args = @_;
 186         no warnings 'redefine';
 187         if ($Moose::SUPER_SLOT{$_super_package}) {
 188             local *{$Moose::SUPER_SLOT{$_super_package}} = sub { $super->body->(@args) };
 189             return $method->(@args);
 190         } else {
 191             confess "Trying to call override modifier'd method without super()";
 192         }
 193     }));
 194 }
 195
 196 sub add_augment_method_modifier {
 197     my ($self, $name, $method) = @_;
 198     (!$self->has_method($name))
 199         || confess "Cannot add an augment method if a local method is already present";
 200     my $super = $self->find_next_method_by_name($name);
 201     (defined $super)
 202         || confess "You cannot augment '$name' because it has no super method";
 203     my $_super_package = $super->package_name;
 204     # BUT!,... if this is an overriden method ....
 205     if ($super->isa('Moose::Meta::Method::Overriden')) {
 206         # we need to be sure that we actually
 207         # find the next method, which is not
 208         # an 'override' method, the reason is
 209         # that an 'override' method will not
 210         # be the one calling inner()
 211         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 212         $_super_package = $real_super->package_name;
 213     }
 214     $self->add_method($name => sub {
 215         my @args = @_;
 216         no warnings 'redefine';
 217         if ($Moose::INNER_SLOT{$_super_package}) {
 218             local *{$Moose::INNER_SLOT{$_super_package}} = sub {
 219                 local *{$Moose::INNER_SLOT{$_super_package}} = sub {};
 220                 $method->(@args);
 221             };
 222             return $super->body->(@args);
 223         }
 224         else {
 225             return $super->body->(@args);
 226         }
 227     });
 228 }
 229
 230 ## Private Utility methods ...
 231
 232 sub _find_next_method_by_name_which_is_not_overridden {
 233     my ($self, $name) = @_;
 234     foreach my $method ($self->find_all_methods_by_name($name)) {
 235         return $method->{code}
 236             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 237     }
 238     return undef;
 239 }
 240
 241 sub _fix_metaclass_incompatability {
 242     my ($self, @superclasses) = @_;
 243     foreach my $super (@superclasses) {
 244         # don't bother if it does not have a meta.
 245         next unless $super->can('meta');
 246         # get the name, make sure we take
 247         # immutable classes into account
 248         my $super_meta_name = ($super->meta->is_immutable
 249                                 ? $super->meta->get_mutable_metaclass_name
 250                                 : blessed($super->meta));
 251         # if it's meta is a vanilla Moose,
 252         # then we can safely ignore it.
 253         next if $super_meta_name eq 'Moose::Meta::Class';
 254         # but if we have anything else,
 255         # we need to check it out ...
 256         unless (# see if of our metaclass is incompatible
 257                 ($self->isa($super_meta_name) &&
 258                  # and see if our instance metaclass is incompatible
 259                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 260                 # ... and if we are just a vanilla Moose
 261                 $self->isa('Moose::Meta::Class')) {
 262             # re-initialize the meta ...
 263             my $super_meta = $super->meta;
 264             # NOTE:
 265             # We might want to consider actually
 266             # transfering any attributes from the
 267             # original meta into this one, but in
 268             # general you should not have any there
 269             # at this point anyway, so it's very
 270             # much an obscure edge case anyway
 271             $self = $super_meta->reinitialize($self->name => (
 272                 'attribute_metaclass' => $super_meta->attribute_metaclass,
 273                 'method_metaclass'    => $super_meta->method_metaclass,
 274                 'instance_metaclass'  => $super_meta->instance_metaclass,
 275             ));
 276         }
 277     }
 278     return $self;
 279 }
 280
 281 # NOTE:
 282 # this was crap anyway, see
 283 # Moose::Util::apply_all_roles
 284 # instead
 285 sub _apply_all_roles { die "DEPRECATED" }
 286
 287 sub _process_attribute {
 288     my ($self, $name, %options) = @_;
 289     if ($name =~ /^\+(.*)/) {
 290         return $self->_process_inherited_attribute($1, %options);
 291     }
 292     else {
 293         if ($options{metaclass}) {
 294             my $metaclass_name = $options{metaclass};
 295             eval {
 296                 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
 297                 Class::MOP::load_class($possible_full_name);
 298                 $metaclass_name = $possible_full_name->can('register_implementation')
 299                     ? $possible_full_name->register_implementation
 300                     : $possible_full_name;
 301             };
 302             if ($@) {
 303                 Class::MOP::load_class($metaclass_name);
 304             }
 305             return $metaclass_name->new($name, %options);
 306         }
 307         else {
 308             return $self->attribute_metaclass->new($name, %options);
 309         }
 310     }
 311 }
 312
 313 sub _process_inherited_attribute {
 314     my ($self, $attr_name, %options) = @_;
 315     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 316     (defined $inherited_attr)
 317         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 318     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 319         return $inherited_attr->clone_and_inherit_options(%options);
 320     }
 321     else {
 322         # NOTE:
 323         # kind of a kludge to handle Class::MOP::Attributes
 324         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 325     }
 326 }
 327
 328 ## -------------------------------------------------
 329
 330 use Moose::Meta::Method::Constructor;
 331 use Moose::Meta::Method::Destructor;
 332
 333 # This could be done by using SUPER and altering ->options
 334 # I am keeping it this way to make it more explicit.
 335 sub create_immutable_transformer {
 336     my $self = shift;
 337     my $class = Class::MOP::Immutable->new($self, {
 338        read_only   => [qw/superclasses/],
 339        cannot_call => [qw/
 340            add_method
 341            alias_method
 342            remove_method
 343            add_attribute
 344            remove_attribute
 345            add_package_symbol
 346            remove_package_symbol
 347            add_role
 348        /],
 349        memoize     => {
 350            class_precedence_list             => 'ARRAY',
 351            compute_all_applicable_attributes => 'ARRAY',
 352            get_meta_instance                 => 'SCALAR',
 353            get_method_map                    => 'SCALAR',
 354            # maybe ....
 355            calculate_all_roles               => 'ARRAY',
 356        }
 357     });
 358     return $class;
 359 }
 360
 361 sub make_immutable {
 362     my $self = shift;
 363     $self->SUPER::make_immutable
 364       (
 365        constructor_class => 'Moose::Meta::Method::Constructor',
 366        destructor_class  => 'Moose::Meta::Method::Destructor',
 367        inline_destructor => 1,
 368        # NOTE:
 369        # no need to do this,
 370        # Moose always does it
 371        inline_accessors  => 0,
 372        @_,
 373       );
 374 }
 375
 376 1;
 377
 378 __END__
 379
 380 =pod
 381
 382 =head1 NAME
 383
 384 Moose::Meta::Class - The Moose metaclass
 385
 386 =head1 DESCRIPTION
 387
 388 This is a subclass of L<Class::MOP::Class> with Moose specific
 389 extensions.
 390
 391 For the most part, the only time you will ever encounter an
 392 instance of this class is if you are doing some serious deep
 393 introspection. To really understand this class, you need to refer
 394 to the L<Class::MOP::Class> documentation.
 395
 396 =head1 METHODS
 397
 398 =over 4
 399
 400 =item B<initialize>
 401
 402 =item B<make_immutable>
 403
 404 Override original to add default options for inlining destructor
 405 and altering the Constructor metaclass.
 406
 407 =item B<create_immutable_transformer>
 408
 409 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 410
 411 =item B<new_object>
 412
 413 We override this method to support the C<trigger> attribute option.
 414
 415 =item B<construct_instance>
 416
 417 This provides some Moose specific extensions to this method, you
 418 almost never call this method directly unless you really know what
 419 you are doing.
 420
 421 This method makes sure to handle the moose weak-ref, type-constraint
 422 and type coercion features.
 423
 424 =item B<get_method_map>
 425
 426 This accommodates Moose::Meta::Role::Method instances, which are
 427 aliased, instead of added, but still need to be counted as valid
 428 methods.
 429
 430 =item B<add_override_method_modifier ($name, $method)>
 431
 432 This will create an C<override> method modifier for you, and install
 433 it in the package.
 434
 435 =item B<add_augment_method_modifier ($name, $method)>
 436
 437 This will create an C<augment> method modifier for you, and install
 438 it in the package.
 439
 440 =item B<calculate_all_roles>
 441
 442 =item B<roles>
 443
 444 This will return an array of C<Moose::Meta::Role> instances which are
 445 attached to this class.
 446
 447 =item B<add_role ($role)>
 448
 449 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 450 to the list of associated roles.
 451
 452 =item B<does_role ($role_name)>
 453
 454 This will test if this class C<does> a given C<$role_name>. It will
 455 not only check it's local roles, but ask them as well in order to
 456 cascade down the role hierarchy.
 457
 458 =item B<excludes_role ($role_name)>
 459
 460 This will test if this class C<excludes> a given C<$role_name>. It will
 461 not only check it's local roles, but ask them as well in order to
 462 cascade down the role hierarchy.
 463
 464 =item B<add_attribute ($attr_name, %params|$params)>
 465
 466 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 467 support for taking the C<$params> as a HASH ref.
 468
 469 =back
 470
 471 =head1 BUGS
 472
 473 All complex software has bugs lurking in it, and this module is no
 474 exception. If you find a bug please either email me, or add the bug
 475 to cpan-RT.
 476
 477 =head1 AUTHOR
 478
 479 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 480
 481 =head1 COPYRIGHT AND LICENSE
 482
 483 Copyright 2006-2008 by Infinity Interactive, Inc.
 484
 485 L<http://www.iinteractive.com>
 486
 487 This library is free software; you can redistribute it and/or modify
 488 it under the same terms as Perl itself.
 489
 490 =cut
 491