be a little more anal about when we skip certain methods for delegation

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index ff4730c..20cdd5f 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -394,7 +394,10 @@ sub install_accessors {
             # any of these methods, as they will
             # override the ones in your class, which
             # is almost certainly not what you want.
-            next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
+
+            # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
+            #cluck("Not delegating method '$handle' because it is a core method") and
+            next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 
             if ((reftype($method_to_call) || '') eq 'CODE') {
                 $associated_class->add_method($handle => $method_to_call);

diff --git a/t/100_bugs/006_handles_foreign_class_bug.t b/t/100_bugs/006_handles_foreign_class_bug.t
index 2554dd6..b4db4c7 100644 (file)
--- a/t/100_bugs/006_handles_foreign_class_bug.t
+++ b/t/100_bugs/006_handles_foreign_class_bug.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 8;
+use Test::More tests => 15;
 use Test::Exception;
 
 {
@@ -40,6 +40,8 @@ isa_ok($bar, 'Bar');
 
 is($bar->a, 'Foo::a', '... got the right delgated value');
 
+my @w;
+$SIG{__WARN__} = sub { push @w, "@_" };
 {
     package Baz;
     use Moose;
@@ -56,6 +58,9 @@ is($bar->a, 'Foo::a', '... got the right delgated value');
     
 }
 
+is(@w, 0, "no warnings");
+
+
 my $baz;
 lives_ok {
     $baz = Baz->new;
@@ -68,6 +73,39 @@ is($baz->a, 'Foo::a', '... got the right delgated value');
 
 
 
+@w = ();
+
+{
+    package Blart;
+    use Moose;
+
+    ::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');