t/020_attributes/010_attribute_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 84;
   7 use Test::Exception;
   8
   9
  10
  11 # -------------------------------------------------------------------
  12 # HASH handles
  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
  17
  18 {
  19     package Foo;
  20     use Moose;
  21
  22     has 'bar' => (is => 'rw', default => 10);
  23
  24     package Bar;
  25     use Moose;
  26
  27     has 'foo' => (
  28         is      => 'rw',
  29         default => sub { Foo->new },
  30         handles => { 'foo_bar' => 'bar' }
  31     );
  32 }
  33
  34 my $bar = Bar->new;
  35 isa_ok($bar, 'Bar');
  36
  37 ok($bar->foo, '... we have something in bar->foo');
  38 isa_ok($bar->foo, 'Foo');
  39
  40 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
  41
  42 can_ok($bar, 'foo_bar');
  43 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
  44
  45 # change the value ...
  46
  47 $bar->foo->bar(30);
  48
  49 # and make sure the delegation picks it up
  50
  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');
  53
  54 # change the value through the delegation ...
  55
  56 $bar->foo_bar(50);
  57
  58 # and make sure everyone sees it
  59
  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');
  62
  63 # change the object we are delegating too
  64
  65 my $foo = Foo->new(bar => 25);
  66 isa_ok($foo, 'Foo');
  67
  68 is($foo->bar, 25, '... got the right foo->bar');
  69
  70 lives_ok {
  71     $bar->foo($foo);
  72 } '... assigned the new Foo to Bar->foo';
  73
  74 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
  75
  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');
  78
  79 # -------------------------------------------------------------------
  80 # ARRAY handles
  81 # -------------------------------------------------------------------
  82 # we also support an array based format
  83 # which assumes that the name is the same
  84 # on either end
  85
  86 {
  87     package Engine;
  88     use Moose;
  89
  90     sub go   { 'Engine::go'   }
  91     sub stop { 'Engine::stop' }
  92
  93     package Car;
  94     use Moose;
  95
  96     has 'engine' => (
  97         is      => 'rw',
  98         default => sub { Engine->new },
  99         handles => [ 'go', 'stop' ]
 100     );
 101 }
 102
 103 my $car = Car->new;
 104 isa_ok($car, 'Car');
 105
 106 isa_ok($car->engine, 'Engine');
 107 can_ok($car->engine, 'go');
 108 can_ok($car->engine, 'stop');
 109
 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');
 112
 113 can_ok($car, 'go');
 114 can_ok($car, 'stop');
 115
 116 is($car->go, 'Engine::go', '... got the right value from ->go');
 117 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
 118
 119 # -------------------------------------------------------------------
 120 # REGEXP handles
 121 # -------------------------------------------------------------------
 122 # and we support regexp delegation
 123
 124 {
 125     package Baz;
 126     use Moose;
 127
 128     sub foo { 'Baz::foo' }
 129     sub bar { 'Baz::bar' }
 130     sub boo { 'Baz::boo' }
 131
 132     package Baz::Proxy1;
 133     use Moose;
 134
 135     has 'baz' => (
 136         is      => 'ro',
 137         isa     => 'Baz',
 138         default => sub { Baz->new },
 139         handles => qr/.*/
 140     );
 141
 142     package Baz::Proxy2;
 143     use Moose;
 144
 145     has 'baz' => (
 146         is      => 'ro',
 147         isa     => 'Baz',
 148         default => sub { Baz->new },
 149         handles => qr/.oo/
 150     );
 151
 152     package Baz::Proxy3;
 153     use Moose;
 154
 155     has 'baz' => (
 156         is      => 'ro',
 157         isa     => 'Baz',
 158         default => sub { Baz->new },
 159         handles => qr/b.*/
 160     );
 161 }
 162
 163 {
 164     my $baz_proxy = Baz::Proxy1->new;
 165     isa_ok($baz_proxy, 'Baz::Proxy1');
 166
 167     can_ok($baz_proxy, 'baz');
 168     isa_ok($baz_proxy->baz, 'Baz');
 169
 170     can_ok($baz_proxy, 'foo');
 171     can_ok($baz_proxy, 'bar');
 172     can_ok($baz_proxy, 'boo');
 173
 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');
 177 }
 178 {
 179     my $baz_proxy = Baz::Proxy2->new;
 180     isa_ok($baz_proxy, 'Baz::Proxy2');
 181
 182     can_ok($baz_proxy, 'baz');
 183     isa_ok($baz_proxy->baz, 'Baz');
 184
 185     can_ok($baz_proxy, 'foo');
 186     can_ok($baz_proxy, 'boo');
 187
 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');
 190 }
 191 {
 192     my $baz_proxy = Baz::Proxy3->new;
 193     isa_ok($baz_proxy, 'Baz::Proxy3');
 194
 195     can_ok($baz_proxy, 'baz');
 196     isa_ok($baz_proxy->baz, 'Baz');
 197
 198     can_ok($baz_proxy, 'bar');
 199     can_ok($baz_proxy, 'boo');
 200
 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');
 203 }
 204
 205 # -------------------------------------------------------------------
 206 # ROLE handles
 207 # -------------------------------------------------------------------
 208
 209 {
 210     package Foo::Bar;
 211     use Moose::Role;
 212
 213     requires 'foo';
 214     requires 'bar';
 215
 216     package Foo::Baz;
 217     use Moose;
 218
 219     sub foo { 'Foo::Baz::FOO' }
 220     sub bar { 'Foo::Baz::BAR' }
 221     sub baz { 'Foo::Baz::BAZ' }
 222
 223     package Foo::Thing;
 224     use Moose;
 225
 226     has 'thing' => (
 227         is      => 'rw',
 228         isa     => 'Foo::Baz',
 229         handles => 'Foo::Bar',
 230     );
 231
 232 }
 233
 234 {
 235     my $foo = Foo::Thing->new(thing => Foo::Baz->new);
 236     isa_ok($foo, 'Foo::Thing');
 237     isa_ok($foo->thing, 'Foo::Baz');
 238
 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');
 242
 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');
 246 }
 247
 248 # -------------------------------------------------------------------
 249 # AUTOLOAD & handles
 250 # -------------------------------------------------------------------
 251
 252 {
 253     package Foo::Autoloaded;
 254     use Moose;
 255
 256     sub AUTOLOAD {
 257         my $self = shift;
 258
 259         my $name = our $AUTOLOAD;
 260         $name =~ s/.*://;               # strip fully-qualified portion
 261
 262         if (@_) {
 263             return $self->{$name} = shift;
 264         } else {
 265             return $self->{$name};
 266         }
 267     }
 268
 269     package Bar::Autoloaded;
 270     use Moose;
 271
 272     has 'foo' => (
 273         is      => 'rw',
 274         default => sub { Foo::Autoloaded->new },
 275         handles => { 'foo_bar' => 'bar' }
 276     );
 277
 278     package Baz::Autoloaded;
 279     use Moose;
 280
 281     has 'foo' => (
 282         is      => 'rw',
 283         default => sub { Foo::Autoloaded->new },
 284         handles => ['bar']
 285     );
 286
 287     package Goorch::Autoloaded;
 288     use Moose;
 289
 290     ::dies_ok {
 291         has 'foo' => (
 292             is      => 'rw',
 293             default => sub { Foo::Autoloaded->new },
 294             handles => qr/bar/
 295         );
 296     } '... you cannot delegate to AUTOLOADED class with regexp';
 297 }
 298
 299 # check HASH based delegation w/ AUTOLOAD
 300
 301 {
 302     my $bar = Bar::Autoloaded->new;
 303     isa_ok($bar, 'Bar::Autoloaded');
 304
 305     ok($bar->foo, '... we have something in bar->foo');
 306     isa_ok($bar->foo, 'Foo::Autoloaded');
 307
 308     # change the value ...
 309
 310     $bar->foo->bar(30);
 311
 312     # and make sure the delegation picks it up
 313
 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');
 316
 317     # change the value through the delegation ...
 318
 319     $bar->foo_bar(50);
 320
 321     # and make sure everyone sees it
 322
 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');
 325
 326     # change the object we are delegating too
 327
 328     my $foo = Foo::Autoloaded->new;
 329     isa_ok($foo, 'Foo::Autoloaded');
 330
 331     $foo->bar(25);
 332
 333     is($foo->bar, 25, '... got the right foo->bar');
 334
 335     lives_ok {
 336         $bar->foo($foo);
 337     } '... assigned the new Foo to Bar->foo';
 338
 339     is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
 340
 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');
 343 }
 344
 345 # check ARRAY based delegation w/ AUTOLOAD
 346
 347 {
 348     my $baz = Baz::Autoloaded->new;
 349     isa_ok($baz, 'Baz::Autoloaded');
 350
 351     ok($baz->foo, '... we have something in baz->foo');
 352     isa_ok($baz->foo, 'Foo::Autoloaded');
 353
 354     # change the value ...
 355
 356     $baz->foo->bar(30);
 357
 358     # and make sure the delegation picks it up
 359
 360     is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
 361     is($baz->bar, 30, '... baz->foo_bar delegated correctly');
 362
 363     # change the value through the delegation ...
 364
 365     $baz->bar(50);
 366
 367     # and make sure everyone sees it
 368
 369     is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
 370     is($baz->bar, 50, '... baz->foo_bar delegated correctly');
 371
 372     # change the object we are delegating too
 373
 374     my $foo = Foo::Autoloaded->new;
 375     isa_ok($foo, 'Foo::Autoloaded');
 376
 377     $foo->bar(25);
 378
 379     is($foo->bar, 25, '... got the right foo->bar');
 380
 381     lives_ok {
 382         $baz->foo($foo);
 383     } '... assigned the new Foo to Baz->foo';
 384
 385     is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
 386
 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');
 389 }