diff options
| -rw-r--r-- | doc/copy.n | 21 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 32 | ||||
| -rw-r--r-- | tests/oo.test | 35 |
3 files changed, 77 insertions, 11 deletions
@@ -14,7 +14,7 @@ oo::copy \- create copies of objects and classes .nf package require TclOO -\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? +\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR? .fi .BE .SH DESCRIPTION @@ -22,11 +22,20 @@ 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. -If \fItargetObject\fR is omitted, a new name is chosen. 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 copied. +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 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 +copied. .PP .VS After the \fItargetObject\fR has been created and all definitions of its diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 8cb80e5..b2c06a7 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1183,8 +1183,9 @@ TclOOCopyObjectCmd( { Tcl_Object oPtr, o2Ptr; - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?"); + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "sourceName ?targetName? ?targetNamespace?"); return TCL_ERROR; } @@ -1204,12 +1205,14 @@ TclOOCopyObjectCmd( if (objc == 2) { o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); } else { - const char *name; + const char *name, *namespaceName; Tcl_DString buffer; 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) { @@ -1220,7 +1223,26 @@ TclOOCopyObjectCmd( Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); } - o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL); + + /* + * Choose a unique namespace name if the user didn't supply one. + */ + + namespaceName = NULL; + if (objc == 4) { + namespaceName = TclGetString(objv[3]); + + 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; + } + } + + o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); Tcl_DStringFree(&buffer); } diff --git a/tests/oo.test b/tests/oo.test index cb37a76..5eaa8bf 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 |