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.15';
  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
 108 # FIXME:
 109 # This is ugly
 110 sub get_method_map {
 111     my $self = shift;
 112     my $map  = $self->{'%!methods'};
 113
 114     my $class_name       = $self->name;
 115     my $method_metaclass = $self->method_metaclass;
 116
 117     foreach my $symbol ($self->list_all_package_symbols('CODE')) {
 118
 119         my $code = $self->get_package_symbol('&' . $symbol);
 120
 121         next if exists  $map->{$symbol} &&
 122                 defined $map->{$symbol} &&
 123                         $map->{$symbol}->body == $code;
 124
 125         my $gv = B::svref_2object($code)->GV;
 126
 127         my $pkg = $gv->STASH->NAME;
 128         if ($pkg->can('meta')
 129             # NOTE:
 130             # we don't know what ->meta we are calling
 131             # here, so we need to be careful cause it
 132             # just might blow up at us, or just complain
 133             # loudly (in the case of Curses.pm) so we
 134             # just be a little overly cautious here.
 135             # - SL
 136             && eval { no warnings; blessed($pkg->meta) }
 137             && $pkg->meta->isa('Moose::Meta::Role')) {
 138             #my $role = $pkg->meta->name;
 139             #next unless $self->does_role($role);
 140         }
 141         else {
 142             next if ($gv->STASH->NAME || '') ne $class_name &&
 143                     ($gv->NAME        || '') ne '__ANON__';
 144         }
 145
 146         $map->{$symbol} = $method_metaclass->wrap($code);
 147     }
 148
 149     return $map;
 150 }
 151
 152 ### ---------------------------------------------
 153
 154 sub add_attribute {
 155     my $self = shift;
 156     my $name = shift;
 157     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
 158         # NOTE:
 159         # if it is a HASH ref, we de-ref it.
 160         # this will usually mean that it is
 161         # coming from a role
 162         $self->SUPER::add_attribute($name => %{$_[0]});
 163     }
 164     else {
 165         # otherwise we just pass the args
 166         $self->SUPER::add_attribute($name => @_);
 167     }
 168 }
 169
 170 sub add_override_method_modifier {
 171     my ($self, $name, $method, $_super_package) = @_;
 172     (!$self->has_method($name))
 173         || confess "Cannot add an override method if a local method is already present";
 174     # need this for roles ...
 175     $_super_package ||= $self->name;
 176     my $super = $self->find_next_method_by_name($name);
 177     (defined $super)
 178         || confess "You cannot override '$name' because it has no super method";
 179     $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
 180         my @args = @_;
 181         no warnings 'redefine';
 182         if ($Moose::SUPER_SLOT{$_super_package}) {
 183           local *{$Moose::SUPER_SLOT{$_super_package}}
 184             = sub { $super->(@args) };
 185           return $method->(@args);
 186         } else {
 187           confess "Trying to call override modifier'd method without super()";
 188         }
 189     }));
 190 }
 191
 192 sub add_augment_method_modifier {
 193     my ($self, $name, $method) = @_;
 194     (!$self->has_method($name))
 195         || confess "Cannot add an augment method if a local method is already present";
 196     my $super = $self->find_next_method_by_name($name);
 197     (defined $super)
 198         || confess "You cannot augment '$name' because it has no super method";
 199     my $_super_package = $super->package_name;
 200     # BUT!,... if this is an overriden method ....
 201     if ($super->isa('Moose::Meta::Method::Overriden')) {
 202         # we need to be sure that we actually
 203         # find the next method, which is not
 204         # an 'override' method, the reason is
 205         # that an 'override' method will not
 206         # be the one calling inner()
 207         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 208         $_super_package = $real_super->package_name;
 209     }
 210     $self->add_method($name => sub {
 211         my @args = @_;
 212         no warnings 'redefine';
 213         if ($Moose::INNER_SLOT{$_super_package}) {
 214           local *{$Moose::INNER_SLOT{$_super_package}}
 215             = sub { $method->(@args) };
 216           return $super->(@args);
 217         } else {
 218           return $super->(@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 sub _apply_all_roles {
 275     my ($self, @roles) = @_;
 276     ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
 277         || confess "You can only consume roles, $_ is not a Moose role"
 278             foreach @roles;
 279     if (scalar @roles == 1) {
 280         $roles[0]->meta->apply($self);
 281     }
 282     else {
 283         # FIXME
 284         # we should make a Moose::Meta::Role::Composite
 285         # which is a smaller version of Moose::Meta::Role
 286         # which does not use any package stuff
 287         Moose::Meta::Role->combine(
 288             map { $_->meta } @roles
 289         )->apply($self);
 290     }
 291 }
 292
 293 sub _process_attribute {
 294     my ($self, $name, %options) = @_;
 295     if ($name =~ /^\+(.*)/) {
 296         my $new_attr = $self->_process_inherited_attribute($1, %options);
 297         $self->add_attribute($new_attr);
 298     }
 299     else {
 300         if ($options{metaclass}) {
 301             my $metaclass_name = $options{metaclass};
 302             eval {
 303                 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
 304                 Class::MOP::load_class($possible_full_name);
 305                 $metaclass_name = $possible_full_name->can('register_implementation')
 306                     ? $possible_full_name->register_implementation
 307                     : $possible_full_name;
 308             };
 309             if ($@) {
 310                 Class::MOP::load_class($metaclass_name);
 311             }
 312             $self->add_attribute($metaclass_name->new($name, %options));
 313         }
 314         else {
 315             $self->add_attribute($name, %options);
 316         }
 317     }
 318 }
 319
 320 sub _process_inherited_attribute {
 321     my ($self, $attr_name, %options) = @_;
 322     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 323     (defined $inherited_attr)
 324         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 325     my $new_attr;
 326     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 327         $new_attr = $inherited_attr->clone_and_inherit_options(%options);
 328     }
 329     else {
 330         # NOTE:
 331         # kind of a kludge to handle Class::MOP::Attributes
 332         $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
 333             $inherited_attr, %options
 334         );
 335     }
 336     return $new_attr;
 337 }
 338
 339 ## -------------------------------------------------
 340
 341 use Moose::Meta::Method::Constructor;
 342 use Moose::Meta::Method::Destructor;
 343
 344 # This could be done by using SUPER and altering ->options
 345 # I am keeping it this way to make it more explicit.
 346 sub create_immutable_transformer {
 347     my $self = shift;
 348     my $class = Class::MOP::Immutable->new($self, {
 349        read_only   => [qw/superclasses/],
 350        cannot_call => [qw/
 351            add_method
 352            alias_method
 353            remove_method
 354            add_attribute
 355            remove_attribute
 356            add_package_symbol
 357            remove_package_symbol
 358            add_role
 359        /],
 360        memoize     => {
 361            class_precedence_list             => 'ARRAY',
 362            compute_all_applicable_attributes => 'ARRAY',
 363            get_meta_instance                 => 'SCALAR',
 364            get_method_map                    => 'SCALAR',
 365            # maybe ....
 366            calculate_all_roles               => 'ARRAY',
 367        }
 368     });
 369     return $class;
 370 }
 371
 372 sub make_immutable {
 373     my $self = shift;
 374     $self->SUPER::make_immutable
 375       (
 376        constructor_class => 'Moose::Meta::Method::Constructor',
 377        destructor_class  => 'Moose::Meta::Method::Destructor',
 378        inline_destructor => 1,
 379        # NOTE:
 380        # no need to do this,
 381        # Moose always does it
 382        inline_accessors  => 0,
 383        @_,
 384       );
 385 }
 386
 387 1;
 388
 389 __END__
 390
 391 =pod
 392
 393 =head1 NAME
 394
 395 Moose::Meta::Class - The Moose metaclass
 396
 397 =head1 DESCRIPTION
 398
 399 This is a subclass of L<Class::MOP::Class> with Moose specific
 400 extensions.
 401
 402 For the most part, the only time you will ever encounter an
 403 instance of this class is if you are doing some serious deep
 404 introspection. To really understand this class, you need to refer
 405 to the L<Class::MOP::Class> documentation.
 406
 407 =head1 METHODS
 408
 409 =over 4
 410
 411 =item B<initialize>
 412
 413 =item B<make_immutable>
 414
 415 Override original to add default options for inlining destructor
 416 and altering the Constructor metaclass.
 417
 418 =item B<create_immutable_transformer>
 419
 420 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 421
 422 =item B<new_object>
 423
 424 We override this method to support the C<trigger> attribute option.
 425
 426 =item B<construct_instance>
 427
 428 This provides some Moose specific extensions to this method, you
 429 almost never call this method directly unless you really know what
 430 you are doing.
 431
 432 This method makes sure to handle the moose weak-ref, type-constraint
 433 and type coercion features.
 434
 435 =item B<get_method_map>
 436
 437 This accommodates Moose::Meta::Role::Method instances, which are
 438 aliased, instead of added, but still need to be counted as valid
 439 methods.
 440
 441 =item B<add_override_method_modifier ($name, $method)>
 442
 443 This will create an C<override> method modifier for you, and install
 444 it in the package.
 445
 446 =item B<add_augment_method_modifier ($name, $method)>
 447
 448 This will create an C<augment> method modifier for you, and install
 449 it in the package.
 450
 451 =item B<calculate_all_roles>
 452
 453 =item B<roles>
 454
 455 This will return an array of C<Moose::Meta::Role> instances which are
 456 attached to this class.
 457
 458 =item B<add_role ($role)>
 459
 460 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 461 to the list of associated roles.
 462
 463 =item B<does_role ($role_name)>
 464
 465 This will test if this class C<does> a given C<$role_name>. It will
 466 not only check it's local roles, but ask them as well in order to
 467 cascade down the role hierarchy.
 468
 469 =item B<excludes_role ($role_name)>
 470
 471 This will test if this class C<excludes> a given C<$role_name>. It will
 472 not only check it's local roles, but ask them as well in order to
 473 cascade down the role hierarchy.
 474
 475 =item B<add_attribute ($attr_name, %params|$params)>
 476
 477 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 478 support for taking the C<$params> as a HASH ref.
 479
 480 =back
 481
 482 =head1 BUGS
 483
 484 All complex software has bugs lurking in it, and this module is no
 485 exception. If you find a bug please either email me, or add the bug
 486 to cpan-RT.
 487
 488 =head1 AUTHOR
 489
 490 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 491
 492 =head1 COPYRIGHT AND LICENSE
 493
 494 Copyright 2006, 2007 by Infinity Interactive, Inc.
 495
 496 L<http://www.iinteractive.com>
 497
 498 This library is free software; you can redistribute it and/or modify
 499 it under the same terms as Perl itself.
 500
 501 =cut
 502