From 36dbbdbb723b994c072318068ca9c78aac8a2bcf Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 1 Aug 2021 11:47:23 +0000
Subject: Turn code snippets in TIP into a branch.

---
 doc/Class.3             | 15 +++++++++++++++
 generic/tclOO.c         | 20 ++++++++++++++++++++
 generic/tclOO.decls     |  6 ++++++
 generic/tclOODecls.h    | 11 +++++++++++
 generic/tclOOStubInit.c |  2 ++
 5 files changed, 54 insertions(+)

diff --git a/doc/Class.3 b/doc/Class.3
index 5f8e061..c89c5f4 100644
--- a/doc/Class.3
+++ b/doc/Class.3
@@ -55,6 +55,14 @@ Tcl_ObjectMapMethodNameProc
 \fBTcl_ObjectGetMethodNameMapper\fR(\fIobject\fR)
 .sp
 \fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR)
+.sp
+.VS "TIP 605"
+Tcl_Class
+\fBTcl_GetClassOfObject\fR(\fIobject\fR)
+.sp
+Tcl_Obj *
+\fBTcl_GetObjectClassName\fR(\fIinterp\fR, \fIobject\fR)
+.VE "TIP 605"
 .SH ARGUMENTS
 .AS ClientData metadata in/out
 .AP Tcl_Interp *interp in/out
@@ -114,6 +122,13 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR
 is a shared reference. You can also get whether the object has been marked for
 deletion with \fBTcl_ObjectDeleted\fR (it returns true if deletion of the
 object has begun); this can be useful during the processing of methods.
+.VS "TIP 605"
+The class of an object can be retrieved with \fBTcl_GetClassOfObject\fR, and
+the name of the class of an object with \fBTcl_GetObjectClassName\fR; note
+that these two \fImay\fR return NULL during deletion of an object (this is
+transient, and only occurs when the object is a long way through being
+deleted).
+.VE "TIP 605"
 .PP
 Instances of classes are created using \fBTcl_NewObjectInstance\fR, which
 creates an object from any class (and which is internally called by both
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 405d5d0..bdceec4 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -3144,6 +3144,26 @@ Tcl_ObjectSetMethodNameMapper(
 {
     ((Object *) object)->mapMethodNameProc = mapMethodNameProc;
 }
+
+Tcl_Class
+Tcl_GetClassOfObject(
+    Tcl_Object object)
+{
+    return (Tcl_Class) ((Object *) object)->selfCls;
+}
+
+Tcl_Obj *
+Tcl_GetObjectClassName(
+    Tcl_Interp *interp,
+    Tcl_Object object)
+{
+    Tcl_Object classObj = (Tcl_Object) (((Object *) object)->selfCls)->thisPtr;
+
+    if (classObj == NULL) {
+	return NULL;
+    }
+    return Tcl_GetObjectName(interp, classObj);
+}
 
 /*
  * Local Variables:
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 4602460..e4063c7 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -129,6 +129,12 @@ declare 28 {
 declare 29 {
     int Tcl_MethodIsPrivate(Tcl_Method method)
 }
+declare 30 {
+    Tcl_Class Tcl_GetClassOfObject(Tcl_Object object)
+}
+declare 31 {
+    Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
+}
 
 ######################################################################
 # Private API, exposed to support advanced OO systems that plug in on top of
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 928d07e..3be1e3d 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -118,6 +118,11 @@ TCLAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
 				Tcl_Object object);
 /* 29 */
 TCLAPI int		Tcl_MethodIsPrivate(Tcl_Method method);
+/* 30 */
+TCLAPI Tcl_Class	Tcl_GetClassOfObject(Tcl_Object object);
+/* 31 */
+TCLAPI Tcl_Obj *	Tcl_GetObjectClassName(Tcl_Interp *interp,
+				Tcl_Object object);
 
 typedef struct {
     const struct TclOOIntStubs *tclOOIntStubs;
@@ -157,6 +162,8 @@ typedef struct TclOOStubs {
     void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
     Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
     int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
+    Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
+    Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
 } TclOOStubs;
 
 extern const TclOOStubs *tclOOStubsPtr;
@@ -231,6 +238,10 @@ extern const TclOOStubs *tclOOStubsPtr;
 	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
 #define Tcl_MethodIsPrivate \
 	(tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
+#define Tcl_GetClassOfObject \
+	(tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
+#define Tcl_GetObjectClassName \
+	(tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
 
 #endif /* defined(USE_TCLOO_STUBS) */
 
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index 5e235f4..b9034f0 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -74,6 +74,8 @@ const TclOOStubs tclOOStubs = {
     Tcl_ClassSetDestructor, /* 27 */
     Tcl_GetObjectName, /* 28 */
     Tcl_MethodIsPrivate, /* 29 */
+    Tcl_GetClassOfObject, /* 30 */
+    Tcl_GetObjectClassName, /* 31 */
 };
 
 /* !END!: Do not edit above this line. */
-- 
cgit v0.12