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