t/020_attributes/010_attribute_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 58;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Moose');
  11 }
  12
  13 # -------------------------------------------------------------------
  14 # HASH handles
  15 # -------------------------------------------------------------------
  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;
  22     use Moose;
  23
  24     has 'bar' => (is => 'rw', default => 10);
  25
  26     package Bar;
  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
  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
  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
  81 # -------------------------------------------------------------------
  82 # ARRAY handles
  83 # -------------------------------------------------------------------
  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;
  90     use Moose;
  91
  92     sub go   { 'Engine::go'   }
  93     sub stop { 'Engine::stop' }
  94
  95     package Car;
  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
 121 # -------------------------------------------------------------------
 122 # REGEXP handles
 123 # -------------------------------------------------------------------
 124 # and we support regexp delegation
 125
 126 {
 127     package Baz;
 128     use Moose;
 129
 130     sub foo { 'Baz::foo' }
 131     sub bar { 'Baz::bar' }
 132     sub boo { 'Baz::boo' }
 133
 134     package Baz::Proxy1;
 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;
 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;
 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
 207 # -------------------------------------------------------------------
 208 # ROLE handles
 209 # -------------------------------------------------------------------
 210
 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