X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=f4c8a4e8634389b78f6f40885b32014ff0604af5;hb=b7e0449689a12fc26b602e0880078a99e56aaa8d;hp=41fc05995f5eda49014fb9f9c2ddf64855ab28d7;hpb=943cbe2dc6895a397ba6cc20469eb26e04933472;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 41fc059..f4c8a4e 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -15,7 +15,7 @@ use Scalar::Util 'blessed', 'weaken'; use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; -our $VERSION = '0.83'; +our $VERSION = '0.88'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -371,7 +371,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); } @@ -517,11 +521,16 @@ sub superclasses { # we don't know about $self->_check_metaclass_compatibility(); - $self->update_meta_instance_dependencies(); + $self->_superclasses_updated(); } @{$self->get_package_symbol($var_spec)}; } +sub _superclasses_updated { + my $self = shift; + $self->update_meta_instance_dependencies(); +} + sub subclasses { my $self = shift; my $super_class = $self->name; @@ -529,6 +538,16 @@ sub subclasses { return @{ $super_class->mro::get_isarev() }; } +sub direct_subclasses { + my $self = shift; + my $super_class = $self->name; + + return grep { + grep { + $_ eq $super_class + } Class::MOP::Class->initialize($_)->superclasses + } $self->subclasses; +} sub linearized_isa { return @{ mro::get_linear_isa( (shift)->name ) }; @@ -604,15 +623,18 @@ sub add_method { $method->attach_to_class($self); - # This used to call get_method_map, which meant we would build all - # the method objects for the class just because we added one - # method. This is hackier, but quicker too. - $self->{methods}{$method_name} = $method; - - my $full_method_name = ($self->name . '::' . $method_name); + $self->get_method_map->{$method_name} = $method; + + my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); + + if ( !defined $current_name || $current_name eq '__ANON__' ) { + my $full_method_name = ($self->name . '::' . $method_name); + subname($full_method_name => $body); + } + $self->add_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name }, - subname($full_method_name => $body) + { sigil => '&', type => 'CODE', name => $method_name }, + $body, ); } @@ -698,7 +720,7 @@ sub has_method { (defined $method_name && $method_name) || confess "You must define a method name"; - exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name}; + exists $self->get_method_map->{$method_name}; } sub get_method { @@ -706,7 +728,7 @@ sub get_method { (defined $method_name && $method_name) || confess "You must define a method name"; - return $self->{methods}{$method_name} || $self->get_method_map->{$method_name}; + return $self->get_method_map->{$method_name}; } sub remove_method { @@ -837,7 +859,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; @@ -990,7 +1017,6 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } -sub immutable_transformer { return } sub _immutable_options { my ( $self, @args ) = @_; @@ -1059,15 +1085,13 @@ 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) ) { @@ -1082,7 +1106,7 @@ sub _immutable_metaclass { else { my @super = ( $trait, ref($self) ); - my $meta = Class::MOP::Class->initialize($class_name); + my $meta = $self->initialize($class_name); $meta->superclasses(@super); $meta->make_immutable; @@ -1144,11 +1168,7 @@ sub _inline_constructor { my $name = $args{constructor_name}; - #if ( my $existing = $self->name->can($args{constructor_name}) ) { - # if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) { - - unless ( $args{replace_constructor} - or !$self->has_method($name) ) { + if ( $self->has_method($name) && !$args{replace_constructor} ) { my $class = $self->name; warn "Not inlining a constructor for $class since it defines" . " its own constructor.\n" @@ -1179,10 +1199,17 @@ sub _inline_constructor { sub _inline_destructor { my ( $self, %args ) = @_; - ( exists $args{destructor_class} ) + ( exists $args{destructor_class} && defined $args{destructor_class} ) || confess "The 'inline_destructor' option is present, but " . "no destructor class was specified"; + if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) { + my $class = $self->name; + warn "Not inlining a destructor for $class since it defines" + . " its own destructor.\n"; + return; + } + my $destructor_class = $args{destructor_class}; Class::MOP::load_class($destructor_class); @@ -1196,9 +1223,10 @@ sub _inline_destructor { name => 'DESTROY' ); - $self->add_method( 'DESTROY' => $destructor ); - - $self->_add_inlined_method($destructor); + if ( $args{replace_destructor} or $destructor->can_be_inlined ) { + $self->add_method( 'DESTROY' => $destructor ); + $self->_add_inlined_method($destructor); + } } 1; @@ -1389,7 +1417,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 >> @@ -1454,7 +1486,13 @@ duplicates removed. =item B<< $metaclass->subclasses >> -This returns a list of subclasses for this class. +This returns a list of all subclasses for this class, even indirect +subclasses. + +=item B<< $metaclass->direct_subclasses >> + +This returns a list of immediate subclasses for this class, which does not +include indirect subclasses. =back @@ -1586,7 +1624,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. =item B<< $metaclass->has_attribute($attribute_name) >> @@ -1661,6 +1702,12 @@ Making a class immutable lets us optimize the class by inlining some methods, and also allows us to optimize some methods on the metaclass object itself. +After immutabilization, the metaclass object will cache most +informational methods such as C and +C. Methods which would alter the class, such as +C, C, and so on will throw an error on an +immutable metaclass object. + The immutabilization system in L takes much greater advantage of the inlining features than Class::MOP itself does. @@ -1671,20 +1718,62 @@ of the inlining features than Class::MOP itself does. This method will create an immutable transformer and uses it to make the class and its metaclass object immutable. -Details of how immutabilization works are in L -documentation. +This method accepts the following options: -=item B<< $metaclass->make_mutable >> +=over 8 -Calling this method reverse the immutabilization transformation. +=item * inline_accessors + +=item * inline_constructor + +=item * inline_destructor + +These are all booleans indicating whether the specified method(s) +should be inlined. + +By default, accessors and the constructor are inlined, but not the +destructor. + +=item * immutable_trait + +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 functionality of the metaclass (but not the +transformation itself). + +This defaults to L. + +=item * constructor_name -=item B<< $metaclass->immutable_transformer >> +This is the constructor method name. This defaults to "new". -If the class has been made immutable previously, this returns the -L object that was created to do the -transformation. +=item * constructor_class -If the class was never made immutable, this method will die. +The name of the method metaclass for constructors. It will be used to +generate the inlined constructor. This defaults to +"Class::MOP::Method::Constructor". + +=item * replace_constructor + +This is a boolean indicating whether an existing constructor should be +replaced when inlining a constructor. This defaults to false. + +=item * destructor_class + +The name of the method metaclass for destructors. It will be used to +generate the inlined destructor. This defaults to +"Class::MOP::Method::Denstructor". + +=item * replace_destructor + +This is a boolean indicating whether an existing destructor should be +replaced when inlining a destructor. This defaults to false. + +=back + +=item B<< $metaclass->make_mutable >> + +Calling this method reverse the immutabilization transformation. =back