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

1 files changed, 63 insertions, 0 deletions

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 *),