From 9522bf6fed9c7eb8da5cd6684b609e84964fb0ac Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Thu, 20 May 2010 16:05:00 -0500
Subject: handle broken constructors that don't like to be subclassed
 (jhallock)

---
 lib/MooseX/NonMoose/Meta/Role/Class.pm       | 16 +++++
 lib/MooseX/NonMoose/Meta/Role/Constructor.pm | 17 ++++-
 t/101-buggy-constructors.t                   | 98 ++++++++++++++++++++++++++++
 3 files changed, 130 insertions(+), 1 deletion(-)
 create mode 100644 t/101-buggy-constructors.t

diff --git a/lib/MooseX/NonMoose/Meta/Role/Class.pm b/lib/MooseX/NonMoose/Meta/Role/Class.pm
index 5f78326..cc7275e 100644
--- a/lib/MooseX/NonMoose/Meta/Role/Class.pm
+++ b/lib/MooseX/NonMoose/Meta/Role/Class.pm
@@ -142,6 +142,22 @@ sub _check_superclass_constructor {
                            ? $class->FOREIGNBUILDARGS(@_)
                            : @_;
         my $instance = $super_new->execute($class, @foreign_params);
+        if (!blessed($instance)) {
+            confess "The constructor for "
+                  . $super_new->associated_metaclass->name
+                  . " did not return a blessed instance";
+        }
+        elsif (!$instance->isa($class)) {
+            if (!$class->isa(blessed($instance))) {
+                confess "The constructor for "
+                      . $super_new->associated_metaclass->name
+                      . " returned an object whose class is not a parent of "
+                      . $class;
+            }
+            else {
+                bless $instance, $class;
+            }
+        }
         return Class::MOP::Class->initialize($class)->new_object(
             __INSTANCE__ => $instance,
             %$params,
diff --git a/lib/MooseX/NonMoose/Meta/Role/Constructor.pm b/lib/MooseX/NonMoose/Meta/Role/Constructor.pm
index 9a69d7c..d0ececb 100644
--- a/lib/MooseX/NonMoose/Meta/Role/Constructor.pm
+++ b/lib/MooseX/NonMoose/Meta/Role/Constructor.pm
@@ -59,7 +59,22 @@ sub _generate_instance {
                 ? "${class_var}->FOREIGNBUILDARGS(\@_)"
                 : '@_';
     my $instance = "$super_new_class->$new($arglist)";
-    "my $var = " . $self->_meta_instance->inline_rebless_instance_structure($instance, $class_var) . ";\n";
+    return "my $var = $instance;\n"
+         . "if (!Scalar::Util::blessed($var)) {\n"
+         . "    " . $self->_inline_throw_error(
+               "'The constructor for $super_new_class did not return a blessed instance'"
+           ) . ";\n"
+         . "}\n"
+         . "elsif (!$var->isa($class_var)) {\n"
+         . "    if (!$class_var->isa(Scalar::Util::blessed($var))) {\n"
+         . "        " . $self->_inline_throw_error(
+               "\"The constructor for $super_new_class returned an object whose class is not a parent of $class_var\""
+           ) . ";\n"
+         . "    }\n"
+         . "    else {\n"
+         . "        " . $self->_meta_instance->inline_rebless_instance_structure($var, $class_var) . ";\n"
+         . "    }\n"
+         . "}\n";
 }
 
 no Moose::Role;
diff --git a/t/101-buggy-constructors.t b/t/101-buggy-constructors.t
new file mode 100644
index 0000000..066498d
--- /dev/null
+++ b/t/101-buggy-constructors.t
@@ -0,0 +1,98 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Test::Moose;
+
+{
+    package Foo;
+
+    sub new { bless {}, shift }
+}
+
+{
+    package Foo::Sub;
+    use Moose;
+    use MooseX::NonMoose;
+
+    extends 'Foo';
+}
+
+with_immutable {
+    my $foo;
+    lives_ok {
+        $foo = Foo::Sub->new;
+    } "subclassing nonmoose classes with correct constructors works";
+    isa_ok($foo, 'Foo');
+    isa_ok($foo, 'Foo::Sub');
+} 'Foo::Sub';
+
+{
+    package BadFoo;
+
+    sub new { bless {} }
+}
+
+{
+    package BadFoo::Sub;
+    use Moose;
+    use MooseX::NonMoose;
+
+    extends 'BadFoo';
+}
+
+with_immutable {
+    my $foo;
+    lives_ok {
+        $foo = BadFoo::Sub->new;
+    } "subclassing nonmoose classes with incorrect constructors works";
+    isa_ok($foo, 'BadFoo');
+    isa_ok($foo, 'BadFoo::Sub');
+} 'BadFoo::Sub';
+
+{
+    package BadFoo2;
+
+    sub new { {} }
+}
+
+{
+    package BadFoo2::Sub;
+    use Moose;
+    use MooseX::NonMoose;
+
+    extends 'BadFoo2';
+}
+
+with_immutable {
+    my $foo;
+    throws_ok {
+        $foo = BadFoo2::Sub->new;
+    } qr/\QThe constructor for BadFoo2 did not return a blessed instance/,
+      "subclassing nonmoose classes with incorrect constructors dies properly";
+} 'BadFoo2::Sub';
+
+{
+    package BadFoo3;
+
+    sub new { bless {}, 'Something::Else::Entirely' }
+}
+
+{
+    package BadFoo3::Sub;
+    use Moose;
+    use MooseX::NonMoose;
+
+    extends 'BadFoo3';
+}
+
+with_immutable {
+    my $foo;
+    throws_ok {
+        $foo = BadFoo3::Sub->new;
+    } qr/\QThe constructor for BadFoo3 returned an object whose class is not a parent of BadFoo3::Sub/,
+      "subclassing nonmoose classes with incorrect constructors dies properly";
+} 'BadFoo3::Sub';
+
+done_testing;
-- 
cgit v1.2.3-54-g00ecf