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 | |
1134f694 |
7 | my $before = 0; |
c3398f5b |
8 | do { |
9 | package Person; |
cb80a70a |
10 | use Mouse; |
c3398f5b |
11 | |
cb80a70a |
12 | has name => (is => 'rw'); |
13 | has age => (is => 'rw'); |
c3398f5b |
14 | |
a2db83e3 |
15 | sub make_string { |
16 | my($self, $template) = @_; |
17 | return sprintf $template, $self->name; |
18 | } |
19 | |
c3398f5b |
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', |
a2db83e3 |
31 | person_hello => [make_string => 'Hello, %s'], |
c3398f5b |
32 | }, |
33 | ); |
34 | |
35 | has me => ( |
cb80a70a |
36 | is => 'rw', |
37 | isa => 'Person', |
c3398f5b |
38 | default => sub { Person->new(age => 21, name => "Shawn") }, |
39 | predicate => 'quid', |
40 | handles => [qw/name age/], |
41 | ); |
cb80a70a |
42 | |
1134f694 |
43 | before me => sub { $before++ }; |
c3398f5b |
44 | }; |
45 | |
46 | can_ok(Class => qw(person has_person person_name person_age name age quid)); |
47 | |
48 | my $object = Class->new; |
49 | ok(!$object->has_person, "don't have a person yet"); |
50 | $object->person_name("Todd"); |
51 | ok($object->has_person, "calling person_name instantiated person"); |
52 | ok($object->person, "we really do have a person"); |
53 | |
54 | is($object->person_name, "Todd", "handles method"); |
55 | is($object->person->name, "Todd", "traditional lookup"); |
56 | is($object->person_age, 37, "handles method"); |
57 | is($object->person->age, 37, "traditional lookup"); |
a2db83e3 |
58 | is($object->person_hello, 'Hello, Todd', 'curring'); |
c3398f5b |
59 | |
60 | my $object2 = Class->new(person => Person->new(name => "Philbert")); |
61 | ok($object2->has_person, "we have a person from the constructor"); |
62 | is($object2->person_name, "Philbert", "handles method"); |
63 | is($object2->person->name, "Philbert", "traditional lookup"); |
64 | is($object2->person_age, undef, "no age because we didn't use the default"); |
65 | is($object2->person->age, undef, "no age because we didn't use the default"); |
a2db83e3 |
66 | is($object2->person_hello, 'Hello, Philbert', 'currying'); |
c3398f5b |
67 | |
68 | ok($object->quid, "we have a Shawn"); |
69 | is($object->name, "Shawn", "name handle"); |
70 | is($object->age, 21, "age handle"); |
1134f694 |
71 | is $before, 2, 'delegations with method modifiers'; |
c3398f5b |
72 | is($object->me->name, "Shawn", "me->name"); |
73 | is($object->me->age, 21, "me->age"); |
74 | |
75 | is_deeply( |
76 | $object->meta->get_attribute('me')->handles, |
c3cc3642 |
77 | [ 'name', 'age' ], |
c3398f5b |
78 | "correct handles layout for 'me'", |
79 | ); |
80 | |
81 | is_deeply( |
82 | $object->meta->get_attribute('person')->handles, |
a2db83e3 |
83 | { person_name => 'name', person_age => 'age', person_hello => [make_string => 'Hello, %s']}, |
c3398f5b |
84 | "correct handles layout for 'person'", |
85 | ); |
86 | |
cb80a70a |
87 | throws_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/; |
912fa381 |
91 | |
cb80a70a |
92 | throws_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/; |
912fa381 |
96 | |
cb80a70a |
97 | throws_ok{ |
7b133c92 |
98 | $object->person(undef); |
99 | $object->person_name(); |
cb80a70a |
100 | } qr/Cannot delegate person_name to name because the value of person is not defined/; |
7b133c92 |
101 | |
cb80a70a |
102 | throws_ok{ |
7b133c92 |
103 | $object->person([]); |
104 | $object->person_age(); |
cb80a70a |
105 | } qr/Cannot delegate person_age to age because the value of person is not an object/; |
106 | |
912fa381 |
107 | |
cb80a70a |
108 | done_testing; |
7b133c92 |
109 | |