From: Stevan Little <stevan.little@iinteractive.com>
Date: Sat, 24 May 2008 03:23:00 +0000 (+0000)
Subject: fixing get_{read,write}_method_ref
X-Git-Tag: 0_64~53
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=def5c0b559748ec86e53f2397939a657b5a9b5f9;hp=a982eca7c166a79612242a352d67c9276540ba59;p=gitmo%2FClass-MOP.git

fixing get_{read,write}_method_ref
---

diff --git a/Changes b/Changes
index 9845290..7cef425 100644
--- a/Changes
+++ b/Changes
@@ -12,6 +12,10 @@ Revision history for Perl extension Class-MOP.
 
     * Class::MOP::Attribute
       - add has_read_method and has_write_method
+      - get_{read,write}_method_ref now wraps the 
+        anon-sub ref in the method metaclass when
+        possible
+        - added tests for this
      
     * Class::MOP::Immutable
       - added the ability to "wrap" methods when 
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 9f4ff49..6ccf691 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -196,7 +196,17 @@ sub get_read_method_ref {
         return $self->associated_class->get_method($reader);
     }
     else {
-        return sub { $self->get_value(@_) };
+        my $code = sub { $self->get_value(@_) };
+        if (my $class = $self->associated_class) {
+            return $class->method_metaclass->wrap(
+                $code,
+                package_name => $class->name,
+                name         => '__ANON__'
+            );
+        }
+        else {
+            return $code;
+        }
     }
 }
 
@@ -206,7 +216,17 @@ sub get_write_method_ref {
         return $self->associated_class->get_method($writer);
     }
     else {
-        return sub { $self->set_value(@_) };
+        my $code = sub { $self->set_value(@_) };
+        if (my $class = $self->associated_class) {
+            return $class->method_metaclass->wrap(
+                $code,
+                package_name => $class->name,
+                name         => '__ANON__'
+            );
+        }
+        else {
+            return $code;
+        }
     }
 }
 
diff --git a/t/020_attribute.t b/t/020_attribute.t
index 3ec9921..9d9c771 100644
--- a/t/020_attribute.t
+++ b/t/020_attribute.t
@@ -5,7 +5,7 @@ use warnings;
 
 use Scalar::Util 'reftype', 'blessed';
 
-use Test::More tests => 97;
+use Test::More tests => 101;
 use Test::Exception;
 
 BEGIN {
@@ -27,6 +27,17 @@ BEGIN {
     ok(!$attr->has_default, '... $attr does not have an default');
     ok(!$attr->has_builder, '... $attr does not have a builder');
 
+    {
+        my $reader = $attr->get_read_method_ref;
+        my $writer = $attr->get_write_method_ref;        
+        
+        ok(!blessed($reader), '... it is a plain old sub');
+        ok(!blessed($writer), '... it is a plain old sub');        
+        
+        is(reftype($reader), 'CODE', '... it is a plain old sub');
+        is(reftype($writer), 'CODE', '... it is a plain old sub');                
+    }
+
     my $class = Class::MOP::Class->initialize('Foo');
     isa_ok($class, 'Class::MOP::Class');
 
@@ -43,11 +54,11 @@ BEGIN {
         my $reader = $attr->get_read_method_ref;
         my $writer = $attr->get_write_method_ref;        
         
-        ok(!blessed($reader), '... it is a plain old sub');
-        ok(!blessed($writer), '... it is a plain old sub');        
+        ok(blessed($reader), '... it is a plain old sub');
+        ok(blessed($writer), '... it is a plain old sub');        
         
-        is(reftype($reader), 'CODE', '... it is a plain old sub');
-        is(reftype($writer), 'CODE', '... it is a plain old sub');                
+        isa_ok($reader, 'Class::MOP::Method');
+        isa_ok($writer, 'Class::MOP::Method');        
     }
 
     my $attr_clone = $attr->clone();
diff --git a/t/023_attribute_get_read_write.t b/t/023_attribute_get_read_write.t
index a664727..0bf8290 100644
--- a/t/023_attribute_get_read_write.t
+++ b/t/023_attribute_get_read_write.t
@@ -5,7 +5,7 @@ use warnings;
 
 use Scalar::Util 'blessed', 'reftype';
 
-use Test::More tests => 35;
+use Test::More tests => 37;
 
 BEGIN {
     use_ok('Class::MOP');
@@ -108,7 +108,9 @@ ok(!$gorch_attr->get_write_method, '... $attr does not have an write method');
     my $writer = $gorch_attr->get_write_method_ref;        
     
     isa_ok($reader, 'Class::MOP::Method');
-    ok(!blessed($writer), '... it is not a plain old sub'); 
+    ok(blessed($writer), '... it is not a plain old sub'); 
+    isa_ok($writer, 'Class::MOP::Method');    
     
     is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for');
+    is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for');    
 }