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