X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=d35f95939bfbd7ae353c197c09e7dfdb9262f933;hb=7c38ac19ef7f318f4d1134201ac004672b726668;hp=05839111601fd0adfa63138e023d5e0cc5c944e5;hpb=1cbf42dfef434a0e64d840c3c4238dc33b9abe86;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 0583911..d35f959 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.80'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -41,11 +41,11 @@ sub initialize { sub construct_class_instance { warn 'The construct_class_instance method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"; - goto &_construct_class_instance; + shift->_construct_class_instance; } # NOTE: (meta-circularity) -# this is a special form of &construct_instance +# this is a special form of _construct_instance # (see below), which is used to construct class # meta-object instances for any Class::MOP::* # class. All other classes will use the more @@ -79,15 +79,14 @@ 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: # it is safe to use meta here because # class will always be a subclass of # Class::MOP::Class, which defines meta - $meta = $class->meta->construct_instance($options) + $meta = $class->meta->_construct_instance($options) } # and check the metaclass compatibility @@ -157,7 +156,7 @@ sub update_package_cache_flag { sub check_metaclass_compatibility { warn 'The check_metaclass_compatibility method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"; - goto &_check_metaclass_compatibility; + shift->_check_metaclass_compatibility; } sub _check_metaclass_compatibility { @@ -183,16 +182,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) . ")"; } } @@ -277,8 +277,6 @@ sub create { || confess "You must pass a HASH ref of methods" if exists $options{methods}; - $class->SUPER::create(%options); - my (%initialize_options) = @args; delete @initialize_options{qw( package @@ -290,6 +288,8 @@ sub create { )}; my $meta = $class->initialize( $package_name => %initialize_options ); + $meta->_instantiate_module( $options{version}, $options{authority} ); + # FIXME totally lame $meta->add_method('meta' => sub { $class->initialize(ref($_[0]) || $_[0]); @@ -339,15 +339,21 @@ sub new_object { # which will deal with the singletons return $class->_construct_class_instance(@_) if $class->name->isa('Class::MOP::Class'); - return $class->construct_instance(@_); + return $class->_construct_instance(@_); } sub construct_instance { + warn 'The construct_instance method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"; + shift->_construct_instance; +} + +sub _construct_instance { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; my $meta_instance = $class->get_meta_instance(); my $instance = $meta_instance->create_instance(); - foreach my $attr ($class->compute_all_applicable_attributes()) { + foreach my $attr ($class->get_all_attributes()) { $attr->initialize_instance_slot($meta_instance, $instance, $params); } # NOTE: @@ -374,7 +380,7 @@ sub get_meta_instance { sub create_meta_instance { warn 'The create_meta_instance method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"; - goto &_create_meta_instance; + shift->_create_meta_instance; } sub _create_meta_instance { @@ -382,7 +388,7 @@ sub _create_meta_instance { my $instance = $self->instance_metaclass->new( associated_metaclass => $self, - attributes => [ $self->compute_all_applicable_attributes() ], + attributes => [ $self->get_all_attributes() ], ); $self->add_meta_instance_dependencies() @@ -408,7 +414,7 @@ sub clone_object { sub clone_instance { warn 'The clone_instance method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"; - goto &_clone_instance; + shift->_clone_instance; } sub _clone_instance { @@ -417,7 +423,7 @@ sub _clone_instance { || confess "You can only clone instances, ($instance) is not a blessed instance"; my $meta_instance = $class->get_meta_instance(); my $clone = $meta_instance->clone_instance($instance); - foreach my $attr ($class->compute_all_applicable_attributes()) { + foreach my $attr ($class->get_all_attributes()) { if ( defined( my $init_arg = $attr->init_arg ) ) { if (exists $params{$init_arg}) { $attr->set_value($clone, $params{$init_arg}); @@ -430,26 +436,22 @@ 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."; + + $old_metaclass->rebless_instance_away($instance, $self, %params) + if $old_metaclass; - $self->name->isa($old_metaclass->name) - || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't."; + my $meta_instance = $self->get_meta_instance(); # rebless! # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8 $meta_instance->rebless_instance_structure($_[1], $self); - foreach my $attr ( $self->compute_all_applicable_attributes ) { + foreach my $attr ( $self->get_all_attributes ) { if ( $attr->has_value($instance) ) { if ( defined( my $init_arg = $attr->init_arg ) ) { $params{$init_arg} = $attr->get_value($instance) @@ -461,13 +463,17 @@ sub rebless_instance { } } - foreach my $attr ($self->compute_all_applicable_attributes) { + foreach my $attr ($self->get_all_attributes) { $attr->initialize_instance_slot($meta_instance, $instance, \%params); } $instance; } +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + # Inheritance sub superclasses { @@ -499,51 +505,9 @@ sub superclasses { sub subclasses { my $self = shift; - my $super_class = $self->name; - if ( Class::MOP::HAVE_ISAREV() ) { - return @{ $super_class->mro::get_isarev() }; - } else { - my @derived_classes; - - my $find_derived_classes; - $find_derived_classes = sub { - my ($outer_class) = @_; - - my $symbol_table_hashref = do { no strict 'refs'; \%{"${outer_class}::"} }; - - SYMBOL: - for my $symbol ( keys %$symbol_table_hashref ) { - next SYMBOL if $symbol !~ /\A (\w+):: \z/x; - my $inner_class = $1; - - next SYMBOL if $inner_class eq 'SUPER'; # skip '*::SUPER' - - my $class = - $outer_class - ? "${outer_class}::$inner_class" - : $inner_class; - - if ( $class->isa($super_class) and $class ne $super_class ) { - push @derived_classes, $class; - } - - next SYMBOL if $class eq 'main'; # skip 'main::*' - - $find_derived_classes->($class); - } - }; - - my $root_class = q{}; - $find_derived_classes->($root_class); - - undef $find_derived_classes; - - @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes; - - return @derived_classes; - } + return @{ $super_class->mro::get_isarev() }; } @@ -707,7 +671,7 @@ sub add_method { sub alias_method { warn "The alias_method method is deprecated. Use add_method instead.\n"; - goto &add_method; + shift->add_method; } sub has_method { @@ -871,7 +835,7 @@ sub add_meta_instance_dependencies { $self->remove_meta_instance_dependencies; - my @attrs = $self->compute_all_applicable_attributes(); + my @attrs = $self->get_all_attributes(); my %seen; my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs; @@ -956,15 +920,18 @@ sub get_attribute_list { } sub get_all_attributes { - shift->compute_all_applicable_attributes(@_); -} - -sub compute_all_applicable_attributes { my $self = shift; my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; return values %attrs; } +sub compute_all_applicable_attributes { + warn 'The compute_all_applicable_attributes method has been deprecated.' + . " Use get_all_attributes instead.\n"; + + shift->get_all_attributes; +} + sub find_attribute_by_name { my ($self, $attr_name) = @_; foreach my $class ($self->linearized_isa) { @@ -1000,108 +967,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 immutable_transformer { $_[0]->{immutable_transformer} } +sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } - 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 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', + get_all_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 @@ -1110,8 +1025,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; @@ -1292,6 +1228,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 @@ -1302,7 +1244,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 >> @@ -1467,6 +1409,17 @@ track the original source of any methods added from other classes 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 @@ -1506,8 +1459,6 @@ defined in this class. This will traverse the inheritance hierarchy and return a list of all the L objects for this class and its parents. -This method can also be called as C. - =item B<< $metaclass->find_attribute_by_name($attribute_name) >> This will return a L for the specified @@ -1576,7 +1527,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