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 {
 336     # NOTE:
 337     # the immutable version of a
 338     # particular metaclass is
 339     # really class-level data so
 340     # we don't want to regenerate
 341     # it any more than we need to
 342     my $IMMUTABLE_METACLASS;
 343     sub make_immutable {
 344         my $self = shift;
 345
 346         $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
 347             read_only   => [qw/superclasses/],
 348             cannot_call => [qw/
 349                 add_method
 350                 alias_method
 351                 remove_method
 352                 add_attribute
 353                 remove_attribute
 354                 add_package_symbol
 355                 remove_package_symbol
 356                 add_role
 357             /],
 358             memoize     => {
 359                 class_precedence_list             => 'ARRAY',
 360                 compute_all_applicable_attributes => 'ARRAY',
 361                 get_meta_instance                 => 'SCALAR',
 362                 get_method_map                    => 'SCALAR',
 363                 # maybe ....
 364                 calculate_all_roles               => 'ARRAY',
 365             }
 366         });
 367
 368         $IMMUTABLE_METACLASS->make_metaclass_immutable(
 369             $self,
 370             constructor_class => 'Moose::Meta::Method::Constructor',
 371             destructor_class  => 'Moose::Meta::Method::Destructor',
 372             inline_destructor => 1,
 373             # NOTE:
 374             # no need to do this,
 375             # Moose always does it
 376             inline_accessors  => 0,
 377             @_,
 378         )
 379     }
 380 }
 381
 382 1;
 383
 384 __END__
 385
 386 =pod
 387
 388 =head1 NAME
 389
 390 Moose::Meta::Class - The Moose metaclass
 391
 392 =head1 DESCRIPTION
 393
 394 This is a subclass of L<Class::MOP::Class> with Moose specific
 395 extensions.
 396
 397 For the most part, the only time you will ever encounter an
 398 instance of this class is if you are doing some serious deep
 399 introspection. To really understand this class, you need to refer
 400 to the L<Class::MOP::Class> documentation.
 401
 402 =head1 METHODS
 403
 404 =over 4
 405
 406 =item B<initialize>
 407
 408 =item B<make_immutable>
 409
 410 =item B<new_object>
 411
 412 We override this method to support the C<trigger> attribute option.
 413
 414 =item B<construct_instance>
 415
 416 This provides some Moose specific extensions to this method, you
 417 almost never call this method directly unless you really know what
 418 you are doing.
 419
 420 This method makes sure to handle the moose weak-ref, type-constraint
 421 and type coercion features.
 422
 423 =item B<get_method_map>
 424
 425 This accommodates Moose::Meta::Role::Method instances, which are
 426 aliased, instead of added, but still need to be counted as valid
 427 methods.
 428
 429 =item B<add_override_method_modifier ($name, $method)>
 430
 431 This will create an C<override> method modifier for you, and install
 432 it in the package.
 433
 434 =item B<add_augment_method_modifier ($name, $method)>
 435
 436 This will create an C<augment> method modifier for you, and install
 437 it in the package.
 438
 439 =item B<calculate_all_roles>
 440
 441 =item B<roles>
 442
 443 This will return an array of C<Moose::Meta::Role> instances which are
 444 attached to this class.
 445
 446 =item B<add_role ($role)>
 447
 448 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 449 to the list of associated roles.
 450
 451 =item B<does_role ($role_name)>
 452
 453 This will test if this class C<does> a given C<$role_name>. It will
 454 not only check it's local roles, but ask them as well in order to
 455 cascade down the role hierarchy.
 456
 457 =item B<excludes_role ($role_name)>
 458
 459 This will test if this class C<excludes> a given C<$role_name>. It will
 460 not only check it's local roles, but ask them as well in order to
 461 cascade down the role hierarchy.
 462
 463 =item B<add_attribute ($attr_name, %params|$params)>
 464
 465 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 466 support for taking the C<$params> as a HASH ref.
 467
 468 =back
 469
 470 =head1 BUGS
 471
 472 All complex software has bugs lurking in it, and this module is no
 473 exception. If you find a bug please either email me, or add the bug
 474 to cpan-RT.
 475
 476 =head1 AUTHOR
 477
 478 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 479
 480 =head1 COPYRIGHT AND LICENSE
 481
 482 Copyright 2006, 2007 by Infinity Interactive, Inc.
 483
 484 L<http://www.iinteractive.com>
 485
 486 This library is free software; you can redistribute it and/or modify
 487 it under the same terms as Perl itself.
 488
 489 =cut
 490