From d63bf48fae3c37de04f6f82c8bde59587e1ed2aa Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 19 Jul 2009 11:46:52 +0000 Subject: Expose function to efficiently return current name of an object. --- ChangeLog | 11 ++++++++--- doc/Class.3 | 12 +++++++++--- generic/tclOO.c | 12 ++++++++++-- generic/tclOO.decls | 24 ++++++++++++++++++++---- generic/tclOODecls.h | 13 ++++++++++++- generic/tclOOStubInit.c | 3 ++- 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 + + * 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 * 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 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. */ -- cgit v0.12