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