* generic/tclOOInfo.c (InfoObjectMethodTypeCmd)

	(InfoClassMethodTypeCmd): Added introspection of method types so that
	it is possible to find this info out without using errors.

1 files changed, 134 insertions, 1 deletions

diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 9874864..b8679b3 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.13 2009/05/15 10:08:02 dkf Exp $
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.14 2010/03/24 13:21:11 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -25,6 +25,7 @@ static Tcl_ObjCmdProc InfoObjectFiltersCmd;
 static Tcl_ObjCmdProc InfoObjectForwardCmd;
 static Tcl_ObjCmdProc InfoObjectIsACmd;
 static Tcl_ObjCmdProc InfoObjectMethodsCmd;
+static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
 static Tcl_ObjCmdProc InfoObjectMixinsCmd;
 static Tcl_ObjCmdProc InfoObjectNsCmd;
 static Tcl_ObjCmdProc InfoObjectVarsCmd;
@@ -36,6 +37,7 @@ static Tcl_ObjCmdProc InfoClassFiltersCmd;
 static Tcl_ObjCmdProc InfoClassForwardCmd;
 static Tcl_ObjCmdProc InfoClassInstancesCmd;
 static Tcl_ObjCmdProc InfoClassMethodsCmd;
+static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
 static Tcl_ObjCmdProc InfoClassMixinsCmd;
 static Tcl_ObjCmdProc InfoClassSubsCmd;
 static Tcl_ObjCmdProc InfoClassSupersCmd;
@@ -54,6 +56,7 @@ static const struct NameProcMap infoObjectCmds[] = {
     {"::oo::InfoObject::forward",	InfoObjectForwardCmd},
     {"::oo::InfoObject::isa",		InfoObjectIsACmd},
     {"::oo::InfoObject::methods",	InfoObjectMethodsCmd},
+    {"::oo::InfoObject::methodtype",	InfoObjectMethodTypeCmd},
     {"::oo::InfoObject::mixins",	InfoObjectMixinsCmd},
     {"::oo::InfoObject::namespace",	InfoObjectNsCmd},
     {"::oo::InfoObject::variables",	InfoObjectVariablesCmd},
@@ -73,6 +76,7 @@ static const struct NameProcMap infoClassCmds[] = {
     {"::oo::InfoClass::forward",	InfoClassForwardCmd},
     {"::oo::InfoClass::instances",	InfoClassInstancesCmd},
     {"::oo::InfoClass::methods",	InfoClassMethodsCmd},
+    {"::oo::InfoClass::methodtype",	InfoClassMethodTypeCmd},
     {"::oo::InfoClass::mixins",		InfoClassMixinsCmd},
     {"::oo::InfoClass::subclasses",	InfoClassSubsCmd},
     {"::oo::InfoClass::superclasses",	InfoClassSupersCmd},
@@ -173,6 +177,8 @@ GetClassFromObj(
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, "\"", TclGetString(objPtr),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		TclGetString(objPtr), NULL);
 	return NULL;
     }
     return oPtr->classPtr;
@@ -223,6 +229,8 @@ InfoObjectClassCmd(
 	if (o2Ptr->classPtr == NULL) {
 	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
 		    "\" is not a class", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		    TclGetString(objv[2]), NULL);
 	    return TCL_ERROR;
 	}
 
@@ -279,12 +287,16 @@ InfoObjectDefnCmd(
     unknownMethod:
 	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
 		"\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
     procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
     if (procPtr == NULL) {
 	Tcl_AppendResult(interp,
 		"definition not available for this kind of method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
 
@@ -386,6 +398,8 @@ InfoObjectForwardCmd(
     unknownMethod:
 	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
 		"\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
     prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
@@ -393,6 +407,8 @@ InfoObjectForwardCmd(
 	Tcl_AppendResult(interp,
 		"prefix argument list not available for this kind of method",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
 
@@ -605,6 +621,63 @@ InfoObjectMethodsCmd(
 /*
  * ----------------------------------------------------------------------
  *
+ * InfoObjectMethodTypeCmd --
+ *
+ *	Implements [info object methodtype $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectMethodTypeCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    Tcl_HashEntry *hPtr;
+    Method *mPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    if (!oPtr->methodsPtr) {
+	goto unknownMethod;
+    }
+    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
+    if (hPtr == NULL) {
+    unknownMethod:
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+		"\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
+	return TCL_ERROR;
+    }
+    mPtr = Tcl_GetHashValue(hPtr);
+    if (mPtr->typePtr == NULL) {
+	/*
+	 * Special entry for visibility control: pretend the method doesnt
+	 * exist.
+	 */
+
+	goto unknownMethod;
+    }
+
+    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * InfoObjectMixinsCmd --
  *
  *	Implements [info object mixins $objName]
@@ -869,12 +942,16 @@ InfoClassDefnCmd(
     if (hPtr == NULL) {
 	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
 		"\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
     procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
     if (procPtr == NULL) {
 	Tcl_AppendResult(interp,
 		"definition not available for this kind of method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
 
@@ -1012,6 +1089,8 @@ InfoClassForwardCmd(
     if (hPtr == NULL) {
 	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
 		"\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
     prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
@@ -1019,6 +1098,8 @@ InfoClassForwardCmd(
 	Tcl_AppendResult(interp,
 		"prefix argument list not available for this kind of method",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
 
@@ -1160,6 +1241,58 @@ InfoClassMethodsCmd(
 /*
  * ----------------------------------------------------------------------
  *
+ * InfoClassMethodTypeCmd --
+ *
+ *	Implements [info class methodtype $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassMethodTypeCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Method *mPtr;
+    Class *clsPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+	return TCL_ERROR;
+    }
+    clsPtr = GetClassFromObj(interp, objv[1]);
+    if (clsPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
+    if (hPtr == NULL) {
+    unknownMethod:
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
+		"\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		TclGetString(objv[2]), NULL);
+	return TCL_ERROR;
+    }
+    mPtr = Tcl_GetHashValue(hPtr);
+    if (mPtr->typePtr == NULL) {
+	/*
+	 * Special entry for visibility control: pretend the method doesnt
+	 * exist.
+	 */
+
+	goto unknownMethod;
+    }
+    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * InfoClassMixinsCmd --
  *
  *	Implements [info class mixins $clsName]