X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=eaa838dc961230e928e31b4aad146d74c1ab0d3c;hb=33ecbaa40bbcda7518cb3e5477d357e6b3d95ff6;hp=249d6a872522006c5a4fc8616c9095a66532a879;hpb=44d6ea77ff5ddf47824a680d3fe11a2263290ed0;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 249d6a8..eaa838d 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'; @@ -35,16 +35,22 @@ sub initialize { || confess "You must pass a package name and it cannot be blessed"; return Class::MOP::get_metaclass_by_name($package_name) - || $class->construct_class_instance(package => $package_name, @_); + || $class->_construct_class_instance(package => $package_name, @_); +} + +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"; + 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 # normal &construct_instance. -sub construct_class_instance { +sub _construct_class_instance { my $class = shift; my $options = @_ == 1 ? $_[0] : {@_}; my $package_name = $options->{package}; @@ -80,11 +86,11 @@ sub construct_class_instance { # 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 - $meta->check_metaclass_compatibility(); + $meta->_check_metaclass_compatibility(); Class::MOP::store_metaclass_by_name($package_name, $meta); @@ -146,7 +152,14 @@ sub update_package_cache_flag { $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } + 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"; + shift->_check_metaclass_compatibility; +} + +sub _check_metaclass_compatibility { my $self = shift; # this is always okay ... @@ -169,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) . ")"; } } @@ -263,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 @@ -276,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]); @@ -323,17 +337,23 @@ sub new_object { # Class::MOP::Class singletons here, so we # delegate this to &construct_class_instance # which will deal with the singletons - return $class->construct_class_instance(@_) + 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: @@ -354,15 +374,21 @@ sub construct_instance { sub get_meta_instance { my $self = shift; - $self->{'_meta_instance'} ||= $self->create_meta_instance(); + $self->{'_meta_instance'} ||= $self->_create_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"; + shift->_create_meta_instance; +} + +sub _create_meta_instance { my $self = shift; 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() @@ -382,16 +408,22 @@ sub clone_object { # Class::MOP::Class singletons here, they # should not be cloned. return $instance if $instance->isa('Class::MOP::Class'); - $class->clone_instance($instance, @_); + $class->_clone_instance($instance, @_); } 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"; + shift->_clone_instance; +} + +sub _clone_instance { my ($class, $instance, %params) = @_; (blessed($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}); @@ -404,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."; - $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 $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) @@ -435,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 { @@ -465,7 +497,7 @@ sub superclasses { # not potentially creating an issues # we don't know about - $self->check_metaclass_compatibility(); + $self->_check_metaclass_compatibility(); $self->update_meta_instance_dependencies(); } @{$self->get_package_symbol($var_spec)}; @@ -473,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() }; } @@ -679,9 +669,9 @@ sub add_method { } sub alias_method { - my $self = shift; + warn "The alias_method method is deprecated. Use add_method instead.\n"; - $self->add_method(@_); + shift->add_method; } sub has_method { @@ -742,8 +732,10 @@ sub get_all_methods { return values %methods; } -# compatibility sub compute_all_applicable_methods { + warn 'The compute_all_applicable_methods method is deprecated.' + . " Use get_all_methods instead.\n"; + return map { { name => $_->name, @@ -843,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; @@ -928,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 construct_class_instance 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) { @@ -975,18 +970,31 @@ sub is_immutable { 0 } sub immutable_transformer { $_[0]->{immutable_transformer} } sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } +sub make_immutable { + my $self = shift; + + return if $self->is_immutable; + + my $transformer = $self->immutable_transformer + || $self->_make_immutable_transformer(@_); + + $self->_set_immutable_transformer($transformer); + + $transformer->make_metaclass_immutable; +} + { my %Default_Immutable_Options = ( read_only => [qw/superclasses/], cannot_call => [ - qw/ + qw( add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol - / + ) ], memoize => { class_precedence_list => 'ARRAY', @@ -1019,22 +1027,19 @@ sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } }, ); - sub make_immutable { - my $self = shift; - - return if $self->is_immutable; - - my $transformer = $self->immutable_transformer - || Class::MOP::Immutable->new( - $self, - %Default_Immutable_Options, - @_ - ); + sub _default_immutable_transformer_options { + return %Default_Immutable_Options; + } +} - $self->_set_immutable_transformer($transformer); +sub _make_immutable_transformer { + my $self = shift; - $transformer->make_metaclass_immutable; - } + Class::MOP::Immutable->new( + $self, + $self->_default_immutable_transformer_options, + @_ + ); } sub make_mutable { @@ -1091,11 +1096,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 @@ -1203,7 +1208,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: @@ -1223,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 @@ -1233,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 >> @@ -1398,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 @@ -1437,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 @@ -1486,7 +1506,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. @@ -1530,8 +1550,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 @@ -1623,6 +1643,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