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