1533 lines
37 KiB
C
1533 lines
37 KiB
C
|
/*
|
|||
|
* tclOODefineCmds.c --
|
|||
|
*
|
|||
|
* This file contains the implementation of the ::oo-related [info]
|
|||
|
* subcommands.
|
|||
|
*
|
|||
|
* 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.
|
|||
|
*/
|
|||
|
|
|||
|
#ifdef HAVE_CONFIG_H
|
|||
|
#include "config.h"
|
|||
|
#endif
|
|||
|
#include "tclInt.h"
|
|||
|
#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;
|
|||
|
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;
|
|||
|
|
|||
|
/*
|
|||
|
* List of commands that are used to implement the [info object] subcommands.
|
|||
|
*/
|
|||
|
|
|||
|
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 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}
|
|||
|
};
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* TclOOInitInfo --
|
|||
|
*
|
|||
|
* Adjusts the Tcl core [info] command to contain subcommands ("object"
|
|||
|
* and "class") for introspection of objects and classes.
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
void
|
|||
|
TclOOInitInfo(
|
|||
|
Tcl_Interp *interp)
|
|||
|
{
|
|||
|
Tcl_Command infoCmd;
|
|||
|
Tcl_Obj *mapDict;
|
|||
|
|
|||
|
/*
|
|||
|
* Build the ensembles used to implement [info object] and [info class].
|
|||
|
*/
|
|||
|
|
|||
|
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
|
|||
|
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
|
|||
|
|
|||
|
/*
|
|||
|
* Install into the [info] ensemble.
|
|||
|
*/
|
|||
|
|
|||
|
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
|
|||
|
if (infoCmd) {
|
|||
|
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);
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* GetClassFromObj --
|
|||
|
*
|
|||
|
* How to correctly get a class from a Tcl_Obj. Just a wrapper round
|
|||
|
* Tcl_GetObjectFromObj, but this is an idiom that was used heavily.
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static inline Class *
|
|||
|
GetClassFromObj(
|
|||
|
Tcl_Interp *interp,
|
|||
|
Tcl_Obj *objPtr)
|
|||
|
{
|
|||
|
Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);
|
|||
|
|
|||
|
if (oPtr == NULL) {
|
|||
|
return NULL;
|
|||
|
}
|
|||
|
if (oPtr->classPtr == 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;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectClassCmd --
|
|||
|
*
|
|||
|
* Implements [info object class $objName ?$className?]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectClassCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
|
|||
|
if (objc != 2 && objc != 3) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
if (objc == 2) {
|
|||
|
Tcl_SetObjResult(interp,
|
|||
|
TclOOObjectName(interp, oPtr->selfCls->thisPtr));
|
|||
|
return TCL_OK;
|
|||
|
} else {
|
|||
|
Class *mixinPtr, *o2clsPtr;
|
|||
|
int i;
|
|||
|
|
|||
|
o2clsPtr = GetClassFromObj(interp, objv[2]);
|
|||
|
if (o2clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
FOREACH(mixinPtr, oPtr->mixins) {
|
|||
|
if (!mixinPtr) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewIntObj(
|
|||
|
TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectDefnCmd --
|
|||
|
*
|
|||
|
* Implements [info object definition $objName $methodName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectDefnCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
Tcl_HashEntry *hPtr;
|
|||
|
Proc *procPtr;
|
|||
|
CompiledLocal *localPtr;
|
|||
|
Tcl_Obj *resultObjs[2];
|
|||
|
|
|||
|
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;
|
|||
|
}
|
|||
|
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
|
|||
|
if (procPtr == 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;
|
|||
|
}
|
|||
|
|
|||
|
resultObjs[0] = Tcl_NewObj();
|
|||
|
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
|
|||
|
localPtr=localPtr->nextPtr) {
|
|||
|
if (TclIsVarArgument(localPtr)) {
|
|||
|
Tcl_Obj *argObj;
|
|||
|
|
|||
|
argObj = Tcl_NewObj();
|
|||
|
Tcl_ListObjAppendElement(NULL, argObj,
|
|||
|
Tcl_NewStringObj(localPtr->name, -1));
|
|||
|
if (localPtr->defValuePtr != NULL) {
|
|||
|
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
|
|||
|
}
|
|||
|
}
|
|||
|
resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectFiltersCmd --
|
|||
|
*
|
|||
|
* Implements [info object filters $objName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectFiltersCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
int i;
|
|||
|
Tcl_Obj *filterObj, *resultObj;
|
|||
|
Object *oPtr;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
|
|||
|
FOREACH(filterObj, oPtr->filters) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectForwardCmd --
|
|||
|
*
|
|||
|
* Implements [info object forward $objName $methodName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectForwardCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
Tcl_HashEntry *hPtr;
|
|||
|
Tcl_Obj *prefixObj;
|
|||
|
|
|||
|
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;
|
|||
|
}
|
|||
|
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
|
|||
|
if (prefixObj == NULL) {
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
|||
|
"prefix argument list not available for this kind of method",
|
|||
|
-1));
|
|||
|
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
|
|||
|
TclGetString(objv[2]), NULL);
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
Tcl_SetObjResult(interp, prefixObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectIsACmd --
|
|||
|
*
|
|||
|
* Implements [info object isa $category $objName ...]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectIsACmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
static const char *const categories[] = {
|
|||
|
"class", "metaclass", "mixin", "object", "typeof", NULL
|
|||
|
};
|
|||
|
enum IsACats {
|
|||
|
IsClass, IsMetaclass, IsMixin, IsObject, IsType
|
|||
|
};
|
|||
|
Object *oPtr, *o2Ptr;
|
|||
|
int idx, i, result = 0;
|
|||
|
|
|||
|
if (objc < 3) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
|
|||
|
&idx) != TCL_OK) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Now we know what test we are doing, we can check we've got the right
|
|||
|
* number of arguments.
|
|||
|
*/
|
|||
|
|
|||
|
switch ((enum IsACats) idx) {
|
|||
|
case IsObject:
|
|||
|
case IsClass:
|
|||
|
case IsMetaclass:
|
|||
|
if (objc != 3) {
|
|||
|
Tcl_WrongNumArgs(interp, 2, objv, "objName");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
break;
|
|||
|
case IsMixin:
|
|||
|
case IsType:
|
|||
|
if (objc != 4) {
|
|||
|
Tcl_WrongNumArgs(interp, 2, objv, "objName className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
break;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Perform the check. Note that we can guarantee that we will not fail
|
|||
|
* from here on; "failures" result in a false-TCL_OK result.
|
|||
|
*/
|
|||
|
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
goto failPrecondition;
|
|||
|
}
|
|||
|
|
|||
|
switch ((enum IsACats) idx) {
|
|||
|
case IsObject:
|
|||
|
result = 1;
|
|||
|
break;
|
|||
|
case IsClass:
|
|||
|
result = (oPtr->classPtr != NULL);
|
|||
|
break;
|
|||
|
case IsMetaclass:
|
|||
|
if (oPtr->classPtr != NULL) {
|
|||
|
result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls,
|
|||
|
oPtr->classPtr);
|
|||
|
}
|
|||
|
break;
|
|||
|
case IsMixin:
|
|||
|
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
|
|||
|
if (o2Ptr == NULL) {
|
|||
|
goto failPrecondition;
|
|||
|
}
|
|||
|
if (o2Ptr->classPtr != NULL) {
|
|||
|
Class *mixinPtr;
|
|||
|
|
|||
|
FOREACH(mixinPtr, oPtr->mixins) {
|
|||
|
if (!mixinPtr) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
|
|||
|
result = 1;
|
|||
|
break;
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
break;
|
|||
|
case IsType:
|
|||
|
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
|
|||
|
if (o2Ptr == NULL) {
|
|||
|
goto failPrecondition;
|
|||
|
}
|
|||
|
if (o2Ptr->classPtr != NULL) {
|
|||
|
result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls);
|
|||
|
}
|
|||
|
break;
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
|
|||
|
return TCL_OK;
|
|||
|
|
|||
|
failPrecondition:
|
|||
|
Tcl_ResetResult(interp);
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectMethodsCmd --
|
|||
|
*
|
|||
|
* Implements [info object methods $objName ?$option ...?]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectMethodsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
int flag = PUBLIC_METHOD, recurse = 0;
|
|||
|
FOREACH_HASH_DECLS;
|
|||
|
Tcl_Obj *namePtr, *resultObj;
|
|||
|
Method *mPtr;
|
|||
|
static const char *const options[] = {
|
|||
|
"-all", "-localprivate", "-private", NULL
|
|||
|
};
|
|||
|
enum Options {
|
|||
|
OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
|
|||
|
};
|
|||
|
|
|||
|
if (objc < 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (objc != 2) {
|
|||
|
int i, idx;
|
|||
|
|
|||
|
for (i=2 ; i<objc ; i++) {
|
|||
|
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
|
|||
|
&idx) != TCL_OK) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
switch ((enum Options) idx) {
|
|||
|
case OPT_ALL:
|
|||
|
recurse = 1;
|
|||
|
break;
|
|||
|
case OPT_LOCALPRIVATE:
|
|||
|
flag = PRIVATE_METHOD;
|
|||
|
break;
|
|||
|
case OPT_PRIVATE:
|
|||
|
flag = 0;
|
|||
|
break;
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
if (recurse) {
|
|||
|
const char **names;
|
|||
|
int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
|
|||
|
|
|||
|
for (i=0 ; i<numNames ; i++) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj,
|
|||
|
Tcl_NewStringObj(names[i], -1));
|
|||
|
}
|
|||
|
if (numNames > 0) {
|
|||
|
ckfree(names);
|
|||
|
}
|
|||
|
} else if (oPtr->methodsPtr) {
|
|||
|
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
|
|||
|
if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* 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]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectMixinsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Class *mixinPtr;
|
|||
|
Object *oPtr;
|
|||
|
Tcl_Obj *resultObj;
|
|||
|
int i;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(mixinPtr, oPtr->mixins) {
|
|||
|
if (!mixinPtr) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj,
|
|||
|
TclOOObjectName(interp, mixinPtr->thisPtr));
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectNsCmd --
|
|||
|
*
|
|||
|
* Implements [info object namespace $objName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectNsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
Tcl_SetObjResult(interp,
|
|||
|
Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectVariablesCmd --
|
|||
|
*
|
|||
|
* Implements [info object variables $objName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectVariablesCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
Tcl_Obj *variableObj, *resultObj;
|
|||
|
int i;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(variableObj, oPtr->variables) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoObjectVarsCmd --
|
|||
|
*
|
|||
|
* Implements [info object vars $objName ?$pattern?]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoObjectVarsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
const char *pattern = NULL;
|
|||
|
FOREACH_HASH_DECLS;
|
|||
|
VarInHash *vihPtr;
|
|||
|
Tcl_Obj *nameObj, *resultObj;
|
|||
|
|
|||
|
if (objc != 2 && objc != 3) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
|
|||
|
if (oPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (objc == 3) {
|
|||
|
pattern = TclGetString(objv[2]);
|
|||
|
}
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
|
|||
|
/*
|
|||
|
* Extract the information we need from the object's namespace's table of
|
|||
|
* variables. Note that this involves horrific knowledge of the guts of
|
|||
|
* tclVar.c, so we can't leverage our hash-iteration macros properly.
|
|||
|
*/
|
|||
|
|
|||
|
FOREACH_HASH_VALUE(vihPtr,
|
|||
|
&((Namespace *) oPtr->namespacePtr)->varTable.table) {
|
|||
|
nameObj = vihPtr->entry.key.objPtr;
|
|||
|
|
|||
|
if (TclIsVarUndefined(&vihPtr->var)
|
|||
|
|| !TclIsVarNamespaceVar(&vihPtr->var)) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
if (pattern != NULL
|
|||
|
&& !Tcl_StringMatch(TclGetString(nameObj), pattern)) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
|
|||
|
}
|
|||
|
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassConstrCmd --
|
|||
|
*
|
|||
|
* Implements [info class constructor $clsName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassConstrCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Proc *procPtr;
|
|||
|
CompiledLocal *localPtr;
|
|||
|
Tcl_Obj *resultObjs[2];
|
|||
|
Class *clsPtr;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (clsPtr->constructorPtr == NULL) {
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
|
|||
|
if (procPtr == 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;
|
|||
|
}
|
|||
|
|
|||
|
resultObjs[0] = Tcl_NewObj();
|
|||
|
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
|
|||
|
localPtr=localPtr->nextPtr) {
|
|||
|
if (TclIsVarArgument(localPtr)) {
|
|||
|
Tcl_Obj *argObj;
|
|||
|
|
|||
|
argObj = Tcl_NewObj();
|
|||
|
Tcl_ListObjAppendElement(NULL, argObj,
|
|||
|
Tcl_NewStringObj(localPtr->name, -1));
|
|||
|
if (localPtr->defValuePtr != NULL) {
|
|||
|
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
|
|||
|
}
|
|||
|
}
|
|||
|
resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassDefnCmd --
|
|||
|
*
|
|||
|
* Implements [info class definition $clsName $methodName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassDefnCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Tcl_HashEntry *hPtr;
|
|||
|
Proc *procPtr;
|
|||
|
CompiledLocal *localPtr;
|
|||
|
Tcl_Obj *resultObjs[2];
|
|||
|
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) {
|
|||
|
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_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;
|
|||
|
}
|
|||
|
|
|||
|
resultObjs[0] = Tcl_NewObj();
|
|||
|
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
|
|||
|
localPtr=localPtr->nextPtr) {
|
|||
|
if (TclIsVarArgument(localPtr)) {
|
|||
|
Tcl_Obj *argObj;
|
|||
|
|
|||
|
argObj = Tcl_NewObj();
|
|||
|
Tcl_ListObjAppendElement(NULL, argObj,
|
|||
|
Tcl_NewStringObj(localPtr->name, -1));
|
|||
|
if (localPtr->defValuePtr != NULL) {
|
|||
|
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
|
|||
|
}
|
|||
|
}
|
|||
|
resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
|
|||
|
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassDestrCmd --
|
|||
|
*
|
|||
|
* Implements [info class destructor $clsName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassDestrCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Proc *procPtr;
|
|||
|
Class *clsPtr;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
if (clsPtr->destructorPtr == NULL) {
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
|
|||
|
if (procPtr == 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;
|
|||
|
}
|
|||
|
|
|||
|
Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassFiltersCmd --
|
|||
|
*
|
|||
|
* Implements [info class filters $clsName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassFiltersCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
int i;
|
|||
|
Tcl_Obj *filterObj, *resultObj;
|
|||
|
Class *clsPtr;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(filterObj, clsPtr->filters) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassForwardCmd --
|
|||
|
*
|
|||
|
* Implements [info class forward $clsName $methodName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassForwardCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Tcl_HashEntry *hPtr;
|
|||
|
Tcl_Obj *prefixObj;
|
|||
|
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) {
|
|||
|
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_SetObjResult(interp, Tcl_NewStringObj(
|
|||
|
"prefix argument list not available for this kind of method",
|
|||
|
-1));
|
|||
|
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
|
|||
|
TclGetString(objv[2]), NULL);
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
Tcl_SetObjResult(interp, prefixObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassInstancesCmd --
|
|||
|
*
|
|||
|
* Implements [info class instances $clsName ?$pattern?]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassInstancesCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Object *oPtr;
|
|||
|
Class *clsPtr;
|
|||
|
int i;
|
|||
|
const char *pattern = NULL;
|
|||
|
Tcl_Obj *resultObj;
|
|||
|
|
|||
|
if (objc != 2 && objc != 3) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (objc == 3) {
|
|||
|
pattern = TclGetString(objv[2]);
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(oPtr, clsPtr->instances) {
|
|||
|
Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr);
|
|||
|
|
|||
|
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassMethodsCmd --
|
|||
|
*
|
|||
|
* Implements [info class methods $clsName ?-private?]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassMethodsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
int flag = PUBLIC_METHOD, recurse = 0;
|
|||
|
Tcl_Obj *namePtr, *resultObj;
|
|||
|
Method *mPtr;
|
|||
|
Class *clsPtr;
|
|||
|
static const char *const options[] = {
|
|||
|
"-all", "-localprivate", "-private", NULL
|
|||
|
};
|
|||
|
enum Options {
|
|||
|
OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
|
|||
|
};
|
|||
|
|
|||
|
if (objc < 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (objc != 2) {
|
|||
|
int i, idx;
|
|||
|
|
|||
|
for (i=2 ; i<objc ; i++) {
|
|||
|
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
|
|||
|
&idx) != TCL_OK) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
switch ((enum Options) idx) {
|
|||
|
case OPT_ALL:
|
|||
|
recurse = 1;
|
|||
|
break;
|
|||
|
case OPT_LOCALPRIVATE:
|
|||
|
flag = PRIVATE_METHOD;
|
|||
|
break;
|
|||
|
case OPT_PRIVATE:
|
|||
|
flag = 0;
|
|||
|
break;
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
if (recurse) {
|
|||
|
const char **names;
|
|||
|
int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
|
|||
|
|
|||
|
for (i=0 ; i<numNames ; i++) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj,
|
|||
|
Tcl_NewStringObj(names[i], -1));
|
|||
|
}
|
|||
|
if (numNames > 0) {
|
|||
|
ckfree(names);
|
|||
|
}
|
|||
|
} else {
|
|||
|
FOREACH_HASH_DECLS;
|
|||
|
|
|||
|
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
|
|||
|
if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* 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]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassMixinsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Class *clsPtr, *mixinPtr;
|
|||
|
Tcl_Obj *resultObj;
|
|||
|
int i;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(mixinPtr, clsPtr->mixins) {
|
|||
|
if (!mixinPtr) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj,
|
|||
|
TclOOObjectName(interp, mixinPtr->thisPtr));
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassSubsCmd --
|
|||
|
*
|
|||
|
* Implements [info class subclasses $clsName ?$pattern?]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassSubsCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Class *clsPtr, *subclassPtr;
|
|||
|
Tcl_Obj *resultObj;
|
|||
|
int i;
|
|||
|
const char *pattern = NULL;
|
|||
|
|
|||
|
if (objc != 2 && objc != 3) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
if (objc == 3) {
|
|||
|
pattern = TclGetString(objv[2]);
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(subclassPtr, clsPtr->subclasses) {
|
|||
|
Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
|
|||
|
|
|||
|
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
|
|||
|
}
|
|||
|
FOREACH(subclassPtr, clsPtr->mixinSubs) {
|
|||
|
Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
|
|||
|
|
|||
|
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
|
|||
|
continue;
|
|||
|
}
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassSupersCmd --
|
|||
|
*
|
|||
|
* Implements [info class superclasses $clsName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassSupersCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Class *clsPtr, *superPtr;
|
|||
|
Tcl_Obj *resultObj;
|
|||
|
int i;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(superPtr, clsPtr->superclasses) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj,
|
|||
|
TclOOObjectName(interp, superPtr->thisPtr));
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InfoClassVariablesCmd --
|
|||
|
*
|
|||
|
* Implements [info class variables $clsName]
|
|||
|
*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InfoClassVariablesCmd(
|
|||
|
ClientData clientData,
|
|||
|
Tcl_Interp *interp,
|
|||
|
int objc,
|
|||
|
Tcl_Obj *const objv[])
|
|||
|
{
|
|||
|
Class *clsPtr;
|
|||
|
Tcl_Obj *variableObj, *resultObj;
|
|||
|
int i;
|
|||
|
|
|||
|
if (objc != 2) {
|
|||
|
Tcl_WrongNumArgs(interp, 1, objv, "className");
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
clsPtr = GetClassFromObj(interp, objv[1]);
|
|||
|
if (clsPtr == NULL) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
resultObj = Tcl_NewObj();
|
|||
|
FOREACH(variableObj, clsPtr->variables) {
|
|||
|
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
|
|||
|
}
|
|||
|
Tcl_SetObjResult(interp, resultObj);
|
|||
|
return TCL_OK;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* ----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* 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
|
|||
|
* fill-column: 78
|
|||
|
* End:
|
|||
|
*/
|