diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | doc/info.n | 8 | ||||
| -rw-r--r-- | generic/tclOOInfo.c | 37 | ||||
| -rw-r--r-- | tests/oo.test | 12 |
4 files changed, 59 insertions, 4 deletions
@@ -1,3 +1,9 @@ +2009-05-14 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclOOInfo.c (InfoObjectNsCmd): Added introspection mechanism + for finding out what an object's namespace is. Experience suggests + that it is just too useful to be able to do without it. + 2009-05-12 Donal K. Fellows <dkf@users.sf.net> * doc/vwait.n: Added more words to make it clear just how bad it is to @@ -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: info.n,v 1.32 2008/10/19 16:27:58 dkf Exp $ +'\" RCS: @(#) $Id: info.n,v 1.33 2009/05/15 10:08:02 dkf Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -567,6 +567,12 @@ This subcommand returns a list of all classes that have been mixed into the object named \fIobject\fR. .VE 8.6 .TP +\fBinfo object namespace\fI object\fR +.VS 8.6 +This subcommand returns the name of the internal namespace of the object named +\fIobject\fR. +.VE 8.6 +.TP \fBinfo object variables\fI object\fR .VS 8.6 This subcommand returns a list of all variables that have been declared for diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index daacc02..9874864 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOInfo.c,v 1.12 2009/01/09 11:21:46 dkf Exp $ + * RCS: @(#) $Id: tclOOInfo.c,v 1.13 2009/05/15 10:08:02 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -26,6 +26,7 @@ static Tcl_ObjCmdProc InfoObjectForwardCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; +static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; @@ -54,6 +55,7 @@ static const struct NameProcMap infoObjectCmds[] = { {"::oo::InfoObject::isa", InfoObjectIsACmd}, {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, + {"::oo::InfoObject::namespace", InfoObjectNsCmd}, {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, {"::oo::InfoObject::vars", InfoObjectVarsCmd}, {NULL, NULL} @@ -643,6 +645,39 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * InfoObjectNsCmd -- + * + * Implements [info object namespace $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectNsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectVariablesCmd -- * * Implements [info object variables $objName] diff --git a/tests/oo.test b/tests/oo.test index c8957b3..da295a6 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.26 2009/05/08 08:48:19 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.27 2009/05/15 10:08:02 dkf Exp $ package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1319,7 +1319,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -1416,6 +1416,14 @@ test oo-16.12 {OO: object introspection} -setup { oo::objdefine foo unexport {*}[info object methods foo -all] info object methods foo -all } -result {} +test oo-16.13 {OO: object introspection} -setup { + oo::object create foo +} -cleanup { + rename foo {} +} -body { + oo::objdefine foo method Bar {} {return "ok in foo"} + [info object namespace foo]::my Bar +} -result "ok in foo" test oo-17.1 {OO: class introspection} -body { info class |