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