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