static Tcl_Object
copyObjectInstance(
Tcl_Interp *interp,
Tcl_Object source,
const char *name,
const char *nameSpace)
{
Tcl_Object result;
result = Tcl_CopyObjectInstance(interp, source, name, nameSpace);
if (result == NULL) {
Tcl_AppendResult(interp, "ERROR: copy failed.");
}
return result;
}
int
TclOOCopyObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr, o2Ptr;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
return TCL_ERROR;
}
oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
/*
* Create a cloned object of the correct class. Note that constructors are
* not called. Also note that we must resolve the object name ourselves
* because we do not want to create the object in the current namespace,
* but rather in the context of the namespace of the caller of the overall
* [oo::define] command.
*/
if (objc == 2) {
o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
} else {
const char *name;
Tcl_DString buffer;
name = TclGetString(objv[2]);
Tcl_DStringInit(&buffer);
if (name[0]!=':' || name[1]!=':') {
Interp *iPtr = (Interp *) interp;
if (iPtr->varFramePtr != NULL) {
Tcl_DStringAppend(&buffer,
iPtr->varFramePtr->nsPtr->fullName, -1);
}
TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, name, -1);
name = Tcl_DStringValue(&buffer);
}
o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
Tcl_DStringFree(&buffer);
}
if (o2Ptr == NULL) {
return TCL_ERROR;
}
/*
* Return the name of the cloned object.
*/
Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
return TCL_OK;
}