diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclOOInfo.c | 135 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 4 |
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 = { |