Implementation of TIP #320.#320.#320.

1 files changed, 88 insertions, 28 deletions

diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index bc7b4fb..41d90a4 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.6 2008/08/12 23:19:15 hobbs Exp $
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.7 2008/09/23 05:05:54 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -26,6 +26,7 @@ static Tcl_ObjCmdProc InfoObjectIsACmd;
 static Tcl_ObjCmdProc InfoObjectMethodsCmd;
 static Tcl_ObjCmdProc InfoObjectMixinsCmd;
 static Tcl_ObjCmdProc InfoObjectVarsCmd;
+static Tcl_ObjCmdProc InfoObjectVariablesCmd;
 static Tcl_ObjCmdProc InfoClassConstrCmd;
 static Tcl_ObjCmdProc InfoClassDefnCmd;
 static Tcl_ObjCmdProc InfoClassDestrCmd;
@@ -36,6 +37,7 @@ static Tcl_ObjCmdProc InfoClassMethodsCmd;
 static Tcl_ObjCmdProc InfoClassMixinsCmd;
 static Tcl_ObjCmdProc InfoClassSubsCmd;
 static Tcl_ObjCmdProc InfoClassSupersCmd;
+static Tcl_ObjCmdProc InfoClassVariablesCmd;
 
 struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
 
@@ -51,6 +53,7 @@ static const struct NameProcMap infoObjectCmds[] = {
     {"::oo::InfoObject::isa",	     InfoObjectIsACmd},
     {"::oo::InfoObject::methods",    InfoObjectMethodsCmd},
     {"::oo::InfoObject::mixins",     InfoObjectMixinsCmd},
+    {"::oo::InfoObject::variables",  InfoObjectVariablesCmd},
     {"::oo::InfoObject::vars",	     InfoObjectVarsCmd},
     {NULL, NULL}
 };
@@ -70,6 +73,7 @@ static const struct NameProcMap infoClassCmds[] = {
     {"::oo::InfoClass::mixins",	      InfoClassMixinsCmd},
     {"::oo::InfoClass::subclasses",   InfoClassSubsCmd},
     {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
+    {"::oo::InfoClass::variables",    InfoClassVariablesCmd},
     {NULL, NULL}
 };
 
@@ -268,18 +272,8 @@ InfoObjectDefnCmd(
 	}
     }
     Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
-
-    /*
-     * This is copied from the [info body] implementation. See the comments
-     * there for why this copy has to be done here.
-     */
-
-    if (procPtr->bodyPtr->bytes == NULL) {
-	(void) Tcl_GetString(procPtr->bodyPtr);
-    }
     Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
-	    procPtr->bodyPtr->length));
+	    TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
     return TCL_OK;
 }
 
@@ -617,6 +611,42 @@ InfoObjectMixinsCmd(
 /*
  * ----------------------------------------------------------------------
  *
+ * InfoObjectVariablesCmd --
+ *
+ *	Implements [info object variables $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVariablesCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Tcl_Obj *variableObj;
+    int i;
+
+    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;
+    }
+
+    FOREACH(variableObj, oPtr->variables) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * InfoObjectVarsCmd --
  *
  *	Implements [info object vars $objName ?$pattern?]
@@ -739,12 +769,8 @@ InfoClassConstrCmd(
 	}
     }
     Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
-    if (procPtr->bodyPtr->bytes == NULL) {
-	(void) Tcl_GetString(procPtr->bodyPtr);
-    }
     Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
-	    procPtr->bodyPtr->length));
+	    TclOOGetMethodBody(clsPtr->constructorPtr));
     return TCL_OK;
 }
 
@@ -816,12 +842,8 @@ InfoClassDefnCmd(
 	}
     }
     Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
-    if (procPtr->bodyPtr->bytes == NULL) {
-	(void) Tcl_GetString(procPtr->bodyPtr);
-    }
     Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
-	    procPtr->bodyPtr->length));
+	    TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
     return TCL_OK;
 }
 
@@ -871,12 +893,7 @@ InfoClassDestrCmd(
 	return TCL_ERROR;
     }
 
-    if (procPtr->bodyPtr->bytes == NULL) {
-	(void) Tcl_GetString(procPtr->bodyPtr);
-    }
-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
-	    procPtr->bodyPtr->length));
+    Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
     return TCL_OK;
 }
 
@@ -1263,6 +1280,49 @@ InfoClassSupersCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassVariablesCmd --
+ *
+ *	Implements [info class variables $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassVariablesCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Class *clsPtr;
+    Tcl_Obj *variableObj;
+    int i;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    FOREACH(variableObj, clsPtr->variables) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+    }
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4