X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=482797eeda0231be30ff392b21250385b6e88c71;hb=e473d0c6ec8f263e033140df7f17e5e1c78cedda;hp=6a049b81b675120b447148e68fdfdc683649b122;hpb=1595882a8260310502859380c4af9d1bc58f49f5;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 6a049b8..482797e 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,7 +11,7 @@ use Class::MOP::Method::Wrapped; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.78'; +our $VERSION = '0.79'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -73,8 +73,7 @@ sub construct_class_instance { # now create the metaclass my $meta; if ($class eq 'Class::MOP::Class') { - no strict 'refs'; - $meta = $class->_new($options) + $meta = $class->_new($options); } else { # NOTE: @@ -170,16 +169,17 @@ sub check_metaclass_compatibility { : ref($super_meta); ($self->isa($super_meta_type)) - || confess $self->name . "->meta => (" . (ref($self)) . ")" . - " is not compatible with the " . - $superclass_name . "->meta => (" . ($super_meta_type) . ")"; + || confess "Class::MOP::class_of(" . $self->name . ") => (" + . (ref($self)) . ")" . " is not compatible with the " . + "Class::MOP::class_of(".$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 $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" . + || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" . " is not compatible with the " . - $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; + "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; } } @@ -405,20 +405,16 @@ sub clone_instance { sub rebless_instance { my ($self, $instance, %params) = @_; - my $old_metaclass; - if ($instance->can('meta')) { - ($instance->meta->isa('Class::MOP::Class')) - || confess 'Cannot rebless instance if ->meta is not an instance of Class::MOP::Class'; - $old_metaclass = $instance->meta; - } - else { - $old_metaclass = $self->initialize(ref($instance)); - } + my $old_metaclass = Class::MOP::class_of($instance); - my $meta_instance = $self->get_meta_instance(); + my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance); + $self->name->isa($old_class) + || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't."; - $self->name->isa($old_metaclass->name) - || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't."; + $old_metaclass->rebless_instance_away($instance, $self, %params) + if $old_metaclass; + + my $meta_instance = $self->get_meta_instance(); # rebless! # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8 @@ -443,6 +439,10 @@ sub rebless_instance { $instance; } +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + # Inheritance sub superclasses { @@ -973,108 +973,56 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } -# NOTE: -# Why I changed this (groditi) -# - One Metaclass may have many Classes through many Metaclass instances -# - One Metaclass should only have one Immutable Transformer instance -# - Each Class may have different Immutabilizing options -# - Therefore each Metaclass instance may have different Immutabilizing options -# - We need to store one Immutable Transformer instance per Metaclass -# - We need to store one set of Immutable Transformer options per Class -# - Upon make_mutable we may delete the Immutabilizing options -# - We could clean the immutable Transformer instance when there is no more -# immutable Classes of that type, but we can also keep it in case -# another class with this same Metaclass becomes immutable. It is a case -# of trading of storing an instance to avoid unnecessary instantiations of -# Immutable Transformers. You may view this as a memory leak, however -# Because we have few Metaclasses, in practice it seems acceptable -# - To allow Immutable Transformers instances to be cleaned up we could weaken -# the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM - -{ - - my %IMMUTABLE_TRANSFORMERS; - my %IMMUTABLE_OPTIONS; - - sub get_immutable_options { - my $self = shift; - return if $self->is_mutable; - confess "unable to find immutabilizing options" - unless exists $IMMUTABLE_OPTIONS{$self->name}; - my %options = %{$IMMUTABLE_OPTIONS{$self->name}}; - delete $options{IMMUTABLE_TRANSFORMER}; - return \%options; - } - - sub get_immutable_transformer { - my $self = shift; - if( $self->is_mutable ){ - return $IMMUTABLE_TRANSFORMERS{$self->name} ||= $self->create_immutable_transformer; - } - confess "unable to find transformer for immutable class" - unless exists $IMMUTABLE_OPTIONS{$self->name}; - return $IMMUTABLE_OPTIONS{$self->name}->{IMMUTABLE_TRANSFORMER}; - } +sub immutable_transformer { $_[0]->{immutable_transformer} } +sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } - sub make_immutable { - my $self = shift; - my %options = @_; +sub make_immutable { + my $self = shift; - my $transformer = $self->get_immutable_transformer; - $transformer->make_metaclass_immutable($self, \%options); - $IMMUTABLE_OPTIONS{$self->name} = - { %options, IMMUTABLE_TRANSFORMER => $transformer }; + return if $self->is_immutable; - if( exists $options{debug} && $options{debug} ){ - print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; - print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS; - } + my $transformer = $self->immutable_transformer + || $self->_make_immutable_transformer(@_); - 1; - } + $self->_set_immutable_transformer($transformer); - sub make_mutable{ - my $self = shift; - return if $self->is_mutable; - my $options = delete $IMMUTABLE_OPTIONS{$self->name}; - confess "unable to find immutabilizing options" unless ref $options; - my $transformer = delete $options->{IMMUTABLE_TRANSFORMER}; - $transformer->make_metaclass_mutable($self, $options); - 1; - } + $transformer->make_metaclass_immutable; } -sub create_immutable_transformer { - my $self = shift; - my $class = Class::MOP::Immutable->new($self, { +{ + my %Default_Immutable_Options = ( read_only => [qw/superclasses/], - cannot_call => [qw/ - add_method - alias_method - remove_method - add_attribute - remove_attribute - remove_package_symbol - /], - memoize => { - class_precedence_list => 'ARRAY', - linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need? - get_all_methods => 'ARRAY', - get_all_method_names => 'ARRAY', - #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', + cannot_call => [ + qw( + add_method + alias_method + remove_method + add_attribute + remove_attribute + remove_package_symbol + ) + ], + memoize => { + class_precedence_list => 'ARRAY', + # FIXME perl 5.10 memoizes this on its own, no need? + linearized_isa => 'ARRAY', + get_all_methods => 'ARRAY', + get_all_method_names => 'ARRAY', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', }, + # NOTE: - # this is ugly, but so are typeglobs, + # this is ugly, but so are typeglobs, # so whattayahgonnadoboutit # - SL - wrapped => { + wrapped => { add_package_symbol => sub { my $original = shift; - confess "Cannot add package symbols to an immutable metaclass" - unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol'; + confess "Cannot add package symbols to an immutable metaclass" + unless ( caller(2) )[3] eq + 'Class::MOP::Package::get_package_symbol'; # This is a workaround for a bug in 5.8.1 which thinks that # goto $original->body @@ -1083,8 +1031,29 @@ sub create_immutable_transformer { goto $body; }, }, - }); - return $class; + ); + + sub _default_immutable_transformer_options { + return %Default_Immutable_Options; + } +} + +sub _make_immutable_transformer { + my $self = shift; + + Class::MOP::Immutable->new( + $self, + $self->_default_immutable_transformer_options, + @_ + ); +} + +sub make_mutable { + my $self = shift; + + return if $self->is_mutable; + + $self->immutable_transformer->make_metaclass_mutable; } 1; @@ -1133,11 +1102,11 @@ Class::MOP::Class - Class Meta Object =head1 DESCRIPTION -This is the largest and most complex part of the Class::MOP -meta-object protocol. It controls the introspection and manipulation -of Perl 5 classes, and it can create them as wlel. The best way to -understand what this module can do, is to read the documentation for -each of its methods. +The Class Protocol is the largest and most complex part of the +Class::MOP meta-object protocol. It controls the introspection and +manipulation of Perl 5 classes, and it can create them as well. The +best way to understand what this module can do, is to read the +documentation for each of its methods. =head1 INHERITANCE @@ -1245,7 +1214,7 @@ instances. This method clones an existing object instance. Any parameters you provide are will override existing attribute values in the object. -This is a convience method for cloning an object instance, then +This is a convenience method for cloning an object instance, then blessing it into the appropriate package. You could implement a clone method in your class, using this method: @@ -1265,6 +1234,12 @@ like constructor parameters and used to initialize the object's attributes. Any existing attributes that are already set will be overwritten. +Before reblessing the instance, this method will call +C on the instance's current metaclass. This method +will be passed the instance, the new metaclass, and any parameters +specified to C. By default, C +does nothing; it is merely a hook. + =item B<< $metaclass->new_object(%params) >> This method is used to create a new object of the metaclass's @@ -1275,7 +1250,7 @@ instance's attributes. Returns the class name of the instance metaclass, see L for more information on the instance -metaclasses. +metaclass. =item B<< $metaclass->get_meta_instance >> @@ -1419,6 +1394,38 @@ This method returns the first method in any superclass matching the given name. It is effectively the method that C would dispatch to. +=item B<< $metaclass->add_method($method_name, $method) >> + +This method takes a method name and a subroutine reference, and adds +the method to the class. + +The subroutine reference can be a L, and you are +strongly encouraged to pass a meta method object instead of a code +reference. If you do so, that object gets stored as part of the +class's method map directly. If not, the meta information will have to +be recreated later, and may be incorrect. + +If you provide a method object, this method will clone that object if +the object's package name does not match the class name. This lets us +track the original source of any methods added from other classes +(notably Moose roles). + +=item B<< $metaclass->remove_method($method_name) >> + +Remove the named method from the class. This method returns the +L object for the method. + +=item B<< $metaclass->method_metaclass >> + +Returns the class name of the method metaclass, see +L for more information on the method metaclass. + +=item B<< $metaclass->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L for more information on the wrapped +method metaclass. + =back =head2 Attribute introspection and creation @@ -1507,7 +1514,7 @@ Making a class immutable "freezes" the class definition. You can no longer call methods which alter the class, such as adding or removing methods or attributes. -Making a class immutable lets us optimize the class by inlning some +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. @@ -1528,7 +1535,7 @@ documentation. Calling this method reverse the immutabilization transformation. -=item B<< $metaclass->get_immutable_transformer >> +=item B<< $metaclass->immutable_transformer >> If the class has been made immutable previously, this returns the L object that was created to do the @@ -1551,8 +1558,8 @@ parent classes. Method modifiers work by wrapping the original method and then replacing it in the class's symbol table. The wrappers will handle -calling all the modifiers in the appropariate orders and preserving -the calling context for the original method. +calling all the modifiers in the appropriate order and preserving the +calling context for the original method. The return values of C and C modifiers are ignored. This is because their purpose is B to filter the input @@ -1644,6 +1651,20 @@ The return value of the modifier is what will be seen by the caller. =back +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Class->meta >> + +This will return a L instance for this class. + +It should also be noted that L will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + =head1 AUTHORS Stevan Little Estevan@iinteractive.comE