diff options
author | dkf <dkf@noemail.net> | 2011-05-25 13:35:37 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2011-05-25 13:35:37 (GMT) |
commit | 40d360c5215eb5c467ca781174c0fb6d8f992b2f (patch) | |
tree | 66985fe8898ea0617e9fdf977923ca63d85c4389 /generic/tclOOInfo.c | |
parent | 27d699e8685f69a322b3e92e2d70175629d71c47 (diff) | |
download | tcl-40d360c5215eb5c467ca781174c0fb6d8f992b2f.zip tcl-40d360c5215eb5c467ca781174c0fb6d8f992b2f.tar.gz tcl-40d360c5215eb5c467ca781174c0fb6d8f992b2f.tar.bz2 |
Implementation of TIP #381: Call Chain Introspection and Control
FossilOrigin-Name: 2778ad161a0a0c67ae685b848e3b97470f163128
Diffstat (limited to 'generic/tclOOInfo.c')
-rw-r--r-- | generic/tclOOInfo.c | 90 |
1 files changed, 90 insertions, 0 deletions
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 4f25772..ac8ae46 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -17,6 +17,7 @@ #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; @@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; +static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; @@ -48,6 +50,7 @@ struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; */ static const struct NameProcMap infoObjectCmds[] = { + {"::oo::InfoObject::call", InfoObjectCallCmd}, {"::oo::InfoObject::class", InfoObjectClassCmd}, {"::oo::InfoObject::definition", InfoObjectDefnCmd}, {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, @@ -67,6 +70,7 @@ static const struct NameProcMap infoObjectCmds[] = { */ static const struct NameProcMap infoClassCmds[] = { + {"::oo::InfoClass::call", InfoClassCallCmd}, {"::oo::InfoClass::constructor", InfoClassConstrCmd}, {"::oo::InfoClass::definition", InfoClassDefnCmd}, {"::oo::InfoClass::destructor", InfoClassDestrCmd}, @@ -1456,6 +1460,92 @@ InfoClassVariablesCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoObjectCallCmd -- + * + * Implements [info object call $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + CallContext *contextPtr; + + 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; + } + + /* + * Get the call context and render its call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + TclOORenderCallChain(interp, contextPtr->callPtr)); + TclOODeleteContext(contextPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassCallCmd -- + * + * Implements [info class call $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + CallChain *callPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get an render the stereotypical call chain. + */ + + callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); + if (callPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |