From f80e08da71e969b6b79dd861d91f684a8159e9f2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 20 Aug 2025 12:22:28 +0000
Subject: Move a bit of internal machinery

---
 generic/tclOO.c       |  1 +
 generic/tclOOBasic.c  | 37 ++++++++++++++++++++++++++++++++++++-
 generic/tclOOInt.h    |  1 +
 generic/tclOOScript.h |  3 ---
 tools/tclOOScript.tcl | 14 --------------
 5 files changed, 38 insertions(+), 18 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 4a2e35c..ec20537 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -456,6 +456,7 @@ InitFoundation(
     CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->ooNs, "DelegateName", TclOODelegateNameObjCmd, NULL, NULL, 0);
 
     TclOOInitInfo(interp);
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 866f080..44d8cb6 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1494,7 +1494,8 @@ TclOOClassVariableObjCmd(
 	}
 
 	// Create the new variable and link it to otherPtr.
-	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) {
+	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
+		TCL_INDEX_NONE) != TCL_OK) {
 	    return TCL_ERROR;
 	}
     }
@@ -1503,6 +1504,40 @@ TclOOClassVariableObjCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODelegateNameObjCmd --
+ *
+ *	Implementation of the [oo::DelegateName] command, which is a utility
+ *	that gets the name of the class delegate for a class. It's trivial,
+ *	but makes working with them much easier as delegate names are
+ *	intentionally hard to create by accident.
+ *
+ *	Not part of TclOO public API. No public documentation.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOODelegateNameObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "class");
+	return TCL_ERROR;
+    }
+    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
+    if (clsPtr == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate",
+	    clsPtr->thisPtr->namespacePtr->fullName));
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 0367e60..1331703 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -521,6 +521,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOODelegateNameObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOSelfObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index dcc44c0..643e536 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -52,9 +52,6 @@ static const char *tclOOSetupScript =
 "\t\t\trename $cmd {}\n"
 "\t\t}\n"
 "\t}\n"
-"\tproc DelegateName {class} {\n"
-"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
-"\t}\n"
 "\tproc MixinClassDelegates {class} {\n"
 "\t\tif {![info object isa class $class]} {\n"
 "\t\t\treturn\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 3f34c56..2cf40e1 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -65,20 +65,6 @@
 
     # ----------------------------------------------------------------------
     #
-    # DelegateName --
-    #
-    #	Utility that gets the name of the class delegate for a class. It's
-    #	trivial, but makes working with them much easier as delegate names are
-    #	intentionally hard to create by accident.
-    #
-    # ----------------------------------------------------------------------
-
-    proc DelegateName {class} {
-	string cat [info object namespace $class] {:: oo ::delegate}
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # MixinClassDelegates --
     #
     #	Support code called *after* [oo::define] inside the constructor of a
-- 
cgit v0.12