TIP #605 implementation: Function to get class name from object

5 files changed, 51 insertions, 14 deletions

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 64892a8..e4063c7 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -129,8 +129,11 @@ declare 28 {
 declare 29 {
     int Tcl_MethodIsPrivate(Tcl_Method method)
 }
+declare 30 {
+    Tcl_Class Tcl_GetClassOfObject(Tcl_Object object)
+}
 declare 31 {
-    void TclOOUnusedStubEntry(void)
+    Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
 }
 
 ######################################################################
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 4263bf0..3be1e3d 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -118,9 +118,11 @@ TCLAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
 				Tcl_Object object);
 /* 29 */
 TCLAPI int		Tcl_MethodIsPrivate(Tcl_Method method);
-/* Slot 30 is reserved */
+/* 30 */
+TCLAPI Tcl_Class	Tcl_GetClassOfObject(Tcl_Object object);
 /* 31 */
-TCLAPI void		TclOOUnusedStubEntry(void);
+TCLAPI Tcl_Obj *	Tcl_GetObjectClassName(Tcl_Interp *interp,
+				Tcl_Object object);
 
 typedef struct {
     const struct TclOOIntStubs *tclOOIntStubs;
@@ -160,8 +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 */
-    void (*reserved30)(void);
-    void (*tclOOUnusedStubEntry) (void); /* 31 */
+    Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
+    Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
 } TclOOStubs;
 
 extern const TclOOStubs *tclOOStubsPtr;
@@ -236,14 +238,13 @@ extern const TclOOStubs *tclOOStubsPtr;
 	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
 #define Tcl_MethodIsPrivate \
 	(tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
-/* Slot 30 is reserved */
-#define TclOOUnusedStubEntry \
-	(tclOOStubsPtr->tclOOUnusedStubEntry) /* 31 */
+#define Tcl_GetClassOfObject \
+	(tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
+#define Tcl_GetObjectClassName \
+	(tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
 
 #endif /* defined(USE_TCLOO_STUBS) */
 
 /* !END!: Do not edit above this line. */
 
-#undef TclOOUnusedStubEntry
-
 #endif /* _TCLOODECLS */
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index 4b6559a..b9034f0 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -14,8 +14,6 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
 #pragma GCC dependency "tclOO.decls"
 #endif
 
-#define TclOOUnusedStubEntry 0
-
 /* !BEGIN!: Do not edit below this line. */
 
 static const TclOOIntStubs tclOOIntStubs = {
@@ -76,8 +74,8 @@ const TclOOStubs tclOOStubs = {
     Tcl_ClassSetDestructor, /* 27 */
     Tcl_GetObjectName, /* 28 */
     Tcl_MethodIsPrivate, /* 29 */
-    0, /* 30 */
-    TclOOUnusedStubEntry, /* 31 */
+    Tcl_GetClassOfObject, /* 30 */
+    Tcl_GetObjectClassName, /* 31 */
 };
 
 /* !END!: Do not edit above this line. */