Moose-t-failing/020_attributes/010_attribute_delegation.t

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