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