From: Stevan Little Date: Fri, 28 Apr 2006 05:03:09 +0000 (+0000) Subject: instance-refactored X-Git-Tag: 0_29_02~38 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=49c93440bd912ed231b8ab8e93a8e9ac7328fdc7;p=gitmo%2FClass-MOP.git instance-refactored --- diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod index 8a3dabc..49ef294 100644 --- a/examples/ClassEncapsulatedAttributes.pod +++ b/examples/ClassEncapsulatedAttributes.pod @@ -62,14 +62,14 @@ sub initialize_instance_slot { } # 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 ); + $self->associated_class + ->get_meta_instance + ->set_slot_value($instance, $self->name, $val); } -# mangle the slot name to include the fully qualified attr -sub slot_name { - my $self = shift; - $self->associated_class->name . "::" . $self->SUPER::slot_name; +sub name { + my $self = shift; + return ($self->associated_class->name . '::' . $self->SUPER::name) } 1; diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 0213973..aaf581a 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -14,37 +14,30 @@ use Scalar::Util 'refaddr'; use base 'Class::MOP::Instance'; sub create_instance { - my ( $self, $class ) = @_; - my $x; - bless \$x, $class || $self->{meta}->name; -} - -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 ); + my ($self, $class) = @_; + $self->bless_instance_structure(\(my $instance)); } sub get_slot_value { - my ( $self, $instance, $slot_name ) = @_; - confess "$self is no instance" unless ref $self; - $self->{containers}{$slot_name}{refaddr $instance}; + my ($self, $instance, $slot_name) = @_; + $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance}; } sub set_slot_value { - my ( $self, $instance, $slot_name, $value ) = @_; - $self->{containers}{$slot_name}{refaddr $instance} = $value; + my ($self, $instance, $slot_name, $value) = @_; + $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} = $value; } -sub initialize_slot { } +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->{meta}->add_package_variable('%' . $slot_name); + $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} = undef; +} -sub slot_initialized { - my ( $self, $instance, $slot_name ) = @_; - exists $self->{containers}{$slot_name}{refaddr $instance}; +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + return 0 unless $self->{meta}->has_package_variable('%' . $slot_name); + return exists $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} ? 1 : 0; } ## &remove_slot is left as an exercise for the reader :) diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod index 38482ec..566aacf 100644 --- a/examples/LazyClass.pod +++ b/examples/LazyClass.pod @@ -20,28 +20,29 @@ sub initialize_instance_slot { 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); + $self->associated_class + ->get_meta_instance + ->set_slot_value($instance, $self->name, $val); } } sub generate_accessor_method { my $attr = shift; - my $slot_name = $attr->slot_name; + my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->get_meta_instance; sub { if (scalar(@_) == 2) { - $meta_instance->set_slot_value_with_init( $_[0], $slot_name, $_[1] ); + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); } else { - unless ( $meta_instance->slot_initialized( $_[0], $slot_name ) ) { + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { my $value = $attr->has_default ? $attr->default($_[0]) : undef; - $meta_instance->set_slot_value_with_init( $_[0], $slot_name, $value ); + $meta_instance->set_slot_value($_[0], $attr_name, $value); } - $meta_instance->get_slot_value( $_[0], $slot_name ); + $meta_instance->get_slot_value($_[0], $attr_name); } }; } @@ -49,18 +50,18 @@ sub generate_accessor_method { sub generate_reader_method { my $attr = shift; - my $slot_name = $attr->slot_name; + my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->get_meta_instance; sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - unless ( $meta_instance->slot_initialized( $_[0], $slot_name ) ) { + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { my $value = $attr->has_default ? $attr->default($_[0]) : undef; - $meta_instance->set_slot_value_with_init( $_[0], $slot_name, $value ); + $meta_instance->set_slot_value($_[0], $attr_name, $value); } - $meta_instance->get_slot_value( $_[0], $slot_name ); + $meta_instance->get_slot_value($_[0], $attr_name); }; } diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 2eeee2d..3190a4b 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -71,9 +71,9 @@ sub initialize_instance_slot { if (!defined $val && defined $self->{default}) { $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 ); + $self->associated_class + ->get_meta_instance + ->set_slot_value($instance, $self->name, $val); } # NOTE: @@ -126,65 +126,43 @@ 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 = shift; my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - - sub { - $meta_instance->set_slot_value($_[0], $slot_name, $_[1]) if scalar(@_) == 2; - $meta_instance->get_slot_value($_[0], $slot_name); + my $attr_name = $self->name; + return sub { + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); }; } sub generate_reader_method { my $self = shift; my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - sub { + my $attr_name = $self->name; + return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $meta_instance->get_slot_value($_[0], $slot_name); + $meta_instance->get_slot_value($_[0], $attr_name); }; } sub generate_writer_method { my $self = shift; my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - sub { - $meta_instance->set_slot_value($_[0], $slot_name, $_[1]); + my $attr_name = $self->name; + return sub { + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); }; } sub generate_predicate_method { my $self = shift; my $meta_instance = $self->associated_class->get_meta_instance; - my $slot_name = $self->slot_name; - sub { - defined $meta_instance->get_slot_value($_[0], $slot_name); + my $attr_name = $self->name; + return sub { + defined $meta_instance->get_slot_value($_[0], $attr_name) ? 1 : 0; }; } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index c0bebc4..945cf90 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -179,9 +179,7 @@ sub new_object { sub construct_instance { my ($class, %params) = @_; - my $instance = $class->get_meta_instance->create_instance(); - foreach my $attr ($class->compute_all_applicable_attributes()) { $attr->initialize_instance_slot($instance, \%params); } @@ -190,8 +188,7 @@ sub construct_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 ); + $class->{':instance_meta_object_cache'} ||= $class->instance_metaclass->new($class); } sub clone_object { @@ -491,8 +488,6 @@ sub add_attribute { || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; $attribute->attach_to_class($self); $attribute->install_accessors(); - $attribute->allocate_slots; - $self->get_attribute_map->{$attribute->name} = $attribute; } @@ -524,7 +519,6 @@ sub remove_attribute { return unless defined $removed_attribute; delete $self->get_attribute_map->{$attribute_name}; $removed_attribute->remove_accessors(); - $removed_attribute->deallocate_slots(); $removed_attribute->detach_from_class(); return $removed_attribute; } diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index dcc13c7..b6d6435 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -15,79 +15,41 @@ sub meta { } sub new { - my ( $class, $meta ) = @_; + my ($class, $meta) = @_; + my $slots = $class->_compute_slot_list_from_class($meta); bless { - meta => $meta, - instance_layout => {} + meta => $meta, + slots => $slots, } => $class; } -sub create_instance { - my ( $self, $class ) = @_; - - # rely on autovivification - $self->bless_instance_structure( {}, $class ); +# private for now ... +sub _compute_slot_list_from_class { + my ($self, $meta) = @_; + return [ + map { + $_->name + } $meta->compute_all_applicable_attributes() + ]; } -sub bless_instance_structure { - my ( $self, $instance_structure, $class ) = @_; - $class ||= $self->{meta}->name; - bless $instance_structure, $class; +sub create_instance { + my $self = shift; + $self->bless_instance_structure({}); } -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; +sub bless_instance_structure { + my ($self, $instance_structure) = @_; + bless $instance_structure, $self->{meta}->name; } # operations on meta instance -sub add_slot { - my ($self, $slot_name ) = @_; - confess "The slot '$slot_name' already exists" - if 0 && $self->has_slot_recursively( $slot_name ); # FIXME - $self->{instance_layout}->{$slot_name} = undef; -} - sub get_all_slots { my $self = shift; - keys %{ $self->{instance_layout} }; -} - -sub get_all_slots_recursively { - my $self = shift; - return ( - $self->get_all_slots, - map { $_->get_all_slots } $self->get_all_parents, - ), -} - -sub has_slot { - my ($self, $slot_name) = @_; - 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; + return @{$self->{slots}}; } -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 ); # FIXME - delete $self->{instance_layout}->{$slot_name}; -} - - # operations on created instances sub get_slot_value { @@ -95,82 +57,41 @@ sub get_slot_value { return $instance->{$slot_name}; } -# can be called only after initialize_slot_value sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; $instance->{$slot_name} = $value; } -sub set_weak_slot_value { - my ( $self, $instance, $slot_name, $value) = @_; - $self->set_slot_value( $instance, $slot_name, $value ); - $self->weeaken_slot_value( $instance, $slot_name ); -} - -sub weaken_slot_value { - my ( $self, $instance, $slot_name ) = @_; - weaken( $instance->{$slot_name} ); -} - -# 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 ) = @_; + my ($self, $instance, $slot_name) = @_; + $instance->{$slot_name} = undef; } -sub slot_initialized { - my ($self, $instance, $slot_name) = @_; +sub is_slot_initialized { + my ($self, $instance, $slot_name, $value) = @_; exists $instance->{$slot_name} ? 1 : 0; } - # inlinable operation snippets sub inline_get_slot_value { - my ($self, $instance, $slot_name) = @_; - sprintf "%s->{%s}", $instance, $slot_name; + my ($self, $instance_var_name, $slot_name) = @_; + return ($instance_var_name . '->{\'' . $slot_name . '\'}'); } sub inline_set_slot_value { - my ($self, $instance, $slot_name, $value) = @_; - $self->_inline_slot_lvalue( $instance, $slot_name ) . " = $value", -} - -sub inline_set_weak_slot_value { - my ( $self, $instance, $slot_name, $value ) = @_; - return "" - . $self->inline_set_slot_value( $instance, $slot_name, $value ) - . "; " - . $self->inline_weaken_slot_value( $instance, $slot_name ); -} - -sub inline_weaken_slot_value { - my ( $self, $instance, $slot_name ) = @_; - return 'Scalar::Util::weaken( ' . $self->_inline_slot_lvalue( $instance, $slot_name ) . ')'; -} - -sub inline_set_slot_value_with_init { - my ( $self, $instance, $slot_name, $value) = @_; - $self->inline_set_slot_value( $instance, $slot_name, $value ) . ";"; + my ($self, $instance_var_name, $slot_name, $value_name) = @_; + return ($self->inline_get_slot_value($instance_var_name, $slot_name) . ' = ' . $value_name); } sub inline_initialize_slot { - return ""; + my ($self, $instance_var_name, $slot_name) = @_; + $self->inline_set_slot_value($instance_var_name, $slot_name, 'undef'); } -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_get_slot_value( $instance, $slot_name ); +sub inline_is_slot_initialized { + my ($self, $instance_var_name, $slot_name) = @_; + return ('exists ' . $self->inline_get_slot_value($instance_var_name, $slot_name) . ' ? 1 : 0'); } 1; @@ -193,43 +114,29 @@ Class::MOP::Instance - Instance Meta Object =item B -=item B - =item B +=item B + =item B -=item B +=item B =item B -=item B - -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B +=item B -=item B +=item B =back diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index 5084f79..390fcc1 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 => 43; +use Test::More tests => 40; use Test::Exception; BEGIN { @@ -44,10 +44,6 @@ BEGIN { process_accessors install_accessors remove_accessors - - slot_name - allocate_slots - deallocate_slots ); is_deeply( diff --git a/t/060_instance.t b/t/060_instance.t index cbaaa1a..36657f1 100644 --- a/t/060_instance.t +++ b/t/060_instance.t @@ -3,78 +3,84 @@ use strict; use warnings; -use Test::More tests => 30; +use Test::More tests => 25; use Test::Exception; -use Scalar::Util 'reftype', 'isweak'; - BEGIN { use_ok('Class::MOP::Instance'); } can_ok( "Class::MOP::Instance", $_ ) for qw/ + new + create_instance bless_instance_structure - add_slot - remove_slot - get_all_slots - get_all_slots_recursively - has_slot - has_slot_recursively - get_all_parents + get_all_slots get_slot_value set_slot_value - slot_initialized - initialize_slot - set_slot_value_with_init inline_get_slot_value inline_set_slot_value - inline_initialize_slot - inline_set_slot_value_with_init /; { package Foo; use metaclass; + + Foo->meta->add_attribute('moosen'); package Bar; use metaclass; use base qw/Foo/; -} -isa_ok( my $mi_foo = Foo->meta->get_meta_instance, "Class::MOP::Instance" ); - -$mi_foo->add_slot("moosen"); + Bar->meta->add_attribute('elken'); +} -is_deeply( [ $mi_foo->get_all_slots ], [ "moosen" ], "get slots" ); +my $mi_foo = Foo->meta->get_meta_instance; +isa_ok($mi_foo, "Class::MOP::Instance"); +is_deeply( + [ $mi_foo->get_all_slots ], + [ "moosen" ], + '... get all slots for Foo'); my $mi_bar = Bar->meta->get_meta_instance; +isa_ok($mi_bar, "Class::MOP::Instance"); -is_deeply( [ $mi_bar->get_all_slots ], [], "get slots" ); -is_deeply( [ $mi_bar->get_all_slots_recursively ], ["moosen"], "get slots rec" ); +isnt($mi_foo, $mi_bar, '... they are not the same instance'); -$mi_bar->add_slot("elken"); +is_deeply( + [ sort $mi_bar->get_all_slots ], + [ "elken", "moosen" ], + '... get all slots for Bar'); -is_deeply( [ sort $mi_bar->get_all_slots_recursively ], [qw/elken moosen/], "get slots rec" ); +my $i_foo = $mi_foo->create_instance; +isa_ok($i_foo, "Foo"); -isa_ok( my $i_foo = $mi_foo->create_instance, "Foo" ); +{ + my $i_foo_2 = $mi_foo->create_instance; + isa_ok($i_foo_2, "Foo"); + isnt($i_foo_2, $i_foo, '... not the same instance'); + is_deeply($i_foo, $i_foo_2, '... but the same structure'); +} -ok( !$mi_foo->get_slot_value( $i_foo, "moosen" ), "no value for slot"); +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); -$mi_foo->initialize_slot( $i_foo, "moosen" ); $mi_foo->set_slot_value( $i_foo, "moosen", "the value" ); -is ( $mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "get slot value" ); +is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value"); + +ok(!$i_foo->can('moosen'), '... Foo cant moosen'); + +eval 'sub Foo::moosen { ' . $mi_foo->inline_get_slot_value( '$_[0]', 'moosen' ) . ' }'; +ok(!$@, "compilation of inline get value had no error"); -eval 'sub Foo::moosen { ' . $mi_foo->inline_get_slot_value( '$_[0]', '"moosen"' ) . ' }'; -ok( !$@, "compilation of inline get value had no error" ); +can_ok($i_foo, 'moosen'); -is( $i_foo->moosen, "the value", "inline get value" ); +is($i_foo->moosen, "the value", "... inline get value worked"); $mi_foo->set_slot_value( $i_foo, "moosen", "the other value" ); -is( $i_foo->moosen, "the other value", "inline get value"); +is($i_foo->moosen, "the other value", "... inline get value worked (even after value is changed)"); diff --git a/t/106_LazyClass_test.t b/t/106_LazyClass_test.t index 877c845..ff3e354 100644 --- a/t/106_LazyClass_test.t +++ b/t/106_LazyClass_test.t @@ -15,7 +15,7 @@ BEGIN { package BinaryTree; use metaclass 'Class::MOP::Class' => ( - ':attribute_metaclass' => 'LazyClass::Attribute' + ':attribute_metaclass' => 'LazyClass::Attribute', ); BinaryTree->meta->add_attribute('$:node' => (