t/020_attributes/010_attribute_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 85;
   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
 250 # -------------------------------------------------------------------
 251 # AUTOLOAD & handles
 252 # -------------------------------------------------------------------
 253
 254 {
 255     package Foo::Autoloaded;
 256     use Moose;
 257
 258     sub AUTOLOAD {
 259         my $self = shift;
 260
 261         my $name = our $AUTOLOAD;
 262         $name =~ s/.*://;               # strip fully-qualified portion
 263
 264         if (@_) {
 265             return $self->{$name} = shift;
 266         } else {
 267             return $self->{$name};
 268         }
 269     }
 270
 271     package Bar::Autoloaded;
 272     use Moose;
 273
 274     has 'foo' => (
 275         is      => 'rw',
 276         default => sub { Foo::Autoloaded->new },
 277         handles => { 'foo_bar' => 'bar' }
 278     );
 279
 280     package Baz::Autoloaded;
 281     use Moose;
 282
 283     has 'foo' => (
 284         is      => 'rw',
 285         default => sub { Foo::Autoloaded->new },
 286         handles => ['bar']
 287     );
 288
 289     package Goorch::Autoloaded;
 290     use Moose;
 291
 292     ::dies_ok {
 293         has 'foo' => (
 294             is      => 'rw',
 295             default => sub { Foo::Autoloaded->new },
 296             handles => qr/bar/
 297         );
 298     } '... you cannot delegate to AUTOLOADED class with regexp';
 299 }
 300
 301 # check HASH based delegation w/ AUTOLOAD
 302
 303 {
 304     my $bar = Bar::Autoloaded->new;
 305     isa_ok($bar, 'Bar::Autoloaded');
 306
 307     ok($bar->foo, '... we have something in bar->foo');
 308     isa_ok($bar->foo, 'Foo::Autoloaded');
 309
 310     # change the value ...
 311
 312     $bar->foo->bar(30);
 313
 314     # and make sure the delegation picks it up
 315
 316     is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
 317     is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
 318
 319     # change the value through the delegation ...
 320
 321     $bar->foo_bar(50);
 322
 323     # and make sure everyone sees it
 324
 325     is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
 326     is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
 327
 328     # change the object we are delegating too
 329
 330     my $foo = Foo::Autoloaded->new;
 331     isa_ok($foo, 'Foo::Autoloaded');
 332
 333     $foo->bar(25);
 334
 335     is($foo->bar, 25, '... got the right foo->bar');
 336
 337     lives_ok {
 338         $bar->foo($foo);
 339     } '... assigned the new Foo to Bar->foo';
 340
 341     is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
 342
 343     is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
 344     is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
 345 }
 346
 347 # check ARRAY based delegation w/ AUTOLOAD
 348
 349 {
 350     my $baz = Baz::Autoloaded->new;
 351     isa_ok($baz, 'Baz::Autoloaded');
 352
 353     ok($baz->foo, '... we have something in baz->foo');
 354     isa_ok($baz->foo, 'Foo::Autoloaded');
 355
 356     # change the value ...
 357
 358     $baz->foo->bar(30);
 359
 360     # and make sure the delegation picks it up
 361
 362     is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
 363     is($baz->bar, 30, '... baz->foo_bar delegated correctly');
 364
 365     # change the value through the delegation ...
 366
 367     $baz->bar(50);
 368
 369     # and make sure everyone sees it
 370
 371     is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
 372     is($baz->bar, 50, '... baz->foo_bar delegated correctly');
 373
 374     # change the object we are delegating too
 375
 376     my $foo = Foo::Autoloaded->new;
 377     isa_ok($foo, 'Foo::Autoloaded');
 378
 379     $foo->bar(25);
 380
 381     is($foo->bar, 25, '... got the right foo->bar');
 382
 383     lives_ok {
 384         $baz->foo($foo);
 385     } '... assigned the new Foo to Baz->foo';
 386
 387     is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
 388
 389     is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
 390     is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
 391 }