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.22';
  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
 205             # NOTE:
 206             # in 5.10 constant.pm the constants show up
 207             # as being in the right package, but in pre-5.10
 208             # they show up as constant::__ANON__ so we
 209             # make an exception here to be sure that things
 210             # work as expected in both.
 211             # - SL
 212             unless ($pkg eq 'constant' && $name eq '__ANON__') {
 213                 next if ($pkg  || '') ne $class_name ||
 214                         (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
 215             }
 216
 217         }
 218
 219         $map->{$symbol} = $method_metaclass->wrap(
 220             $code,
 221             package_name => $class_name,
 222             name         => $symbol
 223         );
 224     }
 225
 226     return $map;
 227 }
 228
 229 ### ---------------------------------------------
 230
 231 sub add_attribute {
 232     my $self = shift;
 233     $self->SUPER::add_attribute(
 234         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 235             ? $_[0]
 236             : $self->_process_attribute(@_))
 237     );
 238 }
 239
 240 sub add_override_method_modifier {
 241     my ($self, $name, $method, $_super_package) = @_;
 242
 243     (!$self->has_method($name))
 244         || confess "Cannot add an override method if a local method is already present";
 245
 246     $self->add_method($name => Moose::Meta::Method::Overriden->new(
 247         method  => $method,
 248         class   => $self,
 249         package => $_super_package, # need this for roles
 250         name    => $name,
 251     ));
 252 }
 253
 254 sub add_augment_method_modifier {
 255     my ($self, $name, $method) = @_;
 256     (!$self->has_method($name))
 257         || confess "Cannot add an augment method if a local method is already present";
 258
 259     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 260         method  => $method,
 261         class   => $self,
 262         name    => $name,
 263     ));
 264 }
 265
 266 ## Private Utility methods ...
 267
 268 sub _find_next_method_by_name_which_is_not_overridden {
 269     my ($self, $name) = @_;
 270     foreach my $method ($self->find_all_methods_by_name($name)) {
 271         return $method->{code}
 272             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 273     }
 274     return undef;
 275 }
 276
 277 sub _fix_metaclass_incompatability {
 278     my ($self, @superclasses) = @_;
 279     foreach my $super (@superclasses) {
 280         # don't bother if it does not have a meta.
 281         next unless $super->can('meta');
 282         # get the name, make sure we take
 283         # immutable classes into account
 284         my $super_meta_name = ($super->meta->is_immutable
 285                                 ? $super->meta->get_mutable_metaclass_name
 286                                 : blessed($super->meta));
 287         # if it's meta is a vanilla Moose,
 288         # then we can safely ignore it.
 289         next if $super_meta_name eq 'Moose::Meta::Class';
 290         # but if we have anything else,
 291         # we need to check it out ...
 292         unless (# see if of our metaclass is incompatible
 293                 ($self->isa($super_meta_name) &&
 294                  # and see if our instance metaclass is incompatible
 295                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 296                 # ... and if we are just a vanilla Moose
 297                 $self->isa('Moose::Meta::Class')) {
 298             # re-initialize the meta ...
 299             my $super_meta = $super->meta;
 300             # NOTE:
 301             # We might want to consider actually
 302             # transfering any attributes from the
 303             # original meta into this one, but in
 304             # general you should not have any there
 305             # at this point anyway, so it's very
 306             # much an obscure edge case anyway
 307             $self = $super_meta->reinitialize($self->name => (
 308                 'attribute_metaclass' => $super_meta->attribute_metaclass,
 309                 'method_metaclass'    => $super_meta->method_metaclass,
 310                 'instance_metaclass'  => $super_meta->instance_metaclass,
 311             ));
 312         }
 313     }
 314     return $self;
 315 }
 316
 317 # NOTE:
 318 # this was crap anyway, see
 319 # Moose::Util::apply_all_roles
 320 # instead
 321 sub _apply_all_roles {
 322     Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
 323 }
 324
 325 sub _process_attribute {
 326     my ( $self, $name, @args ) = @_;
 327
 328     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 329
 330     if ($name =~ /^\+(.*)/) {
 331         return $self->_process_inherited_attribute($1, @args);
 332     }
 333     else {
 334         return $self->_process_new_attribute($name, @args);
 335     }
 336 }
 337
 338 sub _process_new_attribute {
 339     my ( $self, $name, @args ) = @_;
 340
 341     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 342 }
 343
 344 sub _process_inherited_attribute {
 345     my ($self, $attr_name, %options) = @_;
 346     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 347     (defined $inherited_attr)
 348         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 349     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 350         return $inherited_attr->clone_and_inherit_options(%options);
 351     }
 352     else {
 353         # NOTE:
 354         # kind of a kludge to handle Class::MOP::Attributes
 355         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 356     }
 357 }
 358
 359 ## -------------------------------------------------
 360
 361 use Moose::Meta::Method::Constructor;
 362 use Moose::Meta::Method::Destructor;
 363
 364 # This could be done by using SUPER and altering ->options
 365 # I am keeping it this way to make it more explicit.
 366 sub create_immutable_transformer {
 367     my $self = shift;
 368     my $class = Class::MOP::Immutable->new($self, {
 369        read_only   => [qw/superclasses/],
 370        cannot_call => [qw/
 371            add_method
 372            alias_method
 373            remove_method
 374            add_attribute
 375            remove_attribute
 376            remove_package_symbol
 377            add_role
 378        /],
 379        memoize     => {
 380            class_precedence_list             => 'ARRAY',
 381            compute_all_applicable_attributes => 'ARRAY',
 382            get_meta_instance                 => 'SCALAR',
 383            get_method_map                    => 'SCALAR',
 384            # maybe ....
 385            calculate_all_roles               => 'ARRAY',
 386        },
 387        # NOTE:
 388        # this is ugly, but so are typeglobs,
 389        # so whattayahgonnadoboutit
 390        # - SL
 391        wrapped => {
 392            add_package_symbol => sub {
 393                my $original = shift;
 394                confess "Cannot add package symbols to an immutable metaclass"
 395                    unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
 396                goto $original->body;
 397            },
 398        },
 399     });
 400     return $class;
 401 }
 402
 403 sub make_immutable {
 404     my $self = shift;
 405     $self->SUPER::make_immutable
 406       (
 407        constructor_class => 'Moose::Meta::Method::Constructor',
 408        destructor_class  => 'Moose::Meta::Method::Destructor',
 409        inline_destructor => 1,
 410        # NOTE:
 411        # no need to do this,
 412        # Moose always does it
 413        inline_accessors  => 0,
 414        @_,
 415       );
 416 }
 417
 418 1;
 419
 420 __END__
 421
 422 =pod
 423
 424 =head1 NAME
 425
 426 Moose::Meta::Class - The Moose metaclass
 427
 428 =head1 DESCRIPTION
 429
 430 This is a subclass of L<Class::MOP::Class> with Moose specific
 431 extensions.
 432
 433 For the most part, the only time you will ever encounter an
 434 instance of this class is if you are doing some serious deep
 435 introspection. To really understand this class, you need to refer
 436 to the L<Class::MOP::Class> documentation.
 437
 438 =head1 METHODS
 439
 440 =over 4
 441
 442 =item B<initialize>
 443
 444 =item B<create>
 445
 446 Overrides original to accept a list of roles to apply to
 447 the created class.
 448
 449    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 450
 451 =item B<create_anon_class>
 452
 453 Overrides original to support roles and caching.
 454
 455    my $metaclass = Moose::Meta::Class->create_anon_class(
 456        superclasses => ['Foo'],
 457        roles        => [qw/Some Roles Go Here/],
 458        cache        => 1,
 459    );
 460
 461 =item B<make_immutable>
 462
 463 Override original to add default options for inlining destructor
 464 and altering the Constructor metaclass.
 465
 466 =item B<create_immutable_transformer>
 467
 468 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 469
 470 =item B<new_object>
 471
 472 We override this method to support the C<trigger> attribute option.
 473
 474 =item B<construct_instance>
 475
 476 This provides some Moose specific extensions to this method, you
 477 almost never call this method directly unless you really know what
 478 you are doing.
 479
 480 This method makes sure to handle the moose weak-ref, type-constraint
 481 and type coercion features.
 482
 483 =item B<get_method_map>
 484
 485 This accommodates Moose::Meta::Role::Method instances, which are
 486 aliased, instead of added, but still need to be counted as valid
 487 methods.
 488
 489 =item B<add_override_method_modifier ($name, $method)>
 490
 491 This will create an C<override> method modifier for you, and install
 492 it in the package.
 493
 494 =item B<add_augment_method_modifier ($name, $method)>
 495
 496 This will create an C<augment> method modifier for you, and install
 497 it in the package.
 498
 499 =item B<calculate_all_roles>
 500
 501 =item B<roles>
 502
 503 This will return an array of C<Moose::Meta::Role> instances which are
 504 attached to this class.
 505
 506 =item B<add_role ($role)>
 507
 508 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 509 to the list of associated roles.
 510
 511 =item B<does_role ($role_name)>
 512
 513 This will test if this class C<does> a given C<$role_name>. It will
 514 not only check it's local roles, but ask them as well in order to
 515 cascade down the role hierarchy.
 516
 517 =item B<excludes_role ($role_name)>
 518
 519 This will test if this class C<excludes> a given C<$role_name>. It will
 520 not only check it's local roles, but ask them as well in order to
 521 cascade down the role hierarchy.
 522
 523 =item B<add_attribute ($attr_name, %params|$params)>
 524
 525 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 526 support for taking the C<$params> as a HASH ref.
 527
 528 =back
 529
 530 =head1 BUGS
 531
 532 All complex software has bugs lurking in it, and this module is no
 533 exception. If you find a bug please either email me, or add the bug
 534 to cpan-RT.
 535
 536 =head1 AUTHOR
 537
 538 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 539
 540 =head1 COPYRIGHT AND LICENSE
 541
 542 Copyright 2006-2008 by Infinity Interactive, Inc.
 543
 544 L<http://www.iinteractive.com>
 545
 546 This library is free software; you can redistribute it and/or modify
 547 it under the same terms as Perl itself.
 548
 549 =cut
 550