From d9d4467ee79d979c4990a4fc9a520e2c532ffa4a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 30 Aug 2025 20:36:31 +0000
Subject: Make things that ought to be constants be so.

---
 generic/tclOO.c | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 63 insertions(+), 8 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 7900790..90163e7 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -179,20 +179,15 @@ static const Tcl_MethodType configurableConstructor = {
 };
 
 /*
- * Scripted parts of TclOO. First, the main script (cannot be outside this
- * file).
+ * The scripted part of TclOO: (legacy) package registration. There's no C API
+ * at all for doing this, not even internally to Tcl.
  */
 
 static const char initScript[] =
 #ifndef TCL_NO_DEPRECATED
 "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
 #endif
-"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
-"namespace eval ::oo {"
-"    variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL
-"};";
-/* "tcl_findLibrary tcloo $oo::version $oo::version" */
-/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};";
 
 /*
  * The actual definition of the variable holding the TclOO stub table.
@@ -360,6 +355,63 @@ CreateCmdInNS(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclCreateConstantInNS --
+ *
+ *	Create a constant in a given namespace. Does nothing if the variable
+ *	already exists. The variable name should not indicate an array element;
+ *	it should be a simple name as the namespace is given by other means.
+ *
+ * CreateConstantInNSStr --
+ *
+ *	Wrapper to make using a string constant easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+static void
+TclCreateConstantInNS(
+    Tcl_Interp *interp,
+    Namespace *nsPtr,		/* The namespace to contain the constant. */
+    Tcl_Obj *name,		/* The unqualified name of the constant. */
+    Tcl_Obj *value)		/* The value to put in the constant. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr;
+    Var *varPtr, *arrayPtr;
+
+    iPtr->varFramePtr->nsPtr = nsPtr;
+    varPtr = TclObjLookupVarEx(interp, name, NULL,
+	    (TCL_NAMESPACE_ONLY | TCL_AVOID_RESOLVERS),
+	    "write", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+    iPtr->varFramePtr->nsPtr = savedNsPtr;
+    if (arrayPtr) {
+	Tcl_Panic("constants may not be arrays");
+    }
+    if (varPtr && TclIsVarUndefined(varPtr)) {
+	varPtr->value.objPtr = value;
+	Tcl_IncrRefCount(value);
+	varPtr->flags = VAR_CONSTANT;
+    }
+}
+
+static inline void
+CreateConstantInNSStr(
+    Tcl_Interp *interp,
+    Tcl_Namespace *namespacePtr,/* The namespace to contain the constant. */
+    const char *nameStr,	/* The unqualified name of the constant. */
+    const char *valueStr)	/* The value to put in the constant. */
+{
+    Tcl_Obj *nameObj = Tcl_NewStringObj(nameStr, TCL_AUTO_LENGTH);
+    Tcl_IncrRefCount(nameObj);
+    Tcl_Obj *valueObj = Tcl_NewStringObj(valueStr, TCL_AUTO_LENGTH);
+    Tcl_IncrRefCount(valueObj);
+    TclCreateConstantInNS(interp, (Namespace *) namespacePtr, nameObj, valueObj);
+    Tcl_DecrRefCount(nameObj);
+    Tcl_DecrRefCount(valueObj);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * InitFoundation --
  *
  *	Set up the core of the OO core class system. This is a structure
@@ -496,6 +548,9 @@ InitFoundation(
     }
 
     MakeAdditionalClasses(fPtr, define, objdef);
+
+    CreateConstantInNSStr(interp, fPtr->ooNs, "version", TCLOO_VERSION);
+    CreateConstantInNSStr(interp, fPtr->ooNs, "patchlevel", TCLOO_PATCHLEVEL);
     return TCL_OK;
 }
 
-- 
cgit v0.12