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