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         # if it's meta is a vanilla Moose,
 216         # then we can safely ignore it.
 217         next if blessed($super->meta) eq 'Moose::Meta::Class';
 218         # but if we have anything else,
 219         # we need to check it out ...
 220         unless (# see if of our metaclass is incompatible
 221                 ($self->isa(blessed($super->meta)) &&
 222                  # and see if our instance metaclass is incompatible
 223                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 224                 # ... and if we are just a vanilla Moose
 225                 $self->isa('Moose::Meta::Class')) {
 226             # re-initialize the meta ...
 227             my $super_meta = $super->meta;
 228             # NOTE:
 229             # We might want to consider actually
 230             # transfering any attributes from the
 231             # original meta into this one, but in
 232             # general you should not have any there
 233             # at this point anyway, so it's very
 234             # much an obscure edge case anyway
 235             $self = $super_meta->reinitialize($self->name => (
 236                 'attribute_metaclass' => $super_meta->attribute_metaclass,
 237                 'method_metaclass'    => $super_meta->method_metaclass,
 238                 'instance_metaclass'  => $super_meta->instance_metaclass,
 239             ));
 240         }
 241     }
 242     return $self;
 243 }
 244
 245 sub _apply_all_roles {
 246     my ($self, @roles) = @_;
 247     ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
 248         || confess "You can only consume roles, $_ is not a Moose role"
 249             foreach @roles;
 250     if (scalar @roles == 1) {
 251         $roles[0]->meta->apply($self);
 252     }
 253     else {
 254         # FIXME
 255         # we should make a Moose::Meta::Role::Composite
 256         # which is a smaller version of Moose::Meta::Role
 257         # which does not use any package stuff
 258         Moose::Meta::Role->combine(
 259             map { $_->meta } @roles
 260         )->apply($self);
 261     }
 262 }
 263
 264 sub _process_attribute {
 265     my ($self, $name, %options) = @_;
 266     if ($name =~ /^\+(.*)/) {
 267         my $new_attr = $self->_process_inherited_attribute($1, %options);
 268         $self->add_attribute($new_attr);
 269     }
 270     else {
 271         if ($options{metaclass}) {
 272             Moose::_load_all_classes($options{metaclass});
 273             $self->add_attribute($options{metaclass}->new($name, %options));
 274         }
 275         else {
 276             $self->add_attribute($name, %options);
 277         }
 278     }
 279 }
 280
 281 sub _process_inherited_attribute {
 282     my ($self, $attr_name, %options) = @_;
 283     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 284     (defined $inherited_attr)
 285         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 286     my $new_attr;
 287     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 288         $new_attr = $inherited_attr->clone_and_inherit_options(%options);
 289     }
 290     else {
 291         # NOTE:
 292         # kind of a kludge to handle Class::MOP::Attributes
 293         $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
 294             $inherited_attr, %options
 295         );
 296     }
 297     return $new_attr;
 298 }
 299
 300 ## -------------------------------------------------
 301
 302 use Moose::Meta::Method::Constructor;
 303
 304 {
 305     # NOTE:
 306     # the immutable version of a
 307     # particular metaclass is
 308     # really class-level data so
 309     # we don't want to regenerate
 310     # it any more than we need to
 311     my $IMMUTABLE_METACLASS;
 312     sub make_immutable {
 313         my $self = shift;
 314
 315         $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
 316             read_only   => [qw/superclasses/],
 317             cannot_call => [qw/
 318                 add_method
 319                 alias_method
 320                 remove_method
 321                 add_attribute
 322                 remove_attribute
 323                 add_package_symbol
 324                 remove_package_symbol
 325                 add_role
 326             /],
 327             memoize     => {
 328                 class_precedence_list             => 'ARRAY',
 329                 compute_all_applicable_attributes => 'ARRAY',
 330                 get_meta_instance                 => 'SCALAR',
 331                 get_method_map                    => 'SCALAR',
 332                 # maybe ....
 333                 calculate_all_roles               => 'ARRAY',
 334             }
 335         });
 336
 337         $IMMUTABLE_METACLASS->make_metaclass_immutable(
 338             $self,
 339             constructor_class => 'Moose::Meta::Method::Constructor',
 340             inline_accessors  => 0,
 341             @_,
 342         )
 343     }
 344 }
 345
 346 1;
 347
 348 __END__
 349
 350 =pod
 351
 352 =head1 NAME
 353
 354 Moose::Meta::Class - The Moose metaclass
 355
 356 =head1 DESCRIPTION
 357
 358 This is a subclass of L<Class::MOP::Class> with Moose specific
 359 extensions.
 360
 361 For the most part, the only time you will ever encounter an
 362 instance of this class is if you are doing some serious deep
 363 introspection. To really understand this class, you need to refer
 364 to the L<Class::MOP::Class> documentation.
 365
 366 =head1 METHODS
 367
 368 =over 4
 369
 370 =item B<initialize>
 371
 372 =item B<make_immutable>
 373
 374 =item B<new_object>
 375
 376 We override this method to support the C<trigger> attribute option.
 377
 378 =item B<construct_instance>
 379
 380 This provides some Moose specific extensions to this method, you
 381 almost never call this method directly unless you really know what
 382 you are doing.
 383
 384 This method makes sure to handle the moose weak-ref, type-constraint
 385 and type coercion features.
 386
 387 =item B<get_method_map>
 388
 389 This accommodates Moose::Meta::Role::Method instances, which are
 390 aliased, instead of added, but still need to be counted as valid
 391 methods.
 392
 393 =item B<add_override_method_modifier ($name, $method)>
 394
 395 This will create an C<override> method modifier for you, and install
 396 it in the package.
 397
 398 =item B<add_augment_method_modifier ($name, $method)>
 399
 400 This will create an C<augment> method modifier for you, and install
 401 it in the package.
 402
 403 =item B<calculate_all_roles>
 404
 405 =item B<roles>
 406
 407 This will return an array of C<Moose::Meta::Role> instances which are
 408 attached to this class.
 409
 410 =item B<add_role ($role)>
 411
 412 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 413 to the list of associated roles.
 414
 415 =item B<does_role ($role_name)>
 416
 417 This will test if this class C<does> a given C<$role_name>. It will
 418 not only check it's local roles, but ask them as well in order to
 419 cascade down the role hierarchy.
 420
 421 =item B<excludes_role ($role_name)>
 422
 423 This will test if this class C<excludes> a given C<$role_name>. It will
 424 not only check it's local roles, but ask them as well in order to
 425 cascade down the role hierarchy.
 426
 427 =item B<add_attribute ($attr_name, %params|$params)>
 428
 429 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 430 support for taking the C<$params> as a HASH ref.
 431
 432 =back
 433
 434 =head1 BUGS
 435
 436 All complex software has bugs lurking in it, and this module is no
 437 exception. If you find a bug please either email me, or add the bug
 438 to cpan-RT.
 439
 440 =head1 AUTHOR
 441
 442 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 443
 444 =head1 COPYRIGHT AND LICENSE
 445
 446 Copyright 2006 by Infinity Interactive, Inc.
 447
 448 L<http://www.iinteractive.com>
 449
 450 This library is free software; you can redistribute it and/or modify
 451 it under the same terms as Perl itself.
 452
 453 =cut
 454