t/039_attribute_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 46;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Moose');
  11 }
  12
  13 # the canonical form of of the 'handles'
  14 # option is the hash ref mapping a
  15 # method name to the delegated method name
  16
  17 {
  18     package Foo;
  19     use strict;
  20     use warnings;
  21     use Moose;
  22
  23     has 'bar' => (is => 'rw', default => 10);
  24
  25     package Bar;
  26     use strict;
  27     use warnings;
  28     use Moose;
  29
  30     has 'foo' => (
  31         is      => 'rw',
  32         default => sub { Foo->new },
  33         handles => { 'foo_bar' => 'bar' }
  34     );
  35 }
  36
  37 my $bar = Bar->new;
  38 isa_ok($bar, 'Bar');
  39
  40 ok($bar->foo, '... we have something in bar->foo');
  41 isa_ok($bar->foo, 'Foo');
  42
  43 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
  44
  45 can_ok($bar, 'foo_bar');
  46 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
  47
  48 my $foo = Foo->new(bar => 25);
  49 isa_ok($foo, 'Foo');
  50
  51 is($foo->bar, 25, '... got the right foo->bar');
  52
  53 lives_ok {
  54     $bar->foo($foo);
  55 } '... assigned the new Foo to Bar->foo';
  56
  57 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
  58
  59 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
  60 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
  61
  62 # we also support an array based format
  63 # which assumes that the name is the same
  64 # on either end
  65
  66 {
  67     package Engine;
  68     use strict;
  69     use warnings;
  70     use Moose;
  71
  72     sub go   { 'Engine::go'   }
  73     sub stop { 'Engine::stop' }
  74
  75     package Car;
  76     use strict;
  77     use warnings;
  78     use Moose;
  79
  80     has 'engine' => (
  81         is      => 'rw',
  82         default => sub { Engine->new },
  83         handles => [ 'go', 'stop' ]
  84     );
  85 }
  86
  87 my $car = Car->new;
  88 isa_ok($car, 'Car');
  89
  90 isa_ok($car->engine, 'Engine');
  91 can_ok($car->engine, 'go');
  92 can_ok($car->engine, 'stop');
  93
  94 is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
  95 is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
  96
  97 can_ok($car, 'go');
  98 can_ok($car, 'stop');
  99
 100 is($car->go, 'Engine::go', '... got the right value from ->go');
 101 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
 102
 103 # and we support regexp delegation
 104
 105 {
 106     package Baz;
 107     use strict;
 108     use warnings;
 109     use Moose;
 110
 111     sub foo { 'Baz::foo' }
 112     sub bar { 'Baz::bar' }
 113     sub boo { 'Baz::boo' }
 114
 115     package Baz::Proxy1;
 116     use strict;
 117     use warnings;
 118     use Moose;
 119
 120     has 'baz' => (
 121         is      => 'ro',
 122         isa     => 'Baz',
 123         default => sub { Baz->new },
 124         handles => qr/.*/
 125     );
 126
 127     package Baz::Proxy2;
 128     use strict;
 129     use warnings;
 130     use Moose;
 131
 132     has 'baz' => (
 133         is      => 'ro',
 134         isa     => 'Baz',
 135         default => sub { Baz->new },
 136         handles => qr/.oo/
 137     );
 138
 139     package Baz::Proxy3;
 140     use strict;
 141     use warnings;
 142     use Moose;
 143
 144     has 'baz' => (
 145         is      => 'ro',
 146         isa     => 'Baz',
 147         default => sub { Baz->new },
 148         handles => qr/b.*/
 149     );
 150 }
 151
 152 {
 153     my $baz_proxy = Baz::Proxy1->new;
 154     isa_ok($baz_proxy, 'Baz::Proxy1');
 155
 156     can_ok($baz_proxy, 'baz');
 157     isa_ok($baz_proxy->baz, 'Baz');
 158
 159     can_ok($baz_proxy, 'foo');
 160     can_ok($baz_proxy, 'bar');
 161     can_ok($baz_proxy, 'boo');
 162
 163     is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
 164     is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
 165     is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
 166 }
 167 {
 168     my $baz_proxy = Baz::Proxy2->new;
 169     isa_ok($baz_proxy, 'Baz::Proxy2');
 170
 171     can_ok($baz_proxy, 'baz');
 172     isa_ok($baz_proxy->baz, 'Baz');
 173
 174     can_ok($baz_proxy, 'foo');
 175     can_ok($baz_proxy, 'boo');
 176
 177     is($baz_proxy->foo, 'Baz::foo', '... 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::Proxy3->new;
 182     isa_ok($baz_proxy, 'Baz::Proxy3');
 183
 184     can_ok($baz_proxy, 'baz');
 185     isa_ok($baz_proxy->baz, 'Baz');
 186
 187     can_ok($baz_proxy, 'bar');
 188     can_ok($baz_proxy, 'boo');
 189
 190     is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
 191     is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
 192 }
 193
 194