use strict;
use warnings;
-use Test::More tests => 86;
+use Test::More;
use Test::Exception;
-
# -------------------------------------------------------------------
# HASH handles
# -------------------------------------------------------------------
# the canonical form of of the 'handles'
-# option is the hash ref mapping a
+# option is the hash ref mapping a
# method name to the delegated method name
{
package Foo;
use Moose;
- has 'bar' => (is => 'rw', default => 10);
+ has 'bar' => (is => 'rw', default => 10);
+
+ sub baz { 42 }
package Bar;
- use Moose;
-
+ use Moose;
+
has 'foo' => (
is => 'rw',
default => sub { Foo->new },
- handles => { 'foo_bar' => 'bar' }
+ handles => {
+ 'foo_bar' => 'bar',
+ foo_baz => 'baz',
+ 'foo_bar_to_20' => [ bar => 20 ],
+ },
);
}
$bar->foo_bar(50);
-# and make sure everyone sees it
+# and make sure everyone sees it
is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+# curried handles
+$bar->foo_bar_to_20;
+is($bar->foo_bar, 20, '... correctly curried a single argument');
+
# -------------------------------------------------------------------
-# ARRAY handles
+# ARRAY handles
# -------------------------------------------------------------------
# we also support an array based format
-# which assumes that the name is the same
+# which assumes that the name is the same
# on either end
{
use Moose;
sub go { 'Engine::go' }
- sub stop { 'Engine::stop' }
+ sub stop { 'Engine::stop' }
package Car;
- use Moose;
-
+ use Moose;
+
has 'engine' => (
is => 'rw',
default => sub { Engine->new },
is($car->stop, 'Engine::stop', '... got the right value from ->stop');
# -------------------------------------------------------------------
-# REGEXP handles
+# REGEXP handles
# -------------------------------------------------------------------
# and we support regexp delegation
use Moose;
sub foo { 'Baz::foo' }
- sub bar { 'Baz::bar' }
- sub boo { 'Baz::boo' }
+ sub bar { 'Baz::bar' }
+ sub boo { 'Baz::boo' }
package Baz::Proxy1;
- use Moose;
-
+ use Moose;
+
has 'baz' => (
is => 'ro',
isa => 'Baz',
default => sub { Baz->new },
handles => qr/.*/
);
-
+
package Baz::Proxy2;
- use Moose;
-
+ use Moose;
+
has 'baz' => (
is => 'ro',
isa => 'Baz',
default => sub { Baz->new },
handles => qr/.oo/
- );
-
+ );
+
package Baz::Proxy3;
- use Moose;
-
+ use Moose;
+
has 'baz' => (
is => 'ro',
isa => 'Baz',
default => sub { Baz->new },
handles => qr/b.*/
- );
+ );
}
{
can_ok($baz_proxy, 'foo');
can_ok($baz_proxy, 'bar');
can_ok($baz_proxy, 'boo');
-
+
is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
- is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
{
my $baz_proxy = Baz::Proxy2->new;
can_ok($baz_proxy, 'foo');
can_ok($baz_proxy, 'boo');
-
+
is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
- is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
{
my $baz_proxy = Baz::Proxy3->new;
can_ok($baz_proxy, 'bar');
can_ok($baz_proxy, 'boo');
-
+
is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
- is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
}
# -------------------------------------------------------------------
{
package Foo::Bar;
use Moose::Role;
-
+
requires 'foo';
requires 'bar';
-
+
package Foo::Baz;
use Moose;
-
+
sub foo { 'Foo::Baz::FOO' }
sub bar { 'Foo::Baz::BAR' }
- sub baz { 'Foo::Baz::BAZ' }
-
+ sub baz { 'Foo::Baz::BAZ' }
+
package Foo::Thing;
use Moose;
-
+
has 'thing' => (
- is => 'rw',
+ is => 'rw',
isa => 'Foo::Baz',
handles => 'Foo::Bar',
);
+ package Foo::OtherThing;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has 'other_thing' => (
+ is => 'rw',
+ isa => 'Foo::Baz',
+ handles => Moose::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
+ );
}
{
my $foo = Foo::Thing->new(thing => Foo::Baz->new);
isa_ok($foo, 'Foo::Thing');
isa_ok($foo->thing, 'Foo::Baz');
-
+
ok($foo->meta->has_method('foo'), '... we have the method we expect');
ok($foo->meta->has_method('bar'), '... we have the method we expect');
- ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
-
- is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
+ ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
+
+ is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
- is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
+ is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
}
+{
+ my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new);
+ isa_ok($foo, 'Foo::OtherThing');
+ isa_ok($foo->other_thing, 'Foo::Baz');
+
+ ok($foo->meta->has_method('foo'), '... we have the method we expect');
+ ok($foo->meta->has_method('bar'), '... we have the method we expect');
+ ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
+
+ is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
+ is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
+ is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value');
+}
# -------------------------------------------------------------------
# AUTOLOAD & handles
# -------------------------------------------------------------------
my $self = shift;
my $name = our $AUTOLOAD;
- $name =~ s/.*://; # strip fully-qualified portion
+ $name =~ s/.*://; # strip fully-qualified portion
if (@_) {
return $self->{$name} = shift;
}
package Bar::Autoloaded;
- use Moose;
-
+ use Moose;
+
has 'foo' => (
is => 'rw',
default => sub { Foo::Autoloaded->new },
handles => { 'foo_bar' => 'bar' }
);
-
+
package Baz::Autoloaded;
- use Moose;
-
+ use Moose;
+
has 'foo' => (
is => 'rw',
default => sub { Foo::Autoloaded->new },
handles => ['bar']
- );
-
+ );
+
package Goorch::Autoloaded;
- use Moose;
-
+ use Moose;
+
::dies_ok {
has 'foo' => (
is => 'rw',
default => sub { Foo::Autoloaded->new },
handles => qr/bar/
- );
+ );
} '... you cannot delegate to AUTOLOADED class with regexp';
}
$bar->foo_bar(50);
- # and make sure everyone sees it
+ # and make sure everyone sees it
is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
isa_ok($foo, 'Foo::Autoloaded');
$foo->bar(25);
-
+
is($foo->bar, 25, '... got the right foo->bar');
lives_ok {
$baz->bar(50);
- # and make sure everyone sees it
+ # and make sure everyone sees it
is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
is($baz->bar, 50, '... baz->foo_bar delegated correctly');
isa_ok($foo, 'Foo::Autoloaded');
$foo->bar(25);
-
+
is($foo->bar, 25, '... got the right foo->bar');
lives_ok {
is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
}
+
+# Check that removing attributes removes their handles methods also.
+{
+ {
+ package Quux;
+ use Moose;
+ has foo => (
+ isa => 'Foo',
+ default => sub { Foo->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+ }
+ my $i = Quux->new;
+ ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
+ $i->meta->remove_attribute('foo');
+ ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
+}
+
+# Make sure that a useful error message is thrown when the delegation target is
+# not an object
+{
+ my $i = Bar->new(foo => undef);
+ throws_ok { $i->foo_bar } qr/is not defined/,
+ 'useful error from unblessed reference';
+
+ my $j = Bar->new(foo => []);
+ throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/,
+ 'useful error from unblessed reference';
+
+ my $k = Bar->new(foo => "Foo");
+ lives_ok { $k->foo_baz } "but not for class name";
+}
+
+done_testing;