don't allow incorrectly-blessed __INSTANCE__ parameters

diff --git a/Changes b/Changes
index bc71570..1cebd7e 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,11 @@
 Revision history for Perl extension Class-MOP.
 
+  [BUG FIXES]
+
+  * The __INSTANCE__ parameter to Class::MOP::Class::new_object now enforces
+    that the passed in reference is blessed into the correct class (by dying if
+    it's not) (doy, jhallock).
+
 1.00 Thu, Mar 25, 2010
 
   [GRRR< FUCKING STEVAN@]

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 16ff246..f6ede8f 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -359,7 +359,21 @@ sub _construct_instance {
     # the code below is almost certainly incorrect
     # but this is foreign inheritance, so we might
     # have to kludge it in the end.
-    my $instance = $params->{__INSTANCE__} || $meta_instance->create_instance();
+    my $instance;
+    if (my $instance_class = blessed($params->{__INSTANCE__})) {
+        ($instance_class eq $class->name)
+            || confess "Objects passed as the __INSTANCE__ parameter must "
+                     . "already be blessed into the correct class, but "
+                     . "$params->{__INSTANCE__} is not a " . $class->name;
+        $instance = $params->{__INSTANCE__};
+    }
+    elsif (exists $params->{__INSTANCE__}) {
+        confess "The __INSTANCE__ parameter must be a blessed reference, not "
+              . $params->{__INSTANCE__};
+    }
+    else {
+        $instance = $meta_instance->create_instance();
+    }
     foreach my $attr ($class->get_all_attributes()) {
         $attr->initialize_instance_slot($meta_instance, $instance, $params);
     }

diff --git a/t/062_custom_instance.t b/t/062_custom_instance.t
new file mode 100644 (file)
index 0000000..da03fdb
--- /dev/null
+++ b/t/062_custom_instance.t
@@ -0,0 +1,142 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use Class::MOP;
+
+my $instance;
+{
+    package Foo;
+
+    sub new {
+        my $class = shift;
+        $instance = bless {@_}, $class;
+        return $instance;
+    }
+
+    sub foo { shift->{foo} }
+}
+
+{
+    package Foo::Sub;
+    use base 'Foo';
+    use metaclass;
+
+    sub new {
+        my $class = shift;
+        $class->meta->new_object(
+            __INSTANCE__ => $class->SUPER::new(@_),
+            @_,
+        );
+    }
+
+    __PACKAGE__->meta->add_attribute(
+        bar => (
+            reader      => 'bar',
+            initializer => sub {
+                my $self = shift;
+                my ($value, $writer, $attr) = @_;
+                $writer->(uc $value);
+            },
+        ),
+    );
+}
+
+undef $instance;
+lives_and {
+    my $foo = Foo::Sub->new;
+    isa_ok($foo, 'Foo');
+    isa_ok($foo, 'Foo::Sub');
+    is($foo, $instance, "used the passed-in instance");
+};
+
+undef $instance;
+lives_and {
+    my $foo = Foo::Sub->new(foo => 'FOO');
+    isa_ok($foo, 'Foo');
+    isa_ok($foo, 'Foo::Sub');
+    is($foo, $instance, "used the passed-in instance");
+    is($foo->foo, 'FOO', "set non-CMOP constructor args");
+};
+
+undef $instance;
+lives_and {
+    my $foo = Foo::Sub->new(bar => 'bar');
+    isa_ok($foo, 'Foo');
+    isa_ok($foo, 'Foo::Sub');
+    is($foo, $instance, "used the passed-in instance");
+    is($foo->bar, 'BAR', "set CMOP attributes");
+};
+
+undef $instance;
+lives_and {
+    my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar');
+    isa_ok($foo, 'Foo');
+    isa_ok($foo, 'Foo::Sub');
+    is($foo, $instance, "used the passed-in instance");
+    is($foo->foo, 'FOO', "set non-CMOP constructor arg");
+    is($foo->bar, 'BAR', "set correct CMOP attribute");
+};
+
+{
+    package BadFoo;
+
+    sub new {
+        my $class = shift;
+        $instance = bless {@_};
+        return $instance;
+    }
+
+    sub foo { shift->{foo} }
+}
+
+{
+    package BadFoo::Sub;
+    use base 'BadFoo';
+    use metaclass;
+
+    sub new {
+        my $class = shift;
+        $class->meta->new_object(
+            __INSTANCE__ => $class->SUPER::new(@_),
+            @_,
+        );
+    }
+
+    __PACKAGE__->meta->add_attribute(
+        bar => (
+            reader      => 'bar',
+            initializer => sub {
+                my $self = shift;
+                my ($value, $writer, $attr) = @_;
+                $writer->(uc $value);
+            },
+        ),
+    );
+}
+
+throws_ok { BadFoo::Sub->new }
+    qr/BadFoo=HASH.*is not a BadFoo::Sub/,
+    "error with incorrect constructors";
+
+{
+    my $meta = Class::MOP::Class->create('Really::Bad::Foo');
+    throws_ok {
+        $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class'))
+    } qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/,
+      "error with completely invalid class";
+}
+
+{
+    my $meta = Class::MOP::Class->create('Really::Bad::Foo::2');
+    for my $invalid ('foo', 1, 0, '') {
+        throws_ok {
+            $meta->new_object(__INSTANCE__ => $invalid)
+        } qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/,
+          "error with unblessed thing";
+    }
+}
+
+done_testing;