From: Alex J. G. Burzyński <ajgb@cpan.org>
Date: Thu, 18 Aug 2011 11:49:45 +0000 (+0200)
Subject: fix BUILDALL constructor
X-Git-Tag: v0.009011~12
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9aa500f605f61b9cc25580f9f83678750ed64235;p=gitmo%2FRole-Tiny.git

fix BUILDALL constructor
---

diff --git a/lib/Method/Generate/BuildAll.pm b/lib/Method/Generate/BuildAll.pm
index b8c8a19..b4aa1fb 100644
--- a/lib/Method/Generate/BuildAll.pm
+++ b/lib/Method/Generate/BuildAll.pm
@@ -5,12 +5,18 @@ use base qw(Moo::Object);
 use Sub::Quote;
 use Moo::_mro;
 use Moo::_Utils;
+use B 'perlstring';
 
 sub generate_method {
   my ($self, $into) = @_;
   quote_sub "${into}::BUILDALL", join '',
     qq{    my \$self = shift;\n},
-    $self->buildall_body_for($into, '$self', '@_'),
+    qq{    my \$class = ref \$self;\n},
+      '    if ('. perlstring($into) ." ne \$class) {\n",
+    qq{        return \$self->\${\\(\$Moo::Object::BUILD_MAKER->generate_method(\$class))}(\@_);\n},
+      "    } else {\n",
+               $self->buildall_body_for($into, '$self', '@_'),
+      "    }\n",
     qq{    return \$self\n};
 }
 
@@ -20,7 +26,7 @@ sub buildall_body_for {
     grep *{_getglob($_)}{CODE},
     map "${_}::BUILD",
     reverse @{mro::get_linear_isa($into)};
-  join '', map qq{    ${me}->${_}(${args});\n}, @builds;
+  join '', map qq{        ${me}->${_}(${args});\n}, @builds;
 }
 
 1;
diff --git a/t/buildall-subconstructor.t b/t/buildall-subconstructor.t
new file mode 100644
index 0000000..2cfe28e
--- /dev/null
+++ b/t/buildall-subconstructor.t
@@ -0,0 +1,88 @@
+use strictures 1;
+use Test::More;
+
+my @ran;
+
+{
+  package Foo; use Moo; sub BUILD { push @ran, 'Foo' }
+  package Bar; use Moo; extends 'Foo'; sub BUILD { push @ran, 'Bar' }
+  package Baz; use Moo; extends 'Bar';
+  package Quux; use Moo; extends 'Baz'; sub BUILD { push @ran, 'Quux' }
+}
+
+{
+  package Fleem;
+  use Moo;
+  extends 'Quux';
+  has 'foo' => (is => 'ro');
+  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' }
+}
+
+{
+  package Sub1;
+  use Moo;
+  has 'foo' => (is => 'ro');
+  package Sub2;
+  use Moo;
+  extends 'Sub1';
+  sub BUILD { push @ran, "sub2" }
+}
+
+my @tests = (
+    'Foo' => {
+        ran => [qw( Foo )],
+    },
+    'Bar' => {
+        ran => [qw( Foo Bar )],
+    },
+    'Baz' => {
+        ran => [qw( Foo Bar )],
+    },
+    'Quux' => {
+        ran => [qw( Foo Bar Quux )],
+    },
+    'Fleem' => {
+        ran => [qw( Foo Bar Quux Fleem1 Fleem2 )],
+        args => [ foo => 'Fleem1', bar => 'Fleem2' ],
+    },
+    'Odd1' => {
+        ran => [qw( Odd1 )],
+    },
+    'Odd2' => {
+        ran => [qw( Odd1 )],
+    },
+    'Odd3' => {
+        ran => [qw( Odd1 Odd3 )],
+        args => [ odd1 => 1, odd3 => 3 ],
+    },
+    'Sub1' => {
+        ran => [],
+    },
+    'Sub2' => {
+        ran => [qw( sub2 )],
+    },
+);
+
+while ( my ($class, $conf) = splice(@tests,0,2) ) {
+    my $o = $class->new( @{ $conf->{args} || [] } );
+    isa_ok($o, $class);
+    is_deeply(\@ran, $conf->{ran}, 'BUILDs ran in order');
+    @ran = ();
+}
+
+done_testing;