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