Added more introspection: ability to look up namespace of an object.

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