diff options
| -rw-r--r-- | doc/copy.n | 10 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 15 | ||||
| -rw-r--r-- | tests/oo.test | 35 |
3 files changed, 54 insertions, 6 deletions
@@ -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 |