X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=t%2F020_attributes%2Ffailing%2F010_attribute_delegation.t;fp=t%2F020_attributes%2Ffailing%2F010_attribute_delegation.t;h=0000000000000000000000000000000000000000;hp=9dd746a239190afbeebce444927f60c45a6c1759;hb=c47cf41554416ee1828eab17d31342a53aaa0839;hpb=9864f0e4ba233c5f30ad6dc7c484ced43d883d27

diff --git a/t/020_attributes/failing/010_attribute_delegation.t b/t/020_attributes/failing/010_attribute_delegation.t
deleted file mode 100644
index 9dd746a..0000000
--- a/t/020_attributes/failing/010_attribute_delegation.t
+++ /dev/null
@@ -1,436 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 92;
-use Test::Exception;
-
-
-
-# -------------------------------------------------------------------
-# HASH handles
-# -------------------------------------------------------------------
-# the canonical form of of the 'handles'
-# option is the hash ref mapping a
-# method name to the delegated method name
-
-{
-    package Foo;
-    use Mouse;
-
-    has 'bar' => (is => 'rw', default => 10);
-
-    sub baz { 42 }
-
-    package Bar;
-    use Mouse;
-
-    has 'foo' => (
-        is      => 'rw',
-        default => sub { Foo->new },
-        handles => {
-            'foo_bar' => 'bar',
-            foo_baz => 'baz',
-            'foo_bar_to_20' => [ bar => 20 ],
-        },
-    );
-}
-
-my $bar = Bar->new;
-isa_ok($bar, 'Bar');
-
-ok($bar->foo, '... we have something in bar->foo');
-isa_ok($bar->foo, 'Foo');
-
-my $meth = Bar->meta->get_method('foo_bar');
-isa_ok($meth, 'Mouse::Meta::Method::Delegation');
-is($meth->associated_attribute->name, 'foo',
-   'associated_attribute->name for this method is foo');
-
-is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
-
-can_ok($bar, 'foo_bar');
-is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
-
-# change the value ...
-
-$bar->foo->bar(30);
-
-# and make sure the delegation picks it up
-
-is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
-is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
-
-# change the value through the delegation ...
-
-$bar->foo_bar(50);
-
-# 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');
-
-# change the object we are delegating too
-
-my $foo = Foo->new(bar => 25);
-isa_ok($foo, 'Foo');
-
-is($foo->bar, 25, '... got the right foo->bar');
-
-lives_ok {
-    $bar->foo($foo);
-} '... assigned the new Foo to Bar->foo';
-
-is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
-
-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
-# -------------------------------------------------------------------
-# we also support an array based format
-# which assumes that the name is the same
-# on either end
-
-{
-    package Engine;
-    use Mouse;
-
-    sub go   { 'Engine::go'   }
-    sub stop { 'Engine::stop' }
-
-    package Car;
-    use Mouse;
-
-    has 'engine' => (
-        is      => 'rw',
-        default => sub { Engine->new },
-        handles => [ 'go', 'stop' ]
-    );
-}
-
-my $car = Car->new;
-isa_ok($car, 'Car');
-
-isa_ok($car->engine, 'Engine');
-can_ok($car->engine, 'go');
-can_ok($car->engine, 'stop');
-
-is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
-is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
-
-can_ok($car, 'go');
-can_ok($car, 'stop');
-
-is($car->go, 'Engine::go', '... got the right value from ->go');
-is($car->stop, 'Engine::stop', '... got the right value from ->stop');
-
-# -------------------------------------------------------------------
-# REGEXP handles
-# -------------------------------------------------------------------
-# and we support regexp delegation
-
-{
-    package Baz;
-    use Mouse;
-
-    sub foo { 'Baz::foo' }
-    sub bar { 'Baz::bar' }
-    sub boo { 'Baz::boo' }
-
-    package Baz::Proxy1;
-    use Mouse;
-
-    has 'baz' => (
-        is      => 'ro',
-        isa     => 'Baz',
-        default => sub { Baz->new },
-        handles => qr/.*/
-    );
-
-    package Baz::Proxy2;
-    use Mouse;
-
-    has 'baz' => (
-        is      => 'ro',
-        isa     => 'Baz',
-        default => sub { Baz->new },
-        handles => qr/.oo/
-    );
-
-    package Baz::Proxy3;
-    use Mouse;
-
-    has 'baz' => (
-        is      => 'ro',
-        isa     => 'Baz',
-        default => sub { Baz->new },
-        handles => qr/b.*/
-    );
-}
-
-{
-    my $baz_proxy = Baz::Proxy1->new;
-    isa_ok($baz_proxy, 'Baz::Proxy1');
-
-    can_ok($baz_proxy, 'baz');
-    isa_ok($baz_proxy->baz, 'Baz');
-
-    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');
-}
-{
-    my $baz_proxy = Baz::Proxy2->new;
-    isa_ok($baz_proxy, 'Baz::Proxy2');
-
-    can_ok($baz_proxy, 'baz');
-    isa_ok($baz_proxy->baz, 'Baz');
-
-    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');
-}
-{
-    my $baz_proxy = Baz::Proxy3->new;
-    isa_ok($baz_proxy, 'Baz::Proxy3');
-
-    can_ok($baz_proxy, 'baz');
-    isa_ok($baz_proxy->baz, 'Baz');
-
-    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');
-}
-
-# -------------------------------------------------------------------
-# ROLE handles
-# -------------------------------------------------------------------
-
-{
-    package Foo::Bar;
-    use Mouse::Role;
-
-    requires 'foo';
-    requires 'bar';
-
-    package Foo::Baz;
-    use Mouse;
-
-    sub foo { 'Foo::Baz::FOO' }
-    sub bar { 'Foo::Baz::BAR' }
-    sub baz { 'Foo::Baz::BAZ' }
-
-    package Foo::Thing;
-    use Mouse;
-
-    has 'thing' => (
-        is      => 'rw',
-        isa     => 'Foo::Baz',
-        handles => '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');
-    is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
-    is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
-}
-
-# -------------------------------------------------------------------
-# AUTOLOAD & handles
-# -------------------------------------------------------------------
-
-{
-    package Foo::Autoloaded;
-    use Mouse;
-
-    sub AUTOLOAD {
-        my $self = shift;
-
-        my $name = our $AUTOLOAD;
-        $name =~ s/.*://; # strip fully-qualified portion
-
-        if (@_) {
-            return $self->{$name} = shift;
-        } else {
-            return $self->{$name};
-        }
-    }
-
-    package Bar::Autoloaded;
-    use Mouse;
-
-    has 'foo' => (
-        is      => 'rw',
-        default => sub { Foo::Autoloaded->new },
-        handles => { 'foo_bar' => 'bar' }
-    );
-
-    package Baz::Autoloaded;
-    use Mouse;
-
-    has 'foo' => (
-        is      => 'rw',
-        default => sub { Foo::Autoloaded->new },
-        handles => ['bar']
-    );
-
-    package Goorch::Autoloaded;
-    use Mouse;
-
-    ::dies_ok {
-        has 'foo' => (
-            is      => 'rw',
-            default => sub { Foo::Autoloaded->new },
-            handles => qr/bar/
-        );
-    } '... you cannot delegate to AUTOLOADED class with regexp';
-}
-
-# check HASH based delegation w/ AUTOLOAD
-
-{
-    my $bar = Bar::Autoloaded->new;
-    isa_ok($bar, 'Bar::Autoloaded');
-
-    ok($bar->foo, '... we have something in bar->foo');
-    isa_ok($bar->foo, 'Foo::Autoloaded');
-
-    # change the value ...
-
-    $bar->foo->bar(30);
-
-    # and make sure the delegation picks it up
-
-    is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
-    is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
-
-    # change the value through the delegation ...
-
-    $bar->foo_bar(50);
-
-    # 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');
-
-    # change the object we are delegating too
-
-    my $foo = Foo::Autoloaded->new;
-    isa_ok($foo, 'Foo::Autoloaded');
-
-    $foo->bar(25);
-
-    is($foo->bar, 25, '... got the right foo->bar');
-
-    lives_ok {
-        $bar->foo($foo);
-    } '... assigned the new Foo to Bar->foo';
-
-    is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
-
-    is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
-    is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
-}
-
-# check ARRAY based delegation w/ AUTOLOAD
-
-{
-    my $baz = Baz::Autoloaded->new;
-    isa_ok($baz, 'Baz::Autoloaded');
-
-    ok($baz->foo, '... we have something in baz->foo');
-    isa_ok($baz->foo, 'Foo::Autoloaded');
-
-    # change the value ...
-
-    $baz->foo->bar(30);
-
-    # and make sure the delegation picks it up
-
-    is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
-    is($baz->bar, 30, '... baz->foo_bar delegated correctly');
-
-    # change the value through the delegation ...
-
-    $baz->bar(50);
-
-    # 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');
-
-    # change the object we are delegating too
-
-    my $foo = Foo::Autoloaded->new;
-    isa_ok($foo, 'Foo::Autoloaded');
-
-    $foo->bar(25);
-
-    is($foo->bar, 25, '... got the right foo->bar');
-
-    lives_ok {
-        $baz->foo($foo);
-    } '... assigned the new Foo to Baz->foo';
-
-    is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
-
-    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 Mouse;
-        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";
-}