Add Moose::Meta::Method::Delegation and use it for delegation methods

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index b454640..f16d2f7 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -11,6 +11,7 @@ our $VERSION   = '0.57';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Method::Accessor;
+use Moose::Meta::Method::Delegation;
 use Moose::Util ();
 use Moose::Util::TypeConstraints ();
 
@@ -598,29 +599,9 @@ sub install_delegation {
         #cluck("Not delegating method '$handle' because it is a core method") and
         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 
-        if ('CODE' eq ref($method_to_call)) {
-            $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
-        }
-        else {
-            # NOTE:
-            # we used to do a goto here, but the
-            # goto didn't handle failure correctly
-            # (it just returned nothing), so I took 
-            # that out. However, the more I thought
-            # about it, the less I liked it doing 
-            # the goto, and I prefered the act of 
-            # delegation being actually represented
-            # in the stack trace. 
-            # - SL
-            $associated_class->add_method($handle => Class::MOP::subname($name, sub {
-                my $instance = shift;
-                my $proxy = $instance->$accessor();
-                (defined $proxy) 
-                    || $self->throw_error("Cannot delegate $handle to $method_to_call because " . 
-                              "the value of " . $self->name . " is not defined", method_name => $method_to_call, object => $instance);
-                $proxy->$method_to_call(@_);
-            }));
-        }
+        my $method = $self->_make_delegation_method($accessor, $handle, $method_to_call);
+
+        $self->associated_class->add_method($method->name, $method);
     }    
 }
 
@@ -713,6 +694,48 @@ sub _get_delegate_method_list {
     }
 }
 
+sub _make_delegation_method {
+    my ( $self, $accessor, $handle_name, $method_to_call ) = @_;
+
+    my $method_body;
+
+    if ( 'CODE' eq ref($method_to_call) ) {
+        $method_body = $method_to_call;
+    }
+    else {
+
+        # NOTE:
+        # we used to do a goto here, but the
+        # goto didn't handle failure correctly
+        # (it just returned nothing), so I took
+        # that out. However, the more I thought
+        # about it, the less I liked it doing
+        # the goto, and I prefered the act of
+        # delegation being actually represented
+        # in the stack trace.
+        # - SL
+        $method_body = sub {
+            my $instance = shift;
+            my $proxy    = $instance->$accessor();
+            ( defined $proxy )
+                || $self->throw_error(
+                "Cannot delegate $handle_name to $method_to_call because "
+                    . "the value of "
+                    . $self->name
+                    . " is not defined", method_name => $method_to_call,
+                object => $instance );
+            $proxy->$method_to_call(@_);
+        };
+    }
+
+    return Moose::Meta::Method::Delegation->new(
+        name         => $handle_name,
+        package_name => $self->associated_class->name,
+        attribute    => $self,
+        body         => $method_body,
+    );
+}
+
 package Moose::Meta::Attribute::Custom::Moose;
 sub register_implementation { 'Moose::Meta::Attribute' }
 

diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm
new file mode 100644 (file)
index 0000000..b24579b
--- /dev/null
+++ b/lib/Moose/Meta/Method/Delegation.pm
@@ -0,0 +1,37 @@
+
+package Moose::Meta::Method::Delegation;
+
+use strict;
+use warnings;
+
+use Carp         'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION   = '0.57';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method';
+
+
+sub new {
+    my $class   = shift;
+    my %options = @_;
+
+    (exists $options{attribute})
+        || confess "You must supply an attribute to construct with";
+
+    (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
+        || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
+
+    ($options{package_name} && $options{name})
+        || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+
+    my $self = $class->_new(\%options);
+
+    weaken($self->{'attribute'});
+
+    return $self;
+}
+
+1;

diff --git a/t/020_attributes/010_attribute_delegation.t b/t/020_attributes/010_attribute_delegation.t
index 91bcf17..6eaf355 100644 (file)
--- a/t/020_attributes/010_attribute_delegation.t
+++ b/t/020_attributes/010_attribute_delegation.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 84;
+use Test::More tests => 85;
 use Test::Exception;
 
 
@@ -37,6 +37,8 @@ isa_ok($bar, 'Bar');
 ok($bar->foo, '... we have something in bar->foo');
 isa_ok($bar->foo, 'Foo');
 
+isa_ok(Bar->meta->get_method('foo_bar'), 'Moose::Meta::Method::Delegation');
+
 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
 
 can_ok($bar, 'foo_bar');