Implement a can_be_inlined method for MMM::Constructor that does not

inline unless the new method comes from Moose::Object, by
default. Also left a hook in to allow subclasses of MMMC to easily
share this logic.

diff --git a/Changes b/Changes
index b2cbc48..b2664f6 100644 (file)
--- a/Changes
+++ b/Changes
@@ -7,6 +7,14 @@ Revision history for Perl extension Moose
         methods, as opposed to just the first one found. Requested by
         Michael Schwern (RT #41119). (Dave Rolsky)
 
+    * Moose::Meta::Method::Constructor
+      - Moose will no longer inline a constructor for your class
+        unless it inherits its constructor from Moose::Object, and
+        will warn when it doesn't inline. If you want to force
+        inlining anyway, pass "replace_constructor => 1" to
+        make_immutable. Addresses RT #40968, reported by Jon
+        Swartz. (Dave Rolsky)
+
 0.62_01 Wed, December 3, 2008
     * Moose::Object
       - use the method->execute API for BUILDALL

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 839ee26..838a7e2 100644 (file)
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -47,6 +47,35 @@ sub new {
     return $self;
 }
 
+sub can_be_inlined {
+    my $self      = shift;
+    my $metaclass = $self->associated_metaclass;
+
+    if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
+
+        my $expected_class = $self->_expected_constructor_class;
+
+        if ( $constructor->body != $expected_class->can('new') ) {
+            my $class = $metaclass->name;
+            warn "Not inlining a constructor for $class since it is not inheriting the default $expected_class constructor\n";
+
+            return 0;
+        }
+        else {
+            return 1;
+        }
+    }
+
+    # This would be a rather weird case where we have no constructor
+    # in the inheritance chain.
+    return 1;
+}
+
+# This is here so can_be_inlined can be inherited by MooseX modules.
+sub _expected_constructor_class {
+    return 'Moose::Object';
+}
+
 ## accessors
 
 sub options       { (shift)->{'options'}       }

diff --git a/t/300_immutable/010_constructor_is_not_moose.t b/t/300_immutable/010_constructor_is_not_moose.t
new file mode 100644 (file)
index 0000000..948c35f
--- /dev/null
+++ b/t/300_immutable/010_constructor_is_not_moose.t
@@ -0,0 +1,59 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Output";
+plan skip_all => "Test::Output is required for this test" if $@;
+
+plan tests => 4;
+
+{
+    package NotMoose;
+
+    sub new {
+        my $class = shift;
+
+        return bless { not_moose => 1 }, $class;
+    }
+}
+
+{
+    package Foo;
+    use Moose;
+
+    extends 'NotMoose';
+
+    ::stderr_is(
+        sub { Foo->meta->make_immutable },
+        "Not inlining a constructor for Foo since it is not inheriting the default Moose::Object constructor\n",
+        'got a warning that Foo may not have an inlined constructor'
+    );
+}
+
+is(
+    Foo->meta->find_method_by_name('new')->body,
+    NotMoose->can('new'),
+    'Foo->new is inherited from NotMoose'
+);
+
+{
+    package Bar;
+    use Moose;
+
+    extends 'NotMoose';
+
+    ::stderr_is(
+        sub { Foo->meta->make_immutable( replace_constructor => 1 ) },
+        q{},
+        'no warning when replace_constructor is true'
+    );
+}
+
+isnt(
+    Bar->meta->find_method_by_name('new')->body,
+    Moose::Object->can('new'),
+    'Bar->new is not inherited from NotMoose because it was inlined'
+);