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