Backport of oo::object-><cloned> in C.

11 files changed, 446 insertions, 345 deletions

diff --git a/generic/tclInt.h b/generic/tclInt.h
index c450c80..2499501 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -750,6 +750,8 @@ typedef struct VarInHash {
 #define VAR_ARRAY		0x1
 #define VAR_LINK		0x2
 #define VAR_CONSTANT		0x10000
+#define VAR_TYPE \
+	(VAR_ARRAY | VAR_LINK | VAR_CONSTANT)
 
 /* Type of storage (0 is compiled local) */
 #define VAR_IN_HASHTABLE	0x4
@@ -3368,6 +3370,10 @@ MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
 			    Tcl_Obj *originObjPtr);
 MODULE_SCOPE Tcl_Size	TclConvertElement(const char *src, Tcl_Size length,
 			    char *dst, int flags);
+MODULE_SCOPE int	TclCopyNamespaceProcedures(Tcl_Interp *interp,
+			    Namespace *srcNsPtr, Namespace *tgtNsPtr);
+MODULE_SCOPE int	TclCopyNamespaceVariables(Tcl_Interp *interp,
+			    Namespace *originNs, Namespace *targetNs);
 MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp,
 			    const char *cmdName, Tcl_Namespace *nsPtr,
 			    Tcl_ObjCmdProc *proc, void *clientData,
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 2e84bf8..7900790 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -133,6 +133,7 @@ static Tcl_CmdDeleteProc	MyClassDeleted;
 	{TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}
 
 static const DeclaredClassMethod objMethods[] = {
+    DCM("<cloned>", 0,	TclOO_Object_Cloned),
     DCM("destroy", 1,	TclOO_Object_Destroy),
     DCM("eval", 0,	TclOO_Object_Eval),
     DCM("unknown", 0,	TclOO_Object_Unknown),
@@ -194,12 +195,6 @@ static const char initScript[] =
 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
 
 /*
- * The scripted part of the definitions of TclOO.
- */
-
-#include "tclOOScript.h"
-
-/*
  * The actual definition of the variable holding the TclOO stub table.
  */
 
@@ -501,12 +496,7 @@ InitFoundation(
     }
 
     MakeAdditionalClasses(fPtr, define, objdef);
-
-    /*
-     * Evaluate the remaining definitions, which are a compiled-in Tcl script.
-     */
-
-    return Tcl_EvalEx(interp, tclOOSetupScript, TCL_INDEX_NONE, 0);
+    return TCL_OK;
 }
 
 /*
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 030d497..61b20ee 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -616,6 +616,48 @@ TclOO_Configurable_Constructor(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOO_Object_Cloned --
+ *
+ *	Handler for cloning objects that clones basic bits (only!) of the
+ *	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+ *	more complex (and class-specific) handling.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOO_Object_Cloned(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Interpreter for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    Object *originObject, *targetObject;
+    Namespace *originNs, *targetNs;
+
+    if (objc != skip + 1) {
+	Tcl_WrongNumArgs(interp, skip, objv, "originObject");
+	return TCL_ERROR;
+    }
+
+    targetObject = (Object *) Tcl_ObjectContextObject(context);
+    originObject = (Object *) Tcl_GetObjectFromObj(interp, objv[skip]);
+    if (!originObject) {
+	return TCL_ERROR;
+    }
+
+    originNs = (Namespace *) originObject->namespacePtr;
+    targetNs = (Namespace *) targetObject->namespacePtr;
+    if (TclCopyNamespaceProcedures(interp, originNs, targetNs) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    return TclCopyNamespaceVariables(interp, originNs, targetNs);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOO_Object_Destroy --
  *
  *	Implementation for oo::object->destroy method.
@@ -1916,6 +1958,16 @@ TclOODelegateNameObjCmd(
     return TCL_OK;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Singleton_New, MarkAsSingleton --
+ *
+ *	Implementation for oo::singleton->new method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
 int
 TclOO_Singleton_New(
     TCL_UNUSED(void *),
@@ -1972,6 +2024,17 @@ MarkAsSingleton(
     return result;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_SingletonInstance_Destroy, TclOO_SingletonInstance_Cloned --
+ *
+ *	Implementation for oo::SingletonInstance->destroy method and its
+ *	cloning callback method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
 int
 TclOO_SingletonInstance_Destroy(
     TCL_UNUSED(void *),
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 66ec7d1..326fe61 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -538,6 +538,7 @@ MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_Constructor;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_Create;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_CreateNs;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Class_New;
+MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_Cloned;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_Destroy;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_Eval;
 MODULE_SCOPE Tcl_MethodCallProc	TclOO_Object_LinkVar;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
deleted file mode 100644
index 24a3255..0000000
--- a/generic/tclOOScript.h
+++ /dev/null
@@ -1,67 +0,0 @@
-/*
- * tclOOScript.h --
- *
- *	This file contains support scripts for TclOO. They are defined here so
- *	that the code can be definitely run even in safe interpreters; TclOO's
- *	core setup is safe.
- *
- * Copyright (c) 2012-2018 Donal K. Fellows
- * Copyright (c) 2013 Andreas Kupries
- * Copyright (c) 2017 Gerald Lester
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef TCL_OO_SCRIPT_H
-#define TCL_OO_SCRIPT_H
-
-/*
- * The scripted part of the definitions of TclOO.
- *
- * Compiled from tools/tclOOScript.tcl by tools/makeHeader.tcl, which
- * contains the commented version of everything; *this* file is automatically
- * generated.
- */
-
-static const char *tclOOSetupScript =
-/* !BEGIN!: Do not edit below this line. */
-"::oo::define ::oo::object method <cloned> -unexport {originObject} {\n"
-"\tforeach p [info procs [info object namespace $originObject]::*] {\n"
-"\t\tset args [info args $p]\n"
-"\t\tset idx -1\n"
-"\t\tforeach a $args {\n"
-"\t\t\tif {[info default $p $a d]} {\n"
-"\t\t\t\tlset args [incr idx] [list $a $d]\n"
-"\t\t\t} else {\n"
-"\t\t\t\tlset args [incr idx] [list $a]\n"
-"\t\t\t}\n"
-"\t\t}\n"
-"\t\tset b [info body $p]\n"
-"\t\tset p [namespace tail $p]\n"
-"\t\tproc $p $args $b\n"
-"\t}\n"
-"\tforeach v [info vars [info object namespace $originObject]::*] {\n"
-"\t\tupvar 0 $v vOrigin\n"
-"\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
-"\t\tif {[info exists vOrigin]} {\n"
-"\t\t\tif {[array exists vOrigin]} {\n"
-"\t\t\t\tarray set vNew [array get vOrigin]\n"
-"\t\t\t} else {\n"
-"\t\t\t\tset vNew $vOrigin\n"
-"\t\t\t}\n"
-"\t\t}\n"
-"\t}\n"
-"}\n"
-/* !END!: Do not edit above this line. */
-;
-
-#endif /* TCL_OO_SCRIPT_H */
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index cc3d5fb..3f92d1a 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2831,6 +2831,202 @@ TclGetCmdFrameForProcedure(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TclCopyNamespaceProcedures --
+ *
+ *	Copy procedures from one namespace into another.
+ *
+ * Results:
+ *	A standard Tcl result code.
+ *
+ * Side effects:
+ *	Modifies the target namespace's commands.
+ *
+ *----------------------------------------------------------------------
+ */
+
+/* Duplicate an argument to a procedure. */
+static inline int
+DuplicateArgument(
+    Proc *newProc,
+    const CompiledLocal *origLocal,
+    Tcl_Size i)
+{
+    const char *argname = origLocal->name;
+    Tcl_Size nameLength = origLocal->nameLength;
+    CompiledLocal *localPtr;
+
+    /*
+     * Allocate an entry in the runtime procedure frame's list of local
+     * variables for the argument.
+     */
+
+    localPtr = (CompiledLocal *)Tcl_AttemptAlloc(
+	    offsetof(CompiledLocal, name) + 1U + nameLength);
+    if (!localPtr) {
+	return TCL_ERROR;
+    }
+    if (newProc->firstLocalPtr == NULL) {
+	newProc->firstLocalPtr = newProc->lastLocalPtr = localPtr;
+    } else {
+	newProc->lastLocalPtr->nextPtr = localPtr;
+	newProc->lastLocalPtr = localPtr;
+    }
+    localPtr->nextPtr = NULL;
+    localPtr->nameLength = nameLength;
+    localPtr->frameIndex = i;
+    localPtr->flags = VAR_ARGUMENT;
+    localPtr->resolveInfo = NULL;
+    localPtr->defValuePtr = origLocal->defValuePtr;
+    if (localPtr->defValuePtr) {
+	Tcl_IncrRefCount(localPtr->defValuePtr);
+    }
+    memcpy(localPtr->name, argname, nameLength + 1);
+    if (origLocal->flags & VAR_IS_ARGS) {
+	localPtr->flags |= VAR_IS_ARGS;
+    }
+    return TCL_OK;
+}
+
+/* Duplicate a procedure into a different namespace. */
+static int
+DuplicateProc(
+    Tcl_Interp *interp,
+    Namespace *nsPtr,
+    const char *cmdName,
+    const Proc *origProc,
+    const Command *origCmd)
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Size length, i;
+    const char *bytes;
+    Tcl_Obj *bodyPtr;
+    Proc *newProc;
+    const CompiledLocal *origLocal;
+    Tcl_HashEntry *origHePtr;
+
+    /* Duplicate the string of body, not the bytecode. */
+    bytes = TclGetStringFromObj(origProc->bodyPtr, &length);
+    bodyPtr = Tcl_NewStringObj(bytes, length);
+    TclContinuationsCopy(bodyPtr, origProc->bodyPtr);
+    Tcl_IncrRefCount(bodyPtr);
+
+    /* The new procedure record. */
+    newProc = (Proc *) Tcl_Alloc(sizeof(Proc));
+    newProc->iPtr = iPtr;
+    newProc->refCount = 1;
+    newProc->bodyPtr = bodyPtr;
+    newProc->numArgs = origProc->numArgs;
+    newProc->numCompiledLocals = origProc->numArgs;
+    newProc->firstLocalPtr = NULL;
+    newProc->lastLocalPtr = NULL;
+
+    /* Work through the original arguments, duplicating them. */
+    origLocal = origProc->firstLocalPtr;
+    for (i = 0; i < newProc->numArgs; i++) {
+	if (DuplicateArgument(newProc, origLocal, i) != TCL_OK) {
+	    /* Don't set the interp result here. Since a malloc just failed,
+	     * first clean up some memory before doing that. */
+	    goto procError;
+	}
+	origLocal = origLocal->nextPtr;
+    }
+
+    /* Create the new command backed by the procedure. */
+    newProc->cmdPtr = (Command *) TclNRCreateCommandInNs(interp, cmdName,
+	    (Tcl_Namespace *) nsPtr, TclObjInterpProc, NRInterpProc, newProc,
+	    TclProcDeleteProc);
+
+    /* TIP #280: Duplicate the origin information (if we have it). */
+    origHePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, origProc);
+    if (origHePtr) {
+	CmdFrame *newCfPtr = (CmdFrame *) Tcl_Alloc(sizeof(CmdFrame));
+	const CmdFrame *origCfPtr = (CmdFrame *) Tcl_GetHashValue(origHePtr);
+	Tcl_HashEntry *hePtr;
+	int isNew;
+
+	/* Copy info, then fix up bits that need different treatment. */
+	memcpy(newCfPtr, origCfPtr, sizeof(CmdFrame));
+	newCfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size));
+	newCfPtr->line[0] = origCfPtr->line[0];
+	Tcl_IncrRefCount(newCfPtr->data.eval.path);
+
+	hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, newProc, &isNew);
+	Tcl_SetHashValue(hePtr, newCfPtr);
+    }
+
+    /* Optimize for no-op procs. Note that this is simpler than in [proc]; we
+     * just see whether we've got the compiler in the old command! */
+    if (origCmd->compileProc == TclCompileNoOp) {
+	newProc->cmdPtr->compileProc = TclCompileNoOp;
+    }
+
+    return TCL_OK;
+
+  procError:
+    /* Delete the data allocated so far. */
+    Tcl_DecrRefCount(bodyPtr);
+    while (newProc->firstLocalPtr != NULL) {
+	CompiledLocal *localPtr = newProc->firstLocalPtr;
+	newProc->firstLocalPtr = localPtr->nextPtr;
+
+	if (localPtr->defValuePtr != NULL) {
+	    Tcl_DecrRefCount(localPtr->defValuePtr);
+	}
+
+	Tcl_Free(localPtr);
+    }
+    Tcl_Free(newProc);
+    /* Complain about the failure to allocate. */
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "procedure \"%s\": arg list contains too many (%"
+	    TCL_SIZE_MODIFIER "d) entries", cmdName, origProc->numArgs));
+    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+	    TOOMANYARGS, (char *)NULL);
+    return TCL_ERROR;
+}
+
+/* Duplicate all the procedures in a namespace into another (new) namespace. */
+int
+TclCopyNamespaceProcedures(
+    Tcl_Interp *interp,
+    Namespace *srcNsPtr,	/* Where to copy from. */
+    Namespace *tgtNsPtr)	/* Where to copy to. */
+{
+    Tcl_HashEntry *entryPtr;
+    Tcl_HashSearch search;
+    if (srcNsPtr == tgtNsPtr) {
+	Tcl_Panic("cannot copy procedures from one namespace to itself");
+    }
+    for (entryPtr = Tcl_FirstHashEntry(&srcNsPtr->cmdTable, &search);
+	    entryPtr; entryPtr = Tcl_NextHashEntry(&search)) {
+	const char *cmdName = (const char *)
+		Tcl_GetHashKey(&srcNsPtr->cmdTable, entryPtr);
+	Command *cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+	Proc *procPtr;
+
+	/* For non-procedures, check if this is an import of a procedure; those
+	 * also get copied. */
+	if (!TclIsProc(cmdPtr)) {
+	    Command *realCmdPtr = (Command *)
+		    TclGetOriginalCommand((Tcl_Command) cmdPtr);
+	    if (!realCmdPtr || !TclIsProc(realCmdPtr)) {
+		continue;
+	    }
+	    cmdPtr = realCmdPtr;
+	}
+
+	/* Make the copy. */
+	procPtr = (Proc *) cmdPtr->objClientData;
+	if (DuplicateProc(interp, tgtNsPtr, cmdName, procPtr, cmdPtr) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 53538df..5f6730a 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -7058,6 +7058,183 @@ SetArrayDefault(
     }
 }
 
+/*----------------------------------------------------------------------
+ *
+ * TclCopyNamespaceVariables --
+ *
+ *	This copies the variables of one namespace (the source) to another
+ *	(the target). It skips variables in the source that have the same name
+ *	in the target.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	May run traces on the source variables.
+ *
+ *----------------------------------------------------------------------
+ */
+
+/* Copy an array from one namespace to another.
+ * This is basically [array set $tgt [array get $src]] but optimised. */
+static int
+CopyNSArray(
+    Tcl_Interp *interp,
+    Var *srcAryPtr,
+    Var *tgtAryPtr,
+    Tcl_Obj *arrayName)
+{
+    Var *varPtr2;
+    Tcl_HashSearch search;
+    Tcl_Size count;
+    Tcl_Obj **names, *nameList;
+
+    /* List the elements of the array prior to traces. */
+    nameList = Tcl_NewObj();
+    for (varPtr2 = VarHashFirstVar(srcAryPtr->value.tablePtr, &search);
+	    varPtr2; varPtr2 = VarHashNextVar(&search)) {
+	if (TclIsVarUndefined(varPtr2)) {
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, nameList, VarHashGetKey(varPtr2));
+    }
+    TclListObjGetElements(NULL, nameList, &count, &names);
+
+    /* Make sure the Var structure of the array is not removed by a trace
+     * while we're working. */
+    VarHashRefCount(srcAryPtr)++;
+
+    /* Init the target array if necessary. */
+    if (!TclIsVarArray(tgtAryPtr)) {
+	TclInitArrayVar(tgtAryPtr);
+    }
+    /* Make sure it won't go away. */
+    VarHashRefCount(tgtAryPtr)++;
+
+    /* Copy elements! */
+    for (Tcl_Size i=0 ; i<count ; i++) {
+	Tcl_Obj *elemName = names[i], *valueObj;
+	Var *srcElem, *tgtElem;
+
+	/* Read the element in the source; may invoke read traces. */
+	srcElem = TclLookupArrayElement(interp, arrayName, elemName,
+		TCL_LEAVE_ERR_MSG, "read", 0, 0, srcAryPtr, TCL_INDEX_NONE);
+	if (!srcElem) {
+	    if (TclIsVarArray(srcAryPtr)) {
+		continue;
+	    }
+	    goto errorCopyingElement;
+	}
+	valueObj = TclPtrGetVarIdx(interp, srcElem, srcAryPtr,
+		arrayName, elemName, TCL_LEAVE_ERR_MSG, TCL_INDEX_NONE);
+	if (!valueObj) {
+	    if (TclIsVarArray(srcAryPtr)) {
+		continue;
+	    }
+	    goto errorCopyingElement;
+	}
+
+	/* Write the element in the target; may invoke write traces. */
+	tgtElem = TclLookupArrayElement(interp, arrayName, elemName,
+		TCL_LEAVE_ERR_MSG, "write", 0, 1, tgtAryPtr, TCL_INDEX_NONE);
+	if (!tgtElem) {
+	    goto errorCopyingElement;
+	}
+	if (TclPtrSetVarIdx(interp, tgtElem, tgtAryPtr, arrayName, elemName,
+		valueObj, TCL_LEAVE_ERR_MSG, TCL_INDEX_NONE) == NULL) {
+	    goto errorCopyingElement;
+	}
+    }
+
+    /* Clean up. */
+    VarHashRefCount(srcAryPtr)--;
+    VarHashRefCount(tgtAryPtr)--;
+    Tcl_BounceRefCount(nameList);
+    return TCL_OK;
+
+  errorCopyingElement:
+    VarHashRefCount(srcAryPtr)--;
+    VarHashRefCount(tgtAryPtr)--;
+    Tcl_BounceRefCount(nameList);
+    return TCL_ERROR;
+}
+
+/* Copy variables from one namespace to another. */
+int
+TclCopyNamespaceVariables(
+    Tcl_Interp *interp,
+    Namespace *originNs,	/* Namespace to copy from. */
+    Namespace *targetNs)	/* Namespace to copy to. */
+{
+    Var *srcVarPtr, *tgtVarPtr;
+    Tcl_HashSearch search;
+
+    if (targetNs == originNs) {
+	Tcl_Panic("cannot copy namespace variables to itself");
+    }
+
+  restartScan:
+    for (srcVarPtr=VarHashFirstVar(&originNs->varTable, &search);
+	    srcVarPtr!=NULL ; srcVarPtr=VarHashNextVar(&search)) {
+	Tcl_Obj *nameObj = VarHashGetKey(srcVarPtr), *valueObj;
+	int isNew, restart = 0;
+
+	tgtVarPtr = VarHashCreateVar(&targetNs->varTable, nameObj, &isNew);
+	if (!tgtVarPtr || !isNew) {
+	    /* If we couldn't make it or it existed, we skip.
+	     * This means that a variable that triggered a rescan because of
+	     * a trace won't do the second time round. */
+	    continue;
+	}
+	/* Mark this like [variable] does. */
+	TclSetVarNamespaceVar(tgtVarPtr);
+	if (TclIsVarUndefined(srcVarPtr)) {
+	    continue;
+	}
+	switch (srcVarPtr->flags & VAR_TYPE) {
+	case VAR_ARRAY:
+	    if (srcVarPtr->flags & VAR_ALL_TRACES) {
+		restart = 1;
+	    }
+	    if (CopyNSArray(interp, srcVarPtr, tgtVarPtr, nameObj) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    break;
+	case VAR_LINK:
+	    /* Links don't have traces */
+	    while (TclIsVarLink(srcVarPtr)) {
+		srcVarPtr = srcVarPtr->value.linkPtr;
+	    }
+	    TclSetVarLink(tgtVarPtr);
+	    tgtVarPtr->value.linkPtr = srcVarPtr;
+	    if (TclIsVarInHash(srcVarPtr)) {
+		VarHashRefCount(srcVarPtr)++;
+	    }
+	    break;
+	default:
+	    if (srcVarPtr->flags & VAR_ALL_TRACES) {
+		restart = 1;
+	    }
+	    valueObj = TclPtrGetVarIdx(interp, srcVarPtr, NULL, nameObj, NULL,
+		    TCL_LEAVE_ERR_MSG, TCL_INDEX_NONE);
+	    if (!valueObj) {
+		return TCL_ERROR;
+	    }
+	    tgtVarPtr->value.objPtr = valueObj;
+	    Tcl_IncrRefCount(valueObj);
+	    if (srcVarPtr->flags & VAR_CONSTANT) {
+		tgtVarPtr->flags |= VAR_CONSTANT;
+	    }
+	    break;
+	}
+	if (restart) {
+	    /* A trace existed on a variable we touched, so we must rescan. */
+	    goto restartScan;
+	}
+    }
+    return TCL_OK;
+}
+
 /*
  * Local Variables:
  * mode: c
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
deleted file mode 100644
index e20e336..0000000
--- a/tools/makeHeader.tcl
+++ /dev/null
@@ -1,183 +0,0 @@
-# makeHeader.tcl --
-#
-#	This script generates embeddable C source (in a .h file) from a .tcl
-#	script.
-#
-# Copyright © 2018 Donal K. Fellows
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-
-package require Tcl 8.6-
-
-namespace eval makeHeader {
-
-    ####################################################################
-    #
-    # mapSpecial --
-    #	Transform a single line so that it is able to be put in a C string.
-    #
-    proc mapSpecial {str} {
-	# All Tcl metacharacters and key C backslash sequences
-	set MAP {
-	    \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
-	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
-	}
-	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
-
-	subst [regsub -all {[^\x20-\x7E]} [string map $MAP $str] $XFORM]
-    }
-
-    ####################################################################
-    #
-    # compactLeadingSpaces --
-    #	Converts the leading whitespace on a line into a more compact form.
-    #
-    proc compactLeadingSpaces {line} {
-	set line [string map {\t {        }} [string trimright $line]]
-	if {[regexp {^[ ]+} $line spaces]} {
-	    regsub -all {[ ]{4}} $spaces \t replace
-	    set len [expr {[string length $spaces] - 1}]
-	    set line [string replace $line 0 $len $replace]
-	}
-	return $line
-    }
-
-    ####################################################################
-    #
-    # processScript --
-    #	Transform a whole sequence of lines with [mapSpecial].
-    #
-    proc processScript {scriptLines} {
-	lmap line $scriptLines {
-	    # Skip blank and comment lines; they're there in the original
-	    # sources so we don't need to copy them over.
-	    if {[regexp {^\s*(?:#|$)} $line]} continue
-	    format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
-	}
-    }
-
-    ####################################################################
-    #
-    # updateTemplate --
-    #	Rewrite a template to contain the content from the input script.
-    #
-    proc updateTemplate {dataVar scriptLines} {
-	set BEGIN "*!BEGIN!: Do not edit below this line.*"
-	set END "*!END!: Do not edit above this line.*"
-
-	upvar 1 $dataVar data
-
-	set from [lsearch -glob $data $BEGIN]
-	set to [lsearch -glob $data $END]
-	if {$from < 0 || $to < 0 || $from >= $to} {
-	    throw BAD "not a template"
-	}
-
-	set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
-    }
-
-    ####################################################################
-    #
-    # stripSurround --
-    #	Removes the header and footer comments from a (line-split list of
-    #	lines of) Tcl script code.
-    #
-    proc stripSurround {lines} {
-	set RE {^\s*$|^#}
-	set state 0
-	set lines [lmap line [lreverse $lines] {
-	    if {!$state && [regexp $RE $line]} continue {
-		set state 1
-		set line
-	    }
-	}]
-	return [lmap line [lreverse $lines] {
-	    if {$state && [regexp $RE $line]} continue {
-		set state 0
-		set line
-	    }
-	}]
-    }
-
-    ####################################################################
-    #
-    # updateTemplateFile --
-    #	Rewrites a template file with the lines of the given script.
-    #
-    proc updateTemplateFile {headerFile scriptLines} {
-	set f [open $headerFile "r+"]
-	try {
-	    chan configure $f -translation {auto lf}
-	    set content [split [chan read -nonewline $f] "\n"]
-	    updateTemplate content [stripSurround $scriptLines]
-	    chan seek $f 0
-	    chan puts $f [join $content \n]
-	    chan truncate $f
-	} trap BAD msg {
-	    # Add the filename to the message
-	    throw BAD "${headerFile}: $msg"
-	} finally {
-	    chan close $f
-	}
-    }
-
-    ####################################################################
-    #
-    # readScript --
-    #	Read a script from a file and return its lines.
-    #
-    proc readScript {script} {
-	set f [open $script]
-	try {
-	    chan configure $f -encoding utf-8
-	    return [split [string trim [chan read $f]] "\n"]
-	} finally {
-	    chan close $f
-	}
-    }
-
-    ####################################################################
-    #
-    # run --
-    #	The main program of this script.
-    #
-    proc run {args} {
-	try {
-	    if {[llength $args] != 2} {
-		throw ARGS "inputTclScript templateFile"
-	    }
-	    lassign $args inputTclScript templateFile
-
-	    puts "Inserting $inputTclScript into $templateFile"
-	    set scriptLines [readScript $inputTclScript]
-	    updateTemplateFile $templateFile $scriptLines
-	    exit 0
-	} trap ARGS msg {
-	    puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\""
-	    exit 2
-	} trap BAD msg {
-	    puts stderr $msg
-	    exit 1
-	} trap POSIX msg {
-	    puts stderr $msg
-	    exit 1
-	} on error {- opts} {
-	    puts stderr [dict get $opts -errorinfo]
-	    exit 3
-	}
-    }
-}
-
-########################################################################
-#
-# Launch the main program
-#
-if {[info script] eq $::argv0} {
-    makeHeader::run {*}$::argv
-}
-
-# Local-Variables:
-# mode: tcl
-# fill-column: 78
-# End:
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
deleted file mode 100644
index ef2d325..0000000
--- a/tools/tclOOScript.tcl
+++ /dev/null
@@ -1,61 +0,0 @@
-# tclOOScript.h --
-#
-#	This file contains support scripts for TclOO. They are defined here so
-#	that the code can be definitely run even in safe interpreters; TclOO's
-#	core setup is safe.
-#
-# Copyright © 2012-2019 Donal K. Fellows
-# Copyright © 2013 Andreas Kupries
-# Copyright © 2017 Gerald Lester
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-
-# ----------------------------------------------------------------------
-#
-# oo::object <cloned> --
-#
-#	Handler for cloning objects that clones basic bits (only!) of the
-#	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
-#	more complex (and class-specific) handling.
-#
-# ----------------------------------------------------------------------
-
-::oo::define ::oo::object method <cloned> -unexport {originObject} {
-    # Copy over the procedures from the original namespace
-    foreach p [info procs [info object namespace $originObject]::*] {
-	set args [info args $p]
-	set idx -1
-	foreach a $args {
-	    if {[info default $p $a d]} {
-		lset args [incr idx] [list $a $d]
-	    } else {
-		lset args [incr idx] [list $a]
-	    }
-	}
-	set b [info body $p]
-	set p [namespace tail $p]
-	proc $p $args $b
-    }
-    # Copy over the variables from the original namespace
-    foreach v [info vars [info object namespace $originObject]::*] {
-	upvar 0 $v vOrigin
-	namespace upvar [namespace current] [namespace tail $v] vNew
-	if {[info exists vOrigin]} {
-	    if {[array exists vOrigin]} {
-		array set vNew [array get vOrigin]
-	    } else {
-		set vNew $vOrigin
-	    }
-	}
-    }
-    # General commands, sub-namespaces and advancd variable config (traces,
-    # etc) are *not* copied over. Classes that want that should do it
-    # themselves.
-}
-
-# Local Variables:
-# mode: tcl
-# c-basic-offset: 4
-# fill-column: 78
-# End:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 253d384..e6b9b9d 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1464,7 +1464,7 @@ tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
 tclNotify.o: $(GENERIC_DIR)/tclNotify.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c
 
-tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h
+tclOO.o: $(GENERIC_DIR)/tclOO.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c
 
 tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c
@@ -2203,11 +2203,6 @@ $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
 	@echo "Developers may want to run \"make genstubs\" to regenerate."
 	@echo "This warning can be safely ignored, do not report as a bug!"
 
-$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
-	@echo "Warning: tclOOScript.h may be out of date."
-	@echo "Developers may want to run \"make genscript\" to regenerate."
-	@echo "This warning can be safely ignored, do not report as a bug!"
-
 genstubs:
 	$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
 		$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
@@ -2215,10 +2210,6 @@ genstubs:
 	$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
 		$(GENERIC_DIR)/tclOO.decls
 
-genscript:
-	$(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \
-		$(TOOL_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h
-
 #
 # Target to check that all exported functions have an entry in the stubs
 # tables.
diff --git a/win/Makefile.in b/win/Makefile.in
index bcb35c1..76678ab 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -767,8 +767,6 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c
 .rc.$(RES):
 	$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
 
-tclOO.${OBJEXT}: tclOO.c tclOOScript.h
-
 #--------------------------------------------------------------------------
 # Minizip implementation
 #--------------------------------------------------------------------------
@@ -1155,11 +1153,6 @@ $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
 	@echo "Developers may want to run \"make genstubs\" to regenerate."
 	@echo "This warning can be safely ignored, do not report as a bug!"
 
-$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
-	@echo "Warning: tclOOScript.h may be out of date."
-	@echo "Developers may want to run \"make genscript\" to regenerate."
-	@echo "This warning can be safely ignored, do not report as a bug!"
-
 genstubs:
 	$(TCL_EXE) "$(TOOL_DIR_NATIVE)/genStubs.tcl" \
 	    "$(GENERIC_DIR_NATIVE)" \
@@ -1170,11 +1163,6 @@ genstubs:
 	    "$(GENERIC_DIR_NATIVE)" \
 	    "$(GENERIC_DIR_NATIVE)/tclOO.decls"
 
-genscript:
-	$(TCL_EXE) "$(TOOL_DIR_NATIVE)/makeHeader.tcl" \
-		"$(TOOL_DIR_NATIVE)/tclOOScript.tcl" \
-		"$(GENERIC_DIR_NATIVE)/tclOOScript.h"
-
 #
 # This target creates the HTML folder for Tcl & Tk and places it in
 # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool