X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=24acd8315d4a298611bf425c2a440ed922dac009;hb=970a92fa56f1ea409c8d7c5428392479292fd8d4;hp=1eec1a6a2d8905ca2f18c879e548f9e97524122a;hpb=dd3ac8f94d9b58bde82976f329e24a41dbd86736;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 1eec1a6..24acd83 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -6,13 +6,13 @@ use warnings; use Class::MOP; -use Carp (); +use Carp qw( confess ); use Data::OptList; use List::Util qw( first ); use List::MoreUtils qw( any all uniq first_index ); use Scalar::Util 'weaken', 'blessed'; -our $VERSION = '1.04'; +our $VERSION = '1.19'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -22,9 +22,14 @@ use Moose::Error::Default; use Moose::Meta::Class::Immutable::Trait; use Moose::Meta::Method::Constructor; use Moose::Meta::Method::Destructor; +use Moose::Meta::Method::Meta; +use Moose::Util; +use Class::MOP::MiniTrait; use base 'Class::MOP::Class'; +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + __PACKAGE__->meta->add_attribute('roles' => ( reader => 'roles', default => sub { [] } @@ -69,19 +74,6 @@ sub initialize { ); } -sub _immutable_options { - my ( $self, @args ) = @_; - - $self->SUPER::_immutable_options( - inline_destructor => 1, - - # Moose always does this when an attribute is created - inline_accessors => 0, - - @args, - ); -} - sub create { my ($class, $package_name, %options) = @_; @@ -113,14 +105,21 @@ sub create_anon_class { return $ANON_CLASSES{$cache_key}; } + $options{weaken} = !$cache_ok + unless exists $options{weaken}; + my $new_class = $self->SUPER::create_anon_class(%options); - $ANON_CLASSES{$cache_key} = $new_class - if $cache_ok; + if ($cache_ok) { + $ANON_CLASSES{$cache_key} = $new_class; + weaken($ANON_CLASSES{$cache_key}); + } return $new_class; } +sub _meta_method_class { 'Moose::Meta::Method::Meta' } + sub _anon_cache_key { # Makes something like Super::Class|Super::Class::2=Role|Role::1 return join '=' => ( @@ -170,6 +169,7 @@ sub reinitialize { delete $ANON_CLASSES{$cache_key}; $ANON_CLASSES{$new_cache_key} = $new_meta; + weaken($ANON_CLASSES{$new_cache_key}); return $new_meta; } @@ -200,6 +200,16 @@ sub calculate_all_roles { grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles }; } +sub calculate_all_roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('calculate_all_roles') + ? Class::MOP::class_of($_)->calculate_all_roles + : () } + $self->linearized_isa; +} + sub does_role { my ($self, $role_name) = @_; @@ -351,201 +361,62 @@ sub _base_metaclasses { ); } -sub _find_common_base { - my $self = shift; - my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; - return unless defined($meta1) && defined($meta2); - - # FIXME? This doesn't account for multiple inheritance (not sure - # if it needs to though). For example, is somewhere in $meta1's - # history it inherits from both ClassA and ClassB, and $meta2 - # inherits from ClassB & ClassA, does it matter? And what crazy - # fool would do that anyway? - - my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa; - - return first { $meta1_parents{$_} } $meta2->linearized_isa; -} - -sub _get_ancestors_until { - my $self = shift; - my ($start_name, $until_name) = @_; - - my @ancestor_names; - for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) { - last if $ancestor_name eq $until_name; - push @ancestor_names, $ancestor_name; - } - return @ancestor_names; -} - -sub _is_role_only_subclass { - my $self = shift; - my ($meta_name) = @_; - my $meta = Class::MOP::Class->initialize($meta_name); - my @parent_names = $meta->superclasses; - - # XXX: don't feel like messing with multiple inheritance here... what would - # that even do? - return unless @parent_names == 1; - my ($parent_name) = @parent_names; - my $parent_meta = Class::MOP::Class->initialize($parent_name); - - # loop over all methods that are a part of the current class - # (not inherited) - for my $method (map { $meta->get_method($_) } $meta->get_method_list) { - # always ignore meta - next if $method->name eq 'meta'; - # we'll deal with attributes below - next if $method->isa('Class::MOP::Method::Accessor'); - # if the method comes from a role we consumed, ignore it - next if $meta->can('does_role') - && $meta->does_role($method->original_package_name); - - return 0; - } - - # loop over all attributes that are a part of the current class - # (not inherited) - # FIXME - this really isn't right. Just because an attribute is - # defined in a role doesn't mean it isn't _also_ defined in the - # subclass. - for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) { - next if any { $_->has_attribute($attr->name) } - map { $_->meta->can('calculate_all_roles') - ? $_->meta->calculate_all_roles - : () } - $meta->linearized_isa; - - return 0; - } - - return 1; -} - -sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation { +sub _fix_class_metaclass_incompatibility { my $self = shift; my ($super_meta) = @_; - my $common_base_name = $self->_find_common_base(blessed($self), blessed($super_meta)); - # if they're not both moose metaclasses, and the cmop fixing couldn't - # do anything, there's nothing more we can do - return unless defined($common_base_name); - return unless $common_base_name->isa('Moose::Meta::Class'); - - my @super_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($super_meta), $common_base_name); - my @class_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($self), $common_base_name); - # we're only dealing with roles here - return unless all { $self->_is_role_only_subclass($_) } - (@super_meta_name_ancestor_names, - @class_meta_name_ancestor_names); - - return 1; -} - -sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($metaclass_type, $super_meta) = @_; - - my $class_specific_meta_name = $self->$metaclass_type; - return unless $super_meta->can($metaclass_type); - my $super_specific_meta_name = $super_meta->$metaclass_type; - my %metaclasses = $self->_base_metaclasses; - - my $common_base_name = $self->_find_common_base($class_specific_meta_name, $super_specific_meta_name); - # if they're not both moose metaclasses, and the cmop fixing couldn't - # do anything, there's nothing more we can do - return unless defined($common_base_name); - return unless $common_base_name->isa($metaclasses{$metaclass_type}); - - my @super_specific_meta_name_ancestor_names = $self->_get_ancestors_until($super_specific_meta_name, $common_base_name); - my @class_specific_meta_name_ancestor_names = $self->_get_ancestors_until($class_specific_meta_name, $common_base_name); - # we're only dealing with roles here - return unless all { $self->_is_role_only_subclass($_) } - (@super_specific_meta_name_ancestor_names, - @class_specific_meta_name_ancestor_names); - - return 1; -} - -sub _role_differences { - my $self = shift; - my ($class_meta_name, $super_meta_name) = @_; - my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles') - ? $super_meta_name->meta->calculate_all_roles - : (); - my @role_metas = $class_meta_name->meta->can('calculate_all_roles') - ? $class_meta_name->meta->calculate_all_roles - : (); - my @differences; - for my $role_meta (@role_metas) { - push @differences, $role_meta - unless any { $_->name eq $role_meta->name } @super_role_metas; - } - return @differences; -} - -sub _reconcile_roles_for_metaclass { - my $self = shift; - my ($class_meta_name, $super_meta_name) = @_; - - my @role_differences = $self->_role_differences( - $class_meta_name, $super_meta_name, - ); - return $self->create_anon_class( - superclasses => [$super_meta_name], - roles => \@role_differences, - cache => 1, - ); -} - -sub _can_fix_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($super_meta) = @_; + $self->SUPER::_fix_class_metaclass_incompatibility(@_); - return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta); + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + my $super_meta_name = $super_meta->_real_ref_name; + my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name); + my $new_self = $class_meta_subclass_meta_name->reinitialize( + $self->name, + ); - my %base_metaclass = $self->_base_metaclasses; - for my $metaclass_type (keys %base_metaclass) { - next unless defined $self->$metaclass_type; - return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta); + $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); } - - return; } -sub _can_fix_metaclass_incompatibility { +sub _fix_single_metaclass_incompatibility { my $self = shift; - return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_); - return $self->SUPER::_can_fix_metaclass_incompatibility(@_); -} + my ($metaclass_type, $super_meta) = @_; -sub _fix_class_metaclass_incompatibility { - my $self = shift; - my ($super_meta) = @_; + $self->SUPER::_fix_single_metaclass_incompatibility(@_); - $self->SUPER::_fix_class_metaclass_incompatibility(@_); + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + my $super_meta_name = $super_meta->_real_ref_name; + my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); + my $new_self = $super_meta->reinitialize( + $self->name, + $metaclass_type => $class_specific_meta_subclass_meta_name, + ); - if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) { - my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), blessed($super_meta)); - # XXX: this doesn't work! we're reblessing $self into a subclass of - # $super_meta, not of itself... probably do need to just go ahead and - # reinitialize things here - $class_meta_subclass_meta->rebless_instance($self); + $self->_replace_self( $new_self, $super_meta_name ); } } -sub _fix_single_metaclass_incompatibility { - my $self = shift; - my ($metaclass_type, $super_meta) = @_; +sub _replace_self { + my $self = shift; + my ( $new_self, $new_class) = @_; - $self->SUPER::_fix_single_metaclass_incompatibility(@_); + %$self = %$new_self; + bless $self, $new_class; - if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) { - my %metaclasses = $self->_base_metaclasses; - my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); - $self->$metaclass_type($class_specific_meta_subclass_meta->name); - } + # We need to replace the cached metaclass instance or else when it goes + # out of scope Class::MOP::Class destroy's the namespace for the + # metaclass's class, causing much havoc. + my $weaken = Class::MOP::metaclass_is_weak( $self->name ); + Class::MOP::store_metaclass_by_name( $self->name, $self ); + Class::MOP::weaken_metaclass( $self->name ) if $weaken; } sub _process_attribute { @@ -582,6 +453,21 @@ sub _process_inherited_attribute { } } +## Immutability + +sub _immutable_options { + my ( $self, @args ) = @_; + + $self->SUPER::_immutable_options( + inline_destructor => 1, + + # Moose always does this when an attribute is created + inline_accessors => 0, + + @args, + ); +} + ## ------------------------------------------------- our $error_level; @@ -697,8 +583,8 @@ This overrides the parent's method to add a few options. Specifically, it uses the Moose-specific constructor and destructor classes, and enables inlining the destructor. -Also, since Moose always inlines attributes, it sets the -C option to false. +Since Moose always inlines attributes, it sets the C option +to false. =item B<< $metaclass->new_object(%params) >> @@ -727,6 +613,11 @@ This adds an C method modifier to the package. This will return a unique array of C instances which are attached to this class. +=item B<< $metaclass->calculate_all_roles_with_inheritance >> + +This will return a unique array of C instances +which are attached to this class, and each of this class's ancestors. + =item B<< $metaclass->add_role($role) >> This takes a L object, and adds it to the class's @@ -764,8 +655,8 @@ be provided as a hash reference. =item B<< $metaclass->destructor_class($class_name) >> -These are the names of classes used when making a class -immutable. These default to L and +These are the names of classes used when making a class immutable. These +default to L and L respectively. These accessors are read-write, so you can use them to change the class name.