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