From: gfx <gfuji@cpan.org>
Date: Fri, 19 Feb 2010 07:42:01 +0000 (+0900)
Subject: Add argument currying for delegation
X-Git-Tag: 0.50_02~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a2db83e38b11a6f16370ade6061dec71ab4b8106;p=gitmo%2FMouse.git

Add argument currying for delegation
---

diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index 1fa1dd0..6a89774 100644
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -375,7 +375,10 @@ sub _make_delegation_method {
     my $delegator = $self->delegation_metaclass;
     Mouse::Util::load_class($delegator);
 
-    return $delegator->_generate_delegation($self, $handle, $method_to_call);
+    return $delegator->_generate_delegation($self, $handle,
+        ref($method_to_call) eq 'ARRAY'
+            ? @{$method_to_call}
+            :   $method_to_call);
 }
 
 sub throw_error{
diff --git a/lib/Mouse/Meta/Method/Delegation.pm b/lib/Mouse/Meta/Method/Delegation.pm
index 51c898a..06e27ab 100644
--- a/lib/Mouse/Meta/Method/Delegation.pm
+++ b/lib/Mouse/Meta/Method/Delegation.pm
@@ -3,7 +3,7 @@ use Mouse::Util qw(:meta); # enables strict and warnings
 use Scalar::Util;
 
 sub _generate_delegation{
-    my (undef, $attribute, $handle_name, $method_to_call) = @_;
+    my (undef, $attribute, $handle_name, $method_to_call, @curried_args) = @_;
 
     my $reader = $attribute->get_read_method_ref();
     return sub {
@@ -21,7 +21,7 @@ sub _generate_delegation{
                     . $error
              );
         }
-        $proxy->$method_to_call(@_);
+        $proxy->$method_to_call(@curried_args, @_);
     };
 }
 
diff --git a/t/001_mouse/019-handles.t b/t/001_mouse/019-handles.t
index 32f865b..5bae5a9 100644
--- a/t/001_mouse/019-handles.t
+++ b/t/001_mouse/019-handles.t
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 24;
+use Test::More tests => 26;
 use Test::Exception;
 
 do {
@@ -17,6 +17,11 @@ do {
     sub name { $_[0]->{name} = $_[1] if @_ > 1; $_[0]->{name} }
     sub age { $_[0]->{age} = $_[1] if @_ > 1; $_[0]->{age} }
 
+    sub make_string {
+        my($self, $template) = @_;
+        return sprintf $template, $self->name;
+    }
+
     package Class;
     use Mouse;
 
@@ -28,6 +33,7 @@ do {
         handles   => {
             person_name => 'name',
             person_age  => 'age',
+            person_hello => [make_string => 'Hello, %s'],
         },
     );
 
@@ -51,6 +57,7 @@ is($object->person_name, "Todd", "handles method");
 is($object->person->name, "Todd", "traditional lookup");
 is($object->person_age, 37, "handles method");
 is($object->person->age, 37, "traditional lookup");
+is($object->person_hello, 'Hello, Todd', 'curring');
 
 my $object2 = Class->new(person => Person->new(name => "Philbert"));
 ok($object2->has_person, "we have a person from the constructor");
@@ -58,7 +65,7 @@ is($object2->person_name, "Philbert", "handles method");
 is($object2->person->name, "Philbert", "traditional lookup");
 is($object2->person_age, undef, "no age because we didn't use the default");
 is($object2->person->age, undef, "no age because we didn't use the default");
-
+is($object2->person_hello, 'Hello, Philbert', 'currying');
 
 ok($object->quid, "we have a Shawn");
 is($object->name, "Shawn", "name handle");
@@ -74,7 +81,7 @@ is_deeply(
 
 is_deeply(
     $object->meta->get_attribute('person')->handles,
-    { person_name => 'name', person_age => 'age' },
+    { person_name => 'name', person_age => 'age', person_hello => [make_string => 'Hello, %s']},
     "correct handles layout for 'person'",
 );