t/020_attributes/010_attribute_delegation.t

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