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.16';
  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()) {
 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($name => %{$_[0]});
 168     }
 169     else {
 170         # otherwise we just pass the args
 171         $self->SUPER::add_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->(@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->(@args);
 223         }
 224         else {
 225             return $super->(@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 sub _apply_all_roles {
 282     my ($self, @roles) = @_;
 283     ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
 284         || confess "You can only consume roles, $_ is not a Moose role"
 285             foreach @roles;
 286     if (scalar @roles == 1) {
 287         $roles[0]->meta->apply($self);
 288     }
 289     else {
 290         # FIXME
 291         # we should make a Moose::Meta::Role::Composite
 292         # which is a smaller version of Moose::Meta::Role
 293         # which does not use any package stuff
 294         Moose::Meta::Role->combine(
 295             map { $_->meta } @roles
 296         )->apply($self);
 297     }
 298 }
 299
 300 sub _process_attribute {
 301     my ($self, $name, %options) = @_;
 302     if ($name =~ /^\+(.*)/) {
 303         my $new_attr = $self->_process_inherited_attribute($1, %options);
 304         $self->add_attribute($new_attr);
 305     }
 306     else {
 307         if ($options{metaclass}) {
 308             my $metaclass_name = $options{metaclass};
 309             eval {
 310                 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
 311                 Class::MOP::load_class($possible_full_name);
 312                 $metaclass_name = $possible_full_name->can('register_implementation')
 313                     ? $possible_full_name->register_implementation
 314                     : $possible_full_name;
 315             };
 316             if ($@) {
 317                 Class::MOP::load_class($metaclass_name);
 318             }
 319             $self->add_attribute($metaclass_name->new($name, %options));
 320         }
 321         else {
 322             $self->add_attribute($name, %options);
 323         }
 324     }
 325 }
 326
 327 sub _process_inherited_attribute {
 328     my ($self, $attr_name, %options) = @_;
 329     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 330     (defined $inherited_attr)
 331         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 332     my $new_attr;
 333     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 334         $new_attr = $inherited_attr->clone_and_inherit_options(%options);
 335     }
 336     else {
 337         # NOTE:
 338         # kind of a kludge to handle Class::MOP::Attributes
 339         $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
 340             $inherited_attr, %options
 341         );
 342     }
 343     return $new_attr;
 344 }
 345
 346 ## -------------------------------------------------
 347
 348 use Moose::Meta::Method::Constructor;
 349 use Moose::Meta::Method::Destructor;
 350
 351 # This could be done by using SUPER and altering ->options
 352 # I am keeping it this way to make it more explicit.
 353 sub create_immutable_transformer {
 354     my $self = shift;
 355     my $class = Class::MOP::Immutable->new($self, {
 356        read_only   => [qw/superclasses/],
 357        cannot_call => [qw/
 358            add_method
 359            alias_method
 360            remove_method
 361            add_attribute
 362            remove_attribute
 363            add_package_symbol
 364            remove_package_symbol
 365            add_role
 366        /],
 367        memoize     => {
 368            class_precedence_list             => 'ARRAY',
 369            compute_all_applicable_attributes => 'ARRAY',
 370            get_meta_instance                 => 'SCALAR',
 371            get_method_map                    => 'SCALAR',
 372            # maybe ....
 373            calculate_all_roles               => 'ARRAY',
 374        }
 375     });
 376     return $class;
 377 }
 378
 379 sub make_immutable {
 380     my $self = shift;
 381     $self->SUPER::make_immutable
 382       (
 383        constructor_class => 'Moose::Meta::Method::Constructor',
 384        destructor_class  => 'Moose::Meta::Method::Destructor',
 385        inline_destructor => 1,
 386        # NOTE:
 387        # no need to do this,
 388        # Moose always does it
 389        inline_accessors  => 0,
 390        @_,
 391       );
 392 }
 393
 394 1;
 395
 396 __END__
 397
 398 =pod
 399
 400 =head1 NAME
 401
 402 Moose::Meta::Class - The Moose metaclass
 403
 404 =head1 DESCRIPTION
 405
 406 This is a subclass of L<Class::MOP::Class> with Moose specific
 407 extensions.
 408
 409 For the most part, the only time you will ever encounter an
 410 instance of this class is if you are doing some serious deep
 411 introspection. To really understand this class, you need to refer
 412 to the L<Class::MOP::Class> documentation.
 413
 414 =head1 METHODS
 415
 416 =over 4
 417
 418 =item B<initialize>
 419
 420 =item B<make_immutable>
 421
 422 Override original to add default options for inlining destructor
 423 and altering the Constructor metaclass.
 424
 425 =item B<create_immutable_transformer>
 426
 427 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 428
 429 =item B<new_object>
 430
 431 We override this method to support the C<trigger> attribute option.
 432
 433 =item B<construct_instance>
 434
 435 This provides some Moose specific extensions to this method, you
 436 almost never call this method directly unless you really know what
 437 you are doing.
 438
 439 This method makes sure to handle the moose weak-ref, type-constraint
 440 and type coercion features.
 441
 442 =item B<get_method_map>
 443
 444 This accommodates Moose::Meta::Role::Method instances, which are
 445 aliased, instead of added, but still need to be counted as valid
 446 methods.
 447
 448 =item B<add_override_method_modifier ($name, $method)>
 449
 450 This will create an C<override> method modifier for you, and install
 451 it in the package.
 452
 453 =item B<add_augment_method_modifier ($name, $method)>
 454
 455 This will create an C<augment> method modifier for you, and install
 456 it in the package.
 457
 458 =item B<calculate_all_roles>
 459
 460 =item B<roles>
 461
 462 This will return an array of C<Moose::Meta::Role> instances which are
 463 attached to this class.
 464
 465 =item B<add_role ($role)>
 466
 467 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 468 to the list of associated roles.
 469
 470 =item B<does_role ($role_name)>
 471
 472 This will test if this class C<does> a given C<$role_name>. It will
 473 not only check it's local roles, but ask them as well in order to
 474 cascade down the role hierarchy.
 475
 476 =item B<excludes_role ($role_name)>
 477
 478 This will test if this class C<excludes> a given C<$role_name>. It will
 479 not only check it's local roles, but ask them as well in order to
 480 cascade down the role hierarchy.
 481
 482 =item B<add_attribute ($attr_name, %params|$params)>
 483
 484 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 485 support for taking the C<$params> as a HASH ref.
 486
 487 =back
 488
 489 =head1 BUGS
 490
 491 All complex software has bugs lurking in it, and this module is no
 492 exception. If you find a bug please either email me, or add the bug
 493 to cpan-RT.
 494
 495 =head1 AUTHOR
 496
 497 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 498
 499 =head1 COPYRIGHT AND LICENSE
 500
 501 Copyright 2006, 2007 by Infinity Interactive, Inc.
 502
 503 L<http://www.iinteractive.com>
 504
 505 This library is free software; you can redistribute it and/or modify
 506 it under the same terms as Perl itself.
 507
 508 =cut
 509