From: Stevan Little <stevan.little@iinteractive.com>
Date: Mon, 16 Oct 2006 02:04:23 +0000 (+0000)
Subject: fixing up the method protocol more, actually this is probably closer to the accessor... 
X-Git-Tag: 0_36~2^2~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3545c727b64808e435c361e061962d14ba5b3f31;hp=ba38bf08d30369c19a2c25997a0243c0d30be3d5;p=gitmo%2FClass-MOP.git

fixing up the method protocol more, actually this is probably closer to the accessor protocol to be honest
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 0c7d0c9..66db0e2 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -315,6 +315,12 @@ Class::MOP::Attribute->meta->add_attribute(
     ))
 );
 
+Class::MOP::Attribute->meta->add_attribute(
+    Class::MOP::Attribute->new('associated_methods' => (
+        reader  => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
+        default => sub { [] } 
+    ))
+);
 
 # NOTE: (meta-circularity)
 # This should be one of the last things done
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 6f13f38..c8ab6c0 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -56,6 +56,9 @@ sub new {
         # keep a weakened link to the 
         # class we are associated with
         associated_class => undef,
+        # and a list of the methods 
+        # associated with this attr
+        associated_methods => [],
     } => $class;
 }
 
@@ -92,7 +95,8 @@ sub initialize_instance_slot {
 
 sub name { $_[0]->{name} }
 
-sub associated_class { $_[0]->{associated_class} }
+sub associated_class   { $_[0]->{associated_class}   }
+sub associated_methods { $_[0]->{associated_methods} }
 
 sub has_accessor  { defined($_[0]->{accessor})  ? 1 : 0 }
 sub has_reader    { defined($_[0]->{reader})    ? 1 : 0 }
@@ -146,24 +150,47 @@ sub detach_from_class {
     $self->{associated_class} = undef;        
 }
 
+# method association 
+
+sub associate_method {
+    my ($self, $method) = @_;
+    push @{$self->{associated_methods}} => $method;
+}
+
 ## Slot management
 
 sub set_value {
     my ($self, $instance, $value) = @_;
 
-    Class::MOP::Class->initialize(Scalar::Util::blessed($instance))
+    Class::MOP::Class->initialize(blessed($instance))
                      ->get_meta_instance
-                     ->set_slot_value( $instance, $self->name, $value );
+                     ->set_slot_value($instance, $self->name, $value);
 }
 
 sub get_value {
     my ($self, $instance) = @_;
 
-    Class::MOP::Class->initialize(Scalar::Util::blessed($instance))
+    Class::MOP::Class->initialize(blessed($instance))
                      ->get_meta_instance
                      ->get_slot_value($instance, $self->name);
 }
 
+sub has_value {
+    my ($self, $instance) = @_;
+    
+    defined Class::MOP::Class->initialize(blessed($instance))
+                             ->get_meta_instance
+                             ->get_slot_value($instance, $self->name) ? 1 : 0;    
+}
+
+sub clear_value {
+    my ($self, $instance) = @_;
+        
+    Class::MOP::Class->initialize(blessed($instance))
+                     ->get_meta_instance
+                     ->deinitialize_slot($instance, $self->name);    
+}
+
 ## load em up ...
 
 sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
@@ -174,7 +201,9 @@ sub process_accessors {
         (reftype($accessor) eq 'HASH')
             || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
         my ($name, $method) = %{$accessor};
-        return ($name, $self->accessor_metaclass->wrap($method));        
+        $method = $self->accessor_metaclass->wrap($method);
+        $self->associate_method($method);
+        return ($name, $method);        
     }
     else {
         my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);         
@@ -187,6 +216,7 @@ sub process_accessors {
             );            
         };
         confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;        
+        $self->associate_method($method);
         return ($accessor, $method);
     }    
 }
@@ -417,16 +447,20 @@ back to their "unfulfilled" state.
 
 =over 4
 
-=item set_value $instance, $value
+=item B<set_value ($instance, $value)>
 
 Set the value without going through the accessor. Note that this may be done to
 even attributes with just read only accessors.
 
-=item get_value $instance
+=item B<get_value ($instance)>
 
 Return the value without going through the accessor. Note that this may be done
 even to attributes with just write only accessors.
 
+=item B<has_value ($instance)>
+
+=item B<clear_value ($instance)>
+
 =back
 
 =head2 Informational
@@ -497,12 +531,6 @@ These are all basic predicate methods for the values passed into C<new>.
 
 =item B<detach_from_class>
 
-=item B<slot_name>
-
-=item B<allocate_slots>
-
-=item B<deallocate_slots>
-
 =back
 
 =head2 Attribute Accessor generation
@@ -511,6 +539,10 @@ These are all basic predicate methods for the values passed into C<new>.
 
 =item B<accessor_metaclass>
 
+=item B<associate_method>
+
+=item B<associated_methods>
+
 =item B<install_accessors>
 
 This allows the attribute to generate and install code for it's own 
diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm
index 9264eda..1c0ea40 100644
--- a/lib/Class/MOP/Method/Accessor.pm
+++ b/lib/Class/MOP/Method/Accessor.pm
@@ -12,19 +12,6 @@ our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Class::MOP::Method';
 
-=pod
-
-So, the idea here is that we have an accessor class
-which takes a weak-link to the attribute and can 
-generate the actual code ref needed. This might allow
-for more varied approaches.
-
-And if the attribute type can also declare what 
-kind of accessor method metaclass it uses, then 
-this relationship can be handled by delegation.
-
-=cut
-
 sub new {
     my $class   = shift;
     my %options = @_;
@@ -75,9 +62,7 @@ sub intialize_body {
         ($self->as_inline ? 'inline' : ())
     );
     
-    eval {
-        $self->{body} = $self->$method_name();
-    };
+    eval { $self->{body} = $self->$method_name() };
     die $@ if $@;
 }
 
@@ -107,22 +92,16 @@ sub generate_writer_method {
 }
 
 sub generate_predicate_method {
-    my $attr      = (shift)->associated_attribute; 
-    my $attr_name = $attr->name;
+    my $attr = (shift)->associated_attribute; 
     return sub { 
-        defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
-                                 ->get_meta_instance
-                                 ->get_slot_value($_[0], $attr_name) ? 1 : 0;
+        $attr->has_value($_[0])
     };
 }
 
 sub generate_clearer_method {
-    my $attr      = (shift)->associated_attribute; 
-    my $attr_name = $attr->name;
+    my $attr = (shift)->associated_attribute; 
     return sub { 
-        Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
-                         ->get_meta_instance
-                         ->deinitialize_slot($_[0], $attr_name);
+        $attr->clear_value($_[0])
     };
 }
 
diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t
index e33edf6..30af573 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 => 44;
+use Test::More tests => 49;
 use Test::Exception;
 
 BEGIN {
@@ -37,12 +37,17 @@ BEGIN {
         slots
         get_value
         set_value
+        has_value
+        clear_value
         
         associated_class
         attach_to_class detach_from_class 
         
         accessor_metaclass
         
+        associated_methods
+        associate_method
+        
         process_accessors
         install_accessors
         remove_accessors
@@ -59,7 +64,7 @@ BEGIN {
     
     my @attributes = qw(
         name accessor reader writer predicate clearer
-        init_arg default associated_class
+        init_arg default associated_class associated_methods
         );
 
     is_deeply(