4 use Test::More tests => 26;
17 sub name { $_[0]->{name} = $_[1] if @_ > 1; $_[0]->{name} }
18 sub age { $_[0]->{age} = $_[1] if @_ > 1; $_[0]->{age} }
21 my($self, $template) = @_;
22 return sprintf $template, $self->name;
31 default => sub { Person->new(age => 37, name => "Chuck") },
32 predicate => 'has_person',
34 person_name => 'name',
36 person_hello => [make_string => 'Hello, %s'],
42 default => sub { Person->new(age => 21, name => "Shawn") },
44 handles => [qw/name age/],
48 can_ok(Class => qw(person has_person person_name person_age name age quid));
50 my $object = Class->new;
51 ok(!$object->has_person, "don't have a person yet");
52 $object->person_name("Todd");
53 ok($object->has_person, "calling person_name instantiated person");
54 ok($object->person, "we really do have a person");
56 is($object->person_name, "Todd", "handles method");
57 is($object->person->name, "Todd", "traditional lookup");
58 is($object->person_age, 37, "handles method");
59 is($object->person->age, 37, "traditional lookup");
60 is($object->person_hello, 'Hello, Todd', 'curring');
62 my $object2 = Class->new(person => Person->new(name => "Philbert"));
63 ok($object2->has_person, "we have a person from the constructor");
64 is($object2->person_name, "Philbert", "handles method");
65 is($object2->person->name, "Philbert", "traditional lookup");
66 is($object2->person_age, undef, "no age because we didn't use the default");
67 is($object2->person->age, undef, "no age because we didn't use the default");
68 is($object2->person_hello, 'Hello, Philbert', 'currying');
70 ok($object->quid, "we have a Shawn");
71 is($object->name, "Shawn", "name handle");
72 is($object->age, 21, "age handle");
73 is($object->me->name, "Shawn", "me->name");
74 is($object->me->age, 21, "me->age");
77 $object->meta->get_attribute('me')->handles,
79 "correct handles layout for 'me'",
83 $object->meta->get_attribute('person')->handles,
84 { person_name => 'name', person_age => 'age', person_hello => [make_string => 'Hello, %s']},
85 "correct handles layout for 'person'",
91 $object->person(undef);
92 $object->person_name();
93 } qr/Cannot delegate person_name to name because the value of person is not defined/;
97 $object->person_age();
98 } qr/Cannot delegate person_age to age because the value of person is not an object/;
102 $object->person(undef);
103 $object->person_name();
105 like $@, qr/Cannot delegate person_name to name because the value of person is not defined/;
109 $object->person_age();
111 like $@, qr/Cannot delegate person_age to age because the value of person is not an object/;