summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-05-15 10:08:02 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-05-15 10:08:02 (GMT)
commit11bd2610c43ddd48a8bbf6b2e594df74b4f2ac4c (patch)
tree5741aec073dba6d5081e376f592ba0c4e5c5bc5f
parentc17a6f4f80e5bb7dcdf8e5c1740443906d6ae89a (diff)
downloadtcl-11bd2610c43ddd48a8bbf6b2e594df74b4f2ac4c.zip
tcl-11bd2610c43ddd48a8bbf6b2e594df74b4f2ac4c.tar.gz
tcl-11bd2610c43ddd48a8bbf6b2e594df74b4f2ac4c.tar.bz2
Added more introspection: ability to look up namespace of an object.
-rw-r--r--ChangeLog6
-rw-r--r--doc/info.n8
-rw-r--r--generic/tclOOInfo.c37
-rw-r--r--tests/oo.test12
4 files changed, 59 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index b5f6716..e53961f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
diff --git a/doc/info.n b/doc/info.n
index 58bf428..b4c4b60 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -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