From: Matt S Trout <mst@shadowcat.co.uk>
Date: Wed, 20 Jul 2011 02:28:46 +0000 (+0000)
Subject: generate constructors in subclasses on demand
X-Git-Tag: release_0.009009~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e0e12d1608252f728a654c5a015bd5469e28615f;p=gitmo%2FMoo.git

generate constructors in subclasses on demand
---

diff --git a/Changes b/Changes
index 2765308..fe81b8d 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+  - automatically generate constructors in subclasses when required so that
+    subclasses with a BUILD method but no attributes get it honoured
   - add coerce handling
 
 0.009008 - 2011-06-03
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index fdaa636..1d7e740 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -43,6 +43,7 @@ sub generate_method {
   }
   local $self->{captures} = {};
   my $body = '    my $class = shift;'."\n";
+  $body .= $self->_handle_subconstructor($into, $name);
   $body .= $self->_generate_args;
   $body .= $self->_check_required($spec);
   $body .= '    my $new = '.$self->construction_string.";\n";
@@ -60,6 +61,18 @@ sub generate_method {
   ;
 }
 
+sub _handle_subconstructor {
+  my ($self, $into, $name) = @_;
+  if (my $gen = $self->{subconstructor_generator}) {
+    '    if ($class ne '.perlstring($into).') {'."\n".
+    '      '.$gen.";\n".
+    '      return $class->'.$name.'(@_)'.";\n".
+    '    }'."\n";
+  } else {
+    ''
+  }
+}
+
 sub _cap_call {
   my ($self, $code, $captures) = @_;
   @{$self->{captures}}{keys %$captures} = values %$captures if $captures;
diff --git a/lib/Moo.pm b/lib/Moo.pm
index 09ad5c2..3286a87 100644
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -2,6 +2,7 @@ package Moo;
 
 use strictures 1;
 use Moo::_Utils;
+use B 'perlstring';
 
 our $VERSION = '0.009008'; # 0.9.8
 $VERSION = eval $VERSION;
@@ -85,7 +86,10 @@ sub _constructor_maker_for {
           $moo_constructor
             ? ($con ? $con->construction_string : undef)
             : ('$class->'.$target.'::SUPER::new(@_)')
-        )
+        ),
+        subconstructor_generator => (
+          $class.'->_constructor_maker_for($class,'.perlstring($target).')'
+        ),
       )
       ->install_delayed
       ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
diff --git a/t/buildall.t b/t/buildall.t
index a6e64d9..9f441f0 100644
--- a/t/buildall.t
+++ b/t/buildall.t
@@ -33,6 +33,16 @@ my @ran;
   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 $o = Quux->new;
 
 is(ref($o), 'Quux', 'object returned');
@@ -52,4 +62,11 @@ $o = Odd3->new(odd1 => 1, odd3 => 3);
 is(ref($o), 'Odd3', 'Odd3 object constructed');
 is_deeply(\@ran, [ qw(Odd1 Odd3) ], 'BUILDs ran in order');
 
+@ran = ();
+
+$o = Sub2->new;
+
+is(ref($o), 'Sub2', 'Sub2 object constructed');
+is_deeply(\@ran, [ qw(sub2) ], 'BUILD ran');
+
 done_testing;