Commit | Line | Data |
452bac1b |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
f4f3e701 |
6 | use Test::More tests => 58; |
452bac1b |
7 | use Test::Exception; |
8 | |
9 | BEGIN { |
10 | use_ok('Moose'); |
11 | } |
12 | |
f4f3e701 |
13 | # ------------------------------------------------------------------- |
14 | # HASH handles |
15 | # ------------------------------------------------------------------- |
452bac1b |
16 | # the canonical form of of the 'handles' |
17 | # option is the hash ref mapping a |
18 | # method name to the delegated method name |
19 | |
20 | { |
21 | package Foo; |
452bac1b |
22 | use Moose; |
23 | |
24 | has 'bar' => (is => 'rw', default => 10); |
25 | |
26 | package Bar; |
452bac1b |
27 | use Moose; |
28 | |
29 | has 'foo' => ( |
30 | is => 'rw', |
31 | default => sub { Foo->new }, |
32 | handles => { 'foo_bar' => 'bar' } |
33 | ); |
34 | } |
35 | |
36 | my $bar = Bar->new; |
37 | isa_ok($bar, 'Bar'); |
38 | |
39 | ok($bar->foo, '... we have something in bar->foo'); |
40 | isa_ok($bar->foo, 'Foo'); |
41 | |
42 | is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); |
43 | |
44 | can_ok($bar, 'foo_bar'); |
45 | is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); |
46 | |
f4f3e701 |
47 | # change the value ... |
48 | |
49 | $bar->foo->bar(30); |
50 | |
51 | # and make sure the delegation picks it up |
52 | |
53 | is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); |
54 | is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); |
55 | |
56 | # change the value through the delegation ... |
57 | |
58 | $bar->foo_bar(50); |
59 | |
60 | # and make sure everyone sees it |
61 | |
62 | is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); |
63 | is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); |
64 | |
65 | # change the object we are delegating too |
66 | |
452bac1b |
67 | my $foo = Foo->new(bar => 25); |
68 | isa_ok($foo, 'Foo'); |
69 | |
70 | is($foo->bar, 25, '... got the right foo->bar'); |
71 | |
72 | lives_ok { |
73 | $bar->foo($foo); |
74 | } '... assigned the new Foo to Bar->foo'; |
75 | |
76 | is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); |
77 | |
78 | is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); |
79 | is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); |
80 | |
f4f3e701 |
81 | # ------------------------------------------------------------------- |
82 | # ARRAY handles |
83 | # ------------------------------------------------------------------- |
452bac1b |
84 | # we also support an array based format |
85 | # which assumes that the name is the same |
86 | # on either end |
87 | |
88 | { |
89 | package Engine; |
452bac1b |
90 | use Moose; |
91 | |
92 | sub go { 'Engine::go' } |
93 | sub stop { 'Engine::stop' } |
94 | |
95 | package Car; |
452bac1b |
96 | use Moose; |
97 | |
98 | has 'engine' => ( |
99 | is => 'rw', |
100 | default => sub { Engine->new }, |
101 | handles => [ 'go', 'stop' ] |
102 | ); |
103 | } |
104 | |
105 | my $car = Car->new; |
106 | isa_ok($car, 'Car'); |
107 | |
108 | isa_ok($car->engine, 'Engine'); |
109 | can_ok($car->engine, 'go'); |
110 | can_ok($car->engine, 'stop'); |
111 | |
112 | is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); |
113 | is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); |
114 | |
115 | can_ok($car, 'go'); |
116 | can_ok($car, 'stop'); |
117 | |
118 | is($car->go, 'Engine::go', '... got the right value from ->go'); |
119 | is($car->stop, 'Engine::stop', '... got the right value from ->stop'); |
120 | |
f4f3e701 |
121 | # ------------------------------------------------------------------- |
122 | # REGEXP handles |
123 | # ------------------------------------------------------------------- |
452bac1b |
124 | # and we support regexp delegation |
125 | |
126 | { |
127 | package Baz; |
452bac1b |
128 | use Moose; |
129 | |
130 | sub foo { 'Baz::foo' } |
131 | sub bar { 'Baz::bar' } |
132 | sub boo { 'Baz::boo' } |
133 | |
134 | package Baz::Proxy1; |
452bac1b |
135 | use Moose; |
136 | |
137 | has 'baz' => ( |
138 | is => 'ro', |
139 | isa => 'Baz', |
140 | default => sub { Baz->new }, |
141 | handles => qr/.*/ |
142 | ); |
143 | |
144 | package Baz::Proxy2; |
452bac1b |
145 | use Moose; |
146 | |
147 | has 'baz' => ( |
148 | is => 'ro', |
149 | isa => 'Baz', |
150 | default => sub { Baz->new }, |
151 | handles => qr/.oo/ |
152 | ); |
153 | |
154 | package Baz::Proxy3; |
452bac1b |
155 | use Moose; |
156 | |
157 | has 'baz' => ( |
158 | is => 'ro', |
159 | isa => 'Baz', |
160 | default => sub { Baz->new }, |
161 | handles => qr/b.*/ |
162 | ); |
163 | } |
164 | |
165 | { |
166 | my $baz_proxy = Baz::Proxy1->new; |
167 | isa_ok($baz_proxy, 'Baz::Proxy1'); |
168 | |
169 | can_ok($baz_proxy, 'baz'); |
170 | isa_ok($baz_proxy->baz, 'Baz'); |
171 | |
172 | can_ok($baz_proxy, 'foo'); |
173 | can_ok($baz_proxy, 'bar'); |
174 | can_ok($baz_proxy, 'boo'); |
175 | |
176 | is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); |
177 | is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); |
178 | is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); |
179 | } |
180 | { |
181 | my $baz_proxy = Baz::Proxy2->new; |
182 | isa_ok($baz_proxy, 'Baz::Proxy2'); |
183 | |
184 | can_ok($baz_proxy, 'baz'); |
185 | isa_ok($baz_proxy->baz, 'Baz'); |
186 | |
187 | can_ok($baz_proxy, 'foo'); |
188 | can_ok($baz_proxy, 'boo'); |
189 | |
190 | is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); |
191 | is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); |
192 | } |
193 | { |
194 | my $baz_proxy = Baz::Proxy3->new; |
195 | isa_ok($baz_proxy, 'Baz::Proxy3'); |
196 | |
197 | can_ok($baz_proxy, 'baz'); |
198 | isa_ok($baz_proxy->baz, 'Baz'); |
199 | |
200 | can_ok($baz_proxy, 'bar'); |
201 | can_ok($baz_proxy, 'boo'); |
202 | |
203 | is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); |
204 | is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); |
205 | } |
206 | |
f4f3e701 |
207 | # ------------------------------------------------------------------- |
208 | # ROLE handles |
209 | # ------------------------------------------------------------------- |
210 | |
c84f324f |
211 | { |
212 | package Foo::Bar; |
213 | use Moose::Role; |
214 | |
215 | requires 'foo'; |
216 | requires 'bar'; |
217 | |
218 | package Foo::Baz; |
219 | use Moose; |
220 | |
221 | sub foo { 'Foo::Baz::FOO' } |
222 | sub bar { 'Foo::Baz::BAR' } |
223 | sub baz { 'Foo::Baz::BAZ' } |
224 | |
225 | package Foo::Thing; |
226 | use Moose; |
227 | |
228 | has 'thing' => ( |
229 | is => 'rw', |
230 | isa => 'Foo::Baz', |
231 | handles => 'Foo::Bar', |
232 | ); |
233 | |
234 | } |
235 | |
236 | { |
237 | my $foo = Foo::Thing->new(thing => Foo::Baz->new); |
238 | isa_ok($foo, 'Foo::Thing'); |
239 | isa_ok($foo->thing, 'Foo::Baz'); |
240 | |
241 | ok($foo->meta->has_method('foo'), '... we have the method we expect'); |
242 | ok($foo->meta->has_method('bar'), '... we have the method we expect'); |
243 | ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); |
244 | |
245 | is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); |
246 | is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); |
247 | is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); |
248 | } |
249 | |