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