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