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