X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F001_mouse%2F019-handles.t;h=4878cc66fd80f66bee59cfcaf025993eb8ea45fb;hb=HEAD;hp=d9bb7c39fdc65086b4a8184d9968d290e83beaed;hpb=3fab876a432091471f0c7f8bf2c6c9eb0f289567;p=gitmo%2FMouse.git

diff --git a/t/001_mouse/019-handles.t b/t/001_mouse/019-handles.t
index d9bb7c3..4878cc6 100644
--- a/t/001_mouse/019-handles.t
+++ b/t/001_mouse/019-handles.t
@@ -1,22 +1,22 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 27;
+use Test::More;
 use Test::Exception;
 
+my $before = 0;
 do {
     package Person;
+    use Mouse;
 
-    sub new {
-        my $class = shift;
-        my %args  = @_;
+    has name => (is => 'rw');
+    has age  => (is => 'rw');
 
-        bless \%args, $class;
+    sub make_string {
+        my($self, $template) = @_;
+        return sprintf $template, $self->name;
     }
 
-    sub name { $_[0]->{name} = $_[1] if @_ > 1; $_[0]->{name} }
-    sub age { $_[0]->{age} = $_[1] if @_ > 1; $_[0]->{age} }
-
     package Class;
     use Mouse;
 
@@ -28,45 +28,19 @@ do {
         handles   => {
             person_name => 'name',
             person_age  => 'age',
+            person_hello => [make_string => 'Hello, %s'],
         },
     );
 
     has me => (
-        is => 'rw',
+        is  => 'rw',
+        isa => 'Person',
         default => sub { Person->new(age => 21, name => "Shawn") },
         predicate => 'quid',
         handles => [qw/name age/],
     );
 
-    TODO: {
-        local our $TODO = "Mouse lacks this";
-        eval {
-            has error => (
-                handles => "string",
-            );
-        };
-        ::ok(!$@, "handles => role");
-    }
-
-    TODO: {
-        local our $TODO = "Mouse lacks this";
-        eval {
-            has error2 => (
-                handles => \"ref_to_string",
-            );
-        };
-        ::ok(!$@, "handles => \\str");
-    }
-
-    TODO: {
-        local our $TODO = "Mouse lacks this";
-        eval {
-            has error4 => (
-                handles => sub { "code" },
-            );
-        };
-        ::ok(!$@, "handles => sub { code }");
-    }
+    before me => sub { $before++ };
 };
 
 can_ok(Class => qw(person has_person person_name person_age name age quid));
@@ -81,6 +55,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");
@@ -88,11 +63,12 @@ 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");
 is($object->age, 21, "age handle");
+is $before, 2, 'delegations with method modifiers';
 is($object->me->name, "Shawn", "me->name");
 is($object->me->age, 21, "me->age");
 
@@ -104,34 +80,30 @@ 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'",
 );
 
+throws_ok{
+    $object->person(undef);
+    $object->person_name();
+} qr/Cannot delegate person_name to name because the value of person is not defined/;
 
-{
-    local $TODO = "failed on some environment, but I don't know why it happens (gfx)";
-    throws_ok{
-        $object->person(undef);
-        $object->person_name();
-    } qr/Cannot delegate person_name to name because the value of person is not defined/;
-
-    throws_ok{
-        $object->person([]);
-        $object->person_age();
-    } qr/Cannot delegate person_age to age because the value of person is not an object/;
-}
+throws_ok{
+    $object->person([]);
+    $object->person_age();
+} qr/Cannot delegate person_age to age because the value of person is not an object/;
 
-eval{
+throws_ok{
     $object->person(undef);
     $object->person_name();
-};
-like $@, qr/Cannot delegate person_name to name because the value of person is not defined/;
+} qr/Cannot delegate person_name to name because the value of person is not defined/;
 
-eval{
+throws_ok{
     $object->person([]);
     $object->person_age();
-};
-like $@, qr/Cannot delegate person_age to age because the value of person is not an object/;
+} qr/Cannot delegate person_age to age because the value of person is not an object/;
+
 
+done_testing;