Expose function to efficiently return current name of an object.

6 files changed, 61 insertions, 14 deletions

diff --git a/ChangeLog b/ChangeLog
index 4d978f2..9023354 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2009-07-19  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.decls, generic/tclOO.c (Tcl_GetObjectName): Expose a
+	function for efficiently returning the current name of an object.
+
 2009-07-18  Daniel Steffen  <das@users.sourceforge.net>
 
 	* unix/Makefile.in: Define NDEBUG in optimized (non-symbols) build to
@@ -18,9 +23,9 @@
 
 	* generic/tclScan.c:    Typo in ACCEPT_NAN configuration.
 
-	* generic/tclStrToD.c:  Set floating point control register on
-	MIPS systems so that the gradual underflow expected by Tcl is
-	in effect.  [Bug 2819200]
+	* generic/tclStrToD.c:  [Bug 2819200]: Set floating point control
+	register on MIPS systems so that the gradual underflow expected by Tcl
+	is in effect.
 
 2009-07-15  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/doc/Class.3 b/doc/Class.3
index e7b0881..5792b17 100644
--- a/doc/Class.3
+++ b/doc/Class.3
@@ -4,7 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
-'\" RCS: @(#) $Id: Class.3,v 1.3 2009/07/12 14:57:56 dkf Exp $
+'\" RCS: @(#) $Id: Class.3,v 1.4 2009/07/19 11:46:53 dkf Exp $
 '\"
 .so man.macros
 .TH Tcl_Class 3 0.1 TclOO "TclOO Library Functions"
@@ -25,6 +25,9 @@ Tcl_Object
 Tcl_Class
 \fBTcl_GetObjectAsClass\fR(\fIobject\fR)
 .sp
+Tcl_Obj *
+\fBTcl_GetObjectName\fR(\fIinterp, object\fR)
+.sp
 Tcl_Command
 \fBTcl_GetObjectCommand\fR(\fIobject\fR)
 .sp
@@ -103,8 +106,11 @@ found. The correct way to look up a class by name is to look up the object
 with that name, and then to use \fBTcl_GetObjectAsClass\fR.
 .PP
 Every object has its own command and namespace associated with it. The command
-may be retrieved using the \fBTcl_GetObjectCommand\fR function, and the
-namespace may be retrieved using the \fBTcl_GetObjectNamespace\fR function.
+may be retrieved using the \fBTcl_GetObjectCommand\fR function, the name of
+the object (and hence the name of the command) with \fBTcl_GetObjectName\fR,
+and the namespace may be retrieved using the \fBTcl_GetObjectNamespace\fR
+function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR
+is a shared reference.
 .PP
 Instances of classes are created using \fBTcl_NewObjectInstance\fR, which
 takes creates an object from any class (and which is internally called by both
diff --git a/generic/tclOO.c b/generic/tclOO.c
index c1e8678..4233020 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOO.c,v 1.23 2009/07/12 14:51:30 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.24 2009/07/19 11:46:53 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -2439,7 +2439,7 @@ TclOOIsReachable(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOOObjectName --
+ * TclOOObjectName, Tcl_GetObjectName --
  *
  *	Utility function that returns the name of the object. Note that this
  *	simplifies cache management by keeping the code to do it in one place
@@ -2465,6 +2465,14 @@ TclOOObjectName(
     oPtr->cachedNameObj = namePtr;
     return namePtr;
 }
+
+Tcl_Obj *
+Tcl_GetObjectName(
+    Tcl_Interp *interp,
+    Tcl_Object object)
+{
+    return TclOOObjectName(interp, (Object *) object);
+}
 
 /*
  * ----------------------------------------------------------------------
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index dd33f14..f06dd6b 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -1,8 +1,11 @@
-# -*- tcl -*-
-# $Id: tclOO.decls,v 1.4 2008/10/17 18:42:12 nijtmans Exp $
+# $Id: tclOO.decls,v 1.5 2009/07/19 11:46:53 dkf Exp $
 
-# public API
 library tclOO
+
+######################################################################
+# public API
+#
+
 interface tclOO
 hooks tclOOInt
 
@@ -109,9 +112,16 @@ declare 27 generic {
     void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz,
 	    Tcl_Method method)
 }
-
+declare 28 generic {
+    Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
+}
+
+######################################################################
 # private API, exposed to support advanced OO systems that plug in on top
+#
+
 interface tclOOInt
+
 declare 0 generic {
     Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp)
 }
@@ -187,3 +197,9 @@ declare 15 generic {
     void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
 	    int numMixins, Class *const *mixins)
 }
+
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 1a0c262..c42c02f 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -1,5 +1,5 @@
 /*
- * $Id: tclOODecls.h,v 1.11 2009/01/29 14:53:36 dkf Exp $
+ * $Id: tclOODecls.h,v 1.12 2009/07/19 11:46:53 dkf Exp $
  *
  * This file is (mostly) automatically generated from tclOO.decls.
  */
@@ -207,6 +207,12 @@ EXTERN void		Tcl_ClassSetConstructor (Tcl_Interp * interp,
 EXTERN void		Tcl_ClassSetDestructor (Tcl_Interp * interp,
 				Tcl_Class clazz, Tcl_Method method);
 #endif
+#ifndef Tcl_GetObjectName_TCL_DECLARED
+#define Tcl_GetObjectName_TCL_DECLARED
+/* 28 */
+EXTERN Tcl_Obj *	Tcl_GetObjectName (Tcl_Interp * interp,
+				Tcl_Object object);
+#endif
 
 typedef struct TclOOStubHooks {
     const struct TclOOIntStubs *tclOOIntStubs;
@@ -244,6 +250,7 @@ typedef struct TclOOStubs {
     void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc mapMethodNameProc); /* 25 */
     void (*tcl_ClassSetConstructor) (Tcl_Interp * interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
     void (*tcl_ClassSetDestructor) (Tcl_Interp * interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
+    Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp * interp, Tcl_Object object); /* 28 */
 } TclOOStubs;
 
 #if defined(USE_TCLOO_STUBS) && !defined(USE_TCLOO_STUB_PROCS)
@@ -368,6 +375,10 @@ extern const TclOOStubs *tclOOStubsPtr;
 #define Tcl_ClassSetDestructor \
 	(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
 #endif
+#ifndef Tcl_GetObjectName
+#define Tcl_GetObjectName \
+	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
+#endif
 
 #endif /* defined(USE_TCLOO_STUBS) && !defined(USE_TCLOO_STUB_PROCS) */
 
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index 400eeef..4ec3992 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -1,5 +1,5 @@
 /*
- * $Id: tclOOStubInit.c,v 1.6 2008/07/22 23:01:39 das Exp $
+ * $Id: tclOOStubInit.c,v 1.7 2009/07/19 11:46:53 dkf Exp $
  *
  * This file is (mostly) automatically generated from tclOO.decls.
  * It is compiled and linked in with the tclOO package proper.
@@ -69,6 +69,7 @@ static const TclOOStubs tclOOStubs = {
     Tcl_ObjectSetMethodNameMapper, /* 25 */
     Tcl_ClassSetConstructor, /* 26 */
     Tcl_ClassSetDestructor, /* 27 */
+    Tcl_GetObjectName, /* 28 */
 };
 
 /* !END!: Do not edit above this line. */