6 use Test::More tests => 84;
11 # -------------------------------------------------------------------
13 # -------------------------------------------------------------------
14 # the canonical form of of the 'handles'
15 # option is the hash ref mapping a
16 # method name to the delegated method name
22 has 'bar' => (is => 'rw', default => 10);
29 default => sub { Foo->new },
30 handles => { 'foo_bar' => 'bar' }
37 ok($bar->foo, '... we have something in bar->foo');
38 isa_ok($bar->foo, 'Foo');
40 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
42 can_ok($bar, 'foo_bar');
43 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
45 # change the value ...
49 # and make sure the delegation picks it up
51 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
52 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
54 # change the value through the delegation ...
58 # and make sure everyone sees it
60 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
61 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
63 # change the object we are delegating too
65 my $foo = Foo->new(bar => 25);
68 is($foo->bar, 25, '... got the right foo->bar');
72 } '... assigned the new Foo to Bar->foo';
74 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
76 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
77 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
79 # -------------------------------------------------------------------
81 # -------------------------------------------------------------------
82 # we also support an array based format
83 # which assumes that the name is the same
90 sub go { 'Engine::go' }
91 sub stop { 'Engine::stop' }
98 default => sub { Engine->new },
99 handles => [ 'go', 'stop' ]
106 isa_ok($car->engine, 'Engine');
107 can_ok($car->engine, 'go');
108 can_ok($car->engine, 'stop');
110 is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
111 is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
114 can_ok($car, 'stop');
116 is($car->go, 'Engine::go', '... got the right value from ->go');
117 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
119 # -------------------------------------------------------------------
121 # -------------------------------------------------------------------
122 # and we support regexp delegation
128 sub foo { 'Baz::foo' }
129 sub bar { 'Baz::bar' }
130 sub boo { 'Baz::boo' }
138 default => sub { Baz->new },
148 default => sub { Baz->new },
158 default => sub { Baz->new },
164 my $baz_proxy = Baz::Proxy1->new;
165 isa_ok($baz_proxy, 'Baz::Proxy1');
167 can_ok($baz_proxy, 'baz');
168 isa_ok($baz_proxy->baz, 'Baz');
170 can_ok($baz_proxy, 'foo');
171 can_ok($baz_proxy, 'bar');
172 can_ok($baz_proxy, 'boo');
174 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
175 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
176 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
179 my $baz_proxy = Baz::Proxy2->new;
180 isa_ok($baz_proxy, 'Baz::Proxy2');
182 can_ok($baz_proxy, 'baz');
183 isa_ok($baz_proxy->baz, 'Baz');
185 can_ok($baz_proxy, 'foo');
186 can_ok($baz_proxy, 'boo');
188 is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
189 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
192 my $baz_proxy = Baz::Proxy3->new;
193 isa_ok($baz_proxy, 'Baz::Proxy3');
195 can_ok($baz_proxy, 'baz');
196 isa_ok($baz_proxy->baz, 'Baz');
198 can_ok($baz_proxy, 'bar');
199 can_ok($baz_proxy, 'boo');
201 is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
202 is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
205 # -------------------------------------------------------------------
207 # -------------------------------------------------------------------
219 sub foo { 'Foo::Baz::FOO' }
220 sub bar { 'Foo::Baz::BAR' }
221 sub baz { 'Foo::Baz::BAZ' }
229 handles => 'Foo::Bar',
235 my $foo = Foo::Thing->new(thing => Foo::Baz->new);
236 isa_ok($foo, 'Foo::Thing');
237 isa_ok($foo->thing, 'Foo::Baz');
239 ok($foo->meta->has_method('foo'), '... we have the method we expect');
240 ok($foo->meta->has_method('bar'), '... we have the method we expect');
241 ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
243 is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
244 is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
245 is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
248 # -------------------------------------------------------------------
250 # -------------------------------------------------------------------
253 package Foo::Autoloaded;
259 my $name = our $AUTOLOAD;
260 $name =~ s/.*://; # strip fully-qualified portion
263 return $self->{$name} = shift;
265 return $self->{$name};
269 package Bar::Autoloaded;
274 default => sub { Foo::Autoloaded->new },
275 handles => { 'foo_bar' => 'bar' }
278 package Baz::Autoloaded;
283 default => sub { Foo::Autoloaded->new },
287 package Goorch::Autoloaded;
293 default => sub { Foo::Autoloaded->new },
296 } '... you cannot delegate to AUTOLOADED class with regexp';
299 # check HASH based delegation w/ AUTOLOAD
302 my $bar = Bar::Autoloaded->new;
303 isa_ok($bar, 'Bar::Autoloaded');
305 ok($bar->foo, '... we have something in bar->foo');
306 isa_ok($bar->foo, 'Foo::Autoloaded');
308 # change the value ...
312 # and make sure the delegation picks it up
314 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
315 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
317 # change the value through the delegation ...
321 # and make sure everyone sees it
323 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
324 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
326 # change the object we are delegating too
328 my $foo = Foo::Autoloaded->new;
329 isa_ok($foo, 'Foo::Autoloaded');
333 is($foo->bar, 25, '... got the right foo->bar');
337 } '... assigned the new Foo to Bar->foo';
339 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
341 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
342 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
345 # check ARRAY based delegation w/ AUTOLOAD
348 my $baz = Baz::Autoloaded->new;
349 isa_ok($baz, 'Baz::Autoloaded');
351 ok($baz->foo, '... we have something in baz->foo');
352 isa_ok($baz->foo, 'Foo::Autoloaded');
354 # change the value ...
358 # and make sure the delegation picks it up
360 is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
361 is($baz->bar, 30, '... baz->foo_bar delegated correctly');
363 # change the value through the delegation ...
367 # and make sure everyone sees it
369 is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
370 is($baz->bar, 50, '... baz->foo_bar delegated correctly');
372 # change the object we are delegating too
374 my $foo = Foo::Autoloaded->new;
375 isa_ok($foo, 'Foo::Autoloaded');
379 is($foo->bar, 25, '... got the right foo->bar');
383 } '... assigned the new Foo to Baz->foo';
385 is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
387 is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
388 is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');