From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 8 Jan 2011 05:41:04 +0000 (+0000)
Subject: rewrite nonMoo detection
X-Git-Tag: release_0.9.5~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c45702917a553f4c038f0fc77869380b57da4742;p=gitmo%2FRole-Tiny.git

rewrite nonMoo detection
---

diff --git a/Changes b/Changes
index 1a1a22c..51ad7f0 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,6 @@
+  - Fix bug where nonMoo is mistakenly detected given a Moo superclass
+    with no attributes (and hence no own constructor)
+
 0.9.4 Mon Dec 13 2010
   - Automatic detection on non-Moo superclasses
 
diff --git a/lib/Moo.pm b/lib/Moo.pm
index 01d9830..2c02cf2 100644
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -48,22 +48,31 @@ sub import {
 }
 
 sub _constructor_maker_for {
-  my ($class, $target) = @_;
+  my ($class, $target, $select_super) = @_;
   return unless $MAKERS{$target};
   $MAKERS{$target}{constructor} ||= do {
     require Method::Generate::Constructor;
-    my $con;
+    require Sub::Defer;
+    my ($moo_constructor, $con);
 
-    # using the -last- entry in @ISA means that classes created by
-    # Role::Tiny as N roles + superclass will still get the attributes
-    # from the superclass via the ->register_attribute_specs call later
-
-    if (my $super = do { no strict 'refs'; ${"${target}::ISA"}[-1] }) {
-      $con = $MAKERS{$super}{constructor} if $MAKERS{$super};
-    }
-    my $moo_constructor = !!$con || do {
+    if ($select_super && $MAKERS{$select_super}) {
+      $moo_constructor = 1;
+      $con = $MAKERS{$select_super}{constructor};
+    } else {
       my $t_new = $target->can('new');
-      $t_new and $t_new == Moo::Object->can('new');
+      if ($t_new) {
+        if ($t_new == Moo::Object->can('new')) {
+          $moo_constructor = 1;
+        } elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) {
+          my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
+          if ($MAKERS{$pkg}) {
+            $moo_constructor = 1;
+            $con = $MAKERS{$pkg}{constructor};
+          }
+        }
+      } else {
+        $moo_constructor = 1; # no other constructor, make a Moo one
+      }
     };
     require Moo::_mro unless $moo_constructor;
     Method::Generate::Constructor
diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm
index a38677a..a8c2083 100644
--- a/lib/Moo/Role.pm
+++ b/lib/Moo/Role.pm
@@ -46,7 +46,7 @@ sub create_class_with_roles {
   }
 
   $me->_handle_constructor(
-    $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }
+    $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }, $superclass
   );
 
   return $new_name;
@@ -58,14 +58,14 @@ sub _install_single_modifier {
 }
 
 sub _handle_constructor {
-  my ($me, $to, $attr_info) = @_;
+  my ($me, $to, $attr_info, $superclass) = @_;
   return unless $attr_info && keys %$attr_info;
   if ($INFO{$to}) {
     @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
   } else {
     # only fiddle with the constructor if the target is a Moo class
     if ($INC{"Moo.pm"}
-        and my $con = Moo->_constructor_maker_for($to)) {
+        and my $con = Moo->_constructor_maker_for($to, $superclass)) {
       $con->register_attribute_specs(%$attr_info);
     }
   }
diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm
index 0aa0068..4f2db1f 100644
--- a/lib/Sub/Defer.pm
+++ b/lib/Sub/Defer.pm
@@ -18,9 +18,15 @@ sub undefer_sub {
     no warnings 'redefine';
     *{_getglob($target)} = $made;
   }
+  push @{$DEFERRED{$made} = $DEFERRED{$deferred}}, $made;
   return $made;
 }
 
+sub defer_info {
+  my ($deferred) = @_;
+  $DEFERRED{$deferred||''};
+}
+
 sub defer_sub {
   my ($target, $maker) = @_;
   my $undeferred;
diff --git a/t/buildall.t b/t/buildall.t
index 9129cc6..a6e64d9 100644
--- a/t/buildall.t
+++ b/t/buildall.t
@@ -18,6 +18,21 @@ my @ran;
   sub BUILD { push @ran, $_[0]->foo, $_[1]->{bar} }
 }
 
+{
+  package Odd1;
+  use Moo;
+  has 'odd1' => (is => 'ro');
+  sub BUILD { push @ran, 'Odd1' }
+  package Odd2;
+  use Moo;
+  extends 'Odd1';
+  package Odd3;
+  use Moo;
+  extends 'Odd2';
+  has 'odd3' => (is => 'ro');
+  sub BUILD { push @ran, 'Odd3' }
+}
+
 my $o = Quux->new;
 
 is(ref($o), 'Quux', 'object returned');
@@ -30,4 +45,11 @@ $o = Fleem->new(foo => 'Fleem1', bar => 'Fleem2');
 is(ref($o), 'Fleem', 'object with inline constructor returned');
 is_deeply(\@ran, [ qw(Foo Bar Quux Fleem1 Fleem2) ], 'BUILDs ran in order');
 
+@ran = ();
+
+$o = Odd3->new(odd1 => 1, odd3 => 3);
+
+is(ref($o), 'Odd3', 'Odd3 object constructed');
+is_deeply(\@ran, [ qw(Odd1 Odd3) ], 'BUILDs ran in order');
+
 done_testing;