t/020_attributes/failing/010_attribute_delegation.t

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