1#!/usr/bin/env perl
2use strict;
3use warnings;
4use Test::More;
5use Test::Exception;
6
7my $before = 0;
8do {
9    package Person;
10    use Mouse;
11
12    has name => (is => 'rw');
13    has age  => (is => 'rw');
14
15    sub make_string {
16        my($self, $template) = @_;
17        return sprintf $template, $self->name;
18    }
19
20    package Class;
21    use Mouse;
22
23    has person => (
24        is        => 'rw',
25        lazy      => 1,
26        default   => sub { Person->new(age => 37, name => "Chuck") },
27        predicate => 'has_person',
28        handles   => {
29            person_name => 'name',
30            person_age  => 'age',
31            person_hello => [make_string => 'Hello, %s'],
32        },
33    );
34
35    has me => (
36        is  => 'rw',
37        isa => 'Person',
38        default => sub { Person->new(age => 21, name => "Shawn") },
39        predicate => 'quid',
40        handles => [qw/name age/],
41    );
42
43    before me => sub { $before++ };
44};
45
46can_ok(Class => qw(person has_person person_name person_age name age quid));
47
48my $object = Class->new;
49ok(!$object->has_person, "don't have a person yet");
50$object->person_name("Todd");
51ok($object->has_person, "calling person_name instantiated person");
52ok($object->person, "we really do have a person");
53
54is($object->person_name, "Todd", "handles method");
55is($object->person->name, "Todd", "traditional lookup");
56is($object->person_age, 37, "handles method");
57is($object->person->age, 37, "traditional lookup");
58is($object->person_hello, 'Hello, Todd', 'curring');
59
60my $object2 = Class->new(person => Person->new(name => "Philbert"));
61ok($object2->has_person, "we have a person from the constructor");
62is($object2->person_name, "Philbert", "handles method");
63is($object2->person->name, "Philbert", "traditional lookup");
64is($object2->person_age, undef, "no age because we didn't use the default");
65is($object2->person->age, undef, "no age because we didn't use the default");
66is($object2->person_hello, 'Hello, Philbert', 'currying');
67
68ok($object->quid, "we have a Shawn");
69is($object->name, "Shawn", "name handle");
70is($object->age, 21, "age handle");
71is $before, 2, 'delegations with method modifiers';
72is($object->me->name, "Shawn", "me->name");
73is($object->me->age, 21, "me->age");
74
75is_deeply(
76    $object->meta->get_attribute('me')->handles,
77    [ 'name', 'age' ],
78    "correct handles layout for 'me'",
79);
80
81is_deeply(
82    $object->meta->get_attribute('person')->handles,
83    { person_name => 'name', person_age => 'age', person_hello => [make_string => 'Hello, %s']},
84    "correct handles layout for 'person'",
85);
86
87throws_ok{
88    $object->person(undef);
89    $object->person_name();
90} qr/Cannot delegate person_name to name because the value of person is not defined/;
91
92throws_ok{
93    $object->person([]);
94    $object->person_age();
95} qr/Cannot delegate person_age to age because the value of person is not an object/;
96
97throws_ok{
98    $object->person(undef);
99    $object->person_name();
100} qr/Cannot delegate person_name to name because the value of person is not defined/;
101
102throws_ok{
103    $object->person([]);
104    $object->person_age();
105} qr/Cannot delegate person_age to age because the value of person is not an object/;
106
107
108done_testing;
109
110