From: Yuval Kogman Date: Thu, 27 Apr 2006 22:21:53 +0000 (+0000) Subject: The great Class::MOP::Instance refactoring X-Git-Tag: 0_29_02~45 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2d711cc8f03b6d8cbfe53f9628883ff33582ed03;p=gitmo%2FClass-MOP.git The great Class::MOP::Instance refactoring --- diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod index 8e84dbd..8a3dabc 100644 --- a/examples/ClassEncapsulatedAttributes.pod +++ b/examples/ClassEncapsulatedAttributes.pod @@ -12,23 +12,25 @@ use base 'Class::MOP::Class'; sub initialize { (shift)->SUPER::initialize(@_, # use the custom attribute metaclass here - ':attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute' + ':attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', ); } sub construct_instance { my ($class, %params) = @_; - my $meta_instance = Class::MOP::Instance->new($class); + + my $instance = $class->get_meta_instance->create_instance(); + + # initialize *ALL* attributes, including masked ones (as opposed to applicable) foreach my $current_class ($class->class_precedence_list()) { - $meta_instance->add_slot($current_class => {}) - unless $meta_instance->has_slot($current_class); my $meta = $current_class->meta; foreach my $attr_name ($meta->get_attribute_list()) { my $attr = $meta->get_attribute($attr_name); - $attr->initialize_instance_slot($meta, $meta_instance, \%params); + $attr->initialize_instance_slot($instance, \%params); } } - return $meta_instance->get_instance; + + return $instance; } package # hide the package from PAUSE @@ -41,64 +43,35 @@ our $VERSION = '0.04'; use base 'Class::MOP::Attribute'; +# alter the way parameters are specified sub initialize_instance_slot { - my ($self, $class, $meta_instance, $params) = @_; + my ($self, $instance, $params) = @_; # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $self->init_arg(); # try to fetch the init arg from the %params ... - my $val; + my $class = $self->associated_class; + my $val; $val = $params->{$class->name}->{$init_arg} if exists $params->{$class->name} && exists ${$params->{$class->name}}{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) if (!defined $val && $self->has_default) { - $val = $self->default($meta_instance->get_instance); + $val = $self->default($instance); } - # now add this to the instance structure - $meta_instance->get_slot_value( - $meta_instance->get_instance, - $class->name - )->{$self->name} = $val; -} -sub generate_accessor_method { - my ($self, $attr_name) = @_; - my $class_name = $self->associated_class->name; - eval qq{sub { - \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; - \$_[0]->{'$class_name'}->{'$attr_name'}; - }}; -} - -sub generate_reader_method { - my ($self, $attr_name) = @_; - my $class_name = $self->associated_class->name; - eval qq{sub { - Carp::confess "Cannot assign a value to a read-only accessor" if \@_ > 1; - \$_[0]->{'$class_name'}->{'$attr_name'}; - }}; -} - -sub generate_writer_method { - my ($self, $attr_name) = @_; - my $class_name = $self->associated_class->name; - eval qq{sub { - \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1]; - }}; + # now add this to the instance structure + my $meta_instance = $self->associated_class->get_meta_instance; + $meta_instance->set_slot_value_with_init( $instance, $self->slot_name, $val ); } -sub generate_predicate_method { - my ($self, $attr_name) = @_; - my $class_name = $self->associated_class->name; - eval qq{sub { - defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0; - }}; +# mangle the slot name to include the fully qualified attr +sub slot_name { + my $self = shift; + $self->associated_class->name . "::" . $self->SUPER::slot_name; } -## &remove_attribute is left as an exercise for the reader :) - 1; __END__ diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index ec1d21b..0213973 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -1,7 +1,7 @@ package # hide the package from PAUSE - InsideOutClass::Attribute; + InsideOutClass::Instance; use strict; use warnings; @@ -11,57 +11,43 @@ our $VERSION = '0.06'; use Carp 'confess'; use Scalar::Util 'refaddr'; -use base 'Class::MOP::Attribute'; - -sub initialize_instance_slot { - my ($self, $class, $meta_instance, $params) = @_; - # if the attr has an init_arg, use that, otherwise, - # use the attributes name itself as the init_arg - my $init_arg = $self->init_arg(); - # try to fetch the init arg from the %params ... - my $val; - $val = $params->{$init_arg} if exists $params->{$init_arg}; - # if nothing was in the %params, we can use the - # attribute's default value (if it has one) - if (!defined $val && $self->has_default) { - $val = $self->default($meta_instance->get_instance); - } - # now add this to the instance structure - $class->get_package_variable('%' . $self->name)->{ refaddr($meta_instance->get_instance) } = $val; +use base 'Class::MOP::Instance'; + +sub create_instance { + my ( $self, $class ) = @_; + my $x; + bless \$x, $class || $self->{meta}->name; } -sub generate_accessor_method { - my ($self, $attr_name) = @_; - $attr_name = ($self->associated_class->name . '::' . $attr_name); - eval 'sub { - $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; - $' . $attr_name . '{ refaddr($_[0]) }; - }'; +sub add_slot { + my ( $self, $slot_name ) = @_; + $self->{containers}{$slot_name} = do { + my $fqn = $self->{meta}->name . "::" . $slot_name; + no strict 'refs'; + \%$fqn; + }; + $self->SUPER::add_slot( $slot_name ); } -sub generate_reader_method { - my ($self, $attr_name) = @_; - eval 'sub { - confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }; - }'; +sub get_slot_value { + my ( $self, $instance, $slot_name ) = @_; + confess "$self is no instance" unless ref $self; + $self->{containers}{$slot_name}{refaddr $instance}; } -sub generate_writer_method { - my ($self, $attr_name) = @_; - eval 'sub { - $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) } = $_[1]; - }'; +sub set_slot_value { + my ( $self, $instance, $slot_name, $value ) = @_; + $self->{containers}{$slot_name}{refaddr $instance} = $value; } -sub generate_predicate_method { - my ($self, $attr_name) = @_; - eval 'sub { - defined($' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }) ? 1 : 0; - }'; +sub initialize_slot { } + +sub slot_initialized { + my ( $self, $instance, $slot_name ) = @_; + exists $self->{containers}{$slot_name}{refaddr $instance}; } -## &remove_attribute is left as an exercise for the reader :) +## &remove_slot is left as an exercise for the reader :) 1; @@ -81,7 +67,7 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec # tell our metaclass to use the # InsideOut attribute metclass # to construct all it's attributes - ':attribute_metaclass' => 'InsideOutClass::Attribute' + ':instance_metaclass' => 'InsideOutClass::Instance' ); __PACKAGE__->meta->add_attribute('foo' => ( @@ -102,22 +88,26 @@ This is a set of example metaclasses which implement the Inside-Out class technique. What follows is a brief explaination of the code found in this module. -We must create a subclass of B and override -the instance initialization and method generation code. This requires -overloading C, C, -C, C and -C. All other aspects are taken care of with -the existing B infastructure. +We must create a subclass of B and override +the slot operations. This requires +overloading C, C, C, and +C, as well as their inline counterparts. Additionally we +overload C in order to initialize the global hash containing the +actual slot values. And that is pretty much all. Of course I am ignoring need for inside-out objects to be C-ed, and some other details as -well, but this is an example. A real implementation is left as an -exercise to the reader. +well (threading, etc), but this is an example. A real implementation is left as +an exercise to the reader. =head1 AUTHOR Stevan Little Estevan@iinteractive.comE +=head1 SEE ALSO + +L + =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc. diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod index 3ce659b..38482ec 100644 --- a/examples/LazyClass.pod +++ b/examples/LazyClass.pod @@ -12,44 +12,55 @@ our $VERSION = '0.04'; use base 'Class::MOP::Attribute'; sub initialize_instance_slot { - my ($self, $class, $meta_instance, $params) = @_; + my ($self, $instance, $params) = @_; + # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $self->init_arg(); - # try to fetch the init arg from the %params ... - my $val; - $val = $params->{$init_arg} if exists $params->{$init_arg}; - # now add this to the instance structure - # only if we have found a value at all - $meta_instance->add_slot($self->name, $val) if defined $val; -} + if ( exists $params->{$init_arg} ) { + my $val = $params->{$init_arg}; + my $meta_instance = $self->associated_class->get_meta_instance; + $meta_instance->set_slot_value_with_init( $instance, $self->slot_name, $val); + } +} sub generate_accessor_method { - my ($self, $attr_name) = @_; + my $attr = shift; + + my $slot_name = $attr->slot_name; + my $meta_instance = $attr->associated_class->get_meta_instance; + sub { if (scalar(@_) == 2) { - $_[0]->{$attr_name} = $_[1]; + $meta_instance->set_slot_value_with_init( $_[0], $slot_name, $_[1] ); } else { - if (!exists $_[0]->{$attr_name}) { - my $attr = $self->associated_class->get_attribute($attr_name); - $_[0]->{$attr_name} = $attr->has_default ? $attr->default($_[0]) : undef; - } - $_[0]->{$attr_name}; + unless ( $meta_instance->slot_initialized( $_[0], $slot_name ) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value_with_init( $_[0], $slot_name, $value ); + } + + $meta_instance->get_slot_value( $_[0], $slot_name ); } }; } sub generate_reader_method { - my ($self, $attr_name) = @_; + my $attr = shift; + + my $slot_name = $attr->slot_name; + my $meta_instance = $attr->associated_class->get_meta_instance; + sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - if (!exists $_[0]->{$attr_name}) { - my $attr = $self->associated_class->get_attribute($attr_name); - $_[0]->{$attr_name} = $attr->has_default ? $attr->default($_[0]) : undef; - } - $_[0]->{$attr_name}; + + unless ( $meta_instance->slot_initialized( $_[0], $slot_name ) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value_with_init( $_[0], $slot_name, $value ); + } + + $meta_instance->get_slot_value( $_[0], $slot_name ); }; } @@ -121,4 +132,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 0677448..5e2563c 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -61,7 +61,7 @@ sub clone { } sub initialize_instance_slot { - my ($self, $class, $meta_instance, $params) = @_; + my ($self, $instance, $params) = @_; my $init_arg = $self->{init_arg}; # try to fetch the init arg from the %params ... my $val; @@ -69,9 +69,11 @@ sub initialize_instance_slot { # if nothing was in the %params, we can use the # attribute's default value (if it has one) if (!defined $val && defined $self->{default}) { - $val = $self->default($meta_instance->get_instance); - } - $meta_instance->add_slot($self->name, $val); + $val = $self->default($instance); + } + + my $meta_instance = $self->associated_class->get_meta_instance; + $meta_instance->set_slot_value_with_init( $instance, $self->slot_name, $val ); } # NOTE: @@ -124,39 +126,65 @@ sub detach_from_class { $self->{associated_class} = undef; } +# slot management + +sub slot_name { # when attr <-> slot mapping is 1:1 + my $self = shift; + $self->name; +} + +# slot alocation + +sub allocate_slots { + my $self = shift; + my $meta_instance = $self->associated_class->get_meta_instance; + $meta_instance->add_slot( $self->slot_name ); +} + +sub deallocate_slots { + my $self = shift; + my $meta_instance = $self->associated_class->get_meta_instance; + $meta_instance->remove_slot( $self->slot_name ); +} + ## Method generation helpers sub generate_accessor_method { my ($self, $attr_name) = @_; - my $meta_instance = $self->associated_class->instance_metaclass; + my $meta_instance = $self->associated_class->get_meta_instance; + my $slot_name = $self->slot_name; + sub { - $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; - $meta_instance->get_slot_value($_[0], $attr_name); + $meta_instance->set_slot_value($_[0], $slot_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $slot_name); }; } sub generate_reader_method { my ($self, $attr_name) = @_; - my $meta_instance = $self->associated_class->instance_metaclass; + my $meta_instance = $self->associated_class->get_meta_instance; + my $slot_name = $self->slot_name; sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $meta_instance->get_slot_value($_[0], $attr_name); + $meta_instance->get_slot_value($_[0], $slot_name); }; } sub generate_writer_method { my ($self, $attr_name) = @_; - my $meta_instance = $self->associated_class->instance_metaclass; + my $meta_instance = $self->associated_class->get_meta_instance; + my $slot_name = $self->slot_name; sub { - $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); + $meta_instance->set_slot_value($_[0], $slot_name, $_[1]); }; } sub generate_predicate_method { my ($self, $attr_name) = @_; - my $meta_instance = $self->associated_class->instance_metaclass; + my $meta_instance = $self->associated_class->get_meta_instance; + my $slot_name = $self->slot_name; sub { - $meta_instance->has_slot_value($_[0], $attr_name); + defined $meta_instance->get_slot_value($_[0], $slot_name); }; } @@ -458,6 +486,12 @@ These are all basic predicate methods for the values passed into C. =item B +=item B + +=item B + +=item B + =back =head2 Attribute Accessor generation diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 5ba6570..c0bebc4 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -52,13 +52,13 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } my $package_name = $options{':package'}; (defined $package_name && $package_name) || confess "You must pass a package name"; - # NOTE: - # return the metaclass if we have it cached, - # and it is still defined (it has not been - # reaped by DESTROY yet, which can happen - # annoyingly enough during global destruction) + # NOTE: + # return the metaclass if we have it cached, + # and it is still defined (it has not been + # reaped by DESTROY yet, which can happen + # annoyingly enough during global destruction) return $METAS{$package_name} - if exists $METAS{$package_name} && defined $METAS{$package_name}; + if exists $METAS{$package_name} && defined $METAS{$package_name}; $class = blessed($class) || $class; # now create the metaclass my $meta; @@ -179,11 +179,19 @@ sub new_object { sub construct_instance { my ($class, %params) = @_; - my $meta_instance = $class->instance_metaclass->new($class); + + my $instance = $class->get_meta_instance->create_instance(); + foreach my $attr ($class->compute_all_applicable_attributes()) { - $attr->initialize_instance_slot($class, $meta_instance, \%params); + $attr->initialize_instance_slot($instance, \%params); } - return $meta_instance->get_instance; + return $instance; +} + +sub get_meta_instance { + my $class = shift; + # make it work,.. *then* make it right ... # yeah that was my plan, i just thought we'll make it async + $class->{meta_instance} ||= $class->instance_metaclass->new( $class ); } sub clone_object { @@ -261,63 +269,63 @@ sub add_method { || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); - $method = $self->method_metaclass->wrap($method) unless blessed($method); - + $method = $self->method_metaclass->wrap($method) unless blessed($method); + no strict 'refs'; no warnings 'redefine'; *{$full_method_name} = subname $full_method_name => $method; } { - my $fetch_and_prepare_method = sub { - my ($self, $method_name) = @_; - # fetch it locally - my $method = $self->get_method($method_name); - # if we dont have local ... - unless ($method) { - # make sure this method even exists ... - ($self->find_next_method_by_name($method_name)) - || confess "The method '$method_name' is not found in the inherience hierarchy for this class"; - # if so, then create a local which just - # calls the next applicable method ... - $self->add_method($method_name => sub { - $self->find_next_method_by_name($method_name)->(@_); - }); - $method = $self->get_method($method_name); - } - - # now make sure we wrap it properly - # (if it isnt already) - unless ($method->isa('Class::MOP::Method::Wrapped')) { - $method = Class::MOP::Method::Wrapped->wrap($method); - $self->add_method($method_name => $method); - } - return $method; - }; - - sub add_before_method_modifier { - my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; - my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_before_modifier(subname ':before' => $method_modifier); - } - - sub add_after_method_modifier { - my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; - my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_after_modifier(subname ':after' => $method_modifier); - } - - sub add_around_method_modifier { - my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; - my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_around_modifier(subname ':around' => $method_modifier); - } + my $fetch_and_prepare_method = sub { + my ($self, $method_name) = @_; + # fetch it locally + my $method = $self->get_method($method_name); + # if we dont have local ... + unless ($method) { + # make sure this method even exists ... + ($self->find_next_method_by_name($method_name)) + || confess "The method '$method_name' is not found in the inherience hierarchy for this class"; + # if so, then create a local which just + # calls the next applicable method ... + $self->add_method($method_name => sub { + $self->find_next_method_by_name($method_name)->(@_); + }); + $method = $self->get_method($method_name); + } + + # now make sure we wrap it properly + # (if it isnt already) + unless ($method->isa('Class::MOP::Method::Wrapped')) { + $method = Class::MOP::Method::Wrapped->wrap($method); + $self->add_method($method_name => $method); + } + return $method; + }; + + sub add_before_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && $method_name) + || confess "You must pass in a method name"; + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_before_modifier(subname ':before' => $method_modifier); + } + + sub add_after_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && $method_name) + || confess "You must pass in a method name"; + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_after_modifier(subname ':after' => $method_modifier); + } + + sub add_around_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && $method_name) + || confess "You must pass in a method name"; + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_around_modifier(subname ':around' => $method_modifier); + } # NOTE: # the methods above used to be named like this: @@ -342,7 +350,7 @@ sub alias_method { || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); - $method = $self->method_metaclass->wrap($method) unless blessed($method); + $method = $self->method_metaclass->wrap($method) unless blessed($method); no strict 'refs'; no warnings 'redefine'; @@ -358,13 +366,13 @@ sub has_method { no strict 'refs'; return 0 if !defined(&{$sub_name}); - my $method = \&{$sub_name}; + my $method = \&{$sub_name}; return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name && - (svref_2object($method)->GV->NAME || '') ne '__ANON__'; - - # at this point we are relatively sure - # it is our method, so we bless/wrap it - $self->method_metaclass->wrap($method) unless blessed($method); + (svref_2object($method)->GV->NAME || '') ne '__ANON__'; + + # at this point we are relatively sure + # it is our method, so we bless/wrap it + $self->method_metaclass->wrap($method) unless blessed($method); return 1; } @@ -373,7 +381,7 @@ sub get_method { (defined $method_name && $method_name) || confess "You must define a method name"; - return unless $self->has_method($method_name); + return unless $self->has_method($method_name); no strict 'refs'; return \&{$self->name . '::' . $method_name}; @@ -452,23 +460,23 @@ sub find_all_methods_by_name { sub find_next_method_by_name { my ($self, $method_name) = @_; (defined $method_name && $method_name) - || confess "You must define a method name to find"; + || confess "You must define a method name to find"; # keep a record of what we have seen # here, this will handle all the # inheritence issues because we are # using the &class_precedence_list my %seen_class; - my @cpl = $self->class_precedence_list(); - shift @cpl; # discard ourselves + my @cpl = $self->class_precedence_list(); + shift @cpl; # discard ourselves foreach my $class (@cpl) { next if $seen_class{$class}; $seen_class{$class}++; # fetch the meta-class ... my $meta = $self->initialize($class); - return $meta->get_method($method_name) - if $meta->has_method($method_name); + return $meta->get_method($method_name) + if $meta->has_method($method_name); } - return; + return; } ## Attributes @@ -482,7 +490,9 @@ sub add_attribute { ($attribute->isa('Class::MOP::Attribute')) || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; $attribute->attach_to_class($self); - $attribute->install_accessors(); + $attribute->install_accessors(); + $attribute->allocate_slots; + $self->get_attribute_map->{$attribute->name} = $attribute; } @@ -513,8 +523,9 @@ sub remove_attribute { my $removed_attribute = $self->get_attribute_map->{$attribute_name}; return unless defined $removed_attribute; delete $self->get_attribute_map->{$attribute_name}; - $removed_attribute->remove_accessors(); - $removed_attribute->detach_from_class(); + $removed_attribute->remove_accessors(); + $removed_attribute->deallocate_slots(); + $removed_attribute->detach_from_class(); return $removed_attribute; } @@ -624,7 +635,7 @@ sub get_package_variable { } confess "Could not get the package variable ($variable) because : $e" if $e; # if we didn't die, then we can return it - return $ref; + return $ref; } sub remove_package_variable { @@ -781,6 +792,8 @@ to use them or not. =item B +=item B + =item B This is a convience method for creating a new object of the class, and @@ -1205,4 +1218,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cutchistian \ No newline at end of file diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index 9d47700..fb8a276 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -15,39 +15,127 @@ sub meta { } sub new { - my $class = shift; - my $meta = shift; + my ( $class, $meta ) = @_; bless { - instance => (bless {} => $meta->name) + meta => $meta, + instance_layout => {} } => $class; } +sub create_instance { + my ( $self, $class ) = @_; + + # rely on autovivification + $self->bless_instance_structure( {}, $class ); +} + +sub bless_instance_structure { + my ( $self, $instance_structure, $class ) = @_; + $class ||= $self->{meta}->name; + bless $instance_structure, $class; +} + +sub get_all_parents { + my $self = shift; + my @parents = $self->{meta}->class_precedence_list; + shift @parents; # shift off ourselves + return map { $_->get_meta_instance } map { $_->meta || () } @parents; +} + +# operations on meta instance + sub add_slot { - my ($self, $slot_name, $value) = @_; - return $self->{instance}->{$slot_name} = $value; + my ($self, $slot_name ) = @_; + confess "The slot '$slot_name' already exists" + if 0 && $self->has_slot_recursively( $slot_name ); + $self->{instance_layout}->{$slot_name} = undef; } sub has_slot { my ($self, $slot_name) = @_; - exists $self->{instance}->{$slot_name} ? 1 : 0; + exists $self->{instance_layout}->{$slot_name} ? 1 : 0; +} + +sub has_slot_recursively { + my ( $self, $slot_name ) = @_; + return 1 if $self->has_slot($slot_name); + $_->has_slot_recursively($slot_name) && return 1 for $self->get_all_parents; + return 0; } +sub remove_slot { + my ( $self, $slot_name ) = @_; + # NOTE: + # this does not search recursively cause + # that is not the domain of this meta-instance + # it is specific to this class ... + confess "The slot '$slot_name' does not exist (maybe it's inherited?)" + if 0 && $self->has_slot( $slot_name ); + delete $self->{instance_layout}->{$slot_name}; +} + + +# operations on created instances + sub get_slot_value { my ($self, $instance, $slot_name) = @_; return $instance->{$slot_name}; } +# can be called only after initialize_slot_value sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; + $slot_name or confess "must provide slot name"; $instance->{$slot_name} = $value; } -sub has_slot_value { +# convenience method +# non autovivifying stores will have this as { initialize_slot unless slot_initlized; set_slot_value } +sub set_slot_value_with_init { + my ( $self, $instance, $slot_name, $value ) = @_; + $self->set_slot_value( $instance, $slot_name, $value ); +} + +sub initialize_slot { + my ( $self, $instance, $slot_name ) = @_; +} + +sub slot_initialized { my ($self, $instance, $slot_name) = @_; - defined $instance->{$slot_name} ? 1 : 0; + exists $instance->{$slot_name} ? 1 : 0; } -sub get_instance { (shift)->{instance} } + +# inlinable operation snippets + +sub inline_get_slot_value { + my ($self, $instance, $slot_name) = @_; + sprintf "%s->{%s}", $instance, $slot_name; +} + +sub inline_set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->_inline_slot_lvalue . " = $value", +} + +sub inline_set_slot_value_with_init { + my ( $self, $instance, $slot_name, $value) = @_; + $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";"; +} + +sub inline_initialize_slot { + return ""; +} + +sub inline_slot_initialized { + my ($self, $instance, $slot_name) = @_; + "exists " . $self->inline_get_slot_value; +} + +sub _inline_slot_lvalue { + my ($self, $instance, $slot_name) = @_; + $self->inline_slot_value; +} 1; @@ -79,8 +167,6 @@ Class::MOP::Instance - Instance Meta Object =item B -=item B - =back =head2 Introspection diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index febc677..38feb82 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 140; +use Test::More tests => 142; use Test::Exception; BEGIN { @@ -26,7 +26,7 @@ my @methods = qw( initialize create create_anon_class - instance_metaclass + instance_metaclass get_meta_instance new_object clone_object construct_instance construct_class_instance clone_instance check_metaclass_compatability diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index c51c953..5084f79 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 40; +use Test::More tests => 43; use Test::Exception; BEGIN { @@ -44,6 +44,10 @@ BEGIN { process_accessors install_accessors remove_accessors + + slot_name + allocate_slots + deallocate_slots ); is_deeply( @@ -75,4 +79,4 @@ BEGIN { # but that is getting a little excessive so I # wont worry about it for now. Maybe if I get # bored I will do it. -} \ No newline at end of file +} diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index 9e25568..41942c1 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -15,7 +15,7 @@ BEGIN { package Foo; use metaclass 'Class::MOP::Class' => ( - ':attribute_metaclass' => 'InsideOutClass::Attribute' + ':instance_metaclass' => 'InsideOutClass::Instance' ); Foo->meta->add_attribute('foo' => (