t/020_attributes/010_attribute_delegation.t

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