X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=52cd74ce15b2bfe17a2f4c110f227ea8efbd9f83;hb=78f6e9c6a73ff3dd985a1cebaafd0b81e543beb8;hp=3dacb0380637dc84e4024bb05ee79d2d87ec3a88;hpb=1079de031658d03262317dc24d981e4f49b9a376;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 3dacb03..52cd74c 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -8,14 +8,13 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; -use Class::MOP::Class::Immutable::Class::MOP::Class; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; -our $VERSION = '0.86'; +our $VERSION = '0.88'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -181,6 +180,8 @@ sub _check_metaclass_compatibility { return if ref($self) eq 'Class::MOP::Class' && $self->instance_metaclass eq 'Class::MOP::Instance'; + return if $self->can('get_mutable_metaclass_name'); + my @class_list = $self->linearized_isa; shift @class_list; # shift off $self->name @@ -197,17 +198,17 @@ sub _check_metaclass_compatibility { : ref($super_meta); ($self->isa($super_meta_type)) - || confess "Class::MOP::class_of(" . $self->name . ") => (" + || confess "The metaclass of " . $self->name . " (" . (ref($self)) . ")" . " is not compatible with the " . - "Class::MOP::class_of(".$superclass_name . ") => (" + "metaclass of its superclass, ".$superclass_name . " (" . ($super_meta_type) . ")"; # NOTE: # we also need to check that instance metaclasses # are compatibile in the same the class. ($self->instance_metaclass->isa($super_meta->instance_metaclass)) - || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" . + || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" . " is not compatible with the " . - "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; + "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")"; } } @@ -371,7 +372,11 @@ sub _construct_instance { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; my $meta_instance = $class->get_meta_instance(); - my $instance = $meta_instance->create_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); } @@ -623,7 +628,7 @@ sub add_method { my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); - if ( $current_name eq '__ANON__' ) { + if ( !defined $current_name || $current_name eq '__ANON__' ) { my $full_method_name = ($self->name . '::' . $method_name); subname($full_method_name => $body); } @@ -855,7 +860,12 @@ sub add_attribute { $self->get_attribute_map->{$attribute->name} = $attribute; # invalidate package flag here - my $e = do { local $@; eval { $attribute->install_accessors() }; $@ }; + my $e = do { + local $@; + local $SIG{__DIE__}; + eval { $attribute->install_accessors() }; + $@; + }; if ( $e ) { $self->remove_attribute($attribute->name); die $e; @@ -1076,36 +1086,36 @@ sub _immutable_metaclass { my $class_name; if ( $meta_attr and $trait eq $meta_attr->default ) { - - # if the trait is the same as the default we try and pick a predictable - # name for the immutable metaclass - $class_name = "Class::MOP::Class::Immutable::" . ref($self); + # if the trait is the same as the default we try and pick a + # predictable name for the immutable metaclass + $class_name = 'Class::MOP::Class::Immutable::' . ref($self); } else { - $class_name - = join( "::", "Class::MOP::Class::Immutable::CustomTrait", $trait, - "ForMetaClass", ref($self) ); + $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait', + $trait, 'ForMetaClass', ref($self); } - if ( Class::MOP::is_class_loaded($class_name) ) { - if ( $class_name->isa($trait) ) { - return $class_name; + return $class_name + if Class::MOP::is_class_loaded($class_name); + + my $meta = Class::MOP::Class->create( + $class_name, + superclasses => [ ref $self ], + ); + + Class::MOP::load_class($trait); + for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) { + next if $meta->has_method( $meth->name ); + + if ( $meta->find_method_by_name( $meth->name ) ) { + $meta->add_around_method_modifier( $meth->name, $meth->body ); } else { - confess - "$class_name is already defined but does not inherit $trait"; + $meta->add_method( $meth->name, $meth->clone ); } } - else { - my @super = ( $trait, ref($self) ); - - my $meta = Class::MOP::Class->initialize($class_name); - $meta->superclasses(@super); - $meta->make_immutable; - - return $class_name; - } + return $class_name; } sub _remove_inlined_code { @@ -1410,7 +1420,11 @@ does nothing; it is merely a hook. This method is used to create a new object of the metaclass's class. Any parameters you provide are used to initialize the -instance's attributes. +instance's attributes. A special C<__INSTANCE__> key can be passed to +provide an already generated instance, rather than having Class::MOP +generate it for you. This is mostly useful for using Class::MOP with +foreign classes, which generally generate instances using their own +constructor. =item B<< $metaclass->instance_metaclass >> @@ -1613,10 +1627,10 @@ attributes which are defined in terms of "regular" Perl 5 methods. This will return a L for the specified C<$attribute_name>. If the class does not have the specified -attribute, it returns C. +attribute, it returns C. -NOTE that get_attribute does not search superclasses, for -that you need to use C. +NOTE that get_attribute does not search superclasses, for that you +need to use C. =item B<< $metaclass->has_attribute($attribute_name) >> @@ -1727,7 +1741,7 @@ destructor. The name of a class which will be used as a parent class for the metaclass object being made immutable. This "trait" implements the -post-immutability functionlity of the metaclass (but not the +post-immutability functionality of the metaclass (but not the transformation itself). This defaults to L.