summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-07-19 11:46:52 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-07-19 11:46:52 (GMT)
commitd63bf48fae3c37de04f6f82c8bde59587e1ed2aa (patch)
treea8a19f6d92c70e4d6476438a0e2ce346f2fc7fff
parent87edf9c39870a062040ef47d131ee19dfc4161d8 (diff)
downloadtcl-d63bf48fae3c37de04f6f82c8bde59587e1ed2aa.zip
tcl-d63bf48fae3c37de04f6f82c8bde59587e1ed2aa.tar.gz
tcl-d63bf48fae3c37de04f6f82c8bde59587e1ed2aa.tar.bz2
Expose function to efficiently return current name of an object.
-rw-r--r--ChangeLog11
-rw-r--r--doc/Class.312
-rw-r--r--generic/tclOO.c12
-rw-r--r--generic/tclOO.decls24
-rw-r--r--generic/tclOODecls.h13
-rw-r--r--generic/tclOOStubInit.c3
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. */