summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-03-24 13:21:11 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-03-24 13:21:11 (GMT)
commit188c38659bf0d5e51f7263d592af87cd8c753a17 (patch)
tree18095fdb9ca794ca8c336dc02b1b74419705e5cb /generic
parent8158cea2c168d259b1161bffdc4cd276b93b386b (diff)
downloadtcl-188c38659bf0d5e51f7263d592af87cd8c753a17.zip
tcl-188c38659bf0d5e51f7263d592af87cd8c753a17.tar.gz
tcl-188c38659bf0d5e51f7263d592af87cd8c753a17.tar.bz2
* generic/tclOOInfo.c (InfoObjectMethodTypeCmd)
(InfoClassMethodTypeCmd): Added introspection of method types so that it is possible to find this info out without using errors.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOOInfo.c135
-rw-r--r--generic/tclOOMethod.c4
2 files changed, 136 insertions, 3 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]
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 6c13116..9f5be6b 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -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: tclOOMethod.c,v 1.25 2010/03/07 14:39:26 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.26 2010/03/24 13:21:11 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -108,7 +108,7 @@ static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp,
*/
static const Tcl_MethodType procMethodType = {
- TCL_OO_METHOD_VERSION_CURRENT, "procedural method",
+ TCL_OO_METHOD_VERSION_CURRENT, "method",
InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
};
static const Tcl_MethodType fwdMethodType = {