lib/Moose/Meta/Class.pm

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