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