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