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 __PACKAGE__->meta->add_attribute('constructor_class' => (
  27     accessor => 'constructor_class',
  28     default  => sub { 'Moose::Meta::Method::Constructor' }
  29 ));
  30
  31 __PACKAGE__->meta->add_attribute('destructor_class' => (
  32     accessor => 'destructor_class',
  33     default  => sub { 'Moose::Meta::Method::Destructor' }
  34 ));
  35
  36 sub initialize {
  37     my $class = shift;
  38     my $pkg   = shift;
  39     return Class::MOP::get_metaclass_by_name($pkg)
  40         || $class->SUPER::initialize($pkg,
  41                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  42                 'method_metaclass'    => 'Moose::Meta::Method',
  43                 'instance_metaclass'  => 'Moose::Meta::Instance',
  44                 @_
  45             );
  46 }
  47
  48 sub create {
  49     my ($self, $package_name, %options) = @_;
  50
  51     (ref $options{roles} eq 'ARRAY')
  52         || confess "You must pass an ARRAY ref of roles"
  53             if exists $options{roles};
  54
  55     my $class = $self->SUPER::create($package_name, %options);
  56
  57     if (exists $options{roles}) {
  58         Moose::Util::apply_all_roles($class, @{$options{roles}});
  59     }
  60
  61     return $class;
  62 }
  63
  64 my %ANON_CLASSES;
  65
  66 sub create_anon_class {
  67     my ($self, %options) = @_;
  68
  69     my $cache_ok = delete $options{cache};
  70
  71     # something like Super::Class|Super::Class::2=Role|Role::1
  72     my $cache_key = join '=' => (
  73         join('|', sort @{$options{superclasses} || []}),
  74         join('|', sort @{$options{roles}        || []}),
  75     );
  76
  77     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
  78         return $ANON_CLASSES{$cache_key};
  79     }
  80
  81     my $new_class = $self->SUPER::create_anon_class(%options);
  82
  83     $ANON_CLASSES{$cache_key} = $new_class
  84         if $cache_ok;
  85
  86     return $new_class;
  87 }
  88
  89 sub add_role {
  90     my ($self, $role) = @_;
  91     (blessed($role) && $role->isa('Moose::Meta::Role'))
  92         || confess "Roles must be instances of Moose::Meta::Role";
  93     push @{$self->roles} => $role;
  94 }
  95
  96 sub calculate_all_roles {
  97     my $self = shift;
  98     my %seen;
  99     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 100 }
 101
 102 sub does_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') && $class->meta->can('roles');
 108         foreach my $role (@{$class->meta->roles}) {
 109             return 1 if $role->does_role($role_name);
 110         }
 111     }
 112     return 0;
 113 }
 114
 115 sub excludes_role {
 116     my ($self, $role_name) = @_;
 117     (defined $role_name)
 118         || confess "You must supply a role name to look for";
 119     foreach my $class ($self->class_precedence_list) {
 120         next unless $class->can('meta');
 121         # NOTE:
 122         # in the pretty rare instance when a Moose metaclass
 123         # is itself extended with a role, this check needs to
 124         # be done since some items in the class_precedence_list
 125         # might in fact be Class::MOP based still.
 126         next unless $class->meta->can('roles');
 127         foreach my $role (@{$class->meta->roles}) {
 128             return 1 if $role->excludes_role($role_name);
 129         }
 130     }
 131     return 0;
 132 }
 133
 134 sub new_object {
 135     my $class = shift;
 136     my $params = @_ == 1 ? $_[0] : {@_};
 137     my $self = $class->SUPER::new_object($params);
 138     foreach my $attr ($class->compute_all_applicable_attributes()) {
 139         # if we have a trigger, then ...
 140         if ($attr->can('has_trigger') && $attr->has_trigger) {
 141             # make sure we have an init-arg ...
 142             if (defined(my $init_arg = $attr->init_arg)) {
 143                 # now make sure an init-arg was passes ...
 144                 if (exists $params->{$init_arg}) {
 145                     # and if get here, fire the trigger
 146                     $attr->trigger->(
 147                         $self,
 148                         # check if there is a coercion
 149                         ($attr->should_coerce
 150                             # and if so, we need to grab the
 151                             # value that is actually been stored
 152                             ? $attr->get_read_method_ref->($self)
 153                             # otherwise, just get the value from
 154                             # the constructor params
 155                             : $params->{$init_arg}),
 156                         $attr
 157                     );
 158                 }
 159             }
 160         }
 161     }
 162     return $self;
 163 }
 164
 165 sub construct_instance {
 166     my $class = shift;
 167     my $params = @_ == 1 ? $_[0] : {@_};
 168     my $meta_instance = $class->get_meta_instance;
 169     # FIXME:
 170     # the code below is almost certainly incorrect
 171     # but this is foreign inheritence, so we might
 172     # have to kludge it in the end.
 173     my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
 174     foreach my $attr ($class->compute_all_applicable_attributes()) {
 175         $attr->initialize_instance_slot($meta_instance, $instance, $params);
 176     }
 177     return $instance;
 178 }
 179
 180 # FIXME:
 181 # This is ugly
 182 sub get_method_map {
 183     my $self = shift;
 184
 185     my $current = Class::MOP::check_package_cache_flag($self->name);
 186
 187     if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
 188         return $self->{'methods'};
 189     }
 190
 191     $self->{_package_cache_flag} = $current;
 192
 193     my $map  = $self->{'methods'};
 194
 195     my $class_name       = $self->name;
 196     my $method_metaclass = $self->method_metaclass;
 197
 198     my %all_code = $self->get_all_package_symbols('CODE');
 199
 200     foreach my $symbol (keys %all_code) {
 201         my $code = $all_code{$symbol};
 202
 203         next if exists  $map->{$symbol} &&
 204                 defined $map->{$symbol} &&
 205                         $map->{$symbol}->body == $code;
 206
 207         my ($pkg, $name) = Class::MOP::get_code_info($code);
 208
 209         if ($pkg->can('meta')
 210             # NOTE:
 211             # we don't know what ->meta we are calling
 212             # here, so we need to be careful cause it
 213             # just might blow up at us, or just complain
 214             # loudly (in the case of Curses.pm) so we
 215             # just be a little overly cautious here.
 216             # - SL
 217             && eval { no warnings; blessed($pkg->meta) }
 218             && $pkg->meta->isa('Moose::Meta::Role')) {
 219             #my $role = $pkg->meta->name;
 220             #next unless $self->does_role($role);
 221         }
 222         else {
 223
 224             # NOTE:
 225             # in 5.10 constant.pm the constants show up
 226             # as being in the right package, but in pre-5.10
 227             # they show up as constant::__ANON__ so we
 228             # make an exception here to be sure that things
 229             # work as expected in both.
 230             # - SL
 231             unless ($pkg eq 'constant' && $name eq '__ANON__') {
 232                 next if ($pkg  || '') ne $class_name ||
 233                         (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
 234             }
 235
 236         }
 237
 238         $map->{$symbol} = $method_metaclass->wrap(
 239             $code,
 240             package_name => $class_name,
 241             name         => $symbol
 242         );
 243     }
 244
 245     return $map;
 246 }
 247
 248 ### ---------------------------------------------
 249
 250 sub add_attribute {
 251     my $self = shift;
 252     $self->SUPER::add_attribute(
 253         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 254             ? $_[0]
 255             : $self->_process_attribute(@_))
 256     );
 257 }
 258
 259 sub add_override_method_modifier {
 260     my ($self, $name, $method, $_super_package) = @_;
 261
 262     (!$self->has_method($name))
 263         || confess "Cannot add an override method if a local method is already present";
 264
 265     $self->add_method($name => Moose::Meta::Method::Overriden->new(
 266         method  => $method,
 267         class   => $self,
 268         package => $_super_package, # need this for roles
 269         name    => $name,
 270     ));
 271 }
 272
 273 sub add_augment_method_modifier {
 274     my ($self, $name, $method) = @_;
 275     (!$self->has_method($name))
 276         || confess "Cannot add an augment method if a local method is already present";
 277
 278     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 279         method  => $method,
 280         class   => $self,
 281         name    => $name,
 282     ));
 283 }
 284
 285 ## Private Utility methods ...
 286
 287 sub _find_next_method_by_name_which_is_not_overridden {
 288     my ($self, $name) = @_;
 289     foreach my $method ($self->find_all_methods_by_name($name)) {
 290         return $method->{code}
 291             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 292     }
 293     return undef;
 294 }
 295
 296 # Right now, this method does not handle the case where two
 297 # metaclasses differ only in roles applied against a common parent
 298 # class. This can happen fairly easily when ClassA applies metaclass
 299 # Role1, and then a subclass, ClassB, applies a metaclass Role2. In
 300 # reality, the way to resolve the problem is to apply Role1 to
 301 # ClassB's metaclass. However, we cannot currently detect this, and so
 302 # we simply fail to fix the incompatibility.
 303 #
 304 # The algorithm for fixing it is not that complicated.
 305 #
 306 # First, we see if the two metaclasses share a common parent (probably
 307 # Moose::Meta::Class).
 308 #
 309 # Second, we see if the metaclasses only differ in terms of roles
 310 # applied. This second point is where things break down. There is no
 311 # easy way to determine if the difference is from roles only. To do
 312 # that, we'd need to able to reliably determine the origin of each
 313 # method and attribute in each metaclass. If all the unshared methods
 314 # & attributes come from roles, and there is no name collision, then
 315 # we can apply the missing roles to the child's metaclass.
 316 #
 317 # Tracking the origin of these things will require some fairly
 318 # invasive changes to various parts of Moose & Class::MOP.
 319 #
 320 # For now, the workaround is for ClassB to subclass ClassA _and then_
 321 # apply metaclass roles to its metaclass.
 322 sub _fix_metaclass_incompatability {
 323     my ($self, @superclasses) = @_;
 324
 325     my $self_meta_name = ref($self);
 326
 327     foreach my $super (@superclasses) {
 328         # don't bother if it does not have a meta.
 329         my $super_meta = Class::MOP::Class->initialize($super) or next;
 330         next unless $super_meta->isa("Class::MOP::Class");
 331
 332         # get the name, make sure we take
 333         # immutable classes into account
 334         my $super_meta_name
 335             = $super_meta->is_immutable
 336             ? $super_meta->get_mutable_metaclass_name
 337             : ref($super_meta);
 338
 339         next if
 340             # if our metaclass is compatible
 341             $self->isa($super_meta_name)
 342                 and
 343             # and our instance metaclass is also compatible then no
 344             # fixes are needed
 345             $self->instance_metaclass->isa( $super_meta->instance_metaclass );
 346
 347         if ( $super_meta->isa($self_meta_name) ) {
 348             $self->_require_pristine_to_reinitialize;
 349
 350             $self = $super_meta->reinitialize(
 351                 $self->name,
 352                 attribute_metaclass => $super_meta->attribute_metaclass,
 353                 method_metaclass    => $super_meta->method_metaclass,
 354                 instance_metaclass  => $super_meta->instance_metaclass,
 355             );
 356
 357             $self->$_( $super_meta->$_ )
 358                 for qw( constructor_class destructor_class );
 359         }
 360         elsif ( __difference_is_roles_only( $self, $super_meta ) ) {
 361             $self->_require_pristine_to_reinitialize;
 362
 363             my @roles = map { $_->name } @{$self->meta->roles};
 364
 365             $self = $super_meta->reinitialize(
 366                 $self->name,
 367                 attribute_metaclass => $super_meta->attribute_metaclass,
 368                 method_metaclass    => $super_meta->method_metaclass,
 369                 instance_metaclass  => $super_meta->instance_metaclass,
 370             );
 371
 372             $self = Moose::Util::MetaRole::apply_metaclass_roles(
 373                 for_class       => $self->name,
 374                 metaclass_roles => \@roles,
 375             );
 376         }
 377     }
 378
 379     return $self;
 380 }
 381
 382 sub _require_pristine_to_reinitialize {
 383     my $self = shift;
 384
 385     return if $self->is_pristine;
 386
 387     confess "Not reinitializing metaclass for "
 388         . $self->name
 389         . ", it isn't pristine";
 390 }
 391
 392 # This stuff is called as functions because while it operates on
 393 # metaclasses, it might get a Class::MOP::Class as opposed to a
 394 # Moose::Meta::Class.
 395 sub __difference_is_roles_only {
 396     my ( $meta1, $meta2 ) = @_;
 397
 398     return
 399         unless $meta1->meta->can('does_role')
 400             || $meta2->meta->can('does_role');
 401
 402     return
 403         if __arrays_differ(
 404         __methods_excluding_roles( $meta1->meta ),
 405         __methods_excluding_roles( $meta2->meta )
 406         );
 407
 408     return
 409         if __arrays_differ(
 410         __attr_excluding_roles( $meta1->meta ),
 411         __attr_excluding_roles( $meta2->meta )
 412         );
 413
 414     return 1;
 415 }
 416
 417 sub __arrays_differ {
 418     my ( $arr1, $arr2 ) = @_;
 419
 420     my %arr1_vals = map { $_ => 1 } @{$arr1};
 421     delete @arr1_vals{ @{$arr2} };
 422
 423     return keys %arr1_vals ? 1 : 0;
 424 }
 425
 426 sub __methods_excluding_roles {
 427     my $meta = shift;
 428
 429     my %map = map { $_->name => $_ } $meta->get_all_methods;
 430
 431     delete $map{meta};
 432
 433     return values %map unless $meta->can('roles') && $meta->roles;
 434
 435     for my $role ( @{$meta->roles} ) {
 436         for my $role_meth ( values %{$role->get_method_map} ) {
 437             next if $role_meth->name eq 'meta';
 438
 439             my $meta_meth = $map{ $role_meth->name };
 440
 441             next unless $meta_meth;
 442             next unless $meta_meth->body eq $role_meth->body;
 443
 444             delete $map{ $role_meth->name };
 445         }
 446
 447         for my $attr ( grep { defined } map { $meta->get_attribute($_) } $role->get_attribute_list ) {
 448             delete @map{ map { $_->name } @{$attr->associated_methods} };
 449         }
 450     }
 451
 452     return [ values %map ];
 453 }
 454
 455 sub __attr_excluding_roles {
 456     my $meta = shift;
 457
 458     my %map = map { $_->name => $_ } $meta->get_all_attributes;
 459
 460     return values %map unless $meta->can('roles') && $meta->roles;
 461
 462     for my $role ( @{$meta->roles} ) {
 463         delete @map{ $role->get_attribute_list };
 464     }
 465
 466     return [ values %map ];
 467 }
 468
 469 # NOTE:
 470 # this was crap anyway, see
 471 # Moose::Util::apply_all_roles
 472 # instead
 473 sub _apply_all_roles {
 474     Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
 475 }
 476
 477 sub _process_attribute {
 478     my ( $self, $name, @args ) = @_;
 479
 480     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 481
 482     if ($name =~ /^\+(.*)/) {
 483         return $self->_process_inherited_attribute($1, @args);
 484     }
 485     else {
 486         return $self->_process_new_attribute($name, @args);
 487     }
 488 }
 489
 490 sub _process_new_attribute {
 491     my ( $self, $name, @args ) = @_;
 492
 493     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 494 }
 495
 496 sub _process_inherited_attribute {
 497     my ($self, $attr_name, %options) = @_;
 498     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 499     (defined $inherited_attr)
 500         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 501     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 502         return $inherited_attr->clone_and_inherit_options(%options);
 503     }
 504     else {
 505         # NOTE:
 506         # kind of a kludge to handle Class::MOP::Attributes
 507         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 508     }
 509 }
 510
 511 ## -------------------------------------------------
 512
 513 use Moose::Meta::Method::Constructor;
 514 use Moose::Meta::Method::Destructor;
 515
 516 # This could be done by using SUPER and altering ->options
 517 # I am keeping it this way to make it more explicit.
 518 sub create_immutable_transformer {
 519     my $self = shift;
 520     my $class = Class::MOP::Immutable->new($self, {
 521        read_only   => [qw/superclasses/],
 522        cannot_call => [qw/
 523            add_method
 524            alias_method
 525            remove_method
 526            add_attribute
 527            remove_attribute
 528            remove_package_symbol
 529            add_role
 530        /],
 531        memoize     => {
 532            class_precedence_list             => 'ARRAY',
 533            linearized_isa                    => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
 534            get_all_methods                   => 'ARRAY',
 535            #get_all_attributes               => 'ARRAY', # it's an alias, no need, but maybe in the future
 536            compute_all_applicable_attributes => 'ARRAY',
 537            get_meta_instance                 => 'SCALAR',
 538            get_method_map                    => 'SCALAR',
 539            calculate_all_roles               => 'ARRAY',
 540        },
 541        # NOTE:
 542        # this is ugly, but so are typeglobs,
 543        # so whattayahgonnadoboutit
 544        # - SL
 545        wrapped => {
 546            add_package_symbol => sub {
 547                my $original = shift;
 548                confess "Cannot add package symbols to an immutable metaclass"
 549                    unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
 550                goto $original->body;
 551            },
 552        },
 553     });
 554     return $class;
 555 }
 556
 557 sub make_immutable {
 558     my $self = shift;
 559     $self->SUPER::make_immutable
 560       (
 561        constructor_class => $self->constructor_class,
 562        destructor_class  => $self->destructor_class,
 563        inline_destructor => 1,
 564        # NOTE:
 565        # no need to do this,
 566        # Moose always does it
 567        inline_accessors  => 0,
 568        @_,
 569       );
 570 }
 571
 572 1;
 573
 574 __END__
 575
 576 =pod
 577
 578 =head1 NAME
 579
 580 Moose::Meta::Class - The Moose metaclass
 581
 582 =head1 DESCRIPTION
 583
 584 This is a subclass of L<Class::MOP::Class> with Moose specific
 585 extensions.
 586
 587 For the most part, the only time you will ever encounter an
 588 instance of this class is if you are doing some serious deep
 589 introspection. To really understand this class, you need to refer
 590 to the L<Class::MOP::Class> documentation.
 591
 592 =head1 METHODS
 593
 594 =over 4
 595
 596 =item B<initialize>
 597
 598 =item B<create>
 599
 600 Overrides original to accept a list of roles to apply to
 601 the created class.
 602
 603    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 604
 605 =item B<create_anon_class>
 606
 607 Overrides original to support roles and caching.
 608
 609    my $metaclass = Moose::Meta::Class->create_anon_class(
 610        superclasses => ['Foo'],
 611        roles        => [qw/Some Roles Go Here/],
 612        cache        => 1,
 613    );
 614
 615 =item B<make_immutable>
 616
 617 Override original to add default options for inlining destructor
 618 and altering the Constructor metaclass.
 619
 620 =item B<create_immutable_transformer>
 621
 622 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 623
 624 =item B<new_object>
 625
 626 We override this method to support the C<trigger> attribute option.
 627
 628 =item B<construct_instance>
 629
 630 This provides some Moose specific extensions to this method, you
 631 almost never call this method directly unless you really know what
 632 you are doing.
 633
 634 This method makes sure to handle the moose weak-ref, type-constraint
 635 and type coercion features.
 636
 637 =item B<get_method_map>
 638
 639 This accommodates Moose::Meta::Role::Method instances, which are
 640 aliased, instead of added, but still need to be counted as valid
 641 methods.
 642
 643 =item B<add_override_method_modifier ($name, $method)>
 644
 645 This will create an C<override> method modifier for you, and install
 646 it in the package.
 647
 648 =item B<add_augment_method_modifier ($name, $method)>
 649
 650 This will create an C<augment> method modifier for you, and install
 651 it in the package.
 652
 653 =item B<calculate_all_roles>
 654
 655 =item B<roles>
 656
 657 This will return an array of C<Moose::Meta::Role> instances which are
 658 attached to this class.
 659
 660 =item B<add_role ($role)>
 661
 662 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 663 to the list of associated roles.
 664
 665 =item B<does_role ($role_name)>
 666
 667 This will test if this class C<does> a given C<$role_name>. It will
 668 not only check it's local roles, but ask them as well in order to
 669 cascade down the role hierarchy.
 670
 671 =item B<excludes_role ($role_name)>
 672
 673 This will test if this class C<excludes> a given C<$role_name>. It will
 674 not only check it's local roles, but ask them as well in order to
 675 cascade down the role hierarchy.
 676
 677 =item B<add_attribute ($attr_name, %params|$params)>
 678
 679 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 680 support for taking the C<$params> as a HASH ref.
 681
 682 =back
 683
 684 =head1 BUGS
 685
 686 All complex software has bugs lurking in it, and this module is no
 687 exception. If you find a bug please either email me, or add the bug
 688 to cpan-RT.
 689
 690 =head1 AUTHOR
 691
 692 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 693
 694 =head1 COPYRIGHT AND LICENSE
 695
 696 Copyright 2006-2008 by Infinity Interactive, Inc.
 697
 698 L<http://www.iinteractive.com>
 699
 700 This library is free software; you can redistribute it and/or modify
 701 it under the same terms as Perl itself.
 702
 703 =cut
 704