X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=t%2F100_bugs%2Ffailing%2F006_handles_foreign_class_bug.t;fp=t%2F100_bugs%2Ffailing%2F006_handles_foreign_class_bug.t;h=c48d9d509bb20058ccc484007f63eedd8ff3dba8;hp=0000000000000000000000000000000000000000;hb=4c98ebb0cca8d5d49d3a91eaf735f9861d00ccb0;hpb=ad20156284763b7d6019af2279f24e1af097f3be

diff --git a/t/100_bugs/failing/006_handles_foreign_class_bug.t b/t/100_bugs/failing/006_handles_foreign_class_bug.t
new file mode 100644
index 0000000..c48d9d5
--- /dev/null
+++ b/t/100_bugs/failing/006_handles_foreign_class_bug.t
@@ -0,0 +1,111 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+{
+    package Foo;
+
+    sub new {
+        bless({}, 'Foo')
+    }
+
+    sub a { 'Foo::a' }
+}
+
+{
+    package Bar;
+    use Mouse;
+
+    ::lives_ok {
+        has 'baz' => (
+            is      => 'ro',
+            isa     => 'Foo',
+            lazy    => 1,
+            default => sub { Foo->new() },
+            handles => qr/^a$/,
+        );
+    } '... can create the attribute with delegations';
+
+}
+
+my $bar;
+lives_ok {
+    $bar = Bar->new;
+} '... created the object ok';
+isa_ok($bar, 'Bar');
+
+is($bar->a, 'Foo::a', '... got the right delgated value');
+
+my @w;
+$SIG{__WARN__} = sub { push @w, "@_" };
+{
+    package Baz;
+    use Mouse;
+
+    ::lives_ok {
+        has 'bar' => (
+            is      => 'ro',
+            isa     => 'Foo',
+            lazy    => 1,
+            default => sub { Foo->new() },
+            handles => qr/.*/,
+        );
+    } '... can create the attribute with delegations';
+
+}
+
+is(@w, 0, "no warnings");
+
+
+my $baz;
+lives_ok {
+    $baz = Baz->new;
+} '... created the object ok';
+isa_ok($baz, 'Baz');
+
+is($baz->a, 'Foo::a', '... got the right delgated value');
+
+
+
+
+
+@w = ();
+
+{
+    package Blart;
+    use Mouse;
+
+    ::lives_ok {
+        has 'bar' => (
+            is      => 'ro',
+            isa     => 'Foo',
+            lazy    => 1,
+            default => sub { Foo->new() },
+            handles => [qw(a new)],
+        );
+    } '... can create the attribute with delegations';
+
+}
+
+{
+    local $TODO = "warning not yet implemented";
+
+    is(@w, 1, "one warning");
+    like($w[0], qr/not delegating.*new/i, "warned");
+}
+
+
+
+my $blart;
+lives_ok {
+    $blart = Blart->new;
+} '... created the object ok';
+isa_ok($blart, 'Blart');
+
+is($blart->a, 'Foo::a', '... got the right delgated value');
+
+