summaryrefslogtreecommitdiffstats
path: root/generic/tclOOInfo.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOOInfo.c')
-rw-r--r--generic/tclOOInfo.c405
1 files changed, 297 insertions, 108 deletions
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 9874864..3217f98 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -4,12 +4,10 @@
* This file contains the implementation of the ::oo-related [info]
* subcommands.
*
- * Copyright (c) 2006-2008 by Donal K. Fellows
+ * Copyright (c) 2006-2011 by Donal K. Fellows
*
* 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 $
*/
#ifdef HAVE_CONFIG_H
@@ -19,16 +17,19 @@
#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;
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;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
+static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
@@ -36,48 +37,51 @@ 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;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
-struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
-
/*
* List of commands that are used to implement the [info object] subcommands.
*/
-static const struct NameProcMap infoObjectCmds[] = {
- {"::oo::InfoObject::class", InfoObjectClassCmd},
- {"::oo::InfoObject::definition", InfoObjectDefnCmd},
- {"::oo::InfoObject::filters", InfoObjectFiltersCmd},
- {"::oo::InfoObject::forward", InfoObjectForwardCmd},
- {"::oo::InfoObject::isa", InfoObjectIsACmd},
- {"::oo::InfoObject::methods", InfoObjectMethodsCmd},
- {"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
- {"::oo::InfoObject::namespace", InfoObjectNsCmd},
- {"::oo::InfoObject::variables", InfoObjectVariablesCmd},
- {"::oo::InfoObject::vars", InfoObjectVarsCmd},
- {NULL, NULL}
+static const EnsembleImplMap infoObjectCmds[] = {
+ {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+ {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
+ {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* List of commands that are used to implement the [info class] subcommands.
*/
-static const struct NameProcMap infoClassCmds[] = {
- {"::oo::InfoClass::constructor", InfoClassConstrCmd},
- {"::oo::InfoClass::definition", InfoClassDefnCmd},
- {"::oo::InfoClass::destructor", InfoClassDestrCmd},
- {"::oo::InfoClass::filters", InfoClassFiltersCmd},
- {"::oo::InfoClass::forward", InfoClassForwardCmd},
- {"::oo::InfoClass::instances", InfoClassInstancesCmd},
- {"::oo::InfoClass::methods", InfoClassMethodsCmd},
- {"::oo::InfoClass::mixins", InfoClassMixinsCmd},
- {"::oo::InfoClass::subclasses", InfoClassSubsCmd},
- {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
- {"::oo::InfoClass::variables", InfoClassVariablesCmd},
- {NULL, NULL}
+static const EnsembleImplMap infoClassCmds[] = {
+ {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -95,58 +99,27 @@ void
TclOOInitInfo(
Tcl_Interp *interp)
{
- Tcl_Namespace *nsPtr;
Tcl_Command infoCmd;
- int i;
+ Tcl_Obj *mapDict;
/*
- * Build the ensemble used to implement [info object].
+ * Build the ensembles used to implement [info object] and [info class].
*/
- nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
- Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
- Tcl_Export(interp, nsPtr, "[a-z]*", 1);
- for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
- Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
- infoObjectCmds[i].proc, NULL, NULL);
- }
-
- /*
- * Build the ensemble used to implement [info class].
- */
-
- nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
- Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
- Tcl_Export(interp, nsPtr, "[a-z]*", 1);
- for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
- Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
- infoClassCmds[i].proc, NULL, NULL);
- }
+ TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
+ TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the master [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
- if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) {
- Tcl_Obj *mapDict, *objectObj, *classObj;
-
- Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
- if (mapDict != NULL) {
- objectObj = Tcl_NewStringObj("object", -1);
- classObj = Tcl_NewStringObj("class", -1);
-
- Tcl_IncrRefCount(objectObj);
- Tcl_IncrRefCount(classObj);
- Tcl_DictObjPut(NULL, mapDict, objectObj,
- Tcl_NewStringObj("::oo::InfoObject", -1));
- Tcl_DictObjPut(NULL, mapDict, classObj,
- Tcl_NewStringObj("::oo::InfoClass", -1));
- Tcl_DecrRefCount(objectObj);
- Tcl_DecrRefCount(classObj);
- Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
- }
- }
+ Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
+ Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
+ Tcl_NewStringObj("::oo::InfoObject", -1));
+ Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1),
+ Tcl_NewStringObj("::oo::InfoClass", -1));
+ Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
}
/*
@@ -171,8 +144,10 @@ GetClassFromObj(
return NULL;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objPtr),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objPtr), NULL);
return NULL;
}
return oPtr->classPtr;
@@ -212,28 +187,22 @@ InfoObjectClassCmd(
TclOOObjectName(interp, oPtr->selfCls->thisPtr));
return TCL_OK;
} else {
- Object *o2Ptr;
- Class *mixinPtr;
+ Class *mixinPtr, *o2clsPtr;
int i;
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
- "\" is not a class", NULL);
+ o2clsPtr = GetClassFromObj(interp, objv[2]);
+ if (o2clsPtr == NULL) {
return TCL_ERROR;
}
FOREACH(mixinPtr, oPtr->mixins) {
- if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+ if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(
- TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+ TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
return TCL_OK;
}
}
@@ -277,14 +246,18 @@ InfoObjectDefnCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ 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_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -384,15 +357,19 @@ InfoObjectForwardCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -481,7 +458,9 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "non-classes cannot be mixins", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
} else {
Class *mixinPtr;
@@ -505,7 +484,9 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "non-classes cannot be types", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
}
if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
@@ -589,7 +570,7 @@ InfoObjectMethodsCmd(
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
- ckfree((char *) names);
+ ckfree(names);
}
} else if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
@@ -605,6 +586,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_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ 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]
@@ -809,8 +847,9 @@ InfoClassConstrCmd(
}
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
@@ -867,14 +906,18 @@ InfoClassDefnCmd(
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ 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_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -932,8 +975,9 @@ InfoClassDestrCmd(
}
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
@@ -1010,15 +1054,19 @@ InfoClassForwardCmd(
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -1142,7 +1190,7 @@ InfoClassMethodsCmd(
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
- ckfree((char *) names);
+ ckfree(names);
}
} else {
FOREACH_HASH_DECLS;
@@ -1160,6 +1208,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_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
+ 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]
@@ -1329,6 +1429,95 @@ 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_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct any call chain", -1));
+ 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_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct any call chain", -1));
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
+ TclOODeleteChain(callPtr);
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
generated by cgit v0.12 at 2025-10-25 22:09:01 (GMT)