From 9a0f3fc06f63ce3a77d1257877bc079fa5d33d99 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 13 Jun 2017 12:28:35 +0000
Subject: Improve docs, add tests, fix a corner case in the implementation.

---
 doc/copy.n           | 10 ++++++++--
 generic/tclOOBasic.c | 15 +++++++++++----
 tests/oo.test        | 35 +++++++++++++++++++++++++++++++++++
 3 files changed, 54 insertions(+), 6 deletions(-)

diff --git a/doc/copy.n b/doc/copy.n
index 1bd0adb..8149397 100644
--- a/doc/copy.n
+++ b/doc/copy.n
@@ -22,10 +22,16 @@ package require TclOO
 The \fBoo::copy\fR command creates a copy of an object or class. It takes the
 name of the object or class to be copied, \fIsourceObject\fR, and optionally
 the name of the object or class to create, \fItargetObject\fR, which will be
-resolved relative to the current namespace if not an absolute qualified name and
+resolved relative to the current namespace if not an absolute qualified name
+and
+.VS TIP473
 \fItargetNamespace\fR which is the name of the namespace where the object is
 going to be created in.
-If \fItargetObject\fR or \fItargetNamespace\fR is omitted, a new name is chosen.
+If either \fItargetObject\fR or \fItargetNamespace\fR is omitted or is given
+as the empty string, a new name is chosen. Names, unless specified, are
+chosen with the same algorithm used by the \fBnew\fR method of
+\fBoo::class\fR.
+.VE TIP473
 The copied object will be of the same class as the source object, and will have 
 all its per-object methods copied. If it is a class, it will also have all the 
 class methods in the class copied, but it will not have any of its instances 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 798bad4..b2c06a7 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1210,7 +1210,9 @@ TclOOCopyObjectCmd(
 
 	name = TclGetString(objv[2]);
 	Tcl_DStringInit(&buffer);
-	if (name[0]!=':' || name[1]!=':') {
+	if (name[0] == '\0') {
+	    name = NULL;
+	} else if (name[0]!=':' || name[1]!=':') {
 	    Interp *iPtr = (Interp *) interp;
 
 	    if (iPtr->varFramePtr != NULL) {
@@ -1222,13 +1224,18 @@ TclOOCopyObjectCmd(
 	    name = Tcl_DStringValue(&buffer);
 	}
 
-	/* Choose a unique namespace name if the user didn't supply one */
-	namespaceName = NULL;
+	/*
+	 * Choose a unique namespace name if the user didn't supply one.
+	 */
 
+	namespaceName = NULL;
 	if (objc == 4) {
 	    namespaceName = TclGetString(objv[3]);
 
-	    if (Tcl_FindNamespace(interp, namespaceName, NULL, 0) != NULL) {
+	    if (namespaceName[0] == '\0') {
+		namespaceName = NULL;
+	    } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
+		    0) != NULL) {
 		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			"%s refers to an existing namespace", namespaceName));
 		return TCL_ERROR;
diff --git a/tests/oo.test b/tests/oo.test
index ccb05c1..15700ae 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2013,6 +2013,41 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
 } -cleanup {
     FooClass destroy
 } -result {foo bar grill bar}
+test oo-15.11 {OO: object cloning} -returnCodes error -body {
+    oo::copy
+} -result {wrong # args: should be "oo::copy sourceName ?targetName? ?targetNamespace?"}
+test oo-15.12 {OO: object cloning with target NS} -setup {
+    oo::class create Super
+    oo::class create Cls {superclass Super}
+} -body {
+    namespace eval ::existing {}
+    oo::copy Cls {} ::existing
+} -returnCodes error -cleanup {
+    Super destroy
+    catch {namespace delete ::existing}
+} -result {::existing refers to an existing namespace}
+test oo-15.13 {OO: object cloning with target NS} -setup {
+    oo::class create Super
+    oo::class create Cls {superclass Super}
+} -body {
+    list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
+} -cleanup {
+    Super destroy
+} -result {0 ::Cls2 1}
+test oo-15.14 {OO: object cloning with target NS} -setup {
+    oo::class create Cls {export eval}
+    set result {}
+} -body {
+    Cls create obj
+    obj eval {
+	proc test-15.14 {} {}
+    }
+    lappend result [info commands ::dupens::t*]
+    oo::copy obj obj2 ::dupens
+    lappend result [info commands ::dupens::t*]
+} -cleanup {
+    Cls destroy
+} -result {{} ::dupens::test-15.14}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
-- 
cgit v0.12