Move the generation of delegation methods into MM::Method::Delegation itself.

[gitmo/Moose.git] / lib / Moose / Meta / Method / Delegation.pm

diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm
index 49449ce..e37a235 100644 (file)
--- a/lib/Moose/Meta/Method/Delegation.pm
+++ b/lib/Moose/Meta/Method/Delegation.pm
@@ -18,18 +18,28 @@ sub new {
     my $class   = shift;
     my %options = @_;
 
-    (exists $options{attribute})
+    ( exists $options{attribute} )
         || confess "You must supply an attribute to construct with";
 
-    (blessed($options{attribute}) && $options{attribute}->isa('Moose::Meta::Attribute'))
-        || confess "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
+    ( blessed( $options{attribute} )
+            && $options{attribute}->isa('Moose::Meta::Attribute') )
+        || confess
+        "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
 
-    ($options{package_name} && $options{name})
-        || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+    ( $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);
+    ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
+            || ( 'CODE' eq ref $options{delegate_to_method} ) )
+        || confess
+        'You must supply a delegate_to_method which is a method name or a CODE reference';
 
-    weaken($self->{'attribute'});
+    my $self = $class->_new( \%options );
+
+    weaken( $self->{'attribute'} );
+
+    $self->_initialize_body;
 
     return $self;
 }
@@ -43,6 +53,50 @@ sub _new {
 
 sub associated_attribute { (shift)->{'attribute'} }
 
+sub delegate_to_method { (shift)->{'delegate_to_method'} }
+
+sub _initialize_body {
+    my $self = shift;
+
+    my $method_to_call = $self->delegate_to_method;
+    return $self->{body} = $method_to_call
+        if ref $method_to_call;
+
+    my $accessor = $self->_get_delegate_accessor;
+
+    my $handle_name = $self->name;
+
+    # 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
+    $self->{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(@_);
+    };
+}
+
+sub _get_delegate_accessor {
+    my $self = shift;
+
+    my $accessor = $self->associated_attribute->get_read_method_ref;
+
+    $accessor = $accessor->body if blessed $accessor;
+
+    return $accessor;
+}
+
 1;
 
 __END__
@@ -74,12 +128,21 @@ these options are:
 This must be an instance of C<Moose::Meta::Attribute> which this
 accessor is being generated for. This paramter is B<required>.
 
+=item I<delegate_to_method>
+
+The method in the associated attribute's value to which we
+delegate. This can be either a method name or a code reference.
+
 =back
 
 =item B<associated_attribute>
 
 Returns the attribute associated with this method.
 
+=item B<delegate_to_method>
+
+Returns the method to which this method delegates.
+
 =back
 
 =head1 BUGS