From: Yuval Kogman <nothingmuch@woobling.org>
Date: Fri, 4 Aug 2006 13:19:18 +0000 (+0000)
Subject: clear/deinitialize but with tests only for deinitialize
X-Git-Tag: 0_33~12
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7d28758b5343c4ee5efa15f2c51e7114a3afab92;p=gitmo%2FClass-MOP.git

clear/deinitialize but with tests only for deinitialize
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index af04c94..93189c0 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -150,6 +150,13 @@ Class::MOP::Attribute->meta->add_attribute(
 );
 
 Class::MOP::Attribute->meta->add_attribute(
+    Class::MOP::Attribute->new('clearer' => (
+        reader    => 'clearer',
+        predicate => 'has_clearer',
+    ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
     Class::MOP::Attribute->new('init_arg' => (
         reader    => 'init_arg',
         predicate => 'has_init_arg',
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index b496b15..9647481 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -39,6 +39,7 @@ sub new {
         reader    => $options{reader},
         writer    => $options{writer},
         predicate => $options{predicate},
+        clearer   => $options{clearer},
         init_arg  => $options{init_arg},
         default   => $options{default},
         # keep a weakened link to the 
@@ -86,6 +87,7 @@ sub has_accessor  { defined($_[0]->{accessor})  ? 1 : 0 }
 sub has_reader    { defined($_[0]->{reader})    ? 1 : 0 }
 sub has_writer    { defined($_[0]->{writer})    ? 1 : 0 }
 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
+sub has_clearer   { defined($_[0]->{clearer})   ? 1 : 0 }
 sub has_init_arg  { defined($_[0]->{init_arg})  ? 1 : 0 }
 sub has_default   { defined($_[0]->{default})   ? 1 : 0 }
 
@@ -93,6 +95,7 @@ sub accessor  { $_[0]->{accessor}  }
 sub reader    { $_[0]->{reader}    }
 sub writer    { $_[0]->{writer}    }
 sub predicate { $_[0]->{predicate} }
+sub clearer   { $_[0]->{clearer}   }
 sub init_arg  { $_[0]->{init_arg}  }
 
 # end bootstrapped away method section.
@@ -226,6 +229,16 @@ sub generate_predicate_method {
     };
 }
 
+sub generate_clearer_method {
+    my $self = shift;
+    my $attr_name  = $self->name;
+    return sub { 
+        Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
+                         ->get_meta_instance
+                         ->deinitialize_slot($_[0], $attr_name);
+    };
+}
+
 sub generate_predicate_method_inline {
     my $self          = shift; 
     my $attr_name     = $self->name;
@@ -234,7 +247,20 @@ sub generate_predicate_method_inline {
     my $code = eval 'sub {'
         . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0'
     . '}';
-    confess "Could not generate inline accessor because : $@" if $@;
+    confess "Could not generate inline predicate because : $@" if $@;
+
+    return $code;
+}
+
+sub generate_clearer_method_inline {
+    my $self          = shift; 
+    my $attr_name     = $self->name;
+    my $meta_instance = $self->associated_class->instance_metaclass;
+
+    my $code = eval 'sub {'
+        . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'")
+    . '}';
+    confess "Could not generate inline clearer because : $@" if $@;
 
     return $code;
 }
@@ -243,7 +269,7 @@ sub process_accessors {
     my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
     if (reftype($accessor)) {
         (reftype($accessor) eq 'HASH')
-            || confess "bad accessor/reader/writer/predicate format, must be a HASH ref";
+            || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
         my ($name, $method) = %{$accessor};
         return ($name, Class::MOP::Attribute::Accessor->wrap($method));        
     }
@@ -280,6 +306,10 @@ sub install_accessors {
         $self->process_accessors('predicate' => $self->predicate(), $inline)
     ) if $self->has_predicate();
     
+    $class->add_method(
+        $self->process_accessors('clearer' => $self->clearer(), $inline)
+    ) if $self->has_clearer();
+    
     return;
 }
 
@@ -300,6 +330,7 @@ sub install_accessors {
         $_remove_accessor->($self->reader(),    $self->associated_class()) if $self->has_reader();
         $_remove_accessor->($self->writer(),    $self->associated_class()) if $self->has_writer();
         $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
+        $_remove_accessor->($self->clearer(),   $self->associated_class()) if $self->has_clearer();
         return;                        
     }
 
@@ -429,12 +460,11 @@ an exercise to the reader :).
 
 =back
 
-The I<accessor>, I<reader>, I<writer> and I<predicate> keys can 
-contain either; the name of the method and an appropriate default 
-one will be generated for you, B<or> a HASH ref containing exactly one 
-key (which will be used as the name of the method) and one value, 
-which should contain a CODE reference which will be installed as 
-the method itself.
+The I<accessor>, I<reader>, I<writer>, I<predicate> and I<clearer> keys can
+contain either; the name of the method and an appropriate default one will be
+generated for you, B<or> a HASH ref containing exactly one key (which will be
+used as the name of the method) and one value, which should contain a CODE
+reference which will be installed as the method itself.
 
 =over 4
 
@@ -475,6 +505,11 @@ This is a basic test to see if the value of the attribute is not
 C<undef>. It will return true (C<1>) if the attribute's value is 
 defined, and false (C<0>) otherwise.
 
+=item I<clearer>
+
+This is the a method that will uninitialize the attr, reverting lazy values
+back to their "unfulfilled" state.
+
 =back
 
 =item B<clone (%options)>
@@ -516,6 +551,8 @@ passed into C<new>. I think they are pretty much self-explanitory.
 
 =item B<predicate>
 
+=item B<clearer>
+
 =item B<init_arg>
 
 =item B<is_default_a_coderef>
@@ -547,6 +584,8 @@ These are all basic predicate methods for the values passed into C<new>.
 
 =item B<has_predicate>
 
+=item B<has_clearer>
+
 =item B<has_init_arg>
 
 =item B<has_default>
@@ -598,6 +637,8 @@ use the custom method passed through the constructor.
 
 =item B<generate_predicate_method>
 
+=item B<generate_clearer_method>
+
 =item B<generate_reader_method>
 
 =item B<generate_writer_method>
@@ -610,6 +651,8 @@ use the custom method passed through the constructor.
 
 =item B<generate_predicate_method_inline>
 
+=item B<generate_clearer_method_inline>
+
 =item B<generate_reader_method_inline>
 
 =item B<generate_writer_method_inline>
@@ -619,7 +662,7 @@ use the custom method passed through the constructor.
 =item B<remove_accessors>
 
 This allows the attribute to remove the method for it's own 
-I<accessor/reader/writer/predicate>. This is called by 
+I<accessor/reader/writer/predicate/clearer>. This is called by 
 C<Class::MOP::Class::remove_attribute>.
 
 =back
@@ -657,3 +700,4 @@ it under the same terms as Perl itself.
 
 =cut
 
+
diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm
index 9a143bc..d8bf313 100644
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -76,6 +76,11 @@ sub initialize_slot {
     $self->set_slot_value($instance, $slot_name, undef);
 }
 
+sub deinitialize_slot {
+    my ( $self, $instance, $slot_name ) = @_;
+    delete $instance->{$slot_name};
+}
+
 sub initialize_all_slots {
     my ($self, $instance) = @_;
     foreach my $slot_name ($self->get_all_slots) {
@@ -83,6 +88,13 @@ sub initialize_all_slots {
     }
 }
 
+sub deinitialize_all_slots {
+    my ($self, $instance) = @_;
+    foreach my $slot_name ($self->get_all_slots) {
+        $self->deinitialize_slot($instance, $slot_name);
+    }
+}
+
 sub is_slot_initialized {
     my ($self, $instance, $slot_name, $value) = @_;
     exists $instance->{$slot_name} ? 1 : 0;
@@ -127,6 +139,10 @@ sub inline_initialize_slot {
     $self->inline_set_slot_value($instance, $slot_name, 'undef'),
 }
 
+sub inline_deinitialize_slot {
+    my ($self, $instance, $slot_name) = @_;
+    "delete " . $self->inline_slot_access($instance, $slot_name);
+}
 sub inline_is_slot_initialized {
     my ($self, $instance, $slot_name) = @_;
     "exists " . $self->inline_slot_access($instance, $slot_name) . " ? 1 : 0";
@@ -245,8 +261,12 @@ require that the C<$instance_structure> is passed into them.
 
 =item B<initialize_slot ($instance_structure, $slot_name)>
 
+=item B<deinitialize_slot ($instance_structure, $slot_name)>
+
 =item B<initialize_all_slots ($instance_structure)>
 
+=item B<deinitialize_all_slots ($instance_structure)>
+
 =item B<is_slot_initialized ($instance_structure, $slot_name)>
 
 =item B<weaken_slot_value ($instance_structure, $slot_name)>
@@ -281,6 +301,8 @@ optimizations.
 
 =item B<inline_initialize_slot ($instance_structure, $slot_name)>
 
+=item B<inline_deinitialize_slot ($instance_structure, $slot_name)>
+
 =item B<inline_is_slot_initialized ($instance_structure, $slot_name)>
 
 =item B<inline_weaken_slot_value ($instance_structure, $slot_name)>
diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t
index 56467d6..a85e087 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 => 48;
+use Test::More tests => 53;
 use Test::Exception;
 
 BEGIN {
@@ -30,6 +30,7 @@ BEGIN {
         has_writer    writer
         has_reader    reader
         has_predicate predicate
+        has_clearer   clearer
         has_init_arg  init_arg
         has_default   default    is_default_a_coderef
         
@@ -44,11 +45,13 @@ BEGIN {
         generate_reader_method
         generate_writer_method
         generate_predicate_method
+        generate_clearer_method
         
         generate_accessor_method_inline
         generate_reader_method_inline
         generate_writer_method_inline
         generate_predicate_method_inline    
+        generate_clearer_method_inline    
         
         process_accessors
         install_accessors
@@ -56,8 +59,8 @@ BEGIN {
         );
         
     is_deeply(
-        [ sort @methods ],
         [ sort $meta->get_method_list ],
+        [ sort @methods ],
         '... our method list matches');        
     
     foreach my $method_name (@methods) {
@@ -65,13 +68,13 @@ BEGIN {
     }
     
     my @attributes = qw(
-        name accessor reader writer predicate
+        name accessor reader writer predicate clearer
         init_arg default associated_class
         );
 
     is_deeply(
-        [ sort @attributes ],
         [ sort $meta->get_attribute_list ],
+        [ sort @attributes ],
         '... our attribute list matches');
     
     foreach my $attribute_name (@attributes) {
diff --git a/t/060_instance.t b/t/060_instance.t
index 9362034..dafd509 100644
--- a/t/060_instance.t
+++ b/t/060_instance.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 39;
+use Test::More tests => 47;
 use Test::Exception;
 
 use Scalar::Util qw/isweak reftype/;
@@ -21,10 +21,12 @@ can_ok( "Class::MOP::Instance", $_ ) for qw/
     get_all_slots
     
 	initialize_all_slots    
+	deinitialize_all_slots    
 
 	get_slot_value
 	set_slot_value
 	initialize_slot
+	deinitialize_slot
 	is_slot_initialized	
 	weaken_slot_value
 	strengthen_slot_value	
@@ -32,6 +34,7 @@ can_ok( "Class::MOP::Instance", $_ ) for qw/
 	inline_get_slot_value
 	inline_set_slot_value
 	inline_initialize_slot
+	inline_deinitialize_slot
 	inline_is_slot_initialized	
 	inline_weaken_slot_value
 	inline_strengthen_slot_value	
@@ -78,8 +81,16 @@ isa_ok($i_foo, "Foo");
     is_deeply($i_foo, $i_foo_2, '... but the same structure');
 }
 
+ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot not initialized");
+
 ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot");
 
+$mi_foo->initialize_slot( $i_foo, "moosen" );
+
+ok($mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot initialized");
+
+ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... but no value for slot");
+
 $mi_foo->set_slot_value( $i_foo, "moosen", "the value" );
 
 is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value");
@@ -122,3 +133,9 @@ undef $ref;
 
 is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "weak value can be strengthened" );
 
+$mi_foo->deinitialize_slot( $i_foo, "moosen" );
+
+ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot deinitialized");
+
+ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot");
+