t/attributes/attribute_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   8
   9
  10 # -------------------------------------------------------------------
  11 # HASH handles
  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 Moose;
  20
  21     has 'bar' => (is => 'rw', default => 10);
  22
  23     sub baz { 42 }
  24
  25     package Bar;
  26     use Moose;
  27
  28     has 'foo' => (
  29         is      => 'rw',
  30         default => sub { Foo->new },
  31         handles => {
  32             'foo_bar' => 'bar',
  33             foo_baz => 'baz',
  34             'foo_bar_to_20' => [ bar => 20 ],
  35         },
  36     );
  37 }
  38
  39 my $bar = Bar->new;
  40 isa_ok($bar, 'Bar');
  41
  42 ok($bar->foo, '... we have something in bar->foo');
  43 isa_ok($bar->foo, 'Foo');
  44
  45 my $meth = Bar->meta->get_method('foo_bar');
  46 isa_ok($meth, 'Moose::Meta::Method::Delegation');
  47 is($meth->associated_attribute->name, 'foo',
  48    'associated_attribute->name for this method is foo');
  49
  50 is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
  51
  52 can_ok($bar, 'foo_bar');
  53 is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
  54
  55 # change the value ...
  56
  57 $bar->foo->bar(30);
  58
  59 # and make sure the delegation picks it up
  60
  61 is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
  62 is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
  63
  64 # change the value through the delegation ...
  65
  66 $bar->foo_bar(50);
  67
  68 # and make sure everyone sees it
  69
  70 is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
  71 is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
  72
  73 # change the object we are delegating too
  74
  75 my $foo = Foo->new(bar => 25);
  76 isa_ok($foo, 'Foo');
  77
  78 is($foo->bar, 25, '... got the right foo->bar');
  79
  80 is( exception {
  81     $bar->foo($foo);
  82 }, undef, '... assigned the new Foo to Bar->foo' );
  83
  84 is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
  85
  86 is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
  87 is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
  88
  89 # curried handles
  90 $bar->foo_bar_to_20;
  91 is($bar->foo_bar, 20, '... correctly curried a single argument');
  92
  93 # -------------------------------------------------------------------
  94 # ARRAY handles
  95 # -------------------------------------------------------------------
  96 # we also support an array based format
  97 # which assumes that the name is the same
  98 # on either end
  99
 100 {
 101     package Engine;
 102     use Moose;
 103
 104     sub go   { 'Engine::go'   }
 105     sub stop { 'Engine::stop' }
 106
 107     package Car;
 108     use Moose;
 109
 110     has 'engine' => (
 111         is      => 'rw',
 112         default => sub { Engine->new },
 113         handles => [ 'go', 'stop' ]
 114     );
 115 }
 116
 117 my $car = Car->new;
 118 isa_ok($car, 'Car');
 119
 120 isa_ok($car->engine, 'Engine');
 121 can_ok($car->engine, 'go');
 122 can_ok($car->engine, 'stop');
 123
 124 is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
 125 is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
 126
 127 can_ok($car, 'go');
 128 can_ok($car, 'stop');
 129
 130 is($car->go, 'Engine::go', '... got the right value from ->go');
 131 is($car->stop, 'Engine::stop', '... got the right value from ->stop');
 132
 133 # -------------------------------------------------------------------
 134 # REGEXP handles
 135 # -------------------------------------------------------------------
 136 # and we support regexp delegation
 137
 138 {
 139     package Baz;
 140     use Moose;
 141
 142     sub foo { 'Baz::foo' }
 143     sub bar { 'Baz::bar' }
 144     sub boo { 'Baz::boo' }
 145
 146     package Baz::Proxy1;
 147     use Moose;
 148
 149     has 'baz' => (
 150         is      => 'ro',
 151         isa     => 'Baz',
 152         default => sub { Baz->new },
 153         handles => qr/.*/
 154     );
 155
 156     package Baz::Proxy2;
 157     use Moose;
 158
 159     has 'baz' => (
 160         is      => 'ro',
 161         isa     => 'Baz',
 162         default => sub { Baz->new },
 163         handles => qr/.oo/
 164     );
 165
 166     package Baz::Proxy3;
 167     use Moose;
 168
 169     has 'baz' => (
 170         is      => 'ro',
 171         isa     => 'Baz',
 172         default => sub { Baz->new },
 173         handles => qr/b.*/
 174     );
 175 }
 176
 177 {
 178     my $baz_proxy = Baz::Proxy1->new;
 179     isa_ok($baz_proxy, 'Baz::Proxy1');
 180
 181     can_ok($baz_proxy, 'baz');
 182     isa_ok($baz_proxy->baz, 'Baz');
 183
 184     can_ok($baz_proxy, 'foo');
 185     can_ok($baz_proxy, 'bar');
 186     can_ok($baz_proxy, 'boo');
 187
 188     is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
 189     is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
 190     is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
 191 }
 192 {
 193     my $baz_proxy = Baz::Proxy2->new;
 194     isa_ok($baz_proxy, 'Baz::Proxy2');
 195
 196     can_ok($baz_proxy, 'baz');
 197     isa_ok($baz_proxy->baz, 'Baz');
 198
 199     can_ok($baz_proxy, 'foo');
 200     can_ok($baz_proxy, 'boo');
 201
 202     is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
 203     is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
 204 }
 205 {
 206     my $baz_proxy = Baz::Proxy3->new;
 207     isa_ok($baz_proxy, 'Baz::Proxy3');
 208
 209     can_ok($baz_proxy, 'baz');
 210     isa_ok($baz_proxy->baz, 'Baz');
 211
 212     can_ok($baz_proxy, 'bar');
 213     can_ok($baz_proxy, 'boo');
 214
 215     is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
 216     is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
 217 }
 218
 219 # -------------------------------------------------------------------
 220 # ROLE handles
 221 # -------------------------------------------------------------------
 222
 223 {
 224     package Foo::Bar;
 225     use Moose::Role;
 226
 227     requires 'foo';
 228     requires 'bar';
 229
 230     package Foo::Baz;
 231     use Moose;
 232
 233     sub foo { 'Foo::Baz::FOO' }
 234     sub bar { 'Foo::Baz::BAR' }
 235     sub baz { 'Foo::Baz::BAZ' }
 236
 237     package Foo::Thing;
 238     use Moose;
 239
 240     has 'thing' => (
 241         is      => 'rw',
 242         isa     => 'Foo::Baz',
 243         handles => 'Foo::Bar',
 244     );
 245
 246     package Foo::OtherThing;
 247     use Moose;
 248     use Moose::Util::TypeConstraints;
 249
 250     has 'other_thing' => (
 251         is      => 'rw',
 252         isa     => 'Foo::Baz',
 253         handles => Moose::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
 254     );
 255 }
 256
 257 {
 258     my $foo = Foo::Thing->new(thing => Foo::Baz->new);
 259     isa_ok($foo, 'Foo::Thing');
 260     isa_ok($foo->thing, 'Foo::Baz');
 261
 262     ok($foo->meta->has_method('foo'), '... we have the method we expect');
 263     ok($foo->meta->has_method('bar'), '... we have the method we expect');
 264     ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
 265
 266     is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
 267     is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
 268     is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
 269 }
 270
 271 {
 272     my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new);
 273     isa_ok($foo, 'Foo::OtherThing');
 274     isa_ok($foo->other_thing, 'Foo::Baz');
 275
 276     ok($foo->meta->has_method('foo'), '... we have the method we expect');
 277     ok($foo->meta->has_method('bar'), '... we have the method we expect');
 278     ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
 279
 280     is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
 281     is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
 282     is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value');
 283 }
 284 # -------------------------------------------------------------------
 285 # AUTOLOAD & handles
 286 # -------------------------------------------------------------------
 287
 288 {
 289     package Foo::Autoloaded;
 290     use Moose;
 291
 292     sub AUTOLOAD {
 293         my $self = shift;
 294
 295         my $name = our $AUTOLOAD;
 296         $name =~ s/.*://; # strip fully-qualified portion
 297
 298         if (@_) {
 299             return $self->{$name} = shift;
 300         } else {
 301             return $self->{$name};
 302         }
 303     }
 304
 305     package Bar::Autoloaded;
 306     use Moose;
 307
 308     has 'foo' => (
 309         is      => 'rw',
 310         default => sub { Foo::Autoloaded->new },
 311         handles => { 'foo_bar' => 'bar' }
 312     );
 313
 314     package Baz::Autoloaded;
 315     use Moose;
 316
 317     has 'foo' => (
 318         is      => 'rw',
 319         default => sub { Foo::Autoloaded->new },
 320         handles => ['bar']
 321     );
 322
 323     package Goorch::Autoloaded;
 324     use Moose;
 325
 326     ::isnt( ::exception {
 327         has 'foo' => (
 328             is      => 'rw',
 329             default => sub { Foo::Autoloaded->new },
 330             handles => qr/bar/
 331         );
 332     }, undef, '... you cannot delegate to AUTOLOADED class with regexp' );
 333 }
 334
 335 # check HASH based delegation w/ AUTOLOAD
 336
 337 {
 338     my $bar = Bar::Autoloaded->new;
 339     isa_ok($bar, 'Bar::Autoloaded');
 340
 341     ok($bar->foo, '... we have something in bar->foo');
 342     isa_ok($bar->foo, 'Foo::Autoloaded');
 343
 344     # change the value ...
 345
 346     $bar->foo->bar(30);
 347
 348     # and make sure the delegation picks it up
 349
 350     is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
 351     is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
 352
 353     # change the value through the delegation ...
 354
 355     $bar->foo_bar(50);
 356
 357     # and make sure everyone sees it
 358
 359     is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
 360     is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
 361
 362     # change the object we are delegating too
 363
 364     my $foo = Foo::Autoloaded->new;
 365     isa_ok($foo, 'Foo::Autoloaded');
 366
 367     $foo->bar(25);
 368
 369     is($foo->bar, 25, '... got the right foo->bar');
 370
 371     is( exception {
 372         $bar->foo($foo);
 373     }, undef, '... assigned the new Foo to Bar->foo' );
 374
 375     is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
 376
 377     is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
 378     is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
 379 }
 380
 381 # check ARRAY based delegation w/ AUTOLOAD
 382
 383 {
 384     my $baz = Baz::Autoloaded->new;
 385     isa_ok($baz, 'Baz::Autoloaded');
 386
 387     ok($baz->foo, '... we have something in baz->foo');
 388     isa_ok($baz->foo, 'Foo::Autoloaded');
 389
 390     # change the value ...
 391
 392     $baz->foo->bar(30);
 393
 394     # and make sure the delegation picks it up
 395
 396     is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
 397     is($baz->bar, 30, '... baz->foo_bar delegated correctly');
 398
 399     # change the value through the delegation ...
 400
 401     $baz->bar(50);
 402
 403     # and make sure everyone sees it
 404
 405     is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
 406     is($baz->bar, 50, '... baz->foo_bar delegated correctly');
 407
 408     # change the object we are delegating too
 409
 410     my $foo = Foo::Autoloaded->new;
 411     isa_ok($foo, 'Foo::Autoloaded');
 412
 413     $foo->bar(25);
 414
 415     is($foo->bar, 25, '... got the right foo->bar');
 416
 417     is( exception {
 418         $baz->foo($foo);
 419     }, undef, '... assigned the new Foo to Baz->foo' );
 420
 421     is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
 422
 423     is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
 424     is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
 425 }
 426
 427 # Check that removing attributes removes their handles methods also.
 428 {
 429     {
 430         package Quux;
 431         use Moose;
 432         has foo => (
 433             isa => 'Foo',
 434             default => sub { Foo->new },
 435             handles => { 'foo_bar' => 'bar' }
 436         );
 437     }
 438     my $i = Quux->new;
 439     ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
 440     $i->meta->remove_attribute('foo');
 441     ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
 442 }
 443
 444 # Make sure that a useful error message is thrown when the delegation target is
 445 # not an object
 446 {
 447     my $i = Bar->new(foo => undef);
 448     like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' );
 449
 450     my $j = Bar->new(foo => []);
 451     like( exception { $j->foo_bar }, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' );
 452
 453     my $k = Bar->new(foo => "Foo");
 454     is( exception { $k->foo_baz }, undef, "but not for class name" );
 455 }
 456
 457 {
 458     package Delegator;
 459     use Moose;
 460
 461     sub full { 1 }
 462     sub stub;
 463
 464     ::like(
 465         ::exception{ has d1 => (
 466                 isa     => 'X',
 467                 handles => ['full'],
 468             );
 469             },
 470         qr/\QYou cannot overwrite a locally defined method (full) with a delegation/,
 471         'got an error when trying to declare a delegation method that overwrites a local method'
 472     );
 473
 474     ::is(
 475         ::exception{ has d2 => (
 476                 isa     => 'X',
 477                 handles => ['stub'],
 478             );
 479             },
 480         undef,
 481         'no error when trying to declare a delegation method that overwrites a stub method'
 482     );
 483 }
 484
 485 done_testing;