X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=fa5331560d1fb3d61cdbf16d90fd7f56c4a6900b;hb=45160c4b37efc1dce63d008c7a734d8250fb714c;hp=b1c642d1609553139887dd30d82f20599b23ead1;hpb=349cda54dc7757032705b5485612b7cedfa2e2d5;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index b1c642d..fa53315 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -11,7 +11,7 @@ use List::Util qw( first ); use List::MoreUtils qw( any all uniq first_index ); use Scalar::Util 'weaken', 'blessed'; -our $VERSION = '0.77'; +our $VERSION = '0.99'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -115,11 +115,8 @@ sub create_anon_class { my $cache_ok = delete $options{cache}; - # something like Super::Class|Super::Class::2=Role|Role::1 - my $cache_key = join '=' => ( - join('|', @{$options{superclasses} || []}), - join('|', sort @{$options{roles} || []}), - ); + my $cache_key + = _anon_cache_key( $options{superclasses}, $options{roles} ); if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { return $ANON_CLASSES{$cache_key}; @@ -133,6 +130,59 @@ sub create_anon_class { return $new_class; } +sub _anon_cache_key { + # Makes something like Super::Class|Super::Class::2=Role|Role::1 + return join '=' => ( + join( '|', @{ $_[0] || [] } ), + join( '|', sort @{ $_[1] || [] } ), + ); +} + +sub reinitialize { + my $self = shift; + my $pkg = shift; + + my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); + + my $cache_key; + + my %existing_classes; + if ($meta) { + %existing_classes = map { $_ => $meta->$_() } qw( + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class + ); + + $cache_key = _anon_cache_key( + [ $meta->superclasses ], + [ map { $_->name } @{ $meta->roles } ], + ) if $meta->is_anon_class; + } + + my $new_meta = $self->SUPER::reinitialize( + $pkg, + %existing_classes, + @_, + ); + + return $new_meta unless defined $cache_key; + + my $new_cache_key = _anon_cache_key( + [ $meta->superclasses ], + [ map { $_->name } @{ $meta->roles } ], + ); + + delete $ANON_CLASSES{$cache_key}; + $ANON_CLASSES{$new_cache_key} = $new_meta; + + return $new_meta; +} + sub add_role { my ($self, $role) = @_; (blessed($role) && $role->isa('Moose::Meta::Role')) @@ -227,27 +277,13 @@ sub new_object { return $self; } -sub _construct_instance { - my $class = shift; - my $params = @_ == 1 ? $_[0] : {@_}; - my $meta_instance = $class->get_meta_instance; - # FIXME: - # the code below is almost certainly incorrect - # but this is foreign inheritance, so we might - # have to kludge it in the end. - my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance(); - foreach my $attr ($class->get_all_attributes()) { - $attr->initialize_instance_slot($meta_instance, $instance, $params); - } - return $instance; -} - sub superclasses { my $self = shift; my @supers = @_; foreach my $super (@supers) { - my $meta = Class::MOP::load_class($super); - Moose->throw_error("You cannot inherit from a Moose Role ($super)") + Class::MOP::load_class($super); + my $meta = Class::MOP::class_of($super); + $self->throw_error("You cannot inherit from a Moose Role ($super)") if $meta && $meta->isa('Moose::Meta::Role') } return $self->SUPER::superclasses(@supers); @@ -257,11 +293,17 @@ sub superclasses { sub add_attribute { my $self = shift; - $self->SUPER::add_attribute( + my $attr = (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') ? $_[0] - : $self->_process_attribute(@_)) - ); + : $self->_process_attribute(@_)); + $self->SUPER::add_attribute($attr); + # it may be a Class::MOP::Attribute, theoretically, which doesn't have + # 'bare' and doesn't implement this method + if ($attr->can('_check_associated_methods')) { + $attr->_check_associated_methods; + } + return $attr; } sub add_override_method_modifier { @@ -304,27 +346,8 @@ sub _find_next_method_by_name_which_is_not_overridden { sub _fix_metaclass_incompatibility { my ($self, @superclasses) = @_; - foreach my $super (@superclasses) { - my $meta = Class::MOP::Class->initialize($super); - - my @all_supers = $meta->linearized_isa; - shift(@all_supers); # Discard self - my @super_metas_to_fix = ( $meta ); - - # We need to check&fix the imediate superclass, and if its @ISA contains - # a class without a metaclass instance, followed by a class with a - # metaclass instance, init a metaclass instance for classes without - # one and fix compat up to and including the class which was already - # initialized. - my $idx = first_index { Class::MOP::class_of($_) } @all_supers; - push(@super_metas_to_fix, - map { Class::MOP::Class->initialize($_) } @all_supers[0..$idx] - ) if ($idx >= 0); - - foreach my $super_meta (@super_metas_to_fix) { - $self->_fix_one_incompatible_metaclass($super_meta); - } - } + $self->_fix_one_incompatible_metaclass($_) + for map { Moose::Meta::Class->initialize($_) } @superclasses; } sub _fix_one_incompatible_metaclass { @@ -338,6 +361,7 @@ sub _fix_one_incompatible_metaclass { . $self->name . ", it isn't pristine" ); } + $self->_reconcile_with_superclass_meta($meta); } @@ -348,7 +372,7 @@ sub _superclass_meta_is_compatible { my $super_meta_name = $super_meta->is_immutable - ? $super_meta->get_mutable_metaclass_name + ? $super_meta->_get_mutable_metaclass_name : ref($super_meta); return 1 @@ -372,7 +396,7 @@ sub _reconcile_with_superclass_meta { my $super_meta_name = $super_meta->is_immutable - ? $super_meta->get_mutable_metaclass_name + ? $super_meta->_get_mutable_metaclass_name : ref($super_meta); my $self_metaclass = ref $self; @@ -677,8 +701,9 @@ These all default to the appropriate Moose class. =item B<< Moose::Meta::Class->create($package_name, %options) >> This overrides the parent's method in order to accept a C -option. This should be an array reference containing one more roles -that the class does. +option. This should be an array reference containing roles +that the class does, each optionally followed by a hashref of options +(C<-excludes> and C<-alias>). my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); @@ -742,10 +767,11 @@ adds it to the class's list of role applications. This I actually apply any role to the class; it is only for tracking role applications. -=item B<< $metaclass->does_role($role_name) >> +=item B<< $metaclass->does_role($role) >> -This returns a boolean indicating whether or not the class does the -specified role. This tests both the class and its parents. +This returns a boolean indicating whether or not the class does the specified +role. The role provided can be either a role name or a L +object. This tests both the class and its parents. =item B<< $metaclass->excludes_role($role_name) >> @@ -780,9 +806,7 @@ Throws the error created by C using C =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. =head1 AUTHOR @@ -790,7 +814,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2009 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L