From: gfx <gfuji@cpan.org>
Date: Wed, 9 Jun 2010 11:02:37 +0000 (+0900)
Subject: Make clone_object() into PurePerl
X-Git-Tag: 0.60~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=13b9990881cb1c765a47711fc4eb0d47a404c756;p=gitmo%2FMouse.git

Make clone_object() into PurePerl
---

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 663f6ae..79fac5c 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -228,20 +228,8 @@ sub compute_all_applicable_attributes { # DEPRECATED
 sub linearized_isa;
 
 sub new_object;
+sub clone_object;
 
-sub clone_object {
-    my $class  = shift;
-    my $object = shift;
-    my $args   = $object->Mouse::Object::BUILDARGS(@_);
-
-    (blessed($object) && $object->isa($class->name))
-        || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
-
-    my $cloned = bless { %$object }, ref $object;
-    $class->_initialize_object($cloned, $args, 1);
-
-    return $cloned;
-}
 
 sub clone_instance { # DEPRECATED
     my ($class, $instance, %params) = @_;
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 643795a..44390ed 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -288,6 +288,20 @@ sub new_object {
     return $object;
 }
 
+sub clone_object {
+    my $class  = shift;
+    my $object = shift;
+    my $args   = $object->Mouse::Object::BUILDARGS(@_);
+
+    (blessed($object) && $object->isa($class->name))
+        || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
+
+    my $cloned = bless { %$object }, ref $object;
+    $class->_initialize_object($cloned, $args, 1);
+
+    return $cloned;
+}
+
 sub _initialize_object{
     my($self, $object, $args, $is_cloning) = @_;
 
diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index c47072d..8033635 100644
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -580,11 +580,31 @@ CODE:
 
     RETVAL = mouse_instance_create(aTHX_ MOUSE_xc_stash(xc));
     mouse_class_initialize_object(aTHX_ meta, RETVAL, args, FALSE);
-    mouse_buildall(aTHX_ xc, RETVAL, args); /* BUILDALL */
+    mouse_buildall(aTHX_ xc, RETVAL, sv_2mortal(newRV_inc((SV*)args))); /* BUILDALL */
 }
 OUTPUT:
     RETVAL
 
+SV*
+clone_object(SV* meta, SV* object, ...)
+CODE:
+{
+    AV* const xc   = mouse_get_xc(aTHX_ meta);
+    HV* const args = mouse_buildargs(aTHX_ meta, NULL, ax + 1, items - 1);
+
+    if(!mouse_is_an_instance_of(aTHX_ MOUSE_xc_stash(xc), object)) {
+        mouse_throw_error(meta, object,
+            "You must pass an instance of the metaclass (%"SVf"), not (%"SVf")",
+            mcall0(meta, mouse_name), object);
+    }
+
+    RETVAL = mouse_instance_clone(aTHX_ object);
+    mouse_class_initialize_object(aTHX_ meta, RETVAL, args, TRUE);
+}
+OUTPUT:
+    RETVAL
+
+
 void
 _initialize_object(SV* meta, SV* object, HV* args, bool is_cloning = FALSE)
 CODE: