diff options
| author | William Joye <wjoye@cfa.harvard.edu> | 2018-01-02 21:03:49 (GMT) |
|---|---|---|
| committer | William Joye <wjoye@cfa.harvard.edu> | 2018-01-02 21:03:49 (GMT) |
| commit | 914501b5b992e7b6c7e0a4c958712a8ba9cab41c (patch) | |
| tree | edbc059b9557d5fdb79e5a5c47889bc54708da53 /tcl8.6/pkgs/itcl4.1.1/generic | |
| parent | f88c190a01bc7f57e79dfaf91a3c0c48c2031549 (diff) | |
| download | blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.zip blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.tar.gz blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.tar.bz2 | |
upgrade to tcl/tk 8.6.8
Diffstat (limited to 'tcl8.6/pkgs/itcl4.1.1/generic')
33 files changed, 37079 insertions, 0 deletions
diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/clientData b/tcl8.6/pkgs/itcl4.1.1/generic/clientData new file mode 100644 index 0000000..62e3f3c --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/clientData @@ -0,0 +1,16 @@ +itcl2TclOO.c: framePtr->clientData = NULL; +itcl2TclOO.c: framePtr->objc = objc; +itcl2TclOO.c: framePtr->objv = objv; +itcl2TclOO.c: framePtr->procPtr = procPtr; +itcl2TclOO.c: if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { +itcl2TclOO.c: contextPtr = framePtr->clientData; +itcl2TclOO.c: if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { +itclMigrate2TclCore.c: framePtr->isProcCallFrame |= FRAME_HAS_RESOLVER; +itclMigrate2TclCore.c: framePtr->resolvePtr = resolvePtr; +itclMigrate2TclCore.c: framePtr = framePtr->callerVarPtr; +itclMigrate2TclCore.c: framePtr = framePtr->callerVarPtr; +itclMigrate2TclCore.c: return (Tcl_Namespace *)framePtr->nsPtr; +itclMigrate2TclCore.c: return framePtr->clientData; +itclMigrate2TclCore.c: ((Interp *)interp)->framePtr->nsPtr = (Namespace *)nsPtr; +itclMigrate2TclCore.c: return ((Interp *)interp)->framePtr->objc; +itclMigrate2TclCore.c: return ((Interp *)interp)->framePtr->objv; diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itcl.decls b/tcl8.6/pkgs/itcl4.1.1/generic/itcl.decls new file mode 100644 index 0000000..1530464 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itcl.decls @@ -0,0 +1,621 @@ +# -*- tcl -*- + +# public API +library itcl +interface itcl +hooks {itclInt} +epoch 0 +scspec ITCLAPI + +# Declare each of the functions in the public Tcl interface. Note that +# the an index should never be reused for a different function in order +# to preserve backwards compatibility. + +declare 2 { + int Itcl_RegisterC(Tcl_Interp *interp, const char *name, + Tcl_CmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) +} +declare 3 { + int Itcl_RegisterObjC(Tcl_Interp *interp, const char *name, + Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) +} +declare 4 { + int Itcl_FindC(Tcl_Interp *interp, const char *name, + Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr, + ClientData *cDataPtr) +} +declare 5 { + void Itcl_InitStack(Itcl_Stack *stack) +} +declare 6 { + void Itcl_DeleteStack(Itcl_Stack *stack) +} +declare 7 { + void Itcl_PushStack(ClientData cdata, Itcl_Stack *stack) +} +declare 8 { + ClientData Itcl_PopStack(Itcl_Stack *stack) +} +declare 9 { + ClientData Itcl_PeekStack(Itcl_Stack *stack) +} +declare 10 { + ClientData Itcl_GetStackValue(Itcl_Stack *stack, int pos) +} +declare 11 { + void Itcl_InitList(Itcl_List *listPtr) +} +declare 12 { + void Itcl_DeleteList(Itcl_List *listPtr) +} +declare 13 { + Itcl_ListElem *Itcl_CreateListElem(Itcl_List *listPtr) +} +declare 14 { + Itcl_ListElem *Itcl_DeleteListElem(Itcl_ListElem *elemPtr) +} +declare 15 { + Itcl_ListElem *Itcl_InsertList(Itcl_List *listPtr, ClientData val) +} +declare 16 { + Itcl_ListElem *Itcl_InsertListElem(Itcl_ListElem *pos, ClientData val) +} +declare 17 { + Itcl_ListElem *Itcl_AppendList(Itcl_List *listPtr, ClientData val) +} +declare 18 { + Itcl_ListElem *Itcl_AppendListElem(Itcl_ListElem *pos, ClientData val) +} +declare 19 { + void Itcl_SetListValue(Itcl_ListElem *elemPtr, ClientData val) +} +declare 20 { + void Itcl_EventuallyFree(ClientData cdata, Tcl_FreeProc *fproc) +} +declare 21 { + void Itcl_PreserveData(ClientData cdata) +} +declare 22 { + void Itcl_ReleaseData(ClientData cdata) +} +declare 23 { + Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp *interp, int status) +} +declare 24 { + int Itcl_RestoreInterpState(Tcl_Interp *interp, Itcl_InterpState state) +} +declare 25 { + void Itcl_DiscardInterpState(Itcl_InterpState state) +} + + +# private API +interface itclInt +# +# Functions used within the package, but not considered "public" +# + +declare 0 { + int Itcl_IsClassNamespace(Tcl_Namespace *namesp) +} +declare 1 { + int Itcl_IsClass(Tcl_Command cmd) +} +declare 2 { + ItclClass *Itcl_FindClass(Tcl_Interp *interp, const char *path, int autoload) +} +declare 3 { + int Itcl_FindObject(Tcl_Interp *interp, const char *name, ItclObject **roPtr) +} +declare 4 { + int Itcl_IsObject(Tcl_Command cmd) +} +declare 5 { + int Itcl_ObjectIsa(ItclObject *contextObj, ItclClass *cdefn) +} +declare 6 { + int Itcl_Protection(Tcl_Interp *interp, int newLevel) +} +declare 7 { + const char *Itcl_ProtectionStr(int pLevel) +} +declare 8 { + int Itcl_CanAccess(ItclMemberFunc *memberPtr, Tcl_Namespace *fromNsPtr) +} +declare 9 { + int Itcl_CanAccessFunc(ItclMemberFunc *mfunc, Tcl_Namespace *fromNsPtr) +} +declare 11 { + void Itcl_ParseNamespPath(const char *name, Tcl_DString *buffer, + const char **head, const char **tail) +} +declare 12 { + int Itcl_DecodeScopedCommand(Tcl_Interp *interp, const char *name, + Tcl_Namespace **rNsPtr, char **rCmdPtr) +} +declare 13 { + int Itcl_EvalArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +} +declare 14 { + Tcl_Obj *Itcl_CreateArgs(Tcl_Interp *interp, const char *string, + int objc, Tcl_Obj *const objv[]) +} +declare 17 { + int Itcl_GetContext(Tcl_Interp *interp, ItclClass **iclsPtrPtr, + ItclObject **ioPtrPtr) +} +declare 18 { + void Itcl_InitHierIter(ItclHierIter *iter, ItclClass *iclsPtr) +} +declare 19 { + void Itcl_DeleteHierIter(ItclHierIter *iter) +} +declare 20 { + ItclClass *Itcl_AdvanceHierIter(ItclHierIter *iter) +} +declare 21 { + int Itcl_FindClassesCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 22 { + int Itcl_FindObjectsCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 24 { + int Itcl_DelClassCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 25 { + int Itcl_DelObjectCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 26 { + int Itcl_ScopeCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 27 { + int Itcl_CodeCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 28 { + int Itcl_StubCreateCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 29 { + int Itcl_StubExistsCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 30 { + int Itcl_IsStub(Tcl_Command cmd) +} + + +# +# Functions for manipulating classes +# + +declare 31 { + int Itcl_CreateClass(Tcl_Interp *interp, const char *path, + ItclObjectInfo *info, ItclClass **rPtr) +} +declare 32 { + int Itcl_DeleteClass(Tcl_Interp *interp, ItclClass *iclsPtr) +} +declare 33 { + Tcl_Namespace *Itcl_FindClassNamespace(Tcl_Interp *interp, const char *path) +} +declare 34 { + int Itcl_HandleClass(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 38 { + void Itcl_BuildVirtualTables(ItclClass *iclsPtr) +} +declare 39 { + int Itcl_CreateVariable(Tcl_Interp *interp, ItclClass *iclsPtr, + Tcl_Obj *name, char *init, char *config, ItclVariable **ivPtr) +} +declare 40 { + void Itcl_DeleteVariable(char *cdata) +} +declare 41 { + const char *Itcl_GetCommonVar(Tcl_Interp *interp, const char *name, + ItclClass *contextClass) +} + + +# +# Functions for manipulating objects +# + +declare 44 { + int Itcl_CreateObject(Tcl_Interp *interp, const char* name, ItclClass *iclsPtr, + int objc, Tcl_Obj *const objv[], ItclObject **rioPtr) +} +declare 45 { + int Itcl_DeleteObject(Tcl_Interp *interp, ItclObject *contextObj) +} +declare 46 { + int Itcl_DestructObject(Tcl_Interp *interp, ItclObject *contextObj, + int flags) +} +declare 48 { + const char *Itcl_GetInstanceVar(Tcl_Interp *interp, const char *name, + ItclObject *contextIoPtr, ItclClass *contextIclsPtr) +} + +# +# Functions for manipulating methods and procs +# + +declare 50 { + int Itcl_BodyCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 51 { + int Itcl_ConfigBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 52 { + int Itcl_CreateMethod(Tcl_Interp *interp, ItclClass *iclsPtr, + Tcl_Obj *namePtr, const char *arglist, const char *body) +} +declare 53 { + int Itcl_CreateProc(Tcl_Interp *interp, ItclClass *iclsPtr, + Tcl_Obj *namePtr, const char *arglist, const char *body) +} +declare 54 { + int Itcl_CreateMemberFunc(Tcl_Interp *interp, ItclClass *iclsPtr, + Tcl_Obj *name, const char *arglist, const char *body, + ItclMemberFunc **mfuncPtr) +} +declare 55 { + int Itcl_ChangeMemberFunc(Tcl_Interp *interp, ItclMemberFunc *mfunc, + const char *arglist, const char *body) +} +declare 56 { + void Itcl_DeleteMemberFunc(char *cdata) +} +declare 57 { + int Itcl_CreateMemberCode(Tcl_Interp *interp, ItclClass *iclsPtr, \ + const char *arglist, const char *body, ItclMemberCode **mcodePtr) +} +declare 58 { + void Itcl_DeleteMemberCode(char *cdata) +} +declare 59 { + int Itcl_GetMemberCode(Tcl_Interp *interp, ItclMemberFunc *mfunc) +} +declare 61 { + int Itcl_EvalMemberCode(Tcl_Interp *interp, ItclMemberFunc *mfunc, + ItclObject *contextObj, int objc, Tcl_Obj *const objv[]) +} +declare 67 { + void Itcl_GetMemberFuncUsage(ItclMemberFunc *mfunc, + ItclObject *contextObj, Tcl_Obj *objPtr) +} +declare 68 { + int Itcl_ExecMethod(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 69 { + int Itcl_ExecProc(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 71 { + int Itcl_ConstructBase(Tcl_Interp *interp, ItclObject *contextObj, + ItclClass *contextClass) +} +declare 72 { + int Itcl_InvokeMethodIfExists(Tcl_Interp *interp, const char *name, + ItclClass *contextClass, ItclObject *contextObj, int objc, + Tcl_Obj *const objv[]) +} +declare 74 { + int Itcl_ReportFuncErrors(Tcl_Interp *interp, ItclMemberFunc *mfunc, + ItclObject *contextObj, int result) +} + + +# +# Commands for parsing class definitions +# + +declare 75 { + int Itcl_ParseInit(Tcl_Interp *interp, ItclObjectInfo *info) +} +declare 76 { + int Itcl_ClassCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 77 { + int Itcl_ClassInheritCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 78 { + int Itcl_ClassProtectionCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 79 { + int Itcl_ClassConstructorCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 80 { + int Itcl_ClassDestructorCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 81 { + int Itcl_ClassMethodCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 82 { + int Itcl_ClassProcCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 83 { + int Itcl_ClassVariableCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 84 { + int Itcl_ClassCommonCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 85 { + int Itcl_ParseVarResolver(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNs, int flags, Tcl_Var *rPtr) +} + +# +# Commands in the "builtin" namespace +# + +declare 86 { + int Itcl_BiInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr) +} +declare 87 { + int Itcl_InstallBiMethods(Tcl_Interp *interp, ItclClass *cdefn) +} +declare 88 { + int Itcl_BiIsaCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 89 { + int Itcl_BiConfigureCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 90 { + int Itcl_BiCgetCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 91 { + int Itcl_BiChainCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 92 { + int Itcl_BiInfoClassCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 93 { + int Itcl_BiInfoInheritCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 94 { + int Itcl_BiInfoHeritageCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 95 { + int Itcl_BiInfoFunctionCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 96 { + int Itcl_BiInfoVariableCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 97 { + int Itcl_BiInfoBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 98 { + int Itcl_BiInfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +#declare 99 { +# int Itcl_DefaultInfoCmd(ClientData dummy, Tcl_Interp *interp, int objc, +# Tcl_Obj *const objv[]) +#} + + +# +# Ensembles +# + +declare 100 { + int Itcl_EnsembleInit(Tcl_Interp *interp) +} +declare 101 { + int Itcl_CreateEnsemble(Tcl_Interp *interp, const char *ensName) +} +declare 102 { + int Itcl_AddEnsemblePart(Tcl_Interp *interp, const char *ensName, + const char *partName, const char *usageInfo, Tcl_ObjCmdProc *objProc, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc) +} +declare 103 { + int Itcl_GetEnsemblePart(Tcl_Interp *interp, const char *ensName, + const char *partName, Tcl_CmdInfo *infoPtr) +} +declare 104 { + int Itcl_IsEnsemble(Tcl_CmdInfo *infoPtr) +} +declare 105 { + int Itcl_GetEnsembleUsage(Tcl_Interp *interp, const char *ensName, + Tcl_Obj *objPtr) +} +declare 106 { + int Itcl_GetEnsembleUsageForObj(Tcl_Interp *interp, Tcl_Obj *ensObjPtr, + Tcl_Obj *objPtr) +} +declare 107 { + int Itcl_EnsembleCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 108 { + int Itcl_EnsPartCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 109 { + int Itcl_EnsembleErrorCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 115 { + void Itcl_Assert(const char *testExpr, const char *fileName, int lineNum) +} +declare 116 { + int Itcl_IsObjectCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 117 { + int Itcl_IsClassCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} + +# +# new commands to use TclOO functionality +# + +declare 140 { + int Itcl_FilterAddCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 141 { + int Itcl_FilterDeleteCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 142 { + int Itcl_ForwardAddCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 143 { + int Itcl_ForwardDeleteCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 144 { + int Itcl_MixinAddCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 145 { + int Itcl_MixinDeleteCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} + +# +# Helper commands +# + +#declare 150 { +# int Itcl_BiInfoCmd(ClientData clientData, Tcl_Interp *interp, int objc, +# Tcl_Obj *const objv[]) +#} +declare 151 { + int Itcl_BiInfoUnknownCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 152 { + int Itcl_BiInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 153 { + int Itcl_CanAccess2(ItclClass *iclsPtr, int protection, + Tcl_Namespace *fromNsPtr) +} +declare 160 { + int Itcl_SetCallFrameResolver(Tcl_Interp *interp, + Tcl_Resolve *resolvePtr) +} +declare 161 { + int ItclEnsembleSubCmd(ClientData clientData, Tcl_Interp *interp, + const char *ensembleName, int objc, Tcl_Obj *const *objv, + const char *functionName) +} +declare 162 { + Tcl_Namespace *Itcl_GetUplevelNamespace(Tcl_Interp *interp, int level) +} +declare 163 { + ClientData Itcl_GetCallFrameClientData(Tcl_Interp *interp) +} +declare 165 { + int Itcl_SetCallFrameNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) +} +declare 166 { + int Itcl_GetCallFrameObjc(Tcl_Interp *interp) +} +declare 167 { + Tcl_Obj *const *Itcl_GetCallFrameObjv(Tcl_Interp *interp) +} +declare 168 { + int Itcl_NWidgetCmd(ClientData infoPtr, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 169 { + int Itcl_AddOptionCmd(ClientData infoPtr, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 170 { + int Itcl_AddComponentCmd(ClientData infoPtr, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 171 { + int Itcl_BiInfoOptionCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +} +declare 172 { + int Itcl_BiInfoComponentCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +} +declare 173 { + int Itcl_RenameCommand(Tcl_Interp *interp, const char *oldName, + const char *newName) +} +declare 174 { + int Itcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, + Tcl_Namespace *nsPtr, int isProcCallFrame) +} +declare 175 { + void Itcl_PopCallFrame(Tcl_Interp *interp) +} +declare 176 { + Tcl_CallFrame *Itcl_GetUplevelCallFrame(Tcl_Interp *interp, + int level) +} +declare 177 { + Tcl_CallFrame *Itcl_ActivateCallFrame(Tcl_Interp *interp, + Tcl_CallFrame *framePtr) +} +declare 178 { + const char* ItclSetInstanceVar(Tcl_Interp *interp, + const char *name, const char *name2, const char *value, + ItclObject *contextIoPtr, ItclClass *contextIclsPtr) +} +declare 179 { + Tcl_Obj * ItclCapitalize(const char *str) +} +declare 180 { + int ItclClassBaseCmd(ClientData clientData, Tcl_Interp *interp, + int flags, int objc, Tcl_Obj *const objv[], ItclClass **iclsPtrPtr) +} +declare 181 { + int ItclCreateComponent(Tcl_Interp *interp, ItclClass *iclsPtr, + Tcl_Obj *componentPtr, int type, ItclComponent **icPtrPtr) +} +declare 182 { + void Itcl_SetContext(Tcl_Interp *interp, ItclObject *ioPtr) +} +declare 183 { + void Itcl_UnsetContext(Tcl_Interp *interp) +} +declare 184 { + const char * ItclGetInstanceVar(Tcl_Interp *interp, const char *name, + const char *name2, ItclObject *ioPtr, ItclClass *iclsPtr) +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itcl.h b/tcl8.6/pkgs/itcl4.1.1/generic/itcl.h new file mode 100644 index 0000000..23a84a6 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itcl.h @@ -0,0 +1,203 @@ +/* + * itcl.h -- + * + * This file contains definitions for the C-implemeted part of a Itcl + * this version of [incr Tcl] (Itcl) is a completely new implementation + * based on TclOO extension of Tcl 8.5 + * It tries to provide the same interfaces as the original implementation + * of Michael J. McLennan + * Some small pieces of code are taken from that implementation + * + * Copyright (c) 2007 by Arnulf P. Wiedemann + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * ADDING [incr Tcl] TO A Tcl-BASED APPLICATION: + * + * To add [incr Tcl] facilities to a Tcl application, modify the + * Tcl_AppInit() routine as follows: + * + * 1) Include this header file near the top of the file containing + * Tcl_AppInit(): + * + * #include "itcl.h" +* + * 2) Within the body of Tcl_AppInit(), add the following lines: + * + * if (Itcl_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * 3) Link your application with libitcl.a + * + * NOTE: An example file "tclAppInit.c" containing the changes shown + * above is included in this distribution. + * + *--------------------------------------------------------------------- + */ + +#ifndef ITCL_H_INCLUDED +#define ITCL_H_INCLUDED + +#include <tcl.h> + +#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6) +# error Itcl 4 build requires tcl.h from Tcl 8.6 or later +#endif + +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef TCL_ALPHA_RELEASE +# define TCL_ALPHA_RELEASE 0 +#endif +#ifndef TCL_BETA_RELEASE +# define TCL_BETA_RELEASE 1 +#endif +#ifndef TCL_FINAL_RELEASE +# define TCL_FINAL_RELEASE 2 +#endif + +#define ITCL_MAJOR_VERSION 4 +#define ITCL_MINOR_VERSION 1 +#define ITCL_RELEASE_LEVEL TCL_FINAL_RELEASE +#define ITCL_RELEASE_SERIAL 1 + +#define ITCL_VERSION "4.1" +#define ITCL_PATCH_LEVEL "4.1.1" + + +/* + * A special definition used to allow this header file to be included from + * windows resource files so that they can obtain version information. + * RC_INVOKED is defined by default by the windows RC tool. + * + * Resource compilers don't like all the C stuff, like typedefs and function + * declarations, that occur below, so block them out. + */ + +#ifndef RC_INVOKED + +#define ITCL_NAMESPACE "::itcl" + +#ifndef ITCLAPI +# if defined(BUILD_itcl) +# define ITCLAPI MODULE_SCOPE +# else +# define ITCLAPI extern +# undef USE_ITCL_STUBS +# define USE_ITCL_STUBS 1 +# endif +#endif + +#if defined(BUILD_itcl) && !defined(STATIC_BUILD) +# define ITCL_EXTERN extern DLLEXPORT +#else +# define ITCL_EXTERN extern +#endif + +ITCL_EXTERN int Itcl_Init(Tcl_Interp *interp); +ITCL_EXTERN int Itcl_SafeInit(Tcl_Interp *interp); + +/* + * Protection levels: + * + * ITCL_PUBLIC - accessible from any namespace + * ITCL_PROTECTED - accessible from namespace that imports in "protected" mode + * ITCL_PRIVATE - accessible only within the namespace that contains it + */ +#define ITCL_PUBLIC 1 +#define ITCL_PROTECTED 2 +#define ITCL_PRIVATE 3 +#define ITCL_DEFAULT_PROTECT 4 + +/* + * Generic stack. + */ +typedef struct Itcl_Stack { + ClientData *values; /* values on stack */ + int len; /* number of values on stack */ + int max; /* maximum size of stack */ + ClientData space[5]; /* initial space for stack data */ +} Itcl_Stack; + +#define Itcl_GetStackSize(stackPtr) ((stackPtr)->len) + +/* + * Generic linked list. + */ +struct Itcl_List; +typedef struct Itcl_ListElem { + struct Itcl_List* owner; /* list containing this element */ + ClientData value; /* value associated with this element */ + struct Itcl_ListElem *prev; /* previous element in linked list */ + struct Itcl_ListElem *next; /* next element in linked list */ +} Itcl_ListElem; + +typedef struct Itcl_List { + int validate; /* validation stamp */ + int num; /* number of elements */ + struct Itcl_ListElem *head; /* previous element in linked list */ + struct Itcl_ListElem *tail; /* next element in linked list */ +} Itcl_List; + +#define Itcl_FirstListElem(listPtr) ((listPtr)->head) +#define Itcl_LastListElem(listPtr) ((listPtr)->tail) +#define Itcl_NextListElem(elemPtr) ((elemPtr)->next) +#define Itcl_PrevListElem(elemPtr) ((elemPtr)->prev) +#define Itcl_GetListLength(listPtr) ((listPtr)->num) +#define Itcl_GetListValue(elemPtr) ((elemPtr)->value) + +/* + * Token representing the state of an interpreter. + */ +typedef struct Itcl_InterpState_ *Itcl_InterpState; + + +/* + * Include all the public API, generated from itcl.decls. + */ + +#include "itclDecls.h" + +#ifdef ITCL_PRESERVE_DEBUG +#undef Itcl_PreserveData +#undef Itcl_ReleaseData +void ItclDbgPreserveData(ClientData cdata, int line, const char *file); +void ItclDbgReleaseData(ClientData cdata, int line, const char *file); +#define Itcl_PreserveData(addr) ItclDbgPreserveData(addr, __LINE__, __FILE__) +#define Itcl_ReleaseData(addr) ItclDbgReleaseData(addr, __LINE__, __FILE__) +#endif + +#endif /* RC_INVOKED */ + +/* + * end block for C++ + */ + +#ifdef __cplusplus +} +#endif + +#endif /* ITCL_H_INCLUDED */ diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.c b/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.c new file mode 100644 index 0000000..30ea887 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.c @@ -0,0 +1,377 @@ +/* + * itcl2TclOO.c -- + * + * This file contains code to create and manage methods. + * + * Copyright (c) 2007 by Arnulf P. Wiedemann + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include <tclInt.h> +#include <tclOOInt.h> +#include "itclInt.h" + +void * +Itcl_GetCurrentCallbackPtr( + Tcl_Interp *interp) +{ + return TOP_CB(interp); +} + +int +Itcl_NRRunCallbacks( + Tcl_Interp *interp, + void *rootPtr) +{ + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); +} + +static int +CallFinalizePMCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Namespace *nsPtr = data[0]; + TclOO_PostCallProc *postCallProc = (TclOO_PostCallProc *)data[1]; + ClientData clientData = data[2]; + + /* + * Give the post-call callback a chance to do some cleanup. Note that at + * this point the call frame itself is invalid; it's already been popped. + */ + + return postCallProc(clientData, interp, NULL, nsPtr, result); +} + +static int +FreeCommand( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + Proc *procPtr = data[1]; + + ckfree(cmdPtr); + procPtr->cmdPtr = NULL; + + return result; +} + +static int +Tcl_InvokeClassProcedureMethod( + Tcl_Interp *interp, + Tcl_Obj *namePtr, /* name of the method */ + Tcl_Namespace *nsPtr, /* namespace for calling method */ + ProcedureMethod *pmPtr, /* method type specific data */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Arguments as actually seen. */ +{ + Proc *procPtr = pmPtr->procPtr; + CallFrame *framePtr = NULL; + CallFrame **framePtrPtr1 = &framePtr; + Tcl_CallFrame **framePtrPtr = (Tcl_CallFrame **)framePtrPtr1; + int result; + + if (procPtr->cmdPtr == NULL) { + Command *cmdPtr = ckalloc(sizeof(Command)); + + memset(cmdPtr, 0, sizeof(Command)); + cmdPtr->nsPtr = (Namespace *) nsPtr; + cmdPtr->clientData = NULL; + procPtr->cmdPtr = cmdPtr; + Tcl_NRAddCallback(interp, FreeCommand, cmdPtr, procPtr, NULL, NULL); + } + + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) nsPtr, "body of method", Tcl_GetString(namePtr)); + if (result != TCL_OK) { + return result; + } + /* + * Make the stack frame and fill it out with information about this call. + * This operation may fail. + */ + + + result = TclPushStackFrame(interp, framePtrPtr, nsPtr, FRAME_IS_PROC); + if (result != TCL_OK) { + return result; + } + + framePtr->clientData = NULL; + framePtr->objc = objc; + framePtr->objv = objv; + framePtr->procPtr = procPtr; + + /* + * Give the pre-call callback a chance to do some setup and, possibly, + * veto the call. + */ + + if (pmPtr->preCallProc != NULL) { + int isFinished; + + result = pmPtr->preCallProc(pmPtr->clientData, interp, NULL, + (Tcl_CallFrame *) framePtr, &isFinished); + if (isFinished || result != TCL_OK) { + Tcl_PopCallFrame(interp); + TclStackFree(interp, framePtr); + goto done; + } + } + + /* + * Now invoke the body of the method. Note that we need to take special + * action when doing unknown processing to ensure that the missing method + * name is passed as an argument. + */ + + if (pmPtr->postCallProc) { + Tcl_NRAddCallback(interp, CallFinalizePMCall, nsPtr, + (Tcl_NRPostProc *)pmPtr->postCallProc, pmPtr->clientData, NULL); + } + return TclNRInterpProcCore(interp, namePtr, 1, pmPtr->errProc); + +done: + return result; +} + +int +Itcl_InvokeProcedureMethod( + ClientData clientData, /* Pointer to some per-method context. */ + Tcl_Interp *interp, + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Arguments as actually seen. */ +{ + Tcl_Namespace *nsPtr; + Method *mPtr; + + mPtr = clientData; + if (mPtr->declaringClassPtr == NULL) { + /* that is the case for typemethods */ + nsPtr = mPtr->declaringObjectPtr->namespacePtr; + } else { + nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr; + } + + return Tcl_InvokeClassProcedureMethod(interp, mPtr->namePtr, nsPtr, + mPtr->clientData, objc, objv); +} + +static int +FreeProcedureMethod( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ProcedureMethod *pmPtr = data[0]; + ckfree(pmPtr); + return result; +} + +int +Itcl_InvokeEnsembleMethod( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, /* namespace to call the method in */ + Tcl_Obj *namePtr, /* name of the method */ + Tcl_Proc *procPtr, + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Arguments as actually seen. */ +{ + ProcedureMethod *pmPtr = ckalloc(sizeof(ProcedureMethod)); + + memset(pmPtr, 0, sizeof(ProcedureMethod)); + pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; + pmPtr->procPtr = (Proc *)procPtr; + pmPtr->flags = USE_DECLARER_NS; + + Tcl_NRAddCallback(interp, FreeProcedureMethod, pmPtr, NULL, NULL, NULL); + return Tcl_InvokeClassProcedureMethod(interp, namePtr, nsPtr, + pmPtr, objc, objv); +} + + +/* + * ---------------------------------------------------------------------- + * + * Itcl_PublicObjectCmd, Itcl_PrivateObjectCmd -- + * + * Main entry point for object invokations. The Public* and Private* + * wrapper functions are just thin wrappers around the main ObjectCmd + * function that does call chain creation, management and invokation. + * + * ---------------------------------------------------------------------- + */ + +int +Itcl_PublicObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + Tcl_Class clsPtr, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Object oPtr = (Tcl_Object)clientData; + int result; + + result = TclOOInvokeObject(interp, oPtr, clsPtr, PUBLIC_METHOD, + objc, objv); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Itcl_NewProcClassMethod -- + * + * Create a new procedure-like method for a class for Itcl. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Itcl_NewProcClassMethod( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Tcl_Class clsPtr, /* The class to modify. */ + TclOO_PreCallProc *preCallPtr, + TclOO_PostCallProc *postCallPtr, + ProcErrorProc *errProc, + ClientData clientData, + Tcl_Obj *nameObj, /* The name of the method, which may be NULL; + * if so, up to caller to manage storage + * (e.g., because it is a constructor or + * destructor). */ + Tcl_Obj *argsObj, /* The formal argument list for the method, + * which may be NULL; if so, it is equivalent + * to an empty list. */ + Tcl_Obj *bodyObj, /* The body of the method, which must not be + * NULL. */ + ClientData *clientData2) +{ + Tcl_Method result; + + result = TclOONewProcMethodEx(interp, clsPtr, preCallPtr, postCallPtr, + errProc, clientData, nameObj, argsObj, bodyObj, + PUBLIC_METHOD | USE_DECLARER_NS, clientData2); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Itcl_NewProcMethod -- + * + * Create a new procedure-like method for an object for Itcl. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Itcl_NewProcMethod( + Tcl_Interp *interp, /* The interpreter containing the object. */ + Tcl_Object oPtr, /* The object to modify. */ + TclOO_PreCallProc *preCallPtr, + TclOO_PostCallProc *postCallPtr, + ProcErrorProc *errProc, + ClientData clientData, + Tcl_Obj *nameObj, /* The name of the method, which must not be + * NULL. */ + Tcl_Obj *argsObj, /* The formal argument list for the method, + * which must not be NULL. */ + Tcl_Obj *bodyObj, /* The body of the method, which must not be + * NULL. */ + ClientData *clientData2) +{ + return TclOONewProcInstanceMethodEx(interp, oPtr, preCallPtr, postCallPtr, + errProc, clientData, nameObj, argsObj, bodyObj, + PUBLIC_METHOD | USE_DECLARER_NS, clientData2); +} + +/* + * ---------------------------------------------------------------------- + * + * Itcl_NewForwardClassMethod -- + * + * Create a new forwarded method for a class for Itcl. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Itcl_NewForwardClassMethod( + Tcl_Interp *interp, + Tcl_Class clsPtr, + int flags, + Tcl_Obj *nameObj, + Tcl_Obj *prefixObj) +{ + return (Tcl_Method)TclOONewForwardMethod(interp, (Class *)clsPtr, + flags, nameObj, prefixObj); +} + + +static Tcl_Obj * +Itcl_TclOOObjectName( + Tcl_Interp *interp, + Object *oPtr) +{ + Tcl_Obj *namePtr; + + if (oPtr->cachedNameObj) { + return oPtr->cachedNameObj; + } + namePtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->command, namePtr); + Tcl_IncrRefCount(namePtr); + oPtr->cachedNameObj = namePtr; + return namePtr; +} + +int +Itcl_SelfCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + CallContext *contextPtr; + + if (!Itcl_IsMethodCallFrame(interp)) { + Tcl_AppendResult(interp, TclGetString(objv[0]), + " may only be called from inside a method", NULL); + return TCL_ERROR; + } + + contextPtr = framePtr->clientData; + + if (objc == 1) { + Tcl_SetObjResult(interp, Itcl_TclOOObjectName(interp, contextPtr->oPtr)); + return TCL_OK; + } + return TCL_ERROR; +} + +int +Itcl_IsMethodCallFrame( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + return 0; + } + return 1; +} + +/* needed as work around for problem in Tcl 8.6.2 TclOO */ +void +Itcl_IncrObjectRefCount(Tcl_Object ptr) { + Object * oPtr = (Object *) ptr; + oPtr->refCount++; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.h b/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.h new file mode 100644 index 0000000..4f9df0a --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.h @@ -0,0 +1,34 @@ + +#ifndef _TCLINT +typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); +#endif + +#ifndef TCL_OO_INTERNAL_H +typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); +typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); +#endif + +MODULE_SCOPE int Itcl_NRRunCallbacks(Tcl_Interp *interp, void *rootPtr); +MODULE_SCOPE void * Itcl_GetCurrentCallbackPtr(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Method Itcl_NewProcClassMethod(Tcl_Interp *interp, Tcl_Class clsPtr, + TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, + ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, + Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ClientData *clientData2); +MODULE_SCOPE Tcl_Method Itcl_NewProcMethod(Tcl_Interp *interp, Tcl_Object oPtr, + TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, + ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, + Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ClientData *clientData2); +MODULE_SCOPE int Itcl_PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, + Tcl_Class clsPtr, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE Tcl_Method Itcl_NewForwardClassMethod(Tcl_Interp *interp, + Tcl_Class clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); +MODULE_SCOPE int Itcl_SelfCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int Itcl_IsMethodCallFrame(Tcl_Interp *interp); +MODULE_SCOPE int Itcl_InvokeEnsembleMethod(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + Tcl_Obj *namePtr, Tcl_Proc *procPtr, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int Itcl_InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE void Itcl_IncrObjectRefCount(Tcl_Object ptr); diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclBase.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclBase.c new file mode 100644 index 0000000..450074a --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclBase.c @@ -0,0 +1,838 @@ +/* + * itclBase.c -- + * + * This file contains the C-implemented startup part of an + * Itcl implemenatation + * + * Copyright (c) 2007 by Arnulf P. Wiedemann + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include <stdlib.h> +#include "itclInt.h" + +static Tcl_ObjCmdProc ItclFinishCmd; +static Tcl_ObjCmdProc ItclSetHullWindowName; +static Tcl_ObjCmdProc ItclCheckSetItclHull; + +#ifdef OBJ_REF_COUNT_DEBUG +static Tcl_ObjCmdProc ItclDumpRefCountInfo; +#endif + +#ifdef ITCL_PRESERVE_DEBUG +static Tcl_ObjCmdProc ItclDumpPreserveInfo; +#endif + +MODULE_SCOPE const ItclStubs itclStubs; + +static int Initialize(Tcl_Interp *interp); + +static const char initScript[] = +"namespace eval ::itcl {\n" +" proc _find_init {} {\n" +" global env tcl_library\n" +" variable library\n" +" variable patchLevel\n" +" rename _find_init {}\n" +" if {[info exists library]} {\n" +" lappend dirs $library\n" +" } else {\n" +" set dirs {}\n" +" if {[info exists env(ITCL_LIBRARY)]} {\n" +" lappend dirs $env(ITCL_LIBRARY)\n" +" }\n" +" lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n" +" set bindir [file dirname [info nameofexecutable]]\n" +" lappend dirs [file join . library]\n" +" lappend dirs [file join $bindir .. lib itcl$patchLevel]\n" +" lappend dirs [file join $bindir .. library]\n" +" lappend dirs [file join $bindir .. .. library]\n" +" lappend dirs [file join $bindir .. .. itcl library]\n" +" lappend dirs [file join $bindir .. .. .. itcl library]\n" +" lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n" +" # On *nix, check the directories in the tcl_pkgPath\n" +" # XXX JH - this looks unnecessary, maybe Darwin only?\n" +" if {[string equal $::tcl_platform(platform) \"unix\"]} {\n" +" foreach d $::tcl_pkgPath {\n" +" lappend dirs $d\n" +" lappend dirs [file join $d itcl$patchLevel]\n" +" }\n" +" }\n" +" }\n" +" foreach i $dirs {\n" +" set library $i\n" +" if {![catch {uplevel #0 [list source [file join $i itcl.tcl]]}]} {\n" +" set library $i\n" +" return\n" +" }\n" +" }\n" +" set msg \"Can't find a usable itcl.tcl in the following directories:\n\"\n" +" append msg \" $dirs\n\"\n" +" append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n" +" append msg \"If you know where the Itcl library directory was installed,\n\"\n" +" append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n" +" append msg \"to the library directory.\n\"\n" +" error $msg\n" +" }\n" +" _find_init\n" +"}"; + +/* + * The following script is used to initialize Itcl in a safe interpreter. + */ + +static const char safeInitScript[] = +"proc ::itcl::local {class name args} {\n" +" set ptr [uplevel [list $class $name] $args]\n" +" uplevel [list set itcl-local-$ptr $ptr]\n" +" set cmd [uplevel namespace which -command $ptr]\n" +" uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n" +" return $ptr\n" +"}"; + +static const char *clazzClassScript = +"::oo::class create ::itcl::clazz {\n" +" superclass ::oo::class\n" +" method unknown args {\n" +" ::tailcall ::itcl::parser::handleClass [::lindex [::info level 0] 0] [self] {*}$args\n" +" }\n" +" unexport create new unknown\n" +"}"; + +#define ITCL_IS_ENSEMBLE 0x1 + +typedef struct ItclCmdsInfo { + const char *name; + int flags; +} ItclCmdsInfo; +static ItclCmdsInfo itclCmds [] = { + { "::itcl::class", 0}, + { "::itcl::find", ITCL_IS_ENSEMBLE}, + { "::itcl::delete", ITCL_IS_ENSEMBLE}, + { "::itcl::is", ITCL_IS_ENSEMBLE}, + { "::itcl::filter", ITCL_IS_ENSEMBLE}, + { "::itcl::forward", ITCL_IS_ENSEMBLE}, + { "::itcl::import::stub", ITCL_IS_ENSEMBLE}, + { "::itcl::mixin", ITCL_IS_ENSEMBLE}, + { "::itcl::parser::delegate", ITCL_IS_ENSEMBLE}, + { "::itcl::type", 0}, + { "::itcl::widget", 0}, + { "::itcl::widgetadaptor", 0}, + { "::itcl::nwidget", 0}, + { "::itcl::addoption", 0}, + { "::itcl::addobjectoption", 0}, + { "::itcl::adddelegatedoption", 0}, + { "::itcl::adddelegatedmethod", 0}, + { "::itcl::addcomponent", 0}, + { "::itcl::setcomponent", 0}, + { "::itcl::extendedclass", 0}, + { "::itcl::genericclass", 0}, + { "::itcl::parser::delegate", ITCL_IS_ENSEMBLE}, + { NULL, 0}, +}; +#ifdef ITCL_DEBUG_C_INTERFACE +extern void RegisterDebugCFunctions( Tcl_Interp * interp); +#endif + +static const Tcl_ObjectMetadataType objMDT = { + TCL_OO_METADATA_VERSION_CURRENT, + "ItclObject", + ItclDeleteObjectMetadata, /* Not really used yet */ + NULL +}; + +static Tcl_MethodCallProc RootCallProc; + +const Tcl_MethodType itclRootMethodType = { + TCL_OO_METHOD_VERSION_CURRENT, + "itcl root method", + RootCallProc, + NULL, + NULL +}; + +static int +RootCallProc( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Object oPtr = Tcl_ObjectContextObject(context); + ItclObject *ioPtr = Tcl_ObjectGetMetadata(oPtr, &objMDT); + ItclRootMethodProc *proc = (ItclRootMethodProc *)clientData; + + return (*proc)(ioPtr, interp, objc, objv); +} + +/* + * ------------------------------------------------------------------------ + * FreeItclObjectInfo() + * + * called when an interp is deleted to free up memory + * + * ------------------------------------------------------------------------ + */ +static void +FreeItclObjectInfo( + ClientData clientData) +{ + ItclObjectInfo *infoPtr; + + infoPtr = (ItclObjectInfo *)clientData; + ItclFinishCmd(infoPtr, infoPtr->interp, 0, NULL); +} + +/* + * ------------------------------------------------------------------------ + * Initialize() + * + * that is the starting point when loading the library + * it initializes all internal stuff + * + * ------------------------------------------------------------------------ + */ + +#ifdef NEW_PROTO_RESOLVER +int ItclVarsAndCommandResolveInit(Tcl_Interp *interp); +#endif + +static int +Initialize ( + Tcl_Interp *interp) +{ + Tcl_Namespace *nsPtr; + Tcl_Namespace *itclNs; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + const char * ret; + char *res_option; + int opt; + int isNew; + Tcl_Object clazzObjectPtr, root; + Tcl_Obj *objPtr; + + if (Tcl_InitStubs(interp, "8.6", 0) == NULL) { + return TCL_ERROR; + } + + ret = TclOOInitializeStubs(interp, "1.0"); + if (ret == NULL) { + return TCL_ERROR; + } + + nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, NULL, NULL); + if (nsPtr == NULL) { + Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE); + } + + nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::internal::dicts", + NULL, NULL); + if (nsPtr == NULL) { + Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n", + ITCL_NAMESPACE); + } + + Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::finish", ItclFinishCmd, + NULL, NULL); + + /* for debugging only !!! */ +#ifdef OBJ_REF_COUNT_DEBUG + Tcl_CreateObjCommand(interp, + ITCL_NAMESPACE"::dumprefcountinfo", + ItclDumpRefCountInfo, NULL, NULL); +#endif + +#ifdef ITCL_PRESERVE_DEBUG + Tcl_CreateObjCommand(interp, + ITCL_NAMESPACE"::dumppreserveinfo", + ItclDumpPreserveInfo, NULL, NULL); +#endif + /* END for debugging only !!! */ + + /* + * Create the top-level data structure for tracking objects. + * Store this as "associated data" for easy access, but link + * it to the itcl namespace for ownership. + */ + infoPtr = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo)); + memset(infoPtr, 0, sizeof(ItclObjectInfo)); + infoPtr->interp = interp; + infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc( + sizeof(Tcl_ObjectMetadataType)); + infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT; + infoPtr->class_meta_type->name = "ItclClass"; + infoPtr->class_meta_type->deleteProc = ItclDeleteClassMetadata; + infoPtr->class_meta_type->cloneProc = NULL; + + infoPtr->object_meta_type = &objMDT; + + Tcl_InitHashTable(&infoPtr->objects, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoPtr->objectCmds, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoPtr->classes, TCL_ONE_WORD_KEYS); + Tcl_InitObjHashTable(&infoPtr->nameClasses); + Tcl_InitHashTable(&infoPtr->namespaceClasses, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoPtr->procMethods, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoPtr->instances, TCL_STRING_KEYS); + Tcl_InitHashTable(&infoPtr->frameContext, TCL_ONE_WORD_KEYS); + Tcl_InitObjHashTable(&infoPtr->classTypes); + infoPtr->ensembleInfo = (EnsembleInfo *)ckalloc(sizeof(EnsembleInfo)); + memset(infoPtr->ensembleInfo, 0, sizeof(EnsembleInfo)); + Tcl_InitHashTable(&infoPtr->ensembleInfo->ensembles, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoPtr->ensembleInfo->subEnsembles, TCL_ONE_WORD_KEYS); + infoPtr->ensembleInfo->numEnsembles = 0; + infoPtr->protection = ITCL_DEFAULT_PROTECT; + infoPtr->currClassFlags = 0; + infoPtr->buildingWidget = 0; + infoPtr->typeDestructorArgumentPtr = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(infoPtr->typeDestructorArgumentPtr); + infoPtr->lastIoPtr = NULL; + + Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classes", "", 0); + Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::objects", "", 0); + Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", "", 0); + Tcl_SetVar(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", "", 0); + Tcl_SetVar(interp, + ITCL_NAMESPACE"::internal::dicts::classComponents", "", 0); + Tcl_SetVar(interp, + ITCL_NAMESPACE"::internal::dicts::classVariables", "", 0); + Tcl_SetVar(interp, + ITCL_NAMESPACE"::internal::dicts::classFunctions", "", 0); + Tcl_SetVar(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", "", 0); + + hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, + (char *)Tcl_NewStringObj("class", -1), &isNew); + Tcl_SetHashValue(hPtr, ITCL_CLASS); + hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, + (char *)Tcl_NewStringObj("type", -1), &isNew); + Tcl_SetHashValue(hPtr, ITCL_TYPE); + hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, + (char *)Tcl_NewStringObj("widget", -1), &isNew); + Tcl_SetHashValue(hPtr, ITCL_WIDGET); + hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, + (char *)Tcl_NewStringObj("widgetadaptor", -1), &isNew); + Tcl_SetHashValue(hPtr, ITCL_WIDGETADAPTOR); + hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, + (char *)Tcl_NewStringObj("extendedclass", -1), &isNew); + Tcl_SetHashValue(hPtr, ITCL_ECLASS); + + res_option = getenv("ITCL_USE_OLD_RESOLVERS"); + if (res_option == NULL) { + opt = 1; + } else { + opt = atoi(res_option); + } + infoPtr->useOldResolvers = opt; + Itcl_InitStack(&infoPtr->clsStack); + + Tcl_SetAssocData(interp, ITCL_INTERP_DATA, + (Tcl_InterpDeleteProc*)FreeItclObjectInfo, (ClientData)infoPtr); + + Itcl_PreserveData((ClientData)infoPtr); + +#ifdef NEW_PROTO_RESOLVER + ItclVarsAndCommandResolveInit(interp); +#endif + + objPtr = Tcl_NewStringObj("::oo::class", -1); + root = Tcl_NewObjectInstance(interp, Tcl_GetObjectAsClass( + Tcl_GetObjectFromObj(interp, objPtr)), "::itcl::Root", + NULL, 0, NULL, 0); + Tcl_DecrRefCount(objPtr); + + Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), + Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType, + ItclUnknownGuts); + Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), + Tcl_NewStringObj("ItclConstructBase", -1), 0, + &itclRootMethodType, ItclConstructGuts); + Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), + Tcl_NewStringObj("info", -1), 1, + &itclRootMethodType, ItclInfoGuts); + + /* first create the Itcl base class as root of itcl classes */ + if (Tcl_EvalEx(interp, clazzClassScript, -1, 0) != TCL_OK) { + Tcl_Panic("cannot create Itcl root class ::itcl::clazz"); + } + clazzObjectPtr = Tcl_GetObjectFromObj(interp, Tcl_GetObjResult(interp)); + + + if (clazzObjectPtr == NULL) { + Tcl_AppendResult(interp, + "ITCL: cannot get Object for ::itcl::clazz for class \"", + "::itcl::clazz", "\"", NULL); + return TCL_ERROR; + } + + /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */ + if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) { + Itcl_IncrObjectRefCount(clazzObjectPtr); + } + + infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr); + + /* + * Initialize the ensemble package first, since we need this + * for other parts of [incr Tcl]. + */ + + if (Itcl_EnsembleInit(interp) != TCL_OK) { + return TCL_ERROR; + } + + Itcl_ParseInit(interp, infoPtr); + + /* + * Create "itcl::builtin" namespace for commands that + * are automatically built into class definitions. + */ + if (Itcl_BiInit(interp, infoPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Export all commands in the "itcl" namespace so that they + * can be imported with something like "namespace import itcl::*" + */ + itclNs = Tcl_FindNamespace(interp, "::itcl", (Tcl_Namespace*)NULL, + TCL_LEAVE_ERR_MSG); + + /* + * This was changed from a glob export (itcl::*) to explicit + * command exports, so that the itcl::is command can *not* be + * exported. This is done for concern that the itcl::is command + * imported might be confusing ("is"). + */ + if (!itclNs || + (Tcl_Export(interp, itclNs, "body", /* reset */ 1) != TCL_OK) || + (Tcl_Export(interp, itclNs, "class", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "code", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "configbody", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "delete", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "delete_helper", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "ensemble", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "filter", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "find", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "forward", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "local", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "mixin", 0) != TCL_OK) || + (Tcl_Export(interp, itclNs, "scope", 0) != TCL_OK)) { + return TCL_ERROR; + } + + Tcl_CreateObjCommand(interp, + ITCL_NAMESPACE"::internal::commands::sethullwindowname", + ItclSetHullWindowName, infoPtr, NULL); + Tcl_CreateObjCommand(interp, + ITCL_NAMESPACE"::internal::commands::checksetitclhull", + ItclCheckSetItclHull, infoPtr, NULL); + + /* + * Set up the variables containing version info. + */ + + Tcl_SetVar(interp, "::itcl::version", ITCL_VERSION, TCL_NAMESPACE_ONLY); + Tcl_SetVar(interp, "::itcl::patchLevel", ITCL_PATCH_LEVEL, + TCL_NAMESPACE_ONLY); + + +#ifdef ITCL_DEBUG_C_INTERFACE + RegisterDebugCFunctions(interp); +#endif + /* + * Package is now loaded. + */ + + Tcl_PkgProvideEx(interp, "Itcl", ITCL_PATCH_LEVEL, &itclStubs); + return Tcl_PkgProvideEx(interp, "itcl", ITCL_PATCH_LEVEL, &itclStubs); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_Init() + * + * Invoked whenever a new INTERPRETER is created to install the + * [incr Tcl] package. Usually invoked within Tcl_AppInit() at + * the start of execution. + * + * Creates the "::itcl" namespace and installs access commands for + * creating classes and querying info. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ + +int +Itcl_Init ( + Tcl_Interp *interp) +{ + if (Initialize(interp) != TCL_OK) { + return TCL_ERROR; + } + + return Tcl_EvalEx(interp, initScript, -1, 0); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_SafeInit() + * + * Invoked whenever a new SAFE INTERPRETER is created to install + * the [incr Tcl] package. + * + * Creates the "::itcl" namespace and installs access commands for + * creating classes and querying info. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ + +int +Itcl_SafeInit ( + Tcl_Interp *interp) +{ + if (Initialize(interp) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_EvalEx(interp, safeInitScript, -1, 0); +} + +/* + * ------------------------------------------------------------------------ + * ItclSetHullWindowName() + * + * + * ------------------------------------------------------------------------ + */ +static int +ItclSetHullWindowName( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr; + + infoPtr = (ItclObjectInfo *)clientData; + if (infoPtr->currIoPtr != NULL) { + infoPtr->currIoPtr->hullWindowNamePtr = objv[1]; + Tcl_IncrRefCount(infoPtr->currIoPtr->hullWindowNamePtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclCheckSetItclHull() + * + * + * ------------------------------------------------------------------------ + */ +static int +ItclCheckSetItclHull( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + ItclObject *ioPtr; + ItclVariable *ivPtr; + ItclObjectInfo *infoPtr; + const char *valueStr; + + if (objc < 3) { + Tcl_AppendResult(interp, "ItclCheckSetItclHull wrong # args should be ", + "<objectName> <value>", NULL); + return TCL_ERROR; + } + + /* + * This is an internal command, and is never called with an + * objectName value other than the empty list. Check that with + * an assertion so alternative handling can be removed. + */ + assert( strlen(Tcl_GetString(objv[1])) == 0); + infoPtr = (ItclObjectInfo *)clientData; + { + ioPtr = infoPtr->currIoPtr; + if (ioPtr == NULL) { + Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find object", + NULL); + return TCL_ERROR; + } + } + objPtr = Tcl_NewStringObj("itcl_hull", -1); + hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find itcl_hull", + " variable for object \"", Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + ivPtr = Tcl_GetHashValue(hPtr); + valueStr = Tcl_GetString(objv[2]); + if (strcmp(valueStr, "2") == 0) { + ivPtr->initted = 2; + } else { + if (strcmp(valueStr, "0") == 0) { + ivPtr->initted = 0; + } else { + Tcl_AppendResult(interp, "ItclCheckSetItclHull bad value \"", + valueStr, "\"", NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclFinishCmd() + * + * called when an interp is deleted to free up memory or called explicitly + * to check memory leaks + * + * ------------------------------------------------------------------------ + */ +static int +ItclFinishCmd( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch place; + Tcl_Namespace *nsPtr; + Tcl_Obj **newObjv; + Tcl_Obj *objPtr; + Tcl_Obj *ensObjPtr; + Tcl_Command cmdPtr; + Tcl_Obj *mapDict; + ItclObjectInfo *infoPtr; + ItclCmdsInfo *iciPtr; + int checkMemoryLeaks; + int i; + int result; + + ItclShowArgs(1, "ItclFinishCmd", objc, objv); + result = TCL_OK; + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + if (infoPtr == NULL) { + infoPtr = (ItclObjectInfo *)clientData; + } + checkMemoryLeaks = 0; + if (objc > 1) { + if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) { + /* if we have that option, the namespace of the Tcl ensembles + * is not teared down, so we have to simulate it here to + * have the correct reference counts for infoPtr->infoVars2Ptr + * infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr + */ + checkMemoryLeaks = 1; + } + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2); + newObjv[0] = Tcl_NewStringObj("my", -1);; + for (i = 0; ;i++) { + iciPtr = &itclCmds[i]; + if (iciPtr->name == NULL) { + break; + } + if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) { + result = Itcl_RenameCommand(interp, iciPtr->name, ""); + } else { + objPtr = Tcl_NewStringObj(iciPtr->name, -1); + newObjv[1] = objPtr; + Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv); + Tcl_DecrRefCount(objPtr); + } + iciPtr++; + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + + /* remove the unknow handler, to free the reference to the + * Tcl_Obj with the name of it */ + ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1); + cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG); + if (cmdPtr != NULL) { + Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL); + } + Tcl_DecrRefCount(ensObjPtr); + + while (1) { + hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place); + if (hPtr == NULL) { + break; + } + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&infoPtr->instances); + + while (1) { + hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place); + if (hPtr == NULL) { + break; + } + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&infoPtr->classTypes); + + Tcl_DeleteHashTable(&infoPtr->procMethods); + + Tcl_DeleteHashTable(&infoPtr->objectCmds); + Tcl_DeleteHashTable(&infoPtr->classes); + Tcl_DeleteHashTable(&infoPtr->nameClasses); + Tcl_DeleteHashTable(&infoPtr->namespaceClasses); + + nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + + mapDict = NULL; + ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1); + if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) { + Tcl_SetEnsembleUnknownHandler(NULL, + Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), + NULL); + } + Tcl_DecrRefCount(ensObjPtr); + + /* remove the vars entry from the info dict */ + /* and replace it by the original one */ + cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); + if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) { + Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict); + if (mapDict != NULL) { + + objPtr = Tcl_NewStringObj("vars", -1); + Tcl_DictObjRemove(interp, mapDict, objPtr); + Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr); + Tcl_DecrRefCount(objPtr); + Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict); + } + } + /* FIXME have to figure out why the refCount of + * ::itcl::builtin::Info + * and ::itcl::builtin::Info::vars and vars is 2 here !! */ + /* seems to be as the tclOO commands are not yet deleted ?? */ + Tcl_DecrRefCount(infoPtr->infoVars3Ptr); + Tcl_DecrRefCount(infoPtr->infoVars4Ptr); + if (checkMemoryLeaks) { + Tcl_DecrRefCount(infoPtr->infoVars3Ptr); + Tcl_DecrRefCount(infoPtr->infoVars4Ptr); + /* see comment above */ + } + + Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr); + + Tcl_EvalEx(infoPtr->interp, + "::oo::define ::itcl::clazz deletemethod unknown", -1, 0); + + /* first have to look for the remaining memory leaks, then remove the next ifdef */ + Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", ""); + + /* tear down ::itcl namespace (this includes ::itcl::parser namespace) */ + nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl", NULL, 0); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + + /* cleanup ensemble info */ + ItclFinishEnsemble(infoPtr); + + ckfree((char *)infoPtr->class_meta_type); + + Itcl_DeleteStack(&infoPtr->clsStack); + /* clean up list pool */ + Itcl_FinishList(); + + Itcl_ReleaseData((ClientData)infoPtr); + return result; +} + +#ifdef OBJ_REF_COUNT_DEBUG +void Tcl_DbDumpRefCountInfo(const char *fileName, int noDeleted); + + +/* + * ------------------------------------------------------------------------ + * ItclDumpRefCountInfo() + * + * debugging routine to check for memory leaks in use of Tcl_Obj's + * + * ------------------------------------------------------------------------ + */ +static int +ItclDumpRefCountInfo( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int noDeleted; + + noDeleted = 0; + if (objc > 1) { + if (strcmp(Tcl_GetString(objv[1]), "-nodeleted") == 0) { + noDeleted = 1; + } + } + ItclShowArgs(0, "ItclDumpRefCountInfo", objc, objv); + Tcl_DbDumpRefCountInfo(NULL, noDeleted); + return TCL_OK; +} +#endif + +#ifdef ITCL_PRESERVE_DEBUG +void Itcl_DbDumpPreserveInfo(const char *fileName); + + +/* + * ------------------------------------------------------------------------ + * ItclDumpPreserveInfo() + * + * debugging routine to check for memory leaks in use of Itcl_PreserveData + * and Itcl_ReleaseData + * + * ------------------------------------------------------------------------ + */ +static int +ItclDumpPreserveInfo( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclShowArgs(0, "ItclDumpPreserveInfo", objc, objv); + Itcl_DbDumpPreserveInfo(NULL); + return TCL_OK; +} +#endif diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclBuiltin.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclBuiltin.c new file mode 100644 index 0000000..e605762 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclBuiltin.c @@ -0,0 +1,3783 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle built-in class methods, including the + * "isa" method (to query hierarchy info) and the "info" method + * (to query class/object data). + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +static char initHullCmdsScript[] = +"namespace eval ::itcl {\n" +" proc _find_hull_init {} {\n" +" global env tcl_library\n" +" variable library\n" +" variable patchLevel\n" +" rename _find_hull_init {}\n" +" if {[info exists library]} {\n" +" lappend dirs $library\n" +" } else {\n" +" if {[catch {uplevel #0 source -rsrc itcl}] == 0} {\n" +" return\n" +" }\n" +" set dirs {}\n" +" if {[info exists env(ITCL_LIBRARY)]} {\n" +" lappend dirs $env(ITCL_LIBRARY)\n" +" }\n" +" lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n" +" set bindir [file dirname [info nameofexecutable]]\n" +" lappend dirs [file join . library]\n" +" lappend dirs [file join $bindir .. lib itcl$patchLevel]\n" +" lappend dirs [file join $bindir .. library]\n" +" lappend dirs [file join $bindir .. .. library]\n" +" lappend dirs [file join $bindir .. .. itcl library]\n" +" lappend dirs [file join $bindir .. .. .. itcl library]\n" +" lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n" +" # On MacOSX, check the directories in the tcl_pkgPath\n" +" if {[string equal $::tcl_platform(platform) \"unix\"] && " +" [string equal $::tcl_platform(os) \"Darwin\"]} {\n" +" foreach d $::tcl_pkgPath {\n" +" lappend dirs [file join $d itcl$patchLevel]\n" +" }\n" +" }\n" +" # On *nix, check the directories in the tcl_pkgPath\n" +" if {[string equal $::tcl_platform(platform) \"unix\"]} {\n" +" foreach d $::tcl_pkgPath {\n" +" lappend dirs $d\n" +" lappend dirs [file join $d itcl$patchLevel]\n" +" }\n" +" }\n" +" }\n" +" foreach i $dirs {\n" +" set library $i\n" +" set itclfile [file join $i itclHullCmds.tcl]\n" +" if {![catch {uplevel #0 [list source $itclfile]} msg]} {\n" +" return\n" +" }\n" +"puts stderr \"MSG!$msg!\"\n" +" }\n" +" set msg \"Can't find a usable itclHullCmds.tcl in the following directories:\n\"\n" +" append msg \" $dirs\n\"\n" +" append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n" +" append msg \"If you know where the Itcl library directory was installed,\n\"\n" +" append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n" +" append msg \"to the library directory.\n\"\n" +" error $msg\n" +" }\n" +" _find_hull_init\n" +"}"; + +static Tcl_ObjCmdProc Itcl_BiDestroyCmd; +static Tcl_ObjCmdProc ItclExtendedConfigure; +static Tcl_ObjCmdProc ItclExtendedCget; +static Tcl_ObjCmdProc ItclExtendedSetGet; +static Tcl_ObjCmdProc Itcl_BiCreateHullCmd; +static Tcl_ObjCmdProc Itcl_BiSetupComponentCmd; +static Tcl_ObjCmdProc Itcl_BiKeepComponentOptionCmd; +static Tcl_ObjCmdProc Itcl_BiIgnoreComponentOptionCmd; +static Tcl_ObjCmdProc Itcl_BiInitOptionsCmd; + +/* + * FORWARD DECLARATIONS + */ +static Tcl_Obj* ItclReportPublicOpt(Tcl_Interp *interp, + ItclVariable *ivPtr, ItclObject *contextIoPtr); + +static Tcl_ObjCmdProc ItclBiClassUnknownCmd; +/* + * Standard list of built-in methods for all objects. + */ +typedef struct BiMethod { + const char* name; /* method name */ + const char* usage; /* string describing usage */ + const char* registration;/* registration name for C proc */ + Tcl_ObjCmdProc *proc; /* implementation C proc */ + int flags; /* flag for which type of class to be used */ +} BiMethod; + +static const BiMethod BiMethodList[] = { + { "callinstance", + "<instancename>", + "@itcl-builtin-callinstance", + Itcl_BiCallInstanceCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "getinstancevar", + "<instancename>", + "@itcl-builtin-getinstancevar", + Itcl_BiGetInstanceVarCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "cget", + "-option", + "@itcl-builtin-cget", + Itcl_BiCgetCmd, + ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "configure", + "?-option? ?value -option value...?", + "@itcl-builtin-configure", + Itcl_BiConfigureCmd, + ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + {"createhull", + "widgetType widgetPath ?-class className? ?optionName value ...?", + "@itcl-builtin-createhull", + Itcl_BiCreateHullCmd, + ITCL_ECLASS + }, + { "destroy", + "", + "@itcl-builtin-destroy", + Itcl_BiDestroyCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "installcomponent", + "<componentName> using <classname> <winpath> ?-option value...?", + "@itcl-builtin-installcomponent", + Itcl_BiInstallComponentCmd, + ITCL_WIDGET + }, + { "itcl_hull", + "", + "@itcl-builtin-itcl_hull", + Itcl_BiItclHullCmd, + ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "isa", + "className", + "@itcl-builtin-isa", + Itcl_BiIsaCmd, + ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET + }, + {"itcl_initoptions", + "?optionName value ...?", + "@itcl-builtin-initoptions", + Itcl_BiInitOptionsCmd, + ITCL_ECLASS + }, + { "mymethod", + "", + "@itcl-builtin-mymethod", + Itcl_BiMyMethodCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "myvar", + "", + "@itcl-builtin-myvar", + Itcl_BiMyVarCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "myproc", + "", + "@itcl-builtin-myproc", + Itcl_BiMyProcCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "mytypemethod", + "", + "@itcl-builtin-mytypemethod", + Itcl_BiMyTypeMethodCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "mytypevar", + "", + "@itcl-builtin-mytypevar", + Itcl_BiMyTypeVarCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + { "setget", + "varName ?value?", + "@itcl-builtin-setget", + ItclExtendedSetGet, + ITCL_ECLASS + }, + { "unknown", + "", + "@itcl-builtin-classunknown", + ItclBiClassUnknownCmd, + ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR + }, + {"keepcomponentoption", + "componentName optionName ?optionName ...?", + "@itcl-builtin-keepcomponentoption", + Itcl_BiKeepComponentOptionCmd, + ITCL_ECLASS + }, + {"ignorecomponentoption", + "componentName optionName ?optionName ...?", + "@itcl-builtin-ignorecomponentoption", + Itcl_BiIgnoreComponentOptionCmd, + ITCL_ECLASS + }, + /* the next 3 are defined in library/itclHullCmds.tcl */ + {"addoptioncomponent", + "componentName optionName ?optionName ...?", + "@itcl-builtin-addoptioncomponent", + NULL, + ITCL_ECLASS + }, + {"ignoreoptioncomponent", + "componentName optionName ?optionName ...?", + "@itcl-builtin-ignoreoptioncomponent", + NULL, + ITCL_ECLASS + }, + {"renameoptioncomponent", + "componentName optionName ?optionName ...?", + "@itcl-builtin-renameoptioncomponent", + NULL, + ITCL_ECLASS + }, + {"setupcomponent", + "componentName using widgetType widgetPath ?optionName value ...?", + "@itcl-builtin-setupcomponent", + Itcl_BiSetupComponentCmd, + ITCL_ECLASS + }, +}; +static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod); + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInit() + * + * Creates a namespace full of built-in methods/procs for [incr Tcl] + * classes. This includes things like the "isa" method and "info" + * for querying class info. Usually invoked by Itcl_Init() when + * [incr Tcl] is first installed into an interpreter. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_BiInit( + Tcl_Interp *interp, /* current interpreter */ + ItclObjectInfo *infoPtr) +{ + Tcl_Namespace *itclBiNs; + Tcl_DString buffer; + Tcl_Obj *mapDict; + Tcl_Command infoCmd; + int result; + int i; + + /* + * "::itcl::builtin" commands. + * These commands are imported into each class + * just before the class definition is parsed. + */ + Tcl_DStringInit(&buffer); + for (i=0; i < BiMethodListLen; i++) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, "::itcl::builtin::", -1); + Tcl_DStringAppend(&buffer, BiMethodList[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + BiMethodList[i].proc, (ClientData)infoPtr, + (Tcl_CmdDeleteProc*)NULL); + } + Tcl_DStringFree(&buffer); + + Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd, + NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::builtin::classunknown", + ItclBiClassUnknownCmd, infoPtr, (Tcl_CmdDeleteProc*)NULL); + + ItclInfoInit(interp, infoPtr); + /* + * Export all commands in the built-in namespace so we can + * import them later on. + */ + itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin", + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if ((itclBiNs == NULL) || + Tcl_Export(interp, itclBiNs, "[a-z]*", /* resetListFirst */ 1) != TCL_OK) { + return TCL_ERROR; + } + /* + * Install into the master [info] ensemble. + */ + + infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); + if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + if (mapDict != NULL) { + infoPtr->infoVars4Ptr = + Tcl_NewStringObj("vars", -1); + Tcl_IncrRefCount(infoPtr->infoVars4Ptr); + result = Tcl_DictObjGet(interp, mapDict, infoPtr->infoVars4Ptr, + &infoPtr->infoVarsPtr); + if(result != TCL_OK) { + /* FIXME need code here!! */ + } + + infoPtr->infoVars3Ptr = + Tcl_NewStringObj("::itcl::builtin::Info::vars", -1); + /* FIXME see comment in itclBase.c ItclFinishCmd */ + Tcl_IncrRefCount(infoPtr->infoVars3Ptr); + Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, + infoPtr->infoVars3Ptr); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); + } + } + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InstallBiMethods() + * + * Invoked when a class is first created, just after the class + * definition has been parsed, to add definitions for built-in + * methods to the class. If a method already exists in the class + * with the same name as the built-in, then the built-in is skipped. + * Otherwise, a method definition for the built-in method is added. + * + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_InstallBiMethods( + Tcl_Interp *interp, /* current interpreter */ + ItclClass *iclsPtr) /* class definition to be updated */ +{ + int result = TCL_OK; + + int i; + ItclHierIter hier; + ItclClass *superPtr; + + /* + * Scan through all of the built-in methods and see if + * that method already exists in the class. If not, add + * it in. + * + * TRICKY NOTE: The virtual tables haven't been built yet, + * so look for existing methods the hard way--by scanning + * through all classes. + */ + Tcl_Obj *objPtr = Tcl_NewStringObj("", 0); + for (i=0; i < BiMethodListLen; i++) { + Tcl_HashEntry *hPtr = NULL; + + Itcl_InitHierIter(&hier, iclsPtr); + Tcl_SetStringObj(objPtr, BiMethodList[i].name, -1); + superPtr = Itcl_AdvanceHierIter(&hier); + while (superPtr) { + hPtr = Tcl_FindHashEntry(&superPtr->functions, (char *)objPtr); + if (hPtr) { + break; + } + superPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + if (!hPtr) { + if (iclsPtr->flags & BiMethodList[i].flags) { + result = Itcl_CreateMethod(interp, iclsPtr, + Tcl_NewStringObj(BiMethodList[i].name, -1), + BiMethodList[i].usage, BiMethodList[i].registration); + + if (result != TCL_OK) { + break; + } + } + } + } + + /* + * Every Itcl class gets an info method installed so that each has + * a proper context for the subcommands to do their context senstive + * work. + */ + + if (result == TCL_OK + && (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + result = Itcl_CreateMethod(interp, iclsPtr, + Tcl_NewStringObj("info", -1), NULL, "@itcl-builtin-info"); + } + + Tcl_DecrRefCount(objPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiIsaCmd() + * + * Invoked whenever the user issues the "isa" method for an object. + * Handles the following syntax: + * + * <objName> isa <className> + * + * Checks to see if the object has the given <className> anywhere + * in its heritage. Returns 1 if so, and 0 otherwise. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiIsaCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *iclsPtr; + const char *token; + + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be \"object isa className\"", + (char*)NULL); + return TCL_ERROR; + } + if (objc != 2) { + token = Tcl_GetString(objv[0]); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"object ", token, " className\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Look for the requested class. If it is not found, then + * try to autoload it. If it absolutely cannot be found, + * signal an error. + */ + token = Tcl_GetString(objv[1]); + iclsPtr = Itcl_FindClass(interp, token, /* autoload */ 1); + if (iclsPtr == NULL) { + return TCL_ERROR; + } + + if (Itcl_ObjectIsa(contextIoPtr, iclsPtr)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiConfigureCmd() + * + * Invoked whenever the user issues the "configure" method for an object. + * Handles the following syntax: + * + * <objName> configure ?-<option>? ?<value> -<option> <value>...? + * + * Allows access to public variables as if they were configuration + * options. With no arguments, this command returns the current + * list of public variable options. If -<option> is specified, + * this returns the information for just one option: + * + * -<optionName> <initVal> <currentVal> + * + * Otherwise, the list of arguments is parsed, and values are + * assigned to the various public variable options. When each + * option changes, a big of "config" code associated with the option + * is executed, to bring the object up to date. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiConfigureCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_DString buffer; + Tcl_DString buffer2; + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + Tcl_Namespace *saveNsPtr; + Tcl_Obj * const *unparsedObjv; + ItclClass *iclsPtr; + ItclVariable *ivPtr; + ItclVarLookup *vlookup; + ItclMemberCode *mcode; + ItclHierIter hier; + ItclObjectInfo *infoPtr; + const char *lastval; + const char *token; + char *varName; + int i; + int unparsedObjc; + int result; + + ItclShowArgs(1, "Itcl_BiConfigureCmd", objc, objv); + vlookup = NULL; + token = NULL; + hPtr = NULL; + unparsedObjc = objc; + unparsedObjv = objv; + Tcl_DStringInit(&buffer); + Tcl_DStringInit(&buffer2); + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be ", + "\"object configure ?-option? ?value -option value...?\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * BE CAREFUL: work in the virtual scope! + */ + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + infoPtr = contextIclsPtr->infoPtr; + if (!(contextIclsPtr->flags & ITCL_CLASS)) { + /* first check if it is an option */ + if (objc > 1) { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->options, + (char *) objv[1]); + } + result = ItclExtendedConfigure(contextIclsPtr, interp, objc, objv); + if (result != TCL_CONTINUE) { + return result; + } + if (infoPtr->unparsedObjc > 0) { + unparsedObjc = infoPtr->unparsedObjc; + unparsedObjv = infoPtr->unparsedObjv; + } else { + unparsedObjc = objc; + } + } + /* + * HANDLE: configure + */ + if (unparsedObjc == 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place); + while (hPtr) { + ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); + if (ivPtr->protection == ITCL_PUBLIC) { + objPtr = ItclReportPublicOpt(interp, ivPtr, contextIoPtr); + + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } else { + + /* + * HANDLE: configure -option + */ + if (unparsedObjc == 2) { + token = Tcl_GetStringFromObj(unparsedObjv[1], (int*)NULL); + if (*token != '-') { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be ", + "\"object configure ?-option? ?value -option value...?\"", + (char*)NULL); + return TCL_ERROR; + } + + vlookup = NULL; + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token+1); + if (hPtr) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + + if (vlookup->ivPtr->protection != ITCL_PUBLIC) { + vlookup = NULL; + } + } + if (!vlookup) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown option \"", token, "\"", + (char*)NULL); + return TCL_ERROR; + } + resultPtr = ItclReportPublicOpt(interp, + vlookup->ivPtr, contextIoPtr); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } + + /* + * HANDLE: configure -option value -option value... + * + * Be careful to work in the virtual scope. If this "configure" + * method was defined in a base class, the current namespace + * (from Itcl_ExecMethod()) will be that base class. Activate + * the derived class namespace here, so that instance variables + * are accessed properly. + */ + result = TCL_OK; + + for (i=1; i < unparsedObjc; i+=2) { + if (i+1 >= unparsedObjc) { + Tcl_AppendResult(interp, "need option value pair", NULL); + result = TCL_ERROR; + goto configureDone; + } + vlookup = NULL; + token = Tcl_GetString(unparsedObjv[i]); + if (*token == '-') { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token+1); + if (hPtr == NULL) { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token); + } + if (hPtr) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + } + } + + if (!vlookup || (vlookup->ivPtr->protection != ITCL_PUBLIC)) { + Tcl_AppendResult(interp, "unknown option \"", token, "\"", + (char*)NULL); + result = TCL_ERROR; + goto configureDone; + } + if (i == unparsedObjc-1) { + Tcl_AppendResult(interp, "value for \"", token, "\" missing", + (char*)NULL); + result = TCL_ERROR; + goto configureDone; + } + + ivPtr = vlookup->ivPtr; + Tcl_DStringSetLength(&buffer2, 0); + if (!(ivPtr->flags & ITCL_COMMON)) { + Tcl_DStringAppend(&buffer2, + Tcl_GetString(contextIoPtr->varNsNamePtr), -1); + } + Tcl_DStringAppend(&buffer2, + Tcl_GetString(ivPtr->iclsPtr->fullNamePtr), -1); + Tcl_DStringAppend(&buffer2, "::", 2); + Tcl_DStringAppend(&buffer2, + Tcl_GetString(ivPtr->namePtr), -1); + varName = Tcl_DStringValue(&buffer2); + lastval = Tcl_GetVar2(interp, varName, (char*)NULL, 0); + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1); + + token = Tcl_GetString(unparsedObjv[i+1]); + if (Tcl_SetVar2(interp, varName, (char*)NULL, token, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (error in configuration of public variable \"%s\")", + Tcl_GetString(ivPtr->fullNamePtr))); + result = TCL_ERROR; + goto configureDone; + } + + /* + * If this variable has some "config" code, invoke it now. + * + * TRICKY NOTE: Be careful to evaluate the code one level + * up in the call stack, so that it's executed in the + * calling context, and not in the context that we've + * set up for public variable access. + */ + mcode = ivPtr->codePtr; + if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { + if (!ivPtr->iclsPtr->infoPtr->useOldResolvers) { + Itcl_SetCallFrameResolver(interp, contextIoPtr->resolvePtr); + } + saveNsPtr = Tcl_GetCurrentNamespace(interp); + Itcl_SetCallFrameNamespace(interp, ivPtr->iclsPtr->nsPtr); + result = Tcl_EvalObjEx(interp, mcode->bodyPtr, 0); + Itcl_SetCallFrameNamespace(interp, saveNsPtr); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } else { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (error in configuration of public variable \"%s\")", + Tcl_GetString(ivPtr->fullNamePtr))); + Tcl_SetVar2(interp, varName,(char*)NULL, + Tcl_DStringValue(&buffer), 0); + + goto configureDone; + } + } + } + +configureDone: + if (infoPtr->unparsedObjc > 0) { + ckfree ((char *)infoPtr->unparsedObjv); + infoPtr->unparsedObjv = NULL; + infoPtr->unparsedObjc = 0; + } + Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&buffer); + + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiCgetCmd() + * + * Invoked whenever the user issues the "cget" method for an object. + * Handles the following syntax: + * + * <objName> cget -<option> + * + * Allows access to public variables as if they were configuration + * options. Mimics the behavior of the usual "cget" method for + * Tk widgets. Returns the current value of the public variable + * with name <option>. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiCgetCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + const char *name; + const char *val; + int result; + + ItclShowArgs(1,"Itcl_BiCgetCmd", objc, objv); + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if ((contextIoPtr == NULL) || objc != 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be \"object cget -option\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * BE CAREFUL: work in the virtual scope! + */ + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + if (!(contextIclsPtr->flags & ITCL_CLASS)) { + result = ItclExtendedCget(contextIclsPtr, interp, objc, objv); + if (result != TCL_CONTINUE) { + return result; + } + } + name = Tcl_GetString(objv[1]); + + vlookup = NULL; + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, name+1); + if (hPtr) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + } + + if ((vlookup == NULL) || (vlookup->ivPtr->protection != ITCL_PUBLIC)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown option \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + val = Itcl_GetInstanceVar(interp, + Tcl_GetString(vlookup->ivPtr->namePtr), + contextIoPtr, vlookup->ivPtr->iclsPtr); + + if (val) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1)); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclReportPublicOpt() + * + * Returns information about a public variable formatted as a + * configuration option: + * + * -<varName> <initVal> <currentVal> + * + * Used by Itcl_BiConfigureCmd() to report configuration options. + * Returns a Tcl_Obj containing the information. + * ------------------------------------------------------------------------ + */ +static Tcl_Obj* +ItclReportPublicOpt( + Tcl_Interp *interp, /* interpreter containing the object */ + ItclVariable *ivPtr, /* public variable to be reported */ + ItclObject *contextIoPtr) /* object containing this variable */ +{ + const char *val; + ItclClass *iclsPtr; + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + Tcl_DString optName; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + /* + * Determine how the option name should be reported. + * If the simple name can be used to find it in the virtual + * data table, then use the simple name. Otherwise, this + * is a shadowed variable; use the full name. + */ + Tcl_DStringInit(&optName); + Tcl_DStringAppend(&optName, "-", -1); + + iclsPtr = (ItclClass*)contextIoPtr->iclsPtr; + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, + Tcl_GetString(ivPtr->fullNamePtr)); + assert(hPtr != NULL); + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + Tcl_DStringAppend(&optName, vlookup->leastQualName, -1); + + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_DStringFree(&optName); + + + if (ivPtr->init) { + objPtr = ivPtr->init; + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + + val = Itcl_GetInstanceVar(interp, Tcl_GetString(ivPtr->namePtr), + contextIoPtr, ivPtr->iclsPtr); + + if (val) { + objPtr = Tcl_NewStringObj((const char *)val, -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + + return listPtr; +} + +/* + * ------------------------------------------------------------------------ + * ItclReportOption() + * + * Returns information about an option formatted as a + * configuration option: + * + * <optionName> <initVal> <currentVal> + * + * Used by ItclExtendedConfigure() to report configuration options. + * Returns a Tcl_Obj containing the information. + * ------------------------------------------------------------------------ + */ +static Tcl_Obj* +ItclReportOption( + Tcl_Interp *interp, /* interpreter containing the object */ + ItclOption *ioptPtr, /* option to be reported */ + ItclObject *contextIoPtr) /* object containing this variable */ +{ + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + ItclDelegatedOption *idoPtr; + const char *val; + + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + idoPtr = ioptPtr->iclsPtr->infoPtr->currIdoPtr; + if (idoPtr != NULL) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, idoPtr->namePtr); + if (idoPtr->resourceNamePtr == NULL) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_NewStringObj("", -1)); + /* FIXME possible memory leak */ + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + idoPtr->resourceNamePtr); + } + if (idoPtr->classNamePtr == NULL) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_NewStringObj("", -1)); + /* FIXME possible memory leak */ + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + idoPtr->classNamePtr); + } + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, ioptPtr->namePtr); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + ioptPtr->resourceNamePtr); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + ioptPtr->classNamePtr); + } + if (ioptPtr->defaultValuePtr) { + objPtr = ioptPtr->defaultValuePtr; + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + val = ItclGetInstanceVar(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), + contextIoPtr, ioptPtr->iclsPtr); + if (val) { + objPtr = Tcl_NewStringObj((const char *)val, -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + return listPtr; +} + + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiChainCmd() + * + * Invoked to handle the "chain" command, to access the version of + * a method or proc that exists in a base class. Handles the + * following syntax: + * + * chain ?<arg> <arg>...? + * + * Looks up the inheritance hierarchy for another implementation + * of the method/proc that is currently executing. If another + * implementation is found, it is invoked with the specified + * <arg> arguments. If it is not found, this command does nothing. + * This allows a base class method to be called out in a generic way, + * so the code will not have to change if the base class changes. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +NRBiChainCmd( + ClientData dummy, /* not used */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result = TCL_OK; + + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + const char *cmd; + char *cmd1; + const char *head; + ItclClass *iclsPtr; + ItclHierIter hier; + Tcl_HashEntry *hPtr; + ItclMemberFunc *imPtr; + Tcl_DString buffer; + Tcl_Obj *cmdlinePtr; + Tcl_Obj **newobjv; + Tcl_Obj * const *cObjv; + int cObjc; + int idx; + Tcl_Obj *objPtr; + + ItclShowArgs(1, "Itcl_BiChainCmd", objc, objv); + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot chain functions outside of a class context", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Try to get the command name from the current call frame. + * If it cannot be determined, do nothing. Otherwise, trim + * off any leading path names. + */ + cObjv = Itcl_GetCallVarFrameObjv(interp); + if (cObjv == NULL) { + return TCL_OK; + } + cObjc = Itcl_GetCallVarFrameObjc(interp); + + if ((Itcl_GetCallFrameClientData(interp) == NULL) || (objc == 1)) { + /* that has been a direct call, so no object in front !! */ + if (objc == 1 && cObjc >= 2) { + idx = 1; + } else { + idx = 0; + } + } else { + idx = 1; + } + cmd1 = (char *)ckalloc(strlen(Tcl_GetString(cObjv[idx]))+1); + strcpy(cmd1, Tcl_GetString(cObjv[idx])); + Itcl_ParseNamespPath(cmd1, &buffer, &head, &cmd); + + /* + * Look for the specified command in one of the base classes. + * If we have an object context, then start from the most-specific + * class and walk up the hierarchy to the current context. If + * there is multiple inheritance, having the entire inheritance + * hierarchy will allow us to jump over to another branch of + * the inheritance tree. + * + * If there is no object context, just start with the current + * class context. + */ + if (contextIoPtr != NULL) { + Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + if (iclsPtr == contextIclsPtr) { + break; + } + } + } else { + Itcl_InitHierIter(&hier, contextIclsPtr); + Itcl_AdvanceHierIter(&hier); /* skip the current class */ + } + + /* + * Now search up the class hierarchy for the next implementation. + * If found, execute it. Otherwise, do nothing. + */ + objPtr = Tcl_NewStringObj(cmd, -1); + ckfree(cmd1); + Tcl_IncrRefCount(objPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr); + if (hPtr) { + int my_objc; + imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); + + /* + * NOTE: Avoid the usual "virtual" behavior of + * methods by passing the full name as + * the command argument. + */ + + cmdlinePtr = Itcl_CreateArgs(interp, + Tcl_GetString(imPtr->fullNamePtr), objc-1, objv+1); + + (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &my_objc, &newobjv); + + if (imPtr->flags & ITCL_CONSTRUCTOR) { + contextIoPtr = imPtr->iclsPtr->infoPtr->currIoPtr; + } + ItclShowArgs(1, "___chain", objc-1, newobjv+1); + result = Itcl_EvalMemberCode(interp, imPtr, contextIoPtr, + my_objc-1, newobjv+1); + Tcl_DecrRefCount(cmdlinePtr); + break; + } + } + Tcl_DecrRefCount(objPtr); + + Tcl_DStringFree(&buffer); + Itcl_DeleteHierIter(&hier); + return result; +} +/* ARGSUSED */ +int +Itcl_BiChainCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRBiChainCmd, clientData, objc, objv); +} + +static int +CallCreateObject( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_CallFrame frame; + Tcl_Namespace *nsPtr; + ItclClass *iclsPtr = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj *const *objv = data[2]; + + if (result != TCL_OK) { + return result; + } + nsPtr = Itcl_GetUplevelNamespace(interp, 1); + if (Itcl_PushCallFrame(interp, &frame, nsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + return TCL_ERROR; + } + result = ItclClassCreateObject(iclsPtr->infoPtr, interp, objc, objv); + Itcl_PopCallFrame(interp); + Tcl_DecrRefCount(objv[2]); + Tcl_DecrRefCount(objv[1]); + Tcl_DecrRefCount(objv[0]); + return result; +} + +static int +PrepareCreateObject( + Tcl_Interp *interp, + ItclClass *iclsPtr, + int objc, + Tcl_Obj * const *objv) +{ + Tcl_HashEntry *hPtr; + Tcl_Obj **newObjv; + void *callbackPtr; + const char *funcName; + int result; + int offset; + + offset = 1; + funcName = Tcl_GetString(objv[1]); + if (strcmp(funcName, "itcl_hull") == 0) { + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR ", + "cannot find itcl_hull method", NULL); + return TCL_ERROR; + } + result = Itcl_ExecProc(Tcl_GetHashValue(hPtr), interp, objc, objv); + return result; + } + if (strcmp(funcName, "create") == 0) { + /* allow typeClassName create objectName */ + offset++; + } else { + /* allow typeClassName objectName */ + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc+3-offset)); + newObjv[0] = objv[0]; + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = iclsPtr->namePtr; + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); + Tcl_IncrRefCount(newObjv[2]); + memcpy(newObjv+3, objv+offset, (objc-offset) * sizeof(Tcl_Obj *)); + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + ItclShowArgs(1, "CREATE", objc+3-offset, newObjv); + Tcl_NRAddCallback(interp, CallCreateObject, iclsPtr, + INT2PTR(objc+3-offset), (ClientData)newObjv, NULL); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + if (result != TCL_OK) { + if (iclsPtr->infoPtr->currIoPtr != NULL) { + /* we are in a constructor call */ + if (iclsPtr->infoPtr->currIoPtr->hadConstructorError == 0) { + iclsPtr->infoPtr->currIoPtr->hadConstructorError = 1; + } + } + } + ckfree((char *)newObjv); + return result; +} +/* + * ------------------------------------------------------------------------ + * ItclBiClassUnknownCmd() + * + * Invoked to handle the "classunknown" command + * this is called whenever an object is called with an unknown method/proc + * following syntax: + * + * classunknown <object> <methodname> ?<arg> <arg>...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclBiClassUnknownCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashEntry *hPtr2; + Tcl_Obj **newObjv; + Tcl_Obj **lObjv; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + Tcl_Obj *resPtr; + Tcl_DString buffer; + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + ItclComponent *icPtr; + ItclDelegatedFunction *idmPtr; + ItclDelegatedFunction *idmPtr2; + ItclDelegatedFunction *starIdmPtr; + const char *resStr; + const char *val; + const char *funcName; + int lObjc; + int result; + int offset; + int useComponent; + int isItclHull; + int isTypeMethod; + int isStar; + int isNew; + int idx; + + ItclShowArgs(1, "ItclBiClassUnknownCmd", objc, objv); + listPtr = NULL; + useComponent = 1; + isStar = 0; + isTypeMethod = 0; + isItclHull = 0; + starIdmPtr = NULL; + infoPtr = (ItclObjectInfo *)clientData; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, + (char *)Tcl_GetCurrentNamespace(interp)); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR: ItclBiClassUnknownCmd ", + "cannot find class\n", NULL); + return TCL_ERROR; + } + iclsPtr = Tcl_GetHashValue(hPtr); + funcName = Tcl_GetString(objv[1]); + if (strcmp(funcName, "create") == 0) { + /* check if we have a user method create. If not, it is the builtin + * create method and we don't need to check for delegation + * and components with ITCL_COMPONENT_INHERIT + */ + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]); + if (hPtr == NULL) { + return PrepareCreateObject(interp, iclsPtr, objc, objv); + } + } + if (strcmp(funcName, "itcl_hull") == 0) { + isItclHull = 1; + } + if (!isItclHull) { + FOREACH_HASH_VALUE(icPtr, &iclsPtr->components) { + if (icPtr->flags & ITCL_COMPONENT_INHERIT) { + val = Tcl_GetVar2(interp, Tcl_GetString(icPtr->namePtr), + NULL, 0); + if ((val != NULL) && (strlen(val) > 0)) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *) * (objc-1)); + ItclShowArgs(1, "UK EVAL1", objc, newObjv); + result = Tcl_EvalObjv(interp, objc, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + return result; + } + } + } + } + /* from a class object only typemethods can be called directly + * if delegated, so check for that, otherwise create an object + * for ITCL_ECLASS we allow calling too + */ + hPtr = NULL; + isTypeMethod = 0; + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) { + if (idmPtr->flags & ITCL_TYPE_METHOD) { + isTypeMethod = 1; + } + if (iclsPtr->flags & ITCL_ECLASS) { + isTypeMethod = 1; + } + break; + } + if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) { + if (idmPtr->flags & ITCL_TYPE_METHOD) { + isTypeMethod = 1; + } + starIdmPtr = idmPtr; + break; + } + } + idmPtr = NULL; + if (isTypeMethod) { + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]); + if (hPtr == NULL) { + objPtr = Tcl_NewStringObj("*", -1); + Tcl_IncrRefCount(objPtr); + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, + (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + idmPtr = Tcl_GetHashValue(hPtr); + isStar = 1; + } + } + if (isStar) { + /* check if the function is in the exceptions */ + hPtr2 = Tcl_FindHashEntry(&starIdmPtr->exceptions, (char *)objv[1]); + if (hPtr2 != NULL) { + const char *sep = ""; + objPtr = Tcl_NewStringObj("unknown subcommand \"", -1); + Tcl_AppendToObj(objPtr, funcName, -1); + Tcl_AppendToObj(objPtr, "\": must be ", -1); + FOREACH_HASH_VALUE(idmPtr, + &iclsPtr->delegatedFunctions) { + funcName = Tcl_GetString(idmPtr->namePtr); + if (strcmp(funcName, "*") != 0) { + if (strlen(sep) > 0) { + Tcl_AppendToObj(objPtr, sep, -1); + } + Tcl_AppendToObj(objPtr, funcName, -1); + sep = " or "; + } + } + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + } + if (hPtr != NULL) { + idmPtr = Tcl_GetHashValue(hPtr); + val = NULL; + if (idmPtr->icPtr != NULL) { + if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) { + val = Tcl_GetVar2(interp, + Tcl_GetString(idmPtr->icPtr->namePtr), NULL, 0); + } else { + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + contextIclsPtr = NULL; + contextIoPtr = NULL; + Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr); + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetString(contextIoPtr->varNsNamePtr), -1); + Tcl_DStringAppend(&buffer, + Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), + -1); + val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), + NULL, 0); + Tcl_DStringFree(&buffer); + } + if (val == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR: ", + "ItclBiClassUnknownCmd contents ", + "of component == NULL\n", NULL); + return TCL_ERROR; + } + } + offset = 1; + lObjc = 0; + if ((idmPtr->asPtr != NULL) || (idmPtr->usingPtr != NULL)) { + offset++; + listPtr = Tcl_NewListObj(0, NULL); + result = ExpandDelegateAs(interp, NULL, iclsPtr, + idmPtr, funcName, listPtr); + if (result != TCL_OK) { + return result; + } + result = Tcl_ListObjGetElements(interp, listPtr, + &lObjc, &lObjv); + if (result != TCL_OK) { + Tcl_DecrRefCount(listPtr); + return result; + } + if (idmPtr->usingPtr != NULL) { + useComponent = 0; + } + } + if (useComponent) { + if ((val == NULL) || (strlen(val) == 0)) { + Tcl_AppendResult(interp, "component \"", + Tcl_GetString(idmPtr->icPtr->namePtr), + "\" is not initialized", NULL); + return TCL_ERROR; + } + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * + (objc + lObjc - offset + useComponent)); + if (useComponent) { + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + } + for (idx = 0; idx < lObjc; idx++) { + newObjv[useComponent+idx] = lObjv[idx]; + } + if (objc-offset > 0) { + memcpy(newObjv+useComponent+lObjc, objv+offset, + sizeof(Tcl_Obj *) * (objc-offset)); + } + ItclShowArgs(1, "OBJ UK EVAL", objc+lObjc-offset+useComponent, + newObjv); + result = Tcl_EvalObjv(interp, + objc+lObjc-offset+useComponent, newObjv, 0); + if (isStar && (result == TCL_OK)) { + if (Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, + (char *)newObjv[1]) == NULL) { + result = ItclCreateDelegatedFunction(interp, iclsPtr, + newObjv[1], idmPtr->icPtr, NULL, NULL, + NULL, &idmPtr2); + if (result == TCL_OK) { + if (isTypeMethod) { + idmPtr2->flags |= ITCL_TYPE_METHOD; + } else { + idmPtr2->flags |= ITCL_METHOD; + } + hPtr2 = Tcl_CreateHashEntry( + &iclsPtr->delegatedFunctions, + (char *)newObjv[1], &isNew); + Tcl_SetHashValue(hPtr2, idmPtr2); + } + } + } + if (useComponent) { + Tcl_DecrRefCount(newObjv[0]); + } + ckfree((char *)newObjv); + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + if (result == TCL_ERROR) { + resStr = Tcl_GetStringResult(interp); + /* FIXME ugly hack at the moment !! */ + if (strncmp(resStr, "wrong # args: should be ", 24) == 0) { + resPtr = Tcl_NewStringObj("", -1); + Tcl_AppendToObj(resPtr, resStr, 25); + resStr += 25; + Tcl_AppendToObj(resPtr, Tcl_GetString(iclsPtr->namePtr), + -1); + resStr += strlen(val); + Tcl_AppendToObj(resPtr, resStr, -1); + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, resPtr); + } + } + return result; + } + } + return PrepareCreateObject(interp, iclsPtr, objc, objv); +} + +/* + * ------------------------------------------------------------------------ + * ItclUnknownGuts() + * + * The unknown method handler of the itcl::Root class -- all Itcl + * objects land here when they cannot find a method. + * + * ------------------------------------------------------------------------ + */ + +int +ItclUnknownGuts( + ItclObject *ioPtr, /* The ItclObject seeking method */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashEntry *hPtr2; + Tcl_Obj **newObjv; + Tcl_Obj **lObjv; + Tcl_Obj *listPtr = NULL; + Tcl_Obj *objPtr; + Tcl_Obj *resPtr; + Tcl_DString buffer; + ItclClass *iclsPtr; + ItclComponent *icPtr; + ItclDelegatedFunction *idmPtr; + ItclDelegatedFunction *idmPtr2; + const char *resStr; + const char *val; + const char *funcName; + int lObjc; + int result; + int offset; + int useComponent; + int found; + int isItclHull; + int isStar; + int isTypeMethod; + int isNew; + int idx; + + if (objc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be one of...", + (char*)NULL); + ItclReportObjectUsage(interp, ioPtr, NULL, NULL); + return TCL_ERROR; + } + iclsPtr = ioPtr->iclsPtr; + lObjc = 0; + offset = 1; + isStar = 0; + found = 0; + isItclHull = 0; + useComponent = 1; + result = TCL_OK; + idmPtr = NULL; + funcName = Tcl_GetString(objv[1]); + if (strcmp(funcName, "itcl_hull") == 0) { + isItclHull = 1; + } + icPtr = NULL; + if (!isItclHull) { + FOREACH_HASH_VALUE(icPtr, &ioPtr->objectComponents) { + if (icPtr->flags & ITCL_COMPONENT_INHERIT) { + val = Itcl_GetInstanceVar(interp, + Tcl_GetString(icPtr->namePtr), ioPtr, + icPtr->ivPtr->iclsPtr); + if ((val != NULL) && (strlen(val) > 0)) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * + (objc)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *) * (objc-1)); + result = Tcl_EvalObjv(interp, objc, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + return result; + } + } + } + } + isTypeMethod = 0; + found = 0; + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) { + if (idmPtr->flags & ITCL_TYPE_METHOD) { + isTypeMethod = 1; + } + found = 1; + break; + } + if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) { + if (idmPtr->flags & ITCL_TYPE_METHOD) { + isTypeMethod = 1; + } + found = 1; + break; + } + } + if (! found) { + idmPtr = NULL; + } + iclsPtr = ioPtr->iclsPtr; + found = 0; + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]); + if (hPtr == NULL) { + objPtr = Tcl_NewStringObj("*", -1); + Tcl_IncrRefCount(objPtr); + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, + (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + idmPtr = Tcl_GetHashValue(hPtr); + isStar = 1; + } + } else { + found = 1; + idmPtr = Tcl_GetHashValue(hPtr); + } + if (isStar) { + /* check if the function is in the exceptions */ + hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)objv[1]); + if (hPtr2 != NULL) { + const char *sep = ""; + objPtr = Tcl_NewStringObj("unknown subcommand \"", -1); + Tcl_AppendToObj(objPtr, funcName, -1); + Tcl_AppendToObj(objPtr, "\": must be ", -1); + FOREACH_HASH_VALUE(idmPtr, + &iclsPtr->delegatedFunctions) { + funcName = Tcl_GetString(idmPtr->namePtr); + if (strcmp(funcName, "*") != 0) { + if (strlen(sep) > 0) { + Tcl_AppendToObj(objPtr, sep, -1); + } + Tcl_AppendToObj(objPtr, funcName, -1); + sep = " or "; + } + } + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + } + val = NULL; + if ((idmPtr != NULL) && (idmPtr->icPtr != NULL)) { + Tcl_Obj *objPtr; + /* we cannot use Itcl_GetInstanceVar here as the object is not + * yet completely built. So use the varNsNamePtr + */ + if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) { + objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, + (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(idmPtr->icPtr->namePtr), -1); + val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0); + Tcl_DecrRefCount(objPtr); + } else { + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetString(ioPtr->varNsNamePtr), -1); + Tcl_DStringAppend(&buffer, + Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), -1); + val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), + NULL, 0); + Tcl_DStringFree(&buffer); + } + + if (val == NULL) { + Tcl_AppendResult(interp, "ItclBiObjectUnknownCmd contents of ", + "component == NULL\n", NULL); + return TCL_ERROR; + } + } + + offset = 1; + if (isStar) { + hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)objv[1]); + /* we have no method name in that case in the caller */ + if (hPtr != NULL) { + const char *sep = ""; + objPtr = Tcl_NewStringObj("unknown subcommand \"", -1); + Tcl_AppendToObj(objPtr, funcName, -1); + Tcl_AppendToObj(objPtr, "\": must be ", -1); + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + funcName = Tcl_GetString(idmPtr->namePtr); + if (strcmp(funcName, "*") != 0) { + if (strlen(sep) > 0) { + Tcl_AppendToObj(objPtr, sep, -1); + } + Tcl_AppendToObj(objPtr, funcName, -1); + sep = " or "; + } + } + } + } + if (idmPtr == NULL) { + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), + "\": should be one of...", (char*)NULL); + ItclReportObjectUsage(interp, ioPtr, NULL, NULL); + return TCL_ERROR; + } + lObjc = 0; + if ((idmPtr != NULL) && ((idmPtr->asPtr != NULL) || + (idmPtr->usingPtr != NULL))) { + offset++; + listPtr = Tcl_NewListObj(0, NULL); + result = ExpandDelegateAs(interp, NULL, iclsPtr, + idmPtr, funcName, listPtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(listPtr); + return result; + } + result = Tcl_ListObjGetElements(interp, listPtr, + &lObjc, &lObjv); + if (result != TCL_OK) { + Tcl_DecrRefCount(listPtr); + return result; + } + if (idmPtr->usingPtr != NULL) { + useComponent = 0; + } + } + if (useComponent) { + if ((val == NULL) || (strlen(val) == 0)) { + Tcl_AppendResult(interp, "component \"", + Tcl_GetString(idmPtr->icPtr->namePtr), + "\" is not initialized", NULL); + return TCL_ERROR; + } + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * + (objc + lObjc - offset + useComponent)); + if (useComponent) { + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + } + for (idx = 0; idx < lObjc; idx++) { + newObjv[useComponent+idx] = lObjv[idx]; + } + if (objc-offset > 0) { + memcpy(newObjv+useComponent+lObjc, objv+offset, + sizeof(Tcl_Obj *) * (objc-offset)); + } + ItclShowArgs(1, "UK EVAL2", objc+lObjc-offset+useComponent, + newObjv); + result = Tcl_EvalObjv(interp, objc+lObjc-offset+useComponent, + newObjv, 0); + if (isStar && (result == TCL_OK)) { + if (Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, + (char *)newObjv[1]) == NULL) { + result = ItclCreateDelegatedFunction(interp, iclsPtr, + newObjv[1], idmPtr->icPtr, NULL, NULL, + NULL, &idmPtr2); + if (result == TCL_OK) { + if (isTypeMethod) { + idmPtr2->flags |= ITCL_TYPE_METHOD; + } else { + idmPtr2->flags |= ITCL_METHOD; + } + hPtr2 = Tcl_CreateHashEntry( + &iclsPtr->delegatedFunctions, (char *)newObjv[1], + &isNew); + Tcl_SetHashValue(hPtr2, idmPtr2); + } + } + } + if (useComponent) { + Tcl_DecrRefCount(newObjv[0]); + } + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + ckfree((char *)newObjv); + if (result == TCL_OK) { + return TCL_OK; + } + resStr = Tcl_GetStringResult(interp); + /* FIXME ugly hack at the moment !! */ + if (strncmp(resStr, "wrong # args: should be ", 24) == 0) { + resPtr = Tcl_NewStringObj("", -1); + Tcl_AppendToObj(resPtr, resStr, 25); + resStr += 25; + Tcl_AppendToObj(resPtr, Tcl_GetString(iclsPtr->namePtr), -1); + resStr += strlen(val); + Tcl_AppendToObj(resPtr, resStr, -1); + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, resPtr); + } + return result; +} + +static Tcl_Obj *makeAsOptionInfo( + Tcl_Interp *interp, + Tcl_Obj *optNamePtr, + ItclDelegatedOption *idoPtr, + int lObjc2, + Tcl_Obj * const *lObjv2) +{ + Tcl_Obj *objPtr; + int j; + + objPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + Tcl_GetString(optNamePtr), -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + Tcl_GetString(idoPtr->resourceNamePtr), -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + Tcl_GetString(idoPtr->classNamePtr), -1)); + for (j = 3; j < lObjc2; j++) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + Tcl_GetString(lObjv2[j]), -1)); + } + return objPtr; +} + +/* + * ------------------------------------------------------------------------ + * ItclExtendedConfigure() + * + * Invoked whenever the user issues the "configure" method for an object. + * If the class is not ITCL_CLASS + * Handles the following syntax: + * + * <objName> configure ?-<option>? ?<value> -<option> <value>...? + * + * Allows access to public variables as if they were configuration + * options. With no arguments, this command returns the current + * list of public variable options. If -<option> is specified, + * this returns the information for just one option: + * + * -<optionName> <initVal> <currentVal> + * + * Otherwise, the list of arguments is parsed, and values are + * assigned to the various public variable options. When each + * option changes, a big of "config" code associated with the option + * is executed, to bring the object up to date. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclExtendedConfigure( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashTable unique; + Tcl_HashEntry *hPtr2; + Tcl_HashEntry *hPtr3; + Tcl_Object oPtr; + Tcl_Obj *listPtr; + Tcl_Obj *listPtr2; + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_Obj *optNamePtr; + Tcl_Obj *methodNamePtr; + Tcl_Obj *configureMethodPtr; + Tcl_Obj **lObjv; + Tcl_Obj **newObjv; + Tcl_Obj *lObjvOne[1]; + Tcl_Obj **lObjv2; + Tcl_Obj **lObjv3; + Tcl_Namespace *saveNsPtr; + Tcl_Namespace *evalNsPtr; + ItclClass *contextIclsPtr; + ItclClass *iclsPtr2; + ItclComponent *componentIcPtr; + ItclObject *contextIoPtr; + ItclDelegatedFunction *idmPtr; + ItclDelegatedOption *idoPtr; + ItclDelegatedOption *saveIdoPtr; + ItclObject *ioPtr; + ItclComponent *icPtr; + ItclOption *ioptPtr; + ItclObjectInfo *infoPtr; + const char *val; + int lObjc; + int lObjc2; + int lObjc3; + int i; + int j; + int isNew; + int result; + int isOneOption; + + ItclShowArgs(1, "ItclExtendedConfigure", objc, objv); + ioptPtr = NULL; + optNamePtr = NULL; + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be ", + "\"object configure ?-option? ?value -option value...?\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * BE CAREFUL: work in the virtual scope! + */ + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + infoPtr = contextIclsPtr->infoPtr; + if (infoPtr->currContextIclsPtr != NULL) { + contextIclsPtr = infoPtr->currContextIclsPtr; + } + + hPtr = NULL; + /* first check if method configure is delegated */ + methodNamePtr = Tcl_NewStringObj("*", -1); + hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *) + methodNamePtr); + if (hPtr != NULL) { + /* all methods are delegated */ + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); + Tcl_SetStringObj(methodNamePtr, "configure", -1); + hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)methodNamePtr); + if (hPtr == NULL) { + icPtr = idmPtr->icPtr; + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), + NULL, contextIoPtr, contextIclsPtr); + if (val != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+5)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("configure", -1); + Tcl_IncrRefCount(newObjv[1]); + for(i=1;i<objc;i++) { + newObjv[i+1] = objv[i]; + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + oPtr = Tcl_GetObjectFromObj(interp, objPtr); + if (oPtr != NULL) { + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + infoPtr->currContextIclsPtr = ioPtr->iclsPtr; + } + ItclShowArgs(1, "EXTENDED CONFIGURE EVAL1", objc+1, newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + ckfree((char *)newObjv); + Tcl_DecrRefCount(objPtr); + if (oPtr != NULL) { + infoPtr->currContextIclsPtr = NULL; + } + Tcl_DecrRefCount(methodNamePtr); + return result; + } + } else { + /* configure is not delegated, so reset hPtr for checks later on! */ + hPtr = NULL; + } + } + Tcl_DecrRefCount(methodNamePtr); + /* now do the hard work */ + if (objc == 1) { + Tcl_InitObjHashTable(&unique); + /* plain configure */ + listPtr = Tcl_NewListObj(0, NULL); + if (contextIclsPtr->flags & ITCL_ECLASS) { + result = Tcl_EvalEx(interp, "::itcl::builtin::getEclassOptions", -1, 0); + return result; + } + FOREACH_HASH_VALUE(ioptPtr, &contextIoPtr->objectOptions) { + hPtr2 = Tcl_CreateHashEntry(&unique, + (char *)ioptPtr->namePtr, &isNew); + if (!isNew) { + continue; + } + objPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj( + Tcl_GetString(ioptPtr->resourceNamePtr), -1)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(Tcl_GetString(ioptPtr->classNamePtr), -1)); + if (ioptPtr->defaultValuePtr != NULL) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + Tcl_GetString(ioptPtr->defaultValuePtr), -1)); + } else { + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("", -1)); + } + val = ItclGetInstanceVar(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), contextIoPtr, + contextIclsPtr); + if (val == NULL) { + val = "<undefined>"; + } + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(val, -1)); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } + /* now check for delegated options */ + FOREACH_HASH_VALUE(idoPtr, &contextIoPtr->objectDelegatedOptions) { + + if (idoPtr->icPtr != NULL) { + icPtr = idoPtr->icPtr; + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), + NULL, contextIoPtr, icPtr->ivPtr->iclsPtr); + if ((val != NULL) && (strlen(val) != 0)) { + + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + Tcl_AppendToObj(objPtr, " configure ", -1); + isOneOption = 0; + if (strcmp(Tcl_GetString(idoPtr->namePtr), "*") != 0) { + Tcl_AppendToObj(objPtr, " ", -1); + if (idoPtr->asPtr != NULL) { + Tcl_AppendToObj(objPtr, Tcl_GetString( + idoPtr->asPtr), -1); + } else { + Tcl_AppendToObj(objPtr, Tcl_GetString( + idoPtr->namePtr), -1); + } + isOneOption = 1; + } + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + listPtr2 = Tcl_GetObjResult(interp); + if (isOneOption) { + lObjc = 1; + lObjvOne[0] = listPtr2; + lObjv = &lObjvOne[0]; + } else { + Tcl_ListObjGetElements(interp, listPtr2, + &lObjc, &lObjv); + } + for (i = 0; i < lObjc; i++) { + objPtr = lObjv[i]; + Tcl_ListObjGetElements(interp, objPtr, + &lObjc2, &lObjv2); + optNamePtr = idoPtr->namePtr; + if (lObjc2 == 0) { + hPtr = NULL; + } else { + hPtr = Tcl_FindHashEntry(&idoPtr->exceptions, + (char *)lObjv2[0]); + if (isOneOption) { + /* avoid wrong name where asPtr != NULL */ + optNamePtr = idoPtr->namePtr; + } else { + optNamePtr = lObjv2[0]; + } + } + if ((hPtr == NULL) && (lObjc2 > 0)) { + if (icPtr->haveKeptOptions) { + hPtr = Tcl_FindHashEntry(&icPtr->keptOptions, + (char *)optNamePtr); + if (hPtr == NULL) { + if (idoPtr->asPtr != NULL) { + if (strcmp(Tcl_GetString(idoPtr->asPtr), + Tcl_GetString(lObjv2[0])) == 0) { + hPtr = Tcl_FindHashEntry( + &icPtr->keptOptions, + (char *)optNamePtr); + if (hPtr == NULL) { + /* not in kept list, so ignore */ + continue; + } + objPtr = makeAsOptionInfo(interp, + optNamePtr, idoPtr, lObjc2, + lObjv2); + } + } + } + if (hPtr != NULL) { + hPtr2 = Tcl_CreateHashEntry(&unique, + (char *)optNamePtr, &isNew); + if (!isNew) { + continue; + } + /* add the option */ + if (idoPtr->asPtr != NULL) { + objPtr = makeAsOptionInfo(interp, + optNamePtr, idoPtr, lObjc2, + lObjv2); + } + Tcl_ListObjAppendElement(interp, listPtr, + objPtr); + } + } else { + Tcl_ListObjGetElements(interp, lObjv2[i], + &lObjc3, &lObjv3); + hPtr2 = Tcl_CreateHashEntry(&unique, + (char *)lObjv3[0], &isNew); + if (!isNew) { + continue; + } + /* add the option */ + if (idoPtr->asPtr != NULL) { + objPtr = makeAsOptionInfo(interp, + optNamePtr, idoPtr, lObjc2, + lObjv2); + } + Tcl_ListObjAppendElement(interp, listPtr, + objPtr); + } + } + } + } + } + } + Tcl_SetObjResult(interp, listPtr); + Tcl_DeleteHashTable(&unique); + return TCL_OK; + } + hPtr2 = NULL; + /* first handle delegated options */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *) + objv[1]); + if (hPtr == NULL) { + Tcl_Obj *objPtr; + objPtr = Tcl_NewStringObj("*",1); + Tcl_IncrRefCount(objPtr); + /* check if all options are delegated */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, + (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + /* now check the exceptions */ + idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr); + hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)objv[1]); + if (hPtr2 != NULL) { + /* found in exceptions, so no delegation for this option */ + hPtr = NULL; + } + } + } + componentIcPtr = NULL; + /* check if it is not a local option defined before delegate option "*" + */ + hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, + (char *)objv[1]); + if (hPtr != NULL) { + idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr); + icPtr = idoPtr->icPtr; + if (icPtr != NULL) { + if (icPtr->haveKeptOptions) { + hPtr3 = Tcl_FindHashEntry(&icPtr->keptOptions, (char *)objv[1]); + if (hPtr3 != NULL) { + /* ignore if it is an object option only */ + ItclHierIter hier; + int found; + + found = 0; + Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + if (Tcl_FindHashEntry(&iclsPtr2->options, + (char *)objv[1]) != NULL) { + found = 1; + break; + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + if (! found) { + hPtr2 = NULL; + componentIcPtr = icPtr; + } + } + } + } + } + if ((objc <= 3) && (hPtr != NULL) && (hPtr2 == NULL)) { + /* the option is delegated */ + idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr); + if (componentIcPtr != NULL) { + icPtr = componentIcPtr; + } else { + icPtr = idoPtr->icPtr; + } + val = ItclGetInstanceVar(interp, + Tcl_GetString(icPtr->namePtr), + NULL, contextIoPtr, icPtr->ivPtr->iclsPtr); + if ((val != NULL) && (strlen(val) > 0)) { + if (idoPtr->asPtr != NULL) { + icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = idoPtr; + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("configure", 9); + Tcl_IncrRefCount(newObjv[1]); + if (idoPtr->asPtr != NULL) { + newObjv[2] = idoPtr->asPtr; + } else { + newObjv[2] = objv[1]; + } + Tcl_IncrRefCount(newObjv[2]); + for(i=2;i<objc;i++) { + newObjv[i+1] = objv[i]; + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + oPtr = Tcl_GetObjectFromObj(interp, objPtr); + if (oPtr != NULL) { + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + infoPtr->currContextIclsPtr = ioPtr->iclsPtr; + } + Tcl_DecrRefCount(objPtr); + ItclShowArgs(1, "extended eval delegated option", objc + 1, + newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[2]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = NULL; + if (oPtr != NULL) { + infoPtr->currContextIclsPtr = NULL; + } + return result; + } else { + Tcl_AppendResult(interp, "INTERNAL ERROR component \"", + Tcl_GetString(icPtr->namePtr), "\" not found", + " or not set in ItclExtendedConfigure delegated option", + NULL); + return TCL_ERROR; + } + } + + if (objc == 2) { + saveIdoPtr = infoPtr->currIdoPtr; + /* now look if it is an option at all */ + if (hPtr2 == NULL) { + hPtr2 = Tcl_FindHashEntry(&contextIclsPtr->options, + (char *) objv[1]); + if (hPtr2 == NULL) { + hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, + (char *) objv[1]); + } else { + infoPtr->currIdoPtr = NULL; + } + } + if (hPtr2 == NULL) { + if (contextIclsPtr->flags & ITCL_ECLASS) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc)); + newObjv[0] = Tcl_NewStringObj("::itcl::builtin::eclassConfigure", -1); + Tcl_IncrRefCount(newObjv[0]); + for (j = 1; j < objc; j++) { + newObjv[j] = objv[j]; + Tcl_IncrRefCount(newObjv[j]); + } + result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT); + for (j = 0; j < objc; j++) { + Tcl_DecrRefCount(newObjv[j]); + } + ckfree((char *)newObjv); + if (result == TCL_OK) { + return TCL_OK; + } + } + /* no option at all, let the normal configure do the job */ + infoPtr->currIdoPtr = saveIdoPtr; + return TCL_CONTINUE; + } + ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2); + resultPtr = ItclReportOption(interp, ioptPtr, contextIoPtr); + infoPtr->currIdoPtr = saveIdoPtr; + Tcl_SetResult(interp, Tcl_GetString(resultPtr), TCL_VOLATILE); + Tcl_DecrRefCount(resultPtr); + return TCL_OK; + } + result = TCL_OK; + /* set one or more options */ + for (i=1; i < objc; i+=2) { + if (i+1 >= objc) { + Tcl_AppendResult(interp, "need option value pair", NULL); + result = TCL_ERROR; + break; + } + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectOptions, + (char *) objv[i]); + if (hPtr == NULL) { + if (contextIclsPtr->flags & ITCL_ECLASS) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc)); + newObjv[0] = Tcl_NewStringObj("::itcl::builtin::eclassConfigure", -1); + Tcl_IncrRefCount(newObjv[0]); + for (j = 1; j < objc; j++) { + newObjv[j] = objv[j]; + Tcl_IncrRefCount(newObjv[j]); + } + result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT); + for (j = 0; j < objc; j++) { + Tcl_DecrRefCount(newObjv[j]); + } + ckfree((char *)newObjv); + if (result == TCL_OK) { + continue; + } + } + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, + (char *) objv[i]); + if (hPtr != NULL) { + /* the option is delegated */ + idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr); + icPtr = idoPtr->icPtr; + val = ItclGetInstanceVar(interp, + Tcl_GetString(icPtr->ivPtr->namePtr), + NULL, contextIoPtr, icPtr->ivPtr->iclsPtr); + if ((val != NULL) && (strlen(val) > 0)) { + if (idoPtr->asPtr != NULL) { + icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = idoPtr; + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("configure", 9); + Tcl_IncrRefCount(newObjv[1]); + if (idoPtr->asPtr != NULL) { + newObjv[2] = idoPtr->asPtr; + } else { + newObjv[2] = objv[i]; + } + Tcl_IncrRefCount(newObjv[2]); + newObjv[3] = objv[i+1]; + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + oPtr = Tcl_GetObjectFromObj(interp, objPtr); + if (oPtr != NULL) { + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + infoPtr->currContextIclsPtr = ioPtr->iclsPtr; + } + Tcl_DecrRefCount(objPtr); + ItclShowArgs(1, "extended eval delegated option", 4, + newObjv); + result = Tcl_EvalObjv(interp, 4, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[2]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = NULL; + if (oPtr != NULL) { + infoPtr->currContextIclsPtr = NULL; + } + continue; + } else { + Tcl_AppendResult(interp, "INTERNAL ERROR component not ", + "found or not set in ItclExtendedConfigure ", + "delegated option", NULL); + return TCL_ERROR; + } + } + } + if (hPtr == NULL) { + infoPtr->unparsedObjc += 2; + if (infoPtr->unparsedObjv == NULL) { + infoPtr->unparsedObjc++; /* keep the first slot for + correct working !! */ + infoPtr->unparsedObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) + *(infoPtr->unparsedObjc)); + infoPtr->unparsedObjv[0] = objv[0]; + } else { + infoPtr->unparsedObjv = (Tcl_Obj **)ckrealloc( + (char *)infoPtr->unparsedObjv, sizeof(Tcl_Obj *) + *(infoPtr->unparsedObjc)); + } + infoPtr->unparsedObjv[infoPtr->unparsedObjc-2] = objv[i]; + Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-2]); + infoPtr->unparsedObjv[infoPtr->unparsedObjc-1] = objv[i+1]; + /* check if normal public variable/common ? */ + /* FIXME !!! temporary */ + continue; + } + ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr); + if (ioptPtr->flags & ITCL_OPTION_READONLY) { + if (infoPtr->currIoPtr == NULL) { + /* allow only setting during instance creation + * infoPtr->currIoPtr != NULL during instance creation + */ + Tcl_AppendResult(interp, "option \"", + Tcl_GetString(ioptPtr->namePtr), + "\" can only be set at instance creation", NULL); + return TCL_ERROR; + } + } + if (ioptPtr->validateMethodPtr != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3); + newObjv[0] = ioptPtr->validateMethodPtr; + newObjv[1] = objv[i]; + newObjv[2] = objv[i+1]; + infoPtr->inOptionHandling = 1; + saveNsPtr = Tcl_GetCurrentNamespace(interp); + Itcl_SetCallFrameNamespace(interp, contextIclsPtr->nsPtr); + ItclShowArgs(1, "EVAL validatemethod", 3, newObjv); + result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT); + Itcl_SetCallFrameNamespace(interp, saveNsPtr); + infoPtr->inOptionHandling = 0; + ckfree((char *)newObjv); + if (result != TCL_OK) { + break; + } + } + configureMethodPtr = NULL; + evalNsPtr = NULL; + if (ioptPtr->configureMethodPtr != NULL) { + configureMethodPtr = ioptPtr->configureMethodPtr; + Tcl_IncrRefCount(configureMethodPtr); + evalNsPtr = ioptPtr->iclsPtr->nsPtr; + } + if (ioptPtr->configureMethodVarPtr != NULL) { + val = ItclGetInstanceVar(interp, + Tcl_GetString(ioptPtr->configureMethodVarPtr), NULL, + contextIoPtr, ioptPtr->iclsPtr); + if (val == NULL) { + Tcl_AppendResult(interp, "configure cannot get value for", + " configuremethodvar \"", + Tcl_GetString(ioptPtr->configureMethodVarPtr), + "\"", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(val, -1); + hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveCmds, + (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + ItclMemberFunc *imPtr; + ItclCmdLookup *clookup; + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + evalNsPtr = imPtr->iclsPtr->nsPtr; + } else { + Tcl_AppendResult(interp, "cannot find method \"", + val, "\" found in configuremethodvar", NULL); + return TCL_ERROR; + } + configureMethodPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(configureMethodPtr); + } + if (configureMethodPtr != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*3); + newObjv[0] = configureMethodPtr; + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = objv[i]; + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = objv[i+1]; + Tcl_IncrRefCount(newObjv[2]); + saveNsPtr = Tcl_GetCurrentNamespace(interp); + Itcl_SetCallFrameNamespace(interp, evalNsPtr); + ItclShowArgs(1, "EVAL configuremethod", 3, newObjv); + result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[2]); + ckfree((char *)newObjv); + Itcl_SetCallFrameNamespace(interp, saveNsPtr); + Tcl_DecrRefCount(configureMethodPtr); + if (result != TCL_OK) { + break; + } + } else { + if (ItclSetInstanceVar(interp, "itcl_options", + Tcl_GetString(objv[i]), Tcl_GetString(objv[i+1]), + contextIoPtr, ioptPtr->iclsPtr) == NULL) { + result = TCL_ERROR; + break; + } + } + Tcl_ResetResult(interp); + result = TCL_OK; + } + if (infoPtr->unparsedObjc > 0) { + if (result == TCL_OK) { + return TCL_CONTINUE; + } + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclExtendedCget() + * + * Invoked whenever the user issues the "cget" method for an object. + * If the class is NOT ITCL_CLASS + * Handles the following syntax: + * + * <objName> cget -<option> + * + * Allows access to public variables as if they were configuration + * options. Mimics the behavior of the usual "cget" method for + * Tk widgets. Returns the current value of the public variable + * with name <option>. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclExtendedCget( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr2; + Tcl_HashEntry *hPtr3; + Tcl_Obj *objPtr2; + Tcl_Obj *objPtr; + Tcl_Object oPtr; + Tcl_Obj *methodNamePtr; + Tcl_Obj **newObjv; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclDelegatedFunction *idmPtr; + ItclDelegatedOption *idoPtr; + ItclComponent *icPtr; + ItclObjectInfo *infoPtr; + ItclOption *ioptPtr; + ItclObject *ioPtr; + const char *val; + int i; + int result; + + ItclShowArgs(1,"ItclExtendedCget", objc, objv); + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if ((contextIoPtr == NULL) || objc != 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be \"object cget -option\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * BE CAREFUL: work in the virtual scope! + */ + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + infoPtr = contextIclsPtr->infoPtr; + if (infoPtr->currContextIclsPtr != NULL) { + contextIclsPtr = infoPtr->currContextIclsPtr; + } + + hPtr = NULL; + /* first check if method cget is delegated */ + methodNamePtr = Tcl_NewStringObj("*", -1); + hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *) + methodNamePtr); + if (hPtr != NULL) { + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); + Tcl_SetStringObj(methodNamePtr, "cget", -1); + hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)methodNamePtr); + if (hPtr == NULL) { + icPtr = idmPtr->icPtr; + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), + NULL, contextIoPtr, contextIclsPtr); + if (val != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("cget", 4); + Tcl_IncrRefCount(newObjv[1]); + for(i=1;i<objc;i++) { + newObjv[i+1] = objv[i]; + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + oPtr = Tcl_GetObjectFromObj(interp, objPtr); + if (oPtr != NULL) { + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + infoPtr->currContextIclsPtr = ioPtr->iclsPtr; + } + ItclShowArgs(1, "DELEGATED EVAL", objc+1, newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(objPtr); + if (oPtr != NULL) { + infoPtr->currContextIclsPtr = NULL; + } + Tcl_DecrRefCount(methodNamePtr); + return result; + } + } + } + Tcl_DecrRefCount(methodNamePtr); + if (objc == 1) { + Tcl_WrongNumArgs(interp, 1, objv, "option"); + return TCL_ERROR; + } + /* now do the hard work */ + /* first handle delegated options */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *) + objv[1]); + hPtr3 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *) + objv[1]); + hPtr2 = NULL; + if (hPtr == NULL) { + objPtr2 = Tcl_NewStringObj("*", -1); + /* check for "*" option delegated */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *) + objPtr2); + Tcl_DecrRefCount(objPtr2); + hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *) + objv[1]); + } + if ((hPtr != NULL) && (hPtr2 == NULL) && (hPtr3 == NULL)) { + /* the option is delegated */ + idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr); + /* if the option is in the exceptions, do nothing */ + hPtr = Tcl_FindHashEntry(&idoPtr->exceptions, (char *) + objv[1]); + if (hPtr) { + return TCL_CONTINUE; + } + icPtr = idoPtr->icPtr; + if (icPtr->ivPtr->flags & ITCL_COMMON) { + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), + NULL, contextIoPtr, icPtr->ivPtr->iclsPtr); + } else { + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), + NULL, contextIoPtr, icPtr->ivPtr->iclsPtr); + } + if ((val != NULL) && (strlen(val) > 0)) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1)); + newObjv[0] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("cget", 4); + Tcl_IncrRefCount(newObjv[1]); + for(i=1;i<objc;i++) { + if (strcmp(Tcl_GetString(idoPtr->namePtr), + Tcl_GetString(objv[i])) == 0) { + if (idoPtr->asPtr != NULL) { + newObjv[i+1] = idoPtr->asPtr; + } else { + newObjv[i+1] = objv[i]; + } + } else { + newObjv[i+1] = objv[i]; + } + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + oPtr = Tcl_GetObjectFromObj(interp, objPtr); + if (oPtr != NULL) { + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + infoPtr->currContextIclsPtr = ioPtr->iclsPtr; + } + ItclShowArgs(1, "ExtendedCget delegated option", objc+1, newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(objPtr); + if (oPtr != NULL) { + infoPtr->currContextIclsPtr = NULL; + } + ckfree((char *)newObjv); + return result; + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "component \"", + Tcl_GetString(icPtr->namePtr), + "\" is undefined, needed for option \"", + Tcl_GetString(objv[1]), + "\"", NULL); + return TCL_ERROR; + } + } + + /* now look if it is an option at all */ + if ((hPtr2 == NULL) && (hPtr3 == NULL)) { + /* no option at all, let the normal configure do the job */ + return TCL_CONTINUE; + } + if (hPtr3 != NULL) { + ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr3); + } else { + ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2); + } + result = TCL_CONTINUE; + if (ioptPtr->cgetMethodPtr != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*2); + newObjv[0] = ioptPtr->cgetMethodPtr; + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = objv[1]; + Tcl_IncrRefCount(newObjv[1]); + ItclShowArgs(1, "eval cget method", objc, newObjv); + result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + } else { + val = ItclGetInstanceVar(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), + contextIoPtr, ioptPtr->iclsPtr); + if (val) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1)); + } + result = TCL_OK; + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclExtendedSetGet() + * + * Invoked whenever the user writes to a methodvariable or calls the method + * with the same name as the variable. + * only for not ITCL_CLASS classes + * Handles the following syntax: + * + * <objName> setget varName ?<value>? + * + * Allows access to methodvariables as if they hat a setter and getter + * method + * With no arguments, this command returns the current + * value of the variable. If <value> is specified, + * this sets the variable to the value calling a callback if exists: + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclExtendedSetGet( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + Tcl_HashEntry *hPtr; + Tcl_Obj **newObjv; + ItclMethodVariable *imvPtr; + ItclObjectInfo *infoPtr; + const char *usageStr; + const char *val; + int result; + int setValue; + + ItclShowArgs(1, "ItclExtendedSetGet", objc, objv); + imvPtr = NULL; + result = TCL_OK; + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + usageStr = "improper usage: should be \"object setget varName ?value?\""; + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + usageStr, (char*)NULL); + return TCL_ERROR; + } + + /* + * BE CAREFUL: work in the virtual scope! + */ + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + infoPtr = contextIclsPtr->infoPtr; + if (infoPtr->currContextIclsPtr != NULL) { + contextIclsPtr = infoPtr->currContextIclsPtr; + } + + hPtr = NULL; + if (objc < 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + usageStr, (char*)NULL); + return TCL_ERROR; + } + /* look if it is an methodvariable at all */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectMethodVariables, + (char *) objv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "no such methodvariable \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + imvPtr = (ItclMethodVariable *)Tcl_GetHashValue(hPtr); + if (objc == 2) { + val = ItclGetInstanceVar(interp, Tcl_GetString(objv[1]), NULL, + contextIoPtr, imvPtr->iclsPtr); + if (val == NULL) { + result = TCL_ERROR; + } else { + Tcl_SetResult(interp, (char *)val, TCL_VOLATILE); + } + return result; + } + imvPtr = (ItclMethodVariable *)Tcl_GetHashValue(hPtr); + result = TCL_OK; + setValue = 1; + if (imvPtr->callbackPtr != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*3); + newObjv[0] = imvPtr->callbackPtr; + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = objv[1]; + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = objv[2]; + Tcl_IncrRefCount(newObjv[2]); + result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[2]); + ckfree((char *)newObjv); + } + if (result == TCL_OK) { + Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &setValue); + /* if setValue != 0 set the new value of the variable here */ + if (setValue) { + if (ItclSetInstanceVar(interp, Tcl_GetString(objv[1]), NULL, + Tcl_GetString(objv[2]), contextIoPtr, + imvPtr->iclsPtr) == NULL) { + result = TCL_ERROR; + } + } + } + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiInstallComponentCmd() + * + * Invoked whenever the user issues the "installcomponent" method for an + * object. + * Handles the following syntax: + * + * installcomponent <componentName> using <widgetClassName> <widgetPathName> + * ?-option value -option value ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInstallComponentCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj ** newObjv; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclDelegatedOption *idoPtr; + const char *usageStr; + const char *componentName; + const char *componentValue; + const char *token; + int numOpts; + int result; + + + ItclShowArgs(1, "Itcl_BiInstallComponentCmd", objc, objv); + /* + * Make sure that this command is being invoked in the proper + * context. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be \"object installcomponent \"", + (char*)NULL); + return TCL_ERROR; + } + if (objc < 5) { + /* FIXME strip off the :: parts here properly*/ + token = Tcl_GetString(objv[0])+2; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", token, " <componentName> using", + " <widgetClassName> <widgetPathName>", + " ?-option value -option value ...?\"", + (char*)NULL); + return TCL_ERROR; + } + + /* get component name and check, if it exists */ + token = Tcl_GetString(objv[1]); + if (contextIclsPtr == NULL) { + Tcl_AppendResult(interp, "cannot find context class for object \"", + Tcl_GetCommandName(interp, contextIoPtr->accessCmd), "\"", + NULL); + return TCL_ERROR; + } + if (!(contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + Tcl_AppendResult(interp, "no such method \"installcomponent\"", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&contextIclsPtr->components, (char *)objv[1]); + if (hPtr == NULL) { + numOpts = 0; + FOREACH_HASH_VALUE(idoPtr, &contextIoPtr->objectDelegatedOptions) { + if (idoPtr == NULL) { + /* FIXME need code here !! */ + } + numOpts++; + } + if (numOpts == 0) { + /* there are no delegated options, so no problem that the + * component does not exist. We have nothing to do */ + return TCL_OK; + } + Tcl_AppendResult(interp, "class \"", + Tcl_GetString(contextIclsPtr->namePtr), + "\" has no component \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + if (contextIclsPtr->flags & ITCL_TYPE) { + Tcl_Obj *objPtr; + usageStr = "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"; + if (objc < 4) { + Tcl_AppendResult(interp, usageStr, NULL); + return TCL_ERROR; + } + if (strcmp(Tcl_GetString(objv[2]), "using") != 0) { + Tcl_AppendResult(interp, usageStr, NULL); + return TCL_ERROR; + } + componentName = Tcl_GetString(objv[1]); + /* as it is no widget, we don't need to check for delegated option */ + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc - 3)); + memcpy(newObjv, objv + 3, sizeof(Tcl_Obj *) * ((objc - 3))); + ItclShowArgs(1, "BiInstallComponent", objc - 3, newObjv); + result = Tcl_EvalObjv(interp, objc - 3, newObjv, 0); + if (result != TCL_OK) { + return result; + } + componentValue = Tcl_GetStringResult(interp); + objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, + (Tcl_GetObjectNamespace(contextIclsPtr->oPtr))->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, componentName, -1); + + Tcl_SetVar2(interp, Tcl_GetString(objPtr), NULL, componentValue, 0); + + } else { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 1)); + newObjv[0] = Tcl_NewStringObj("::itcl::builtin::installcomponent", -1); + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv, objv + 1, sizeof(Tcl_Obj *) * ((objc - 1))); + result = Tcl_EvalObjv(interp, objc, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + return result; + } + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiDestroyCmd() + * + * Invoked whenever the user issues the "destroy" method for an + * object. + * Handles the following syntax: + * + * destroy + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiDestroyCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj **newObjv; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + int result; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiDestroyCmd", objc, objv); + contextIoPtr = NULL; + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (contextIclsPtr == NULL) { + Tcl_AppendResult(interp, "cannot find context class for object \"", + Tcl_GetCommandName(interp, contextIoPtr->accessCmd), "\"", + NULL); + return TCL_ERROR; + } + if ((objc > 1) || !(contextIclsPtr->flags & + (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + /* try to execute destroy in uplevel namespace */ + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 2)); + newObjv[0] = Tcl_NewStringObj("uplevel", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("#0", -1); + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = Tcl_NewStringObj("destroy", -1); + Tcl_IncrRefCount(newObjv[2]); + memcpy(newObjv + 3, objv + 1, sizeof(Tcl_Obj *) * (objc - 1)); + ItclShowArgs(1, "DESTROY", objc + 2, newObjv); + result = Tcl_EvalObjv(interp, objc + 2, newObjv, 0); + Tcl_DecrRefCount(newObjv[2]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[0]); + return result; + } + if (objc != 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", Tcl_GetString(objv[0]), (char*)NULL); + return TCL_ERROR; + } + + if (contextIoPtr != NULL) { + Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr); + Itcl_RenameCommand(interp, Tcl_GetString(objPtr), ""); + Tcl_DecrRefCount(objPtr); + result = TCL_OK; + } else { + result = Itcl_DeleteClass(interp, contextIclsPtr); + } + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiCallInstanceCmd() + * + * Invoked whenever the a script generated by mytypemethod, mymethod or + * myproc is evauated later on: + * Handles the following syntax: + * + * callinstance <instanceName> ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiCallInstanceCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + Tcl_Obj **newObjv; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObject *ioPtr; + const char *token; + int result; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiCallInstanceCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (objc < 2) { + token = Tcl_GetString(objv[0]); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", token, " <instanceName>", + (char*)NULL); + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&contextIclsPtr->infoPtr->instances, + Tcl_GetString(objv[1])); + if (hPtr == NULL) { + Tcl_AppendResult(interp, + "no such instanceName \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + ioPtr = Tcl_GetHashValue(hPtr); + objPtr =Tcl_NewObj(); + Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1)); + newObjv[0] = objPtr; + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2)); + result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiGetInstanceVarCmd() + * + * Invoked whenever the a script generated by mytypevar, myvar or + * mycommon is evauated later on: + * Handles the following syntax: + * + * getinstancevar <instanceName> ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiGetInstanceVarCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + Tcl_Obj **newObjv; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObject *ioPtr; + const char *token; + int result; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiGetInstanceVarCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (objc < 2) { + token = Tcl_GetString(objv[0]); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", token, " <instanceName>", + (char*)NULL); + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&contextIclsPtr->infoPtr->instances, + Tcl_GetString(objv[1])); + if (hPtr == NULL) { + Tcl_AppendResult(interp, + "no such instanceName \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + ioPtr = Tcl_GetHashValue(hPtr); + objPtr =Tcl_NewObj(); + Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1)); + newObjv[0] = objPtr; + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2)); + result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiMyTypeMethodCmd() + * + * Invoked when a user calls mytypemethod + * + * Handles the following syntax: + * + * mytypemethod ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiMyTypeMethodCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *objPtr; + Tcl_Obj *resultPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + int i; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiMyTypeMethodCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (objc < 2) { + Tcl_AppendResult(interp, "usage: mytypemethod <name>", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1); + resultPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, resultPtr, objPtr); + + for (i = 1; i < objc; i++) { + Tcl_ListObjAppendElement(interp, resultPtr, objv[i]); + } + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiMyMethodCmd() + * + * Invoked when a user calls mymethod + * + * Handles the following syntax: + * + * mymethod ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiMyMethodCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *resultPtr; + int i; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiMyMethodCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + resultPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj("::itcl::builtin::callinstance", -1)); + Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj( + (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1)); + for (i = 1; i < objc; i++) { + Tcl_ListObjAppendElement(interp, resultPtr, objv[i]); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiMyProcCmd() + * + * Invoked when a user calls myproc + * + * Handles the following syntax: + * + * myproc ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiMyProcCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *objPtr; + Tcl_Obj *resultPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + int i; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiMyProcCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (objc < 2) { + Tcl_AppendResult(interp, "usage: myproc <name>", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(objv[1]), -1); + resultPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, resultPtr, objPtr); + + for (i = 2; i < objc; i++) { + Tcl_ListObjAppendElement(interp, resultPtr, objv[i]); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiMyTypeVarCmd() + * + * Invoked when a user calls mytypevar + * + * Handles the following syntax: + * + * mytypevar ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiMyTypeVarCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *objPtr; + Tcl_Obj *resultPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + int i; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiMyTypeVarCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (objc < 2) { + Tcl_AppendResult(interp, "usage: mytypevar <name>", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(objv[1]), -1); + resultPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, resultPtr, objPtr); + + for (i = 2; i < objc; i++) { + Tcl_ListObjAppendElement(interp, resultPtr, objv[i]); + } + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiMyVarCmd() + * + * Invoked when a user calls myvar + * + * Handles the following syntax: + * + * myvar ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiMyVarCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *resultPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiMyVarCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + resultPtr = Tcl_NewStringObj(Tcl_GetString(contextIoPtr->varNsNamePtr), + -1); + Tcl_AppendToObj(resultPtr, "::", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetString(contextIclsPtr->namePtr), -1); + Tcl_AppendToObj(resultPtr, "::", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetString(objv[1]), -1); + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_BiItclHullCmd() + * + * Invoked when a user calls itcl_hull + * + * Handles the following syntax: + * + * itcl_hull ?arg arg ...? + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiItclHullCmd( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + const char *val; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + ItclShowArgs(1, "Itcl_BiItclHullCmd", objc, objv); + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + val = ItclGetInstanceVar(interp, "itcl_hull", NULL, + contextIoPtr, contextIclsPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1)); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiCreateHullCmd() + * + * Invoked by Tcl normally during evaluating constructor + * the "createhull" command is invoked to install and setup an + * ::itcl::extendedclass itcl_hull + * for an object. Handles the following syntax: + * + * createhull <widget_type> <widget_path> ?-class <widgetClassName>? + * ?<optionName> <optionValue> <optionName> <optionValue> ...? + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_BiCreateHullCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + + ItclShowArgs(1, "Itcl_BiCreateHullCmd", objc, objv); + if (!infoPtr->itclHullCmdsInitted) { + result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0); + if (result != TCL_OK) { + return result; + } + infoPtr->itclHullCmdsInitted = 1; + } + return Tcl_EvalObjv(interp, objc, objv, 0); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiSetupComponentCmd() + * + * Invoked by Tcl during evaluating constructor whenever + * the "setupcomponent" command is invoked to install and setup an + * ::itcl::extendedclass component + * for an object. Handles the following syntax: + * + * setupcomponent <componentName> using <widgetType> <widget_path> + * ?<optionName> <optionValue> <optionName> <optionValue> ...? + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_BiSetupComponentCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + + ItclShowArgs(1, "Itcl_BiSetupComponentCmd", objc, objv); + if (!infoPtr->itclHullCmdsInitted) { + result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0); + if (result != TCL_OK) { + return result; + } + infoPtr->itclHullCmdsInitted = 1; + } + return Tcl_EvalObjv(interp, objc, objv, 0); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInitOptionsCmd() + * + * Invoked by Tcl during evaluating constructor whenever + * the "itcl_initoptions" command is invoked to install and setup an + * ::itcl::extendedclass options + * for an object. Handles the following syntax: + * + * itcl_initoptions + * ?<optionName> <optionValue> <optionName> <optionValue> ...? + * FIXME !!!! seems no longer been used !!! + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_BiInitOptionsCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr; + ItclObject *ioPtr; + ItclDelegatedOption *idoptPtr; + ItclOption *ioptPtr; + FOREACH_HASH_DECLS; + + /* instead ::itcl::builtin::initoptions in ../library/itclHullCmds.tcl is used !! */ + ItclShowArgs(1, "Itcl_BiInitOptionsCmd", objc, objv); + if (!infoPtr->itclHullCmdsInitted) { + result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0); + if (result != TCL_OK) { + return result; + } + infoPtr->itclHullCmdsInitted = 1; + } + result = Tcl_EvalObjv(interp, objc, objv, 0); + iclsPtr = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + /* first handle delegated options */ + FOREACH_HASH_VALUE(idoptPtr, &ioPtr->objectDelegatedOptions) { +fprintf(stderr, "delopt!%s!\n", Tcl_GetString(idoptPtr->namePtr)); + } + FOREACH_HASH_VALUE(ioptPtr, &ioPtr->objectOptions) { +fprintf(stderr, "opt!%s!\n", Tcl_GetString(ioptPtr->namePtr)); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiKeepComponentOptionCmd() + * + * Invoked by Tcl during evaluating constructor whenever + * the "keepcomponentoption" command is invoked to list the options + * to be kept when and ::itcl::extendedclass component has been setup + * for an object. Handles the following syntax: + * + * keepcomponentoption <componentName> <optionName> ?<optionName> ...? + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_BiKeepComponentOptionCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + + ItclShowArgs(1, "Itcl_BiKeepComponentOptionCmd", objc, objv); + if (!infoPtr->itclHullCmdsInitted) { + result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0); + if (result != TCL_OK) { + return result; + } + infoPtr->itclHullCmdsInitted = 1; + } + result = Tcl_EvalObjv(interp, objc, objv, 0); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiIgnoreComponentOptionCmd() + * + * Invoked by Tcl during evaluating constructor whenever + * the "keepcomponentoption" command is invoked to list the options + * to be kept when and ::itcl::extendedclass component has been setup + * for an object. Handles the following syntax: + * + * ignorecomponentoption <componentName> <optionName> ?<optionName> ...? + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_BiIgnoreComponentOptionCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr2; + Tcl_Obj *objPtr; + ItclClass *iclsPtr; + ItclObject *ioPtr; + ItclDelegatedOption *idoPtr; + ItclComponent *icPtr; + const char *val; + int idx; + int isNew; + int result; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + + ItclShowArgs(0, "Itcl_BiIgnoreComponentOptionCmd", objc, objv); + if (!infoPtr->itclHullCmdsInitted) { + result = Tcl_Eval(interp, initHullCmdsScript); + if (result != TCL_OK) { + return result; + } + infoPtr->itclHullCmdsInitted = 1; + } + iclsPtr = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (objc < 3) { + Tcl_AppendResult(interp, "wrong # args, should be: ", + "ignorecomponentoption component option ?option ...?", NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&ioPtr->objectComponents, (char *)objv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, + "ignorecomponentoption cannot find component \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + icPtr = Tcl_GetHashValue(hPtr); + icPtr->haveKeptOptions = 1; + for (idx = 2; idx < objc; idx++) { + hPtr = Tcl_CreateHashEntry(&icPtr->keptOptions, (char *)objv[idx], + &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, objv[idx]); + } + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions, + (char *)objv[idx], &isNew); + if (isNew) { + idoPtr = (ItclDelegatedOption *)ckalloc(sizeof( + ItclDelegatedOption)); + memset(idoPtr, 0, sizeof(ItclDelegatedOption)); + Tcl_InitObjHashTable(&idoPtr->exceptions); + idoPtr->namePtr = objv[idx]; + Tcl_IncrRefCount(idoPtr->namePtr); + idoPtr->resourceNamePtr = NULL; + if (idoPtr->resourceNamePtr != NULL) { + Tcl_IncrRefCount(idoPtr->resourceNamePtr); + } + idoPtr->classNamePtr = NULL; + if (idoPtr->classNamePtr != NULL) { + Tcl_IncrRefCount(idoPtr->classNamePtr); + } + idoPtr->icPtr = icPtr; + idoPtr->ioptPtr = NULL; + Tcl_SetHashValue(hPtr2, idoPtr); + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), + NULL, ioPtr, iclsPtr); + if (val != NULL) { + objPtr = Tcl_NewStringObj(val, -1); + Tcl_AppendToObj(objPtr, " cget ", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(objv[idx]), -1); + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); + if (result == TCL_OK) { + ItclSetInstanceVar(interp, "itcl_options", + Tcl_GetString(objv[idx]), + Tcl_GetStringResult(interp), ioPtr, iclsPtr); + } + } + } + } + ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr); + } + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclClass.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclClass.c new file mode 100644 index 0000000..af02d6e --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclClass.c @@ -0,0 +1,2640 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle class definitions. Classes are composed of + * data members (public/protected/common) and the member functions + * (methods/procs) that operate on them. Each class has its own + * namespace which manages the class scope. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann Copyright (c) 2007 + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +static Tcl_NamespaceDeleteProc* _TclOONamespaceDeleteProc = NULL; +static void ItclDeleteOption(char *cdata); + +/* + * FORWARD DECLARATIONS + */ +static void ItclDestroyClass(ClientData cdata); +static void ItclFreeClass (char* cdata); +static void ItclDeleteFunction(ItclMemberFunc *imPtr); +static void ItclDeleteComponent(ItclComponent *icPtr); +static void ItclDeleteOption(char *cdata); + +void +ItclPreserveClass( + ItclClass *iclsPtr) +{ + iclsPtr->refCount++; +} + +void +ItclReleaseClass( + ClientData clientData) +{ + ItclClass *iclsPtr = (ItclClass *)clientData; + + if (--iclsPtr->refCount == 0) { + ItclFreeClass((char *) clientData); + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteMemberFunc() + * + * ------------------------------------------------------------------------ + */ + +void Itcl_DeleteMemberFunc ( + char *cdata) +{ + /* needed for stubs compatibility */ + ItclMemberFunc *imPtr; + + imPtr = (ItclMemberFunc *)cdata; + if (imPtr == NULL) { + /* FIXME need code here */ + } + ItclDeleteFunction((ItclMemberFunc *)cdata); +} + +/* + * ------------------------------------------------------------------------ + * ItclDestroyClass2() + * + * ------------------------------------------------------------------------ + */ + +static void +ItclDestroyClass2( + ClientData clientData) /* The class being deleted. */ +{ + ItclClass *iclsPtr; + + iclsPtr = clientData; + ItclDestroyClassNamesp(iclsPtr); + ItclReleaseClass(iclsPtr); +} + +/* + * ------------------------------------------------------------------------ + * ClassCmdDeleteTrace() + * + * ------------------------------------------------------------------------ + */ + +static void +ClassCmdDeleteTrace( + ClientData clientData, /* The class being deleted. */ + Tcl_Interp *interp, /* The interpreter containing the object. */ + const char *oldName, /* What the object was (last) called. */ + const char *newName, /* Always NULL. */ + int flags) /* Why was the object deleted? */ +{ + Tcl_HashEntry *hPtr; + Tcl_DString buffer; + Tcl_Namespace *nsPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr = clientData; + + /* + * How is it decided what cleanup is done here tracing the access command deletion, + * versus what cleanup is done by the Tcl_CmdDeleteProc tied to the access command? + */ + + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); + if (hPtr == NULL) { + return; + } + if (iclsPtr->flags & ITCL_CLASS_IS_RENAMED) { /* DUMB! name for this flag */ + return; /* Flag very likely serves no purpose as well. */ + } + iclsPtr->flags |= ITCL_CLASS_IS_RENAMED; /* DUMB! name for this flag */ + ItclPreserveClass(iclsPtr); + /* delete the namespace for the common variables */ + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1); + nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + if (!(iclsPtr->flags & ITCL_CLASS_NS_IS_DESTROYED)) { + ItclDestroyClassNamesp(iclsPtr); + } + ItclReleaseClass(iclsPtr); + return; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDeleteClassMetadata() + * + * Delete the metadata data if any + *------------------------------------------------------------------------- + */ +void +ItclDeleteClassMetadata( + ClientData clientData) +{ + /* + * This is how we get alerted from TclOO that the object corresponding + * to an Itcl class (or its namespace...) is being torn down. + */ + + ItclClass *iclsPtr = clientData; + Tcl_Object oPtr = iclsPtr->oPtr; + Tcl_Namespace *ooNsPtr = Tcl_GetObjectNamespace(oPtr); + + if (ooNsPtr != iclsPtr->nsPtr) { + /* + * Itcl's idea of the class namespace is different from that of TclOO. + * Make sure both get torn down and pulled from tables. + */ + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, + (char *)ooNsPtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteNamespace(iclsPtr->nsPtr); + } else { + ItclDestroyClass2(iclsPtr); + } + ItclReleaseClass(iclsPtr); +} + +static int +CallNewObjectInstance( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ItclObjectInfo *infoPtr = data[0]; + const char* path = data[1]; + Tcl_Object *oPtr = data[2]; + Tcl_Obj *nameObjPtr = data[3]; + + *oPtr = Tcl_NewObjectInstance(interp, infoPtr->clazzClassPtr, + path, path, 0, NULL, 0); + if (*oPtr == NULL) { + Tcl_AppendResult(interp, + "ITCL: cannot create Tcl_NewObjectInstance for class \"", + Tcl_GetString(nameObjPtr), "\"", NULL); + return TCL_ERROR; + } + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_CreateClass() + * + * Creates a namespace and its associated class definition data. + * If a namespace already exists with that name, then this routine + * returns TCL_ERROR, along with an error message in the interp. + * If successful, it returns TCL_OK and a pointer to the new class + * definition. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateClass( + Tcl_Interp* interp, /* interpreter that will contain new class */ + const char* path, /* name of new class */ + ItclObjectInfo *infoPtr, /* info for all known objects */ + ItclClass **rPtr) /* returns: pointer to class definition */ +{ + const char *head; + const char *tail; + Tcl_DString buffer; + Tcl_Command cmd; + Tcl_CmdInfo cmdInfo; + Tcl_Namespace *classNs, *ooNs; + Tcl_Object oPtr; + Tcl_Obj *nameObjPtr; + Tcl_Obj *namePtr; + ItclClass *iclsPtr; + ItclVariable *ivPtr; + Tcl_HashEntry *hPtr; + void *callbackPtr; + int result; + int newEntry; + ItclResolveInfo *resolveInfoPtr; + Tcl_Obj *cmdNamePtr; + + /* + * check for an empty class name to avoid a crash + */ + if (strlen(path) == 0) { + Tcl_AppendResult(interp, "invalid class name \"\"", NULL); + return TCL_ERROR; + } + /* + * Make sure that a class with the given name does not + * already exist in the current namespace context. If a + * namespace exists, that's okay. It may have been created + * to contain stubs during a "namespace import" operation. + * We'll just replace the namespace data below with the + * proper class data. + */ + classNs = Tcl_FindNamespace(interp, (const char *)path, + (Tcl_Namespace*)NULL, /* flags */ 0); + + if (classNs != NULL && Itcl_IsClassNamespace(classNs)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "class \"", path, "\" already exists", + (char*)NULL); + return TCL_ERROR; + } + + oPtr = NULL; + /* + * Make sure that a command with the given class name does not + * already exist in the current namespace. This prevents the + * usual Tcl commands from being clobbered when a programmer + * makes a bogus call like "class info". + */ + cmd = Tcl_FindCommand(interp, (const char *)path, + (Tcl_Namespace*)NULL, /* flags */ TCL_NAMESPACE_ONLY); + + if (cmd != NULL && !Itcl_IsStub(cmd)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", path, "\" already exists", + (char*)NULL); + + if (strstr(path,"::") == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " in namespace \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char*)NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the class name does not have any goofy + * characters: + * + * . => reserved for member access like: class.publicVar + */ + Itcl_ParseNamespPath(path, &buffer, &head, &tail); + + if (strstr(tail,".")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad class name \"", tail, "\"", + (char*)NULL); + Tcl_DStringFree(&buffer); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer); + + /* + * Allocate class definition data. + */ + iclsPtr = (ItclClass*)ckalloc(sizeof(ItclClass)); + memset(iclsPtr, 0, sizeof(ItclClass)); + iclsPtr->interp = interp; + iclsPtr->infoPtr = infoPtr; + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_InitObjHashTable(&iclsPtr->variables); + Tcl_InitObjHashTable(&iclsPtr->functions); + Tcl_InitObjHashTable(&iclsPtr->options); + Tcl_InitObjHashTable(&iclsPtr->components); + Tcl_InitObjHashTable(&iclsPtr->delegatedOptions); + Tcl_InitObjHashTable(&iclsPtr->delegatedFunctions); + Tcl_InitObjHashTable(&iclsPtr->methodVariables); + Tcl_InitObjHashTable(&iclsPtr->resolveCmds); + + iclsPtr->numInstanceVars = 0; + Tcl_InitHashTable(&iclsPtr->classCommons, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iclsPtr->contextCache, TCL_ONE_WORD_KEYS); + + Itcl_InitList(&iclsPtr->bases); + Itcl_InitList(&iclsPtr->derived); + + resolveInfoPtr = (ItclResolveInfo *) ckalloc(sizeof(ItclResolveInfo)); + memset (resolveInfoPtr, 0, sizeof(ItclResolveInfo)); + resolveInfoPtr->flags = ITCL_RESOLVE_CLASS; + resolveInfoPtr->iclsPtr = iclsPtr; + iclsPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve)); + iclsPtr->resolvePtr->cmdProcPtr = Itcl_CmdAliasProc; + iclsPtr->resolvePtr->varProcPtr = Itcl_VarAliasProc; + iclsPtr->resolvePtr->clientData = resolveInfoPtr; + iclsPtr->flags = infoPtr->currClassFlags; + + /* + * Initialize the heritage info--each class starts with its + * own class definition in the heritage. Base classes are + * added to the heritage from the "inherit" statement. + */ + Tcl_InitHashTable(&iclsPtr->heritage, TCL_ONE_WORD_KEYS); + (void) Tcl_CreateHashEntry(&iclsPtr->heritage, (char*)iclsPtr, &newEntry); + + /* + * Create a namespace to represent the class. Add the class + * definition info as client data for the namespace. If the + * namespace already exists, then replace any existing client + * data with the class data. + */ + + ItclPreserveClass(iclsPtr); + + nameObjPtr = Tcl_NewStringObj("", 0); + Tcl_IncrRefCount(nameObjPtr); + if ((path[0] != ':') || (path[1] != ':')) { + Tcl_Namespace *currNsPtr = Tcl_GetCurrentNamespace(interp); + Tcl_AppendToObj(nameObjPtr, currNsPtr->fullName, -1); + if (currNsPtr->parentPtr != NULL) { + Tcl_AppendToObj(nameObjPtr, "::", 2); + } + } + Tcl_AppendToObj(nameObjPtr, path, -1); + { + /* + * TclOO machinery will refuse to overwrite an existing command + * with creation of a new object. However, Itcl has a legacy + * "stubs" auto-importing mechanism that explicitly needs such + * overwriting. So, check whether we have a stub, and if so, + * delete it before TclOO has a chance to object. + */ + Tcl_Command oldCmd = Tcl_FindCommand(interp, path, NULL, 0); + + if (Itcl_IsStub(oldCmd)) { + Tcl_DeleteCommandFromToken(interp, oldCmd); + } + } + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + /* + * Create a command in the current namespace to manage the class: + * <className> + * <className> <objName> ?<constructor-args>? + */ + Tcl_NRAddCallback(interp, CallNewObjectInstance, infoPtr, + (ClientData)path, &oPtr, nameObjPtr); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + if (result == TCL_ERROR) { + result = TCL_ERROR; + goto errorOut; + } + iclsPtr->clsPtr = Tcl_GetObjectAsClass(oPtr); + iclsPtr->oPtr = oPtr; + ItclPreserveClass(iclsPtr); + Tcl_ObjectSetMetadata(iclsPtr->oPtr, infoPtr->class_meta_type, iclsPtr); + cmd = Tcl_GetObjectCommand(iclsPtr->oPtr); + Tcl_GetCommandInfoFromToken(cmd, &cmdInfo); + cmdInfo.deleteProc = ItclDestroyClass; + cmdInfo.deleteData = iclsPtr; + Tcl_SetCommandInfoFromToken(cmd, &cmdInfo); + ooNs = Tcl_GetObjectNamespace(oPtr); + classNs = Tcl_FindNamespace(interp, Tcl_GetString(nameObjPtr), + (Tcl_Namespace*)NULL, /* flags */ 0); + if (_TclOONamespaceDeleteProc == NULL) { + _TclOONamespaceDeleteProc = ooNs->deleteProc; + } + + if (classNs == NULL) { + Tcl_AppendResult(interp, + "ITCL: cannot create/get class namespace for class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); + return TCL_ERROR; + } + + if (iclsPtr->infoPtr->useOldResolvers) { +#ifdef NEW_PROTO_RESOLVER + Itcl_SetNamespaceResolvers(ooNs, + (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver2, + (Tcl_ResolveVarProc*)Itcl_ClassVarResolver2, + (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver2); + Itcl_SetNamespaceResolvers(classNs, + (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver2, + (Tcl_ResolveVarProc*)Itcl_ClassVarResolver2, + (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver2); +#else + Itcl_SetNamespaceResolvers(ooNs, + (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, + (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, + (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); + Itcl_SetNamespaceResolvers(classNs, + (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, + (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, + (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); +#endif + } else { + Tcl_SetNamespaceResolver(ooNs, iclsPtr->resolvePtr); + Tcl_SetNamespaceResolver(classNs, iclsPtr->resolvePtr); + } + iclsPtr->nsPtr = classNs; + + + iclsPtr->namePtr = Tcl_NewStringObj(classNs->name, -1); + Tcl_IncrRefCount(iclsPtr->namePtr); + + iclsPtr->fullNamePtr = Tcl_NewStringObj(classNs->fullName, -1); + Tcl_IncrRefCount(iclsPtr->fullNamePtr); + + hPtr = Tcl_CreateHashEntry(&infoPtr->nameClasses, + (char *)iclsPtr->fullNamePtr, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + + + hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)classNs, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + if (classNs != ooNs) { + hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)ooNs, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + + if (classNs->clientData && classNs->deleteProc) { + (*classNs->deleteProc)(classNs->clientData); + } + classNs->clientData = (ClientData)iclsPtr; + classNs->deleteProc = ItclDestroyClass2; +} + + hPtr = Tcl_CreateHashEntry(&infoPtr->classes, (char *)iclsPtr, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + + /* + * now build the namespace for the common private and protected variables + * public variables go directly to the class namespace + */ + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1); + if ((NULL == Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, + TCL_GLOBAL_ONLY)) && (NULL == Tcl_CreateNamespace(interp, + Tcl_DStringValue(&buffer), NULL, 0))) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "ITCL: cannot create variables namespace \"", + Tcl_DStringValue(&buffer), "\"", NULL); + result = TCL_ERROR; + goto errorOut; + } + + /* + * Add the built-in "this" command to the list of function members. + */ + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_DStringAppend(&buffer, "::this", -1); + iclsPtr->thisCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + Itcl_ThisCmd, iclsPtr, NULL); + + /* + * Add the built-in "type" variable to the list of data members. + */ + if (iclsPtr->flags & ITCL_TYPE) { + namePtr = Tcl_NewStringObj("type", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_TYPE_VAR; /* mark as "type" variable */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + } + + if (iclsPtr->flags & (ITCL_ECLASS)) { + namePtr = Tcl_NewStringObj("win", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + } + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + namePtr = Tcl_NewStringObj("self", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_SELF_VAR; /* mark as "self" variable */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + + namePtr = Tcl_NewStringObj("selfns", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_SELFNS_VAR; /* mark as "selfns" variable */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + + namePtr = Tcl_NewStringObj("win", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + } + namePtr = Tcl_NewStringObj("this", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ + + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + + if (infoPtr->currClassFlags & + (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET)) { + /* + * Add the built-in "itcl_options" variable to the list of + * data members. + */ + namePtr = Tcl_NewStringObj("itcl_options", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_OPTIONS_VAR; /* mark as "itcl_options" + * variable */ + + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + + } + if (infoPtr->currClassFlags & + ITCL_ECLASS) { + /* + * Add the built-in "itcl_option_components" variable to the list of + * data members. + */ + namePtr = Tcl_NewStringObj("itcl_option_components", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_OPTION_COMP_VAR; /* mark as "itcl_option_components" + * variable */ + + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + + } + if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + /* + * Add the built-in "thiswin" variable to the list of data members. + */ + namePtr = Tcl_NewStringObj("thiswin", -1); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, + (char*)NULL, &ivPtr); + + ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ + ivPtr->flags |= ITCL_THIS_VAR; /* mark as "thiswin" variable */ + + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, + &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + } + if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + /* create the itcl_hull component */ + ItclComponent *icPtr; + namePtr = Tcl_NewStringObj("itcl_hull", 9); + /* itcl_hull must not be an ITCL_COMMON!! */ + if (ItclCreateComponent(interp, iclsPtr, namePtr, 0, &icPtr) != + TCL_OK) { + result = TCL_ERROR; + goto errorOut; + } + } + + ItclPreserveClass(iclsPtr); + iclsPtr->accessCmd = Tcl_GetObjectCommand(oPtr); + + cmdNamePtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, iclsPtr->accessCmd, cmdNamePtr); + + Tcl_TraceCommand(interp, Tcl_GetString(cmdNamePtr), + TCL_TRACE_DELETE, ClassCmdDeleteTrace, iclsPtr); + + Tcl_DecrRefCount(cmdNamePtr); + /* FIXME should set the class objects unknown command to Itcl_HandleClass */ + + *rPtr = iclsPtr; + result = TCL_OK; +errorOut: + Tcl_DecrRefCount(nameObjPtr); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDeleteClassVariablesNamespace() + * + * ------------------------------------------------------------------------ + */ +void +ItclDeleteClassVariablesNamespace( + Tcl_Interp *interp, + ItclClass *iclsPtr) +{ + /* TODO: why is this being skipped? */ + return; +} + +static int +CallDeleteOneObject( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch place; + ItclClass *iclsPtr2 = NULL; + ItclObject *contextIoPtr; + ItclClass *iclsPtr = data[0]; + ItclObjectInfo *infoPtr = data[1]; + void *callbackPtr; + int classIsDeleted; + + if (result != TCL_OK) { + return result; + } + classIsDeleted = 0; + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); + if (hPtr == NULL) { + classIsDeleted = 1; + } + if (classIsDeleted) { + return result; + } + /* + * Fix 227804: Whenever an object to delete was found we + * have to reset the search to the beginning as the + * current entry in the search was deleted and accessing it + * is therefore not allowed anymore. + */ + + hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); + if (hPtr) { + contextIoPtr = (ItclObject*)Tcl_GetHashValue(hPtr); + + while (contextIoPtr->iclsPtr != iclsPtr) { + hPtr = Tcl_NextHashEntry(&place); + if (hPtr == NULL) { + break; + } + } + if (hPtr) { + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + if (Itcl_DeleteObject(interp, contextIoPtr) != TCL_OK) { + iclsPtr2 = iclsPtr; + goto deleteClassFail; + } + + Tcl_NRAddCallback(interp, CallDeleteOneObject, iclsPtr, + infoPtr, NULL, NULL); + return Itcl_NRRunCallbacks(interp, callbackPtr); + } + + } + + return TCL_OK; + +deleteClassFail: + /* check if class is not yet deleted */ + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr2); + if (hPtr != NULL) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while deleting class \"%s\")", + iclsPtr2->nsPtr->fullName)); + } + return TCL_ERROR; +} + +static int +CallDeleteOneClass( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_HashEntry *hPtr; + ItclClass *iclsPtr = data[0]; + ItclObjectInfo *infoPtr = data[1]; + int isDerivedReleased; + + if (result != TCL_OK) { + return result; + } + isDerivedReleased = iclsPtr->flags & ITCL_CLASS_DERIVED_RELEASED; + result = Itcl_DeleteClass(interp, iclsPtr); + if (!isDerivedReleased) { + if (result == TCL_OK) { + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); + if (hPtr != NULL) { + /* release from derived reference */ + ItclReleaseClass(iclsPtr); + } + } + } + if (result == TCL_OK) { + return TCL_OK; + } + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while deleting class \"%s\")", + iclsPtr->nsPtr->fullName)); + return TCL_ERROR; +} +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteClass() + * + * Deletes a class by deleting all derived classes and all objects in + * that class, and finally, by destroying the class namespace. This + * procedure provides a friendly way of doing this. If any errors + * are detected along the way, the process is aborted. + * + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_DeleteClass( + Tcl_Interp *interp, /* interpreter managing this class */ + ItclClass *iclsPtr) /* class */ +{ + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr2 = NULL; + Itcl_ListElem *elem; + void *callbackPtr; + int result; + + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); + if (hPtr == NULL) { + /* class has already been deleted */ + return TCL_OK; + } + if (iclsPtr->flags & ITCL_CLASS_IS_DELETED) { + return TCL_OK; + } + iclsPtr->flags |= ITCL_CLASS_IS_DELETED; + /* + * Destroy all derived classes, since these lose their meaning + * when the base class goes away. If anything goes wrong, + * abort with an error. + * + * TRICKY NOTE: When a derived class is destroyed, it + * automatically deletes itself from the "derived" list. + */ + elem = Itcl_FirstListElem(&iclsPtr->derived); + while (elem) { + iclsPtr2 = (ItclClass*)Itcl_GetListValue(elem); + elem = Itcl_NextListElem(elem); /* advance here--elem will go away */ + + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + Tcl_NRAddCallback(interp, CallDeleteOneClass, iclsPtr2, + iclsPtr2->infoPtr, NULL, NULL); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + if (result != TCL_OK) { + return result; + } + } + + /* + * Scan through and find all objects that belong to this class. + * Note that more specialized objects have already been + * destroyed above, when derived classes were destroyed. + * Destroy objects and report any errors. + */ + /* + * we have to enroll the while loop to fit for NRE + * so we add a callback to delete the first element + * and run this callback. At the end of the execution of that callback + * we add eventually a callback for the next element and run that etc ... + * if an error occurs we terminate the enrolled loop and return + * otherwise we return at the end of the enrolled loop. + */ + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + Tcl_NRAddCallback(interp, CallDeleteOneObject, iclsPtr, + iclsPtr->infoPtr, NULL, NULL); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + if (result != TCL_OK) { + return result; + } + /* + * Destroy the namespace associated with this class. + * + * TRICKY NOTE: + * The cleanup procedure associated with the namespace is + * invoked automatically. It does all of the same things + * above, but it also disconnects this class from its + * base-class lists, and removes the class access command. + */ + ItclDeleteClassVariablesNamespace(interp, iclsPtr); + Tcl_DeleteNamespace(iclsPtr->nsPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDestroyClass() + * + * Invoked whenever the access command for a class is destroyed. + * Destroys the namespace associated with the class, which also + * destroys all objects in the class and all derived classes. + * Disconnects this class from the "derived" class lists of its + * base classes, and releases any claim to the class definition + * data. If this is the last use of that data, the class will + * completely vanish at this point. + * ------------------------------------------------------------------------ + */ +static void +ItclDestroyClass( + ClientData cdata) /* class definition to be destroyed */ +{ + ItclClass *iclsPtr = (ItclClass*)cdata; + + if (iclsPtr->flags & ITCL_CLASS_IS_DESTROYED) { + return; + } + iclsPtr->flags |= ITCL_CLASS_IS_DESTROYED; + if (!(iclsPtr->flags & ITCL_CLASS_NS_IS_DESTROYED)) { + if (iclsPtr->accessCmd) { + Tcl_DeleteCommandFromToken(iclsPtr->interp, iclsPtr->accessCmd); + iclsPtr->accessCmd = NULL; + } + Tcl_DeleteNamespace(iclsPtr->nsPtr); + } + ItclReleaseClass(iclsPtr); +} + + +/* + * ------------------------------------------------------------------------ + * ItclDestroyClassNamesp() + * + * Invoked whenever the namespace associated with a class is destroyed. + * Destroys all objects associated with this class and all derived + * classes. Disconnects this class from the "derived" class lists + * of its base classes, and removes the class access command. Releases + * any claim to the class definition data. If this is the last use + * of that data, the class will completely vanish at this point. + * ------------------------------------------------------------------------ + */ +void +ItclDestroyClassNamesp( + ClientData cdata) /* class definition to be destroyed */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch place; + Tcl_Command cmdPtr; + ItclClass *iclsPtr; + ItclObject *ioPtr; + Itcl_ListElem *elem; + Itcl_ListElem *belem; + ItclClass *iclsPtr2; + ItclClass *basePtr; + ItclClass *derivedPtr; + + + iclsPtr = (ItclClass*)cdata; + if (iclsPtr->flags & ITCL_CLASS_NS_IS_DESTROYED) { + return; + } + iclsPtr->flags |= ITCL_CLASS_NS_IS_DESTROYED; + /* + * Destroy all derived classes, since these lose their meaning + * when the base class goes away. + * + * TRICKY NOTE: When a derived class is destroyed, it + * automatically deletes itself from the "derived" list. + */ + elem = Itcl_FirstListElem(&iclsPtr->derived); + while (elem) { + iclsPtr2 = (ItclClass*)Itcl_GetListValue(elem); + if (iclsPtr2->nsPtr != NULL) { + Tcl_DeleteNamespace(iclsPtr2->nsPtr); + } + + /* As the first namespace is now destroyed we have to get the + * new first element of the hash table. We cannot go to the + * next element from the current one, because the current one + * is deleted. itcl Patch #593112, for Bug #577719. + */ + + elem = Itcl_FirstListElem(&iclsPtr->derived); + } + + /* + * Scan through and find all objects that belong to this class. + * Destroy them quietly by deleting their access command. + */ + hPtr = Tcl_FirstHashEntry(&iclsPtr->infoPtr->objects, &place); + while (hPtr) { + ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr); + if (ioPtr->iclsPtr == iclsPtr) { + if ((ioPtr->accessCmd != NULL) && (!(ioPtr->flags & + (ITCL_OBJECT_IS_DESTRUCTED)))) { + ItclPreserveObject(ioPtr); + Tcl_DeleteCommandFromToken(iclsPtr->interp, ioPtr->accessCmd); + ioPtr->accessCmd = NULL; + ItclReleaseObject(ioPtr); + /* + * Fix 227804: Whenever an object to delete was found we + * have to reset the search to the beginning as the + * current entry in the search was deleted and accessing it + * is therefore not allowed anymore. + */ + + hPtr = Tcl_FirstHashEntry(&iclsPtr->infoPtr->objects, &place); + continue; + } + } + hPtr = Tcl_NextHashEntry(&place); + } + + /* + * Next, remove this class from the "derived" list in + * all base classes. + */ + belem = Itcl_FirstListElem(&iclsPtr->bases); + while (belem) { + basePtr = (ItclClass*)Itcl_GetListValue(belem); + + elem = Itcl_FirstListElem(&basePtr->derived); + while (elem) { + derivedPtr = (ItclClass*)Itcl_GetListValue(elem); + if (derivedPtr == iclsPtr) { + derivedPtr->flags |= ITCL_CLASS_DERIVED_RELEASED; + ItclReleaseClass(derivedPtr); + elem = Itcl_DeleteListElem(elem); + } else { + elem = Itcl_NextListElem(elem); + } + } + belem = Itcl_NextListElem(belem); + } + + /* + * Next, destroy the access command associated with the class. + */ + iclsPtr->flags |= ITCL_CLASS_NS_TEARDOWN; + if (iclsPtr->accessCmd) { + cmdPtr = iclsPtr->accessCmd; + iclsPtr->accessCmd = NULL; + Tcl_DeleteCommandFromToken(iclsPtr->interp, cmdPtr); + } + + /* + * Release the namespace's claim on the class definition. + */ + ItclReleaseClass(iclsPtr); +} + + +/* + * ------------------------------------------------------------------------ + * ItclFreeClass() + * + * Frees all memory associated with a class definition. This is + * usually invoked automatically by Itcl_ReleaseData(), when class + * data is no longer being used. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeClass( + char *cdata) /* class definition to be destroyed */ +{ + FOREACH_HASH_DECLS; + Tcl_HashSearch place; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + ItclVariable *ivPtr; + ItclOption *ioptPtr; + ItclComponent *icPtr; + ItclDelegatedOption *idoPtr; + ItclDelegatedFunction *idmPtr; + Itcl_ListElem *elem; + ItclVarLookup *vlookup; + ItclCmdLookup *clookupPtr; + Tcl_Var var; + + iclsPtr = (ItclClass*)cdata; + if (iclsPtr->flags & ITCL_CLASS_IS_FREED) { + return; + } + ItclDeleteClassesDictInfo(iclsPtr->interp, iclsPtr); + iclsPtr->flags |= ITCL_CLASS_IS_FREED; + + /* + * Tear down the list of derived classes. This list should + * really be empty if everything is working properly, but + * release it here just in case. + */ + elem = Itcl_FirstListElem(&iclsPtr->derived); + while (elem) { + ItclReleaseClass( Itcl_GetListValue(elem) ); + elem = Itcl_NextListElem(elem); + } + Itcl_DeleteList(&iclsPtr->derived); + + /* + * Tear down the variable resolution table. Some records + * appear multiple times in the table (for x, foo::x, etc.) + * so each one has a reference count. + */ +/* Tcl_InitHashTable(&varTable, TCL_STRING_KEYS); */ + + FOREACH_HASH_VALUE(vlookup, &iclsPtr->resolveVars) { + if (--vlookup->usage == 0) { + /* + * If this is a common variable owned by this class, + * then release the class's hold on it. FIXME !!! + */ + ckfree((char*)vlookup); + } + } + + Tcl_DeleteHashTable(&iclsPtr->resolveVars); + + /* + * Tear down the virtual method table... + */ + while (1) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place); + if (hPtr == NULL) { + break; + } + clookupPtr = Tcl_GetHashValue(hPtr); + ckfree((char *)clookupPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&iclsPtr->resolveCmds); + + /* + * Delete all option definitions. + */ + while (1) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->options, &place); + if (hPtr == NULL) { + break; + } + ioptPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + Itcl_ReleaseData(ioptPtr); + } + Tcl_DeleteHashTable(&iclsPtr->options); + + /* + * Delete all function definitions. + */ + FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { + imPtr->iclsPtr = NULL; + ItclReleaseIMF(imPtr); + } + Tcl_DeleteHashTable(&iclsPtr->functions); + + /* + * Delete all delegated options. + */ + FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { + Itcl_ReleaseData(idoPtr); + } + Tcl_DeleteHashTable(&iclsPtr->delegatedOptions); + + /* + * Delete all delegated functions. + */ + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (idmPtr->icPtr != NULL) { + if (idmPtr->icPtr->ivPtr->iclsPtr == iclsPtr) { + ItclDeleteDelegatedFunction(idmPtr); + } + } + } + Tcl_DeleteHashTable(&iclsPtr->delegatedFunctions); + + /* + * Delete all components + */ + while (1) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); + if (hPtr == NULL) { + break; + } + icPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (icPtr != NULL) { + ItclDeleteComponent(icPtr); + } + } + Tcl_DeleteHashTable(&iclsPtr->components); + + /* + * Delete all variable definitions. + */ + while (1) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place); + if (hPtr == NULL) { + break; + } + ivPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (ivPtr != NULL) { + Itcl_ReleaseData(ivPtr); + } + } + Tcl_DeleteHashTable(&iclsPtr->variables); + + /* + * Release the claim on all base classes. + */ + elem = Itcl_FirstListElem(&iclsPtr->bases); + while (elem) { + ItclReleaseClass( Itcl_GetListValue(elem) ); + elem = Itcl_NextListElem(elem); + } + Itcl_DeleteList(&iclsPtr->bases); + Tcl_DeleteHashTable(&iclsPtr->heritage); + + /* remove owerself from the all classes entry */ + hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->nameClasses, + (char *)iclsPtr->fullNamePtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* remove owerself from the all namespaceClasses entry */ + hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, + (char *)iclsPtr->nsPtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* remove owerself from the all classes entry */ + hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->classes, (char *)iclsPtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* FIXME !!! + free contextCache + free resolvePtr -- this is only needed for CallFrame Resolvers + -- not used at the moment + */ + + FOREACH_HASH_VALUE(var, &iclsPtr->classCommons) { + Itcl_ReleaseVar(var); + } + Tcl_DeleteHashTable(&iclsPtr->classCommons); + + /* + * Free up the widget class name + */ + if (iclsPtr->widgetClassPtr != NULL) { + Tcl_DecrRefCount(iclsPtr->widgetClassPtr); + } + + /* + * Free up the widget hulltype name + */ + if (iclsPtr->hullTypePtr != NULL) { + Tcl_DecrRefCount(iclsPtr->hullTypePtr); + } + + /* + * Free up the type typeconstrutor code + */ + + if (iclsPtr->typeConstructorPtr != NULL) { + Tcl_DecrRefCount(iclsPtr->typeConstructorPtr); + } + + /* + * Free up the object initialization code. + */ + if (iclsPtr->initCode) { + Tcl_DecrRefCount(iclsPtr->initCode); + } + + Itcl_ReleaseData((ClientData)iclsPtr->infoPtr); + + Tcl_DecrRefCount(iclsPtr->namePtr); + Tcl_DecrRefCount(iclsPtr->fullNamePtr); + + if (iclsPtr->resolvePtr != NULL) { + ckfree((char *)iclsPtr->resolvePtr->clientData); + ckfree((char *)iclsPtr->resolvePtr); + } + ckfree((char*)iclsPtr); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsClassNamespace() + * + * Checks to see whether or not the given namespace represents an + * [incr Tcl] class. Returns non-zero if so, and zero otherwise. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsClassNamespace( + Tcl_Namespace *nsPtr) /* namespace being tested */ +{ + ItclClass *iclsPtr = ItclNamespace2Class(nsPtr); + return iclsPtr != NULL; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsClass() + * + * Checks the given Tcl command to see if it represents an itcl class. + * Returns non-zero if the command is associated with a class. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsClass( + Tcl_Command cmd) /* command being tested */ +{ + Tcl_CmdInfo cmdInfo; + + if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) == 0) { + return 0; + } + if (cmdInfo.deleteProc == ItclDestroyClass) { + return 1; + } + + /* + * This may be an imported command. Try to get the real + * command and see if it represents a class. + */ + cmd = Tcl_GetOriginalCommand(cmd); + if (cmd != NULL) { + if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) == 0) { + return 0; + } + if (cmdInfo.deleteProc == ItclDestroyClass) { + return 1; + } + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindClass() + * + * Searches for the specified class in the active namespace. If the + * class is found, this procedure returns a pointer to the class + * definition. Otherwise, if the autoload flag is non-zero, an + * attempt will be made to autoload the class definition. If it + * still can't be found, this procedure returns NULL, along with an + * error message in the interpreter. + * ------------------------------------------------------------------------ + */ +ItclClass* +Itcl_FindClass( + Tcl_Interp* interp, /* interpreter containing class */ + const char* path, /* path name for class */ + int autoload) +{ + /* + * Search for a namespace with the specified name, and if + * one is found, see if it is a class namespace. + */ + + Tcl_Namespace* classNs = Itcl_FindClassNamespace(interp, path); + + if (classNs) { + ItclObjectInfo *infoPtr + = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, + (char *) classNs); + if (hPtr) { + return (ItclClass *) Tcl_GetHashValue(hPtr); + } + } + + /* + * If the autoload flag is set, try to autoload the class + * definition, then search again. + */ + if (autoload) { + Tcl_DString buf; + + Tcl_DStringInit(&buf); + Tcl_DStringAppend(&buf, "::auto_load ", -1); + Tcl_DStringAppend(&buf, path, -1); + if (Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0) != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while attempting to autoload class \"%s\")", + path)); + Tcl_DStringFree(&buf); + return NULL; + } + Tcl_ResetResult(interp); + Tcl_DStringFree(&buf); + + return Itcl_FindClass(interp, path, 0); + } + + Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char*)NULL); + + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_FindClassNamespace() + * + * Searches for the specified class namespace. The normal Tcl procedure + * Tcl_FindNamespace also searches for namespaces, but only in the + * current namespace context. This makes it hard to find one class + * from within another. For example, suppose. you have two namespaces + * Foo and Bar. If you're in the context of Foo and you look for + * Bar, you won't find it with Tcl_FindNamespace. This behavior is + * okay for namespaces, but wrong for classes. + * + * This procedure search for a class namespace. If the name is + * absolute (i.e., starts with "::"), then that one name is checked, + * and the class is either found or not. But if the name is relative, + * it is sought in the current namespace context and in the global + * context, just like the normal command lookup. + * + * This procedure returns a pointer to the desired namespace, or + * NULL if the namespace was not found. + * ------------------------------------------------------------------------ + */ +Tcl_Namespace* +Itcl_FindClassNamespace(interp, path) + Tcl_Interp* interp; /* interpreter containing class */ + const char* path; /* path name for class */ +{ + Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp); + Tcl_Namespace *classNs = Tcl_FindNamespace(interp, path, NULL, 0); + + if ( !classNs /* We didn't find it... */ + && contextNs->parentPtr != NULL /* context is not global */ + && (*path != ':' || *(path+1) != ':') /* path not FQ */ + ) { + + if (strcmp(contextNs->name, path) == 0) { + classNs = contextNs; + } else { + classNs = Tcl_FindNamespace(interp, path, NULL, TCL_GLOBAL_ONLY); + } + } + return classNs; +} + + +static int +FinalizeCreateObject( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *objNamePtr = data[0]; + ItclClass *iclsPtr = data[1]; + if (result == TCL_OK) { + if (!(iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_GetString(objNamePtr), NULL); + } + } + Tcl_DecrRefCount(objNamePtr); + return result; +} + +static int +CallCreateObject( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *objNamePtr = data[0]; + ItclClass *iclsPtr = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + + if (result == TCL_OK) { + result = ItclCreateObject(interp, Tcl_GetString(objNamePtr), iclsPtr, + objc, objv); + } + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_HandleClass() + * + * first argument is ::itcl::parser::handleClass + * Invoked by Tcl whenever the user issues the command associated with + * a class name. Handles the following syntax: + * + * <className> + * <className> <objName> ?<args>...? + * + * Without any arguments, the command does nothing. In the olden days, + * this allowed the class name to be invoked by itself to prompt the + * autoloader to load the class definition. Today, this behavior is + * retained for backward compatibility with old releases. + * + * If arguments are specified, then this procedure creates a new + * object named <objName> in the appropriate class. Note that if + * <objName> contains "#auto", that part is automatically replaced + * by a unique string built from the class name. + * ------------------------------------------------------------------------ + */ +int +Itcl_HandleClass( + ClientData clientData, /* class definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + if (objc > 3) { + const char *token = Tcl_GetString(objv[3]); + const char *nsEnd = NULL; + const char *pos = token; + const char *tail = pos; + int fq = 0; + int code = TCL_OK; + Tcl_Obj *nsObj, *fqObj; + + while ((pos = strstr(pos, "::"))) { + if (pos == token) { + fq = 1; + nsEnd = token; + } else if (pos[-1] != ':') { + nsEnd = pos - 1; + } + tail = pos + 2; pos++; + } + + if (fq) { + nsObj = Tcl_NewStringObj(token, nsEnd-token); + } else { + Tcl_Namespace *nsPtr = Tcl_GetCurrentNamespace(interp); + + nsObj = Tcl_NewStringObj(nsPtr->fullName, -1); + if (nsEnd) { + Tcl_AppendToObj(nsObj, "::", 2); + Tcl_AppendToObj(nsObj, token, nsEnd-token); + } + } + + fqObj = Tcl_DuplicateObj(nsObj); + Tcl_AppendToObj(fqObj, "::", 2); + Tcl_AppendToObj(fqObj, tail, -1); + + if (Tcl_GetCommandFromObj(interp, fqObj)) { + Tcl_AppendResult(interp, "command \"", tail, + "\" already exists in namespace \"", Tcl_GetString(nsObj), + "\"", NULL); + code = TCL_ERROR; + } + Tcl_DecrRefCount(fqObj); + Tcl_DecrRefCount(nsObj); + if (code != TCL_OK) { + return code; + } + } + return ItclClassCreateObject(clientData, interp, objc, objv); +} + +int +ItclClassCreateObject( + ClientData clientData, /* IclObjectInfo */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_DString buffer; /* buffer used to build object names */ + Tcl_Obj *objNamePtr; + Tcl_HashEntry *hPtr; + Tcl_Obj **newObjv; + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + void *callbackPtr; + char unique[256]; /* buffer used for unique part of object names */ + char *token; + char *objName; + char tmp; + char *start; + char *pos; + const char *match; + + infoPtr = (ItclObjectInfo *)clientData; + Tcl_ResetResult(interp); + ItclShowArgs(1, "ItclClassCreateObject", objc, objv); + /* + * If the command is invoked without an object name, then do nothing. + * This used to support autoloading--that the class name could be + * invoked as a command by itself, prompting the autoloader to + * load the class definition. We retain the behavior here for + * backward-compatibility with earlier releases. + */ + if (objc <= 3) { + return TCL_OK; + } + + hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "no such class: \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + iclsPtr = Tcl_GetHashValue(hPtr); + + /* + * If the object name is "::", and if this is an old-style class + * definition, then treat the remaining arguments as a command + * in the class namespace. This used to be the way of invoking + * a class proc, but the new syntax is "class::proc" (without + * spaces). + */ + token = Tcl_GetString(objv[3]); + if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 4)) { + /* + * If this is not an old-style class, then return an error + * describing the syntax change. + */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "syntax \"class :: proc\" is an anachronism\n", + "[incr Tcl] no longer supports this syntax.\n", + "Instead, remove the spaces from your procedure invocations:\n", + " ", + Tcl_GetString(objv[1]), "::", + Tcl_GetString(objv[4]), " ?args?", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Otherwise, we have a proper object name. Create a new instance + * with that name. If the name contains "#auto", replace this with + * a uniquely generated string based on the class name. + */ + Tcl_DStringInit(&buffer); + objName = NULL; + + match = "#auto"; + start = token; + for (pos=start; *pos != '\0'; pos++) { + if (*pos == *match) { + if (*(++match) == '\0') { + tmp = *start; + *start = '\0'; /* null-terminate first part */ + + /* + * Substitute a unique part in for "#auto", and keep + * incrementing a counter until a valid name is found. + */ + do { + Tcl_CmdInfo dummy; + + sprintf(unique,"%.200s%d", Tcl_GetString(iclsPtr->namePtr), + iclsPtr->unique++); + unique[0] = tolower(UCHAR(unique[0])); + + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, token, -1); + Tcl_DStringAppend(&buffer, unique, -1); + Tcl_DStringAppend(&buffer, start+5, -1); + + objName = Tcl_DStringValue(&buffer); + + /* + * [Fix 227811] Check for any command with the + * given name, not only objects. + */ + + if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) { + break; /* if an error is found, bail out! */ + } + } while (1); + + *start = tmp; /* undo null-termination */ + objName = Tcl_DStringValue(&buffer); + break; /* object name is ready to go! */ + } + } + else { + match = "#auto"; + pos = start++; + } + } + + /* + * If "#auto" was not found, then just use object name as-is. + */ + if (objName == NULL) { + objName = token; + } + + /* + * Try to create a new object. If successful, return the + * object name as the result of this command. + */ + objNamePtr = Tcl_NewStringObj(objName, -1); + Tcl_IncrRefCount(objNamePtr); + Tcl_DStringFree(&buffer); + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + newObjv = (Tcl_Obj **)(objv+4); + Tcl_NRAddCallback(interp, FinalizeCreateObject, objNamePtr, iclsPtr, + NULL, NULL); + Tcl_NRAddCallback(interp, CallCreateObject, objNamePtr, iclsPtr, + INT2PTR(objc-4), newObjv); + return Itcl_NRRunCallbacks(interp, callbackPtr); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BuildVirtualTables() + * + * Invoked whenever the class heritage changes or members are added or + * removed from a class definition to rebuild the member lookup + * tables. There are two tables: + * + * METHODS: resolveCmds + * Used primarily in Itcl_ClassCmdResolver() to resolve all + * command references in a namespace. + * + * DATA MEMBERS: resolveVars + * Used primarily in Itcl_ClassVarResolver() to quickly resolve + * variable references in each class scope. + * + * These tables store every possible name for each command/variable + * (member, class::member, namesp::class::member, etc.). Members + * in a derived class may shadow members with the same name in a + * base class. In that case, the simple name in the resolution + * table will point to the most-specific member. + * ------------------------------------------------------------------------ + */ +void +Itcl_BuildVirtualTables( + ItclClass* iclsPtr) /* class definition being updated */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch place; + Tcl_Namespace* nsPtr; + Tcl_DString buffer, buffer2; + Tcl_Obj *objPtr; + ItclVarLookup *vlookup; + ItclVariable *ivPtr; + ItclMemberFunc *imPtr; + ItclDelegatedFunction *idmPtr; + ItclHierIter hier; + ItclClass *iclsPtr2; + ItclCmdLookup *clookupPtr; +#ifdef NEW_PROTO_RESOLVER + ItclClassVarInfo *icviPtr; + ItclClassCmdInfo *icciPtr; +#endif + int newEntry; + + Tcl_DStringInit(&buffer); + Tcl_DStringInit(&buffer2); + + /* + * Clear the variable resolution table. + */ + hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveVars, &place); + while (hPtr) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (--vlookup->usage == 0) { + ckfree((char*)vlookup); + } + hPtr = Tcl_NextHashEntry(&place); + } + Tcl_DeleteHashTable(&iclsPtr->resolveVars); + Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_STRING_KEYS); + iclsPtr->numInstanceVars = 0; + + /* + * Set aside the first object-specific slot for the built-in + * "this" variable. Only allocate one of these, even though + * there is a definition for "this" in each class scope. + * Set aside the second and third object-specific slot for the built-in + * "itcl_options" and "itcl_option_components" variable. + */ + iclsPtr->numInstanceVars++; + iclsPtr->numInstanceVars++; + iclsPtr->numInstanceVars++; + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Add a lookup entry for each variable + * into the table. + */ + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr2->variables, &place); + while (hPtr) { +#ifdef NEW_PROTO_RESOLVER + int type = VAR_TYPE_VARIABLE; +#endif + ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); + + vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); + vlookup->ivPtr = ivPtr; + vlookup->usage = 0; + vlookup->leastQualName = NULL; + + /* + * If this variable is PRIVATE to another class scope, + * then mark it as "inaccessible". + */ + vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || + ivPtr->iclsPtr == iclsPtr); + + if (ivPtr->flags & ITCL_COMMON) { +#ifdef NEW_PROTO_RESOLVER + type = VAR_TYPE_COMMON; +#endif + } + /* + * If this is a reference to the built-in "this" + * variable, then its index is "0". Otherwise, + * add another slot to the end of the table. + */ + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + vlookup->varNum = 0; + } else { + if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) { + vlookup->varNum = 1; + } else { + vlookup->varNum = iclsPtr->numInstanceVars++; + } + } +#ifdef NEW_PROTO_RESOLVER + icviPtr = (ItclClassVarInfo *)ckalloc( + sizeof(ItclClassVarInfo)); + icviPtr->type = type; + icviPtr->protection = ivPtr->protection; + icviPtr->nsPtr = iclsPtr->nsPtr; + icviPtr->declaringNsPtr = iclsPtr2->nsPtr; + icviPtr->varNum = vlookup->varNum; + ClientData clientData2; + clientData2 = Itcl_RegisterClassVariable( + iclsPtr->infoPtr->interp, iclsPtr2->nsPtr, + Tcl_GetString(ivPtr->namePtr), icviPtr); + vlookup->classVarInfoPtr = clientData2; +#endif +/* FIXME !!! should use for var lookup !! */ + + /* + * Create all possible names for this variable and enter + * them into the variable resolution table: + * var + * class::var + * namesp1::class::var + * namesp2::namesp1::class::var + * ... + */ + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); + nsPtr = iclsPtr2->nsPtr; + + while (1) { + hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveVars, + Tcl_DStringValue(&buffer), &newEntry); + + if (newEntry) { + Tcl_SetHashValue(hPtr, (ClientData)vlookup); + vlookup->usage++; + + if (!vlookup->leastQualName) { + vlookup->leastQualName = + Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); + } +#ifdef NEW_PROTO_RESOLVER + Itcl_RegisterClassVariable(iclsPtr->infoPtr->interp, + iclsPtr->nsPtr, Tcl_DStringValue(&buffer), + vlookup->classVarInfoPtr); +#endif + } + + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nsPtr->name, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + nsPtr = nsPtr->parentPtr; + } + + /* + * If this record is not needed, free it now. + */ + if (vlookup->usage == 0) { + ckfree((char*)vlookup); + } + hPtr = Tcl_NextHashEntry(&place); + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + /* + * Clear the command resolution table. + */ + while (1) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place); + if (hPtr == NULL) { + break; + } + clookupPtr = Tcl_GetHashValue(hPtr); + ckfree((char *)clookupPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&iclsPtr->resolveCmds); + Tcl_InitObjHashTable(&iclsPtr->resolveCmds); + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Look for the first (most-specific) definition + * of each member function, and enter it into the table. + */ + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr2->functions, &place); + while (hPtr) { + imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); + + /* + * Create all possible names for this function and enter + * them into the command resolution table: + * func + * class::func + * namesp1::class::func + * namesp2::namesp1::class::func + * ... + */ + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, Tcl_GetString(imPtr->namePtr), -1); + nsPtr = iclsPtr2->nsPtr; + + while (1) { + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveCmds, + (char *)objPtr, &newEntry); + + if (newEntry) { + clookupPtr = (ItclCmdLookup *)ckalloc(sizeof(ItclCmdLookup)); + memset(clookupPtr, 0, sizeof(ItclCmdLookup)); + clookupPtr->imPtr = imPtr; + Tcl_SetHashValue(hPtr, (ClientData)clookupPtr); +#ifdef NEW_PROTO_RESOLVER + int type = CMD_TYPE_METHOD; + if (imPtr->flags & ITCL_COMMON) { + type = CMD_TYPE_PROC; + } + icciPtr = (ItclClassCmdInfo *)ckalloc( + sizeof(ItclClassCmdInfo)); + icciPtr->type = type; + icciPtr->protection = imPtr->protection; + icciPtr->nsPtr = iclsPtr->nsPtr; + icciPtr->declaringNsPtr = iclsPtr2->nsPtr; + ClientData clientData2; + clientData2 = Itcl_RegisterClassCommand( + iclsPtr->infoPtr->interp, iclsPtr->nsPtr, + Tcl_GetString(imPtr->namePtr), icciPtr); + clookupPtr->classCmdInfoPtr = clientData2; + clookupPtr->cmdPtr = imPtr->accessCmd; +#endif + } else { + Tcl_DecrRefCount(objPtr); + } + + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nsPtr->name, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + nsPtr = nsPtr->parentPtr; + } + hPtr = Tcl_NextHashEntry(&place); + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Look for the first (most-specific) definition + * of each delegated member function, and enter it into the table. + */ + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr2->delegatedFunctions, &place); + while (hPtr) { + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, + (char *)idmPtr->namePtr); + if (hPtr == NULL) { + hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions, + (char *)idmPtr->namePtr, &newEntry); + Tcl_SetHashValue(hPtr, idmPtr); + } + hPtr = Tcl_NextHashEntry(&place); + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&buffer2); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateVariable() + * + * Creates a new class variable definition. If this is a public + * variable, it may have a bit of "config" code that is used to + * update the object whenever the variable is modified via the + * built-in "configure" method. + * + * Returns TCL_ERROR along with an error message in the specified + * interpreter if anything goes wrong. Otherwise, this returns + * TCL_OK and a pointer to the new variable definition in "ivPtr". + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateVariable( + Tcl_Interp *interp, /* interpreter managing this transaction */ + ItclClass* iclsPtr, /* class containing this variable */ + Tcl_Obj* namePtr, /* variable name */ + char* init, /* initial value */ + char* config, /* code invoked when variable is configured */ + ItclVariable** ivPtrPtr) /* returns: new variable definition */ +{ + int newEntry; + ItclVariable *ivPtr; + ItclMemberCode *mCodePtr; + Tcl_HashEntry *hPtr; + + /* + * Add this variable to the variable table for the class. + * Make sure that the variable name does not already exist. + */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, &newEntry); + if (!newEntry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable name \"", Tcl_GetString(namePtr), + "\" already defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this variable has some "config" code, try to capture + * its implementation. + */ + if (config) { + if (Itcl_CreateMemberCode(interp, iclsPtr, (char*)NULL, config, + &mCodePtr) != TCL_OK) { + Tcl_DeleteHashEntry(hPtr); + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)mCodePtr); + Itcl_EventuallyFree((ClientData)mCodePtr, Itcl_DeleteMemberCode); + } else { + mCodePtr = NULL; + } + + + /* + * If everything looks good, create the variable definition. + */ + ivPtr = (ItclVariable*)ckalloc(sizeof(ItclVariable)); + memset(ivPtr, 0, sizeof(ItclVariable)); + ivPtr->iclsPtr = iclsPtr; + ivPtr->infoPtr = iclsPtr->infoPtr; + ivPtr->protection = Itcl_Protection(interp, 0); + ivPtr->codePtr = mCodePtr; + ivPtr->namePtr = namePtr; + Tcl_IncrRefCount(ivPtr->namePtr); + ivPtr->fullNamePtr = Tcl_NewStringObj( + Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_AppendToObj(ivPtr->fullNamePtr, "::", 2); + Tcl_AppendToObj(ivPtr->fullNamePtr, Tcl_GetString(namePtr), -1); + Tcl_IncrRefCount(ivPtr->fullNamePtr); + + if (ivPtr->protection == ITCL_DEFAULT_PROTECT) { + ivPtr->protection = ITCL_PROTECTED; + } + + if (init != NULL) { + ivPtr->init = Tcl_NewStringObj(init, -1); + Tcl_IncrRefCount(ivPtr->init); + } else { + ivPtr->init = NULL; + } + + Tcl_SetHashValue(hPtr, (ClientData)ivPtr); + Itcl_PreserveData((ClientData)ivPtr); + Itcl_EventuallyFree((ClientData)ivPtr, Itcl_DeleteVariable); + + *ivPtrPtr = ivPtr; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateOption() + * + * Creates a new class option definition. If this is a public + * option, it may have a bit of "config" code that is used to + * update the object whenever the option is modified via the + * built-in "configure" method. + * + * Returns TCL_ERROR along with an error message in the specified + * interpreter if anything goes wrong. Otherwise, this returns + * TCL_OK and a pointer to the new option definition in "ioptPtr". + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateOption( + Tcl_Interp *interp, /* interpreter managing this transaction */ + ItclClass* iclsPtr, /* class containing this variable */ + ItclOption* ioptPtr) /* new option definition */ +{ + int newEntry; + ItclMemberCode *mCodePtr; + Tcl_HashEntry *hPtr; + + mCodePtr = NULL; + /* + * Add this option to the options table for the class. + * Make sure that the option name does not already exist. + */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->options, + (char *)ioptPtr->namePtr, &newEntry); + if (!newEntry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "option name \"", Tcl_GetString(ioptPtr->namePtr), + "\" already defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + iclsPtr->numOptions++; + ioptPtr->iclsPtr = iclsPtr; + ioptPtr->codePtr = mCodePtr; + ioptPtr->fullNamePtr = Tcl_NewStringObj( + Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_AppendToObj(ioptPtr->fullNamePtr, "::", 2); + Tcl_AppendToObj(ioptPtr->fullNamePtr, Tcl_GetString(ioptPtr->namePtr), -1); + Tcl_IncrRefCount(ioptPtr->fullNamePtr); + Tcl_SetHashValue(hPtr, (ClientData)ioptPtr); + Itcl_PreserveData((ClientData)ioptPtr); + Itcl_EventuallyFree((ClientData)ioptPtr, ItclDeleteOption); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateMethodVariable() + * + * Creates a new class methdovariable definition. If this is a public + * methodvariable, + * + * Returns TCL_ERROR along with an error message in the specified + * interpreter if anything goes wrong. Otherwise, this returns + * TCL_OK and a pointer to the new option definition in "imvPtr". + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateMethodVariable( + Tcl_Interp *interp, /* interpreter managing this transaction */ + ItclClass* iclsPtr, /* class containing this variable */ + Tcl_Obj* namePtr, /* variable name */ + Tcl_Obj* defaultPtr, /* initial value */ + Tcl_Obj* callbackPtr, /* code invoked when variable is set */ + ItclMethodVariable** imvPtrPtr) + /* returns: new methdovariable definition */ +{ + int isNew; + ItclMethodVariable *imvPtr; + Tcl_HashEntry *hPtr; + + /* + * Add this methodvariable to the options table for the class. + * Make sure that the methodvariable name does not already exist. + */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->methodVariables, + (char *)namePtr, &isNew); + if (!isNew) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "methdovariable name \"", Tcl_GetString(namePtr), + "\" already defined in class \"", + Tcl_GetString (iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + Tcl_IncrRefCount(namePtr); + + /* + * If everything looks good, create the option definition. + */ + imvPtr = (ItclMethodVariable*)ckalloc(sizeof(ItclMethodVariable)); + memset(imvPtr, 0, sizeof(ItclMethodVariable)); + imvPtr->iclsPtr = iclsPtr; + imvPtr->protection = Itcl_Protection(interp, 0); + imvPtr->namePtr = namePtr; + Tcl_IncrRefCount(imvPtr->namePtr); + imvPtr->fullNamePtr = Tcl_NewStringObj( + Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_AppendToObj(imvPtr->fullNamePtr, "::", 2); + Tcl_AppendToObj(imvPtr->fullNamePtr, Tcl_GetString(namePtr), -1); + Tcl_IncrRefCount(imvPtr->fullNamePtr); + imvPtr->defaultValuePtr = defaultPtr; + if (defaultPtr != NULL) { + Tcl_IncrRefCount(imvPtr->defaultValuePtr); + } + imvPtr->callbackPtr = callbackPtr; + if (callbackPtr != NULL) { + Tcl_IncrRefCount(imvPtr->callbackPtr); + } + + if (imvPtr->protection == ITCL_DEFAULT_PROTECT) { + imvPtr->protection = ITCL_PROTECTED; + } + + Tcl_SetHashValue(hPtr, (ClientData)imvPtr); + + *imvPtrPtr = imvPtr; + return TCL_OK; +} + + + +/* + * ------------------------------------------------------------------------ + * Itcl_GetCommonVar() + * + * Returns the current value for a common class variable. The member + * name is interpreted with respect to the given class scope. That + * scope is installed as the current context before querying the + * variable. This by-passes the protection level in case the variable + * is "private". + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +const char* +Itcl_GetCommonVar( + Tcl_Interp *interp, /* current interpreter */ + const char *name, /* name of desired instance variable */ + ItclClass *contextIclsPtr) /* name is interpreted in this scope */ +{ + const char *val = NULL; + Tcl_HashEntry *hPtr; + Tcl_DString buffer; + Tcl_Obj *namePtr; + ItclVariable *ivPtr; + const char *cp; + const char *lastCp; + Tcl_Object oPtr = NULL; + + lastCp = name; + cp = name; + while (cp != NULL) { + cp = strstr(lastCp, "::"); + if (cp != NULL) { + lastCp = cp + 2; + } + } + namePtr = Tcl_NewStringObj(lastCp, -1); + Tcl_IncrRefCount(namePtr); + hPtr = Tcl_FindHashEntry(&contextIclsPtr->variables, (char *)namePtr); + Tcl_DecrRefCount(namePtr); + if (hPtr == NULL) { + return NULL; + } + ivPtr = Tcl_GetHashValue(hPtr); + /* + * Activate the namespace for the given class. That installs + * the appropriate name resolution rules and by-passes any + * security restrictions. + */ + + if (lastCp == name) { + /* 'name' is a simple name (this is untested!!!!) */ + + /* Use the context class passed in */ + oPtr = contextIclsPtr->oPtr; + + } else { + int code = TCL_ERROR; + Tcl_Obj *classObjPtr = Tcl_NewStringObj(name, lastCp - name - 2); + oPtr = Tcl_GetObjectFromObj(interp, classObjPtr); + + if (oPtr) { + ItclClass *iclsPtr = Tcl_ObjectGetMetadata(oPtr, + contextIclsPtr->infoPtr->class_meta_type); + if (iclsPtr) { + + code = TCL_OK; + assert(oPtr == iclsPtr->oPtr); + + /* + * If the caller gave us a qualified name into + * somewhere other than the context class, then + * things are really weird. Consider an assertion + * to prevent, but for now keep the functioning + * unchanged. + * + * assert(iclsPtr == contextIclsPtr); + */ + + } + + } + Tcl_DecrRefCount(classObjPtr); + if (code != TCL_OK) { + return NULL; + } + + } + + Tcl_DStringInit(&buffer); + if (ivPtr->protection != ITCL_PUBLIC) { + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + } + Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(oPtr))->fullName, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, lastCp, -1); + + val = Tcl_GetVar2(interp, (const char *)Tcl_DStringValue(&buffer), + (char*)NULL, 0); + Tcl_DStringFree(&buffer); + return val; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InitHierIter() + * + * Initializes an iterator for traversing the hierarchy of the given + * class. Subsequent calls to Itcl_AdvanceHierIter() will return + * the base classes in order from most-to-least specific. + * ------------------------------------------------------------------------ + */ +void +Itcl_InitHierIter(iter,iclsPtr) + ItclHierIter *iter; /* iterator used for traversal */ + ItclClass *iclsPtr; /* class definition for start of traversal */ +{ + Itcl_InitStack(&iter->stack); + Itcl_PushStack((ClientData)iclsPtr, &iter->stack); + iter->current = iclsPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteHierIter() + * + * Destroys an iterator for traversing class hierarchies, freeing + * all memory associated with it. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteHierIter(iter) + ItclHierIter *iter; /* iterator used for traversal */ +{ + Itcl_DeleteStack(&iter->stack); + iter->current = NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AdvanceHierIter() + * + * Moves a class hierarchy iterator forward to the next base class. + * Returns a pointer to the current class definition, or NULL when + * the end of the hierarchy has been reached. + * ------------------------------------------------------------------------ + */ +ItclClass* +Itcl_AdvanceHierIter( + ItclHierIter *iter) /* iterator used for traversal */ +{ + register Itcl_ListElem *elem; + ItclClass *iclsPtr; + + iter->current = (ItclClass*)Itcl_PopStack(&iter->stack); + + /* + * Push classes onto the stack in reverse order, so that + * they will be popped off in the proper order. + */ + if (iter->current) { + iclsPtr = (ItclClass*)iter->current; + elem = Itcl_LastListElem(&iclsPtr->bases); + while (elem) { + Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack); + elem = Itcl_PrevListElem(elem); + } + } + return iter->current; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteVariable() + * + * Destroys a variable definition created by Itcl_CreateVariable(), + * freeing all resources associated with it. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteVariable( + char *cdata) /* variable definition to be destroyed */ +{ + Tcl_HashEntry *hPtr; + ItclVariable *ivPtr; + + ivPtr = (ItclVariable *)cdata; +if (ivPtr->arrayInitPtr != NULL) { +} + hPtr = Tcl_FindHashEntry(&ivPtr->infoPtr->classes, (char *)ivPtr->iclsPtr); + if (hPtr != NULL) { + /* unlink owerself from list of class variables */ + hPtr = Tcl_FindHashEntry(&ivPtr->iclsPtr->variables, + (char *)ivPtr->namePtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + } + if (ivPtr->codePtr != NULL) { + Itcl_ReleaseData(ivPtr->codePtr); + } + Tcl_DecrRefCount(ivPtr->namePtr); + Tcl_DecrRefCount(ivPtr->fullNamePtr); + if (ivPtr->init) { + Tcl_DecrRefCount(ivPtr->init); + } + if (ivPtr->arrayInitPtr) { + Tcl_DecrRefCount(ivPtr->arrayInitPtr); + } + ckfree((char*)ivPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteOption() + * + * Destroys a option definition created by Itcl_CreateOption(), + * freeing all resources associated with it. + * ------------------------------------------------------------------------ + */ +static void +ItclDeleteOption( + char *cdata) /* option definition to be destroyed */ +{ + ItclOption *ioptPtr; + + ioptPtr = (ItclOption *)cdata; + Tcl_DecrRefCount(ioptPtr->namePtr); + Tcl_DecrRefCount(ioptPtr->fullNamePtr); + if (ioptPtr->resourceNamePtr != NULL) { + Tcl_DecrRefCount(ioptPtr->resourceNamePtr); + } + if (ioptPtr->resourceNamePtr != NULL) { + Tcl_DecrRefCount(ioptPtr->classNamePtr); + } + + Itcl_ReleaseData(ioptPtr->codePtr); + if (ioptPtr->defaultValuePtr != NULL) { + Tcl_DecrRefCount(ioptPtr->defaultValuePtr); + } + if (ioptPtr->cgetMethodPtr != NULL) { + Tcl_DecrRefCount(ioptPtr->cgetMethodPtr); + } + if (ioptPtr->cgetMethodVarPtr != NULL) { + Tcl_DecrRefCount(ioptPtr->cgetMethodVarPtr); + } + if (ioptPtr->configureMethodPtr != NULL) { + Tcl_DecrRefCount(ioptPtr->configureMethodPtr); + } + if (ioptPtr->configureMethodVarPtr != NULL) { + Tcl_DecrRefCount(ioptPtr->configureMethodVarPtr); + } + if (ioptPtr->validateMethodPtr != NULL) { + Tcl_DecrRefCount(ioptPtr->validateMethodPtr); + } + if (ioptPtr->validateMethodVarPtr != NULL) { + Tcl_DecrRefCount(ioptPtr->validateMethodVarPtr); + } + Itcl_ReleaseData(ioptPtr->idoPtr); + ckfree((char*)ioptPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteFunction() + * + * fre data associated with a function + * ------------------------------------------------------------------------ + */ +static void +ItclDeleteFunction( + ItclMemberFunc *imPtr) +{ + Tcl_HashEntry *hPtr; + +if (imPtr->iclsPtr) { + hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods, + (char *) imPtr->tmPtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } +} + hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->classes, (char *)imPtr->iclsPtr); + if (hPtr != NULL) { + /* unlink owerself from list of class functions */ + hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->functions, + (char *)imPtr->namePtr); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + } + if (imPtr->codePtr != NULL) { + Itcl_ReleaseData(imPtr->codePtr); + } + Tcl_DecrRefCount(imPtr->namePtr); + Tcl_DecrRefCount(imPtr->fullNamePtr); + if (imPtr->usagePtr != NULL) { + Tcl_DecrRefCount(imPtr->usagePtr); + } + if (imPtr->argumentPtr != NULL) { + Tcl_DecrRefCount(imPtr->argumentPtr); + } + if (imPtr->origArgsPtr != NULL) { + Tcl_DecrRefCount(imPtr->origArgsPtr); + } + if (imPtr->builtinArgumentPtr != NULL) { + Tcl_DecrRefCount(imPtr->builtinArgumentPtr); + } + if (imPtr->bodyPtr != NULL) { + Tcl_DecrRefCount(imPtr->bodyPtr); + } + if (imPtr->argListPtr != NULL) { + ItclDeleteArgList(imPtr->argListPtr); + } + ckfree((char*)imPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteComponent() + * + * free data associated with a component + * ------------------------------------------------------------------------ + */ +static void +ItclDeleteComponent( + ItclComponent *icPtr) +{ + Tcl_Obj *objPtr; + FOREACH_HASH_DECLS; + + Tcl_DecrRefCount(icPtr->namePtr); + /* the variable and the command are freed when freeing variables, + * functions */ + FOREACH_HASH_VALUE(objPtr, &icPtr->keptOptions) { + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } + } + Tcl_DeleteHashTable(&icPtr->keptOptions); + ckfree((char*)icPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteDelegatedOption() + * + * free data associated with a delegated option + * ------------------------------------------------------------------------ + */ +void +ItclDeleteDelegatedOption( + char *cdata) +{ + Tcl_Obj *objPtr; + FOREACH_HASH_DECLS; + ItclDelegatedOption *idoPtr; + + idoPtr = (ItclDelegatedOption *)cdata; + Tcl_DecrRefCount(idoPtr->namePtr); + if (idoPtr->resourceNamePtr != NULL) { + Tcl_DecrRefCount(idoPtr->resourceNamePtr); + } + if (idoPtr->classNamePtr != NULL) { + Tcl_DecrRefCount(idoPtr->classNamePtr); + } + if (idoPtr->asPtr != NULL) { + Tcl_DecrRefCount(idoPtr->asPtr); + } + FOREACH_HASH_VALUE(objPtr, &idoPtr->exceptions) { + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } + } + Tcl_DeleteHashTable(&idoPtr->exceptions); + ckfree((char *)idoPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteDelegatedFunction() + * + * free data associated with a delegated function + * ------------------------------------------------------------------------ + */ +void ItclDeleteDelegatedFunction( + ItclDelegatedFunction *idmPtr) +{ + Tcl_Obj *objPtr; + FOREACH_HASH_DECLS; + + Tcl_DecrRefCount(idmPtr->namePtr); + if (idmPtr->asPtr != NULL) { + Tcl_DecrRefCount(idmPtr->asPtr); + } + if (idmPtr->usingPtr != NULL) { + Tcl_DecrRefCount(idmPtr->usingPtr); + } + FOREACH_HASH_VALUE(objPtr, &idmPtr->exceptions) { + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } + } + Tcl_DeleteHashTable(&idmPtr->exceptions); + ckfree((char *)idmPtr); +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclCmd.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclCmd.c new file mode 100644 index 0000000..1111953 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclCmd.c @@ -0,0 +1,2182 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This file defines information that tracks classes and objects + * at a global level for a given interpreter. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "tclInt.h" +#include "itclInt.h" +/* + * ------------------------------------------------------------------------ + * Itcl_ThisCmd() + * + * Invoked by Tcl for fast access to itcl methods + * syntax: + * + * this methodName args .... + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +NRThisCmd( + ClientData clientData, /* class info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ClientData clientData2; + Tcl_Object oPtr; + ItclClass *iclsPtr; + + ItclShowArgs(1, "NRThisCmd", objc, objv); + iclsPtr = clientData; + clientData2 = Itcl_GetCallFrameClientData(interp); + oPtr = Tcl_ObjectContextObject(clientData2); + return Itcl_PublicObjectCmd(oPtr, interp, iclsPtr->clsPtr, objc, objv); +} +/* ARGSUSED */ +int +Itcl_ThisCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + FOREACH_HASH_DECLS; + ClientData clientData2; + Tcl_Object oPtr; + Tcl_Obj **newObjv; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + const char *funcName; + const char *val; + int result; + + if (objc == 1) { + return Itcl_SelfCmd(clientData,interp, objc, objv); + } + ItclShowArgs(1, "Itcl_ThisCmd", objc, objv); + iclsPtr = clientData; + clientData2 = Itcl_GetCallFrameClientData(interp); + if (clientData2 == NULL) { + Tcl_AppendResult(interp, + "this cannot be invoked without an object context", NULL); + return TCL_ERROR; + } + oPtr = Tcl_ObjectContextObject(clientData2); + if (oPtr == NULL) { + Tcl_AppendResult(interp, + "this cannot be invoked without an object context", NULL); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_Obj *namePtr = Tcl_NewObj(); + + Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(oPtr), namePtr); + Tcl_SetObjResult(interp, namePtr); + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]); + funcName = Tcl_GetString(objv[1]); + if (!(iclsPtr->flags & ITCL_CLASS)) { + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) { + if (idmPtr->icPtr == NULL) { + if (idmPtr->usingPtr != NULL) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); + newObjv[0] = idmPtr->usingPtr; + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * + (objc - 2)); +ItclShowArgs(1, "EVAL2", objc - 1, newObjv); + result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + } else { + Tcl_AppendResult(interp, + "delegate has not yet been implemented in", + ": \"this\" method/command!", NULL); + return TCL_ERROR; + } + } else { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * + (objc + 1)); + newObjv[0] = Tcl_NewStringObj("this", -1); + Tcl_IncrRefCount(newObjv[0]); + val = Tcl_GetVar2(interp, + Tcl_GetString(idmPtr->icPtr->namePtr), NULL, 0); + newObjv[1] = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(newObjv[1]); + memcpy(newObjv+2, objv+1, sizeof(Tcl_Obj *) * (objc -1)); +ItclShowArgs(1, "EVAL2", objc+1, newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, 0); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + } + return result; + } + } + } + if (hPtr == NULL) { + Tcl_AppendResult(interp, "class \"", iclsPtr->nsPtr->fullName, + "\" has no method: \"", Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + return Tcl_NRCallObjProc(interp, NRThisCmd, clientData, objc, objv); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindClassesCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::find classes" + * command to query the list of known classes. Handles the following + * syntax: + * + * find classes ?<pattern>? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_FindClassesCmd( + ClientData clientData, /* class/object info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); + Tcl_Namespace *globalNs = Tcl_GetGlobalNamespace(interp); + Tcl_HashTable unique; + Tcl_HashEntry *hPtr; + Tcl_HashSearch place; + Tcl_Command cmd; + Tcl_Command originalCmd; + Tcl_Namespace *nsPtr; + Tcl_Obj *objPtr; + Itcl_Stack search; + char *pattern; + const char *cmdName; + int newEntry; + int handledActiveNs; + int forceFullNames = 0; + + ItclShowArgs(2, "Itcl_FindClassesCmd", objc, objv); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + forceFullNames = (strstr(pattern, "::") != NULL); + } else { + pattern = NULL; + } + + /* + * Search through all commands in the current namespace first, + * in the global namespace next, then in all child namespaces + * in this interpreter. If we find any commands that + * represent classes, report them. + */ + + Itcl_InitStack(&search); + Itcl_PushStack((ClientData)globalNs, &search); + Itcl_PushStack((ClientData)activeNs, &search); /* last in, first out! */ + + Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); + + handledActiveNs = 0; + while (Itcl_GetStackSize(&search) > 0) { + nsPtr = Itcl_PopStack(&search); + if (nsPtr == activeNs && handledActiveNs) { + continue; + } + + hPtr = Tcl_FirstHashEntry(Itcl_GetNamespaceCommandTable(nsPtr), + &place); + while (hPtr) { + cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + if (Itcl_IsClass(cmd)) { + originalCmd = Tcl_GetOriginalCommand(cmd); + + /* + * Report full names if: + * - the pattern has namespace qualifiers + * - the class namespace is not in the current namespace + * - the class's object creation command is imported from + * another namespace. + * + * Otherwise, report short names. + */ + if (forceFullNames || nsPtr != activeNs || + originalCmd != NULL) { + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName(interp, cmd, objPtr); + cmdName = Tcl_GetString(objPtr); + } else { + cmdName = Tcl_GetCommandName(interp, cmd); + objPtr = Tcl_NewStringObj((const char *)cmdName, -1); + } + + if (originalCmd) { + cmd = originalCmd; + } + Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); + + if (newEntry && + ((pattern == NULL) || + Tcl_StringMatch((const char *)cmdName, pattern))) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_GetObjResult(interp), objPtr); + } else { + /* if not appended to the result, free objPtr. */ + Tcl_DecrRefCount(objPtr); + } + + } + hPtr = Tcl_NextHashEntry(&place); + } + handledActiveNs = 1; /* don't process the active namespace twice */ + + /* + * Push any child namespaces onto the stack and continue + * the search in those namespaces. + */ + hPtr = Tcl_FirstHashEntry(Itcl_GetNamespaceChildTable(nsPtr), &place); + while (hPtr != NULL) { + Itcl_PushStack(Tcl_GetHashValue(hPtr), &search); + hPtr = Tcl_NextHashEntry(&place); + } + } + Tcl_DeleteHashTable(&unique); + Itcl_DeleteStack(&search); + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindObjectsCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::find objects" + * command to query the list of known objects. Handles the following + * syntax: + * + * find objects ?-class <className>? ?-isa <className>? ?<pattern>? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_FindObjectsCmd( + ClientData clientData, /* class/object info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); + Tcl_Namespace *globalNs = Tcl_GetGlobalNamespace(interp); + int forceFullNames = 0; + + char *pattern = NULL; + ItclClass *iclsPtr = NULL; + ItclClass *isaDefn = NULL; + + char *name = NULL; + char *token = NULL; + const char *cmdName = NULL; + int pos; + int newEntry; + int match; + int handledActiveNs; + ItclObject *contextIoPtr; + Tcl_HashTable unique; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Itcl_Stack search; + Tcl_Command cmd; + Tcl_Command originalCmd; + Tcl_CmdInfo cmdInfo; + Tcl_Namespace *nsPtr; + Tcl_Obj *objPtr; + + /* + * Parse arguments: + * objects ?-class <className>? ?-isa <className>? ?<pattern>? + */ + pos = 0; + while (++pos < objc) { + token = Tcl_GetString(objv[pos]); + if (*token != '-') { + if (!pattern) { + pattern = token; + forceFullNames = (strstr(pattern, "::") != NULL); + } else { + break; + } + } + else if ((pos+1 < objc) && (strcmp(token,"-class") == 0)) { + name = Tcl_GetString(objv[pos+1]); + iclsPtr = Itcl_FindClass(interp, name, /* autoload */ 1); + if (iclsPtr == NULL) { + return TCL_ERROR; + } + pos++; + } + else if ((pos+1 < objc) && (strcmp(token,"-isa") == 0)) { + name = Tcl_GetString(objv[pos+1]); + isaDefn = Itcl_FindClass(interp, name, /* autoload */ 1); + if (isaDefn == NULL) { + return TCL_ERROR; + } + pos++; + } else { + + /* + * Last token? Take it as the pattern, even if it starts + * with a "-". This allows us to match object names that + * start with "-". + */ + if (pos == objc-1 && !pattern) { + pattern = token; + forceFullNames = (strstr(pattern, "::") != NULL); + } else { + break; + } + } + } + + if (pos < objc) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-class className? ?-isa className? ?pattern?"); + return TCL_ERROR; + } + + /* + * Search through all commands in the current namespace first, + * in the global namespace next, then in all child namespaces + * in this interpreter. If we find any commands that + * represent objects, report them. + */ + + Itcl_InitStack(&search); + Itcl_PushStack((ClientData)globalNs, &search); + Itcl_PushStack((ClientData)activeNs, &search); /* last in, first out! */ + + Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); + + handledActiveNs = 0; + while (Itcl_GetStackSize(&search) > 0) { + nsPtr = Itcl_PopStack(&search); + if (nsPtr == activeNs && handledActiveNs) { + continue; + } + + entry = Tcl_FirstHashEntry(Itcl_GetNamespaceCommandTable(nsPtr), &place); + while (entry) { + cmd = (Tcl_Command)Tcl_GetHashValue(entry); + if (Itcl_IsObject(cmd)) { + originalCmd = Tcl_GetOriginalCommand(cmd); + if (originalCmd) { + cmd = originalCmd; + } + Tcl_GetCommandInfoFromToken(cmd, &cmdInfo); + contextIoPtr = (ItclObject*)cmdInfo.deleteData; + + /* + * Report full names if: + * - the pattern has namespace qualifiers + * - the class namespace is not in the current namespace + * - the class's object creation command is imported from + * another namespace. + * + * Otherwise, report short names. + */ + if (forceFullNames || nsPtr != activeNs || + originalCmd != NULL) { + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName(interp, cmd, objPtr); + cmdName = Tcl_GetString(objPtr); + } else { + cmdName = Tcl_GetCommandName(interp, cmd); + objPtr = Tcl_NewStringObj((const char *)cmdName, -1); + } + + Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); + + match = 0; + if (newEntry && + (!pattern || Tcl_StringMatch((const char *)cmdName, + pattern))) { + if ((iclsPtr == NULL) || + (contextIoPtr->iclsPtr == iclsPtr)) { + if (isaDefn == NULL) { + match = 1; + } else { + entry = Tcl_FindHashEntry( + &contextIoPtr->iclsPtr->heritage, + (char*)isaDefn); + + if (entry) { + match = 1; + } + } + } + } + + if (match) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_GetObjResult(interp), objPtr); + } else { + Tcl_DecrRefCount(objPtr); /* throw away the name */ + } + } + entry = Tcl_NextHashEntry(&place); + } + handledActiveNs = 1; /* don't process the active namespace twice */ + + /* + * Push any child namespaces onto the stack and continue + * the search in those namespaces. + */ + entry = Tcl_FirstHashEntry(Itcl_GetNamespaceChildTable(nsPtr), &place); + while (entry != NULL) { + Itcl_PushStack(Tcl_GetHashValue(entry), &search); + entry = Tcl_NextHashEntry(&place); + } + } + Tcl_DeleteHashTable(&unique); + Itcl_DeleteStack(&search); + + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DelClassCmd() + * + * Part of the "delete" ensemble. Invoked by Tcl whenever the + * user issues a "delete class" command to delete classes. + * Handles the following syntax: + * + * delete class <name> ?<name>...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +NRDelClassCmd( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int i; + char *name; + ItclClass *iclsPtr; + + ItclShowArgs(1, "Itcl_DelClassCmd", objc, objv); + /* + * Since destroying a base class will destroy all derived + * classes, calls like "destroy class Base Derived" could + * fail. Break this into two passes: first check to make + * sure that all classes on the command line are valid, + * then delete them. + */ + for (i=1; i < objc; i++) { + name = Tcl_GetString(objv[i]); + iclsPtr = Itcl_FindClass(interp, name, /* autoload */ 1); + if (iclsPtr == NULL) { + return TCL_ERROR; + } + } + + for (i=1; i < objc; i++) { + name = Tcl_GetString(objv[i]); + iclsPtr = Itcl_FindClass(interp, name, /* autoload */ 0); + + if (iclsPtr) { + Tcl_ResetResult(interp); + if (Itcl_DeleteClass(interp, iclsPtr) != TCL_OK) { + return TCL_ERROR; + } + } + } + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* ARGSUSED */ +int +Itcl_DelClassCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRDelClassCmd, clientData, objc, objv); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DelObjectCmd() + * + * Part of the "delete" ensemble. Invoked by Tcl whenever the user + * issues a "delete object" command to delete [incr Tcl] objects. + * Handles the following syntax: + * + * delete object <name> ?<name>...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +static int +CallDeleteObject( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ItclObject *contextIoPtr = data[0]; + if (contextIoPtr->destructorHasBeenCalled) { + Tcl_AppendResult(interp, "can't delete an object while it is being ", + "destructed", NULL); + return TCL_ERROR; + } + if (result == TCL_OK) { + result = Itcl_DeleteObject(interp, contextIoPtr); + } + return result; +} + +static int +NRDelObjectCmd( + ClientData clientData, /* object management info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObject *contextIoPtr; + char *name; + void *callbackPtr; + int i; + int result; + + ItclShowArgs(1, "Itcl_DelObjectCmd", objc, objv); + /* + * Scan through the list of objects and attempt to delete them. + * If anything goes wrong (i.e., destructors fail), then + * abort with an error. + */ + for (i=1; i < objc; i++) { + name = Tcl_GetStringFromObj(objv[i], (int*)NULL); + contextIoPtr = NULL; + if (Itcl_FindObject(interp, name, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "object \"", name, "\" not found", + (char*)NULL); + return TCL_ERROR; + } + + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + Tcl_NRAddCallback(interp, CallDeleteObject, contextIoPtr, + NULL, NULL, NULL); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* ARGSUSED */ +int +Itcl_DelObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRDelObjectCmd, clientData, objc, objv); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ScopeCmd() + * + * Invoked by Tcl whenever the user issues a "scope" command to + * create a fully qualified variable name. Handles the following + * syntax: + * + * scope <variable> + * + * If the input string is already fully qualified (starts with "::"), + * then this procedure does nothing. Otherwise, it looks for a + * data member called <variable> and returns its fully qualified + * name. If the <variable> is a common data member, this procedure + * returns a name of the form: + * + * ::namesp::namesp::class::variable + * + * If the <variable> is an instance variable, this procedure returns + * a name in a format that Tcl can use to find the same variable from + * any context. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ScopeCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *contextNsPtr; + Tcl_HashEntry *hPtr; + Tcl_Object oPtr; + Tcl_InterpDeleteProc *procPtr; + Tcl_Obj *objPtr2; + Tcl_Var var; + Tcl_HashEntry *entry; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObjectInfo *infoPtr; + ItclVarLookup *vlookup; + char *openParen; + register char *p; + char *token; + int doAppend; + int result; + + ItclShowArgs(1, "Itcl_ScopeCmd", objc, objv); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varname"); + return TCL_ERROR; + } + + contextNsPtr = Tcl_GetCurrentNamespace(interp); + openParen = NULL; + result = TCL_OK; + /* + * If this looks like a fully qualified name already, + * then return it as is. + */ + token = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (*token == ':' && *(token+1) == ':') { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + /* + * If the variable name is an array reference, pick out + * the array name and use that for the lookup operations + * below. + */ + for (p=token; *p != '\0'; p++) { + if (*p == '(') { + openParen = p; + } + else if (*p == ')' && openParen) { + *openParen = '\0'; + break; + } + } + + /* + * Figure out what context we're in. If this is a class, + * then look up the variable in the class definition. + * If this is a namespace, then look up the variable in its + * varTable. Note that the normal Itcl_GetContext function + * returns an error if we're not in a class context, so we + * perform a similar function here, the hard way. + * + * TRICKY NOTE: If this is an array reference, we'll get + * the array variable as the variable name. We must be + * careful to add the index (everything from openParen + * onward) as well. + */ + contextIoPtr = NULL; + contextIclsPtr = NULL; + oPtr = NULL; + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)contextNsPtr); + if (hPtr != NULL) { + contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); + } + if (Itcl_IsClassNamespace(contextNsPtr)) { + ClientData clientData; + + entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token); + if (!entry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable \"", token, "\" not found in class \"", + Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", + (char*)NULL); + result = TCL_ERROR; + goto scopeCmdDone; + } + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + + if (vlookup->ivPtr->flags & ITCL_COMMON) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + if (vlookup->ivPtr->protection != ITCL_PUBLIC) { + Tcl_AppendToObj(resultPtr, ITCL_VARIABLES_NAMESPACE, -1); + } + Tcl_AppendToObj(resultPtr, + Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); + if (openParen) { + *openParen = '('; + Tcl_AppendToObj(resultPtr, openParen, -1); + openParen = NULL; + } + result = TCL_OK; + goto scopeCmdDone; + } + + /* + * If this is not a common variable, then we better have + * an object context. Return the name as a fully qualified name. + */ + infoPtr = contextIclsPtr->infoPtr; + clientData = Itcl_GetCallFrameClientData(interp); + if (clientData != NULL) { + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); + if (oPtr != NULL) { + contextIoPtr = (ItclObject*)Tcl_ObjectGetMetadata( + oPtr, infoPtr->object_meta_type); + } + } + + if (contextIoPtr == NULL) { + if (infoPtr->currIoPtr != NULL) { + contextIoPtr = infoPtr->currIoPtr; + } + } + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't scope variable \"", token, + "\": missing object context", + (char*)NULL); + result = TCL_ERROR; + goto scopeCmdDone; + } + + doAppend = 1; + if (contextIclsPtr->flags & ITCL_ECLASS) { + if (strcmp(token, "itcl_options") == 0) { + doAppend = 0; + } + } + + objPtr2 = Tcl_NewStringObj((char*)NULL, 0); + Tcl_IncrRefCount(objPtr2); + Tcl_AppendToObj(objPtr2, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr2, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1); + + if (doAppend) { + Tcl_AppendToObj(objPtr2, + Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); + } else { + Tcl_AppendToObj(objPtr2, "::", -1); + Tcl_AppendToObj(objPtr2, + Tcl_GetString(vlookup->ivPtr->namePtr), -1); + } + + if (openParen) { + *openParen = '('; + Tcl_AppendToObj(objPtr2, openParen, -1); + openParen = NULL; + } + /* fix for SF bug #238 use Tcl_AppendResult instead of Tcl_AppendElement */ + Tcl_AppendResult(interp, Tcl_GetString(objPtr2), NULL); + Tcl_DecrRefCount(objPtr2); + } else { + + /* + * We must be in an ordinary namespace context. Resolve + * the variable using Tcl_FindNamespaceVar. + * + * TRICKY NOTE: If this is an array reference, we'll get + * the array variable as the variable name. We must be + * careful to add the index (everything from openParen + * onward) as well. + */ + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + var = Itcl_FindNamespaceVar(interp, token, contextNsPtr, + TCL_NAMESPACE_ONLY); + + if (!var) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable \"", token, "\" not found in namespace \"", + contextNsPtr->fullName, "\"", + (char*)NULL); + result = TCL_ERROR; + goto scopeCmdDone; + } + + Itcl_GetVariableFullName(interp, var, resultPtr); + if (openParen) { + *openParen = '('; + Tcl_AppendToObj(resultPtr, openParen, -1); + openParen = NULL; + } + } + +scopeCmdDone: + if (openParen) { + *openParen = '('; + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CodeCmd() + * + * Invoked by Tcl whenever the user issues a "code" command to + * create a scoped command string. Handles the following syntax: + * + * code ?-namespace foo? arg ?arg arg ...? + * + * Unlike the scope command, the code command DOES NOT look for + * scoping information at the beginning of the command. So scopes + * will nest in the code command. + * + * The code command is similar to the "namespace code" command in + * Tcl, but it preserves the list structure of the input arguments, + * so it is a lot more useful. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_CodeCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); + + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + const char *token; + int pos; + + ItclShowArgs(1, "Itcl_CodeCmd", objc, objv); + /* + * Handle flags like "-namespace"... + */ + for (pos=1; pos < objc; pos++) { + token = Tcl_GetStringFromObj(objv[pos], (int*)NULL); + if (*token != '-') { + break; + } + + if (strcmp(token, "-namespace") == 0) { + if (objc == 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-namespace name? command ?arg arg...?"); + return TCL_ERROR; + } else { + token = Tcl_GetString(objv[pos+1]); + contextNs = Tcl_FindNamespace(interp, token, + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (!contextNs) { + return TCL_ERROR; + } + pos++; + } + } else { + if (strcmp(token, "--") == 0) { + pos++; + break; + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be -namespace or --", + (char*)NULL); + return TCL_ERROR; + } + } + } + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-namespace name? command ?arg arg...?"); + return TCL_ERROR; + } + + /* + * Now construct a scoped command by integrating the + * current namespace context, and appending the remaining + * arguments AS A LIST... + */ + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("namespace", -1)); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("inscope", -1)); + + if (contextNs == Tcl_GetGlobalNamespace(interp)) { + objPtr = Tcl_NewStringObj("::", -1); + } else { + objPtr = Tcl_NewStringObj(contextNs->fullName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + if (objc-pos == 1) { + objPtr = objv[pos]; + } else { + objPtr = Tcl_NewListObj(objc-pos, &objv[pos]); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + Tcl_SetResult(interp, Tcl_GetString(listPtr), TCL_VOLATILE); + Tcl_DecrRefCount(listPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsObjectCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::is object" + * command to test whether the argument is an object or not. + * syntax: + * + * itcl::is object ?-class classname? commandname + * + * Returns 1 if it is an object, 0 otherwise + * ------------------------------------------------------------------------ + */ +int +Itcl_IsObjectCmd( + ClientData clientData, /* class/object info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + + int classFlag = 0; + int idx = 0; + char *name = NULL; + char *cname; + char *cmdName; + char *token; + Tcl_Command cmd; + Tcl_Namespace *contextNs = NULL; + ItclClass *iclsPtr = NULL; + + /* + * Handle the arguments. + * objc needs to be either: + * 2 itcl::is object commandname + * 4 itcl::is object -class classname commandname + */ + if (objc != 2 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-class classname? commandname"); + return TCL_ERROR; + } + + /* + * Parse the command args. Look for the -class + * keyword. + */ + for (idx=1; idx < objc; idx++) { + token = Tcl_GetString(objv[idx]); + + if (strcmp(token,"-class") == 0) { + cname = Tcl_GetString(objv[idx+1]); + iclsPtr = Itcl_FindClass(interp, cname, /* no autoload */ 0); + + if (iclsPtr == NULL) { + return TCL_ERROR; + } + + idx++; + classFlag = 1; + } else { + name = Tcl_GetString(objv[idx]); + } + + } /* end for objc loop */ + + + /* + * The object name may be a scoped value of the form + * "namespace inscope <namesp> <command>". If it is, + * decode it. + */ + if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName) + != TCL_OK) { + return TCL_ERROR; + } + + cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0); + + /* + * Need the NULL test, or the test will fail if cmd is NULL + */ + if (cmd == NULL || ! Itcl_IsObject(cmd)) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + ckfree((char *)cmdName); + return TCL_OK; + } + + /* + * Handle the case when the -class flag is given + */ + if (classFlag) { + ItclObject *contextIoPtr; + if (Itcl_FindObject(interp, cmdName, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (contextIoPtr == NULL) { + /* seems that we are in constructor, so look for currIoPtr in info structure */ + contextIoPtr = iclsPtr->infoPtr->currIoPtr; + } + if (! Itcl_ObjectIsa(contextIoPtr, iclsPtr)) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + ckfree((char *)cmdName); + return TCL_OK; + } + + } + + /* + * Got this far, so assume that it is a valid object + */ + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + ckfree(cmdName); + + return TCL_OK; +} + + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsClassCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::is class" + * command to test whether the argument is an itcl class or not + * syntax: + * + * itcl::is class commandname + * + * Returns 1 if it is a class, 0 otherwise + * ------------------------------------------------------------------------ + */ +int +Itcl_IsClassCmd( + ClientData clientData, /* class/object info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + + char *cname; + char *name; + ItclClass *iclsPtr = NULL; + Tcl_Namespace *contextNs = NULL; + + /* + * Need itcl::is class classname + */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "commandname"); + return TCL_ERROR; + } + + name = Tcl_GetString(objv[1]); + + /* + * The object name may be a scoped value of the form + * "namespace inscope <namesp> <command>". If it is, + * decode it. + */ + if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cname) != TCL_OK) { + return TCL_ERROR; + } + + iclsPtr = Itcl_FindClass(interp, cname, /* no autoload */ 0); + + /* + * If classDefn is NULL, then it wasn't found, hence it + * isn't a class + */ + if (iclsPtr != NULL) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } + + ckfree(cname); + + return TCL_OK; + +} /* end Itcl_IsClassCmd function */ + +/* + * ------------------------------------------------------------------------ + * Itcl_FilterCmd() + * + * Used to add a filter command to an object which is called just before + * a method/proc of a class is executed + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_FilterAddCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj **newObjv; + int result; + + ItclShowArgs(1, "Itcl_FilterCmd", objc, objv); +/* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ +/* FIXME need to change the chain command to do the same here as the TclOO next command !! */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "<className> <filterName> ?<filterName> ...?"); + return TCL_ERROR; + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1)); + newObjv[0] = Tcl_NewStringObj("::oo::define", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = objv[1]; + newObjv[2] = Tcl_NewStringObj("filter", -1); + Tcl_IncrRefCount(newObjv[2]); + memcpy(newObjv+3, objv+2, sizeof(Tcl_Obj *)*(objc-2)); + ItclShowArgs(1, "Itcl_FilterAddCmd2", objc+1, newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[2]); + + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_FilterDeleteCmd() + * + * used to delete filter commands of a class or object + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_FilterDeleteCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclShowArgs(1, "Itcl_FilterDeleteCmd", objc, objv); +/* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ + + Tcl_AppendResult(interp, "::itcl::filter delete command not yet implemented", NULL); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ForwardAddCmd() + * + * Used to similar to iterp alias to forward the call of a method + * to another method within the class + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ForwardAddCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *prefixObj; + Tcl_Method mPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + + ItclShowArgs(1, "Itcl_ForwardAddCmd", objc, objv); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "<forwardName> <targetName> ?<arg> ...?"); + return TCL_ERROR; + } + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_HashEntry *hPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "class: \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + iclsPtr = Tcl_GetHashValue(hPtr); + } + prefixObj = Tcl_NewListObj(objc-2, objv+2); + mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1, + objv[1], prefixObj); + if (mPtr == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ForwardDeleteCmd() + * + * used to delete forwarded commands of a class or object + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ForwardDeleteCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclShowArgs(1, "Itcl_ForwardDeleteCmd", objc, objv); +/* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ + + Tcl_AppendResult(interp, "::itcl::forward delete command not yet implemented", NULL); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_MixinAddCmd() + * + * Used to add the methods of a class to another class without heritance + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_MixinAddCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj **newObjv; + int result; + + ItclShowArgs(1, "Itcl_MixinAddCmd", objc, objv); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "<className> <mixinName> ?<mixinName> ...?"); + return TCL_ERROR; + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1)); + newObjv[0] = Tcl_NewStringObj("::oo::define", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = objv[1]; + newObjv[2] = Tcl_NewStringObj("mixin", -1); + Tcl_IncrRefCount(newObjv[2]); + memcpy(newObjv+3, objv+2, sizeof(Tcl_Obj *)*(objc-2)); + ItclShowArgs(1, "Itcl_MixinAddCmd2", objc+1, newObjv); + result = Tcl_EvalObjv(interp, objc+1, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[2]); + + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_MixinDeleteCmd() + * + * Used to delete the methods of a class to another class without heritance + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_MixinDeleteCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclShowArgs(1, "Itcl_MixinDeleteCmd", objc, objv); +/* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ + + Tcl_AppendResult(interp, "::itcl::mixin delete command not yet implemented", NULL); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_NWidgetCmd() + * + * Used to build an [incr Tcl] nwidget + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_NWidgetCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *iclsPtr; + int result; + + iclsPtr = NULL; + ItclShowArgs(0, "Itcl_NWidgetCmd", objc-1, objv); + result = ItclClassBaseCmd(clientData, interp, ITCL_ECLASS|ITCL_NWIDGET, objc, objv, + &iclsPtr); + if (result != TCL_OK) { + return result; + } + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Itcl_NWidgetCmd!iclsPtr == NULL\n", NULL); + result = TCL_ERROR; + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AddOptionCmd() + * + * Used to build an option to an [incr Tcl] nwidget/eclass + * + * Syntax: ::itcl::addoption <nwidget class> <protection> <optionName> <defaultValue> + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_AddOptionCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + const char *protectionStr; + int pLevel; + int result; + + result = TCL_OK; + infoPtr = (ItclObjectInfo *)clientData; + ItclShowArgs(1, "Itcl_AddOptionCmd", objc, objv); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "className protection option optionName ..."); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "class \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + iclsPtr = Tcl_GetHashValue(hPtr); + protectionStr = Tcl_GetString(objv[2]); + pLevel = -1; + if (strcmp(protectionStr, "public") == 0) { + pLevel = ITCL_PUBLIC; + } + if (strcmp(protectionStr, "protected") == 0) { + pLevel = ITCL_PROTECTED; + } + if (strcmp(protectionStr, "private") == 0) { + pLevel = ITCL_PRIVATE; + } + if (pLevel == -1) { + Tcl_AppendResult(interp, "bad protection \"", protectionStr, "\"", + NULL); + return TCL_ERROR; + } + Itcl_PushStack((ClientData)iclsPtr, &infoPtr->clsStack); + result = Itcl_ClassOptionCmd(clientData, interp, objc-2, objv+2); + Itcl_PopStack(&infoPtr->clsStack); + if (result != TCL_OK) { + return result; + } + result = DelegatedOptionsInstall(interp, iclsPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AddObjectOptionCmd() + * + * Used to build an option for an [incr Tcl] object + * + * Syntax: ::itcl::addobjectoption <object> <protection> option <optionSpec> + * ?-default <defaultValue>? + * ?-configuremethod <configuremethod>? + * ?-validatemethod <validatemethod>? + * ?-cgetmethod <cgetmethod>? + * ?-configuremethodvar <configuremethodvar>? + * ?-validatemethodvar <validatemethodvar>? + * ?-cgetmethodvar <cgetmethodvar>? + * ?-readonly? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_AddObjectOptionCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Command cmd; + Tcl_Obj *objPtr; + ItclObjectInfo *infoPtr; + ItclObject *ioPtr; + ItclOption *ioptPtr; + const char *protectionStr; + int pLevel; + int isNew; + + ioptPtr = NULL; + infoPtr = (ItclObjectInfo *)clientData; + ItclShowArgs(1, "Itcl_AddObjectOptionCmd", objc, objv); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "objectName protection option optionName ..."); + return TCL_ERROR; + } + + cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); + if (cmd == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&infoPtr->objectCmds, (char *)cmd); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + ioPtr = Tcl_GetHashValue(hPtr); + protectionStr = Tcl_GetString(objv[2]); + pLevel = -1; + if (strcmp(protectionStr, "public") == 0) { + pLevel = ITCL_PUBLIC; + } + if (strcmp(protectionStr, "protected") == 0) { + pLevel = ITCL_PROTECTED; + } + if (strcmp(protectionStr, "private") == 0) { + pLevel = ITCL_PRIVATE; + } + if (pLevel == -1) { + Tcl_AppendResult(interp, "bad protection \"", protectionStr, "\"", + NULL); + return TCL_ERROR; + } + infoPtr->protection = pLevel; + if (ItclParseOption(infoPtr, interp, objc-3, objv+3, NULL, ioPtr, + &ioptPtr) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); + ioptPtr->fullNamePtr = Tcl_NewStringObj( + Tcl_GetString(ioPtr->namePtr), -1); + Tcl_AppendToObj(ioptPtr->fullNamePtr, "::", 2); + Tcl_AppendToObj(ioptPtr->fullNamePtr, Tcl_GetString(ioptPtr->namePtr), -1); + Tcl_IncrRefCount(ioptPtr->fullNamePtr); + hPtr = Tcl_CreateHashEntry(&ioPtr->objectOptions, + (char *)ioptPtr->namePtr, &isNew); + Tcl_SetHashValue(hPtr, ioptPtr); + ItclSetInstanceVar(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), + Tcl_GetString(ioptPtr->defaultValuePtr), ioPtr, NULL); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AddDelegatedOptionCmd() + * + * Used to build an option to an [incr Tcl] nwidget/eclass + * + * Syntax: ::itcl::adddelegatedoption <nwidget object> <optionName> <defaultValue> + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_AddDelegatedOptionCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Command cmd; + ItclObjectInfo *infoPtr; + ItclObject *ioPtr; + ItclDelegatedOption *idoPtr; + int isNew; + int result; + + result = TCL_OK; + infoPtr = (ItclObjectInfo *)clientData; + ItclShowArgs(1, "Itcl_AddDelegatedOptionCmd", objc, objv); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "className protection option optionName ..."); + return TCL_ERROR; + } + + cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); + if (cmd == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&infoPtr->objectCmds, (char *)cmd); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + ioPtr = Tcl_GetHashValue(hPtr); + result = Itcl_HandleDelegateOptionCmd(interp, ioPtr, NULL, &idoPtr, + objc-3, objv+3); + if (result != TCL_OK) { + return result; + } + hPtr = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions, + (char *)idoPtr->namePtr, &isNew); + Tcl_SetHashValue(hPtr, idoPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AddDelegatedFunctionCmd() + * + * Used to build an function to an [incr Tcl] nwidget/eclass + * + * Syntax: ::itcl::adddelegatedfunction <nwidget object> <fucntionName> ... + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_AddDelegatedFunctionCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Command cmd; + Tcl_Obj *componentNamePtr; + ItclObjectInfo *infoPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + ItclHierIter hier; + const char *val; + int isNew; + int result; + + result = TCL_OK; + infoPtr = (ItclObjectInfo *)clientData; + ItclShowArgs(1, "Itcl_AddDelegatedFunctionCmd", objc, objv); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "className protection method/proc functionName ..."); + return TCL_ERROR; + } + + cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); + if (cmd == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&infoPtr->objectCmds, (char *)cmd); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" not found", NULL); + return TCL_ERROR; + } + ioPtr = Tcl_GetHashValue(hPtr); + result = Itcl_HandleDelegateMethodCmd(interp, ioPtr, NULL, &idmPtr, + objc-3, objv+3); + if (result != TCL_OK) { + return result; + } + componentNamePtr = idmPtr->icPtr->namePtr; + Itcl_InitHierIter(&hier, ioPtr->iclsPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *) + componentNamePtr); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + val = Itcl_GetInstanceVar(interp, + Tcl_GetString(componentNamePtr), ioPtr, iclsPtr); + componentNamePtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(componentNamePtr); + DelegateFunction(interp, ioPtr, ioPtr->iclsPtr, componentNamePtr, idmPtr); + hPtr = Tcl_CreateHashEntry(&ioPtr->objectDelegatedFunctions, + (char *)idmPtr->namePtr, &isNew); + Tcl_DecrRefCount(componentNamePtr); + Tcl_SetHashValue(hPtr, idmPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AddComponentCmd() + * + * Used to add a component to an [incr Tcl] nwidget/eclass + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_AddComponentCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_DString buffer; + Tcl_DString buffer2; + Tcl_Namespace *varNsPtr; + Tcl_Namespace *nsPtr; + Tcl_CallFrame frame; + Tcl_Var varPtr; + ItclVarLookup *vlookup; + ItclObject *contextIoPtr; + ItclClass *contextIclsPtr; + ItclComponent *icPtr; + ItclVariable *ivPtr; + const char *varName; + int isNew; + int result; + + result = TCL_OK; + contextIoPtr = NULL; + ItclShowArgs(1, "Itcl_AddComponentCmd", objc, objv); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "objectName componentName"); + return TCL_ERROR; + } + if (Itcl_FindObject(interp, Tcl_GetString(objv[1]), &contextIoPtr) + != TCL_OK) { + return TCL_ERROR; + } + if (contextIoPtr == NULL) { + Tcl_AppendResult(interp, "Itcl_AddComponentCmd contextIoPtr " + "for \"", Tcl_GetString(objv[1]), "\" == NULL", NULL); + return TCL_ERROR; + } + contextIclsPtr = contextIoPtr->iclsPtr; + hPtr = Tcl_CreateHashEntry(&contextIoPtr->objectComponents, (char *)objv[2], + &isNew); + if (!isNew) { + Tcl_AppendResult(interp, "Itcl_AddComponentCmd component \"", + Tcl_GetString(objv[2]), "\" already exists for object \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + if (ItclCreateComponent(interp, contextIclsPtr, objv[2], /* not common */0, + &icPtr) != TCL_OK) { + return TCL_ERROR; + } + ItclAddClassComponentDictInfo(interp, contextIclsPtr, icPtr); + contextIclsPtr->numVariables++; + Tcl_SetHashValue(hPtr, icPtr); + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1); + Tcl_DStringAppend(&buffer, contextIclsPtr->nsPtr->fullName, -1); + varNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), + NULL, 0); + hPtr = Tcl_FindHashEntry(&contextIclsPtr->variables, (char *)objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "Itcl_AddComponentCmd cannot find component", + " \"", Tcl_GetString(objv[2]), "\"in class variables", NULL); + return TCL_ERROR; + } + ivPtr = Tcl_GetHashValue(hPtr); + /* add entry to the virtual tables */ + vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); + vlookup->ivPtr = ivPtr; + vlookup->usage = 0; + vlookup->leastQualName = NULL; + + /* + * If this variable is PRIVATE to another class scope, + * then mark it as "inaccessible". + */ + vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || + ivPtr->iclsPtr == contextIclsPtr); + + vlookup->varNum = contextIclsPtr->numInstanceVars++; + /* + * Create all possible names for this variable and enter + * them into the variable resolution table: + * var + * class::var + * namesp1::class::var + * namesp2::namesp1::class::var + * ... + */ + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); + nsPtr = contextIclsPtr->nsPtr; + + Tcl_DStringInit(&buffer2); + while (1) { + hPtr = Tcl_CreateHashEntry(&contextIclsPtr->resolveVars, + Tcl_DStringValue(&buffer), &isNew); + + if (isNew) { + Tcl_SetHashValue(hPtr, (ClientData)vlookup); + vlookup->usage++; + + if (!vlookup->leastQualName) { + vlookup->leastQualName = + Tcl_GetHashKey(&contextIclsPtr->resolveVars, hPtr); + } +#ifdef NEW_PROTO_RESOLVER + Itcl_RegisterClassVariable(contextIclsPtr->infoPtr->interp, + contextIclsPtr->nsPtr, Tcl_DStringValue(&buffer), + vlookup->classVarInfoPtr); +#endif + } + + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nsPtr->name, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + nsPtr = nsPtr->parentPtr; + } + Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&buffer); + + + + varName = Tcl_GetString(ivPtr->namePtr); + /* now initialize the variable */ + if (Itcl_PushCallFrame(interp, &frame, varNsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_SetVar2(interp, varName, NULL, + "", TCL_NAMESPACE_ONLY) == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR cannot set", + " variable \"", varName, "\"\n", NULL); + result = TCL_ERROR; + } + Itcl_PopCallFrame(interp); + varPtr = Tcl_NewNamespaceVar(interp, varNsPtr, + Tcl_GetString(ivPtr->namePtr)); + hPtr = Tcl_CreateHashEntry(&contextIoPtr->objectVariables, + (char *)ivPtr, &isNew); + if (isNew) { + Itcl_PreserveVar(varPtr); + Tcl_SetHashValue(hPtr, varPtr); + } else { + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_SetComponentCmd() + * + * Used to set a component for an [incr Tcl] nwidget/eclass + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_SetComponentCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + ItclClass *iclsPtr; + ItclObject *contextIoPtr; + ItclClass *contextIclsPtr; + ItclComponent *icPtr; + ItclDelegatedOption *idoPtr; + ItclHierIter hier; + const char *name; + const char *val; + int result; + + result = TCL_OK; + contextIoPtr = NULL; + ItclShowArgs(1, "Itcl_SetComponentCmd", objc, objv); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "objectName componentName value"); + return TCL_ERROR; + } + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (Itcl_FindObject(interp, name, &contextIoPtr) != TCL_OK) { + return TCL_ERROR; + } + if (contextIoPtr == NULL) { + Tcl_AppendResult(interp, "Itcl_SetComponentCmd contextIoPtr " + "for \"", Tcl_GetString(objv[1]), "\" == NULL", NULL); + return TCL_ERROR; + } + Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); + hPtr = NULL; + while ((contextIclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->components, (char *)objv[2]); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), + "\" has no component \"", Tcl_GetString(objv[2]), "\"", NULL); + return TCL_ERROR; + } + icPtr = Tcl_GetHashValue(hPtr); + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, + contextIoPtr, contextIclsPtr); + if ((val != NULL) && (strlen(val) != 0)) { + /* delete delegated options to the old component here !! */ + Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { + if (strcmp(Tcl_GetString(idoPtr->icPtr->namePtr), + Tcl_GetString(objv[2])) == 0) { + Tcl_DeleteHashEntry(hPtr); + } + } + } + Itcl_DeleteHierIter(&hier); + } + if (ItclSetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, + Tcl_GetString(objv[3]), contextIoPtr, contextIclsPtr) == NULL) { + return TCL_ERROR; + } + val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, + contextIoPtr, contextIclsPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ExtendedClassCmd() + * + * Used to create an [incr Tcl] extended class. + * An extended class is like a class with additional functionality/ + * commands + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ExtendedClassCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *iclsPtr; + int result; + + ItclShowArgs(1, "Itcl_ExtendedClassCmd", objc-1, objv); + result = ItclClassBaseCmd(clientData, interp, ITCL_ECLASS, objc, objv, + &iclsPtr); + if ((iclsPtr == NULL) && (result == TCL_OK)) { + ItclShowArgs(0, "Itcl_ExtendedClassCmd iclsPtr == NULL", objc-1, objv); + return TCL_ERROR; + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_TypeClassCmd() + * + * Used to create an [incr Tcl] type class. + * An type class is like a class with additional functionality/ + * commands. it has no methods and vars but only the equivalent + * of proc and common namely typemethod and typevariable + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_TypeClassCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *objPtr; + ItclClass *iclsPtr; + int result; + + ItclShowArgs(1, "Itcl_TypeClassCmd", objc-1, objv); + result = ItclClassBaseCmd(clientData, interp, ITCL_TYPE, objc, objv, + &iclsPtr); + if ((iclsPtr == NULL) && (result == TCL_OK)) { + ItclShowArgs(0, "Itcl_TypeClassCmd iclsPtr == NULL", objc-1, objv); + return TCL_ERROR; + } + if (result != TCL_OK) { + return result; + } + /* we handle create by ourself !! */ + objPtr = Tcl_NewStringObj("oo::objdefine ", -1); + Tcl_AppendToObj(objPtr, iclsPtr->nsPtr->fullName, -1); + Tcl_AppendToObj(objPtr, " unexport create", -1); + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); + objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); + Tcl_SetResult(interp, Tcl_GetString(objPtr), TCL_VOLATILE); + Tcl_DecrRefCount(objPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassHullTypeCmd() + * + * Used to set a hulltype for a widget + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ClassHullTypeCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + const char *hullTypeName; + int correctArg; + + infoPtr = (ItclObjectInfo *)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + ItclShowArgs(1, "Itcl_ClassHullTypeCmd", objc-1, objv); + if (iclsPtr->flags & ITCL_TYPE) { + Tcl_AppendResult(interp, "can't set hulltype for ::itcl::type", + NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { + Tcl_AppendResult(interp, "can't set hulltype for ", + "::itcl::widgetadaptor", NULL); + return TCL_ERROR; + } + if (objc != 2) { + Tcl_AppendResult(interp, "wrong # args should be: hulltype ", + "<hullTypeName>", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_WIDGET) { + hullTypeName = Tcl_GetString(objv[1]); + if (iclsPtr->hullTypePtr != NULL) { + Tcl_AppendResult(interp, "too many hulltype statements", NULL); + return TCL_ERROR; + } + correctArg = 0; + if (strcmp(hullTypeName, "frame") == 0) { + iclsPtr->flags |= ITCL_WIDGET_FRAME; + correctArg = 1; + } + if (strcmp(hullTypeName, "labelframe") == 0) { + iclsPtr->flags |= ITCL_WIDGET_LABEL_FRAME; + correctArg = 1; + } + if (strcmp(hullTypeName, "toplevel") == 0) { + iclsPtr->flags |= ITCL_WIDGET_TOPLEVEL; + correctArg = 1; + } + if (strcmp(hullTypeName, "ttk::frame") == 0) { + iclsPtr->flags |= ITCL_WIDGET_TTK_FRAME; + correctArg = 1; + } + if (strcmp(hullTypeName, "ttk::labelframe") == 0) { + iclsPtr->flags |= ITCL_WIDGET_TTK_LABEL_FRAME; + correctArg = 1; + } + if (strcmp(hullTypeName, "ttk::toplevel") == 0) { + iclsPtr->flags |= ITCL_WIDGET_TTK_TOPLEVEL; + correctArg = 1; + } + if (!correctArg) { + Tcl_AppendResult(interp, + "syntax: must be hulltype frame|toplevel|labelframe|", + "ttk::frame|ttk::toplevel|ttk::labelframe", NULL); + return TCL_ERROR; + } + iclsPtr->hullTypePtr = Tcl_NewStringObj(hullTypeName, -1); + Tcl_IncrRefCount(iclsPtr->hullTypePtr); + return TCL_OK; + } + Tcl_AppendResult(interp, "invalid command name \"hulltype\"", NULL); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassWidgetClassCmd() + * + * Used to set a widgetclass for a widget + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ClassWidgetClassCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + const char *widgetClassName; + + infoPtr = (ItclObjectInfo *)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + ItclShowArgs(1, "Itcl_ClassWidgetClassCmd", objc-1, objv); + if (iclsPtr->flags & ITCL_TYPE) { + Tcl_AppendResult(interp, "can't set widgetclass for ::itcl::type", + NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { + Tcl_AppendResult(interp, "can't set widgetclass for ", + "::itcl::widgetadaptor", NULL); + return TCL_ERROR; + } + if (objc != 2) { + Tcl_AppendResult(interp, "wrong # args should be: widgetclass ", + "<widgetClassName>", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_WIDGET) { + widgetClassName = Tcl_GetString(objv[1]); + if (!isupper(UCHAR(*widgetClassName))) { + Tcl_AppendResult(interp, "widgetclass \"", widgetClassName, + "\" does not begin with an uppercase letter", NULL); + return TCL_ERROR; + } + if (iclsPtr->widgetClassPtr != NULL) { + Tcl_AppendResult(interp, "too many widgetclass statements", NULL); + return TCL_ERROR; + } + iclsPtr->widgetClassPtr = Tcl_NewStringObj(widgetClassName, -1); + Tcl_IncrRefCount(iclsPtr->widgetClassPtr); + return TCL_OK; + } + Tcl_AppendResult(interp, "invalid command name \"widgetclass\"", NULL); + return TCL_ERROR; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclDecls.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclDecls.h new file mode 100644 index 0000000..4af4200 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclDecls.h @@ -0,0 +1,201 @@ +/* + * This file is (mostly) automatically generated from itcl.decls. + */ + +#ifndef _ITCLDECLS +#define _ITCLDECLS + +#if defined(USE_ITCL_STUBS) + +ITCLAPI const char *Itcl_InitStubs( + Tcl_Interp *, const char *version, int exact); +#else + +#define Itcl_InitStubs(interp, version, exact) Tcl_PkgRequire(interp,"itcl",version,exact) + +#endif + + +/* !BEGIN!: Do not edit below this line. */ + +#define ITCL_STUBS_EPOCH 0 +#define ITCL_STUBS_REVISION 150 + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Exported function declarations: + */ + +/* Slot 0 is reserved */ +/* Slot 1 is reserved */ +/* 2 */ +ITCLAPI int Itcl_RegisterC(Tcl_Interp *interp, const char *name, + Tcl_CmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +/* 3 */ +ITCLAPI int Itcl_RegisterObjC(Tcl_Interp *interp, + const char *name, Tcl_ObjCmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +/* 4 */ +ITCLAPI int Itcl_FindC(Tcl_Interp *interp, const char *name, + Tcl_CmdProc **argProcPtr, + Tcl_ObjCmdProc **objProcPtr, + ClientData *cDataPtr); +/* 5 */ +ITCLAPI void Itcl_InitStack(Itcl_Stack *stack); +/* 6 */ +ITCLAPI void Itcl_DeleteStack(Itcl_Stack *stack); +/* 7 */ +ITCLAPI void Itcl_PushStack(ClientData cdata, Itcl_Stack *stack); +/* 8 */ +ITCLAPI ClientData Itcl_PopStack(Itcl_Stack *stack); +/* 9 */ +ITCLAPI ClientData Itcl_PeekStack(Itcl_Stack *stack); +/* 10 */ +ITCLAPI ClientData Itcl_GetStackValue(Itcl_Stack *stack, int pos); +/* 11 */ +ITCLAPI void Itcl_InitList(Itcl_List *listPtr); +/* 12 */ +ITCLAPI void Itcl_DeleteList(Itcl_List *listPtr); +/* 13 */ +ITCLAPI Itcl_ListElem * Itcl_CreateListElem(Itcl_List *listPtr); +/* 14 */ +ITCLAPI Itcl_ListElem * Itcl_DeleteListElem(Itcl_ListElem *elemPtr); +/* 15 */ +ITCLAPI Itcl_ListElem * Itcl_InsertList(Itcl_List *listPtr, ClientData val); +/* 16 */ +ITCLAPI Itcl_ListElem * Itcl_InsertListElem(Itcl_ListElem *pos, + ClientData val); +/* 17 */ +ITCLAPI Itcl_ListElem * Itcl_AppendList(Itcl_List *listPtr, ClientData val); +/* 18 */ +ITCLAPI Itcl_ListElem * Itcl_AppendListElem(Itcl_ListElem *pos, + ClientData val); +/* 19 */ +ITCLAPI void Itcl_SetListValue(Itcl_ListElem *elemPtr, + ClientData val); +/* 20 */ +ITCLAPI void Itcl_EventuallyFree(ClientData cdata, + Tcl_FreeProc *fproc); +/* 21 */ +ITCLAPI void Itcl_PreserveData(ClientData cdata); +/* 22 */ +ITCLAPI void Itcl_ReleaseData(ClientData cdata); +/* 23 */ +ITCLAPI Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp *interp, int status); +/* 24 */ +ITCLAPI int Itcl_RestoreInterpState(Tcl_Interp *interp, + Itcl_InterpState state); +/* 25 */ +ITCLAPI void Itcl_DiscardInterpState(Itcl_InterpState state); + +typedef struct { + const struct ItclIntStubs *itclIntStubs; +} ItclStubHooks; + +typedef struct ItclStubs { + int magic; + int epoch; + int revision; + const ItclStubHooks *hooks; + + void (*reserved0)(void); + void (*reserved1)(void); + int (*itcl_RegisterC) (Tcl_Interp *interp, const char *name, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 2 */ + int (*itcl_RegisterObjC) (Tcl_Interp *interp, const char *name, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 3 */ + int (*itcl_FindC) (Tcl_Interp *interp, const char *name, Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr, ClientData *cDataPtr); /* 4 */ + void (*itcl_InitStack) (Itcl_Stack *stack); /* 5 */ + void (*itcl_DeleteStack) (Itcl_Stack *stack); /* 6 */ + void (*itcl_PushStack) (ClientData cdata, Itcl_Stack *stack); /* 7 */ + ClientData (*itcl_PopStack) (Itcl_Stack *stack); /* 8 */ + ClientData (*itcl_PeekStack) (Itcl_Stack *stack); /* 9 */ + ClientData (*itcl_GetStackValue) (Itcl_Stack *stack, int pos); /* 10 */ + void (*itcl_InitList) (Itcl_List *listPtr); /* 11 */ + void (*itcl_DeleteList) (Itcl_List *listPtr); /* 12 */ + Itcl_ListElem * (*itcl_CreateListElem) (Itcl_List *listPtr); /* 13 */ + Itcl_ListElem * (*itcl_DeleteListElem) (Itcl_ListElem *elemPtr); /* 14 */ + Itcl_ListElem * (*itcl_InsertList) (Itcl_List *listPtr, ClientData val); /* 15 */ + Itcl_ListElem * (*itcl_InsertListElem) (Itcl_ListElem *pos, ClientData val); /* 16 */ + Itcl_ListElem * (*itcl_AppendList) (Itcl_List *listPtr, ClientData val); /* 17 */ + Itcl_ListElem * (*itcl_AppendListElem) (Itcl_ListElem *pos, ClientData val); /* 18 */ + void (*itcl_SetListValue) (Itcl_ListElem *elemPtr, ClientData val); /* 19 */ + void (*itcl_EventuallyFree) (ClientData cdata, Tcl_FreeProc *fproc); /* 20 */ + void (*itcl_PreserveData) (ClientData cdata); /* 21 */ + void (*itcl_ReleaseData) (ClientData cdata); /* 22 */ + Itcl_InterpState (*itcl_SaveInterpState) (Tcl_Interp *interp, int status); /* 23 */ + int (*itcl_RestoreInterpState) (Tcl_Interp *interp, Itcl_InterpState state); /* 24 */ + void (*itcl_DiscardInterpState) (Itcl_InterpState state); /* 25 */ +} ItclStubs; + +extern const ItclStubs *itclStubsPtr; + +#ifdef __cplusplus +} +#endif + +#if defined(USE_ITCL_STUBS) + +/* + * Inline function declarations: + */ + +/* Slot 0 is reserved */ +/* Slot 1 is reserved */ +#define Itcl_RegisterC \ + (itclStubsPtr->itcl_RegisterC) /* 2 */ +#define Itcl_RegisterObjC \ + (itclStubsPtr->itcl_RegisterObjC) /* 3 */ +#define Itcl_FindC \ + (itclStubsPtr->itcl_FindC) /* 4 */ +#define Itcl_InitStack \ + (itclStubsPtr->itcl_InitStack) /* 5 */ +#define Itcl_DeleteStack \ + (itclStubsPtr->itcl_DeleteStack) /* 6 */ +#define Itcl_PushStack \ + (itclStubsPtr->itcl_PushStack) /* 7 */ +#define Itcl_PopStack \ + (itclStubsPtr->itcl_PopStack) /* 8 */ +#define Itcl_PeekStack \ + (itclStubsPtr->itcl_PeekStack) /* 9 */ +#define Itcl_GetStackValue \ + (itclStubsPtr->itcl_GetStackValue) /* 10 */ +#define Itcl_InitList \ + (itclStubsPtr->itcl_InitList) /* 11 */ +#define Itcl_DeleteList \ + (itclStubsPtr->itcl_DeleteList) /* 12 */ +#define Itcl_CreateListElem \ + (itclStubsPtr->itcl_CreateListElem) /* 13 */ +#define Itcl_DeleteListElem \ + (itclStubsPtr->itcl_DeleteListElem) /* 14 */ +#define Itcl_InsertList \ + (itclStubsPtr->itcl_InsertList) /* 15 */ +#define Itcl_InsertListElem \ + (itclStubsPtr->itcl_InsertListElem) /* 16 */ +#define Itcl_AppendList \ + (itclStubsPtr->itcl_AppendList) /* 17 */ +#define Itcl_AppendListElem \ + (itclStubsPtr->itcl_AppendListElem) /* 18 */ +#define Itcl_SetListValue \ + (itclStubsPtr->itcl_SetListValue) /* 19 */ +#define Itcl_EventuallyFree \ + (itclStubsPtr->itcl_EventuallyFree) /* 20 */ +#define Itcl_PreserveData \ + (itclStubsPtr->itcl_PreserveData) /* 21 */ +#define Itcl_ReleaseData \ + (itclStubsPtr->itcl_ReleaseData) /* 22 */ +#define Itcl_SaveInterpState \ + (itclStubsPtr->itcl_SaveInterpState) /* 23 */ +#define Itcl_RestoreInterpState \ + (itclStubsPtr->itcl_RestoreInterpState) /* 24 */ +#define Itcl_DiscardInterpState \ + (itclStubsPtr->itcl_DiscardInterpState) /* 25 */ + +#endif /* defined(USE_ITCL_STUBS) */ + +/* !END!: Do not edit above this line. */ + +#endif /* _ITCLDECLS */ diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclEnsemble.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclEnsemble.c new file mode 100644 index 0000000..1d5ac19 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclEnsemble.c @@ -0,0 +1,2243 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This part handles ensembles, which support compound commands in Tcl. + * The usual "info" command is an ensemble with parts like "info body" + * and "info globals". Extension developers can extend commands like + * "info" by adding their own parts to the ensemble. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +#define ITCL_ENSEMBLE_CUSTOM 0x01 +#define ITCL_ENSEMBLE_ENSEMBLE 0x02 + +/* + * Data used to represent an ensemble: + */ +struct Ensemble; +typedef struct EnsemblePart { + char *name; /* name of this part */ + Tcl_Obj *namePtr; + Tcl_Command cmdPtr; /* command handling this part */ + char *usage; /* usage string describing syntax */ + struct Ensemble* ensemble; /* ensemble containing this part */ + ItclArgList *arglistPtr; /* the parsed argument list */ + Tcl_ObjCmdProc *objProc; /* handling procedure for part */ + ClientData *clientData; /* the procPtr for the part */ + Tcl_CmdDeleteProc *deleteProc; + /* procedure used to destroy client data */ + int minChars; /* chars needed to uniquely identify part */ + int flags; + Tcl_Interp *interp; + Tcl_Obj *mapNamePtr; + Tcl_Obj *subEnsemblePtr; + Tcl_Obj *newMapDict; +} EnsemblePart; + +#define ENSEMBLE_DELETE_STARTED 0x1 +#define ENSEMBLE_PART_DELETE_STARTED 0x2 + +/* + * Data used to represent an ensemble: + */ +typedef struct Ensemble { + Tcl_Interp *interp; /* interpreter containing this ensemble */ + EnsemblePart **parts; /* list of parts in this ensemble */ + int numParts; /* number of parts in part list */ + int maxParts; /* current size of parts list */ + int ensembleId; /* this ensembles id */ + Tcl_Command cmdPtr; /* command representing this ensemble */ + EnsemblePart* parent; /* parent part for sub-ensembles + * NULL => toplevel ensemble */ + Tcl_Namespace *nsPtr; /* namespace for ensemble part commands */ + int flags; + Tcl_Obj *namePtr; +} Ensemble; + +/* + * Data shared by ensemble access commands and ensemble parser: + */ +typedef struct EnsembleParser { + Tcl_Interp* master; /* master interp containing ensembles */ + Tcl_Interp* parser; /* slave interp for parsing */ + Ensemble* ensData; /* add parts to this ensemble */ +} EnsembleParser; + +static int EnsembleSubCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int EnsembleUnknownCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); + +/* + * Forward declarations for the procedures used in this file. + */ +static void GetEnsembleUsage (Tcl_Interp *interp, + Ensemble *ensData, Tcl_Obj *objPtr); +static void GetEnsemblePartUsage (Tcl_Interp *interp, + Ensemble *ensData, EnsemblePart *ensPart, Tcl_Obj *objPtr); +static int CreateEnsemble (Tcl_Interp *interp, + Ensemble *parentEnsData, const char *ensName); +static int AddEnsemblePart (Tcl_Interp *interp, + Ensemble* ensData, const char* partName, const char* usageInfo, + Tcl_ObjCmdProc *objProc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc, int flags, EnsemblePart **rVal); +static int FindEnsemble (Tcl_Interp *interp, const char **nameArgv, + int nameArgc, Ensemble** ensDataPtr); +static int CreateEnsemblePart (Tcl_Interp *interp, + Ensemble *ensData, const char* partName, EnsemblePart **ensPartPtr); +static void DeleteEnsemblePart (ClientData clientData); +static int FindEnsemblePart (Tcl_Interp *interp, + Ensemble *ensData, const char* partName, EnsemblePart **rensPart); +static void DeleteEnsemble(ClientData clientData); +static int FindEnsemblePartIndex (Ensemble *ensData, + const char *partName, int *posPtr); +static void ComputeMinChars (Ensemble *ensData, int pos); +static EnsembleParser* GetEnsembleParser (Tcl_Interp *interp); +static void DeleteEnsParser (ClientData clientData, Tcl_Interp* interp); + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleInit -- + * + * Called when any interpreter is created to make sure that + * things are properly set up for ensembles. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * On the first call, the "ensemble" object type is registered + * with the Tcl compiler. If an error is encountered, an error + * is left as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Itcl_EnsembleInit( + Tcl_Interp *interp) /* interpreter being initialized */ +{ + Tcl_DString buffer; + Tcl_InterpDeleteProc *procPtr; + ItclObjectInfo *infoPtr; + + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + Tcl_CreateObjCommand(interp, "::itcl::ensemble", + Itcl_EnsembleCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_COMMANDS_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, "::ensembles", -1); + infoPtr->ensembleInfo->ensembleNsPtr = Tcl_CreateNamespace(interp, + Tcl_DStringValue(&buffer), NULL, NULL); + Tcl_DStringFree(&buffer); + if (infoPtr->ensembleInfo->ensembleNsPtr == NULL) { + Tcl_AppendResult(interp, "error in creating namespace: ", + Tcl_DStringValue(&buffer), NULL); + return TCL_ERROR; + } + Tcl_CreateObjCommand(interp, + ITCL_COMMANDS_NAMESPACE "::ensembles::unknown", + EnsembleUnknownCmd, NULL, NULL); + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_CreateEnsemble -- + * + * Creates an ensemble command, or adds a sub-ensemble to an + * existing ensemble command. The ensemble name is a space- + * separated list. The first word in the list is the command + * name for the top-level ensemble. Other names do not have + * commands associated with them; they are merely sub-ensembles + * within the ensemble. So a name like "a::b::foo bar baz" + * represents an ensemble command called "foo" in the namespace + * "a::b" that has a sub-ensemble "bar", that has a sub-ensemble + * "baz". + * + * If the name is a single word, then this procedure creates + * a top-level ensemble and installs an access command for it. + * If a command already exists with that name, it is deleted. + * + * If the name has more than one word, then the leading words + * are treated as a path name for an existing ensemble. The + * last word is treated as the name for a new sub-ensemble. + * If an part already exists with that name, it is an error. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_CreateEnsemble( + Tcl_Interp *interp, /* interpreter to be updated */ + const char* ensName) /* name of the new ensemble */ +{ + const char **nameArgv = NULL; + int nameArgc; + Ensemble *parentEnsData; + + /* + * Split the ensemble name into its path components. + */ + if (Tcl_SplitList(interp, (const char *)ensName, &nameArgc, + &nameArgv) != TCL_OK) { + goto ensCreateFail; + } + if (nameArgc < 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", ensName, "\"", + (char*)NULL); + goto ensCreateFail; + } + + /* + * If there is more than one path component, then follow + * the path down to the last component, to find the containing + * ensemble. + */ + parentEnsData = NULL; + if (nameArgc > 1) { + if (FindEnsemble(interp, nameArgv, nameArgc-1, &parentEnsData) + != TCL_OK) { + goto ensCreateFail; + } + + if (parentEnsData == NULL) { + char *pname = Tcl_Merge(nameArgc-1, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + goto ensCreateFail; + } + } + + /* + * Create the ensemble. + */ + if (CreateEnsemble(interp, parentEnsData, nameArgv[nameArgc-1]) + != TCL_OK) { + goto ensCreateFail; + } + + ckfree((char*)nameArgv); + return TCL_OK; + +ensCreateFail: + if (nameArgv) { + ckfree((char*)nameArgv); + } + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while creating ensemble \"%s\")", + ensName)); + + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_AddEnsemblePart -- + * + * Adds a part to an ensemble which has been created by + * Itcl_CreateEnsemble. Ensembles are addressed by name, as + * described in Itcl_CreateEnsemble. + * + * If the ensemble already has a part with the specified name, + * this procedure returns an error. Otherwise, it adds a new + * part to the ensemble. + * + * Any client data specified is automatically passed to the + * handling procedure whenever the part is invoked. It is + * automatically destroyed by the deleteProc when the part is + * deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_AddEnsemblePart( + Tcl_Interp *interp, /* interpreter to be updated */ + const char* ensName, /* ensemble containing this part */ + const char* partName, /* name of the new part */ + const char* usageInfo, /* usage info for argument list */ + Tcl_ObjCmdProc *objProc, /* handling procedure for part */ + ClientData clientData, /* client data associated with part */ + Tcl_CmdDeleteProc *deleteProc) /* procedure used to destroy client data */ +{ + const char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + EnsemblePart *ensPart; + + /* + * Parse the ensemble name and look for a containing ensemble. + */ + if (Tcl_SplitList(interp, (const char *)ensName, &nameArgc, + &nameArgv) != TCL_OK) { + goto ensPartFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensPartFail; + } + + if (ensData == NULL) { + char *pname = Tcl_Merge(nameArgc, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + goto ensPartFail; + } + + /* + * Install the new part into the part list. + */ + if (AddEnsemblePart(interp, ensData, partName, usageInfo, + objProc, clientData, deleteProc, ITCL_ENSEMBLE_CUSTOM, + &ensPart) != TCL_OK) { + goto ensPartFail; + } + + ckfree((char*)nameArgv); + return TCL_OK; + +ensPartFail: + if (nameArgv) { + ckfree((char*)nameArgv); + } + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while adding to ensemble \"%s\")", + ensName)); + + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsemblePart -- + * + * Looks for a part within an ensemble, and returns information + * about it. + * + * Results: + * If the ensemble and its part are found, this procedure + * loads information about the part into the "infoPtr" structure + * and returns 1. Otherwise, it returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsemblePart( + Tcl_Interp *interp, /* interpreter to be updated */ + const char *ensName, /* ensemble containing the part */ + const char *partName, /* name of the desired part */ + Tcl_CmdInfo *infoPtr) /* returns: info associated with part */ +{ + const char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + EnsemblePart *ensPart; + Itcl_InterpState state; + + /* + * Parse the ensemble name and look for a containing ensemble. + * Save the interpreter state before we do this. If we get any + * errors, we don't want them to affect the interpreter. + */ + state = Itcl_SaveInterpState(interp, TCL_OK); + + if (Tcl_SplitList(interp, (const char *)ensName, &nameArgc, + &nameArgv) != TCL_OK) { + goto ensGetFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensGetFail; + } + if (ensData == NULL) { + goto ensGetFail; + } + + /* + * Look for a part with the desired name. If found, load + * its data into the "infoPtr" structure. + */ + if (FindEnsemblePart(interp, ensData, partName, &ensPart) + != TCL_OK || ensPart == NULL) { + goto ensGetFail; + } + + if (Tcl_GetCommandInfoFromToken(ensPart->cmdPtr, infoPtr) != 1) { + goto ensGetFail; + } + + Itcl_DiscardInterpState(state); + ckfree((char *)nameArgv); + return 1; + +ensGetFail: + if (nameArgv) { + ckfree((char *)nameArgv); + } + Itcl_RestoreInterpState(interp, state); + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_IsEnsemble -- + * + * Determines whether or not an existing command is an ensemble. + * + * Results: + * Returns non-zero if the command is an ensemble, and zero + * otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Itcl_IsEnsemble( + Tcl_CmdInfo* infoPtr) /* command info from Tcl_GetCommandInfo() */ +{ + if (infoPtr) { +/* FIXME use CMD and Tcl_IsEnsemble!! */ + return (infoPtr->deleteProc == DeleteEnsemble); + } + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsembleUsage -- + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. Each part is listed on + * a separate line. Having this summary is sometimes useful + * when building error messages for the "@error" handler in + * an ensemble. + * + * Ensembles are accessed by name, as described in + * Itcl_CreateEnsemble. + * + * Results: + * If the ensemble is found, its usage information is appended + * onto the object "objPtr", and this procedure returns + * non-zero. It is the responsibility of the caller to + * initialize and free the object. If anything goes wrong, + * this procedure returns 0. + * + * Side effects: + * Object passed in is modified. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsembleUsage( + Tcl_Interp *interp, /* interpreter containing the ensemble */ + const char *ensName, /* name of the ensemble */ + Tcl_Obj *objPtr) /* returns: summary of usage info */ +{ + const char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + Itcl_InterpState state; + + /* + * Parse the ensemble name and look for the ensemble. + * Save the interpreter state before we do this. If we get + * any errors, we don't want them to affect the interpreter. + */ + state = Itcl_SaveInterpState(interp, TCL_OK); + + if (Tcl_SplitList(interp, (const char *)ensName, &nameArgc, + &nameArgv) != TCL_OK) { + goto ensUsageFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensUsageFail; + } + if (ensData == NULL) { + goto ensUsageFail; + } + + /* + * Add a summary of usage information to the return buffer. + */ + GetEnsembleUsage(interp, ensData, objPtr); + + Itcl_DiscardInterpState(state); + ckfree((char *)nameArgv); + return 1; + +ensUsageFail: + if (nameArgv) { + ckfree((char *)nameArgv); + } + Itcl_RestoreInterpState(interp, state); + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsembleUsageForObj -- + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. This procedure is just + * like Itcl_GetEnsembleUsage, but it determines the desired + * ensemble from a command line argument. The argument should + * be the first argument on the command line--the ensemble + * command or one of its parts. + * + * Results: + * If the ensemble is found, its usage information is appended + * onto the object "objPtr", and this procedure returns + * non-zero. It is the responsibility of the caller to + * initialize and free the object. If anything goes wrong, + * this procedure returns 0. + * + * Side effects: + * Object passed in is modified. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsembleUsageForObj( + Tcl_Interp *interp, /* interpreter containing the ensemble */ + Tcl_Obj *ensObjPtr, /* argument representing ensemble */ + Tcl_Obj *objPtr) /* returns: summary of usage info */ +{ + Ensemble *ensData; + Tcl_Obj *chainObj; + Tcl_Command cmd; + Tcl_CmdInfo infoPtr; + + /* + * If the argument is an ensemble part, then follow the chain + * back to the command word for the entire ensemble. + */ + chainObj = ensObjPtr; + + if (chainObj) { + cmd = Tcl_GetCommandFromObj(interp, chainObj); + if (Tcl_GetCommandInfoFromToken(cmd, &infoPtr) != 1) { + return 0; + } + if (infoPtr.deleteProc == DeleteEnsemble) { + ensData = (Ensemble*)infoPtr.objClientData; + GetEnsembleUsage(interp, ensData, objPtr); + return 1; + } + } + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsembleUsage -- + * + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. Each part is listed on + * a separate line. This procedure is used internally to + * generate usage information for error messages. + * + * Results: + * Appends usage information onto the object in "objPtr". + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +GetEnsembleUsage( + Tcl_Interp *interp, + Ensemble *ensData, /* ensemble data */ + Tcl_Obj *objPtr) /* returns: summary of usage info */ +{ + const char *spaces = " "; + int isOpenEnded = 0; + + int i; + EnsemblePart *ensPart; + + for (i=0; i < ensData->numParts; i++) { + ensPart = ensData->parts[i]; + + if ((*ensPart->name == '@') && (strcmp(ensPart->name,"@error") == 0)) { + isOpenEnded = 1; + } else { + if ((*ensPart->name == '@') && + (strcmp(ensPart->name,"@itcl-builtin_info") == 0)) { + /* the builtin info command is not reported in [incr tcl] */ + continue; + } + Tcl_AppendToObj(objPtr, spaces, -1); + GetEnsemblePartUsage(interp, ensData, ensPart, objPtr); + spaces = "\n "; + } + } + if (isOpenEnded) { + Tcl_AppendToObj(objPtr, + "\n...and others described on the man page", -1); + } +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsemblePartUsage -- + * + * Determines the usage for a single part within an ensemble, + * and appends a summary onto a dynamic string. The usage + * is a combination of the part name and the argument summary. + * It is the caller's responsibility to initialize and free + * the dynamic string. + * + * Results: + * Returns usage information in the object "objPtr". + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +GetEnsemblePartUsage( + Tcl_Interp *interp, + Ensemble *ensData, + EnsemblePart *ensPart, /* ensemble part for usage info */ + Tcl_Obj *objPtr) /* returns: usage information */ +{ + EnsemblePart *part; + Tcl_Command cmdPtr; + const char *name; + Itcl_List trail; + Itcl_ListElem *elem; + Tcl_DString buffer; + + /* + * Build the trail of ensemble names leading to this part. + */ + Tcl_DStringInit(&buffer); + Itcl_InitList(&trail); + for (part=ensPart; part; part=part->ensemble->parent) { + Itcl_InsertList(&trail, (ClientData)part); + } + + while (ensData->parent != NULL) { + ensData = ensData->parent->ensemble; + } + cmdPtr = ensData->cmdPtr; + name = Tcl_GetCommandName(interp, cmdPtr); + Tcl_DStringAppendElement(&buffer, name); + + for (elem=Itcl_FirstListElem(&trail); elem; elem=Itcl_NextListElem(elem)) { + part = (EnsemblePart*)Itcl_GetListValue(elem); + Tcl_DStringAppendElement(&buffer, part->name); + } + Itcl_DeleteList(&trail); + + /* + * If the part has usage info, use it directly. + */ + if (ensPart->usage && *ensPart->usage != '\0') { + Tcl_DStringAppend(&buffer, " ", 1); + Tcl_DStringAppend(&buffer, ensPart->usage, -1); + } else { + + /* + * If the part is itself an ensemble, summarize its usage. + */ + if (ensPart->cmdPtr != NULL) { + if (Tcl_IsEnsemble(ensPart->cmdPtr)) { + Tcl_DStringAppend(&buffer, " option ?arg arg ...?", 21); + } + } + } + + Tcl_AppendToObj(objPtr, Tcl_DStringValue(&buffer), + Tcl_DStringLength(&buffer)); + + Tcl_DStringFree(&buffer); +} + + +/* + *---------------------------------------------------------------------- + * + * CreateEnsemble -- + * + * Creates an ensemble command, or adds a sub-ensemble to an + * existing ensemble command. Works like Itcl_CreateEnsemble, + * except that the ensemble name is a single name, not a path. + * If a parent ensemble is specified, then a new ensemble is + * added to that parent. If a part already exists with the + * same name, it is an error. If a parent ensemble is not + * specified, then a top-level ensemble is created. If a + * command already exists with the same name, it is deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +CreateEnsemble( + Tcl_Interp *interp, /* interpreter to be updated */ + Ensemble *parentEnsData, /* parent ensemble or NULL */ + const char *ensName) /* name of the new ensemble */ +{ + Tcl_Obj *objPtr; + Tcl_DString buffer; + Tcl_HashEntry *hPtr; + Tcl_InterpDeleteProc *procPtr; + Tcl_Obj *mapDict; + Tcl_Obj *toObjPtr; + ItclObjectInfo *infoPtr; + Ensemble *ensData; + EnsemblePart *ensPart; + int result; + int isNew; + char buf[20]; + Tcl_Obj *unkObjPtr; + + /* + * Create the data associated with the ensemble. + */ + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr->ensembleInfo->numEnsembles++; + ensData = (Ensemble*)ckalloc(sizeof(Ensemble)); + memset(ensData, 0, sizeof(Ensemble)); + ensData->namePtr = Tcl_NewStringObj(ensName, -1); + Tcl_IncrRefCount(ensData->namePtr); + ensData->interp = interp; + ensData->numParts = 0; + ensData->maxParts = 10; + ensData->ensembleId = infoPtr->ensembleInfo->numEnsembles; + ensData->parts = (EnsemblePart**)ckalloc( + (unsigned)(ensData->maxParts*sizeof(EnsemblePart*)) + ); + memset(ensData->parts, 0, ensData->maxParts*sizeof(EnsemblePart*)); + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_COMMANDS_NAMESPACE "::ensembles::", -1); + sprintf(buf, "%d", ensData->ensembleId); + Tcl_DStringAppend(&buffer, buf, -1); + ensData->nsPtr = Tcl_CreateNamespace(interp, Tcl_DStringValue(&buffer), + ensData, DeleteEnsemble); + if (ensData->nsPtr == NULL) { + Tcl_AppendResult(interp, "error in creating namespace: ", + Tcl_DStringValue(&buffer), NULL); + result = TCL_ERROR; + goto finish; + } + + /* + * If there is no parent data, then this is a top-level + * ensemble. Create the ensemble by installing its access + * command. + */ + if (parentEnsData == NULL) { + Tcl_Obj *unkObjPtr; + ensData->cmdPtr = Tcl_CreateEnsemble(interp, ensName, + Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX); + hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles, + (char *)ensData->cmdPtr, &isNew); + if (!isNew) { + result = TCL_ERROR; + goto finish; + } + Tcl_SetHashValue(hPtr, (ClientData)ensData); + unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1); + Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1); + if (Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr, + unkObjPtr) != TCL_OK) { + Tcl_DecrRefCount(unkObjPtr); + result = TCL_ERROR; + goto finish; + } + + Tcl_SetResult(interp, Tcl_DStringValue(&buffer), TCL_VOLATILE); + result = TCL_OK; + goto finish; + } + + /* + * Otherwise, this ensemble is contained within another parent. + * Install the new ensemble as a part within its parent. + */ + if (CreateEnsemblePart(interp, parentEnsData, ensName, &ensPart) + != TCL_OK) { + DeleteEnsemble((ClientData)ensData); + result = TCL_ERROR; + goto finish; + } + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, infoPtr->ensembleInfo->ensembleNsPtr->fullName, -1); + Tcl_DStringAppend(&buffer, "::subensembles::", -1); + sprintf(buf, "%d", parentEnsData->ensembleId); + Tcl_DStringAppend(&buffer, buf, -1); + Tcl_DStringAppend(&buffer, "::", 2); + Tcl_DStringAppend(&buffer, ensName, -1); + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->subEnsembles, + (char *)objPtr, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, ensData); + } + + ensPart->subEnsemblePtr = objPtr; + Tcl_IncrRefCount(ensPart->subEnsemblePtr); + ensPart->cmdPtr = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buffer), + Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX); + hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles, + (char *)ensPart->cmdPtr, &isNew); + if (!isNew) { + result = TCL_ERROR; + goto finish; + } + Tcl_SetHashValue(hPtr, (ClientData)ensData); + unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1); + Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1); + if (Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr, + unkObjPtr) != TCL_OK) { + result = TCL_ERROR; + goto finish; + } + + Tcl_GetEnsembleMappingDict(NULL, parentEnsData->cmdPtr, &mapDict); + if (mapDict == NULL) { + mapDict = Tcl_NewObj(); + } + toObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + Tcl_DictObjPut(NULL, mapDict, ensData->namePtr, toObjPtr); + Tcl_SetEnsembleMappingDict(NULL, parentEnsData->cmdPtr, mapDict); + ensData->cmdPtr = ensPart->cmdPtr; + ensData->parent = ensPart; + result = TCL_OK; + +finish: + Tcl_DStringFree(&buffer); + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * AddEnsemblePart -- + * + * Adds a part to an existing ensemble. Works like + * Itcl_AddEnsemblePart, but the part name is a single word, + * not a path. + * + * If the ensemble already has a part with the specified name, + * this procedure returns an error. Otherwise, it adds a new + * part to the ensemble. + * + * Any client data specified is automatically passed to the + * handling procedure whenever the part is invoked. It is + * automatically destroyed by the deleteProc when the part is + * deleted. + * + * Results: + * Returns TCL_OK if successful, along with a pointer to the + * new part. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +AddEnsemblePart( + Tcl_Interp *interp, /* interpreter to be updated */ + Ensemble* ensData, /* ensemble that will contain this part */ + const char* partName, /* name of the new part */ + const char* usageInfo, /* usage info for argument list */ + Tcl_ObjCmdProc *objProc, /* handling procedure for part */ + ClientData clientData, /* client data associated with part */ + Tcl_CmdDeleteProc *deleteProc, /* procedure used to destroy client data */ + int flags, + EnsemblePart **rVal) /* returns: new ensemble part */ +{ + Tcl_Obj *mapDict; + Tcl_Command cmd; + EnsemblePart *ensPart; + + /* + * Install the new part into the part list. + */ + if (CreateEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { + return TCL_ERROR; + } + + if (usageInfo) { + ensPart->usage = ckalloc((unsigned)(strlen(usageInfo)+1)); + strcpy(ensPart->usage, usageInfo); + } + ensPart->objProc = objProc; + ensPart->clientData = clientData; + ensPart->deleteProc = deleteProc; + ensPart->flags = flags; + + mapDict = NULL; + Tcl_GetEnsembleMappingDict(NULL, ensData->cmdPtr, &mapDict); + if (mapDict == NULL) { + mapDict = Tcl_NewObj(); + ensPart->newMapDict = mapDict; + } + ensPart->mapNamePtr = Tcl_NewStringObj(ensData->nsPtr->fullName, -1); + Tcl_AppendToObj(ensPart->mapNamePtr, "::", 2); + Tcl_AppendToObj(ensPart->mapNamePtr, partName, -1); + Tcl_IncrRefCount(ensPart->namePtr); + Tcl_IncrRefCount(ensPart->mapNamePtr); + Tcl_DictObjPut(NULL, mapDict, ensPart->namePtr, ensPart->mapNamePtr); + cmd = Tcl_CreateObjCommand(interp, Tcl_GetString(ensPart->mapNamePtr), + EnsembleSubCmd, ensPart, DeleteEnsemblePart); + if (cmd == NULL) { + Tcl_DictObjRemove(NULL, mapDict, ensPart->namePtr); + Tcl_DecrRefCount(ensPart->namePtr); + Tcl_DecrRefCount(ensPart->mapNamePtr); + return TCL_ERROR; + } + Tcl_SetEnsembleMappingDict(interp, ensData->cmdPtr, mapDict); + *rVal = ensPart; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsemble -- + * + * Invoked when the command associated with an ensemble is + * destroyed, to delete the ensemble. Destroys all parts + * included in the ensemble, and frees all memory associated + * with it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +DeleteEnsemble( + ClientData clientData) /* ensemble data */ +{ + FOREACH_HASH_DECLS; + ItclObjectInfo *infoPtr; + Ensemble* ensData; + Ensemble* ensData2; + + ensData = (Ensemble*)clientData; + /* remove the unknown handler if set to release the Tcl_Obj of the name */ + if (Tcl_FindCommand(ensData->interp, Tcl_GetString(ensData->namePtr), + NULL, 0) != NULL) { + Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr, NULL); + } + /* + * BE CAREFUL: Each ensemble part removes itself from the list. + * So keep deleting the first part until all parts are gone. + */ + while (ensData->numParts > 0) { + DeleteEnsemblePart(ensData->parts[0]); + } + Tcl_DecrRefCount(ensData->namePtr); + ckfree((char*)ensData->parts); + ensData->parts = NULL; + ensData->numParts = 0; + infoPtr = Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); + FOREACH_HASH_VALUE(ensData2, &infoPtr->ensembleInfo->ensembles) { + if (ensData2 == ensData) { + Tcl_DeleteHashEntry(hPtr); + } + } + ckfree((char*)ensData); +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemble -- + * + * Searches for an ensemble command and follows a path to + * sub-ensembles. + * + * Results: + * Returns TCL_OK if the ensemble was found, along with a + * pointer to the ensemble data in "ensDataPtr". Returns + * TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemble( + Tcl_Interp *interp, /* interpreter containing the ensemble */ + const char **nameArgv, /* path of names leading to ensemble */ + int nameArgc, /* number of strings in nameArgv */ + Ensemble** ensDataPtr) /* returns: ensemble data */ +{ + int i; + Tcl_Command cmdPtr; + Ensemble *ensData; + EnsemblePart *ensPart; + Tcl_Obj *objPtr; + Tcl_CmdInfo cmdInfo; + Tcl_InterpDeleteProc *procPtr; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + + *ensDataPtr = NULL; /* assume that no data will be found */ + + /* + * If there are no names in the path, then return an error. + */ + if (nameArgc < 1) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"\"", -1); + return TCL_ERROR; + } + + /* + * Use the first name to find the command for the top-level + * ensemble. + */ + objPtr = Tcl_NewStringObj(nameArgv[0], -1); + cmdPtr = Tcl_FindEnsemble(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); + + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", nameArgv[0], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmdPtr); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", nameArgv[0], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble *)Tcl_GetHashValue(hPtr); + + /* + * Follow the trail of sub-ensemble names. + */ + for (i=1; i < nameArgc; i++) { + if (FindEnsemblePart(interp, ensData, nameArgv[i], &ensPart) + != TCL_OK) { + return TCL_ERROR; + } + if (ensPart == NULL) { + char *pname = Tcl_Merge(i, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + return TCL_ERROR; + } + + cmdPtr = ensPart->cmdPtr; + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", nameArgv[i], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + if (!Tcl_IsEnsemble(cmdPtr)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", nameArgv[i], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) != 1) { + return TCL_ERROR; + } + ensData = (Ensemble*)cmdInfo.objClientData; + } + *ensDataPtr = ensData; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * CreateEnsemblePart -- + * + * Creates a new part within an ensemble. + * + * Results: + * If successful, this procedure returns TCL_OK, along with a + * pointer to the new part in "ensPartPtr". If a part with the + * same name already exists, this procedure returns TCL_ERROR. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +CreateEnsemblePart( + Tcl_Interp *interp, /* interpreter containing the ensemble */ + Ensemble *ensData, /* ensemble being modified */ + const char* partName, /* name of the new part */ + EnsemblePart **ensPartPtr) /* returns: new ensemble part */ +{ + int i; + int pos; + int size; + EnsemblePart** partList; + EnsemblePart* ensPart; + + /* + * If a matching entry was found, then return an error. + */ + if (FindEnsemblePartIndex(ensData, partName, &pos)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", partName, "\" already exists in ensemble", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Otherwise, make room for a new entry. Keep the parts in + * lexicographical order, so we can search them quickly + * later. + */ + if (ensData->numParts >= ensData->maxParts) { + size = ensData->maxParts*sizeof(EnsemblePart*); + partList = (EnsemblePart**)ckalloc((unsigned)2*size); + memcpy(partList, ensData->parts, (size_t)size); + ckfree((char*)ensData->parts); + + ensData->parts = partList; + ensData->maxParts *= 2; + } + + for (i=ensData->numParts; i > pos; i--) { + ensData->parts[i] = ensData->parts[i-1]; + } + ensData->numParts++; + + ensPart = (EnsemblePart*)ckalloc(sizeof(EnsemblePart)); + memset(ensPart, 0, sizeof(EnsemblePart)); + ensPart->name = (char*)ckalloc((unsigned)(strlen(partName)+1)); + strcpy(ensPart->name, partName); + ensPart->namePtr = Tcl_NewStringObj(ensPart->name, -1); + ensPart->ensemble = ensData; + ensPart->interp = interp; + + ensData->parts[pos] = ensPart; + + /* + * Compare the new part against the one on either side of + * it. Determine how many letters are needed in each part + * to guarantee that an abbreviated form is unique. Update + * the parts on either side as well, since they are influenced + * by the new part. + */ + ComputeMinChars(ensData, pos); + ComputeMinChars(ensData, pos-1); + ComputeMinChars(ensData, pos+1); + + *ensPartPtr = ensPart; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsemblePart -- + * + * Deletes a single part from an ensemble. The part must have + * been created previously by CreateEnsemblePart. + * + * If the part has a delete proc, then it is called to free the + * associated client data. + * + * Results: + * None. + * + * Side effects: + * Delete proc is called. + * + *---------------------------------------------------------------------- + */ +static void +DeleteEnsemblePart( + ClientData clientData) /* part being destroyed */ +{ + Tcl_Obj *mapDict; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + Ensemble *ensData; + Ensemble *ensData2; + EnsemblePart *ensPart; + int i; + int pos; + + mapDict = NULL; + ensPart = (EnsemblePart *)clientData; + if (ensPart == NULL) { + return; + } + ensData = ensPart->ensemble; + + /* + * If this part has a delete proc, then call it to free + * up the client data. + */ + if ((ensPart->deleteProc != NULL) && (ensPart->clientData != NULL)) { + (*ensPart->deleteProc)(ensPart->clientData); + } + + /* if it is a subensemble remove the command to free the data */ + if (ensPart->subEnsemblePtr != NULL) { + infoPtr = Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->subEnsembles, + (char *)ensPart->subEnsemblePtr); + if (hPtr != NULL) { + ensData2 = Tcl_GetHashValue(hPtr); + Tcl_DeleteNamespace(ensData2->nsPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, + (char *)ensPart->ensemble->cmdPtr); + if (hPtr != NULL) { + ensData2 = Tcl_GetHashValue(hPtr); + Tcl_GetEnsembleMappingDict(NULL, ensData2->cmdPtr, &mapDict); + if (mapDict != NULL) { + Tcl_DictObjRemove(ensPart->interp, mapDict, + ensPart->namePtr); + Tcl_SetEnsembleMappingDict(NULL, ensData2->cmdPtr, mapDict); + } + } + Tcl_DecrRefCount(ensPart->subEnsemblePtr); + if (ensPart->newMapDict != NULL) { + Tcl_DecrRefCount(ensPart->newMapDict); + } + } + /* + * Find this part within its ensemble, and remove it from + * the list of parts. + */ + if (FindEnsemblePartIndex(ensPart->ensemble, ensPart->name, &pos)) { + ensData = ensPart->ensemble; + for (i=pos; i < ensData->numParts-1; i++) { + ensData->parts[i] = ensData->parts[i+1]; + } + ensData->numParts--; + } + + /* + * Free the memory associated with the part. + */ + mapDict = NULL; + if (Tcl_FindCommand(ensData->interp, Tcl_GetString(ensData->namePtr), + NULL, 0) != NULL) { + Tcl_GetEnsembleMappingDict(ensData->interp, ensData->cmdPtr, &mapDict); + if (mapDict != NULL) { + if (!Tcl_IsShared(mapDict)) { + Tcl_DictObjRemove(ensPart->interp, mapDict, ensPart->namePtr); + Tcl_SetEnsembleMappingDict(ensPart->interp, ensData->cmdPtr, + mapDict); + } + } + } + /* this is the map !!! */ + if (ensPart->mapNamePtr != NULL) { + Tcl_DecrRefCount(ensPart->mapNamePtr); + } + Tcl_DecrRefCount(ensPart->namePtr); + if (ensPart->usage != NULL) { + ckfree(ensPart->usage); + } + ckfree(ensPart->name); + ckfree((char*)ensPart); +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemblePart -- + * + * Searches for a part name within an ensemble. Recognizes + * unique abbreviations for part names. + * + * Results: + * If the part name is not a unique abbreviation, this procedure + * returns TCL_ERROR. Otherwise, it returns TCL_OK. If the + * part can be found, "rensPart" returns a pointer to the part. + * Otherwise, it returns NULL. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemblePart( + Tcl_Interp *interp, /* interpreter containing the ensemble */ + Ensemble *ensData, /* ensemble being searched */ + const char* partName, /* name of the desired part */ + EnsemblePart **rensPart) /* returns: pointer to the desired part */ +{ + int pos = 0; + int first, last, nlen; + int i, cmp; + + *rensPart = NULL; + + /* + * Search for the desired part name. + * All parts are in lexicographical order, so use a + * binary search to find the part quickly. Match only + * as many characters as are included in the specified + * part name. + */ + first = 0; + last = ensData->numParts-1; + nlen = strlen(partName); + + while (last >= first) { + pos = (first+last)/2; + if (*partName == *ensData->parts[pos]->name) { + cmp = strncmp(partName, ensData->parts[pos]->name, nlen); + if (cmp == 0) { + break; /* found it! */ + } + } + else if (*partName < *ensData->parts[pos]->name) { + cmp = -1; + } + else { + cmp = 1; + } + + if (cmp > 0) { + first = pos+1; + } else { + last = pos-1; + } + } + + /* + * If a matching entry could not be found, then quit. + */ + if (last < first) { + return TCL_OK; + } + + /* + * If a matching entry was found, there may be some ambiguity + * if the user did not specify enough characters. Find the + * top-most match in the list, and see if the part name has + * enough characters. If there are two parts like "foo" + * and "food", this allows us to match "foo" exactly. + */ + if (nlen < ensData->parts[pos]->minChars) { + while (pos > 0) { + pos--; + if (strncmp(partName, ensData->parts[pos]->name, nlen) != 0) { + pos++; + break; + } + } + } + if (nlen < ensData->parts[pos]->minChars) { + Tcl_Obj *resultPtr = Tcl_NewStringObj((char*)NULL, 0); + + Tcl_AppendStringsToObj(resultPtr, + "ambiguous option \"", partName, "\": should be one of...", + (char*)NULL); + + for (i=pos; i < ensData->numParts; i++) { + if (strncmp(partName, ensData->parts[i]->name, nlen) != 0) { + break; + } + Tcl_AppendToObj(resultPtr, "\n ", 3); + GetEnsemblePartUsage(interp, ensData, ensData->parts[i], resultPtr); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + /* + * Found a match. Return the desired part. + */ + *rensPart = ensData->parts[pos]; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemblePartIndex -- + * + * Searches for a part name within an ensemble. The part name + * must be an exact match for an existing part name in the + * ensemble. This procedure is useful for managing (i.e., + * creating and deleting) parts in an ensemble. + * + * Results: + * If an exact match is found, this procedure returns + * non-zero, along with the index of the part in posPtr. + * Otherwise, it returns zero, along with an index in posPtr + * indicating where the part should be. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemblePartIndex( + Ensemble *ensData, /* ensemble being searched */ + const char *partName, /* name of desired part */ + int *posPtr) /* returns: index for part */ +{ + int pos = 0; + int first, last; + int cmp; + + /* + * Search for the desired part name. + * All parts are in lexicographical order, so use a + * binary search to find the part quickly. + */ + first = 0; + last = ensData->numParts-1; + + while (last >= first) { + pos = (first+last)/2; + if (*partName == *ensData->parts[pos]->name) { + cmp = strcmp(partName, ensData->parts[pos]->name); + if (cmp == 0) { + break; /* found it! */ + } + } + else if (*partName < *ensData->parts[pos]->name) { + cmp = -1; + } + else { + cmp = 1; + } + + if (cmp > 0) { + first = pos+1; + } else { + last = pos-1; + } + } + + if (last >= first) { + *posPtr = pos; + return 1; + } + *posPtr = first; + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * ComputeMinChars -- + * + * Compares part names on an ensemble's part list and + * determines the minimum number of characters needed for a + * unique abbreviation. The parts on either side of a + * particular part index are compared. As long as there is + * a part on one side or the other, this procedure updates + * the parts to have the proper minimum abbreviations. + * + * Results: + * None. + * + * Side effects: + * Updates three parts within the ensemble to remember + * the minimum abbreviations. + * + *---------------------------------------------------------------------- + */ +static void +ComputeMinChars( + Ensemble *ensData, /* ensemble being modified */ + int pos) /* index of part being updated */ +{ + int min, max; + char *p, *q; + + /* + * If the position is invalid, do nothing. + */ + if (pos < 0 || pos >= ensData->numParts) { + return; + } + + /* + * Start by assuming that only the first letter is required + * to uniquely identify this part. Then compare the name + * against each neighboring part to determine the real minimum. + */ + ensData->parts[pos]->minChars = 1; + + if (pos-1 >= 0) { + p = ensData->parts[pos]->name; + q = ensData->parts[pos-1]->name; + for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { + p++; + q++; + } + if (min > ensData->parts[pos]->minChars) { + ensData->parts[pos]->minChars = min; + } + } + + if (pos+1 < ensData->numParts) { + p = ensData->parts[pos]->name; + q = ensData->parts[pos+1]->name; + for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { + p++; + q++; + } + if (min > ensData->parts[pos]->minChars) { + ensData->parts[pos]->minChars = min; + } + } + + max = strlen(ensData->parts[pos]->name); + if (ensData->parts[pos]->minChars > max) { + ensData->parts[pos]->minChars = max; + } +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleCmd -- + * + * Invoked by Tcl whenever the user issues the "ensemble" + * command to manipulate an ensemble. Handles the following + * syntax: + * + * ensemble <ensName> ?<command> <arg> <arg>...? + * ensemble <ensName> { + * part <partName> <args> <body> + * ensemble <ensName> { + * ... + * } + * } + * + * Finds or creates the ensemble <ensName>, and then executes + * the commands to add parts. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_EnsembleCmd( + ClientData clientData, /* ensemble data */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int status; + char *ensName; + EnsembleParser *ensInfo; + Ensemble *ensData; + Ensemble *savedEnsData; + EnsemblePart *ensPart; + Tcl_Command cmd; + Tcl_Obj *objPtr; + Tcl_HashEntry *hPtr; + Tcl_InterpDeleteProc *procPtr; + ItclObjectInfo *infoPtr; + + ItclShowArgs(1, "Itcl_EnsembleCmd", objc, objv); + /* + * Make sure that an ensemble name was specified. + */ + if (objc < 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), + " name ?command arg arg...?\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this is the "ensemble" command in the main interpreter, + * then the client data will be null. Otherwise, it is + * the "ensemble" command in the ensemble body parser, and + * the client data indicates which ensemble we are modifying. + */ + if (clientData) { + ensInfo = (EnsembleParser*)clientData; + } else { + ensInfo = GetEnsembleParser(interp); + } + ensData = ensInfo->ensData; + + /* + * Find or create the desired ensemble. If an ensemble is + * being built, then this "ensemble" command is enclosed in + * another "ensemble" command. Use the current ensemble as + * the parent, and find or create an ensemble part within it. + */ + ensName = Tcl_GetString(objv[1]); + + if (ensData) { + if (FindEnsemblePart(ensInfo->master, ensData, ensName, &ensPart) != TCL_OK) { + ensPart = NULL; + } + if (ensPart == NULL) { + if (CreateEnsemble(ensInfo->master, ensData, ensName) != TCL_OK) { + Tcl_TransferResult(ensInfo->master, TCL_ERROR, interp); + return TCL_ERROR; + } + if (FindEnsemblePart(ensInfo->master, ensData, ensName, &ensPart) + != TCL_OK) { + Tcl_Panic("Itcl_EnsembleCmd: can't create ensemble"); + } + } + + cmd = ensPart->cmdPtr; + infoPtr = Tcl_GetAssocData(ensInfo->master, ITCL_INTERP_DATA, &procPtr); + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, + (char *)ensPart->cmdPtr); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble *)Tcl_GetHashValue(hPtr); + } else { + + /* + * Otherwise, the desired ensemble is a top-level ensemble. + * Find or create the access command for the ensemble, and + * then get its data. + */ + cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + if (cmd == NULL) { + if (CreateEnsemble(interp, (Ensemble*)NULL, ensName) + != TCL_OK) { + return TCL_ERROR; + } + cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + } + + if (cmd == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmd); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble *)Tcl_GetHashValue(hPtr); + } + + /* + * At this point, we have the data for the ensemble that is + * being manipulated. Plug this into the parser, and then + * interpret the rest of the arguments in the ensemble parser. + */ + status = TCL_OK; + savedEnsData = ensInfo->ensData; + ensInfo->ensData = ensData; + + if (objc == 3) { + status = Tcl_EvalObjEx(ensInfo->parser, objv[2], 0); + } else { + if (objc > 3) { + objPtr = Tcl_NewListObj(objc-2, objv+2); + Tcl_IncrRefCount(objPtr); /* stop Eval trashing it */ + status = Tcl_EvalObjEx(ensInfo->parser, objPtr, 0); + Tcl_DecrRefCount(objPtr); /* we're done with the object */ + } + } + + /* + * Copy the result from the parser interpreter to the + * master interpreter. If an error was encountered, + * copy the error info first, and then set the result. + * Otherwise, the offending command is reported twice. + */ + if (status == TCL_ERROR) { + /* no longer needed, no extra interpreter !! */ + const char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo", + (char*)NULL, TCL_GLOBAL_ONLY); + + if (errInfo) { + Tcl_AddObjErrorInfo(interp, (const char *)errInfo, -1); + } + + if (objc == 3) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"ensemble\" body line %d)", + Tcl_GetErrorLine(ensInfo->parser))); + } + } + Tcl_SetObjResult(interp, Tcl_GetObjResult(ensInfo->parser)); + + ensInfo->ensData = savedEnsData; + return status; +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsembleParser -- + * + * Returns the slave interpreter that acts as a parser for + * the body of an "ensemble" definition. The first time that + * this is called for an interpreter, the parser is created + * and registered as associated data. After that, it is + * simply returned. + * + * Results: + * Returns a pointer to the ensemble parser data structure. + * + * Side effects: + * On the first call, the ensemble parser is created and + * registered as "itcl_ensembleParser" with the interpreter. + * + *---------------------------------------------------------------------- + */ +static EnsembleParser* +GetEnsembleParser( + Tcl_Interp *interp) /* interpreter handling the ensemble */ +{ + EnsembleParser *ensInfo; + + /* + * Look for an existing ensemble parser. If it is found, + * return it immediately. + */ + ensInfo = (EnsembleParser*) Tcl_GetAssocData(interp, + "itcl_ensembleParser", NULL); + + if (ensInfo) { + return ensInfo; + } + + /* + * Create a slave interpreter that can be used to parse + * the body of an ensemble definition. + */ + ensInfo = (EnsembleParser*)ckalloc(sizeof(EnsembleParser)); + ensInfo->master = interp; + ensInfo->parser = Tcl_CreateInterp(); + ensInfo->ensData = NULL; + + Tcl_DeleteNamespace(Tcl_GetGlobalNamespace(ensInfo->parser)); + /* + * Add the allowed commands to the parser interpreter: + * part, delete, ensemble + */ + Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + /* + * Install the parser data, so we'll have it the next time + * we call this procedure. + */ + (void) Tcl_SetAssocData(interp, "itcl_ensembleParser", + DeleteEnsParser, (ClientData)ensInfo); + + return ensInfo; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsParser -- + * + * Called when an interpreter is destroyed to clean up the + * ensemble parser within it. Destroys the slave interpreter + * and frees up the data associated with it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +DeleteEnsParser( + ClientData clientData, /* client data for ensemble-related commands */ + Tcl_Interp *interp) /* interpreter containing the data */ +{ + EnsembleParser* ensInfo = (EnsembleParser*)clientData; + Tcl_DeleteInterp(ensInfo->parser); + ckfree((char*)ensInfo); +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsPartCmd -- + * + * Invoked by Tcl whenever the user issues the "part" command + * to manipulate an ensemble. This command can only be used + * inside the "ensemble" command, which handles ensembles. + * Handles the following syntax: + * + * ensemble <ensName> { + * part <partName> <args> <body> + * } + * + * Adds a new part called <partName> to the ensemble. If a + * part already exists with that name, it is an error. The + * new part is handled just like an ordinary Tcl proc, with + * a list of <args> and a <body> of code to execute. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_EnsPartCmd( + ClientData clientData, /* ensemble data */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *usagePtr; + Tcl_Proc procPtr; + EnsembleParser *ensInfo = (EnsembleParser*)clientData; + Ensemble *ensData = (Ensemble*)ensInfo->ensData; + EnsemblePart *ensPart; + ItclArgList *arglistPtr; + char *partName; + char *usage; + int result; + int argc; + int maxArgc; + Tcl_CmdInfo cmdInfo; + + ItclShowArgs(1, "Itcl_EnsPartCmd", objc, objv); + if (objc != 4) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), + " name args body\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Create a Tcl-style proc definition using the specified args + * and body. This is not a proc in the usual sense. It belongs + * to the namespace that contains the ensemble, but it is + * accessed through the ensemble, not through a Tcl command. + */ + partName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + if (ItclCreateArgList(interp, Tcl_GetString(objv[2]), &argc, &maxArgc, + &usagePtr, &arglistPtr, NULL, partName) != TCL_OK) { + result = TCL_ERROR; + goto errorOut; + } + if (Tcl_GetCommandInfoFromToken(ensData->cmdPtr, &cmdInfo) != 1) { + result = TCL_ERROR; + goto errorOut; + } + if (Tcl_CreateProc(ensInfo->master, cmdInfo.namespacePtr, partName, objv[2], objv[3], + &procPtr) != TCL_OK) { + Tcl_TransferResult(ensInfo->master, TCL_ERROR, interp); + result = TCL_ERROR; + goto errorOut; + } + + usage = Tcl_GetString(usagePtr); + + /* + * Create a new part within the ensemble. If successful, + * plug the command token into the proc; we'll need it later + * if we try to compile the Tcl code for the part. If + * anything goes wrong, clean up before bailing out. + */ + result = AddEnsemblePart(ensInfo->master, ensData, partName, usage, + Tcl_GetObjInterpProc(), (ClientData)procPtr, _Tcl_ProcDeleteProc, + ITCL_ENSEMBLE_ENSEMBLE, &ensPart); + Tcl_TransferResult(ensInfo->master, result, interp); + +errorOut: + Tcl_DecrRefCount(usagePtr); + ItclDeleteArgList(arglistPtr); + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleErrorCmd -- + * + * Invoked when the user tries to access an unknown part for + * an ensemble. Acts as the default handler for the "@error" + * part. Generates an error message like: + * + * bad option "foo": should be one of... + * info args procname + * info body procname + * info cmdcount + * ... + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * Returns the error message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Itcl_EnsembleErrorCmd( + ClientData clientData, /* ensemble info */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Ensemble *ensData = (Ensemble*)clientData; + + char *cmdName; + Tcl_Obj *objPtr; + + cmdName = Tcl_GetString(objv[0]); + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_AppendStringsToObj(objPtr, + "bad option \"", cmdName, "\": should be one of...\n", + (char*)NULL); + GetEnsembleUsage(interp, ensData, objPtr); + + Tcl_SetResult(interp, Tcl_GetString(objPtr), TCL_VOLATILE); + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * EnsembleSubCmd -- + * + *---------------------------------------------------------------------- + */ + +static int +CallInvokeEnsembleMethod( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Namespace *nsPtr = data[0]; + EnsemblePart *ensPart = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj *const*objv = data[3]; + + result = Itcl_InvokeEnsembleMethod(interp, nsPtr, ensPart->namePtr, + (Tcl_Proc *)ensPart->clientData, objc, objv); + return result; +} + +static int +CallInvokeEnsembleMethod2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + EnsemblePart *ensPart = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj *const*objv = data[2]; + result = (*ensPart->objProc)(ensPart->clientData, interp, objc, objv); + return result; +} + +static int +EnsembleSubCmd( + ClientData clientData, /* ensPart struct pointer */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int result; + Tcl_Namespace *nsPtr; + EnsemblePart *ensPart; + void *callbackPtr; + + ItclShowArgs(1, "EnsembleSubCmd", objc, objv); + result = TCL_OK; + ensPart = (EnsemblePart *)clientData; + nsPtr = Tcl_GetCurrentNamespace(interp); + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + if (ensPart->flags & ITCL_ENSEMBLE_ENSEMBLE) { + /* FIXME !!! */ + if (ensPart->clientData == NULL) { + return TCL_ERROR; + } + Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod, nsPtr, ensPart, INT2PTR(objc), (ClientData)objv); + } else { + Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod2, ensPart, INT2PTR(objc), (ClientData)objv, NULL); + } + result = Itcl_NRRunCallbacks(interp, callbackPtr); + return result; +} +/* + * ------------------------------------------------------------------------ + * EnsembleUnknownCmd() + * + * the unknown handler for the ensemble commands + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +EnsembleUnknownCmd( + ClientData dummy, /* not used */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Command cmd; + Tcl_HashEntry *hPtr; + Tcl_InterpDeleteProc *procPtr; + ItclObjectInfo *infoPtr; + EnsemblePart *ensPart; + Ensemble *ensData; + + ItclShowArgs(2, "EnsembleUnknownCmd", objc, objv); + cmd = Tcl_GetCommandFromObj(interp, objv[1]); + if (cmd == NULL) { + Tcl_AppendResult(interp, "EnsembleUnknownCmd, ensemble not found!", + Tcl_GetString(objv[1]), NULL); + return TCL_ERROR; + } + infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmd); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "EnsembleUnknownCmd, ensemble struct not ", + "found!", Tcl_GetString(objv[1]), NULL); + return TCL_ERROR; + } + ensData = (Ensemble *)Tcl_GetHashValue(hPtr); + if (objc < 3) { + /* produce usage message */ + Tcl_Obj *objPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + GetEnsembleUsage(interp, ensData, objPtr); + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + if (FindEnsemblePart(interp, ensData, "@error", &ensPart) != TCL_OK) { + Tcl_AppendResult(interp, "FindEnsemblePart error", NULL); + return TCL_ERROR; + } + if (ensPart != NULL) { + Tcl_Obj *listPtr; + + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_ListObjAppendElement(NULL, listPtr, objv[1]); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("@error", -1)); + Tcl_ListObjAppendElement(NULL, listPtr, objv[2]); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + + return Itcl_EnsembleErrorCmd(ensData, interp, objc-2, objv+2); +} + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleDeleteCmd -- + * + * Invoked when the user tries to delet an ensemble + *---------------------------------------------------------------------- + */ +int +Itcl_EnsembleDeleteCmd( + ClientData clientData, /* infoPtr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Command cmdPtr; + Ensemble *ensData; + ItclObjectInfo *infoPtr; + int i; + + infoPtr = (ItclObjectInfo *)clientData; + ItclShowArgs(1, "Itcl_EnsembleDeleteCmd", objc, objv); + for (i = 1; i < objc; i++) { + cmdPtr = Tcl_FindCommand(interp, Tcl_GetString(objv[i]), NULL, 0); + if (cmdPtr == NULL) { + Tcl_AppendResult(interp, "no such ensemble \"", + Tcl_GetString(objv[i]), "\"", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmdPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "no such ensemble \"", + Tcl_GetString(objv[i]), "\"", NULL); + return TCL_ERROR; + } + ensData = Tcl_GetHashValue(hPtr); + Itcl_RenameCommand(ensData->interp, Tcl_GetString(ensData->namePtr), ""); + if (Tcl_FindNamespace(interp, ensData->nsPtr->fullName, NULL, 0) + != NULL) { + Tcl_DeleteNamespace(ensData->nsPtr); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Itcl_FinishEnsemble -- + * + * Invoked when itcl package is finished or ItclFinishCmd is called + *---------------------------------------------------------------------- + */ +void +ItclFinishEnsemble( + ItclObjectInfo *infoPtr) +{ + EnsembleParser *ensInfo; + + ensInfo = (EnsembleParser*) Tcl_GetAssocData(infoPtr->interp, + "itcl_ensembleParser", NULL); + ckfree((char *)ensInfo); + /* FIXME have to cleanup contents of infoPtr->ensembleInfo */ + ckfree((char *)infoPtr->ensembleInfo); +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclHelpers.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclHelpers.c new file mode 100644 index 0000000..a3f136b --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclHelpers.c @@ -0,0 +1,1510 @@ +/* + * itclHelpers.c -- + * + * This file contains the C-implemeted part of + * Itcl + * + * Copyright (c) 2007 by Arnulf P. Wiedemann + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "itclInt.h" + +void ItclDeleteArgList(ItclArgList *arglistPtr); +#ifdef ITCL_DEBUG +int _itcl_debug_level = 0; + +/* + * ------------------------------------------------------------------------ + * ItclShowArgs() + * ------------------------------------------------------------------------ + */ + +void +ItclShowArgs( + int level, + const char *str, + int objc, + Tcl_Obj * const* objv) +{ + int i; + + if (level > _itcl_debug_level) { + return; + } + fprintf(stderr, "%s", str); + for (i = 0; i < objc; i++) { + fprintf(stderr, "!%s", objv[i] == NULL ? "??" : + Tcl_GetString(objv[i])); + } + fprintf(stderr, "!\n"); +} +#endif + +/* + * ------------------------------------------------------------------------ + * Itcl_ProtectionStr() + * + * Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED, + * or ITCL_PRIVATE) into a human-readable character string. Returns + * a pointer to this string. + * ------------------------------------------------------------------------ + */ +const char* +Itcl_ProtectionStr( + int pLevel) /* protection level */ +{ + switch (pLevel) { + case ITCL_PUBLIC: + return "public"; + case ITCL_PROTECTED: + return "protected"; + case ITCL_PRIVATE: + return "private"; + } + return "<bad-protection-code>"; +} + +/* + * ------------------------------------------------------------------------ + * ItclCreateArgList() + * ------------------------------------------------------------------------ + */ + +int +ItclCreateArgList( + Tcl_Interp *interp, /* interpreter managing this function */ + const char *str, /* string representing argument list */ + int *argcPtr, /* number of mandatory arguments */ + int *maxArgcPtr, /* number of arguments parsed */ + Tcl_Obj **usagePtr, /* store usage message for arguments here */ + ItclArgList **arglistPtrPtr, + /* returns pointer to parsed argument list */ + ItclMemberFunc *mPtr, + const char *commandName) +{ + int argc; + int defaultArgc; + const char **argv; + const char **defaultArgv; + ItclArgList *arglistPtr; + ItclArgList *lastArglistPtr; + int i; + int hadArgsArgument; + int result; + + *arglistPtrPtr = NULL; + lastArglistPtr = NULL; + argc = 0; + hadArgsArgument = 0; + result = TCL_OK; + *maxArgcPtr = 0; + *argcPtr = 0; + *usagePtr = Tcl_NewStringObj("", -1); + if (str) { + if (Tcl_SplitList(interp, (const char *)str, &argc, &argv) + != TCL_OK) { + return TCL_ERROR; + } + i = 0; + if (argc == 0) { + /* signal there are 0 arguments */ + arglistPtr = (ItclArgList *)ckalloc(sizeof(ItclArgList)); + memset(arglistPtr, 0, sizeof(ItclArgList)); + *arglistPtrPtr = arglistPtr; + } + while (i < argc) { + if (Tcl_SplitList(interp, argv[i], &defaultArgc, &defaultArgv) + != TCL_OK) { + result = TCL_ERROR; + break; + } + arglistPtr = NULL; + if (defaultArgc == 0 || defaultArgv[0][0] == '\0') { + if (commandName != NULL) { + Tcl_AppendResult(interp, "procedure \"", + commandName, + "\" has argument with no name", NULL); + } else { + char buf[10]; + sprintf(buf, "%d", i); + Tcl_AppendResult(interp, "argument #", buf, + " has no name", NULL); + } + result = TCL_ERROR; + break; + } + if (defaultArgc > 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "too many fields in argument specifier \"", + argv[i], "\"", + (char*)NULL); + result = TCL_ERROR; + break; + } + if (strstr(defaultArgv[0],"::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad argument name \"", defaultArgv[0], "\"", + (char*)NULL); + result = TCL_ERROR; + break; + } + arglistPtr = (ItclArgList *)ckalloc(sizeof(ItclArgList)); + memset(arglistPtr, 0, sizeof(ItclArgList)); + if (*arglistPtrPtr == NULL) { + *arglistPtrPtr = arglistPtr; + } else { + lastArglistPtr->nextPtr = arglistPtr; + Tcl_AppendToObj(*usagePtr, " ", 1); + } + arglistPtr->namePtr = + Tcl_NewStringObj(defaultArgv[0], -1); + Tcl_IncrRefCount(arglistPtr->namePtr); + (*maxArgcPtr)++; + if (defaultArgc == 1) { + (*argcPtr)++; + arglistPtr->defaultValuePtr = NULL; + if ((strcmp(defaultArgv[0], "args") == 0) && (i == argc-1)) { + hadArgsArgument = 1; + (*argcPtr)--; + Tcl_AppendToObj(*usagePtr, "?arg arg ...?", -1); + } else { + Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1); + } + } else { + arglistPtr->defaultValuePtr = + Tcl_NewStringObj(defaultArgv[1], -1); + Tcl_IncrRefCount(arglistPtr->defaultValuePtr); + Tcl_AppendToObj(*usagePtr, "?", 1); + Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1); + Tcl_AppendToObj(*usagePtr, "?", 1); + } + lastArglistPtr = arglistPtr; + i++; + ckfree((char *) defaultArgv); + } + ckfree((char *) argv); + } + /* + * If anything went wrong, destroy whatever arguments were + * created and return an error. + */ + if (result != TCL_OK) { + ItclDeleteArgList(*arglistPtrPtr); + *arglistPtrPtr = NULL; + } + if (hadArgsArgument) { + *maxArgcPtr = -1; + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteArgList() + * ------------------------------------------------------------------------ + */ + +void +ItclDeleteArgList( + ItclArgList *arglistPtr) /* first argument in arg list chain */ +{ + ItclArgList *currPtr; + ItclArgList *nextPtr; + + for (currPtr=arglistPtr; currPtr; currPtr=nextPtr) { + if (currPtr->defaultValuePtr != NULL) { + Tcl_DecrRefCount(currPtr->defaultValuePtr); + } + if (currPtr->namePtr != NULL) { + Tcl_DecrRefCount(currPtr->namePtr); + } + nextPtr = currPtr->nextPtr; + ckfree((char *)currPtr); + } +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_EvalArgs() + * + * This procedure invokes a list of (objc,objv) arguments as a + * single command. It is similar to Tcl_EvalObj, but it doesn't + * do any parsing or compilation. It simply treats the first + * argument as a command and invokes that command in the current + * context. + * + * Returns TCL_OK if successful. Otherwise, this procedure returns + * TCL_ERROR along with an error message in the interpreter. + * ------------------------------------------------------------------------ + */ +int +Itcl_EvalArgs( + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result; + Tcl_Command cmd; + int cmdlinec; + Tcl_Obj **cmdlinev; + Tcl_Obj *cmdlinePtr = NULL; + Tcl_CmdInfo infoPtr; + + /* + * Resolve the command by converting it to a CmdName object. + * This caches a pointer to the Command structure for the + * command, so if we need it again, it's ready to use. + */ + cmd = Tcl_GetCommandFromObj(interp, objv[0]); + + cmdlinec = objc; + cmdlinev = (Tcl_Obj **) objv; + + /* + * If the command is still not found, handle it with the + * "unknown" proc. + */ + if (cmd == NULL) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + + if (cmd == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", + Tcl_GetStringFromObj(objv[0], NULL), "\"", NULL); + return TCL_ERROR; + } + + cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv); + Tcl_ListObjGetElements(NULL, cmdlinePtr, &cmdlinec, &cmdlinev); + } + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. Be careful + * to pass in the proper client data. + */ + Tcl_ResetResult(interp); + result = Tcl_GetCommandInfoFromToken(cmd, &infoPtr); + if (result == 1) { + result = (infoPtr.objProc)(infoPtr.objClientData, interp, + cmdlinec, cmdlinev); + } + + if (cmdlinePtr) { + Tcl_DecrRefCount(cmdlinePtr); + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateArgs() + * + * This procedure takes a string and a list of (objc,objv) arguments, + * and glues them together in a single list. This is useful when + * a command word needs to be prepended or substituted into a command + * line before it is executed. The arguments are returned in a single + * list object, and they can be retrieved by calling + * Tcl_ListObjGetElements. When the arguments are no longer needed, + * they should be discarded by decrementing the reference count for + * the list object. + * + * Returns a pointer to the list object containing the arguments. + * ------------------------------------------------------------------------ + */ +Tcl_Obj* +Itcl_CreateArgs( + Tcl_Interp *interp, /* current interpreter */ + const char *string, /* first command word */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int i; + Tcl_Obj *listPtr; + + ItclShowArgs(1, "Itcl_CreateArgs", objc, objv); + listPtr = Tcl_NewListObj(objc+2, NULL); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("my", -1)); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(string, -1)); + + for (i=0; i < objc; i++) { + Tcl_ListObjAppendElement(NULL, listPtr, objv[i]); + } + return listPtr; +} + +/* + * ------------------------------------------------------------------------ + * ItclEnsembleSubCmd() + * ------------------------------------------------------------------------ + */ + +int +ItclEnsembleSubCmd( + ClientData clientData, + Tcl_Interp *interp, + const char *ensembleName, + int objc, + Tcl_Obj *const *objv, + const char *functionName) +{ + int result; + Tcl_Obj **newObjv; + int isRootEnsemble; + ItclShowArgs(2, functionName, objc, objv); + + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc)); + isRootEnsemble = Itcl_InitRewriteEnsemble(interp, 1, 1, objc, objv); + newObjv[0] = Tcl_NewStringObj("::itcl::builtin::Info", -1); + Tcl_IncrRefCount(newObjv[0]); + if (objc > 1) { + memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *) * (objc-1)); + } + result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_INVOKE); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + Itcl_ResetRewriteEnsemble(interp, isRootEnsemble); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclCapitalize() + * ------------------------------------------------------------------------ + */ + +Tcl_Obj * +ItclCapitalize( + const char *str) +{ + Tcl_Obj *objPtr; + char buf[2]; + + sprintf(buf, "%c", toupper(UCHAR(*str))); + buf[1] = '\0'; + objPtr = Tcl_NewStringObj(buf, -1); + Tcl_AppendToObj(objPtr, str+1, -1); + return objPtr; +} +/* + * ------------------------------------------------------------------------ + * DeleteClassDictInfo() + * ------------------------------------------------------------------------ + */ +static int +DeleteClassDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + const char *varName) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + + dictPtr = Tcl_GetVar2Ex(interp, varName, NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", varName, NULL); + return TCL_ERROR; + } + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjRemove(interp, dictPtr, keyPtr) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetVar2Ex(interp, varName, NULL, dictPtr, 0); + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * AddDictEntry() + * ------------------------------------------------------------------------ + */ +static int +AddDictEntry( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *keyStr, + Tcl_Obj *valuePtr) +{ + Tcl_Obj *keyPtr; + + if (valuePtr == NULL) { + return TCL_OK; + } + keyPtr = Tcl_NewStringObj(keyStr, -1); + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) != TCL_OK) { + Tcl_DecrRefCount(keyPtr); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddClassesDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddClassesDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *keyPtr1; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *listPtr; + FOREACH_HASH_DECLS; + ItclHierIter hier; + ItclClass *iclsPtr2; + void *value; + int found; + int newValue1; + int haveHierarchy; + + found = 0; + FOREACH_HASH(keyPtr1, value, &iclsPtr->infoPtr->classTypes) { + if (iclsPtr->flags & PTR2INT(value)) { + found = 1; + break; + } + } + if (! found) { + Tcl_AppendResult(interp, "ItclAddClassesDictInfo bad class ", + "type for class \"", Tcl_GetString(iclsPtr->fullNamePtr), + "\"", NULL); + return TCL_ERROR; + } + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classes", NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classes", NULL); + return TCL_ERROR; + } + if (Tcl_DictObjGet(interp, dictPtr, keyPtr1, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + newValue1 = 1; + valuePtr1 = Tcl_NewDictObj(); + } + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 != NULL) { + if (Tcl_DictObjRemove(interp, valuePtr1, keyPtr) != TCL_OK) { + return TCL_ERROR; + } + } + valuePtr2 = Tcl_NewDictObj(); + if (AddDictEntry(interp, valuePtr2, "-name", iclsPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-fullname", iclsPtr->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + haveHierarchy = 0; + listPtr = Tcl_NewListObj(0, NULL); + while (iclsPtr2 != NULL) { + haveHierarchy = 1; + if (Tcl_ListObjAppendElement(interp, listPtr, iclsPtr2->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + if (haveHierarchy) { + if (AddDictEntry(interp, valuePtr2, "-heritage", listPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_DecrRefCount(listPtr); + } + if (iclsPtr->widgetClassPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-widget", iclsPtr->widgetClassPtr) + != TCL_OK) { + return TCL_ERROR; + } + } + if (iclsPtr->hullTypePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-hulltype", iclsPtr->hullTypePtr) + != TCL_OK) { + return TCL_ERROR; + } + } + if (iclsPtr->typeConstructorPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-typeconstructor", + iclsPtr->typeConstructorPtr) != TCL_OK) { + return TCL_ERROR; + } + } + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + if (Tcl_DictObjPut(interp, dictPtr, keyPtr1, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classes", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteClassesDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclDeleteClassesDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr; + FOREACH_HASH_DECLS; + void* value; + int found; + + found = 0; + FOREACH_HASH(keyPtr, value, &iclsPtr->infoPtr->classTypes) { + if (iclsPtr->flags & PTR2INT(value)) { + found = 1; + break; + } + } + if (! found) { + Tcl_AppendResult(interp, "ItclDeleteClassesDictInfo bad class ", + "type for class \"", Tcl_GetString(iclsPtr->fullNamePtr), + "\"", NULL); + return TCL_ERROR; + } + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classes", NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classes", NULL); + return TCL_ERROR; + } + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr == NULL) { + /* there seems to have been an error during construction + * and no class has been created so ignore silently */ + return TCL_OK; + } + if (Tcl_DictObjRemove(interp, valuePtr, iclsPtr->fullNamePtr) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classes", + NULL, dictPtr, 0); + DeleteClassDictInfo(interp, iclsPtr, + ITCL_NAMESPACE"::internal::dicts::classOptions"); + DeleteClassDictInfo(interp, iclsPtr, + ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions"); + DeleteClassDictInfo(interp, iclsPtr, + ITCL_NAMESPACE"::internal::dicts::classVariables"); + DeleteClassDictInfo(interp, iclsPtr, + ITCL_NAMESPACE"::internal::dicts::classComponents"); + DeleteClassDictInfo(interp, iclsPtr, + ITCL_NAMESPACE"::internal::dicts::classFunctions"); + DeleteClassDictInfo(interp, iclsPtr, + ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions"); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddObjectsDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddObjectsDictInfo( + Tcl_Interp *interp, + ItclObject *ioPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *keyPtr1; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *objPtr; + int newValue1; + + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::objects", NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::objects", NULL); + return TCL_ERROR; + } + keyPtr1 = Tcl_NewStringObj("instances", -1); + if (Tcl_DictObjGet(interp, dictPtr, keyPtr1, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + newValue1 = 1; + valuePtr1 = Tcl_NewDictObj(); + } + keyPtr = ioPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 == NULL) { + if (Tcl_DictObjRemove(interp, valuePtr1, keyPtr) != TCL_OK) { + return TCL_ERROR; + } + } + valuePtr2 = Tcl_NewDictObj(); + if (AddDictEntry(interp, valuePtr2, "-name", ioPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-origname", ioPtr->namePtr) + != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-class", ioPtr->iclsPtr->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr->hullWindowNamePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-hullwindow", + ioPtr->hullWindowNamePtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (AddDictEntry(interp, valuePtr2, "-varns", ioPtr->varNsNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); + if (AddDictEntry(interp, valuePtr2, "-command", objPtr) != TCL_OK) { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + keyPtr = ioPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + /* Cannot fail. Screened non-dicts earlier. */ + Tcl_DictObjPut(interp, dictPtr, keyPtr1, valuePtr1); + } else { + /* Don't leak the key val... */ + Tcl_DecrRefCount(keyPtr1); + } + Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::objects", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteObjectsDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclDeleteObjectsDictInfo( + Tcl_Interp *interp, + ItclObject *ioPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *keyPtr1; + Tcl_Obj *valuePtr; + Tcl_Obj *valuePtr1; + + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::objects", NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::objects", NULL); + return TCL_ERROR; + } + keyPtr1 = Tcl_NewStringObj("instances", -1); + if (Tcl_DictObjGet(interp, dictPtr, keyPtr1, &valuePtr) != TCL_OK) { + Tcl_DecrRefCount(keyPtr1); + return TCL_ERROR; + } + if (valuePtr == NULL) { + /* looks like no object has been registered yet + * so ignore and return OK */ + Tcl_DecrRefCount(keyPtr1); + return TCL_OK; + } + keyPtr = ioPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr, keyPtr, &valuePtr1) != TCL_OK) { + Tcl_DecrRefCount(keyPtr1); + return TCL_ERROR; + } + if (valuePtr1 == NULL) { + /* looks like the object has not been constructed successfully + * so ignore and return OK */ + Tcl_DecrRefCount(keyPtr1); + return TCL_OK; + } + if (Tcl_DictObjRemove(interp, valuePtr, keyPtr) != TCL_OK) { + Tcl_DecrRefCount(keyPtr1); + return TCL_ERROR; + } + if (Tcl_DictObjPut(interp, dictPtr, keyPtr1, valuePtr) != TCL_OK) { + /* This is very likely impossible. non-dict already screened. */ + Tcl_DecrRefCount(keyPtr1); + return TCL_ERROR; + } + Tcl_DecrRefCount(keyPtr1); + Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::objects", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddOptionDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddOptionDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclOption *ioptPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + int newValue1; + + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classOptions", NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classOptions", NULL); + return TCL_ERROR; + } + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + valuePtr1 = Tcl_NewDictObj(); + newValue1 = 1; + } + keyPtr = ioptPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 == NULL) { + valuePtr2 = Tcl_NewDictObj(); + } + if (AddDictEntry(interp, valuePtr2, "-name", ioptPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioptPtr->fullNamePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-fullname", ioptPtr->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + } + if (AddDictEntry(interp, valuePtr2, "-resource", ioptPtr->resourceNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-class", ioptPtr->classNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + if (ioptPtr->defaultValuePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-default", + ioptPtr->defaultValuePtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->flags & ITCL_OPTION_READONLY) { + if (AddDictEntry(interp, valuePtr2, "-readonly", + Tcl_NewStringObj("1", -1)) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->cgetMethodPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-cgetmethod", + ioptPtr->cgetMethodPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->cgetMethodVarPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-cgetmethodvar", + ioptPtr->cgetMethodVarPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->configureMethodPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-configuremethod", + ioptPtr->cgetMethodPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->configureMethodVarPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-configuremethodvar", + ioptPtr->configureMethodVarPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->validateMethodPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-validatemethod", + ioptPtr->validateMethodPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (ioptPtr->validateMethodVarPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-validatemethodvar", + ioptPtr->validateMethodVarPtr) != TCL_OK) { + return TCL_ERROR; + } + } + keyPtr = ioptPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddDelegatedOptionDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddDelegatedOptionDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclDelegatedOption *idoPtr) +{ + FOREACH_HASH_DECLS; + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *listPtr; + void *value; + int haveExceptions; + int newValue1; + + keyPtr = iclsPtr->fullNamePtr; + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", + NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classDelegatedOptions", NULL); + return TCL_ERROR; + } + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + valuePtr1 = Tcl_NewDictObj(); + newValue1 = 1; + } + keyPtr = idoPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 == NULL) { + valuePtr2 = Tcl_NewDictObj(); + } + if (AddDictEntry(interp, valuePtr2, "-name", idoPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (idoPtr->resourceNamePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-resource", + idoPtr->resourceNamePtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (idoPtr->classNamePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-class", idoPtr->classNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + } + if (idoPtr->icPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-component", + idoPtr->icPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (idoPtr->asPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-as", idoPtr->asPtr) + != TCL_OK) { + return TCL_ERROR; + } + } + listPtr = Tcl_NewListObj(0, NULL); + haveExceptions = 0; + FOREACH_HASH(keyPtr, value, &idoPtr->exceptions) { + if (value == NULL) { + /* FIXME need code here */ + } + haveExceptions = 1; + Tcl_ListObjAppendElement(interp, listPtr, keyPtr); + } + if (haveExceptions) { + if (AddDictEntry(interp, valuePtr2, "-except", listPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_DecrRefCount(listPtr); + } + keyPtr = idoPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddClassComponentDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddClassComponentDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclComponent *icPtr) +{ + FOREACH_HASH_DECLS; + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *listPtr; + void *value; + int newValue1; + + keyPtr = iclsPtr->fullNamePtr; + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classComponents", + NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classComponents", NULL); + return TCL_ERROR; + } + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + valuePtr1 = Tcl_NewDictObj(); + newValue1 = 1; + } + keyPtr = icPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 == NULL) { + valuePtr2 = Tcl_NewDictObj(); + } + if (AddDictEntry(interp, valuePtr2, "-name", icPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-variable", icPtr->ivPtr->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + if (icPtr->flags & ITCL_COMPONENT_INHERIT) { + if (AddDictEntry(interp, valuePtr2, "-inherit", + Tcl_NewStringObj("1", -1)) != TCL_OK) { + return TCL_ERROR; + } + } + if (icPtr->flags & ITCL_COMPONENT_PUBLIC) { + if (AddDictEntry(interp, valuePtr2, "-public", + Tcl_NewStringObj("1", -1)) != TCL_OK) { + return TCL_ERROR; + } + } + if (icPtr->haveKeptOptions) { + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH(keyPtr, value, &icPtr->keptOptions) { + if (value == NULL) { + /* FIXME need code here */ + } + Tcl_ListObjAppendElement(interp, listPtr, keyPtr); + } + if (AddDictEntry(interp, valuePtr2, "-keptoptions", listPtr) + != TCL_OK) { + return TCL_ERROR; + } + } + keyPtr = icPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classComponents", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddClassVariableDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddClassVariableDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclVariable *ivPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *listPtr; + const char *cp; + int haveFlags; + int newValue1; + + keyPtr = iclsPtr->fullNamePtr; + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classVariables", + NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classVariables", NULL); + return TCL_ERROR; + } + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + valuePtr1 = Tcl_NewDictObj(); + newValue1 = 1; + } + keyPtr = ivPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 == NULL) { + valuePtr2 = Tcl_NewDictObj(); + } + if (AddDictEntry(interp, valuePtr2, "-name", ivPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-fullname", ivPtr->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + if (ivPtr->init != NULL) { + if (AddDictEntry(interp, valuePtr2, "-init", ivPtr->init) + != TCL_OK) { + return TCL_ERROR; + } + } + if (ivPtr->arrayInitPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-arrayinit", ivPtr->arrayInitPtr) + != TCL_OK) { + return TCL_ERROR; + } + } + cp = Itcl_ProtectionStr(ivPtr->protection); + if (AddDictEntry(interp, valuePtr2, "-protection", Tcl_NewStringObj(cp, -1)) + != TCL_OK) { + return TCL_ERROR; + } + cp = "variable"; + if (ivPtr->flags & ITCL_COMMON) { + cp = "common"; + } + if (ivPtr->flags & ITCL_VARIABLE) { + cp = "variable"; + } + if (ivPtr->flags & ITCL_TYPE_VARIABLE) { + cp = "typevariable"; + } + if (AddDictEntry(interp, valuePtr2, "-type", Tcl_NewStringObj(cp, -1)) + != TCL_OK) { + return TCL_ERROR; + } + haveFlags = 0; + listPtr = Tcl_NewListObj(0, NULL); + if (ivPtr->flags & ITCL_THIS_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("this", -1)); + } + if (ivPtr->flags & ITCL_SELF_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("self", -1)); + } + if (ivPtr->flags & ITCL_SELFNS_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("selfns", -1)); + } + if (ivPtr->flags & ITCL_WIN_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("win", -1)); + } + if (ivPtr->flags & ITCL_COMPONENT_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("component", -1)); + } + if (ivPtr->flags & ITCL_OPTIONS_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("itcl_options", -1)); + } + if (ivPtr->flags & ITCL_HULL_VAR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("itcl_hull", -1)); + } + if (ivPtr->flags & ITCL_OPTION_READONLY) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("option_read_only", -1)); + } + if (haveFlags) { + if (AddDictEntry(interp, valuePtr2, "-flags", listPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_DecrRefCount(listPtr); + } + if (ivPtr->codePtr != NULL) { + if (ivPtr->codePtr->bodyPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-code", + ivPtr->codePtr->bodyPtr) != TCL_OK) { + return TCL_ERROR; + } + } + } + keyPtr = ivPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classVariables", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddClassFunctionDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddClassFunctionDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclMemberFunc *imPtr) +{ + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *listPtr; + const char *cp; + int haveFlags; + int newValue1; + + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classFunctions", + NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classFunctions", NULL); + return TCL_ERROR; + } + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + valuePtr1 = Tcl_NewDictObj(); + newValue1 = 1; + } + keyPtr = imPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 != NULL) { + Tcl_DictObjRemove(interp, valuePtr1, keyPtr); + } + valuePtr2 = Tcl_NewDictObj(); + if (AddDictEntry(interp, valuePtr2, "-name", imPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (AddDictEntry(interp, valuePtr2, "-fullname", imPtr->fullNamePtr) + != TCL_OK) { + return TCL_ERROR; + } + cp = ""; + if (imPtr->protection == ITCL_PUBLIC) { + cp = "public"; + } + if (imPtr->protection == ITCL_PROTECTED) { + cp = "protected"; + } + if (imPtr->protection == ITCL_PRIVATE) { + cp = "private"; + } + if (AddDictEntry(interp, valuePtr2, "-protection", Tcl_NewStringObj(cp, -1)) + != TCL_OK) { + return TCL_ERROR; + } + cp = ""; + if (imPtr->flags & ITCL_COMMON) { + cp = "common"; + } + if (imPtr->flags & ITCL_METHOD) { + cp = "method"; + } + if (imPtr->flags & ITCL_TYPE_METHOD) { + cp = "typemethod"; + } + if (AddDictEntry(interp, valuePtr2, "-type", Tcl_NewStringObj(cp, -1)) + != TCL_OK) { + return TCL_ERROR; + } + haveFlags = 0; + listPtr = Tcl_NewListObj(0, NULL); + if (imPtr->flags & ITCL_CONSTRUCTOR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("constructor", -1)); + } + if (imPtr->flags & ITCL_DESTRUCTOR) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("destructor", -1)); + } + if (imPtr->flags & ITCL_ARG_SPEC) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("have_args", -1)); + } + if (imPtr->flags & ITCL_BODY_SPEC) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("have_body", -1)); + } + if (haveFlags) { + if (AddDictEntry(interp, valuePtr2, "-flags", listPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_DecrRefCount(listPtr); + } + if (imPtr->codePtr != NULL) { + if (imPtr->codePtr->bodyPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-body", + imPtr->codePtr->bodyPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (imPtr->codePtr->argumentPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-args", + imPtr->codePtr->argumentPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (imPtr->codePtr->usagePtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-usage", + imPtr->codePtr->usagePtr) != TCL_OK) { + return TCL_ERROR; + } + } + haveFlags = 0; + listPtr = Tcl_NewListObj(0, NULL); + if (imPtr->codePtr->flags & ITCL_BUILTIN) { + haveFlags = 1; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("builtin", -1)); + } + if (haveFlags) { + if (AddDictEntry(interp, valuePtr2, "-codeflags", listPtr) + != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_DecrRefCount(listPtr); + } + } + keyPtr = imPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classFunctions", + NULL, dictPtr, 0); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclAddClassDelegatedFunctionDictInfo() + * ------------------------------------------------------------------------ + */ +int +ItclAddClassDelegatedFunctionDictInfo( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclDelegatedFunction *idmPtr) +{ + FOREACH_HASH_DECLS; + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr1; + Tcl_Obj *valuePtr2; + Tcl_Obj *listPtr; + void *value; + int haveExceptions; + int newValue1; + + keyPtr = iclsPtr->fullNamePtr; + dictPtr = Tcl_GetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", + NULL, 0); + if (dictPtr == NULL) { + Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, + "::internal::dicts::classDelegatedFunctions", NULL); + return TCL_ERROR; + } + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + newValue1 = 0; + if (valuePtr1 == NULL) { + valuePtr1 = Tcl_NewDictObj(); + newValue1 = 1; + } + keyPtr = idmPtr->namePtr; + if (Tcl_DictObjGet(interp, valuePtr1, keyPtr, &valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr2 == NULL) { + valuePtr2 = Tcl_NewDictObj(); + } + if (AddDictEntry(interp, valuePtr2, "-name", idmPtr->namePtr) != TCL_OK) { + return TCL_ERROR; + } + if (idmPtr->icPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-component", + idmPtr->icPtr->ivPtr->fullNamePtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (idmPtr->asPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-as", idmPtr->asPtr) + != TCL_OK) { + return TCL_ERROR; + } + } + if (idmPtr->usingPtr != NULL) { + if (AddDictEntry(interp, valuePtr2, "-using", idmPtr->usingPtr) + != TCL_OK) { + return TCL_ERROR; + } + } + haveExceptions = 0; + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH(keyPtr, value, &idmPtr->exceptions) { + if (value == NULL) { + /* FIXME need code here */ + } + haveExceptions = 1; + if (Tcl_ListObjAppendElement(interp, listPtr, keyPtr) != TCL_OK) { + return TCL_ERROR; + } + } + + if (haveExceptions) { + if (AddDictEntry(interp, valuePtr2, "-except", listPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_DecrRefCount(listPtr); + } + keyPtr = idmPtr->namePtr; + if (Tcl_DictObjPut(interp, valuePtr1, keyPtr, valuePtr2) != TCL_OK) { + return TCL_ERROR; + } + if (newValue1) { + keyPtr = iclsPtr->fullNamePtr; + if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr1) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetVar2Ex(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", + NULL, dictPtr, 0); + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclInfo.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclInfo.c new file mode 100644 index 0000000..bbd7513 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclInfo.c @@ -0,0 +1,5327 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle built-in class methods, including the + * "isa" method (to query hierarchy info) and the "info" method + * (to query class/object data). + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +static Tcl_ObjCmdProc Itcl_BiInfoClassOptionsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoComponentsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDefaultCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedCmd; +static Tcl_ObjCmdProc Itcl_BiInfoExtendedClassCmd; +static Tcl_ObjCmdProc Itcl_BiInfoInstancesCmd; +static Tcl_ObjCmdProc Itcl_BiInfoHullTypeCmd; +static Tcl_ObjCmdProc Itcl_BiInfoMethodCmd; +static Tcl_ObjCmdProc Itcl_BiInfoMethodsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoOptionsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoTypeCmd; +static Tcl_ObjCmdProc Itcl_BiInfoTypeMethodCmd; +static Tcl_ObjCmdProc Itcl_BiInfoTypeMethodsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoTypesCmd; +static Tcl_ObjCmdProc Itcl_BiInfoTypeVarsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoTypeVariableCmd; +static Tcl_ObjCmdProc Itcl_BiInfoVariablesCmd; +static Tcl_ObjCmdProc Itcl_BiInfoWidgetadaptorCmd; +static Tcl_ObjCmdProc Itcl_BiInfoWidgetCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedOptionsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedMethodsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedTypeMethodsCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedOptionCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedMethodCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedTypeMethodCmd; +static Tcl_ObjCmdProc Itcl_BiInfoDelegatedUnknownCmd; +static Tcl_ObjCmdProc Itcl_BiInfoContextCmd; + +typedef struct InfoMethod { + const char* name; /* method name */ + const char* usage; /* string describing usage */ + Tcl_ObjCmdProc *proc; /* implementation C proc */ + int flags; /* which class commands have it */ +} InfoMethod; + +static const InfoMethod InfoMethodList[] = { + { "args", + "procname", + Itcl_BiInfoArgsCmd, + ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "body", + "procname", + Itcl_BiInfoBodyCmd, + ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "class", + "", + Itcl_BiInfoClassCmd, + ITCL_CLASS|ITCL_WIDGET|ITCL_ECLASS + }, + { "classoptions", + "?pattern?", + Itcl_BiInfoClassOptionsCmd, + ITCL_ECLASS + }, + { "component", + "?name? ?-inherit? ?-value?", + Itcl_BiInfoComponentCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "context", + "", + Itcl_BiInfoContextCmd, + ITCL_ECLASS + }, + { "components", + "?pattern?", + Itcl_BiInfoComponentsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "default", + "method aname varname", + Itcl_BiInfoDefaultCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "delegated", + "?name? ?-inherit? ?-value?", + Itcl_BiInfoDelegatedCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "extendedclass", + "", + Itcl_BiInfoExtendedClassCmd, + ITCL_ECLASS + }, + { "function", + "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", + Itcl_BiInfoFunctionCmd, + ITCL_CLASS|ITCL_ECLASS + }, + { "heritage", + "", + Itcl_BiInfoHeritageCmd, + ITCL_CLASS|ITCL_WIDGET|ITCL_ECLASS + }, + { "hulltype", + "", + Itcl_BiInfoHullTypeCmd, + ITCL_WIDGET + }, + { "hulltypes", + "?pattern?", + Itcl_BiInfoUnknownCmd, + ITCL_WIDGETADAPTOR|ITCL_WIDGET + }, + { "inherit", + "", + Itcl_BiInfoInheritCmd, + ITCL_CLASS|ITCL_WIDGET|ITCL_ECLASS + }, + { "instances", + "?pattern?", + Itcl_BiInfoInstancesCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET + }, + { "method", + "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", + Itcl_BiInfoMethodCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "methods", + "?pattern?", + Itcl_BiInfoMethodsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "option", + "?name? ?-protection? ?-resource? ?-class? ?-name? ?-default? \ +?-cgetmethod? ?-configuremethod? ?-validatemethod? \ +?-cgetmethodvar? ?-configuremethodvar? ?-validatemethodvar? \ +?-value?", + Itcl_BiInfoOptionCmd, + ITCL_WIDGET|ITCL_ECLASS + }, + { "options", + "?pattern?", + Itcl_BiInfoOptionsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "type", + "", + Itcl_BiInfoTypeCmd, + ITCL_TYPE|ITCL_WIDGET|ITCL_ECLASS + }, + { "typemethod", + "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", + Itcl_BiInfoTypeMethodCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "typemethods", + "?pattern?", + Itcl_BiInfoTypeMethodsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "types", + "?pattern?", + Itcl_BiInfoTypesCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "typevariable", + "?name? ?-protection? ?-type? ?-name? ?-init? ?-value?", + Itcl_BiInfoTypeVariableCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "typevars", + "?pattern?", + Itcl_BiInfoTypeVarsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "variable", + "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?", + Itcl_BiInfoVariableCmd, + ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "variables", + "?pattern?", + Itcl_BiInfoVariablesCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "vars", + "?pattern?", + Itcl_BiInfoVarsCmd, + ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "widget", + "", + Itcl_BiInfoWidgetCmd, + ITCL_WIDGET + }, + { "widgets", + "?pattern?", + Itcl_BiInfoUnknownCmd, + ITCL_WIDGET + }, + { "widgetclasses", + "?pattern?", + Itcl_BiInfoUnknownCmd, + ITCL_WIDGET + }, + { "widgetadaptor", + "", + Itcl_BiInfoWidgetadaptorCmd, + ITCL_WIDGETADAPTOR + }, + { "widgetadaptors", + "?pattern?", + Itcl_BiInfoUnknownCmd, + ITCL_WIDGETADAPTOR + }, + { NULL, + NULL, + NULL, + 0 + } +}; + +struct NameProcMap2 { + const char* name; /* method name */ + const char* usage; /* string describing usage */ + Tcl_ObjCmdProc *proc; /* implementation C proc */ + int flags; /* which class commands have it */ +}; + +static const struct NameProcMap2 infoCmdsDelegated2[] = { + { "::itcl::builtin::Info::delegated::methods", + "?pattern?", + Itcl_BiInfoDelegatedMethodsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "::itcl::builtin::Info::delegated::typemethods", + "?pattern?", + Itcl_BiInfoDelegatedTypeMethodsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "::itcl::builtin::Info::delegated::options", + "?pattern?", + Itcl_BiInfoDelegatedOptionsCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { "::itcl::builtin::Info::delegated::method", + "methodName", + Itcl_BiInfoDelegatedMethodCmd, + ITCL_ECLASS + }, + { "::itcl::builtin::Info::delegated::typemethod", + "methodName", + Itcl_BiInfoDelegatedTypeMethodCmd, + ITCL_ECLASS + }, + { "::itcl::builtin::Info::delegated::option", + "methodName", + Itcl_BiInfoDelegatedOptionCmd, + ITCL_ECLASS + }, + { "::itcl::builtin::Info::delegated::unknown", + "", + Itcl_BiInfoDelegatedUnknownCmd, + ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS + }, + { NULL, NULL, NULL, 0 } +}; + +static void ItclGetInfoUsage(Tcl_Interp *interp, Tcl_Obj*objPtr, + ItclObjectInfo *infoPtr, ItclClass *iclsPtr); + + +/* + * ------------------------------------------------------------------------ + * ItclInfoInit() + * + * Creates a namespace full of built-in methods/procs for [incr Tcl] + * classes. This includes things like the "info" + * for querying class info. Usually invoked by Itcl_Init() when + * [incr Tcl] is first installed into an interpreter. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ + +static int +InfoGutsFinish( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_CallFrame *framePtr = (Tcl_CallFrame *) data[0]; + ItclObjectInfo *infoPtr = (ItclObjectInfo *) data[1]; + ItclCallContext *cPtr = (ItclCallContext *) data[2]; + ItclCallContext *popped; + + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, + (char *) framePtr); + + Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); + + popped = Itcl_PopStack(stackPtr); + + if (Itcl_GetStackSize(stackPtr) == 0) { + Itcl_DeleteStack(stackPtr); + ckfree((char *)stackPtr); + Tcl_DeleteHashEntry(hPtr); + } + + if (cPtr != popped) { + Tcl_Panic("Context stack mismatch!"); + } + ckfree((char *) cPtr); + + return result; +} + +int +ItclInfoGuts( + ItclObject *ioPtr, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + ItclObjectInfo *infoPtr = ioPtr->infoPtr; + Tcl_CmdInfo info; + ItclCallContext *cPtr; + Tcl_CallFrame *framePtr; + Tcl_HashEntry *hPtr; + Itcl_Stack *stackPtr; + int new; + + if (objc == 2) { + /* + * No subcommand passed. Give good usage message. NOT the + * default message of a Tcl ensemble. + */ + + Tcl_Obj *objPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + ItclGetInfoUsage(interp, objPtr, infoPtr, ioPtr->iclsPtr); + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + + framePtr = Itcl_GetUplevelCallFrame(interp, 0); + + hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, (char *)framePtr, &new); + if (new) { + stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack)); + Itcl_InitStack(stackPtr); + Tcl_SetHashValue(hPtr, stackPtr); + } else { + stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); + } + + cPtr = (ItclCallContext *) ckalloc(sizeof(ItclCallContext)); + cPtr->objectFlags = ITCL_OBJECT_ROOT_METHOD; + cPtr->nsPtr = NULL; + cPtr->ioPtr = ioPtr; + cPtr->imPtr = NULL; + cPtr->refCount = 1; + + Itcl_PushStack(cPtr, stackPtr); + + Tcl_NRAddCallback(interp, InfoGutsFinish, framePtr, infoPtr, cPtr, NULL); + Tcl_GetCommandInfoFromToken(infoPtr->infoCmd, &info); + return Tcl_NRCallObjProc(interp, info.objProc, info.objClientData, + objc-1, objv+1); +} + +static int +NRInfoWrap( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_CmdInfo info; + Tcl_Command token = (Tcl_Command) clientData; + + if (objc == 1) { + /* + * No subcommand passed. Give good usage message. NOT the + * default message of a Tcl ensemble. + */ + + ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + Tcl_Obj *objPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + ItclGetInfoUsage(interp, objPtr, infoPtr, NULL); + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + + /* Have a subcommand. Pass on to the ensemble */ + + /* + * WARNING! WARNING! WARNING! + * We are doing NOTHING to guarantee that the command corresponding to + * token has not been deleted. If it is deleted, this will fail very + * badly. Another pass to plug up dependencies like this is in order. + * I'm not bothering now because the code is already overflowing with + * worse uncontrolled dependencies. I'll clean the windows sometime + * later when the cracks in the foundation are filled in. + */ + Tcl_GetCommandInfoFromToken(token, &info); + return Tcl_NRCallObjProc(interp, info.objProc, info.objClientData, + objc, objv); +} + +static int +InfoWrap( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return Tcl_NRCallObjProc(interp, NRInfoWrap, clientData, objc, objv); +} + +static void +InfoCmdDelete( + ClientData clientData, + Tcl_Interp *interp, + const char *oldName, + const char *newName, + int flags) +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; + + infoPtr->infoCmd = NULL; +} + +int +ItclInfoInit( + Tcl_Interp *interp, /* current interpreter */ + ItclObjectInfo *infoPtr) +{ + Tcl_Namespace *nsPtr; + Tcl_Command token; + Tcl_CmdInfo info; + Tcl_Obj *unkObjPtr; + Tcl_Obj *ensObjPtr; + int result; + int i; + + /* + * Build the ensemble used to implement [info]. + */ + + nsPtr = Tcl_CreateNamespace(interp, "::itcl::builtin::Info", NULL, NULL); + if (nsPtr == NULL) { + Tcl_Panic("ITCL: error in creating namespace: ::itcl::builtin::Info \n"); + } + if (infoPtr->infoCmd) { + Tcl_Panic("Double init of info ensemble"); + } + token = Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, + TCL_ENSEMBLE_PREFIX); + Tcl_TraceCommand(interp, nsPtr->fullName, TCL_TRACE_DELETE, + InfoCmdDelete, (ClientData) infoPtr); + infoPtr->infoCmd = token; + token = Tcl_NRCreateCommand(interp, "::itcl::builtin::info", InfoWrap, + NRInfoWrap, token, NULL); + Tcl_GetCommandInfoFromToken(token, &info); + + /* + * Make the C implementation of the "info" ensemble available as + * a method body. This makes all [$object info] become the + * equivalent of [::itcl::builtin::Info] without any need for + * tailcall to restore the right frame [87a1bc6e82]. + */ + Itcl_RegisterObjC(interp, "itcl-builtin-info", info.objProc, + info.objClientData, NULL); + + Tcl_Export(interp, nsPtr, "[a-z]*", 1); + ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1); + + for (i=0 ; InfoMethodList[i].name!=NULL ; i++) { + Tcl_Obj *cmdObjPtr = Tcl_DuplicateObj(ensObjPtr); + + Tcl_AppendToObj(cmdObjPtr, "::", 2); + Tcl_AppendToObj(cmdObjPtr, InfoMethodList[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_GetString(cmdObjPtr), + InfoMethodList[i].proc, infoPtr, NULL); + Tcl_DecrRefCount(cmdObjPtr); + } + unkObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::unknown", -1); + Tcl_CreateObjCommand(interp, Tcl_GetString(unkObjPtr), + Itcl_BiInfoUnknownCmd, infoPtr, NULL); + if (Tcl_SetEnsembleUnknownHandler(NULL, + Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), + unkObjPtr) != TCL_OK) { + Tcl_DecrRefCount(unkObjPtr); + Tcl_DecrRefCount(ensObjPtr); + return TCL_ERROR; + } + Tcl_DecrRefCount(ensObjPtr); + + /* + * Build the ensemble used to implement [info delegated]. + */ + + nsPtr = Tcl_CreateNamespace(interp, "::itcl::builtin::Info::delegated", + NULL, NULL); + if (nsPtr == NULL) { + Tcl_Panic("ITCL: error in creating namespace: ::itcl::builtin::Info::delegated \n"); + } + Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, + TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, nsPtr, "[a-z]*", 1); + for (i=0 ; infoCmdsDelegated2[i].name!=NULL ; i++) { + Tcl_CreateObjCommand(interp, infoCmdsDelegated2[i].name, + infoCmdsDelegated2[i].proc, infoPtr, NULL); + } + ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", + -1); + unkObjPtr = Tcl_NewStringObj( + "::itcl::builtin::Info::delegated::unknown", -1); + result = TCL_OK; + if (Tcl_SetEnsembleUnknownHandler(NULL, + Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), + unkObjPtr) != TCL_OK) { + result = TCL_ERROR; + } + Tcl_DecrRefCount(ensObjPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclGetInfoUsage() + * + * ------------------------------------------------------------------------ + */ +void +ItclGetInfoUsage( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* returns: summary of usage info */ + ItclObjectInfo *infoPtr, + ItclClass *iclsPtr) +{ + const char *spaces = " "; + int i; + + ItclObject *ioPtr; + if (iclsPtr == NULL) { + if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &ioPtr)) { + return; + } + } + for (i=0; InfoMethodList[i].name != NULL; i++) { + if (strcmp(InfoMethodList[i].name, "vars") == 0) { + /* we don't report that, as it is a special case + * it is only adding the protected and private commons + * to the ::info vars command */ + continue; + } + if (iclsPtr->flags & InfoMethodList[i].flags) { + Tcl_AppendToObj(objPtr, spaces, -1); + Tcl_AppendToObj(objPtr, "info ", -1); + Tcl_AppendToObj(objPtr, InfoMethodList[i].name, -1); + if (strlen(InfoMethodList[i].usage) > 0) { + Tcl_AppendToObj(objPtr, " ", -1); + Tcl_AppendToObj(objPtr, InfoMethodList[i].usage, -1); + } + spaces = "\n "; + } + } + Tcl_AppendToObj(objPtr, + "\n...and others described on the man page", -1); +} + +/* + * ------------------------------------------------------------------------ + * ItclGetInfoDelegatedUsage() + * + * ------------------------------------------------------------------------ + */ +static void +ItclGetInfoDelegatedUsage( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* returns: summary of usage info */ + ItclObjectInfo *infoPtr) +{ + ItclClass *iclsPtr; + const char *name; + const char *lastName; + const char *spaces = " "; + + int i; + + ItclObject *ioPtr; + if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &ioPtr)) { + return; + } + for (i=0; infoCmdsDelegated2[i].name != NULL; i++) { + name = infoCmdsDelegated2[i].name; + lastName = name; + while (name != NULL) { + name = strstr(name, "::"); + if (name == NULL) { + break; + } + name += 2; + lastName = name; + } + name = lastName; + if (strcmp(name, "unknown") == 0) { + /* we don't report that, as it is a special case */ + continue; + } + if (iclsPtr->flags & infoCmdsDelegated2[i].flags) { + Tcl_AppendToObj(objPtr, spaces, -1); + Tcl_AppendToObj(objPtr, "info ", -1); + Tcl_AppendToObj(objPtr, name, -1); + if (strlen(infoCmdsDelegated2[i].usage) > 0) { + Tcl_AppendToObj(objPtr, " ", -1); + Tcl_AppendToObj(objPtr, infoCmdsDelegated2[i].usage, -1); + } + spaces = "\n "; + } + } + Tcl_AppendToObj(objPtr, + "\n...and others described on the man page", -1); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoClassCmd() + * + * Returns information regarding the class for an object. This command + * can be invoked with or without an object context: + * + * <objName> info class <= returns most-specific class name + * info class <= returns active namespace name + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoClassCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *contextNs = NULL; + ItclClass *contextIclsPtr = NULL; + ItclObject *contextIoPtr; + + char *name; + + ItclShowArgs(1, "Itcl_BiInfoClassCmd", objc, objv); + if (objc != 1) { + /* TODO: convert to NR-enabled fallback to [::info] */ + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + /* try it the hard way */ + ClientData clientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + clientData = Itcl_GetCallFrameClientData(interp); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + if (clientData != NULL) { + oPtr = Tcl_ObjectContextObject(clientData); + contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + contextIclsPtr = contextIoPtr->iclsPtr; + } + if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " \ + "\n namespace eval className { info class }", -1)); + return TCL_ERROR; + } + } + + /* + * If there is an object context, then return the most-specific + * class for the object. Otherwise, return the class namespace + * name. Use normal class names when possible. + */ + if (contextIoPtr) { + contextNs = contextIoPtr->iclsPtr->nsPtr; + } else { + assert(contextIclsPtr != NULL); + assert(contextIclsPtr->nsPtr != NULL); + contextNs = contextIclsPtr->nsPtr; + } + + assert(contextNs); + + name = contextNs->fullName; + + Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoClassOptionsCmd() + * + * Returns information regarding the options for a class. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoClassOptionsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashEntry *hPtr2; + Tcl_Obj *listPtr; + Tcl_Obj *listPtr2; + Tcl_Obj *objPtr; + Tcl_Obj **lObjv; + Tcl_HashTable *tablePtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclOption *ioptPtr; + ItclDelegatedOption *idoPtr; + const char *name; + const char *val; + const char *pattern; + int lObjc; + int result; + int i; + + ItclShowArgs(1, "Itcl_BiInfoClassOptionsCmd", objc, objv); + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info options ", + "?pattern?", NULL); + return TCL_ERROR; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + tablePtr = &iclsPtr->options; + FOREACH_HASH_VALUE(ioptPtr, tablePtr) { + name = Tcl_GetString(ioptPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1)); + } + } + tablePtr = &iclsPtr->delegatedOptions; + FOREACH_HASH_VALUE(idoPtr, tablePtr) { + name = Tcl_GetString(idoPtr->namePtr); + if (strcmp(name, "*") != 0) { + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(idoPtr->namePtr), -1)); + } + } else { + if (idoPtr->icPtr == NULL) { + Tcl_AppendResult(interp, "component \"", + Tcl_GetString(idoPtr->namePtr), + "\" is not initialized", NULL); + return TCL_ERROR; + } + val = ItclGetInstanceVar(interp, + Tcl_GetString(idoPtr->icPtr->namePtr), + NULL, ioPtr, ioPtr->iclsPtr); + if ((val != NULL) && (strlen(val) != 0)) { + objPtr = Tcl_NewStringObj(val, -1); + Tcl_AppendToObj(objPtr, " configure", -1); + result = Tcl_EvalObjEx(interp, objPtr, 0); + if (result != TCL_OK) { + return TCL_ERROR; + } + listPtr2 = Tcl_GetObjResult(interp); + Tcl_ListObjGetElements(interp, listPtr2, &lObjc, &lObjv); + for (i = 0; i < lObjc; i++) { + Tcl_ListObjIndex(interp, lObjv[i], 0, &objPtr); + hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, + (char *)objPtr); + if (hPtr2 == NULL) { + name = Tcl_GetString(objPtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } + } + } + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoContextCmd() + * + * Returns information regarding the context object and class. This command + * can only be invoked with an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoContextCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + ItclObject *ioPtr = NULL; + ItclClass *iclsPtr; + + ItclShowArgs(1, "Itcl_BiInfoContextCmd", objc, objv); + iclsPtr = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr == NULL) { + Tcl_AppendResult(interp, "cannot get object context ", (char*)NULL); + return TCL_ERROR; + } + listPtr = Tcl_NewListObj(0, NULL); + objPtr = Tcl_NewStringObj(Tcl_GetString(iclsPtr->namePtr), -1); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + objPtr = Tcl_NewStringObj(Tcl_GetString(ioPtr->namePtr), -1); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoInheritCmd() + * + * Returns the list of base classes for the current class context. + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoInheritCmd( + ClientData clientdata, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr = NULL; + ItclObject *contextIoPtr = NULL; + Itcl_ListElem *elem; + Tcl_Obj *listPtr; + + ItclShowArgs(2, "Itcl_BiInfoInheritCmd", objc, objv); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info inherit }", -1)); + return TCL_ERROR; + } + + /* + * Return the list of base classes. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + elem = Itcl_FirstListElem(&contextIclsPtr->bases); + while (elem) { + Tcl_Obj *objPtr; + ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem); + objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + elem = Itcl_NextListElem(elem); + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoHeritageCmd() + * + * Returns the entire derivation hierarchy for this class, presented + * in the order that classes are traversed for finding data members + * and member functions. + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoHeritageCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr = NULL; + ItclObject *contextIoPtr = NULL; + ItclHierIter hier; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + ItclClass *iclsPtr; + + ItclShowArgs(2, "Itcl_BiInfoHeritageCmd", objc, objv); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info heritage }", -1)); + return TCL_ERROR; + } + + /* + * Traverse through the derivation hierarchy and return + * base class names. + */ + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + if (iclsPtr->nsPtr == NULL) { + Tcl_AppendResult(interp, "ITCL: iclsPtr->nsPtr == NULL", + Tcl_GetString(iclsPtr->fullNamePtr), NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoFunctionCmd() + * + * Returns information regarding class member functions (methods/procs). + * Handles the following syntax: + * + * info function ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? + * + * If the ?cmdName? is not specified, then a list of all known + * command members is returned. Otherwise, the information for + * a specific command is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoFunctionCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + char *cmdName = NULL; + Tcl_Obj *resultPtr = NULL; + Tcl_Obj *objPtr = NULL; + + static const char *options[] = { + "-args", "-body", "-name", "-protection", "-type", + (char*)NULL + }; + enum BIfIdx { + BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx + } *iflist, iflistStorage[5]; + + static enum BIfIdx DefInfoFunction[5] = { + BIfProtectIdx, + BIfTypeIdx, + BIfNameIdx, + BIfArgsIdx, + BIfBodyIdx + }; + + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + ItclClass *iclsPtr; + int i; + int result; + const char *val; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclMemberFunc *imPtr; + ItclMemberCode *mcode; + ItclHierIter hier; + + ItclShowArgs(2, "Itcl_InfoFunctionCmd", objc, objv); + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info function ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + cmdName = Tcl_GetString(*objv); + objc--; objv++; + } + + /* + * Return info for a specific command. + */ + if (cmdName) { + ItclCmdLookup *clookup; + objPtr = Tcl_NewStringObj(cmdName, -1); + entry = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + objPtr = NULL; + if (entry == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a member function in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); + imPtr = clookup->imPtr; + mcode = imPtr->codePtr; + + /* + * By default, return everything. + */ + if (objc == 0) { + objc = 5; + iflist = DefInfoFunction; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + iflist = &iflistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&iflist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (iflist[i]) { + case BIfArgsIdx: + if (mcode && mcode->argListPtr) { + if (imPtr->usagePtr == NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->usagePtr), -1); + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->usagePtr), -1); + } + } else { + if ((imPtr->flags & ITCL_ARG_SPEC) != 0) { + if (imPtr->usagePtr == NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->usagePtr), -1); + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->usagePtr), -1); + } + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + } + break; + + case BIfBodyIdx: + if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->bodyPtr), -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + break; + + case BIfNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->fullNamePtr), -1); + break; + + case BIfProtectIdx: + val = Itcl_ProtectionStr(imPtr->protection); + objPtr = Tcl_NewStringObj(val, -1); + break; + + case BIfTypeIdx: + val = ((imPtr->flags & ITCL_COMMON) != 0) + ? "proc" : "method"; + objPtr = Tcl_NewStringObj(val, -1); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available commands. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + entry = Tcl_FirstHashEntry(&iclsPtr->functions, &place); + while (entry) { + int useIt = 1; + + imPtr = (ItclMemberFunc*)Tcl_GetHashValue(entry); + if (imPtr->codePtr && (imPtr->codePtr->flags & ITCL_BUILTIN)) { + if (strcmp(Tcl_GetString(imPtr->namePtr), "info") == 0) { + useIt = 0; + } + if (strcmp(Tcl_GetString(imPtr->namePtr), "setget") == 0) { + if (!(imPtr->iclsPtr->flags & ITCL_ECLASS)) { + useIt = 0; + } + } + if (strcmp(Tcl_GetString(imPtr->namePtr), + "installcomponent") == 0) { + if (!(imPtr->iclsPtr->flags & + (ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + useIt = 0; + } + } + } + if (useIt) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + + entry = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoVariableCmd() + * + * Returns information regarding class data members (variables and + * commons). Handles the following syntax: + * + * info variable ?varName? ?-protection? ?-type? ?-name? + * ?-init? ?-config? ?-value? + * + * If the ?varName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoVariableCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclClass *iclsPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclVariable *ivPtr; + ItclVarLookup *vlookup; + ItclHierIter hier; + char *varName; + const char *val; + int i; + int result; + + static const char *options[] = { + "-config", "-init", "-name", "-protection", "-type", + "-value", (char*)NULL + }; + enum BIvIdx { + BIvConfigIdx, BIvInitIdx, BIvNameIdx, BIvProtectIdx, + BIvTypeIdx, BIvValueIdx + } *ivlist, ivlistStorage[6]; + + static enum BIvIdx DefInfoVariable[5] = { + BIvProtectIdx, + BIvTypeIdx, + BIvNameIdx, + BIvInitIdx, + BIvValueIdx + }; + + static enum BIvIdx DefInfoPubVariable[6] = { + BIvProtectIdx, + BIvTypeIdx, + BIvNameIdx, + BIvInitIdx, + BIvConfigIdx, + BIvValueIdx + }; + + + ItclShowArgs(1, "Itcl_BiInfoVariableCmd", objc, objv); + resultPtr = NULL; + objPtr = NULL; + varName = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info variable ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + varName = Tcl_GetString(*objv); + objc--; objv++; + } + + /* + * Return info for a specific variable. + */ + if (varName) { + entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + if (entry == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", varName, "\" isn't a variable in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + ivPtr = vlookup->ivPtr; + + /* + * By default, return everything. + */ + if (objc == 0) { + if (ivPtr->protection == ITCL_PUBLIC && + ((ivPtr->flags & ITCL_COMMON) == 0)) { + ivlist = DefInfoPubVariable; + objc = 6; + } else { + ivlist = DefInfoVariable; + objc = 5; + } + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + ivlist = &ivlistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&ivlist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (ivlist[i]) { + case BIvConfigIdx: + if (ivPtr->codePtr && + Itcl_IsMemberCodeImplemented(ivPtr->codePtr)) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->codePtr->bodyPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BIvInitIdx: + /* + * If this is the built-in "this" variable, then + * report the object name as its initialization string. + */ + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + if ((contextIoPtr != NULL) && + (contextIoPtr->accessCmd != NULL)) { + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName( + contextIoPtr->iclsPtr->interp, + contextIoPtr->accessCmd, objPtr); + } else { + objPtr = Tcl_NewStringObj("<objectName>", -1); + } + } else { + if (vlookup->ivPtr->init) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(vlookup->ivPtr->init), -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + } + break; + + case BIvNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + break; + + case BIvProtectIdx: + val = Itcl_ProtectionStr(ivPtr->protection); + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + + case BIvTypeIdx: + val = ((ivPtr->flags & ITCL_COMMON) != 0) + ? "common" : "variable"; + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + + case BIvValueIdx: + if ((ivPtr->flags & ITCL_COMMON) != 0) { + val = Itcl_GetCommonVar(interp, + Tcl_GetString(ivPtr->fullNamePtr), + ivPtr->iclsPtr); + } else { + if (contextIoPtr == NULL) { + if (objc > 1) { + Tcl_DecrRefCount(resultPtr); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "cannot access object-specific info ", + "without an object context", + (char*)NULL); + return TCL_ERROR; + } else { + val = Itcl_GetInstanceVar(interp, + Tcl_GetString(ivPtr->namePtr), + contextIoPtr, ivPtr->iclsPtr); + } + } + if (val == NULL) { + val = "<undefined>"; + } + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + } + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_GetString(resultPtr), NULL); + Tcl_DecrRefCount(resultPtr); + } else { + + /* + * Return the list of available variables. Report the built-in + * "this" variable only once, for the most-specific class. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + entry = Tcl_FirstHashEntry(&iclsPtr->variables, &place); + while (entry) { + ivPtr = (ItclVariable*)Tcl_GetHashValue(entry); + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + if (iclsPtr == contextIclsPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + entry = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoVarsCmd() + * + * Returns information regarding variables + * + * info vars ?pattern? + * uses ::info vars and adds Itcl common variables!! + * + * Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoVarsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + Tcl_Obj **newObjv; + Tcl_Namespace *nsPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr = NULL; + ItclVariable *ivPtr; + const char *pattern; + const char *name; + int useGlobalInfo; + int result; + ItclObject *ioPtr; + + ItclShowArgs(1, "Itcl_BiInfoVars", objc, objv); + result = TCL_OK; + useGlobalInfo = 1; + pattern = NULL; + infoPtr = (ItclObjectInfo *)clientData; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, " ?pattern?"); + return TCL_ERROR; + } + + if (TCL_OK != Itcl_GetContext(interp, &iclsPtr, &ioPtr)) { + if (objc == 2) { + /* Give pattern a chance to determine context */ + Tcl_ResetResult(interp); + } else { + return TCL_ERROR; + } + } + if (iclsPtr) { + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET)) { + /* don't use the ::tcl::info::vars command */ + useGlobalInfo = 0; + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + } + } + if (useGlobalInfo) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc)); + newObjv[0] = Tcl_NewStringObj("::tcl::info::vars", -1); + Tcl_IncrRefCount(newObjv[0]); + memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *)*(objc-1)); + result = Tcl_EvalObjv(interp, objc, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + } else { + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { + if ((ivPtr->flags & ITCL_VARIABLE) != 0) { + name = Tcl_GetString(ivPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, ivPtr->namePtr); + } + } + } + /* always add the itcl_options variable */ + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("itcl_options", -1)); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + if (objc < 2) { + return result; + } + if (result == TCL_OK) { + Tcl_DString buffer; + const char *head; + const char *tail; + /* check if the pattern contains a class namespace + * and if yes add the common private and protected vars + * and remove the ___DO_NOT_DELETE_THIS_VARIABLE var + */ + Itcl_ParseNamespPath(Tcl_GetString(objv[1]), &buffer, &head, &tail); + if (head == NULL) { + nsPtr = Tcl_GetCurrentNamespace(interp); + } else { + nsPtr = Tcl_FindNamespace(interp, head, NULL, 0); + } + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, + (char *)nsPtr); + if (hPtr != NULL) { + Itcl_List varList; + Tcl_Obj *resultListPtr; + Tcl_Obj *namePtr; + int numElems; + + Itcl_InitList(&varList); + iclsPtr = Tcl_GetHashValue(hPtr); + resultListPtr = Tcl_GetObjResult(interp); + numElems = 0; +/* FIXME !! should perhaps skip ___DO_NOT_DELETE_THIS_VARIABLE here !! */ + FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { + if ((ivPtr->flags & ITCL_VARIABLE) != 0) { + if (head != NULL) { + namePtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + } else { + namePtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->namePtr), -1); + } + Tcl_ListObjAppendElement(interp, resultListPtr, + namePtr); + numElems++; + } + if ((ivPtr->flags & ITCL_COMMON) != 0) { + if (ivPtr->protection != ITCL_PUBLIC) { + if (head != NULL) { + namePtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + } else { + namePtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->namePtr), -1); + } + Tcl_ListObjAppendElement(interp, resultListPtr, + namePtr); + numElems++; + } + } + } + } + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoUnknownCmd() + * + * the unknown handler for the ::itcl::builtin::Info ensemble + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoUnknownCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *objPtr, *listObj; + int usage = 1; + int code = TCL_ERROR; + + ItclShowArgs(1, "Itcl_BiInfoUnknownCmd", objc, objv); + + if (objc < 2) { + /* Namespace ensemble unknown callbacks never do this. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown callback should not be called directly", -1)); + return TCL_ERROR; + } + + /* Redirect to the [::info] command. */ + objPtr = Tcl_NewStringObj("::info", -1); + listObj = Tcl_NewListObj(1, &objPtr); + Tcl_IncrRefCount(listObj); + if (Tcl_GetCommandFromObj(interp, objPtr)) { + usage = 0; + Tcl_ListObjReplace(NULL, listObj, 1, 0, objc-2, objv+2); + code = Tcl_EvalObj(interp, listObj); + if (code == TCL_ERROR) { + /* Redirection to [::info] failed, but why? */ + Tcl_Obj *optDict = Tcl_GetReturnOptions(interp, code); + Tcl_Obj *key = Tcl_NewStringObj("-errorcode", -1); + Tcl_Obj *val, *elem; + + Tcl_DictObjGet(NULL, optDict, key, &val); + Tcl_DecrRefCount(key); + Tcl_ListObjIndex(NULL, val, 0, &elem); + if (elem && !strcmp(Tcl_GetString(elem), "TCL")) { + Tcl_ListObjIndex(NULL, val, 1, &elem); + if (elem && !strcmp(Tcl_GetString(elem), "LOOKUP")) { + Tcl_ListObjIndex(NULL, val, 2, &elem); + if (elem && !strcmp(Tcl_GetString(elem), "SUBCOMMAND")) { + + /* [::info didn't have that subcommand] */ + usage = 1; + Tcl_ResetResult(interp); + } + } + } + } + } + Tcl_DecrRefCount(listObj); + + if (usage) { + /* produce usage message */ + Tcl_Obj *objPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + ItclGetInfoUsage(interp, objPtr, (ItclObjectInfo *)clientData, NULL); + Tcl_SetObjResult(interp, objPtr); + } + if (code == TCL_ERROR) { + return TCL_ERROR; + } + + /* Return a command to replicate the non-error redirect outcome */ + listObj = Tcl_NewStringObj( + "::apply {{o m args} {::tailcall ::return -options $o $m}}", -1); + Tcl_ListObjAppendElement(NULL, listObj, Tcl_GetReturnOptions(interp,code)); + Tcl_ListObjAppendElement(NULL, listObj, Tcl_GetObjResult(interp)); + Tcl_SetObjResult(interp, listObj); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoBodyCmd() + * + * Handles the usual "info body" request, returning the body for a + * specific proc. Included here for backward compatibility, since + * otherwise Tcl would complain that class procs are not real "procs". + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoBodyCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + ItclClass *contextIclsPtr = NULL; + ItclObject *contextIoPtr; + const char *what = "procedure"; + + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + int code; + Tcl_Obj *script; + + /* + * We lack the context for any specialized Itcl meaning for + * [info body], so fallback to Tcl's. + */ + + fallback: + script = Tcl_NewStringObj("::info body", -1); + if (objc == 2) { + Tcl_ListObjAppendElement(NULL, script, objv[1]); + } + Tcl_IncrRefCount(script); + code = Tcl_EvalObjEx(interp, script, 0); + Tcl_DecrRefCount(script); + if (code == TCL_ERROR && what) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a %s", Tcl_GetString(objv[1]), what)); + } + return code; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + what = "function"; + if (contextIclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { + what = "method"; + } + if (objc != 2) { + Tcl_AppendResult(interp, + "wrong # args: should be \"info body ", what, "\"", + NULL); + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objv[1]); + if (hPtr) { + ItclCmdLookup *clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + ItclMemberFunc *imPtr = clookup->imPtr; + ItclMemberCode *mcode = imPtr->codePtr; + + /* + * Return a string describing the implementation. + */ + if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { + Tcl_SetObjResult(interp, mcode->bodyPtr); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1)); + } + return TCL_OK; + } + + if (contextIclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, + (char *)objv[1]); + } + + if (hPtr) { + ItclDelegatedFunction *idmPtr = Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_NewStringObj("delegated ", -1); + + if (idmPtr->flags & ITCL_TYPE_METHOD) { + what = "typemethod"; + } + Tcl_AppendToObj(objPtr, what, -1); + Tcl_AppendToObj(objPtr, " \"", -1); + Tcl_AppendObjToObj(objPtr, objv[1]); + Tcl_AppendToObj(objPtr, "\"", -1); + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + goto fallback; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoArgsCmd() + * + * Handles the usual "info args" request, returning the argument list + * for a specific proc. Included here for backward compatibility, since + * otherwise Tcl would complain that class procs are not real "procs". + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoArgsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr = NULL; + ItclClass *contextIclsPtr = NULL; + ItclObject *contextIoPtr; + const char *what = NULL; + + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK + && objc > 1) { + int code; + Tcl_Obj *script; + + /* + * We lack the context for any specialized Itcl meaning for + * [info args], so fallback to Tcl's. + */ + + fallback: + script = Tcl_NewStringObj("::info args", -1); + if (objc == 2) { + Tcl_ListObjAppendElement(NULL, script, objv[1]); + } + Tcl_IncrRefCount(script); + code = Tcl_EvalObjEx(interp, script, 0); + Tcl_DecrRefCount(script); + if (code == TCL_ERROR && what) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a %s", Tcl_GetString(objv[1]), what)); + } + return code; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + what = "function"; + if ((contextIclsPtr != NULL) && (contextIclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET))) { + what = "method"; + } + if (objc != 2) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"info args %s\"", what)); + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objv[1]); + if (hPtr) { + ItclCmdLookup *clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + ItclMemberFunc *imPtr = clookup->imPtr; + ItclMemberCode *mcode = imPtr->codePtr; + + /* + * Return a string describing the argument list. + */ + if ((mcode && mcode->argListPtr != NULL) + || ((imPtr->flags & ITCL_ARG_SPEC) != 0)) { + Tcl_SetObjResult(interp, imPtr->usagePtr); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1)); + } + return TCL_OK; + } + + if (contextIclsPtr->flags + & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, + (char *)objv[1]); + } + + if (hPtr) { + ItclDelegatedFunction *idmPtr = Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_NewStringObj("delegated ", -1); + + if (idmPtr->flags & ITCL_TYPE_METHOD) { + what = "typemethod"; + } + Tcl_AppendToObj(objPtr, what, -1); + Tcl_AppendToObj(objPtr, " \"", -1); + Tcl_AppendObjToObj(objPtr, objv[1]); + Tcl_AppendToObj(objPtr, "\"", -1); + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; + } + goto fallback; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoOptionCmd() + * + * Returns information regarding class options. + * Handles the following syntax: + * + * info option ?optionName? ?-protection? ?-name? ?-resource? ?-class? + * ?-default? ?-configmethod? ?-cgetmethod? ?-validatemethod? ?-value? + * + * If the ?optionName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoOptionCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + char *optionName = NULL; + Tcl_Obj *resultPtr = NULL; + Tcl_Obj *objPtr = NULL; + Tcl_Obj *optionNamePtr; + + static const char *options[] = { + "-cgetmethod", "-cgetmethodvar","-class", + "-configuremethod", "-configuremethodvar", + "-default", + "-name", "-protection", "-resource", + "-validatemethod", "-validatemethodvar", + "-value", (char*)NULL + }; + enum BOptIdx { + BOptCgetMethodIdx, + BOptCgetMethodVarIdx, + BOptClassIdx, + BOptConfigureMethodIdx, + BOptConfigureMethodVarIdx, + BOptDefaultIdx, + BOptNameIdx, + BOptProtectIdx, + BOptResourceIdx, + BOptValidateMethodIdx, + BOptValidateMethodVarIdx, + BOptValueIdx + } *ioptlist, ioptlistStorage[12]; + + static enum BOptIdx DefInfoOption[12] = { + BOptProtectIdx, + BOptNameIdx, + BOptResourceIdx, + BOptClassIdx, + BOptDefaultIdx, + BOptCgetMethodIdx, + BOptCgetMethodVarIdx, + BOptConfigureMethodIdx, + BOptConfigureMethodVarIdx, + BOptValidateMethodIdx, + BOptValidateMethodVarIdx, + BOptValueIdx + }; + + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclOption *ioptPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + const char *val; + int i; + int result; + + ItclShowArgs(1, "Itcl_BiInfoOptionCmd", objc, objv); + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info option ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?optionName? ?-protection? ?-name? ?-resource? ?-class? + * ?-default? ?-cgetmethod? ?-cgetmethodvar? ?-configuremethod? + * ?-configuremethodvar? ?-validatemethod? ?-validatemethodvar? ?-value? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + optionName = Tcl_GetString(*objv); + objc--; + objv++; + } + + /* + * Return info for a specific option. + */ + if (optionName) { + optionNamePtr = Tcl_NewStringObj(optionName, -1); + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectOptions, + (char *)optionNamePtr); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", optionName, "\" isn't a option in object \"", + Tcl_GetString(contextIoPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); + + /* + * By default, return everything. + */ + if (objc == 0) { + ioptlist = DefInfoOption; + objc = 9; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + ioptlist = &ioptlistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&ioptlist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (ioptlist[i]) { + case BOptCgetMethodIdx: + if (ioptPtr->cgetMethodPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->cgetMethodPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptCgetMethodVarIdx: + if (ioptPtr->cgetMethodVarPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->cgetMethodVarPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptConfigureMethodIdx: + if (ioptPtr->configureMethodPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->configureMethodPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptConfigureMethodVarIdx: + if (ioptPtr->configureMethodVarPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->configureMethodVarPtr), + -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptValidateMethodIdx: + if (ioptPtr->validateMethodPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->validateMethodPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptValidateMethodVarIdx: + if (ioptPtr->validateMethodVarPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->validateMethodVarPtr), + -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptResourceIdx: + if (ioptPtr->resourceNamePtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->resourceNamePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptClassIdx: + if (ioptPtr->classNamePtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->classNamePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptDefaultIdx: + if (ioptPtr->defaultValuePtr != NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->defaultValuePtr), -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + break; + + case BOptNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(ioptPtr->fullNamePtr), -1); + break; + + case BOptProtectIdx: + val = Itcl_ProtectionStr(ioptPtr->protection); + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + + case BOptValueIdx: + if (contextIoPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "cannot access object-specific info ", + "without an object context", + (char*)NULL); + return TCL_ERROR; + } else { + val = ItclGetInstanceVar(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), + contextIoPtr, ioptPtr->iclsPtr); + } + if (val == NULL) { + val = "<undefined>"; + } + objPtr = Tcl_NewStringObj((const char *)val, -1); + Tcl_IncrRefCount(objPtr); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available options. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_IncrRefCount(resultPtr); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->options, &place); + while (hPtr) { + ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); + objPtr = ioptPtr->namePtr; + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoComponentCmd() + * + * Returns information regarding class components. + * Handles the following syntax: + * + * info component ?componentName? ?-inherit? ?-name? ?-value? + * + * If the ?componentName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiInfoComponentCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + char *componentName = NULL; + Tcl_Obj *resultPtr = NULL; + Tcl_Obj *objPtr = NULL; + Tcl_Obj *componentNamePtr; + + static const char *components[] = { + "-name", "-inherit", "-value", (char*)NULL + }; + enum BCompIdx { + BCompNameIdx, BCompInheritIdx, BCompValueIdx + } *icomplist, icomplistStorage[3]; + + static enum BCompIdx DefInfoComponent[3] = { + BCompNameIdx, + BCompInheritIdx, + BCompValueIdx + }; + + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObjectInfo *infoPtr; + + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + Tcl_Namespace *nsPtr; + ItclComponent *icPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + const char *val; + int i; + int result; + + ItclShowArgs(1, "Itcl_BiInfoComponentCmd", objc, objv); + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info component ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + nsPtr = Itcl_GetUplevelNamespace(interp, 1); + if (nsPtr->parentPtr == NULL) { + /* :: namespace */ + nsPtr = contextIclsPtr->nsPtr; + } + infoPtr = contextIclsPtr->infoPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "cannot find class name for namespace \"", + nsPtr->fullName, "\"", NULL); + return TCL_ERROR; + } + contextIclsPtr = Tcl_GetHashValue(hPtr); + + /* + * Process args: + * ?componentName? ?-inherit? ?-name? ?-value? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + componentName = Tcl_GetString(*objv); + objc--; + objv++; + } + + /* + * Return info for a specific component. + */ + if (componentName) { + componentNamePtr = Tcl_NewStringObj(componentName, -1); + if (contextIoPtr != NULL) { + Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); + } else { + Itcl_InitHierIter(&hier, contextIclsPtr); + } + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->components, + (char *)componentNamePtr); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", componentName, "\" isn't a component in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); + + /* + * By default, return everything. + */ + if (objc == 0) { + icomplist = DefInfoComponent; + objc = 3; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + icomplist = &icomplistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + components, "component", 0, (int*)(&icomplist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (icomplist[i]) { + case BCompNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(icPtr->ivPtr->fullNamePtr), -1); + break; + + case BCompInheritIdx: + if (icPtr->flags & ITCL_COMPONENT_INHERIT) { + val = "1"; + } else { + val = "0"; + } + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + + case BCompValueIdx: + if (contextIoPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "cannot access object-specific info ", + "without an object context", + (char*)NULL); + return TCL_ERROR; + } else { + val = ItclGetInstanceVar(interp, + Tcl_GetString(icPtr->namePtr), NULL, + contextIoPtr, icPtr->ivPtr->iclsPtr); + } + if (val == NULL) { + val = "<undefined>"; + } + objPtr = Tcl_NewStringObj((const char *)val, -1); + Tcl_IncrRefCount(objPtr); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available components. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_IncrRefCount(resultPtr); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); + while (hPtr) { + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); + objPtr = Tcl_NewStringObj( + Tcl_GetString(icPtr->ivPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoWidgetCmd() + * + * Returns information regarding widget classes. + * Handles the following syntax: + * + * info widget ?widgetName? + * + * If the ?widgetName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoWidgetCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *contextNs = NULL; + Tcl_Obj *objPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + char *name; + + ItclShowArgs(1, "Itcl_BiInfoWidgetCmd", objc, objv); + if (objc != 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"info widget\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + /* try it the hard way */ + ClientData clientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + clientData = Itcl_GetCallFrameClientData(interp); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + if (clientData != NULL) { + oPtr = Tcl_ObjectContextObject(clientData); + contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + contextIclsPtr = contextIoPtr->iclsPtr; + } + if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info widget ... }", -1)); + return TCL_ERROR; + } + } + + /* + * If there is an object context, then return the most-specific + * class for the object. Otherwise, return the class namespace + * name. Use normal class names when possible. + */ + if (contextIoPtr) { + contextNs = contextIoPtr->iclsPtr->nsPtr; + } else { + assert(contextIclsPtr != NULL); + assert(contextIclsPtr->nsPtr != NULL); +#ifdef NEW_PROTO_RESOLVER + contextNs = contextIclsPtr->nsPtr; +#else + if (contextIclsPtr->infoPtr->useOldResolvers) { + contextNs = contextIclsPtr->nsPtr; + } else { + contextNs = contextIclsPtr->nsPtr; + } +#endif + } + + name = contextNs->fullName; + if (!(contextIclsPtr->flags & ITCL_WIDGET)) { + Tcl_AppendResult(interp, "object or class is no widget", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(name, -1); + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoExtendedClassCmd() + * + * Returns information regarding extendedclasses. + * Handles the following syntax: + * + * info extendedclass ?className? + * + * If the ?className? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoExtendedClassCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ +#ifdef NOTYET + static const char *components[] = { + "-name", "-inherit", "-value", (char*)NULL + }; + enum BCompIdx { + BCompNameIdx, BCompInheritIdx, BCompValueIdx + } *icomplist, icomplistStorage[3]; + + static enum BCompIdx DefInfoComponent[3] = { + BCompNameIdx, + BCompInheritIdx, + BCompValueIdx + }; + + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObjectInfo *infoPtr; + + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + Tcl_Namespace *nsPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + const char *name; + int result; + + ItclShowArgs(1, "Itcl_BiInfoExtendedClassCmd", objc, objv); + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info extendedclass ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + nsPtr = Itcl_GetUplevelNamespace(interp, 1); + if (nsPtr->parentPtr == NULL) { + /* :: namespace */ + nsPtr = contextIclsPtr->nsPtr; + } + infoPtr = contextIclsPtr->infoPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "cannot find class name for namespace \"", + nsPtr->fullName, "\"", NULL); + return TCL_ERROR; + } + contextIclsPtr = Tcl_GetHashValue(hPtr); + +#endif + + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedCmd() + * + * Returns information regarding extendedclasses. + * Handles the following syntax: + * + * info extendedclass ?className? + * + * If the ?className? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ +#ifdef NOTYET + static const char *components[] = { + "-name", "-inherit", "-value", (char*)NULL + }; + enum BCompIdx { + BCompNameIdx, BCompInheritIdx, BCompValueIdx + } *icomplist, icomplistStorage[3]; + + static enum BCompIdx DefInfoComponent[3] = { + BCompNameIdx, + BCompInheritIdx, + BCompValueIdx + }; + + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObjectInfo *infoPtr; + + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + Tcl_Namespace *nsPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + const char *name; + int result; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedCmd", objc, objv); + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info delegated ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + nsPtr = Itcl_GetUplevelNamespace(interp, 1); + if (nsPtr->parentPtr == NULL) { + /* :: namespace */ + nsPtr = contextIclsPtr->nsPtr; + } + infoPtr = contextIclsPtr->infoPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "cannot find class name for namespace \"", + nsPtr->fullName, "\"", NULL); + return TCL_ERROR; + } + contextIclsPtr = Tcl_GetHashValue(hPtr); + +#endif + + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoTypeCmd() + * + * Returns information regarding the Type for an object. This command + * can be invoked with or without an object context: + * + * <objName> info type <= returns most-specific class name + * info type <= returns active namespace name + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoTypeCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *contextNs = NULL; + Tcl_Obj *objPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + char *name; + + ItclShowArgs(1, "Itcl_BiInfoTypeCmd", objc, objv); + if (objc != 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"info type\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + /* try it the hard way */ + ClientData clientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + clientData = Itcl_GetCallFrameClientData(interp); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + if (clientData != NULL) { + oPtr = Tcl_ObjectContextObject(clientData); + contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + contextIclsPtr = contextIoPtr->iclsPtr; + } + if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info type ...}", -1)); + return TCL_ERROR; + } + } + + /* + * If there is an object context, then return the most-specific + * class for the object. Otherwise, return the class namespace + * name. Use normal class names when possible. + */ + if (contextIoPtr) { + contextNs = contextIoPtr->iclsPtr->nsPtr; + } else { + assert(contextIclsPtr != NULL); + assert(contextIclsPtr->nsPtr != NULL); +#ifdef NEW_PROTO_RESOLVER + contextNs = contextIclsPtr->nsPtr; +#else + if (contextIclsPtr->infoPtr->useOldResolvers) { + contextNs = contextIclsPtr->nsPtr; + } else { + contextNs = contextIclsPtr->nsPtr; + } +#endif + } + + name = contextNs->fullName; + if (!(contextIclsPtr->flags & ITCL_TYPE)) { + Tcl_AppendResult(interp, "object or class is no type", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(name, -1); + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoHullTypeCmd() + * + * Returns information regarding the hulltype for an object. This command + * can be invoked with or without an object context: + * + * <objName> info hulltype returns the hulltype name + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoHullTypeCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + + ItclShowArgs(1, "Itcl_BiInfoHullTypeCmd", objc, objv); + if (objc != 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"info hulltype\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + /* try it the hard way */ + ClientData clientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + clientData = Itcl_GetCallFrameClientData(interp); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + if (clientData != NULL) { + oPtr = Tcl_ObjectContextObject(clientData); + contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + contextIclsPtr = contextIoPtr->iclsPtr; + } + if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info hulltype ... }", -1)); + return TCL_ERROR; + } + } + + if (!(contextIclsPtr->flags & ITCL_WIDGET)) { + Tcl_AppendResult(interp, "object or class is no widget.", + " Only ::itcl::widget has a hulltype.", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contextIclsPtr->hullTypePtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDefaultCmd() + * + * Returns information regarding the Type for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDefaultCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + ItclDelegatedFunction *idmPtr; + ItclArgList *argListPtr; + const char *methodName; + const char *argName; + const char *what; + int found; + + ItclShowArgs(1, "Itcl_BiInfoDefaultCmd", objc, objv); + iclsPtr = NULL; + found = 0; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (objc != 4) { + Tcl_AppendResult(interp, "wrong # args, should be info default ", + "<method> <argName> <varName>", NULL); + return TCL_ERROR; + } + methodName = Tcl_GetString(objv[1]); + argName = Tcl_GetString(objv[2]); + FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { + if (strcmp(methodName, Tcl_GetString(imPtr->namePtr)) == 0) { + found = 1; + break; + } + } + if (found) { + argListPtr = imPtr->argListPtr; + while (argListPtr != NULL) { + if (strcmp(argName, Tcl_GetString(argListPtr->namePtr)) == 0) { + if (argListPtr->defaultValuePtr != NULL) { + if (NULL == Tcl_ObjSetVar2(interp, objv[3], NULL, + argListPtr->defaultValuePtr, TCL_LEAVE_ERR_MSG)) { + return TCL_ERROR; + } + Tcl_SetResult(interp, "1", NULL); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "method \"", methodName, + "\" has no default value for argument \"", + argName, "\"", NULL); + return TCL_ERROR; + } + } + argListPtr = argListPtr->nextPtr; + } + } + if (! found) { + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (strcmp(methodName, Tcl_GetString(idmPtr->namePtr)) == 0) { + what = "method"; + if (idmPtr->flags & ITCL_TYPE_METHOD) { + what = "typemethod"; + } + Tcl_AppendResult(interp, "delegated ", what, " \"", methodName, + "\"", NULL); + return TCL_ERROR; + } + } + } + if (! found) { + Tcl_AppendResult(interp, "unknown method \"", methodName, "\"", NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, "method \"", methodName, "\" has no argument \"", + argName, "\"", NULL); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoMethodCmd() + * + * Returns information regarding a method for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoMethodCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + ItclMemberCode *mcode; + ItclHierIter hier; + const char *val; + char *cmdName; + int i; + int result; + + static const char *options[] = { + "-args", "-body", "-name", "-protection", "-type", + (char*)NULL + }; + enum BIfIdx { + BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx + } *iflist, iflistStorage[5]; + + static enum BIfIdx DefInfoFunction[5] = { + BIfProtectIdx, + BIfTypeIdx, + BIfNameIdx, + BIfArgsIdx, + BIfBodyIdx + }; + + ItclShowArgs(1, "Itcl_BiInfoMethodCmd", objc, objv); + cmdName = NULL; + objPtr = NULL; + resultPtr = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info method ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + cmdName = Tcl_GetString(*objv); + objc--; objv++; + } + + /* + * Return info for a specific command. + */ + if (cmdName) { + ItclCmdLookup *clookup; + objPtr = Tcl_NewStringObj(cmdName, -1); + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + objPtr = NULL; + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a method in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + mcode = imPtr->codePtr; + if (imPtr->flags & ITCL_COMMON) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a method in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * By default, return everything. + */ + if (objc == 0) { + objc = 5; + iflist = DefInfoFunction; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + iflist = &iflistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&iflist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (iflist[i]) { + case BIfArgsIdx: + if (mcode && mcode->argListPtr) { + if (imPtr->usagePtr == NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->usagePtr), -1); + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->usagePtr), -1); + } + } else { + if ((imPtr->flags & ITCL_ARG_SPEC) != 0) { + if (imPtr->usagePtr == NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->usagePtr), -1); + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->usagePtr), -1); + } + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + } + break; + + case BIfBodyIdx: + if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->bodyPtr), -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + break; + + case BIfNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->fullNamePtr), -1); + break; + + case BIfProtectIdx: + val = Itcl_ProtectionStr(imPtr->protection); + objPtr = Tcl_NewStringObj(val, -1); + break; + + case BIfTypeIdx: + val = "method"; + objPtr = Tcl_NewStringObj(val, -1); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available commands. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->functions, &place); + while (hPtr) { + int useIt = 1; + + imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); + if (!(imPtr->flags & ITCL_METHOD)) { + useIt = 0; + } + if (useIt) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoMethodsCmd() + * + * Returns information regarding the methods for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoMethodsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + ItclDelegatedFunction *idmPtr; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoMethodsCmd", objc, objv); + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + name = "destroy"; + if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(name, -1)); + } + name = "info"; + if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(name, -1)); + } + FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { + name = Tcl_GetString(imPtr->namePtr); + if (strcmp(name, "*") == 0) { + continue; + } + if (strcmp(name, "destroy") == 0) { + continue; + } + if (strcmp(name, "info") == 0) { + continue; + } + if ((imPtr->flags & ITCL_METHOD) && + !(imPtr->flags & ITCL_CONSTRUCTOR) && + !(imPtr->flags & ITCL_DESTRUCTOR) && + !(imPtr->flags & ITCL_COMMON) && + !(imPtr->codePtr->flags & ITCL_BUILTIN)) { + if ((pattern == NULL) || + Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(imPtr->namePtr), -1)); + } + } + } + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + name = Tcl_GetString(idmPtr->namePtr); + if (strcmp(name, "*") == 0) { + continue; + } + if (strcmp(name, "destroy") == 0) { + continue; + } + if (strcmp(name, "info") == 0) { + continue; + } + if (idmPtr->flags & ITCL_METHOD) { + if ((pattern == NULL) || + Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(idmPtr->namePtr), -1)); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoOptionsCmd() + * + * Returns information regarding the Type for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoOptionsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashEntry *hPtr2; + Tcl_Obj *listPtr; + Tcl_Obj *listPtr2; + Tcl_Obj *objPtr; + Tcl_Obj **lObjv; + Tcl_HashTable *tablePtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclOption *ioptPtr; + ItclDelegatedOption *idoPtr; + const char *name; + const char *val; + const char *pattern; + int lObjc; + int result; + int i; + + ItclShowArgs(1, "Itcl_BiInfoOptionsCmd", objc, objv); + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info options ", + "?pattern?", NULL); + return TCL_ERROR; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + if (ioPtr == NULL) { + tablePtr = &iclsPtr->options; + } else { + tablePtr = &ioPtr->objectOptions; + } + FOREACH_HASH_VALUE(ioptPtr, tablePtr) { + name = Tcl_GetString(ioptPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1)); + } + } + if (ioPtr == NULL) { + tablePtr = &iclsPtr->delegatedOptions; + } else { + tablePtr = &ioPtr->objectDelegatedOptions; + } + FOREACH_HASH_VALUE(idoPtr, tablePtr) { + name = Tcl_GetString(idoPtr->namePtr); + if (strcmp(name, "*") != 0) { + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(idoPtr->namePtr), -1)); + } + } else { + if (idoPtr->icPtr == NULL) { + Tcl_AppendResult(interp, "component \"", + Tcl_GetString(idoPtr->namePtr), + "\" is not initialized", NULL); + return TCL_ERROR; + } + val = ItclGetInstanceVar(interp, + Tcl_GetString(idoPtr->icPtr->namePtr), + NULL, ioPtr, ioPtr->iclsPtr); + if ((val != NULL) && (strlen(val) != 0)) { + objPtr = Tcl_NewStringObj(val, -1); + Tcl_AppendToObj(objPtr, " configure", -1); + result = Tcl_EvalObjEx(interp, objPtr, 0); + if (result != TCL_OK) { + return TCL_ERROR; + } + listPtr2 = Tcl_GetObjResult(interp); + Tcl_ListObjGetElements(interp, listPtr2, &lObjc, &lObjv); + for (i = 0; i < lObjc; i++) { + Tcl_ListObjIndex(interp, lObjv[i], 0, &objPtr); + hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, + (char *)objPtr); + if (hPtr2 == NULL) { + name = Tcl_GetString(objPtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } + } + } + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoTypesCmd() + * + * Returns information regarding the Type for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoTypesCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoTypesCmd", objc, objv); + infoPtr = (ItclObjectInfo *)clientData; + iclsPtr = NULL; + pattern = NULL; + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info types ", + "?pattern?", NULL); + return TCL_ERROR; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(iclsPtr, &infoPtr->nameClasses) { + if (iclsPtr->flags & ITCL_TYPE) { + name = Tcl_GetString(iclsPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(iclsPtr->namePtr), -1)); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoComponentsCmd() + * + * Returns information regarding the Components for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoComponentsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclComponent *icPtr; + ItclHierIter hier; + ItclClass *iclsPtr2; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoComponentsCmd", objc, objv); + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR in Itcl_BiInfoComponentsCmd", + " iclsPtr == NULL", NULL); + return TCL_ERROR; + } + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info components ", + "?pattern?", NULL); + return TCL_ERROR; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + FOREACH_HASH_VALUE(icPtr, &iclsPtr2->components) { + name = Tcl_GetString(icPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(icPtr->namePtr), -1)); + } + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoTypeMethodCmd() + * + * Returns information regarding a typemethod for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoTypeMethodCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + ItclMemberCode *mcode; + ItclHierIter hier; + const char *val; + char *cmdName; + int i; + int result; + + static const char *options[] = { + "-args", "-body", "-name", "-protection", "-type", + (char*)NULL + }; + enum BIfIdx { + BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx + } *iflist, iflistStorage[5]; + + static enum BIfIdx DefInfoFunction[5] = { + BIfProtectIdx, + BIfTypeIdx, + BIfNameIdx, + BIfArgsIdx, + BIfBodyIdx + }; + + + ItclShowArgs(1, "Itcl_BiInfoTypeMethodCmd", objc, objv); + resultPtr = NULL; + objPtr = NULL; + cmdName = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info function ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + cmdName = Tcl_GetString(*objv); + objc--; objv++; + } + + /* + * Return info for a specific command. + */ + if (cmdName) { + ItclCmdLookup *clookup; + objPtr = Tcl_NewStringObj(cmdName, -1); + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + objPtr = NULL; + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a typemethod in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + mcode = imPtr->codePtr; + if (!(imPtr->flags & ITCL_TYPE_METHOD)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a typemethod in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * By default, return everything. + */ + if (objc == 0) { + objc = 5; + iflist = DefInfoFunction; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + iflist = &iflistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&iflist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (iflist[i]) { + case BIfArgsIdx: + if (mcode && mcode->argListPtr) { + if (imPtr->usagePtr == NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->usagePtr), -1); + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->usagePtr), -1); + } + } else { + if ((imPtr->flags & ITCL_ARG_SPEC) != 0) { + if (imPtr->usagePtr == NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->usagePtr), -1); + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->usagePtr), -1); + } + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + } + break; + + case BIfBodyIdx: + if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(mcode->bodyPtr), -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + break; + + case BIfNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->fullNamePtr), -1); + break; + + case BIfProtectIdx: + val = Itcl_ProtectionStr(imPtr->protection); + objPtr = Tcl_NewStringObj(val, -1); + break; + + case BIfTypeIdx: + val = "typemethod"; + objPtr = Tcl_NewStringObj(val, -1); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available commands. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->functions, &place); + while (hPtr) { + int useIt = 1; + + imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); + if (!(imPtr->flags & ITCL_TYPE_METHOD)) { + useIt = 0; + } + if (useIt) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(imPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoMethodsCmd() + * + * Returns information regarding the methods for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoTypeMethodsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + ItclDelegatedFunction *idmPtr; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoTypeMethodsCmd", objc, objv); + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (objc > 1) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + name = "create"; + if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(name, -1)); + } + name = "destroy"; + if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(name, -1)); + } + name = "info"; + if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(name, -1)); + } + FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { + name = Tcl_GetString(imPtr->namePtr); + if (strcmp(name, "*") == 0) { + continue; + } + if (strcmp(name, "create") == 0) { + continue; + } + if (strcmp(name, "destroy") == 0) { + continue; + } + if (strcmp(name, "info") == 0) { + continue; + } + if (imPtr->flags & ITCL_TYPE_METHOD) { + if ((pattern == NULL) || + Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(imPtr->namePtr), -1)); + } + } + } + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + name = Tcl_GetString(idmPtr->namePtr); + if (strcmp(name, "*") == 0) { + continue; + } + if (strcmp(name, "create") == 0) { + continue; + } + if (strcmp(name, "destroy") == 0) { + continue; + } + if (strcmp(name, "info") == 0) { + continue; + } + if (idmPtr->flags & ITCL_TYPE_METHOD) { + if ((pattern == NULL) || + Tcl_StringMatch((const char *)name, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(Tcl_GetString(idmPtr->namePtr), -1)); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoTypeVarsCmd() + * + * Returns information regarding variables for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoTypeVarsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclVariable *ivPtr; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoTypeVarsCmd", objc, objv); + if (objc > 2) { + Tcl_AppendResult(interp, + "wrong # args should be: info typevars ?pattern?", NULL); + return TCL_ERROR; + } + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { + if ((pattern == NULL) || + Tcl_StringMatch(Tcl_GetString(ivPtr->namePtr), pattern)) { + if (ivPtr->flags & ITCL_TYPE_VARIABLE) { + Tcl_ListObjAppendElement(interp, listPtr, ivPtr->fullNamePtr); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoTypeVariableCmd() + * + * Returns information regarding a typevariable for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoTypeVariableCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + ItclClass *iclsPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclVariable *ivPtr; + ItclVarLookup *vlookup; + ItclHierIter hier; + char *varName; + const char *val; + int i; + int result; + + static const char *options[] = { + "-init", "-name", "-protection", "-type", + "-value", (char*)NULL + }; + enum BIvIdx { + BIvInitIdx, + BIvNameIdx, + BIvProtectIdx, + BIvTypeIdx, + BIvValueIdx + } *ivlist, ivlistStorage[5]; + + static enum BIvIdx DefInfoVariable[5] = { + BIvProtectIdx, + BIvTypeIdx, + BIvNameIdx, + BIvInitIdx, + BIvValueIdx + }; + + ItclShowArgs(1, "Itcl_BiInfoTypeVariableCmd", objc, objv); + resultPtr = NULL; + objPtr = NULL; + varName = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info typevariable ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + varName = Tcl_GetString(*objv); + objc--; objv++; + } + + /* + * Return info for a specific variable. + */ + if (varName) { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", varName, "\" isn't a typevariable in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + ivPtr = vlookup->ivPtr; + if (!(ivPtr->flags & ITCL_TYPE_VARIABLE)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", varName, "\" isn't a typevariable in class \"", + contextIclsPtr->nsPtr->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + /* + * By default, return everything. + */ + if (objc == 0) { + ivlist = DefInfoVariable; + objc = 5; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + ivlist = &ivlistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&ivlist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (ivlist[i]) { + case BIvInitIdx: + /* + * If this is the built-in "this" variable, then + * report the object name as its initialization string. + */ + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + if ((contextIoPtr != NULL) && + (contextIoPtr->accessCmd != NULL)) { + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName( + contextIoPtr->iclsPtr->interp, + contextIoPtr->accessCmd, objPtr); + } else { + objPtr = Tcl_NewStringObj("<objectName>", -1); + } + } else { + if (vlookup->ivPtr->init) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(vlookup->ivPtr->init), -1); + } else { + objPtr = Tcl_NewStringObj("<undefined>", -1); + } + } + break; + + case BIvNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + break; + + case BIvProtectIdx: + val = Itcl_ProtectionStr(ivPtr->protection); + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + + case BIvTypeIdx: + val = ((ivPtr->flags & ITCL_COMMON) != 0) + ? "common" : "variable"; + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + + case BIvValueIdx: + if ((ivPtr->flags & ITCL_COMMON) != 0) { + val = Itcl_GetCommonVar(interp, + Tcl_GetString(ivPtr->fullNamePtr), + ivPtr->iclsPtr); + } else { + if (contextIoPtr == NULL) { + if (objc > 1) { + Tcl_DecrRefCount(resultPtr); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "cannot access object-specific info ", + "without an object context", + (char*)NULL); + return TCL_ERROR; + } else { + val = Itcl_GetInstanceVar(interp, + Tcl_GetString(ivPtr->namePtr), + contextIoPtr, ivPtr->iclsPtr); + } + } + if (val == NULL) { + val = "<undefined>"; + } + objPtr = Tcl_NewStringObj((const char *)val, -1); + break; + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + } + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_GetString(resultPtr), NULL); + Tcl_DecrRefCount(resultPtr); + } else { + + /* + * Return the list of available variables. Report the built-in + * "this" variable only once, for the most-specific class. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place); + while (hPtr) { + ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); + if (ivPtr->flags & ITCL_TYPE_VAR) { + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + if (iclsPtr == contextIclsPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + } else { + objPtr = Tcl_NewStringObj( + Tcl_GetString(ivPtr->fullNamePtr), -1); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + resultPtr, objPtr); + } + } + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoVariablesCmd() + * + * Returns information regarding typevariables for an object. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoVariablesCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclShowArgs(1, "Itcl_BiInfoVariablesCmd", objc, objv); + Tcl_AppendResult(interp, "Itcl_BiInfoVariablesCmd not yet implemented\n", + NULL); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoWidgetadaptorCmd() + * + * Returns information regarding a widgetadaptor. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoWidgetadaptorCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Namespace *contextNs = NULL; + Tcl_Obj *objPtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + char *name; + + ItclShowArgs(1, "Itcl_BiInfoWidgetadaptorCmd", objc, objv); + if (objc != 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"info widgetadaptor\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + contextIclsPtr = NULL; + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + /* try it the hard way */ + ClientData clientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + clientData = Itcl_GetCallFrameClientData(interp); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + if (clientData != NULL) { + oPtr = Tcl_ObjectContextObject(clientData); + contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + contextIclsPtr = contextIoPtr->iclsPtr; + } + if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info widgetadaptor ... }", -1)); + return TCL_ERROR; + } + } + + /* + * If there is an object context, then return the most-specific + * class for the object. Otherwise, return the class namespace + * name. Use normal class names when possible. + */ + if (contextIoPtr) { + contextNs = contextIoPtr->iclsPtr->nsPtr; + } else { + assert(contextIclsPtr != NULL); + assert(contextIclsPtr->nsPtr != NULL); +#ifdef NEW_PROTO_RESOLVER + contextNs = contextIclsPtr->nsPtr; +#else + if (contextIclsPtr->infoPtr->useOldResolvers) { + contextNs = contextIclsPtr->nsPtr; + } else { + contextNs = contextIclsPtr->nsPtr; + } +#endif + } + + name = contextNs->fullName; + if (!(contextIclsPtr->flags & ITCL_WIDGETADAPTOR)) { + Tcl_AppendResult(interp, "object or class is no widgetadaptor", NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewStringObj(name, -1); + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoInstancesCmd() + * + * Returns information regarding instances. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoInstancesCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + ItclObjectInfo *infoPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoInstancesCmd", objc, objv); + if (objc > 2) { + Tcl_AppendResult(interp, + "wrong # args should be: info instances ?pattern?", NULL); + return TCL_ERROR; + } + iclsPtr = NULL; + pattern = NULL; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + infoPtr = (ItclObjectInfo *)clientData; + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(ioPtr, &infoPtr->objects) { + /* FIXME need to scan the inheritance too */ + if (ioPtr->iclsPtr == iclsPtr) { + if (ioPtr->iclsPtr->flags & ITCL_WIDGETADAPTOR) { + objPtr = Tcl_NewStringObj(Tcl_GetCommandName(interp, + ioPtr->accessCmd), -1); + } else { + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); + } + if ((pattern == NULL) || + Tcl_StringMatch(Tcl_GetString(objPtr), pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedOptionsCmd() + * + * Returns information regarding delegated options. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedOptionsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + Tcl_Obj *objPtr2; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclDelegatedOption *idoPtr; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedOptionsCmd", objc, objv); + pattern = NULL; + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info delegated ", + "options ?pattern?", NULL); + return TCL_ERROR; + } + + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { + if (iclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { + name = Tcl_GetString(idoPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + objPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, objPtr, + idoPtr->namePtr); + if (idoPtr->icPtr != NULL) { + Tcl_ListObjAppendElement(interp, objPtr, + idoPtr->icPtr->namePtr); + } else { + objPtr2 = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr2); + Tcl_ListObjAppendElement(interp, objPtr, objPtr2); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedMethodsCmd() + * + * Returns information regarding delegated methods. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedMethodsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + Tcl_Obj *objPtr2; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedMethodsCmd", objc, objv); + pattern = NULL; + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info delegated ", + "methods ?pattern?", NULL); + return TCL_ERROR; + } + + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (iclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { + name = Tcl_GetString(idmPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + if ((idmPtr->flags & ITCL_TYPE_METHOD) == 0) { + objPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, objPtr, + idmPtr->namePtr); + if (idmPtr->icPtr != NULL) { + Tcl_ListObjAppendElement(interp, objPtr, + idmPtr->icPtr->namePtr); + } else { + objPtr2 = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr2); + Tcl_ListObjAppendElement(interp, objPtr, objPtr2); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoTypeMethodsCmd() + * + * Returns information regarding delegated type methods. This command + * can be invoked with or without an object context: + * + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedTypeMethodsCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *listPtr; + Tcl_Obj *objPtr; + Tcl_Obj *objPtr2; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + const char *name; + const char *pattern; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedTypeMethodsCmd", objc, objv); + pattern = NULL; + if (objc > 2) { + Tcl_AppendResult(interp, "wrong # args should be: info delegated ", + "typemethods ?pattern?", NULL); + return TCL_ERROR; + } + + if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr != NULL) { + iclsPtr = ioPtr->iclsPtr; + } + listPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (iclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { + name = Tcl_GetString(idmPtr->namePtr); + if ((pattern == NULL) || + Tcl_StringMatch(name, pattern)) { + if (idmPtr->flags & ITCL_TYPE_METHOD) { + objPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, objPtr, + idmPtr->namePtr); + if (idmPtr->icPtr != NULL) { + Tcl_ListObjAppendElement(interp, objPtr, + idmPtr->icPtr->namePtr); + } else { + objPtr2 = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr2); + Tcl_ListObjAppendElement(interp, objPtr, objPtr2); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + } + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedUnknownCmd() + * + * the unknown handler for the ::itcl::builtin::Info::delagted ensemble + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedUnknownCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *objPtr; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedUnknownCmd", objc, objv); + /* produce usage message */ + objPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + ItclGetInfoDelegatedUsage(interp, objPtr, (ItclObjectInfo *)clientData); + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedOptionCmd() + * + * Returns information regarding class options. + * Handles the following syntax: + * + * info delegated option ?optionName? ?-name? ?-resource? ?-class? + * ?-component? ?-as? ?-exceptions? + * + * If the ?optionName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedOptionCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashSearch place; + Tcl_Namespace *nsPtr; + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_Obj *optionNamePtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclObjectInfo *infoPtr; + ItclDelegatedOption *idoptPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + char *optionName; + int i; + int result; + + static const char *options[] = { + "-as", "-class", "-component", "-exceptions", + "-name", "-resource", (char*)NULL + }; + enum BOptIdx { + BOptAsIdx, BOptClassIdx, BOptComponentIdx, BOptExceptionsIdx, + BOptNameIdx, BOptResourceIdx + } *ioptlist, ioptlistStorage[6]; + + static enum BOptIdx DefInfoOption[6] = { + BOptNameIdx, + BOptResourceIdx, + BOptClassIdx, + BOptComponentIdx, + BOptAsIdx, + BOptExceptionsIdx + }; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedOptionCmd", objc, objv); + optionName = NULL; + objPtr = NULL; + resultPtr = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info delegated option ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + nsPtr = Itcl_GetUplevelNamespace(interp, 1); + infoPtr = contextIclsPtr->infoPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "cannot find class name for namespace \"", + nsPtr->fullName, "\"", NULL); + return TCL_ERROR; + } + contextIclsPtr = Tcl_GetHashValue(hPtr); + + /* + * Process args: + * ?optionName? ?-name? ?-resource? ?-class? + * ?-as? ?-exceptions? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + optionName = Tcl_GetString(*objv); + objc--; + objv++; + } + + /* + * Return info for a specific option. + */ + if (optionName) { + optionNamePtr = Tcl_NewStringObj(optionName, -1); + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, + (char *)optionNamePtr); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", optionName, "\" isn't an option in object \"", + Tcl_GetString(contextIoPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + idoptPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); + + /* + * By default, return everything. + */ + if (objc == 0) { + ioptlist = DefInfoOption; + objc = 6; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + ioptlist = &ioptlistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&ioptlist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (ioptlist[i]) { + case BOptAsIdx: + if (idoptPtr->asPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idoptPtr->asPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptExceptionsIdx: + { + Tcl_Obj *entryObj; + int hadEntries; + hadEntries = 0; + objPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(entryObj, &idoptPtr->exceptions) { + Tcl_ListObjAppendElement(interp, objPtr, entryObj); + } + if (!hadEntries) { + objPtr = Tcl_NewStringObj("", -1); + } + } + break; + case BOptResourceIdx: + if (idoptPtr->resourceNamePtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idoptPtr->resourceNamePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptClassIdx: + if (idoptPtr->classNamePtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idoptPtr->classNamePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptComponentIdx: + if (idoptPtr->icPtr != NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idoptPtr->icPtr->namePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(idoptPtr->namePtr), -1); + break; + + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available options. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_IncrRefCount(resultPtr); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedOptions, &place); + while (hPtr) { + idoptPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); + objPtr = idoptPtr->namePtr; + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedMethodCmd() + * + * Returns information regarding class options. + * Handles the following syntax: + * + * info delegated method ?methodName? ?-name? + * ?-component? ?-as? ?-using? ?-exceptions? + * + * If the ?optionName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedMethodCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_HashSearch place; + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_Obj *cmdNamePtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclDelegatedFunction *idmPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + char *cmdName; + int i; + int result; + + static const char *options[] = { + "-as", "-component", "-exceptions", + "-name", "-using", (char*)NULL + }; + enum BOptIdx { + BOptAsIdx, + BOptComponentIdx, + BOptExceptionsIdx, + BOptNameIdx, + BOptUsingIdx + } *ioptlist, ioptlistStorage[5]; + + static enum BOptIdx DefInfoOption[5] = { + BOptNameIdx, + BOptComponentIdx, + BOptAsIdx, + BOptUsingIdx, + BOptExceptionsIdx + }; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedMethodCmd", objc, objv); + cmdName = NULL; + objPtr = NULL; + resultPtr = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info delegated method ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?methodName? ?-name? ?-using? + * ?-as? ?-component? ?-exceptions? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + cmdName = Tcl_GetString(*objv); + objc--; + objv++; + } + + /* + * Return info for a specific option. + */ + if (cmdName) { + cmdNamePtr = Tcl_NewStringObj(cmdName, -1); + if (contextIoPtr != NULL) { + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedFunctions, + (char *)cmdNamePtr); + } else { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, + (char *)cmdNamePtr); + } + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a delegated method in object \"", + Tcl_GetString(contextIoPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + idmPtr = (ItclDelegatedFunction*)Tcl_GetHashValue(hPtr); + if (!(idmPtr->flags & ITCL_METHOD)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a delegated method in object \"", + Tcl_GetString(contextIoPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + /* + * By default, return everything. + */ + if (objc == 0) { + ioptlist = DefInfoOption; + objc = 5; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + ioptlist = &ioptlistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&ioptlist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (ioptlist[i]) { + case BOptAsIdx: + if (idmPtr->asPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->asPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptExceptionsIdx: + { + Tcl_Obj *entryObj; + int hadEntries; + hadEntries = 0; + objPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(entryObj, &idmPtr->exceptions) { + Tcl_ListObjAppendElement(interp, objPtr, entryObj); + } + if (!hadEntries) { + objPtr = Tcl_NewStringObj("", -1); + } + } + break; + case BOptUsingIdx: + if (idmPtr->usingPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->usingPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptComponentIdx: + if (idmPtr->icPtr != NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->icPtr->namePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->namePtr), -1); + break; + + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available options. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_IncrRefCount(resultPtr); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedFunctions, &place); + while (hPtr) { + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); + if (idmPtr->flags & ITCL_METHOD) { + objPtr = idmPtr->namePtr; + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInfoDelegatedTypeMethodCmd() + * + * Returns information regarding class options. + * Handles the following syntax: + * + * info delegated typemethod ?methodName? ?-name? + * ?-component? ?-as? ?-exceptions? + * + * If the ?optionName? is not specified, then a list of all known + * data members is returned. Otherwise, the information for a + * specific member is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_BiInfoDelegatedTypeMethodCmd( + ClientData clientData, /* ItclObjectInfo Ptr */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + + FOREACH_HASH_DECLS; + Tcl_HashSearch place; + Tcl_Obj *resultPtr; + Tcl_Obj *objPtr; + Tcl_Obj *cmdNamePtr; + ItclClass *contextIclsPtr; + ItclObject *contextIoPtr; + ItclDelegatedFunction *idmPtr; + ItclHierIter hier; + ItclClass *iclsPtr; + char *cmdName; + int i; + int result; + + static const char *options[] = { + "-as", "-component", "-exceptions", + "-name", "-using", (char*)NULL + }; + enum BOptIdx { + BOptAsIdx, + BOptComponentIdx, + BOptExceptionsIdx, + BOptNameIdx, + BOptUsingIdx + } *ioptlist, ioptlistStorage[5]; + + static enum BOptIdx DefInfoOption[5] = { + BOptNameIdx, + BOptComponentIdx, + BOptAsIdx, + BOptUsingIdx, + BOptExceptionsIdx + }; + + ItclShowArgs(1, "Itcl_BiInfoDelegatedTypeMethodCmd", objc, objv); + cmdName = NULL; + objPtr = NULL; + resultPtr = NULL; + contextIclsPtr = NULL; + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\nget info like this instead: " + "\n namespace eval className { info delegated type method ... }", -1)); + return TCL_ERROR; + } + if (contextIoPtr != NULL) { + contextIclsPtr = contextIoPtr->iclsPtr; + } + + /* + * Process args: + * ?methodName? ?-name? ?-using? + * ?-as? ?-component? ?-exceptions? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + cmdName = Tcl_GetString(*objv); + objc--; + objv++; + } + + /* + * Return info for a specific option. + */ + if (cmdName) { + cmdNamePtr = Tcl_NewStringObj(cmdName, -1); + if (contextIoPtr != NULL) { + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedFunctions, + (char *)cmdNamePtr); + } else { + hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, + (char *)cmdNamePtr); + } + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a delegated typemethod in object \"", + Tcl_GetString(contextIoPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + idmPtr = (ItclDelegatedFunction*)Tcl_GetHashValue(hPtr); + if (!(idmPtr->flags & ITCL_TYPE_METHOD)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", cmdName, "\" isn't a delegated typemethod in object \"", + Tcl_GetString(contextIoPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + /* + * By default, return everything. + */ + if (objc == 0) { + ioptlist = DefInfoOption; + objc = 5; + } else { + + /* + * Otherwise, scan through all remaining flags and + * figure out what to return. + */ + ioptlist = &ioptlistStorage[0]; + for (i=0 ; i < objc; i++) { + result = Tcl_GetIndexFromObj(interp, objv[i], + options, "option", 0, (int*)(&ioptlist[i])); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + } + + if (objc > 1) { + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + } + + for (i=0 ; i < objc; i++) { + switch (ioptlist[i]) { + case BOptAsIdx: + if (idmPtr->asPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->asPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptExceptionsIdx: + { + Tcl_Obj *entryObj; + int hadEntries; + hadEntries = 0; + objPtr = Tcl_NewListObj(0, NULL); + FOREACH_HASH_VALUE(entryObj, &idmPtr->exceptions) { + Tcl_ListObjAppendElement(interp, objPtr, entryObj); + } + if (!hadEntries) { + objPtr = Tcl_NewStringObj("", -1); + } + } + break; + case BOptUsingIdx: + if (idmPtr->usingPtr) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->usingPtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptComponentIdx: + if (idmPtr->icPtr != NULL) { + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->icPtr->namePtr), -1); + } else { + objPtr = Tcl_NewStringObj("", -1); + } + break; + + case BOptNameIdx: + objPtr = Tcl_NewStringObj( + Tcl_GetString(idmPtr->namePtr), -1); + break; + + } + + if (objc == 1) { + resultPtr = objPtr; + } else { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + } else { + + /* + * Return the list of available options. + */ + resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_IncrRefCount(resultPtr); + Itcl_InitHierIter(&hier, contextIclsPtr); + while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedFunctions, &place); + while (hPtr) { + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); + if (idmPtr->flags & ITCL_TYPE_METHOD) { + objPtr = idmPtr->namePtr; + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + objPtr); + } + hPtr = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclInt.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclInt.h new file mode 100644 index 0000000..5134023 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclInt.h @@ -0,0 +1,854 @@ +/* + * itclInt.h -- + * + * This file contains internal definitions for the C-implemented part of a + * Itcl + * + * Copyright (c) 2007 by Arnulf P. Wiedemann + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#ifdef HAVE_STDINT_H +#include <stdint.h> +#endif + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + +#include <string.h> +#include <ctype.h> +#include <tclOO.h> +#include "itcl.h" +#include "itclMigrate2TclCore.h" +#include "itclTclIntStubsFcn.h" + +/* + * Utility macros: STRINGIFY takes an argument and wraps it in "" (double + * quotation marks). + */ + +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + +/* + * Since the Tcl/Tk distribution doesn't perform any asserts, + * dynamic loading can fail to find the __assert function. + * As a workaround, we'll include our own. + */ + +#undef assert +#define DEBUG 1 +#ifndef DEBUG +#define assert(EX) ((void)0) +#else +#define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0)) +#endif /* DEBUG */ + +#define ITCL_INTERP_DATA "itcl_data" +#define ITCL_TK_VERSION "8.6" + +/* + * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS + * sets up the declarations needed for the main macro, FOREACH_HASH, which + * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that + * only iterates over values. + */ + +#define FOREACH_HASH_DECLS \ + Tcl_HashEntry *hPtr;Tcl_HashSearch search +#define FOREACH_HASH(key,val,tablePtr) \ + for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ + ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\ + (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search)) +#define FOREACH_HASH_VALUE(val,tablePtr) \ + for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ + ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search)) + +/* + * What sort of size of things we like to allocate. + */ + +#define ALLOC_CHUNK 8 + +#define ITCL_VARIABLES_NAMESPACE "::itcl::internal::variables" +#define ITCL_COMMANDS_NAMESPACE "::itcl::internal::commands" + +#ifdef ITCL_PRESERVE_DEBUG +#define ITCL_PRESERVE_BUCKET_SIZE 50 +#define ITCL_PRESERVE_INCR 1 +#define ITCL_PRESERVE_DECR -1 +#define ITCL_PRESERVE_DELETED 0 + +typedef struct ItclPreserveInfoEntry { + int type; + int line; + const char * fileName; +} ItclPreserveInfoEntry; + +typedef struct ItclPreserveInfo { + size_t refCount; + ClientData clientData; + size_t size; + size_t numEntries; + ItclPreserveInfoEntry *entries; +} ItclPreserveInfo; + +#endif + + +typedef struct ItclFoundation { + Itcl_Stack methodCallStack; + Tcl_Command dispatchCommand; +} ItclFoundation; + +typedef struct ItclArgList { + struct ItclArgList *nextPtr; /* pointer to next argument */ + Tcl_Obj *namePtr; /* name of the argument */ + Tcl_Obj *defaultValuePtr; /* default value or NULL if none */ +} ItclArgList; + +/* + * Common info for managing all known objects. + * Each interpreter has one of these data structures stored as + * clientData in the "itcl" namespace. It is also accessible + * as associated data via the key ITCL_INTERP_DATA. + */ +struct ItclClass; +struct ItclObject; +struct ItclMemberFunc; +struct EnsembleInfo; +struct ItclDelegatedOption; +struct ItclDelegatedFunction; + +typedef struct ItclObjectInfo { + Tcl_Interp *interp; /* interpreter that manages this info */ + Tcl_HashTable objects; /* list of all known objects key is + * ioPtr */ + Tcl_HashTable objectCmds; /* list of known objects using accessCmd */ + Tcl_HashTable unused5; /* list of known objects using namePtr */ + Tcl_HashTable classes; /* list of all known classes, + * key is iclsPtr */ + Tcl_HashTable nameClasses; /* maps from fullNamePtr to iclsPtr */ + Tcl_HashTable namespaceClasses; /* maps from nsPtr to iclsPtr */ + Tcl_HashTable procMethods; /* maps from procPtr to mFunc */ + Tcl_HashTable instances; /* maps from instanceNumber to ioPtr */ + Tcl_HashTable unused8; /* maps from ioPtr to instanceNumber */ + Tcl_HashTable frameContext; /* maps frame to context stack */ + Tcl_HashTable classTypes; /* maps from class type i.e. "widget" + * to define value i.e. ITCL_WIDGET */ + int protection; /* protection level currently in effect */ + int useOldResolvers; /* whether to use the "old" style + * resolvers or the CallFrame resolvers */ + Itcl_Stack clsStack; /* stack of class definitions currently + * being parsed */ + Itcl_Stack unused; /* Removed */ + Itcl_Stack unused6; /* obsolete field */ + struct ItclObject *currIoPtr; /* object currently being constructed + * set only during calling of constructors + * otherwise NULL */ + Tcl_ObjectMetadataType *class_meta_type; + /* type for getting the Itcl class info + * from a TclOO Tcl_Object */ + const Tcl_ObjectMetadataType *object_meta_type; + /* type for getting the Itcl object info + * from a TclOO Tcl_Object */ + Tcl_Object unused1; /* the root object of Itcl */ + Tcl_Class clazzClassPtr; /* the root class of Itcl */ + struct EnsembleInfo *ensembleInfo; + struct ItclClass *currContextIclsPtr; + /* context class for delegated option + * handling */ + int currClassFlags; /* flags for the class just in creation */ + int buildingWidget; /* set if in construction of a widget */ + int unparsedObjc; /* number options not parsed by + ItclExtendedConfigure/-Cget function */ + Tcl_Obj **unparsedObjv; /* options not parsed by + ItclExtendedConfigure/-Cget function */ + int functionFlags; /* used for creating of ItclMemberCode */ + int unused7; /* used for having a unique key for objects + * for use in mytypemethod etc. */ + struct ItclDelegatedOption *currIdoPtr; + /* the current delegated option info */ + int inOptionHandling; /* used to indicate for type/widget ... + * that there is an option processing + * and methods are allowed to be called */ + /* these are the Tcl_Obj Ptrs for the clazz unknown procedure */ + /* need to store them to be able to free them at the end */ + int itclWidgetInitted; /* set to 1 if itclWidget.tcl has already + * been called + */ + int itclHullCmdsInitted; /* set to 1 if itclHullCmds.tcl has already + * been called + */ + Tcl_Obj *unused2; + Tcl_Obj *unused3; + Tcl_Obj *unused4; + Tcl_Obj *infoVarsPtr; + Tcl_Obj *infoVars3Ptr; + Tcl_Obj *infoVars4Ptr; + Tcl_Obj *typeDestructorArgumentPtr; + struct ItclObject *lastIoPtr; /* last object constructed */ + Tcl_Command infoCmd; +} ItclObjectInfo; + +typedef struct EnsembleInfo { + Tcl_HashTable ensembles; /* list of all known ensembles */ + Tcl_HashTable subEnsembles; /* list of all known subensembles */ + int numEnsembles; + Tcl_Namespace *ensembleNsPtr; +} EnsembleInfo; +/* + * Representation for each [incr Tcl] class. + */ +#define ITCL_CLASS 0x1 +#define ITCL_TYPE 0x2 +#define ITCL_WIDGET 0x4 +#define ITCL_WIDGETADAPTOR 0x8 +#define ITCL_ECLASS 0x10 +#define ITCL_NWIDGET 0x20 +#define ITCL_WIDGET_FRAME 0x40 +#define ITCL_WIDGET_LABEL_FRAME 0x80 +#define ITCL_WIDGET_TOPLEVEL 0x100 +#define ITCL_WIDGET_TTK_FRAME 0x200 +#define ITCL_WIDGET_TTK_LABEL_FRAME 0x400 +#define ITCL_WIDGET_TTK_TOPLEVEL 0x800 +#define ITCL_CLASS_IS_DELETED 0x1000 +#define ITCL_CLASS_IS_DESTROYED 0x2000 +#define ITCL_CLASS_NS_IS_DESTROYED 0x4000 +#define ITCL_CLASS_IS_RENAMED 0x8000 +#define ITCL_CLASS_IS_FREED 0x10000 +#define ITCL_CLASS_DERIVED_RELEASED 0x20000 +#define ITCL_CLASS_NS_TEARDOWN 0x40000 +#define ITCL_CLASS_NO_VARNS_DELETE 0x80000 +#define ITCL_CLASS_SHOULD_VARNS_DELETE 0x100000 +#define ITCL_CLASS_DESTRUCTOR_CALLED 0x400000 + + +typedef struct ItclClass { + Tcl_Obj *namePtr; /* class name */ + Tcl_Obj *fullNamePtr; /* fully qualified class name */ + Tcl_Interp *interp; /* interpreter that manages this info */ + Tcl_Namespace *nsPtr; /* namespace representing class scope */ + Tcl_Command accessCmd; /* access command for creating instances */ + Tcl_Command thisCmd; /* needed for deletion of class */ + + struct ItclObjectInfo *infoPtr; + /* info about all known objects + * and other stuff like stacks */ + Itcl_List bases; /* list of base classes */ + Itcl_List derived; /* list of all derived classes */ + Tcl_HashTable heritage; /* table of all base classes. Look up + * by pointer to class definition. This + * provides fast lookup for inheritance + * tests. */ + Tcl_Obj *initCode; /* initialization code for new objs */ + Tcl_HashTable variables; /* definitions for all data members + in this class. Look up simple string + names and get back ItclVariable* ptrs */ + Tcl_HashTable options; /* definitions for all option members + in this class. Look up simple string + names and get back ItclOption* ptrs */ + Tcl_HashTable components; /* definitions for all component members + in this class. Look up simple string + names and get back ItclComponent* ptrs */ + Tcl_HashTable functions; /* definitions for all member functions + in this class. Look up simple string + names and get back ItclMemberFunc* ptrs */ + Tcl_HashTable delegatedOptions; /* definitions for all delegated options + in this class. Look up simple string + names and get back + ItclDelegatedOption * ptrs */ + Tcl_HashTable delegatedFunctions; /* definitions for all delegated methods + or procs in this class. Look up simple + string names and get back + ItclDelegatedFunction * ptrs */ + Tcl_HashTable methodVariables; /* definitions for all methodvariable members + in this class. Look up simple string + names and get back + ItclMethodVariable* ptrs */ + int numInstanceVars; /* number of instance vars in variables + table */ + Tcl_HashTable classCommons; /* used for storing variable namespace + * string for Tcl_Resolve */ + Tcl_HashTable resolveVars; /* all possible names for variables in + * this class (e.g., x, foo::x, etc.) */ + Tcl_HashTable resolveCmds; /* all possible names for functions in + * this class (e.g., x, foo::x, etc.) */ + Tcl_HashTable contextCache; /* cache for function contexts */ + struct ItclMemberFunc *unused2; + /* the class constructor or NULL */ + struct ItclMemberFunc *unused3; + /* the class destructor or NULL */ + struct ItclMemberFunc *unused1; + Tcl_Resolve *resolvePtr; + Tcl_Obj *widgetClassPtr; /* class name for widget if class is a + * ::itcl::widget */ + Tcl_Obj *hullTypePtr; /* hulltype name for widget if class is a + * ::itcl::widget */ + Tcl_Object oPtr; /* TclOO class object */ + Tcl_Class clsPtr; /* TclOO class */ + int numCommons; /* number of commons in this class */ + int numVariables; /* number of variables in this class */ + int numOptions; /* number of options in this class */ + int unique; /* unique number for #auto generation */ + int flags; /* maintains class status */ + int callRefCount; /* prevent deleting of class if refcount>1 */ + Tcl_Obj *typeConstructorPtr; /* initialization for types */ + int destructorHasBeenCalled; /* prevent multiple invocations of destrcutor */ + int refCount; +} ItclClass; + +typedef struct ItclHierIter { + ItclClass *current; /* current position in hierarchy */ + Itcl_Stack stack; /* stack used for traversal */ +} ItclHierIter; + +#define ITCL_OBJECT_IS_DELETED 0x01 +#define ITCL_OBJECT_IS_DESTRUCTED 0x02 +#define ITCL_OBJECT_IS_DESTROYED 0x04 +#define ITCL_OBJECT_IS_RENAMED 0x08 +#define ITCL_OBJECT_CLASS_DESTRUCTED 0x10 +#define ITCL_TCLOO_OBJECT_IS_DELETED 0x20 +#define ITCL_OBJECT_DESTRUCT_ERROR 0x40 +#define ITCL_OBJECT_SHOULD_VARNS_DELETE 0x80 +#define ITCL_OBJECT_ROOT_METHOD 0x8000 + +/* + * Representation for each [incr Tcl] object. + */ +typedef struct ItclObject { + ItclClass *iclsPtr; /* most-specific class */ + Tcl_Command accessCmd; /* object access command */ + + Tcl_HashTable* constructed; /* temp storage used during construction */ + Tcl_HashTable* destructed; /* temp storage used during destruction */ + Tcl_HashTable objectVariables; + /* used for storing Tcl_Var entries for + * variable resolving, key is ivPtr of + * variable, value is varPtr */ + Tcl_HashTable objectOptions; /* definitions for all option members + in this object. Look up option namePtr + names and get back ItclOption* ptrs */ + Tcl_HashTable objectComponents; /* definitions for all component members + in this object. Look up component namePtr + names and get back ItclComponent* ptrs */ + Tcl_HashTable objectMethodVariables; + /* definitions for all methodvariable members + in this object. Look up methodvariable + namePtr names and get back + ItclMethodVariable* ptrs */ + Tcl_HashTable objectDelegatedOptions; + /* definitions for all delegated option + members in this object. Look up option + namePtr names and get back + ItclOption* ptrs */ + Tcl_HashTable objectDelegatedFunctions; + /* definitions for all delegated function + members in this object. Look up function + namePtr names and get back + ItclMemberFunc * ptrs */ + Tcl_HashTable contextCache; /* cache for function contexts */ + Tcl_Obj *namePtr; + Tcl_Obj *origNamePtr; /* the original name before any rename */ + Tcl_Obj *createNamePtr; /* the temp name before any rename + * mostly used for widgetadaptor + * because that hijackes the name + * often when installing the hull */ + Tcl_Interp *interp; + ItclObjectInfo *infoPtr; + Tcl_Obj *varNsNamePtr; + Tcl_Object oPtr; /* the TclOO object */ + Tcl_Resolve *resolvePtr; + int flags; + int callRefCount; /* prevent deleting of object if refcount > 1 */ + Tcl_Obj *hullWindowNamePtr; /* the window path name for the hull + * (before renaming in installhull) */ + int destructorHasBeenCalled; /* is set when the destructor is called + * to avoid callin destructor twice */ + int noComponentTrace; /* don't call component traces if + * setting components in DelegationInstall */ + int hadConstructorError; /* needed for multiple calls of CallItclObjectCmd */ + int refCount; +} ItclObject; + +#define ITCL_IGNORE_ERRS 0x002 /* useful for construction/destruction */ + +typedef struct ItclResolveInfo { + int flags; + ItclClass *iclsPtr; + ItclObject *ioPtr; +} ItclResolveInfo; + +#define ITCL_RESOLVE_CLASS 0x01 +#define ITCL_RESOLVE_OBJECT 0x02 + +/* + * Implementation for any code body in an [incr Tcl] class. + */ +typedef struct ItclMemberCode { + int flags; /* flags describing implementation */ + int argcount; /* number of args in arglist */ + int maxargcount; /* max number of args in arglist */ + Tcl_Obj *usagePtr; /* usage string for error messages */ + Tcl_Obj *argumentPtr; /* the function arguments */ + Tcl_Obj *bodyPtr; /* the function body */ + ItclArgList *argListPtr; /* the parsed arguments */ + union { + Tcl_CmdProc *argCmd; /* (argc,argv) C implementation */ + Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */ + } cfunc; + ClientData clientData; /* client data for C implementations */ +} ItclMemberCode; + +/* + * Flag bits for ItclMemberCode: + */ +#define ITCL_IMPLEMENT_NONE 0x001 /* no implementation */ +#define ITCL_IMPLEMENT_TCL 0x002 /* Tcl implementation */ +#define ITCL_IMPLEMENT_ARGCMD 0x004 /* (argc,argv) C implementation */ +#define ITCL_IMPLEMENT_OBJCMD 0x008 /* (objc,objv) C implementation */ +#define ITCL_IMPLEMENT_C 0x00c /* either kind of C implementation */ + +#define Itcl_IsMemberCodeImplemented(mcode) \ + (((mcode)->flags & ITCL_IMPLEMENT_NONE) == 0) + +/* + * Flag bits for ItclMember: functions and variables + */ +#define ITCL_COMMON 0x010 /* non-zero => is a "proc" or common + * variable */ + +/* + * Flag bits for ItclMember: functions + */ +#define ITCL_CONSTRUCTOR 0x020 /* non-zero => is a constructor */ +#define ITCL_DESTRUCTOR 0x040 /* non-zero => is a destructor */ +#define ITCL_ARG_SPEC 0x080 /* non-zero => has an argument spec */ +#define ITCL_BODY_SPEC 0x100 /* non-zero => has an body spec */ +#define ITCL_BUILTIN 0x400 /* non-zero => built-in method */ +#define ITCL_COMPONENT 0x800 /* non-zero => component */ +#define ITCL_TYPE_METHOD 0x1000 /* non-zero => typemethod */ +#define ITCL_METHOD 0x2000 /* non-zero => method */ + +/* + * Flag bits for ItclMember: variables + */ +#define ITCL_THIS_VAR 0x20 /* non-zero => built-in "this" variable */ +#define ITCL_OPTIONS_VAR 0x40 /* non-zero => built-in "itcl_options" + * variable */ +#define ITCL_TYPE_VAR 0x80 /* non-zero => built-in "type" variable */ + /* no longer used ??? */ +#define ITCL_SELF_VAR 0x100 /* non-zero => built-in "self" variable */ +#define ITCL_SELFNS_VAR 0x200 /* non-zero => built-in "selfns" + * variable */ +#define ITCL_WIN_VAR 0x400 /* non-zero => built-in "win" variable */ +#define ITCL_COMPONENT_VAR 0x800 /* non-zero => component variable */ +#define ITCL_HULL_VAR 0x1000 /* non-zero => built-in "itcl_hull" + * variable */ +#define ITCL_OPTION_READONLY 0x2000 /* non-zero => readonly */ +#define ITCL_VARIABLE 0x4000 /* non-zero => normal variable */ +#define ITCL_TYPE_VARIABLE 0x8000 /* non-zero => typevariable */ +#define ITCL_OPTION_INITTED 0x10000 /* non-zero => option has been initialized */ +#define ITCL_OPTION_COMP_VAR 0x20000 /* variable to collect option components of extendedclass */ + +/* + * Instance components. + */ +struct ItclVariable; +typedef struct ItclComponent { + Tcl_Obj *namePtr; /* member name */ + struct ItclVariable *ivPtr; /* variable for this component */ + int flags; + int haveKeptOptions; + Tcl_HashTable keptOptions; /* table of options to keep */ +} ItclComponent; + +#define ITCL_COMPONENT_INHERIT 0x01 +#define ITCL_COMPONENT_PUBLIC 0x02 + +typedef struct ItclDelegatedFunction { + Tcl_Obj *namePtr; + ItclComponent *icPtr; + Tcl_Obj *asPtr; + Tcl_Obj *usingPtr; + Tcl_HashTable exceptions; + int flags; +} ItclDelegatedFunction; + +/* + * Representation of member functions in an [incr Tcl] class. + */ +typedef struct ItclMemberFunc { + Tcl_Obj* namePtr; /* member name */ + Tcl_Obj* fullNamePtr; /* member name with "class::" qualifier */ + ItclClass* iclsPtr; /* class containing this member */ + int protection; /* protection level */ + int flags; /* flags describing member (see above) */ + ItclObjectInfo *infoPtr; + ItclMemberCode *codePtr; /* code associated with member */ + Tcl_Command accessCmd; /* Tcl command installed for this function */ + int argcount; /* number of args in arglist */ + int maxargcount; /* max number of args in arglist */ + Tcl_Obj *usagePtr; /* usage string for error messages */ + Tcl_Obj *argumentPtr; /* the function arguments */ + Tcl_Obj *builtinArgumentPtr; /* the function arguments for builtin functions */ + Tcl_Obj *origArgsPtr; /* the argument string of the original definition */ + Tcl_Obj *bodyPtr; /* the function body */ + ItclArgList *argListPtr; /* the parsed arguments */ + ItclClass *declaringClassPtr; /* the class which declared the method/proc */ + ClientData tmPtr; /* TclOO methodPtr */ + ItclDelegatedFunction *idmPtr; + /* if the function is delegated != NULL */ + int refCount; +} ItclMemberFunc; + +/* + * Instance variables. + */ +typedef struct ItclVariable { + Tcl_Obj *namePtr; /* member name */ + Tcl_Obj *fullNamePtr; /* member name with "class::" qualifier */ + ItclClass *iclsPtr; /* class containing this member */ + ItclObjectInfo *infoPtr; + ItclMemberCode *codePtr; /* code associated with member */ + Tcl_Obj *init; /* initial value */ + Tcl_Obj *arrayInitPtr; /* initial value if variable should be array */ + int protection; /* protection level */ + int flags; /* flags describing member (see below) */ + int initted; /* is set when first time initted, to check + * for example itcl_hull var, which can be only + * initialized once */ +} ItclVariable; + + +struct ItclOption; + +typedef struct ItclDelegatedOption { + Tcl_Obj *namePtr; + Tcl_Obj *resourceNamePtr; + Tcl_Obj *classNamePtr; + struct ItclOption *ioptPtr; /* the option name or null for "*" */ + ItclComponent *icPtr; /* the component where the delegation goes + * to */ + Tcl_Obj *asPtr; + Tcl_HashTable exceptions; /* exceptions from delegation */ +} ItclDelegatedOption; + +/* + * Instance options. + */ +typedef struct ItclOption { + /* within a class hierarchy there must be only + * one option with the same name !! */ + Tcl_Obj *namePtr; /* member name */ + Tcl_Obj *fullNamePtr; /* member name with "class::" qualifier */ + Tcl_Obj *resourceNamePtr; + Tcl_Obj *classNamePtr; + ItclClass *iclsPtr; /* class containing this member */ + int protection; /* protection level */ + int flags; /* flags describing member (see below) */ + ItclMemberCode *codePtr; /* code associated with member */ + Tcl_Obj *defaultValuePtr; /* initial value */ + Tcl_Obj *cgetMethodPtr; + Tcl_Obj *cgetMethodVarPtr; + Tcl_Obj *configureMethodPtr; + Tcl_Obj *configureMethodVarPtr; + Tcl_Obj *validateMethodPtr; + Tcl_Obj *validateMethodVarPtr; + ItclDelegatedOption *idoPtr; + /* if the option is delegated != NULL */ +} ItclOption; + +/* + * Instance methodvariables. + */ +typedef struct ItclMethodVariable { + Tcl_Obj *namePtr; /* member name */ + Tcl_Obj *fullNamePtr; /* member name with "class::" qualifier */ + ItclClass *iclsPtr; /* class containing this member */ + int protection; /* protection level */ + int flags; /* flags describing member (see below) */ + Tcl_Obj *defaultValuePtr; + Tcl_Obj *callbackPtr; +} ItclMethodVariable; + +#define VAR_TYPE_VARIABLE 1 +#define VAR_TYPE_COMMON 2 + +typedef struct ItclClassVarInfo { + int type; + int protection; + int varNum; + Tcl_Namespace *nsPtr; + Tcl_Namespace *declaringNsPtr; +} ItclClassVarInfo; + +#define CMD_TYPE_METHOD 1 +#define CMD_TYPE_PROC 2 + +typedef struct ItclClassCmdInfo { + int type; + int protection; + int cmdNum; + Tcl_Namespace *nsPtr; + Tcl_Namespace *declaringNsPtr; +} ItclClassCmdInfo; + +/* + * Instance variable lookup entry. + */ +typedef struct ItclVarLookup { + ItclVariable* ivPtr; /* variable definition */ + int usage; /* number of uses for this record */ + int accessible; /* non-zero => accessible from class with + * this lookup record in its resolveVars */ + char *leastQualName; /* simplist name for this variable, with + * the fewest qualifiers. This string is + * taken from the resolveVars table, so + * it shouldn't be freed. */ + int varNum; + ItclClassVarInfo *classVarInfoPtr; + Tcl_Var varPtr; +} ItclVarLookup; + +/* + * Instance command lookup entry. + */ +typedef struct ItclCmdLookup { + ItclMemberFunc* imPtr; /* function definition */ + int cmdNum; + ItclClassCmdInfo *classCmdInfoPtr; + Tcl_Command cmdPtr; +} ItclCmdLookup; + +typedef struct ItclCallContext { + int objectFlags; + Tcl_Namespace *nsPtr; + ItclObject *ioPtr; + ItclMemberFunc *imPtr; + int refCount; +} ItclCallContext; + +/* + * The macro below is used to modify a "char" value (e.g. by casting + * it to an unsigned character) so that it can be used safely with + * macros such as isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) +/* + * Macros used to cast between pointers and integers (e.g. when storing an int + * in ClientData), on 64-bit architectures they avoid gcc warning about "cast + * to/from pointer from/to integer of different size". + */ + +#if !defined(INT2PTR) && !defined(PTR2INT) +# if defined(HAVE_INTPTR_T) || defined(intptr_t) +# define INT2PTR(p) ((void*)(intptr_t)(p)) +# define PTR2INT(p) ((int)(intptr_t)(p)) +# else +# define INT2PTR(p) ((void*)(p)) +# define PTR2INT(p) ((int)(p)) +# endif +#endif + +#ifdef ITCL_DEBUG +MODULE_SCOPE int _itcl_debug_level; +MODULE_SCOPE void ItclShowArgs(int level, const char *str, int objc, + Tcl_Obj * const* objv); +#else +#define ItclShowArgs(a,b,c,d) +#endif + +MODULE_SCOPE Tcl_ObjCmdProc ItclCallCCommand; +MODULE_SCOPE Tcl_ObjCmdProc ItclObjectUnknownCommand; +MODULE_SCOPE int ItclCheckCallProc(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext contextPtr, Tcl_CallFrame *framePtr, int *isFinished); + +MODULE_SCOPE void ItclPreserveIMF(ItclMemberFunc *imPtr); +MODULE_SCOPE void ItclReleaseIMF(ClientData imPtr); + +MODULE_SCOPE void ItclPreserveClass(ItclClass *iclsPtr); +MODULE_SCOPE void ItclReleaseClass(ClientData iclsPtr); + +MODULE_SCOPE void ItclPreserveObject(ItclObject *ioPtr); +MODULE_SCOPE void ItclReleaseObject(ClientData ioPtr); + +MODULE_SCOPE ItclFoundation *ItclGetFoundation(Tcl_Interp *interp); +MODULE_SCOPE Tcl_ObjCmdProc ItclClassCommandDispatcher; +MODULE_SCOPE Tcl_Command Itcl_CmdAliasProc(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *cmdName, ClientData clientData); +MODULE_SCOPE Tcl_Var Itcl_VarAliasProc(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *VarName, ClientData clientData); +MODULE_SCOPE int ItclIsClass(Tcl_Interp *interp, Tcl_Command cmd); +MODULE_SCOPE int ItclCheckCallMethod(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext contextPtr, Tcl_CallFrame *framePtr, int *isFinished); +MODULE_SCOPE int ItclAfterCallMethod(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext contextPtr, Tcl_Namespace *nsPtr, int result); +MODULE_SCOPE void ItclReportObjectUsage(Tcl_Interp *interp, + ItclObject *contextIoPtr, Tcl_Namespace *callerNsPtr, + Tcl_Namespace *contextNsPtr); +MODULE_SCOPE int ItclMapMethodNameProc(Tcl_Interp *interp, Tcl_Object oPtr, + Tcl_Class *startClsPtr, Tcl_Obj *methodObj); +MODULE_SCOPE int ItclCreateArgList(Tcl_Interp *interp, const char *str, + int *argcPtr, int *maxArgcPtr, Tcl_Obj **usagePtr, + ItclArgList **arglistPtrPtr, ItclMemberFunc *imPtr, + const char *commandName); +MODULE_SCOPE int ItclObjectCmd(ClientData clientData, Tcl_Interp *interp, + Tcl_Object oPtr, Tcl_Class clsPtr, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int ItclCreateObject (Tcl_Interp *interp, const char* name, + ItclClass *iclsPtr, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE void ItclDeleteObjectVariablesNamespace(Tcl_Interp *interp, + ItclObject *ioPtr); +MODULE_SCOPE void ItclDeleteClassVariablesNamespace(Tcl_Interp *interp, + ItclClass *iclsPtr); +MODULE_SCOPE int ItclInfoInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr); + +struct Tcl_ResolvedVarInfo; +MODULE_SCOPE int Itcl_ClassCmdResolver(Tcl_Interp *interp, const char* name, + Tcl_Namespace *nsPtr, int flags, Tcl_Command *rPtr); +MODULE_SCOPE int Itcl_ClassVarResolver(Tcl_Interp *interp, const char* name, + Tcl_Namespace *nsPtr, int flags, Tcl_Var *rPtr); +MODULE_SCOPE int Itcl_ClassCompiledVarResolver(Tcl_Interp *interp, + const char* name, int length, Tcl_Namespace *nsPtr, + struct Tcl_ResolvedVarInfo **rPtr); +MODULE_SCOPE int Itcl_ClassCmdResolver2(Tcl_Interp *interp, const char* name, + Tcl_Namespace *nsPtr, int flags, Tcl_Command *rPtr); +MODULE_SCOPE int Itcl_ClassVarResolver2(Tcl_Interp *interp, const char* name, + Tcl_Namespace *nsPtr, int flags, Tcl_Var *rPtr); +MODULE_SCOPE int Itcl_ClassCompiledVarResolver2(Tcl_Interp *interp, + const char* name, int length, Tcl_Namespace *nsPtr, + struct Tcl_ResolvedVarInfo **rPtr); +MODULE_SCOPE int ItclSetParserResolver(Tcl_Namespace *nsPtr); +MODULE_SCOPE void ItclProcErrorProc(Tcl_Interp *interp, Tcl_Obj *procNameObj); +MODULE_SCOPE int Itcl_CreateOption (Tcl_Interp *interp, ItclClass *iclsPtr, + ItclOption *ioptPtr); +MODULE_SCOPE int Itcl_CreateMethodVariable (Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *name, Tcl_Obj *defaultPtr, + Tcl_Obj *callbackPtr, ItclMethodVariable **imvPtr); +MODULE_SCOPE int DelegationInstall(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr); +MODULE_SCOPE ItclClass *ItclNamespace2Class(Tcl_Namespace *nsPtr); +MODULE_SCOPE const char* ItclGetCommonInstanceVar(Tcl_Interp *interp, + const char *name, const char *name2, ItclObject *contextIoPtr, + ItclClass *contextIclsPtr); +MODULE_SCOPE int ItclCreateMethod(Tcl_Interp* interp, ItclClass *iclsPtr, + Tcl_Obj *namePtr, const char* arglist, const char* body, + ItclMemberFunc **imPtrPtr); +MODULE_SCOPE int Itcl_WidgetParseInit(Tcl_Interp *interp, + ItclObjectInfo *infoPtr); +MODULE_SCOPE void ItclDeleteObjectMetadata(ClientData clientData); +MODULE_SCOPE void ItclDeleteClassMetadata(ClientData clientData); +MODULE_SCOPE void ItclDeleteArgList(ItclArgList *arglistPtr); +MODULE_SCOPE int Itcl_ClassOptionCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int DelegatedOptionsInstall(Tcl_Interp *interp, + ItclClass *iclsPtr); +MODULE_SCOPE int Itcl_HandleDelegateOptionCmd(Tcl_Interp *interp, + ItclObject *ioPtr, ItclClass *iclsPtr, ItclDelegatedOption **idoPtrPtr, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Itcl_HandleDelegateMethodCmd(Tcl_Interp *interp, + ItclObject *ioPtr, ItclClass *iclsPtr, + ItclDelegatedFunction **idmPtrPtr, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int DelegateFunction(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr, Tcl_Obj *componentNamePtr, + ItclDelegatedFunction *idmPtr); +MODULE_SCOPE int ItclInitObjectMethodVariables(Tcl_Interp *interp, + ItclObject *ioPtr, ItclClass *iclsPtr, const char *name); +MODULE_SCOPE int InitTclOOFunctionPointers(Tcl_Interp *interp); +MODULE_SCOPE ItclOption* ItclNewOption(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr, Tcl_Obj *namePtr, const char *resourceName, + const char *className, char *init, ItclMemberCode *mCodePtr); +MODULE_SCOPE int ItclParseOption(ItclObjectInfo *infoPtr, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], ItclClass *iclsPtr, + ItclObject *ioPtr, ItclOption **ioptPtrPtr); +MODULE_SCOPE void ItclDestroyClassNamesp(ClientData cdata); +MODULE_SCOPE int ExpandDelegateAs(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr, ItclDelegatedFunction *idmPtr, + const char *funcName, Tcl_Obj *listPtr); +MODULE_SCOPE int ItclCheckForInitializedComponents(Tcl_Interp *interp, + ItclClass *iclsPtr, ItclObject *ioPtr); +MODULE_SCOPE int ItclCreateDelegatedFunction(Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *methodNamePtr, ItclComponent *icPtr, + Tcl_Obj *targetPtr, Tcl_Obj *usingPtr, Tcl_Obj *exceptionsPtr, + ItclDelegatedFunction **idmPtrPtr); +MODULE_SCOPE void ItclDeleteDelegatedOption(char *cdata); +MODULE_SCOPE void Itcl_FinishList(); +MODULE_SCOPE void ItclDeleteDelegatedFunction(ItclDelegatedFunction *idmPtr); +MODULE_SCOPE void ItclFinishEnsemble(ItclObjectInfo *infoPtr); +MODULE_SCOPE int Itcl_EnsembleDeleteCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int ItclAddClassesDictInfo(Tcl_Interp *interp, ItclClass *iclsPtr); +MODULE_SCOPE int ItclDeleteClassesDictInfo(Tcl_Interp *interp, + ItclClass *iclsPtr); +MODULE_SCOPE int ItclAddObjectsDictInfo(Tcl_Interp *interp, ItclObject *ioPtr); +MODULE_SCOPE int ItclDeleteObjectsDictInfo(Tcl_Interp *interp, + ItclObject *ioPtr); +MODULE_SCOPE int ItclAddOptionDictInfo(Tcl_Interp *interp, ItclClass *iclsPtr, + ItclOption *ioptPtr); +MODULE_SCOPE int ItclAddDelegatedOptionDictInfo(Tcl_Interp *interp, + ItclClass *iclsPtr, ItclDelegatedOption *idoPtr); +MODULE_SCOPE int ItclAddClassComponentDictInfo(Tcl_Interp *interp, + ItclClass *iclsPtr, ItclComponent *icPtr); +MODULE_SCOPE int ItclAddClassVariableDictInfo(Tcl_Interp *interp, + ItclClass *iclsPtr, ItclVariable *ivPtr); +MODULE_SCOPE int ItclAddClassFunctionDictInfo(Tcl_Interp *interp, + ItclClass *iclsPtr, ItclMemberFunc *imPtr); +MODULE_SCOPE int ItclAddClassDelegatedFunctionDictInfo(Tcl_Interp *interp, + ItclClass *iclsPtr, ItclDelegatedFunction *idmPtr); +MODULE_SCOPE int ItclClassCreateObject(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyProcCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiInstallComponentCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiCallInstanceCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiGetInstanceVarCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyTypeMethodCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyMethodCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyTypeVarCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyVarCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiItclHullCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_ThisCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_ExtendedClassCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_TypeClassCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_AddObjectOptionCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_AddDelegatedOptionCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_AddDelegatedFunctionCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_SetComponentCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_ClassHullTypeCmd; +MODULE_SCOPE Tcl_ObjCmdProc Itcl_ClassWidgetClassCmd; + +typedef int (ItclRootMethodProc)(ItclObject *ioPtr, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); + +MODULE_SCOPE const Tcl_MethodType itclRootMethodType; +MODULE_SCOPE ItclRootMethodProc ItclUnknownGuts; +MODULE_SCOPE ItclRootMethodProc ItclConstructGuts; +MODULE_SCOPE ItclRootMethodProc ItclInfoGuts; + +#include "itcl2TclOO.h" +#ifdef NEW_PROTO_RESOLVER +#include "itclVarsAndCmds.h" +#endif + +/* + * Include all the private API, generated from itcl.decls. + */ + +#include "itclIntDecls.h" diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclIntDecls.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclIntDecls.h new file mode 100644 index 0000000..5c68fb3 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclIntDecls.h @@ -0,0 +1,1046 @@ +/* + * This file is (mostly) automatically generated from itcl.decls. + */ + +#ifndef _ITCLINTDECLS +#define _ITCLINTDECLS + +/* !BEGIN!: Do not edit below this line. */ + +#define ITCLINT_STUBS_EPOCH 0 +#define ITCLINT_STUBS_REVISION 150 + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Exported function declarations: + */ + +/* 0 */ +ITCLAPI int Itcl_IsClassNamespace(Tcl_Namespace *namesp); +/* 1 */ +ITCLAPI int Itcl_IsClass(Tcl_Command cmd); +/* 2 */ +ITCLAPI ItclClass * Itcl_FindClass(Tcl_Interp *interp, const char *path, + int autoload); +/* 3 */ +ITCLAPI int Itcl_FindObject(Tcl_Interp *interp, const char *name, + ItclObject **roPtr); +/* 4 */ +ITCLAPI int Itcl_IsObject(Tcl_Command cmd); +/* 5 */ +ITCLAPI int Itcl_ObjectIsa(ItclObject *contextObj, + ItclClass *cdefn); +/* 6 */ +ITCLAPI int Itcl_Protection(Tcl_Interp *interp, int newLevel); +/* 7 */ +ITCLAPI const char * Itcl_ProtectionStr(int pLevel); +/* 8 */ +ITCLAPI int Itcl_CanAccess(ItclMemberFunc *memberPtr, + Tcl_Namespace *fromNsPtr); +/* 9 */ +ITCLAPI int Itcl_CanAccessFunc(ItclMemberFunc *mfunc, + Tcl_Namespace *fromNsPtr); +/* Slot 10 is reserved */ +/* 11 */ +ITCLAPI void Itcl_ParseNamespPath(const char *name, + Tcl_DString *buffer, const char **head, + const char **tail); +/* 12 */ +ITCLAPI int Itcl_DecodeScopedCommand(Tcl_Interp *interp, + const char *name, Tcl_Namespace **rNsPtr, + char **rCmdPtr); +/* 13 */ +ITCLAPI int Itcl_EvalArgs(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 14 */ +ITCLAPI Tcl_Obj * Itcl_CreateArgs(Tcl_Interp *interp, + const char *string, int objc, + Tcl_Obj *const objv[]); +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* 17 */ +ITCLAPI int Itcl_GetContext(Tcl_Interp *interp, + ItclClass **iclsPtrPtr, + ItclObject **ioPtrPtr); +/* 18 */ +ITCLAPI void Itcl_InitHierIter(ItclHierIter *iter, + ItclClass *iclsPtr); +/* 19 */ +ITCLAPI void Itcl_DeleteHierIter(ItclHierIter *iter); +/* 20 */ +ITCLAPI ItclClass * Itcl_AdvanceHierIter(ItclHierIter *iter); +/* 21 */ +ITCLAPI int Itcl_FindClassesCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 22 */ +ITCLAPI int Itcl_FindObjectsCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 23 is reserved */ +/* 24 */ +ITCLAPI int Itcl_DelClassCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 25 */ +ITCLAPI int Itcl_DelObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 26 */ +ITCLAPI int Itcl_ScopeCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 27 */ +ITCLAPI int Itcl_CodeCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 28 */ +ITCLAPI int Itcl_StubCreateCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 29 */ +ITCLAPI int Itcl_StubExistsCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 30 */ +ITCLAPI int Itcl_IsStub(Tcl_Command cmd); +/* 31 */ +ITCLAPI int Itcl_CreateClass(Tcl_Interp *interp, + const char *path, ItclObjectInfo *info, + ItclClass **rPtr); +/* 32 */ +ITCLAPI int Itcl_DeleteClass(Tcl_Interp *interp, + ItclClass *iclsPtr); +/* 33 */ +ITCLAPI Tcl_Namespace * Itcl_FindClassNamespace(Tcl_Interp *interp, + const char *path); +/* 34 */ +ITCLAPI int Itcl_HandleClass(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 35 is reserved */ +/* Slot 36 is reserved */ +/* Slot 37 is reserved */ +/* 38 */ +ITCLAPI void Itcl_BuildVirtualTables(ItclClass *iclsPtr); +/* 39 */ +ITCLAPI int Itcl_CreateVariable(Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *name, + char *init, char *config, + ItclVariable **ivPtr); +/* 40 */ +ITCLAPI void Itcl_DeleteVariable(char *cdata); +/* 41 */ +ITCLAPI const char * Itcl_GetCommonVar(Tcl_Interp *interp, + const char *name, ItclClass *contextClass); +/* Slot 42 is reserved */ +/* Slot 43 is reserved */ +/* 44 */ +ITCLAPI int Itcl_CreateObject(Tcl_Interp *interp, + const char*name, ItclClass *iclsPtr, + int objc, Tcl_Obj *const objv[], + ItclObject **rioPtr); +/* 45 */ +ITCLAPI int Itcl_DeleteObject(Tcl_Interp *interp, + ItclObject *contextObj); +/* 46 */ +ITCLAPI int Itcl_DestructObject(Tcl_Interp *interp, + ItclObject *contextObj, int flags); +/* Slot 47 is reserved */ +/* 48 */ +ITCLAPI const char * Itcl_GetInstanceVar(Tcl_Interp *interp, + const char *name, ItclObject *contextIoPtr, + ItclClass *contextIclsPtr); +/* Slot 49 is reserved */ +/* 50 */ +ITCLAPI int Itcl_BodyCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +/* 51 */ +ITCLAPI int Itcl_ConfigBodyCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 52 */ +ITCLAPI int Itcl_CreateMethod(Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *namePtr, + const char *arglist, const char *body); +/* 53 */ +ITCLAPI int Itcl_CreateProc(Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *namePtr, + const char *arglist, const char *body); +/* 54 */ +ITCLAPI int Itcl_CreateMemberFunc(Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *name, + const char *arglist, const char *body, + ItclMemberFunc **mfuncPtr); +/* 55 */ +ITCLAPI int Itcl_ChangeMemberFunc(Tcl_Interp *interp, + ItclMemberFunc *mfunc, const char *arglist, + const char *body); +/* 56 */ +ITCLAPI void Itcl_DeleteMemberFunc(char *cdata); +/* 57 */ +ITCLAPI int Itcl_CreateMemberCode(Tcl_Interp *interp, + ItclClass *iclsPtr, const char *arglist, + const char *body, ItclMemberCode **mcodePtr); +/* 58 */ +ITCLAPI void Itcl_DeleteMemberCode(char *cdata); +/* 59 */ +ITCLAPI int Itcl_GetMemberCode(Tcl_Interp *interp, + ItclMemberFunc *mfunc); +/* Slot 60 is reserved */ +/* 61 */ +ITCLAPI int Itcl_EvalMemberCode(Tcl_Interp *interp, + ItclMemberFunc *mfunc, + ItclObject *contextObj, int objc, + Tcl_Obj *const objv[]); +/* Slot 62 is reserved */ +/* Slot 63 is reserved */ +/* Slot 64 is reserved */ +/* Slot 65 is reserved */ +/* Slot 66 is reserved */ +/* 67 */ +ITCLAPI void Itcl_GetMemberFuncUsage(ItclMemberFunc *mfunc, + ItclObject *contextObj, Tcl_Obj *objPtr); +/* 68 */ +ITCLAPI int Itcl_ExecMethod(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 69 */ +ITCLAPI int Itcl_ExecProc(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 70 is reserved */ +/* 71 */ +ITCLAPI int Itcl_ConstructBase(Tcl_Interp *interp, + ItclObject *contextObj, + ItclClass *contextClass); +/* 72 */ +ITCLAPI int Itcl_InvokeMethodIfExists(Tcl_Interp *interp, + const char *name, ItclClass *contextClass, + ItclObject *contextObj, int objc, + Tcl_Obj *const objv[]); +/* Slot 73 is reserved */ +/* 74 */ +ITCLAPI int Itcl_ReportFuncErrors(Tcl_Interp *interp, + ItclMemberFunc *mfunc, + ItclObject *contextObj, int result); +/* 75 */ +ITCLAPI int Itcl_ParseInit(Tcl_Interp *interp, + ItclObjectInfo *info); +/* 76 */ +ITCLAPI int Itcl_ClassCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 77 */ +ITCLAPI int Itcl_ClassInheritCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 78 */ +ITCLAPI int Itcl_ClassProtectionCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 79 */ +ITCLAPI int Itcl_ClassConstructorCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 80 */ +ITCLAPI int Itcl_ClassDestructorCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 81 */ +ITCLAPI int Itcl_ClassMethodCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 82 */ +ITCLAPI int Itcl_ClassProcCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 83 */ +ITCLAPI int Itcl_ClassVariableCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 84 */ +ITCLAPI int Itcl_ClassCommonCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 85 */ +ITCLAPI int Itcl_ParseVarResolver(Tcl_Interp *interp, + const char *name, Tcl_Namespace *contextNs, + int flags, Tcl_Var *rPtr); +/* 86 */ +ITCLAPI int Itcl_BiInit(Tcl_Interp *interp, + ItclObjectInfo *infoPtr); +/* 87 */ +ITCLAPI int Itcl_InstallBiMethods(Tcl_Interp *interp, + ItclClass *cdefn); +/* 88 */ +ITCLAPI int Itcl_BiIsaCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 89 */ +ITCLAPI int Itcl_BiConfigureCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 90 */ +ITCLAPI int Itcl_BiCgetCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 91 */ +ITCLAPI int Itcl_BiChainCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +/* 92 */ +ITCLAPI int Itcl_BiInfoClassCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 93 */ +ITCLAPI int Itcl_BiInfoInheritCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 94 */ +ITCLAPI int Itcl_BiInfoHeritageCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 95 */ +ITCLAPI int Itcl_BiInfoFunctionCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 96 */ +ITCLAPI int Itcl_BiInfoVariableCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 97 */ +ITCLAPI int Itcl_BiInfoBodyCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 98 */ +ITCLAPI int Itcl_BiInfoArgsCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 99 is reserved */ +/* 100 */ +ITCLAPI int Itcl_EnsembleInit(Tcl_Interp *interp); +/* 101 */ +ITCLAPI int Itcl_CreateEnsemble(Tcl_Interp *interp, + const char *ensName); +/* 102 */ +ITCLAPI int Itcl_AddEnsemblePart(Tcl_Interp *interp, + const char *ensName, const char *partName, + const char *usageInfo, + Tcl_ObjCmdProc *objProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +/* 103 */ +ITCLAPI int Itcl_GetEnsemblePart(Tcl_Interp *interp, + const char *ensName, const char *partName, + Tcl_CmdInfo *infoPtr); +/* 104 */ +ITCLAPI int Itcl_IsEnsemble(Tcl_CmdInfo *infoPtr); +/* 105 */ +ITCLAPI int Itcl_GetEnsembleUsage(Tcl_Interp *interp, + const char *ensName, Tcl_Obj *objPtr); +/* 106 */ +ITCLAPI int Itcl_GetEnsembleUsageForObj(Tcl_Interp *interp, + Tcl_Obj *ensObjPtr, Tcl_Obj *objPtr); +/* 107 */ +ITCLAPI int Itcl_EnsembleCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 108 */ +ITCLAPI int Itcl_EnsPartCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 109 */ +ITCLAPI int Itcl_EnsembleErrorCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 110 is reserved */ +/* Slot 111 is reserved */ +/* Slot 112 is reserved */ +/* Slot 113 is reserved */ +/* Slot 114 is reserved */ +/* 115 */ +ITCLAPI void Itcl_Assert(const char *testExpr, + const char *fileName, int lineNum); +/* 116 */ +ITCLAPI int Itcl_IsObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 117 */ +ITCLAPI int Itcl_IsClassCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 118 is reserved */ +/* Slot 119 is reserved */ +/* Slot 120 is reserved */ +/* Slot 121 is reserved */ +/* Slot 122 is reserved */ +/* Slot 123 is reserved */ +/* Slot 124 is reserved */ +/* Slot 125 is reserved */ +/* Slot 126 is reserved */ +/* Slot 127 is reserved */ +/* Slot 128 is reserved */ +/* Slot 129 is reserved */ +/* Slot 130 is reserved */ +/* Slot 131 is reserved */ +/* Slot 132 is reserved */ +/* Slot 133 is reserved */ +/* Slot 134 is reserved */ +/* Slot 135 is reserved */ +/* Slot 136 is reserved */ +/* Slot 137 is reserved */ +/* Slot 138 is reserved */ +/* Slot 139 is reserved */ +/* 140 */ +ITCLAPI int Itcl_FilterAddCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 141 */ +ITCLAPI int Itcl_FilterDeleteCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 142 */ +ITCLAPI int Itcl_ForwardAddCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 143 */ +ITCLAPI int Itcl_ForwardDeleteCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 144 */ +ITCLAPI int Itcl_MixinAddCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 145 */ +ITCLAPI int Itcl_MixinDeleteCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* Slot 146 is reserved */ +/* Slot 147 is reserved */ +/* Slot 148 is reserved */ +/* Slot 149 is reserved */ +/* Slot 150 is reserved */ +/* 151 */ +ITCLAPI int Itcl_BiInfoUnknownCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 152 */ +ITCLAPI int Itcl_BiInfoVarsCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 153 */ +ITCLAPI int Itcl_CanAccess2(ItclClass *iclsPtr, int protection, + Tcl_Namespace *fromNsPtr); +/* Slot 154 is reserved */ +/* Slot 155 is reserved */ +/* Slot 156 is reserved */ +/* Slot 157 is reserved */ +/* Slot 158 is reserved */ +/* Slot 159 is reserved */ +/* 160 */ +ITCLAPI int Itcl_SetCallFrameResolver(Tcl_Interp *interp, + Tcl_Resolve *resolvePtr); +/* 161 */ +ITCLAPI int ItclEnsembleSubCmd(ClientData clientData, + Tcl_Interp *interp, const char *ensembleName, + int objc, Tcl_Obj *const *objv, + const char *functionName); +/* 162 */ +ITCLAPI Tcl_Namespace * Itcl_GetUplevelNamespace(Tcl_Interp *interp, + int level); +/* 163 */ +ITCLAPI ClientData Itcl_GetCallFrameClientData(Tcl_Interp *interp); +/* Slot 164 is reserved */ +/* 165 */ +ITCLAPI int Itcl_SetCallFrameNamespace(Tcl_Interp *interp, + Tcl_Namespace *nsPtr); +/* 166 */ +ITCLAPI int Itcl_GetCallFrameObjc(Tcl_Interp *interp); +/* 167 */ +ITCLAPI Tcl_Obj *const * Itcl_GetCallFrameObjv(Tcl_Interp *interp); +/* 168 */ +ITCLAPI int Itcl_NWidgetCmd(ClientData infoPtr, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 169 */ +ITCLAPI int Itcl_AddOptionCmd(ClientData infoPtr, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 170 */ +ITCLAPI int Itcl_AddComponentCmd(ClientData infoPtr, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 171 */ +ITCLAPI int Itcl_BiInfoOptionCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 172 */ +ITCLAPI int Itcl_BiInfoComponentCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +/* 173 */ +ITCLAPI int Itcl_RenameCommand(Tcl_Interp *interp, + const char *oldName, const char *newName); +/* 174 */ +ITCLAPI int Itcl_PushCallFrame(Tcl_Interp *interp, + Tcl_CallFrame *framePtr, + Tcl_Namespace *nsPtr, int isProcCallFrame); +/* 175 */ +ITCLAPI void Itcl_PopCallFrame(Tcl_Interp *interp); +/* 176 */ +ITCLAPI Tcl_CallFrame * Itcl_GetUplevelCallFrame(Tcl_Interp *interp, + int level); +/* 177 */ +ITCLAPI Tcl_CallFrame * Itcl_ActivateCallFrame(Tcl_Interp *interp, + Tcl_CallFrame *framePtr); +/* 178 */ +ITCLAPI const char* ItclSetInstanceVar(Tcl_Interp *interp, + const char *name, const char *name2, + const char *value, ItclObject *contextIoPtr, + ItclClass *contextIclsPtr); +/* 179 */ +ITCLAPI Tcl_Obj * ItclCapitalize(const char *str); +/* 180 */ +ITCLAPI int ItclClassBaseCmd(ClientData clientData, + Tcl_Interp *interp, int flags, int objc, + Tcl_Obj *const objv[], + ItclClass **iclsPtrPtr); +/* 181 */ +ITCLAPI int ItclCreateComponent(Tcl_Interp *interp, + ItclClass *iclsPtr, Tcl_Obj *componentPtr, + int type, ItclComponent **icPtrPtr); +/* 182 */ +ITCLAPI void Itcl_SetContext(Tcl_Interp *interp, + ItclObject *ioPtr); +/* 183 */ +ITCLAPI void Itcl_UnsetContext(Tcl_Interp *interp); +/* 184 */ +ITCLAPI const char * ItclGetInstanceVar(Tcl_Interp *interp, + const char *name, const char *name2, + ItclObject *ioPtr, ItclClass *iclsPtr); + +typedef struct ItclIntStubs { + int magic; + int epoch; + int revision; + void *hooks; + + int (*itcl_IsClassNamespace) (Tcl_Namespace *namesp); /* 0 */ + int (*itcl_IsClass) (Tcl_Command cmd); /* 1 */ + ItclClass * (*itcl_FindClass) (Tcl_Interp *interp, const char *path, int autoload); /* 2 */ + int (*itcl_FindObject) (Tcl_Interp *interp, const char *name, ItclObject **roPtr); /* 3 */ + int (*itcl_IsObject) (Tcl_Command cmd); /* 4 */ + int (*itcl_ObjectIsa) (ItclObject *contextObj, ItclClass *cdefn); /* 5 */ + int (*itcl_Protection) (Tcl_Interp *interp, int newLevel); /* 6 */ + const char * (*itcl_ProtectionStr) (int pLevel); /* 7 */ + int (*itcl_CanAccess) (ItclMemberFunc *memberPtr, Tcl_Namespace *fromNsPtr); /* 8 */ + int (*itcl_CanAccessFunc) (ItclMemberFunc *mfunc, Tcl_Namespace *fromNsPtr); /* 9 */ + void (*reserved10)(void); + void (*itcl_ParseNamespPath) (const char *name, Tcl_DString *buffer, const char **head, const char **tail); /* 11 */ + int (*itcl_DecodeScopedCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace **rNsPtr, char **rCmdPtr); /* 12 */ + int (*itcl_EvalArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 13 */ + Tcl_Obj * (*itcl_CreateArgs) (Tcl_Interp *interp, const char *string, int objc, Tcl_Obj *const objv[]); /* 14 */ + void (*reserved15)(void); + void (*reserved16)(void); + int (*itcl_GetContext) (Tcl_Interp *interp, ItclClass **iclsPtrPtr, ItclObject **ioPtrPtr); /* 17 */ + void (*itcl_InitHierIter) (ItclHierIter *iter, ItclClass *iclsPtr); /* 18 */ + void (*itcl_DeleteHierIter) (ItclHierIter *iter); /* 19 */ + ItclClass * (*itcl_AdvanceHierIter) (ItclHierIter *iter); /* 20 */ + int (*itcl_FindClassesCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 21 */ + int (*itcl_FindObjectsCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 22 */ + void (*reserved23)(void); + int (*itcl_DelClassCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 24 */ + int (*itcl_DelObjectCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 25 */ + int (*itcl_ScopeCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 26 */ + int (*itcl_CodeCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 27 */ + int (*itcl_StubCreateCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 28 */ + int (*itcl_StubExistsCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 29 */ + int (*itcl_IsStub) (Tcl_Command cmd); /* 30 */ + int (*itcl_CreateClass) (Tcl_Interp *interp, const char *path, ItclObjectInfo *info, ItclClass **rPtr); /* 31 */ + int (*itcl_DeleteClass) (Tcl_Interp *interp, ItclClass *iclsPtr); /* 32 */ + Tcl_Namespace * (*itcl_FindClassNamespace) (Tcl_Interp *interp, const char *path); /* 33 */ + int (*itcl_HandleClass) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 34 */ + void (*reserved35)(void); + void (*reserved36)(void); + void (*reserved37)(void); + void (*itcl_BuildVirtualTables) (ItclClass *iclsPtr); /* 38 */ + int (*itcl_CreateVariable) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *name, char *init, char *config, ItclVariable **ivPtr); /* 39 */ + void (*itcl_DeleteVariable) (char *cdata); /* 40 */ + const char * (*itcl_GetCommonVar) (Tcl_Interp *interp, const char *name, ItclClass *contextClass); /* 41 */ + void (*reserved42)(void); + void (*reserved43)(void); + int (*itcl_CreateObject) (Tcl_Interp *interp, const char*name, ItclClass *iclsPtr, int objc, Tcl_Obj *const objv[], ItclObject **rioPtr); /* 44 */ + int (*itcl_DeleteObject) (Tcl_Interp *interp, ItclObject *contextObj); /* 45 */ + int (*itcl_DestructObject) (Tcl_Interp *interp, ItclObject *contextObj, int flags); /* 46 */ + void (*reserved47)(void); + const char * (*itcl_GetInstanceVar) (Tcl_Interp *interp, const char *name, ItclObject *contextIoPtr, ItclClass *contextIclsPtr); /* 48 */ + void (*reserved49)(void); + int (*itcl_BodyCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 50 */ + int (*itcl_ConfigBodyCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 51 */ + int (*itcl_CreateMethod) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *namePtr, const char *arglist, const char *body); /* 52 */ + int (*itcl_CreateProc) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *namePtr, const char *arglist, const char *body); /* 53 */ + int (*itcl_CreateMemberFunc) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *name, const char *arglist, const char *body, ItclMemberFunc **mfuncPtr); /* 54 */ + int (*itcl_ChangeMemberFunc) (Tcl_Interp *interp, ItclMemberFunc *mfunc, const char *arglist, const char *body); /* 55 */ + void (*itcl_DeleteMemberFunc) (char *cdata); /* 56 */ + int (*itcl_CreateMemberCode) (Tcl_Interp *interp, ItclClass *iclsPtr, const char *arglist, const char *body, ItclMemberCode **mcodePtr); /* 57 */ + void (*itcl_DeleteMemberCode) (char *cdata); /* 58 */ + int (*itcl_GetMemberCode) (Tcl_Interp *interp, ItclMemberFunc *mfunc); /* 59 */ + void (*reserved60)(void); + int (*itcl_EvalMemberCode) (Tcl_Interp *interp, ItclMemberFunc *mfunc, ItclObject *contextObj, int objc, Tcl_Obj *const objv[]); /* 61 */ + void (*reserved62)(void); + void (*reserved63)(void); + void (*reserved64)(void); + void (*reserved65)(void); + void (*reserved66)(void); + void (*itcl_GetMemberFuncUsage) (ItclMemberFunc *mfunc, ItclObject *contextObj, Tcl_Obj *objPtr); /* 67 */ + int (*itcl_ExecMethod) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 68 */ + int (*itcl_ExecProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 69 */ + void (*reserved70)(void); + int (*itcl_ConstructBase) (Tcl_Interp *interp, ItclObject *contextObj, ItclClass *contextClass); /* 71 */ + int (*itcl_InvokeMethodIfExists) (Tcl_Interp *interp, const char *name, ItclClass *contextClass, ItclObject *contextObj, int objc, Tcl_Obj *const objv[]); /* 72 */ + void (*reserved73)(void); + int (*itcl_ReportFuncErrors) (Tcl_Interp *interp, ItclMemberFunc *mfunc, ItclObject *contextObj, int result); /* 74 */ + int (*itcl_ParseInit) (Tcl_Interp *interp, ItclObjectInfo *info); /* 75 */ + int (*itcl_ClassCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 76 */ + int (*itcl_ClassInheritCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 77 */ + int (*itcl_ClassProtectionCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 78 */ + int (*itcl_ClassConstructorCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 79 */ + int (*itcl_ClassDestructorCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 80 */ + int (*itcl_ClassMethodCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 81 */ + int (*itcl_ClassProcCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 82 */ + int (*itcl_ClassVariableCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 83 */ + int (*itcl_ClassCommonCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 84 */ + int (*itcl_ParseVarResolver) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNs, int flags, Tcl_Var *rPtr); /* 85 */ + int (*itcl_BiInit) (Tcl_Interp *interp, ItclObjectInfo *infoPtr); /* 86 */ + int (*itcl_InstallBiMethods) (Tcl_Interp *interp, ItclClass *cdefn); /* 87 */ + int (*itcl_BiIsaCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 88 */ + int (*itcl_BiConfigureCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 89 */ + int (*itcl_BiCgetCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 90 */ + int (*itcl_BiChainCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 91 */ + int (*itcl_BiInfoClassCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 92 */ + int (*itcl_BiInfoInheritCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 93 */ + int (*itcl_BiInfoHeritageCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 94 */ + int (*itcl_BiInfoFunctionCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 95 */ + int (*itcl_BiInfoVariableCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 96 */ + int (*itcl_BiInfoBodyCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 97 */ + int (*itcl_BiInfoArgsCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 98 */ + void (*reserved99)(void); + int (*itcl_EnsembleInit) (Tcl_Interp *interp); /* 100 */ + int (*itcl_CreateEnsemble) (Tcl_Interp *interp, const char *ensName); /* 101 */ + int (*itcl_AddEnsemblePart) (Tcl_Interp *interp, const char *ensName, const char *partName, const char *usageInfo, Tcl_ObjCmdProc *objProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 102 */ + int (*itcl_GetEnsemblePart) (Tcl_Interp *interp, const char *ensName, const char *partName, Tcl_CmdInfo *infoPtr); /* 103 */ + int (*itcl_IsEnsemble) (Tcl_CmdInfo *infoPtr); /* 104 */ + int (*itcl_GetEnsembleUsage) (Tcl_Interp *interp, const char *ensName, Tcl_Obj *objPtr); /* 105 */ + int (*itcl_GetEnsembleUsageForObj) (Tcl_Interp *interp, Tcl_Obj *ensObjPtr, Tcl_Obj *objPtr); /* 106 */ + int (*itcl_EnsembleCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 107 */ + int (*itcl_EnsPartCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 108 */ + int (*itcl_EnsembleErrorCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 109 */ + void (*reserved110)(void); + void (*reserved111)(void); + void (*reserved112)(void); + void (*reserved113)(void); + void (*reserved114)(void); + void (*itcl_Assert) (const char *testExpr, const char *fileName, int lineNum); /* 115 */ + int (*itcl_IsObjectCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 116 */ + int (*itcl_IsClassCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 117 */ + void (*reserved118)(void); + void (*reserved119)(void); + void (*reserved120)(void); + void (*reserved121)(void); + void (*reserved122)(void); + void (*reserved123)(void); + void (*reserved124)(void); + void (*reserved125)(void); + void (*reserved126)(void); + void (*reserved127)(void); + void (*reserved128)(void); + void (*reserved129)(void); + void (*reserved130)(void); + void (*reserved131)(void); + void (*reserved132)(void); + void (*reserved133)(void); + void (*reserved134)(void); + void (*reserved135)(void); + void (*reserved136)(void); + void (*reserved137)(void); + void (*reserved138)(void); + void (*reserved139)(void); + int (*itcl_FilterAddCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 140 */ + int (*itcl_FilterDeleteCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 141 */ + int (*itcl_ForwardAddCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 142 */ + int (*itcl_ForwardDeleteCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 143 */ + int (*itcl_MixinAddCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 144 */ + int (*itcl_MixinDeleteCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 145 */ + void (*reserved146)(void); + void (*reserved147)(void); + void (*reserved148)(void); + void (*reserved149)(void); + void (*reserved150)(void); + int (*itcl_BiInfoUnknownCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 151 */ + int (*itcl_BiInfoVarsCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 152 */ + int (*itcl_CanAccess2) (ItclClass *iclsPtr, int protection, Tcl_Namespace *fromNsPtr); /* 153 */ + void (*reserved154)(void); + void (*reserved155)(void); + void (*reserved156)(void); + void (*reserved157)(void); + void (*reserved158)(void); + void (*reserved159)(void); + int (*itcl_SetCallFrameResolver) (Tcl_Interp *interp, Tcl_Resolve *resolvePtr); /* 160 */ + int (*itclEnsembleSubCmd) (ClientData clientData, Tcl_Interp *interp, const char *ensembleName, int objc, Tcl_Obj *const *objv, const char *functionName); /* 161 */ + Tcl_Namespace * (*itcl_GetUplevelNamespace) (Tcl_Interp *interp, int level); /* 162 */ + ClientData (*itcl_GetCallFrameClientData) (Tcl_Interp *interp); /* 163 */ + void (*reserved164)(void); + int (*itcl_SetCallFrameNamespace) (Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 165 */ + int (*itcl_GetCallFrameObjc) (Tcl_Interp *interp); /* 166 */ + Tcl_Obj *const * (*itcl_GetCallFrameObjv) (Tcl_Interp *interp); /* 167 */ + int (*itcl_NWidgetCmd) (ClientData infoPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 168 */ + int (*itcl_AddOptionCmd) (ClientData infoPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 169 */ + int (*itcl_AddComponentCmd) (ClientData infoPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 170 */ + int (*itcl_BiInfoOptionCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 171 */ + int (*itcl_BiInfoComponentCmd) (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 172 */ + int (*itcl_RenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 173 */ + int (*itcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 174 */ + void (*itcl_PopCallFrame) (Tcl_Interp *interp); /* 175 */ + Tcl_CallFrame * (*itcl_GetUplevelCallFrame) (Tcl_Interp *interp, int level); /* 176 */ + Tcl_CallFrame * (*itcl_ActivateCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr); /* 177 */ + const char* (*itclSetInstanceVar) (Tcl_Interp *interp, const char *name, const char *name2, const char *value, ItclObject *contextIoPtr, ItclClass *contextIclsPtr); /* 178 */ + Tcl_Obj * (*itclCapitalize) (const char *str); /* 179 */ + int (*itclClassBaseCmd) (ClientData clientData, Tcl_Interp *interp, int flags, int objc, Tcl_Obj *const objv[], ItclClass **iclsPtrPtr); /* 180 */ + int (*itclCreateComponent) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *componentPtr, int type, ItclComponent **icPtrPtr); /* 181 */ + void (*itcl_SetContext) (Tcl_Interp *interp, ItclObject *ioPtr); /* 182 */ + void (*itcl_UnsetContext) (Tcl_Interp *interp); /* 183 */ + const char * (*itclGetInstanceVar) (Tcl_Interp *interp, const char *name, const char *name2, ItclObject *ioPtr, ItclClass *iclsPtr); /* 184 */ +} ItclIntStubs; + +extern const ItclIntStubs *itclIntStubsPtr; + +#ifdef __cplusplus +} +#endif + +#if defined(USE_ITCL_STUBS) + +/* + * Inline function declarations: + */ + +#define Itcl_IsClassNamespace \ + (itclIntStubsPtr->itcl_IsClassNamespace) /* 0 */ +#define Itcl_IsClass \ + (itclIntStubsPtr->itcl_IsClass) /* 1 */ +#define Itcl_FindClass \ + (itclIntStubsPtr->itcl_FindClass) /* 2 */ +#define Itcl_FindObject \ + (itclIntStubsPtr->itcl_FindObject) /* 3 */ +#define Itcl_IsObject \ + (itclIntStubsPtr->itcl_IsObject) /* 4 */ +#define Itcl_ObjectIsa \ + (itclIntStubsPtr->itcl_ObjectIsa) /* 5 */ +#define Itcl_Protection \ + (itclIntStubsPtr->itcl_Protection) /* 6 */ +#define Itcl_ProtectionStr \ + (itclIntStubsPtr->itcl_ProtectionStr) /* 7 */ +#define Itcl_CanAccess \ + (itclIntStubsPtr->itcl_CanAccess) /* 8 */ +#define Itcl_CanAccessFunc \ + (itclIntStubsPtr->itcl_CanAccessFunc) /* 9 */ +/* Slot 10 is reserved */ +#define Itcl_ParseNamespPath \ + (itclIntStubsPtr->itcl_ParseNamespPath) /* 11 */ +#define Itcl_DecodeScopedCommand \ + (itclIntStubsPtr->itcl_DecodeScopedCommand) /* 12 */ +#define Itcl_EvalArgs \ + (itclIntStubsPtr->itcl_EvalArgs) /* 13 */ +#define Itcl_CreateArgs \ + (itclIntStubsPtr->itcl_CreateArgs) /* 14 */ +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +#define Itcl_GetContext \ + (itclIntStubsPtr->itcl_GetContext) /* 17 */ +#define Itcl_InitHierIter \ + (itclIntStubsPtr->itcl_InitHierIter) /* 18 */ +#define Itcl_DeleteHierIter \ + (itclIntStubsPtr->itcl_DeleteHierIter) /* 19 */ +#define Itcl_AdvanceHierIter \ + (itclIntStubsPtr->itcl_AdvanceHierIter) /* 20 */ +#define Itcl_FindClassesCmd \ + (itclIntStubsPtr->itcl_FindClassesCmd) /* 21 */ +#define Itcl_FindObjectsCmd \ + (itclIntStubsPtr->itcl_FindObjectsCmd) /* 22 */ +/* Slot 23 is reserved */ +#define Itcl_DelClassCmd \ + (itclIntStubsPtr->itcl_DelClassCmd) /* 24 */ +#define Itcl_DelObjectCmd \ + (itclIntStubsPtr->itcl_DelObjectCmd) /* 25 */ +#define Itcl_ScopeCmd \ + (itclIntStubsPtr->itcl_ScopeCmd) /* 26 */ +#define Itcl_CodeCmd \ + (itclIntStubsPtr->itcl_CodeCmd) /* 27 */ +#define Itcl_StubCreateCmd \ + (itclIntStubsPtr->itcl_StubCreateCmd) /* 28 */ +#define Itcl_StubExistsCmd \ + (itclIntStubsPtr->itcl_StubExistsCmd) /* 29 */ +#define Itcl_IsStub \ + (itclIntStubsPtr->itcl_IsStub) /* 30 */ +#define Itcl_CreateClass \ + (itclIntStubsPtr->itcl_CreateClass) /* 31 */ +#define Itcl_DeleteClass \ + (itclIntStubsPtr->itcl_DeleteClass) /* 32 */ +#define Itcl_FindClassNamespace \ + (itclIntStubsPtr->itcl_FindClassNamespace) /* 33 */ +#define Itcl_HandleClass \ + (itclIntStubsPtr->itcl_HandleClass) /* 34 */ +/* Slot 35 is reserved */ +/* Slot 36 is reserved */ +/* Slot 37 is reserved */ +#define Itcl_BuildVirtualTables \ + (itclIntStubsPtr->itcl_BuildVirtualTables) /* 38 */ +#define Itcl_CreateVariable \ + (itclIntStubsPtr->itcl_CreateVariable) /* 39 */ +#define Itcl_DeleteVariable \ + (itclIntStubsPtr->itcl_DeleteVariable) /* 40 */ +#define Itcl_GetCommonVar \ + (itclIntStubsPtr->itcl_GetCommonVar) /* 41 */ +/* Slot 42 is reserved */ +/* Slot 43 is reserved */ +#define Itcl_CreateObject \ + (itclIntStubsPtr->itcl_CreateObject) /* 44 */ +#define Itcl_DeleteObject \ + (itclIntStubsPtr->itcl_DeleteObject) /* 45 */ +#define Itcl_DestructObject \ + (itclIntStubsPtr->itcl_DestructObject) /* 46 */ +/* Slot 47 is reserved */ +#define Itcl_GetInstanceVar \ + (itclIntStubsPtr->itcl_GetInstanceVar) /* 48 */ +/* Slot 49 is reserved */ +#define Itcl_BodyCmd \ + (itclIntStubsPtr->itcl_BodyCmd) /* 50 */ +#define Itcl_ConfigBodyCmd \ + (itclIntStubsPtr->itcl_ConfigBodyCmd) /* 51 */ +#define Itcl_CreateMethod \ + (itclIntStubsPtr->itcl_CreateMethod) /* 52 */ +#define Itcl_CreateProc \ + (itclIntStubsPtr->itcl_CreateProc) /* 53 */ +#define Itcl_CreateMemberFunc \ + (itclIntStubsPtr->itcl_CreateMemberFunc) /* 54 */ +#define Itcl_ChangeMemberFunc \ + (itclIntStubsPtr->itcl_ChangeMemberFunc) /* 55 */ +#define Itcl_DeleteMemberFunc \ + (itclIntStubsPtr->itcl_DeleteMemberFunc) /* 56 */ +#define Itcl_CreateMemberCode \ + (itclIntStubsPtr->itcl_CreateMemberCode) /* 57 */ +#define Itcl_DeleteMemberCode \ + (itclIntStubsPtr->itcl_DeleteMemberCode) /* 58 */ +#define Itcl_GetMemberCode \ + (itclIntStubsPtr->itcl_GetMemberCode) /* 59 */ +/* Slot 60 is reserved */ +#define Itcl_EvalMemberCode \ + (itclIntStubsPtr->itcl_EvalMemberCode) /* 61 */ +/* Slot 62 is reserved */ +/* Slot 63 is reserved */ +/* Slot 64 is reserved */ +/* Slot 65 is reserved */ +/* Slot 66 is reserved */ +#define Itcl_GetMemberFuncUsage \ + (itclIntStubsPtr->itcl_GetMemberFuncUsage) /* 67 */ +#define Itcl_ExecMethod \ + (itclIntStubsPtr->itcl_ExecMethod) /* 68 */ +#define Itcl_ExecProc \ + (itclIntStubsPtr->itcl_ExecProc) /* 69 */ +/* Slot 70 is reserved */ +#define Itcl_ConstructBase \ + (itclIntStubsPtr->itcl_ConstructBase) /* 71 */ +#define Itcl_InvokeMethodIfExists \ + (itclIntStubsPtr->itcl_InvokeMethodIfExists) /* 72 */ +/* Slot 73 is reserved */ +#define Itcl_ReportFuncErrors \ + (itclIntStubsPtr->itcl_ReportFuncErrors) /* 74 */ +#define Itcl_ParseInit \ + (itclIntStubsPtr->itcl_ParseInit) /* 75 */ +#define Itcl_ClassCmd \ + (itclIntStubsPtr->itcl_ClassCmd) /* 76 */ +#define Itcl_ClassInheritCmd \ + (itclIntStubsPtr->itcl_ClassInheritCmd) /* 77 */ +#define Itcl_ClassProtectionCmd \ + (itclIntStubsPtr->itcl_ClassProtectionCmd) /* 78 */ +#define Itcl_ClassConstructorCmd \ + (itclIntStubsPtr->itcl_ClassConstructorCmd) /* 79 */ +#define Itcl_ClassDestructorCmd \ + (itclIntStubsPtr->itcl_ClassDestructorCmd) /* 80 */ +#define Itcl_ClassMethodCmd \ + (itclIntStubsPtr->itcl_ClassMethodCmd) /* 81 */ +#define Itcl_ClassProcCmd \ + (itclIntStubsPtr->itcl_ClassProcCmd) /* 82 */ +#define Itcl_ClassVariableCmd \ + (itclIntStubsPtr->itcl_ClassVariableCmd) /* 83 */ +#define Itcl_ClassCommonCmd \ + (itclIntStubsPtr->itcl_ClassCommonCmd) /* 84 */ +#define Itcl_ParseVarResolver \ + (itclIntStubsPtr->itcl_ParseVarResolver) /* 85 */ +#define Itcl_BiInit \ + (itclIntStubsPtr->itcl_BiInit) /* 86 */ +#define Itcl_InstallBiMethods \ + (itclIntStubsPtr->itcl_InstallBiMethods) /* 87 */ +#define Itcl_BiIsaCmd \ + (itclIntStubsPtr->itcl_BiIsaCmd) /* 88 */ +#define Itcl_BiConfigureCmd \ + (itclIntStubsPtr->itcl_BiConfigureCmd) /* 89 */ +#define Itcl_BiCgetCmd \ + (itclIntStubsPtr->itcl_BiCgetCmd) /* 90 */ +#define Itcl_BiChainCmd \ + (itclIntStubsPtr->itcl_BiChainCmd) /* 91 */ +#define Itcl_BiInfoClassCmd \ + (itclIntStubsPtr->itcl_BiInfoClassCmd) /* 92 */ +#define Itcl_BiInfoInheritCmd \ + (itclIntStubsPtr->itcl_BiInfoInheritCmd) /* 93 */ +#define Itcl_BiInfoHeritageCmd \ + (itclIntStubsPtr->itcl_BiInfoHeritageCmd) /* 94 */ +#define Itcl_BiInfoFunctionCmd \ + (itclIntStubsPtr->itcl_BiInfoFunctionCmd) /* 95 */ +#define Itcl_BiInfoVariableCmd \ + (itclIntStubsPtr->itcl_BiInfoVariableCmd) /* 96 */ +#define Itcl_BiInfoBodyCmd \ + (itclIntStubsPtr->itcl_BiInfoBodyCmd) /* 97 */ +#define Itcl_BiInfoArgsCmd \ + (itclIntStubsPtr->itcl_BiInfoArgsCmd) /* 98 */ +/* Slot 99 is reserved */ +#define Itcl_EnsembleInit \ + (itclIntStubsPtr->itcl_EnsembleInit) /* 100 */ +#define Itcl_CreateEnsemble \ + (itclIntStubsPtr->itcl_CreateEnsemble) /* 101 */ +#define Itcl_AddEnsemblePart \ + (itclIntStubsPtr->itcl_AddEnsemblePart) /* 102 */ +#define Itcl_GetEnsemblePart \ + (itclIntStubsPtr->itcl_GetEnsemblePart) /* 103 */ +#define Itcl_IsEnsemble \ + (itclIntStubsPtr->itcl_IsEnsemble) /* 104 */ +#define Itcl_GetEnsembleUsage \ + (itclIntStubsPtr->itcl_GetEnsembleUsage) /* 105 */ +#define Itcl_GetEnsembleUsageForObj \ + (itclIntStubsPtr->itcl_GetEnsembleUsageForObj) /* 106 */ +#define Itcl_EnsembleCmd \ + (itclIntStubsPtr->itcl_EnsembleCmd) /* 107 */ +#define Itcl_EnsPartCmd \ + (itclIntStubsPtr->itcl_EnsPartCmd) /* 108 */ +#define Itcl_EnsembleErrorCmd \ + (itclIntStubsPtr->itcl_EnsembleErrorCmd) /* 109 */ +/* Slot 110 is reserved */ +/* Slot 111 is reserved */ +/* Slot 112 is reserved */ +/* Slot 113 is reserved */ +/* Slot 114 is reserved */ +#define Itcl_Assert \ + (itclIntStubsPtr->itcl_Assert) /* 115 */ +#define Itcl_IsObjectCmd \ + (itclIntStubsPtr->itcl_IsObjectCmd) /* 116 */ +#define Itcl_IsClassCmd \ + (itclIntStubsPtr->itcl_IsClassCmd) /* 117 */ +/* Slot 118 is reserved */ +/* Slot 119 is reserved */ +/* Slot 120 is reserved */ +/* Slot 121 is reserved */ +/* Slot 122 is reserved */ +/* Slot 123 is reserved */ +/* Slot 124 is reserved */ +/* Slot 125 is reserved */ +/* Slot 126 is reserved */ +/* Slot 127 is reserved */ +/* Slot 128 is reserved */ +/* Slot 129 is reserved */ +/* Slot 130 is reserved */ +/* Slot 131 is reserved */ +/* Slot 132 is reserved */ +/* Slot 133 is reserved */ +/* Slot 134 is reserved */ +/* Slot 135 is reserved */ +/* Slot 136 is reserved */ +/* Slot 137 is reserved */ +/* Slot 138 is reserved */ +/* Slot 139 is reserved */ +#define Itcl_FilterAddCmd \ + (itclIntStubsPtr->itcl_FilterAddCmd) /* 140 */ +#define Itcl_FilterDeleteCmd \ + (itclIntStubsPtr->itcl_FilterDeleteCmd) /* 141 */ +#define Itcl_ForwardAddCmd \ + (itclIntStubsPtr->itcl_ForwardAddCmd) /* 142 */ +#define Itcl_ForwardDeleteCmd \ + (itclIntStubsPtr->itcl_ForwardDeleteCmd) /* 143 */ +#define Itcl_MixinAddCmd \ + (itclIntStubsPtr->itcl_MixinAddCmd) /* 144 */ +#define Itcl_MixinDeleteCmd \ + (itclIntStubsPtr->itcl_MixinDeleteCmd) /* 145 */ +/* Slot 146 is reserved */ +/* Slot 147 is reserved */ +/* Slot 148 is reserved */ +/* Slot 149 is reserved */ +/* Slot 150 is reserved */ +#define Itcl_BiInfoUnknownCmd \ + (itclIntStubsPtr->itcl_BiInfoUnknownCmd) /* 151 */ +#define Itcl_BiInfoVarsCmd \ + (itclIntStubsPtr->itcl_BiInfoVarsCmd) /* 152 */ +#define Itcl_CanAccess2 \ + (itclIntStubsPtr->itcl_CanAccess2) /* 153 */ +/* Slot 154 is reserved */ +/* Slot 155 is reserved */ +/* Slot 156 is reserved */ +/* Slot 157 is reserved */ +/* Slot 158 is reserved */ +/* Slot 159 is reserved */ +#define Itcl_SetCallFrameResolver \ + (itclIntStubsPtr->itcl_SetCallFrameResolver) /* 160 */ +#define ItclEnsembleSubCmd \ + (itclIntStubsPtr->itclEnsembleSubCmd) /* 161 */ +#define Itcl_GetUplevelNamespace \ + (itclIntStubsPtr->itcl_GetUplevelNamespace) /* 162 */ +#define Itcl_GetCallFrameClientData \ + (itclIntStubsPtr->itcl_GetCallFrameClientData) /* 163 */ +/* Slot 164 is reserved */ +#define Itcl_SetCallFrameNamespace \ + (itclIntStubsPtr->itcl_SetCallFrameNamespace) /* 165 */ +#define Itcl_GetCallFrameObjc \ + (itclIntStubsPtr->itcl_GetCallFrameObjc) /* 166 */ +#define Itcl_GetCallFrameObjv \ + (itclIntStubsPtr->itcl_GetCallFrameObjv) /* 167 */ +#define Itcl_NWidgetCmd \ + (itclIntStubsPtr->itcl_NWidgetCmd) /* 168 */ +#define Itcl_AddOptionCmd \ + (itclIntStubsPtr->itcl_AddOptionCmd) /* 169 */ +#define Itcl_AddComponentCmd \ + (itclIntStubsPtr->itcl_AddComponentCmd) /* 170 */ +#define Itcl_BiInfoOptionCmd \ + (itclIntStubsPtr->itcl_BiInfoOptionCmd) /* 171 */ +#define Itcl_BiInfoComponentCmd \ + (itclIntStubsPtr->itcl_BiInfoComponentCmd) /* 172 */ +#define Itcl_RenameCommand \ + (itclIntStubsPtr->itcl_RenameCommand) /* 173 */ +#define Itcl_PushCallFrame \ + (itclIntStubsPtr->itcl_PushCallFrame) /* 174 */ +#define Itcl_PopCallFrame \ + (itclIntStubsPtr->itcl_PopCallFrame) /* 175 */ +#define Itcl_GetUplevelCallFrame \ + (itclIntStubsPtr->itcl_GetUplevelCallFrame) /* 176 */ +#define Itcl_ActivateCallFrame \ + (itclIntStubsPtr->itcl_ActivateCallFrame) /* 177 */ +#define ItclSetInstanceVar \ + (itclIntStubsPtr->itclSetInstanceVar) /* 178 */ +#define ItclCapitalize \ + (itclIntStubsPtr->itclCapitalize) /* 179 */ +#define ItclClassBaseCmd \ + (itclIntStubsPtr->itclClassBaseCmd) /* 180 */ +#define ItclCreateComponent \ + (itclIntStubsPtr->itclCreateComponent) /* 181 */ +#define Itcl_SetContext \ + (itclIntStubsPtr->itcl_SetContext) /* 182 */ +#define Itcl_UnsetContext \ + (itclIntStubsPtr->itcl_UnsetContext) /* 183 */ +#define ItclGetInstanceVar \ + (itclIntStubsPtr->itclGetInstanceVar) /* 184 */ + +#endif /* defined(USE_ITCL_STUBS) */ + +/* !END!: Do not edit above this line. */ + +#endif /* _ITCLINTDECLS */ diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclLinkage.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclLinkage.c new file mode 100644 index 0000000..b0e87d8 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclLinkage.c @@ -0,0 +1,326 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This part adds a mechanism for integrating C procedures into + * [incr Tcl] classes as methods and procs. Each C procedure must + * either be declared via Itcl_RegisterC() or dynamically loaded. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * These records store the pointers for all "RegisterC" functions. + */ +typedef struct ItclCfunc { + Tcl_CmdProc *argCmdProc; /* old-style (argc,argv) command handler */ + Tcl_ObjCmdProc *objCmdProc; /* new (objc,objv) command handler */ + ClientData clientData; /* client data passed into this function */ + Tcl_CmdDeleteProc *deleteProc; /* proc called to free clientData */ +} ItclCfunc; + +static Tcl_HashTable* ItclGetRegisteredProcs(Tcl_Interp *interp); +static void ItclFreeC(ClientData clientData, Tcl_Interp *interp); + + +/* + * ------------------------------------------------------------------------ + * Itcl_RegisterC() + * + * Used to associate a symbolic name with an (argc,argv) C procedure + * that handles a Tcl command. Procedures that are registered in this + * manner can be referenced in the body of an [incr Tcl] class + * definition to specify C procedures to acting as methods/procs. + * Usually invoked in an initialization routine for an extension, + * called out in Tcl_AppInit() at the start of an application. + * + * Each symbolic procedure can have an arbitrary client data value + * associated with it. This value is passed into the command + * handler whenever it is invoked. + * + * A symbolic procedure name can be used only once for a given style + * (arg/obj) handler. If the name is defined with an arg-style + * handler, it can be redefined with an obj-style handler; or if + * the name is defined with an obj-style handler, it can be redefined + * with an arg-style handler. In either case, any previous client + * data is discarded and the new client data is remembered. However, + * if a name is redefined to a different handler of the same style, + * this procedure returns an error. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in interp->result) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_RegisterC(interp, name, proc, clientData, deleteProc) + Tcl_Interp *interp; /* interpreter handling this registration */ + const char *name; /* symbolic name for procedure */ + Tcl_CmdProc *proc; /* procedure handling Tcl command */ + ClientData clientData; /* client data associated with proc */ + Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ +{ + int newEntry; + Tcl_HashEntry *entry; + Tcl_HashTable *procTable; + ItclCfunc *cfunc; + + /* + * Make sure that a proc was specified. + */ + if (!proc) { + Tcl_AppendResult(interp, "initialization error: null pointer for ", + "C procedure \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Add a new entry for the given procedure. If an entry with + * this name already exists, then make sure that it was defined + * with the same proc. + */ + procTable = ItclGetRegisteredProcs(interp); + entry = Tcl_CreateHashEntry(procTable, name, &newEntry); + if (!newEntry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) { + Tcl_AppendResult(interp, "initialization error: C procedure ", + "with name \"", name, "\" already defined", + (char*)NULL); + return TCL_ERROR; + } + + if (cfunc->deleteProc != NULL) { + (*cfunc->deleteProc)(cfunc->clientData); + } + } else { + cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc)); + cfunc->objCmdProc = NULL; + } + + cfunc->argCmdProc = proc; + cfunc->clientData = clientData; + cfunc->deleteProc = deleteProc; + + Tcl_SetHashValue(entry, (ClientData)cfunc); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_RegisterObjC() + * + * Used to associate a symbolic name with an (objc,objv) C procedure + * that handles a Tcl command. Procedures that are registered in this + * manner can be referenced in the body of an [incr Tcl] class + * definition to specify C procedures to acting as methods/procs. + * Usually invoked in an initialization routine for an extension, + * called out in Tcl_AppInit() at the start of an application. + * + * Each symbolic procedure can have an arbitrary client data value + * associated with it. This value is passed into the command + * handler whenever it is invoked. + * + * A symbolic procedure name can be used only once for a given style + * (arg/obj) handler. If the name is defined with an arg-style + * handler, it can be redefined with an obj-style handler; or if + * the name is defined with an obj-style handler, it can be redefined + * with an arg-style handler. In either case, any previous client + * data is discarded and the new client data is remembered. However, + * if a name is redefined to a different handler of the same style, + * this procedure returns an error. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in interp->result) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_RegisterObjC(interp, name, proc, clientData, deleteProc) + Tcl_Interp *interp; /* interpreter handling this registration */ + const char *name; /* symbolic name for procedure */ + Tcl_ObjCmdProc *proc; /* procedure handling Tcl command */ + ClientData clientData; /* client data associated with proc */ + Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ +{ + int newEntry; + Tcl_HashEntry *entry; + Tcl_HashTable *procTable; + ItclCfunc *cfunc; + + /* + * Make sure that a proc was specified. + */ + if (!proc) { + Tcl_AppendResult(interp, "initialization error: null pointer for ", + "C procedure \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Add a new entry for the given procedure. If an entry with + * this name already exists, then make sure that it was defined + * with the same proc. + */ + procTable = ItclGetRegisteredProcs(interp); + entry = Tcl_CreateHashEntry(procTable, name, &newEntry); + if (!newEntry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) { + Tcl_AppendResult(interp, "initialization error: C procedure ", + "with name \"", name, "\" already defined", + (char*)NULL); + return TCL_ERROR; + } + + if (cfunc->deleteProc != NULL) { + (*cfunc->deleteProc)(cfunc->clientData); + } + } + else { + cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc)); + cfunc->argCmdProc = NULL; + } + + cfunc->objCmdProc = proc; + cfunc->clientData = clientData; + cfunc->deleteProc = deleteProc; + + Tcl_SetHashValue(entry, (ClientData)cfunc); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindC() + * + * Used to query a C procedure via its symbolic name. Looks at the + * list of procedures registered previously by either Itcl_RegisterC + * or Itcl_RegisterObjC and returns pointers to the appropriate + * (argc,argv) or (objc,objv) handlers. Returns non-zero if the + * name is recognized and pointers are returned; returns zero + * otherwise. + * ------------------------------------------------------------------------ + */ +int +Itcl_FindC( + Tcl_Interp *interp, /* interpreter handling this registration */ + const char *name, /* symbolic name for procedure */ + Tcl_CmdProc **argProcPtr, /* returns (argc,argv) command handler */ + Tcl_ObjCmdProc **objProcPtr, /* returns (objc,objv) command handler */ + ClientData *cDataPtr) /* returns client data */ +{ + Tcl_HashEntry *entry; + Tcl_HashTable *procTable; + ItclCfunc *cfunc; + + *argProcPtr = NULL; /* assume info won't be found */ + *objProcPtr = NULL; + *cDataPtr = NULL; + + if (interp) { + procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, + "itcl_RegC", (Tcl_InterpDeleteProc**)NULL); + + if (procTable) { + entry = Tcl_FindHashEntry(procTable, name); + if (entry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + *argProcPtr = cfunc->argCmdProc; + *objProcPtr = cfunc->objCmdProc; + *cDataPtr = cfunc->clientData; + } + } + } + return (*argProcPtr != NULL || *objProcPtr != NULL); +} + + +/* + * ------------------------------------------------------------------------ + * ItclGetRegisteredProcs() + * + * Returns a pointer to a hash table containing the list of registered + * procs in the specified interpreter. If the hash table does not + * already exist, it is created. + * ------------------------------------------------------------------------ + */ +static Tcl_HashTable* +ItclGetRegisteredProcs(interp) + Tcl_Interp *interp; /* interpreter handling this registration */ +{ + Tcl_HashTable* procTable; + + /* + * If the registration table does not yet exist, then create it. + */ + procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC", + (Tcl_InterpDeleteProc**)NULL); + + if (!procTable) { + procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(procTable, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC, + (ClientData)procTable); + } + return procTable; +} + + +/* + * ------------------------------------------------------------------------ + * ItclFreeC() + * + * When an interpreter is deleted, this procedure is called to + * free up the associated data created by Itcl_RegisterC and + * Itcl_RegisterObjC. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeC(clientData, interp) + ClientData clientData; /* associated data */ + Tcl_Interp *interp; /* intepreter being deleted */ +{ + Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclCfunc *cfunc; + + entry = Tcl_FirstHashEntry(tablePtr, &place); + while (entry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + + if (cfunc->deleteProc != NULL) { + (*cfunc->deleteProc)(cfunc->clientData); + } + ckfree ( (char*)cfunc ); + entry = Tcl_NextHashEntry(&place); + } + + Tcl_DeleteHashTable(tablePtr); + ckfree((char*)tablePtr); +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclMethod.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclMethod.c new file mode 100644 index 0000000..e33e62b --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclMethod.c @@ -0,0 +1,2721 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle commands available within a class scope. + * In [incr Tcl], the term "method" is used for a procedure that has + * access to object-specific data, while the term "proc" is used for + * a procedure that has access only to common class data. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +static int EquivArgLists(Tcl_Interp *interp, ItclArgList *origArgs, + ItclArgList *realArgs); +static int ItclCreateMemberCode(Tcl_Interp* interp, ItclClass *iclsPtr, + const char* arglist, const char* body, ItclMemberCode** mcodePtr, + Tcl_Obj *namePtr, int flags); +static int ItclCreateMemberFunc(Tcl_Interp* interp, ItclClass *iclsPtr, + Tcl_Obj *namePtr, const char* arglist, const char* body, + ItclMemberFunc** imPtrPtr, int flags); + +void +ItclPreserveIMF( + ItclMemberFunc *imPtr) +{ + imPtr->refCount++; +} + +void +ItclReleaseIMF( + ClientData clientData) +{ + ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData; + + if (--imPtr->refCount == 0) { + Itcl_DeleteMemberFunc(clientData); + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_BodyCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::body" command to + * define or redefine the implementation for a class method/proc. + * Handles the following syntax: + * + * itcl::body <class>::<func> <arglist> <body> + * + * Looks for an existing class member function with the name <func>, + * and if found, tries to assign the implementation. If an argument + * list was specified in the original declaration, it must match + * <arglist> or an error is flagged. If <body> has the form "@name" + * then it is treated as a reference to a C handling procedure; + * otherwise, it is taken as a body of Tcl statements. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +static int +NRBodyCmd( + ClientData clientData, /* */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const *objv) /* argument objects */ +{ + Tcl_HashEntry *entry; + Tcl_DString buffer; + Tcl_Obj *objPtr; + ItclClass *iclsPtr; + ItclMemberFunc *imPtr; + const char *head; + const char *tail; + const char *token; + char *arglist; + char *body; + int status = TCL_OK; + + ItclShowArgs(2, "Itcl_BodyCmd", objc, objv); + if (objc != 4) { + token = Tcl_GetString(objv[0]); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + token, " class::func arglist body\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Parse the member name "namesp::namesp::class::func". + * Make sure that a class name was specified, and that the + * class exists. + */ + token = Tcl_GetString(objv[1]); + Itcl_ParseNamespPath(token, &buffer, &head, &tail); + + if (!head || *head == '\0') { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "missing class specifier for body declaration \"", token, "\"", + (char*)NULL); + status = TCL_ERROR; + goto bodyCmdDone; + } + + iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1); + if (iclsPtr == NULL) { + status = TCL_ERROR; + goto bodyCmdDone; + } + + /* + * Find the function and try to change its implementation. + * Note that command resolution table contains *all* functions, + * even those in a base class. Make sure that the class + * containing the method definition is the requested class. + */ + + imPtr = NULL; + objPtr = Tcl_NewStringObj(tail, -1); + entry = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (entry) { + ItclCmdLookup *clookup; + clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); + imPtr = clookup->imPtr; + if (imPtr->iclsPtr != iclsPtr) { + imPtr = NULL; + } + } + + if (imPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "function \"", tail, "\" is not defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + status = TCL_ERROR; + goto bodyCmdDone; + } + + arglist = Tcl_GetString(objv[2]); + body = Tcl_GetString(objv[3]); + + if (Itcl_ChangeMemberFunc(interp, imPtr, arglist, body) != TCL_OK) { + status = TCL_ERROR; + goto bodyCmdDone; + } + +bodyCmdDone: + Tcl_DStringFree(&buffer); + return status; +} + +/* ARGSUSED */ +int +Itcl_BodyCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRBodyCmd, clientData, objc, objv); +} + + + +/* + * ------------------------------------------------------------------------ + * Itcl_ConfigBodyCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::configbody" command + * to define or redefine the configuration code associated with a + * public variable. Handles the following syntax: + * + * itcl::configbody <class>::<publicVar> <body> + * + * Looks for an existing public variable with the name <publicVar>, + * and if found, tries to assign the implementation. If <body> has + * the form "@name" then it is treated as a reference to a C handling + * procedure; otherwise, it is taken as a body of Tcl statements. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +NRConfigBodyCmd( + ClientData dummy, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int status = TCL_OK; + + const char *head; + const char *tail; + const char *token; + Tcl_DString buffer; + ItclClass *iclsPtr; + ItclVarLookup *vlookup; + ItclVariable *ivPtr; + ItclMemberCode *mcode; + Tcl_HashEntry *entry; + + ItclShowArgs(2, "Itcl_ConfigBodyCmd", objc, objv); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "class::option body"); + return TCL_ERROR; + } + + /* + * Parse the member name "namesp::namesp::class::option". + * Make sure that a class name was specified, and that the + * class exists. + */ + token = Tcl_GetString(objv[1]); + Itcl_ParseNamespPath(token, &buffer, &head, &tail); + + if ((head == NULL) || (*head == '\0')) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "missing class specifier for body declaration \"", token, "\"", + (char*)NULL); + status = TCL_ERROR; + goto configBodyCmdDone; + } + + iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1); + if (iclsPtr == NULL) { + status = TCL_ERROR; + goto configBodyCmdDone; + } + + /* + * Find the variable and change its implementation. + * Note that variable resolution table has *all* variables, + * even those in a base class. Make sure that the class + * containing the variable definition is the requested class. + */ + vlookup = NULL; + entry = Tcl_FindHashEntry(&iclsPtr->resolveVars, tail); + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (vlookup->ivPtr->iclsPtr != iclsPtr) { + vlookup = NULL; + } + } + + if (vlookup == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "option \"", tail, "\" is not defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + status = TCL_ERROR; + goto configBodyCmdDone; + } + ivPtr = vlookup->ivPtr; + + if (ivPtr->protection != ITCL_PUBLIC) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "option \"", Tcl_GetString(ivPtr->fullNamePtr), + "\" is not a public configuration option", + (char*)NULL); + status = TCL_ERROR; + goto configBodyCmdDone; + } + + token = Tcl_GetString(objv[2]); + + if (Itcl_CreateMemberCode(interp, iclsPtr, (char*)NULL, token, + &mcode) != TCL_OK) { + status = TCL_ERROR; + goto configBodyCmdDone; + } + + Itcl_PreserveData((ClientData)mcode); + Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode); + + if (ivPtr->codePtr) { + Itcl_ReleaseData((ClientData)ivPtr->codePtr); + } + ivPtr->codePtr = mcode; + +configBodyCmdDone: + Tcl_DStringFree(&buffer); + return status; +} + +/* ARGSUSED */ +int +Itcl_ConfigBodyCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRConfigBodyCmd, clientData, objc, objv); +} + + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateMethod() + * + * Installs a method into the namespace associated with a class. + * If another command with the same name is already installed, then + * it is overwritten. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in the specified interp) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateMethod( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class definition */ + Tcl_Obj *namePtr, /* name of new method */ + const char* arglist, /* space-separated list of arg names */ + const char* body) /* body of commands for the method */ +{ + ItclMemberFunc *imPtr; + + return ItclCreateMethod(interp, iclsPtr, namePtr, arglist, body, &imPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclCreateMethod() + * + * Installs a method into the namespace associated with a class. + * If another command with the same name is already installed, then + * it is overwritten. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in the specified interp) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +ItclCreateMethod( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class definition */ + Tcl_Obj *namePtr, /* name of new method */ + const char* arglist, /* space-separated list of arg names */ + const char* body, /* body of commands for the method */ + ItclMemberFunc **imPtrPtr) +{ + ItclMemberFunc *imPtr; + + /* + * Make sure that the method name does not contain anything + * goofy like a "::" scope qualifier. + */ + if (strstr(Tcl_GetString(namePtr),"::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad method name \"", Tcl_GetString(namePtr), "\"", + (char*)NULL); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + + /* + * Create the method definition. + */ + if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, body, + &imPtr, 0) != TCL_OK) { + return TCL_ERROR; + } + + imPtr->flags |= ITCL_METHOD; + if (imPtrPtr != NULL) { + *imPtrPtr = imPtr; + } + ItclAddClassFunctionDictInfo(interp, iclsPtr, imPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateProc() + * + * Installs a class proc into the namespace associated with a class. + * If another command with the same name is already installed, then + * it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along + * with an error message in the specified interp) if anything goes + * wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateProc( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class definition */ + Tcl_Obj* namePtr, /* name of new proc */ + const char *arglist, /* space-separated list of arg names */ + const char *body) /* body of commands for the proc */ +{ + ItclMemberFunc *imPtr; + + /* + * Make sure that the proc name does not contain anything + * goofy like a "::" scope qualifier. + */ + if (strstr(Tcl_GetString(namePtr),"::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad proc name \"", Tcl_GetString(namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Create the proc definition. + */ + if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, + body, &imPtr, ITCL_COMMON) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Mark procs as "common". This distinguishes them from methods. + */ + imPtr->flags |= ITCL_COMMON; + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclCreateMemberFunc() + * + * Creates the data record representing a member function. This + * includes the argument list and the body of the function. If the + * body is of the form "@name", then it is treated as a label for + * a C procedure registered by Itcl_RegisterC(). + * + * If any errors are encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK, and "imPtr" returns a pointer to the new + * member function. + * ------------------------------------------------------------------------ + */ +static int +ItclCreateMemberFunc( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class definition */ + Tcl_Obj *namePtr, /* name of new member */ + const char* arglist, /* space-separated list of arg names */ + const char* body, /* body of commands for the method */ + ItclMemberFunc** imPtrPtr, /* returns: pointer to new method defn */ + int flags) +{ + int newEntry; + char *name; + ItclMemberFunc *imPtr; + ItclMemberCode *mcode; + Tcl_HashEntry *hPtr; + + /* + * Add the member function to the list of functions for + * the class. Make sure that a member function with the + * same name doesn't already exist. + */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->functions, (char *)namePtr, &newEntry); + if (!newEntry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(namePtr), "\" already defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Try to create the implementation for this command member. + */ + if (ItclCreateMemberCode(interp, iclsPtr, arglist, body, + &mcode, namePtr, flags) != TCL_OK) { + + Tcl_DeleteHashEntry(hPtr); + return TCL_ERROR; + } + + Itcl_PreserveData((ClientData)mcode); + Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode); + + /* + * Allocate a member function definition and return. + */ + imPtr = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc)); + memset(imPtr, 0, sizeof(ItclMemberFunc)); + imPtr->iclsPtr = iclsPtr; + imPtr->infoPtr = iclsPtr->infoPtr; + imPtr->protection = Itcl_Protection(interp, 0); + imPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(namePtr), -1); + Tcl_IncrRefCount(imPtr->namePtr); + imPtr->fullNamePtr = Tcl_NewStringObj( + Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_AppendToObj(imPtr->fullNamePtr, "::", 2); + Tcl_AppendToObj(imPtr->fullNamePtr, Tcl_GetString(namePtr), -1); + Tcl_IncrRefCount(imPtr->fullNamePtr); + if (arglist != NULL) { + imPtr->origArgsPtr = Tcl_NewStringObj(arglist, -1); + Tcl_IncrRefCount(imPtr->origArgsPtr); + } + imPtr->codePtr = mcode; + + if (imPtr->protection == ITCL_DEFAULT_PROTECT) { + imPtr->protection = ITCL_PUBLIC; + } + + imPtr->declaringClassPtr = iclsPtr; + + if (arglist) { + imPtr->flags |= ITCL_ARG_SPEC; + } + if (mcode->argListPtr) { + ItclCreateArgList(interp, arglist, &imPtr->argcount, + &imPtr->maxargcount, &imPtr->usagePtr, + &imPtr->argListPtr, imPtr, NULL); + Tcl_IncrRefCount(imPtr->usagePtr); + } + + name = Tcl_GetString(namePtr); + if ((body != NULL) && (body[0] == '@')) { + /* check for builtin cget isa and configure and mark them for + * use of a different arglist "args" for TclOO !! */ + imPtr->codePtr->flags |= ITCL_BUILTIN; + if (strcmp(name, "cget") == 0) { + } + if (strcmp(name, "configure") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "isa") == 0) { + } + if (strcmp(name, "createhull") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "keepcomponentoption") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "ignorecomponentoption") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "renamecomponentoption") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "addoptioncomponent") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "ignoreoptioncomponent") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "renameoptioncomponent") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "setupcomponent") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "itcl_initoptions") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "mytypemethod") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + imPtr->flags |= ITCL_COMMON; + } + if (strcmp(name, "mymethod") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "mytypevar") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + imPtr->flags |= ITCL_COMMON; + } + if (strcmp(name, "myvar") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "itcl_hull") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + imPtr->flags |= ITCL_COMPONENT; + } + if (strcmp(name, "callinstance") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "getinstancevar") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "myproc") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + imPtr->flags |= ITCL_COMMON; + } + if (strcmp(name, "installhull") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "destroy") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "installcomponent") == 0) { + imPtr->argcount = 0; + imPtr->maxargcount = -1; + } + if (strcmp(name, "info") == 0) { + imPtr->flags |= ITCL_COMMON; + } + } + if (strcmp(name, "constructor") == 0) { + /* + * REVISE mcode->bodyPtr here! + * Include a [my ItclConstructBase $iclsPtr] method call. + * Inherited from itcl::Root + */ + + Tcl_Obj *newBody = Tcl_NewStringObj("", -1); + Tcl_AppendToObj(newBody, + "[::info object namespace ${this}]::my ItclConstructBase ", -1); + Tcl_AppendObjToObj(newBody, iclsPtr->fullNamePtr); + Tcl_AppendToObj(newBody, "\n", -1); + + Tcl_AppendObjToObj(newBody, mcode->bodyPtr); + Tcl_DecrRefCount(mcode->bodyPtr); + mcode->bodyPtr = newBody; + Tcl_IncrRefCount(mcode->bodyPtr); + imPtr->flags |= ITCL_CONSTRUCTOR; + } + if (strcmp(name, "destructor") == 0) { + imPtr->flags |= ITCL_DESTRUCTOR; + } + + Tcl_SetHashValue(hPtr, (ClientData)imPtr); + imPtr->refCount = 1; + + *imPtrPtr = imPtr; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateMemberFunc() + * + * Creates the data record representing a member function. This + * includes the argument list and the body of the function. If the + * body is of the form "@name", then it is treated as a label for + * a C procedure registered by Itcl_RegisterC(). + * + * If any errors are encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK, and "imPtr" returns a pointer to the new + * member function. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateMemberFunc( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class definition */ + Tcl_Obj *namePtr, /* name of new member */ + const char* arglist, /* space-separated list of arg names */ + const char* body, /* body of commands for the method */ + ItclMemberFunc** imPtrPtr) /* returns: pointer to new method defn */ +{ + return ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, + body, imPtrPtr, 0); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ChangeMemberFunc() + * + * Modifies the data record representing a member function. This + * is usually the body of the function, but can include the argument + * list if it was not defined when the member was first created. + * If the body is of the form "@name", then it is treated as a label + * for a C procedure registered by Itcl_RegisterC(). + * + * If any errors are encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK, and "imPtr" returns a pointer to the new + * member function. + * ------------------------------------------------------------------------ + */ +int +Itcl_ChangeMemberFunc( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclMemberFunc* imPtr, /* command member being changed */ + const char* arglist, /* space-separated list of arg names */ + const char* body) /* body of commands for the method */ +{ + Tcl_HashEntry *hPtr; + ItclMemberCode *mcode = NULL; + int isNewEntry; + + /* + * Try to create the implementation for this command member. + */ + if (ItclCreateMemberCode(interp, imPtr->iclsPtr, + arglist, body, &mcode, imPtr->namePtr, 0) != TCL_OK) { + + return TCL_ERROR; + } + + /* + * If the argument list was defined when the function was + * created, compare the arg lists or usage strings to make sure + * that the interface is not being redefined. + */ + if ((imPtr->flags & ITCL_ARG_SPEC) != 0 && + (imPtr->argListPtr != NULL) && + !EquivArgLists(interp, imPtr->argListPtr, mcode->argListPtr)) { + const char *argsStr; + if (imPtr->origArgsPtr != NULL) { + argsStr = Tcl_GetString(imPtr->origArgsPtr); + } else { + argsStr = ""; + } + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "argument list changed for function \"", + Tcl_GetString(imPtr->fullNamePtr), "\": should be \"", + argsStr, "\"", + (char*)NULL); + + Itcl_DeleteMemberCode((char*)mcode); + return TCL_ERROR; + } + + if (imPtr->flags & ITCL_CONSTRUCTOR) { + /* + * REVISE mcode->bodyPtr here! + * Include a [my ItclConstructBase $iclsPtr] method call. + * Inherited from itcl::Root + */ + + Tcl_Obj *newBody = Tcl_NewStringObj("", -1); + Tcl_AppendToObj(newBody, + "[::info object namespace ${this}]::my ItclConstructBase ", -1); + Tcl_AppendObjToObj(newBody, imPtr->iclsPtr->fullNamePtr); + Tcl_AppendToObj(newBody, "\n", -1); + + Tcl_AppendObjToObj(newBody, mcode->bodyPtr); + Tcl_DecrRefCount(mcode->bodyPtr); + mcode->bodyPtr = newBody; + Tcl_IncrRefCount(mcode->bodyPtr); + } + + /* + * Free up the old implementation and install the new one. + */ + Itcl_PreserveData((ClientData)mcode); + Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode); + + Itcl_ReleaseData((ClientData)imPtr->codePtr); + imPtr->codePtr = mcode; + if (mcode->flags & ITCL_IMPLEMENT_TCL) { + ClientData pmPtr; + imPtr->tmPtr = (ClientData)Itcl_NewProcClassMethod(interp, + imPtr->iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, + ItclProcErrorProc, imPtr, imPtr->namePtr, mcode->argumentPtr, + mcode->bodyPtr, &pmPtr); + hPtr = Tcl_CreateHashEntry(&imPtr->iclsPtr->infoPtr->procMethods, + (char *)imPtr->tmPtr, &isNewEntry); + if (isNewEntry) { + Tcl_SetHashValue(hPtr, imPtr); + } + } + ItclAddClassFunctionDictInfo(interp, imPtr->iclsPtr, imPtr); + return TCL_OK; +} + +static const char * type_reserved_words [] = { + "type", + "self", + "selfns", + NULL +}; + +/* + * ------------------------------------------------------------------------ + * ItclCreateMemberCode() + * + * Creates the data record representing the implementation behind a + * class member function. This includes the argument list and the body + * of the function. If the body is of the form "@name", then it is + * treated as a label for a C procedure registered by Itcl_RegisterC(). + * + * The implementation is kept by the member function definition, and + * controlled by a preserve/release paradigm. That way, if it is in + * use while it is being redefined, it will stay around long enough + * to avoid a core dump. + * + * If any errors are encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK, and "mcodePtr" returns a pointer to the new + * implementation. + * ------------------------------------------------------------------------ + */ +static int +ItclCreateMemberCode( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class containing this member */ + const char* arglist, /* space-separated list of arg names */ + const char* body, /* body of commands for the method */ + ItclMemberCode** mcodePtr, /* returns: pointer to new implementation */ + Tcl_Obj *namePtr, + int flags) +{ + int argc; + int maxArgc; + Tcl_Obj *usagePtr; + ItclArgList *argListPtr; + ItclMemberCode *mcode; + const char **cPtrPtr; + int haveError; + + /* + * Allocate some space to hold the implementation. + */ + mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode)); + memset(mcode, 0, sizeof(ItclMemberCode)); + + if (arglist) { + if (ItclCreateArgList(interp, arglist, &argc, &maxArgc, &usagePtr, + &argListPtr, NULL, NULL) != TCL_OK) { + Itcl_DeleteMemberCode((char*)mcode); + return TCL_ERROR; + } + mcode->argcount = argc; + mcode->maxargcount = maxArgc; + mcode->argListPtr = argListPtr; + mcode->usagePtr = usagePtr; + Tcl_IncrRefCount(mcode->usagePtr); + mcode->argumentPtr = Tcl_NewStringObj((const char *)arglist, -1); + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + haveError = 0; + while (argListPtr != NULL) { + cPtrPtr = &type_reserved_words[0]; + while (*cPtrPtr != NULL) { + if ((argListPtr->namePtr != NULL) && + (strcmp(Tcl_GetString(argListPtr->namePtr), + *cPtrPtr) == 0)) { + haveError = 1; + } + if ((flags & ITCL_COMMON) != 0) { + if (! (iclsPtr->infoPtr->functionFlags & + ITCL_TYPE_METHOD)) { + haveError = 0; + } + } + if (haveError) { + const char *startStr = "method "; + if (iclsPtr->infoPtr->functionFlags & + ITCL_TYPE_METHOD) { + startStr = "typemethod "; + } + /* FIXME should use iclsPtr->infoPtr->functionFlags here */ + if ((namePtr != NULL) && + (strcmp(Tcl_GetString(namePtr), + "constructor") == 0)) { + startStr = ""; + } + Tcl_AppendResult(interp, startStr, + namePtr == NULL ? "??" : + Tcl_GetString(namePtr), + "'s arglist may not contain \"", + *cPtrPtr, "\" explicitly", NULL); + Itcl_DeleteMemberCode((char*)mcode); + return TCL_ERROR; + } + cPtrPtr++; + } + argListPtr = argListPtr->nextPtr; + } + } + Tcl_IncrRefCount(mcode->argumentPtr); + mcode->flags |= ITCL_ARG_SPEC; + } else { + argc = 0; + argListPtr = NULL; + } + + if (body) { + mcode->bodyPtr = Tcl_NewStringObj((const char *)body, -1); + } else { + mcode->bodyPtr = Tcl_NewStringObj((const char *)"", -1); + mcode->flags |= ITCL_IMPLEMENT_NONE; + } + Tcl_IncrRefCount(mcode->bodyPtr); + + /* + * If the body definition starts with '@', then treat the value + * as a symbolic name for a C procedure. + */ + if (body == NULL) { + /* No-op */ + } else { + if (*body == '@') { + Tcl_CmdProc *argCmdProc; + Tcl_ObjCmdProc *objCmdProc; + ClientData cdata; + int isDone; + + isDone = 0; + if (strcmp(body, "@itcl-builtin-cget") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-configure") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-isa") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-createhull") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-keepcomponentoption") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-ignorecomponentoption") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-renamecomponentoption") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-addoptioncomponent") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-ignoreoptioncomponent") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-renameoptioncomponent") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-setupcomponent") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-initoptions") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-mytypemethod") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-mymethod") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-myproc") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-mytypevar") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-myvar") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-itcl_hull") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-callinstance") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-getinstancevar") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-installhull") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-installcomponent") == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-destroy") == 0) { + isDone = 1; + } + if (strncmp(body, "@itcl-builtin-setget", 20) == 0) { + isDone = 1; + } + if (strcmp(body, "@itcl-builtin-classunknown") == 0) { + isDone = 1; + } + if (!isDone) { + if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, + &cdata)) { + Tcl_AppendResult(interp, + "no registered C procedure with name \"", + body+1, "\"", (char*)NULL); + Itcl_DeleteMemberCode((char*)mcode); + return TCL_ERROR; + } + + /* + * WARNING! WARNING! WARNING! + * This is a pretty dangerous approach. What's done here is + * to copy over the proc + clientData implementation that + * happens to be in place at the moment the method is + * (re-)defined. This denies any freedom for the clientData + * to be changed dynamically or for the implementation to + * shift from OBJCMD to ARGCMD or vice versa, which the + * Itcl_Register(Obj)C routines explicitly permit. The whole + * system also lacks any scheme to unregister. + */ + + if (objCmdProc != NULL) { + mcode->flags |= ITCL_IMPLEMENT_OBJCMD; + mcode->cfunc.objCmd = objCmdProc; + mcode->clientData = cdata; + } else { + if (argCmdProc != NULL) { + mcode->flags |= ITCL_IMPLEMENT_ARGCMD; + mcode->cfunc.argCmd = argCmdProc; + mcode->clientData = cdata; + } + } + } else { + mcode->flags |= ITCL_IMPLEMENT_TCL|ITCL_BUILTIN; + } + } else { + + /* + * Otherwise, treat the body as a chunk of Tcl code. + */ + mcode->flags |= ITCL_IMPLEMENT_TCL; + } + } + + *mcodePtr = mcode; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateMemberCode() + * + * Creates the data record representing the implementation behind a + * class member function. This includes the argument list and the body + * of the function. If the body is of the form "@name", then it is + * treated as a label for a C procedure registered by Itcl_RegisterC(). + * + * The implementation is kept by the member function definition, and + * controlled by a preserve/release paradigm. That way, if it is in + * use while it is being redefined, it will stay around long enough + * to avoid a core dump. + * + * If any errors are encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK, and "mcodePtr" returns a pointer to the new + * implementation. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateMemberCode( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclClass *iclsPtr, /* class containing this member */ + const char* arglist, /* space-separated list of arg names */ + const char* body, /* body of commands for the method */ + ItclMemberCode** mcodePtr) /* returns: pointer to new implementation */ +{ + return ItclCreateMemberCode(interp, iclsPtr, arglist, body, mcodePtr, + NULL, 0); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteMemberCode() + * + * Destroys all data associated with the given command implementation. + * Invoked automatically by Itcl_ReleaseData() when the implementation + * is no longer being used. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteMemberCode( + char* cdata) /* pointer to member code definition */ +{ + ItclMemberCode* mCodePtr; + + mCodePtr = (ItclMemberCode*)cdata; + if (mCodePtr == NULL) { + return; + } + if (mCodePtr->argListPtr != NULL) { + ItclDeleteArgList(mCodePtr->argListPtr); + } + if (mCodePtr->usagePtr != NULL) { + Tcl_DecrRefCount(mCodePtr->usagePtr); + } + if (mCodePtr->argumentPtr != NULL) { + Tcl_DecrRefCount(mCodePtr->argumentPtr); + } + if (mCodePtr->bodyPtr != NULL) { + Tcl_DecrRefCount(mCodePtr->bodyPtr); + } + /* do NOT free mCodePtr->bodyPtr here !! that is done in TclOO!! */ + ckfree((char*)mCodePtr); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_GetMemberCode() + * + * Makes sure that the implementation for an [incr Tcl] code body is + * ready to run. Note that a member function can be declared without + * being defined. The class definition may contain a declaration of + * the member function, but its body may be defined in a separate file. + * If an undefined function is encountered, this routine automatically + * attempts to autoload it. If the body is implemented via Tcl code, + * then it is compiled here as well. + * + * Returns TCL_ERROR (along with an error message in the interpreter) + * if an error is encountered, or if the implementation is not defined + * and cannot be autoloaded. Returns TCL_OK if implementation is + * ready to use. + * ------------------------------------------------------------------------ + */ +int +Itcl_GetMemberCode( + Tcl_Interp* interp, /* interpreter managing this action */ + ItclMemberFunc* imPtr) /* member containing code body */ +{ + int result; + ItclMemberCode *mcode = imPtr->codePtr; + assert(mcode != NULL); + + /* + * If the implementation has not yet been defined, try to + * autoload it now. + */ + + if (!Itcl_IsMemberCodeImplemented(mcode)) { + Tcl_DString buf; + + Tcl_DStringInit(&buf); + Tcl_DStringAppend(&buf, "::auto_load ", -1); + Tcl_DStringAppend(&buf, Tcl_GetString(imPtr->fullNamePtr), -1); + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); + Tcl_DStringFree(&buf); + if (result != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while autoloading code for \"%s\")", + Tcl_GetString(imPtr->fullNamePtr))); + return result; + } + Tcl_ResetResult(interp); /* get rid of 1/0 status */ + } + + /* + * If the implementation is still not available, then + * autoloading must have failed. + * + * TRICKY NOTE: If code has been autoloaded, then the + * old mcode pointer is probably invalid. Go back to + * the member and look at the current code pointer again. + */ + mcode = imPtr->codePtr; + assert(mcode != NULL); + + if (!Itcl_IsMemberCodeImplemented(mcode)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "member function \"", Tcl_GetString(imPtr->fullNamePtr), + "\" is not defined and cannot be autoloaded", + (char*)NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + + + +static int +CallItclObjectCmd( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Object oPtr; + ItclMemberFunc *imPtr = data[0]; + ItclObject *ioPtr = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + + ItclShowArgs(1, "CallItclObjectCmd", objc, objv); + if (ioPtr != NULL) { + ioPtr->hadConstructorError = 0; + } + if (imPtr->flags & (ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR)) { + oPtr = ioPtr->oPtr; + } else { + oPtr = NULL; + } + if (oPtr != NULL) { + result = ItclObjectCmd(imPtr, interp, oPtr, imPtr->iclsPtr->clsPtr, + objc, objv); + } else { + result = ItclObjectCmd(imPtr, interp, NULL, NULL, objc, objv); + } + if (result != TCL_OK) { + if (ioPtr != NULL && ioPtr->hadConstructorError == 0) { + /* we are in a constructor call and did not yet have an error */ + /* -1 means we are not in a constructor */ + ioPtr->hadConstructorError = 1; + } + } + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_EvalMemberCode() + * + * Used to execute an ItclMemberCode representation of a code + * fragment. This code may be a body of Tcl commands, or a C handler + * procedure. + * + * Executes the command with the given arguments (objc,objv) and + * returns an integer status code (TCL_OK/TCL_ERROR). Returns the + * result string or an error message in the interpreter. + * ------------------------------------------------------------------------ + */ + +int +Itcl_EvalMemberCode( + Tcl_Interp *interp, /* current interpreter */ + ItclMemberFunc *imPtr, /* member func, or NULL (for error messages) */ + ItclObject *contextIoPtr, /* object context, or NULL */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclMemberCode *mcode; + void *callbackPtr; + int result = TCL_OK; + int i; + + ItclShowArgs(1, "Itcl_EvalMemberCode", objc, objv); + /* + * If this code does not have an implementation yet, then + * try to autoload one. Also, if this is Tcl code, make sure + * that it's compiled and ready to use. + */ + if (Itcl_GetMemberCode(interp, imPtr) != TCL_OK) { + return TCL_ERROR; + } + mcode = imPtr->codePtr; + + /* + * Bump the reference count on this code, in case it is + * redefined or deleted during execution. + */ + Itcl_PreserveData((ClientData)mcode); + + if ((imPtr->flags & ITCL_DESTRUCTOR) && (contextIoPtr != NULL)) { + contextIoPtr->destructorHasBeenCalled = 1; + } + + /* + * Execute the code body... + */ + if (((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) || + ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0)) { + + if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) { + result = (*mcode->cfunc.objCmd)(mcode->clientData, + interp, objc, objv); + } else { + if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) { + char **argv; + argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) ); + for (i=0; i < objc; i++) { + argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); + } + + result = (*mcode->cfunc.argCmd)(mcode->clientData, + interp, objc, (const char **)argv); + + ckfree((char*)argv); + } + } + } else { + if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + Tcl_NRAddCallback(interp, CallItclObjectCmd, imPtr, contextIoPtr, + INT2PTR(objc), (void *)objv); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + } + } + + Itcl_ReleaseData((ClientData)mcode); + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclEquivArgLists() + * + * Compares two argument lists to see if they are equivalent. The + * first list is treated as a prototype, and the second list must + * match it. Argument names may be different, but they must match in + * meaning. If one argument is optional, the corresponding argument + * must also be optional. If the prototype list ends with the magic + * "args" argument, then it matches everything in the other list. + * + * Returns non-zero if the argument lists are equivalent. + * ------------------------------------------------------------------------ + */ + +static int +EquivArgLists( + Tcl_Interp *interp, + ItclArgList *origArgs, + ItclArgList *realArgs) +{ + ItclArgList *currPtr; + char *argName; + + for (currPtr=origArgs; currPtr != NULL; currPtr=currPtr->nextPtr) { + if ((realArgs != NULL) && (realArgs->namePtr == NULL)) { + if (currPtr->namePtr != NULL) { + if (strcmp(Tcl_GetString(currPtr->namePtr), "args") != 0) { + /* the definition has more arguments */ + return 0; + } + } + } + if (realArgs == NULL) { + if (currPtr->defaultValuePtr != NULL) { + /* default args must be there ! */ + return 0; + } + if (currPtr->namePtr != NULL) { + if (strcmp(Tcl_GetString(currPtr->namePtr), "args") != 0) { + /* the definition has more arguments */ + return 0; + } + } + return 1; + } + if (currPtr->namePtr == NULL) { + /* no args defined */ + if (realArgs->namePtr != NULL) { + return 0; + } + return 1; + } + argName = Tcl_GetString(currPtr->namePtr); + if (strcmp(argName, "args") == 0) { + if (currPtr->nextPtr == NULL) { + /* this is the last arument */ + return 1; + } + } + if (currPtr->defaultValuePtr != NULL) { + if (realArgs->defaultValuePtr != NULL) { + /* default values must be the same */ + if (strcmp(Tcl_GetString(currPtr->defaultValuePtr), + Tcl_GetString(realArgs->defaultValuePtr)) != 0) { + return 0; + } + } + } + realArgs = realArgs->nextPtr; + } + if ((currPtr == NULL) && (realArgs != NULL)) { + /* new definition has more args then the old one */ + return 0; + } + return 1; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_GetContext() + * + * Convenience routine for looking up the current object/class context. + * Useful in implementing methods/procs to see what class, and perhaps + * what object, is active. + * + * Returns TCL_OK if the current namespace is a class namespace. + * Also returns pointers to the class definition, and to object + * data if an object context is active. Returns TCL_ERROR (along + * with an error message in the interpreter) if a class namespace + * is not active. + * ------------------------------------------------------------------------ + */ + +void +Itcl_SetContext( + Tcl_Interp *interp, + ItclObject *ioPtr) +{ + int new; + Itcl_Stack *stackPtr; + Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0); + ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, + (char *)framePtr, &new); + ItclCallContext *contextPtr + = (ItclCallContext *) ckalloc(sizeof(ItclCallContext)); + + memset(contextPtr, 0, sizeof(ItclCallContext)); + contextPtr->ioPtr = ioPtr; + contextPtr->refCount = 1; + + if (!new) { + Tcl_Panic("frame already has context?!"); + } + + stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack)); + Itcl_InitStack(stackPtr); + Tcl_SetHashValue(hPtr, stackPtr); + + Itcl_PushStack(contextPtr, stackPtr); +} + +void +Itcl_UnsetContext( + Tcl_Interp *interp) +{ + Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0); + ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, + (char *)framePtr); + Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); + ItclCallContext *contextPtr = Itcl_PopStack(stackPtr); + + if (Itcl_GetStackSize(stackPtr) > 0) { + Tcl_Panic("frame context stack not empty!"); + } + Itcl_DeleteStack(stackPtr); + ckfree((char *) stackPtr); + Tcl_DeleteHashEntry(hPtr); + if (--contextPtr->refCount) { + Tcl_Panic("frame context ref count not zero!"); + } + ckfree((char *)contextPtr); +} + +int +Itcl_GetContext( + Tcl_Interp *interp, /* current interpreter */ + ItclClass **iclsPtrPtr, /* returns: class definition or NULL */ + ItclObject **ioPtrPtr) /* returns: object data or NULL */ +{ + Tcl_Namespace *nsPtr; + + /* Fetch the current call frame. That determines context. */ + Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0); + + /* Try to map it to a context stack. */ + ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, + (char *)framePtr); + if (hPtr) { + /* Frame maps to a context stack. */ + Itcl_Stack *stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); + ItclCallContext *contextPtr = Itcl_PeekStack(stackPtr); + + assert(contextPtr); + + if (contextPtr->objectFlags & ITCL_OBJECT_ROOT_METHOD) { + ItclObject *ioPtr = contextPtr->ioPtr; + + *iclsPtrPtr = ioPtr->iclsPtr; + *ioPtrPtr = ioPtr; + return TCL_OK; + } + + *iclsPtrPtr = contextPtr->imPtr ? contextPtr->imPtr->iclsPtr + : contextPtr->ioPtr->iclsPtr; + *ioPtrPtr = contextPtr->ioPtr ? contextPtr->ioPtr : infoPtr->currIoPtr; + return TCL_OK; + } + + /* Frame has no Itcl context data. No way to get object context. */ + *ioPtrPtr = NULL; + + /* Fall back to namespace for possible class context info. */ + nsPtr = Tcl_GetCurrentNamespace(interp); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr) { + *iclsPtrPtr = (ItclClass *)Tcl_GetHashValue(hPtr); + return TCL_OK; + } + + /* Cannot get any context. Record an error message. */ + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" is not a class namespace", nsPtr->fullName)); + } + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_GetMemberFuncUsage() + * + * Returns a string showing how a command member should be invoked. + * If the command member is a method, then the specified object name + * is reported as part of the invocation path: + * + * obj method arg ?arg arg ...? + * + * Otherwise, the "obj" pointer is ignored, and the class name is + * used as the invocation path: + * + * class::proc arg ?arg arg ...? + * + * Returns the string by appending it onto the Tcl_Obj passed in as + * an argument. + * ------------------------------------------------------------------------ + */ +void +Itcl_GetMemberFuncUsage( + ItclMemberFunc *imPtr, /* command member being examined */ + ItclObject *contextIoPtr, /* invoked with respect to this object */ + Tcl_Obj *objPtr) /* returns: string showing usage */ +{ + Tcl_HashEntry *entry; + ItclMemberFunc *mf; + ItclClass *iclsPtr; + char *name; + char *arglist; + + /* + * If the command is a method and an object context was + * specified, then add the object context. If the method + * was a constructor, and if the object is being created, + * then report the invocation via the class creation command. + */ + if ((imPtr->flags & ITCL_COMMON) == 0) { + if ((imPtr->flags & ITCL_CONSTRUCTOR) != 0 && + contextIoPtr->constructed) { + + iclsPtr = (ItclClass*)contextIoPtr->iclsPtr; + mf = NULL; + objPtr = Tcl_NewStringObj("constructor", -1); + entry = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (entry) { + ItclCmdLookup *clookup; + clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); + mf = clookup->imPtr; + } + + if (mf == imPtr) { + Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp, + contextIoPtr->iclsPtr->accessCmd, objPtr); + Tcl_AppendToObj(objPtr, " ", -1); + name = (char *) Tcl_GetCommandName( + contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd); + Tcl_AppendToObj(objPtr, name, -1); + } else { + Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1); + } + } else { + if (contextIoPtr && contextIoPtr->accessCmd) { + name = (char *) Tcl_GetCommandName( + contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd); + Tcl_AppendStringsToObj(objPtr, name, " ", + Tcl_GetString(imPtr->namePtr), (char*)NULL); + } else { + Tcl_AppendStringsToObj(objPtr, "<object> ", + Tcl_GetString(imPtr->namePtr), (char*)NULL); + } + } + } else { + Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1); + } + + /* + * Add the argument usage info. + */ + if (imPtr->codePtr) { + if (imPtr->codePtr->usagePtr != NULL) { + arglist = Tcl_GetString(imPtr->codePtr->usagePtr); + } else { + arglist = NULL; + } + } else { + if (imPtr->argListPtr != NULL) { + arglist = Tcl_GetString(imPtr->usagePtr); + } else { + arglist = NULL; + } + } + if (arglist) { + if (strlen(arglist) > 0) { + Tcl_AppendToObj(objPtr, " ", -1); + Tcl_AppendToObj(objPtr, arglist, -1); + } + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ExecMethod() + * + * Invoked by Tcl to handle the execution of a user-defined method. + * A method is similar to the usual Tcl proc, but has access to + * object-specific data. If for some reason there is no current + * object context, then a method call is inappropriate, and an error + * is returned. + * + * Methods are implemented either as Tcl code fragments, or as C-coded + * procedures. For Tcl code fragments, command arguments are parsed + * according to the argument list, and the body is executed in the + * scope of the class where it was defined. For C procedures, the + * arguments are passed in "as-is", and the procedure is executed in + * the most-specific class scope. + * ------------------------------------------------------------------------ + */ +static int +NRExecMethod( + ClientData clientData, /* method definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const *objv) /* argument objects */ +{ + ItclMemberFunc *imPtr = (ItclMemberFunc*)clientData; + int result = TCL_OK; + + const char *token; + Tcl_HashEntry *entry; + ItclClass *iclsPtr; + ItclObject *ioPtr; + + ItclShowArgs(1, "NRExecMethod", objc, objv); + + /* + * Make sure that the current namespace context includes an + * object that is being manipulated. Methods can be executed + * only if an object context exists. + */ + iclsPtr = imPtr->iclsPtr; + if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { + return TCL_ERROR; + } + if (ioPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot access object-specific info without an object context", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Make sure that this command member can be accessed from + * the current namespace context. + * That is now done in ItclMapMethodNameProc !! + */ + + /* + * All methods should be "virtual" unless they are invoked with + * a "::" scope qualifier. + * + * To implement the "virtual" behavior, find the most-specific + * implementation for the method by looking in the "resolveCmds" + * table for this class. + */ + token = Tcl_GetString(objv[0]); + if (strstr(token, "::") == NULL) { + if (ioPtr != NULL) { + entry = Tcl_FindHashEntry(&ioPtr->iclsPtr->resolveCmds, + (char *)imPtr->namePtr); + + if (entry) { + ItclCmdLookup *clookup; + clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); + imPtr = clookup->imPtr; + } + } + } + + /* + * Execute the code for the method. Be careful to protect + * the method in case it gets deleted during execution. + */ + ItclPreserveIMF(imPtr); + result = Itcl_EvalMemberCode(interp, imPtr, ioPtr, objc, objv); + ItclReleaseIMF(imPtr); + return result; +} + +/* ARGSUSED */ +int +Itcl_ExecMethod( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRExecMethod, clientData, objc, objv); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ExecProc() + * + * Invoked by Tcl to handle the execution of a user-defined proc. + * + * Procs are implemented either as Tcl code fragments, or as C-coded + * procedures. For Tcl code fragments, command arguments are parsed + * according to the argument list, and the body is executed in the + * scope of the class where it was defined. For C procedures, the + * arguments are passed in "as-is", and the procedure is executed in + * the most-specific class scope. + * ------------------------------------------------------------------------ + */ +static int +NRExecProc( + ClientData clientData, /* proc definition */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclMemberFunc *imPtr = (ItclMemberFunc*)clientData; + int result = TCL_OK; + + ItclShowArgs(1, "NRExecProc", objc, objv); + + /* + * Make sure that this command member can be accessed from + * the current namespace context. + */ + if (imPtr->protection != ITCL_PUBLIC) { + if (!Itcl_CanAccessFunc(imPtr, Tcl_GetCurrentNamespace(interp))) { + ItclMemberFunc *imPtr2 = NULL; + Tcl_HashEntry *hPtr; + Tcl_ObjectContext context; + context = Itcl_GetCallFrameClientData(interp); + if (context == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't access \"", Tcl_GetString(imPtr->fullNamePtr), + "\": ", Itcl_ProtectionStr(imPtr->protection), + " function", (char*)NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods, + (char *)Tcl_ObjectContextMethod(context)); + if (hPtr != NULL) { + imPtr2 = Tcl_GetHashValue(hPtr); + } + if ((imPtr->protection & ITCL_PRIVATE) && (imPtr2 != NULL) && + (imPtr->iclsPtr->nsPtr != imPtr2->iclsPtr->nsPtr)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", + Tcl_GetString(objv[0]), + "\"", NULL); + return TCL_ERROR; + } + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't access \"", Tcl_GetString(imPtr->fullNamePtr), + "\": ", Itcl_ProtectionStr(imPtr->protection), + " function", (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Execute the code for the proc. Be careful to protect + * the proc in case it gets deleted during execution. + */ + ItclPreserveIMF(imPtr); + + result = Itcl_EvalMemberCode(interp, imPtr, (ItclObject*)NULL, + objc, objv); + ItclReleaseIMF(imPtr); + return result; +} + +/* ARGSUSED */ +int +Itcl_ExecProc( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, NRExecProc, clientData, objc, objv); +} + +static int +CallInvokeMethodIfExists( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ItclClass *iclsPtr = data[0]; + ItclObject *contextObj = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj* const* objv = data[3]; + + result = Itcl_InvokeMethodIfExists(interp, "constructor", + iclsPtr, contextObj, objc, (Tcl_Obj* const*)objv); + + if (result != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_ConstructBase() + * + * Usually invoked just before executing the body of a constructor + * when an object is first created. This procedure makes sure that + * all base classes are properly constructed. If an "initCode" fragment + * was defined with the constructor for the class, then it is invoked. + * After that, the list of base classes is checked for constructors + * that are defined but have not yet been invoked. Each of these is + * invoked implicitly with no arguments. + * + * Assumes that a local call frame is already installed, and that + * constructor arguments have already been matched and are sitting in + * this frame. Returns TCL_OK on success; otherwise, this procedure + * returns TCL_ERROR, along with an error message in the interpreter. + * ------------------------------------------------------------------------ + */ + +int +Itcl_ConstructBase( + Tcl_Interp *interp, /* interpreter */ + ItclObject *contextObj, /* object being constructed */ + ItclClass *contextClass) /* current class being constructed */ +{ + int result = TCL_OK; + Tcl_Obj *objPtr; + Itcl_ListElem *elem; + + /* + * If the class has an "initCode", invoke it in the current context. + */ + + if (contextClass->initCode) { + + /* TODO: NRE */ + result = Tcl_EvalObj(interp, contextClass->initCode); + } + + /* + * Scan through the list of base classes and see if any of these + * have not been constructed. Invoke base class constructors + * implicitly, as needed. Go through the list of base classes + * in reverse order, so that least-specific classes are constructed + * first. + */ + + objPtr = Tcl_NewStringObj("constructor", -1); + Tcl_IncrRefCount(objPtr); + for (elem = Itcl_LastListElem(&contextClass->bases); + result == TCL_OK && elem != NULL; + elem = Itcl_PrevListElem(elem)) { + + Tcl_HashEntry *entry; + ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem); + + if (Tcl_FindHashEntry(contextObj->constructed, + (char *)iclsPtr->namePtr)) { + + /* Already constructed, nothing to do. */ + continue; + } + + entry = Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr); + if (entry) { + void *callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + Tcl_NRAddCallback(interp, CallInvokeMethodIfExists, iclsPtr, + contextObj, INT2PTR(0), NULL); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + } else { + result = Itcl_ConstructBase(interp, contextObj, iclsPtr); + } + } + Tcl_DecrRefCount(objPtr); + return result; +} + +int +ItclConstructGuts( + ItclObject *contextObj, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + ItclClass *contextClass; + + /* Ignore syntax error */ + if (objc != 3) { + return TCL_OK; + } + + /* Object is fully constructed. This becomes no-op. */ + if (contextObj->constructed == NULL) { + return TCL_OK; + } + + contextClass = Itcl_FindClass(interp, Tcl_GetString(objv[2]), 0); + if (contextClass == NULL) { + return TCL_OK; + } + + + return Itcl_ConstructBase(interp, contextObj, contextClass); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_InvokeMethodIfExists() + * + * Looks for a particular method in the specified class. If the + * method is found, it is invoked with the given arguments. Any + * protection level (protected/private) for the method is ignored. + * If the method does not exist, this procedure does nothing. + * + * This procedure is used primarily to invoke the constructor/destructor + * when an object is created/destroyed. + * + * Returns TCL_OK on success; otherwise, this procedure returns + * TCL_ERROR along with an error message in the interpreter. + * ------------------------------------------------------------------------ + */ +int +Itcl_InvokeMethodIfExists( + Tcl_Interp *interp, /* interpreter */ + const char *name, /* name of desired method */ + ItclClass *contextClassPtr, /* current class being constructed */ + ItclObject *contextObjectPtr, /* object being constructed */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *cmdlinePtr; + Tcl_Obj **cmdlinev; + Tcl_Obj **newObjv; + Tcl_CallFrame frame; + ItclMemberFunc *imPtr; + int cmdlinec; + int result = TCL_OK; + Tcl_Obj *objPtr = Tcl_NewStringObj(name, -1); + + ItclShowArgs(1, "Itcl_InvokeMethodIfExists", objc, objv); + hPtr = Tcl_FindHashEntry(&contextClassPtr->functions, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr) { + imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); + + /* + * Prepend the method name to the list of arguments. + */ + cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv); + + (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &cmdlinec, &cmdlinev); + + ItclShowArgs(1, "EMC", cmdlinec, cmdlinev); + /* + * Execute the code for the method. Be careful to protect + * the method in case it gets deleted during execution. + */ + ItclPreserveIMF(imPtr); + + if (contextObjectPtr->oPtr == NULL) { + Tcl_DecrRefCount(cmdlinePtr); + return TCL_ERROR; + } + result = Itcl_EvalMemberCode(interp, imPtr, contextObjectPtr, + cmdlinec, cmdlinev); + ItclReleaseIMF(imPtr); + Tcl_DecrRefCount(cmdlinePtr); + } else { + if (contextClassPtr->flags & + (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + if (strcmp(name, "constructor") == 0) { + if (objc > 0) { + if (contextClassPtr->numOptions == 0) { + /* check if all options are delegeted */ + Tcl_Obj *objPtr; + objPtr = Tcl_NewStringObj("*", -1); + hPtr = Tcl_FindHashEntry( + &contextClassPtr->delegatedOptions, + (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "type \"", + Tcl_GetString(contextClassPtr->namePtr), + "\" has no options, but constructor has", + " option arguments", NULL); + return TCL_ERROR; + } + } + if (Itcl_PushCallFrame(interp, &frame, + contextClassPtr->nsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + Tcl_AppendResult(interp, "INTERNAL ERROR in", + "Itcl_InvokeMethodIfExists Itcl_PushCallFrame", + NULL); + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc + 2)); + newObjv[0] = Tcl_NewStringObj("my", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("configure", -1); + Tcl_IncrRefCount(newObjv[1]); + memcpy(newObjv + 2, objv, (objc * sizeof(Tcl_Obj *))); + ItclShowArgs(1, "DEFAULT Constructor", objc + 2, newObjv); + result = Tcl_EvalObjv(interp, objc + 2, newObjv, 0); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *)newObjv); + Itcl_PopCallFrame(interp); + } + } + } + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ReportFuncErrors() + * + * Used to interpret the status code returned when the body of a + * Tcl-style proc is executed. Handles the "errorInfo" and "errorCode" + * variables properly, and adds error information into the interpreter + * if anything went wrong. Returns a new status code that should be + * treated as the return status code for the command. + * + * This same operation is usually buried in the Tcl InterpProc() + * procedure. It is defined here so that it can be reused more easily. + * ------------------------------------------------------------------------ + */ +int +Itcl_ReportFuncErrors( + Tcl_Interp* interp, /* interpreter being modified */ + ItclMemberFunc *imPtr, /* command member that was invoked */ + ItclObject *contextObj, /* object context for this command */ + int result) /* integer status code from proc body */ +{ +/* FIXME !!! */ +/* adapt to use of ItclProcErrorProc for stubs compatibility !! */ + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CmdAliasProc() + * + * ------------------------------------------------------------------------ + */ +Tcl_Command +Itcl_CmdAliasProc( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *cmdName, + ClientData clientData) +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclObject *ioPtr; + ItclMemberFunc *imPtr; + ItclResolveInfo *resolveInfoPtr; + ItclCmdLookup *clookup; + + resolveInfoPtr = (ItclResolveInfo *)clientData; + if (resolveInfoPtr->flags & ITCL_RESOLVE_OBJECT) { + ioPtr = resolveInfoPtr->ioPtr; + iclsPtr = ioPtr->iclsPtr; + } else { + ioPtr = NULL; + iclsPtr = resolveInfoPtr->iclsPtr; + } + infoPtr = iclsPtr->infoPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return NULL; + } + iclsPtr = Tcl_GetHashValue(hPtr); + objPtr = Tcl_NewStringObj(cmdName, -1); + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr == NULL) { + if (strcmp(cmdName, "@itcl-builtin-cget") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::cget", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-configure") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::configure", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-destroy") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::destroy", NULL, 0); + } + if (strncmp(cmdName, "@itcl-builtin-setget", 20) == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::setget", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-isa") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::isa", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-createhull") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::createhull", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-keepcomponentoption") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::keepcomponentoption", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-ignorecomponentoption") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::removecomponentoption", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-irgnorecomponentoption") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::ignorecomponentoption", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-setupcomponent") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::setupcomponent", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-initoptions") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::initoptions", NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-mytypemethod") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::mytypemethod", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-mymethod") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::mymethod", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-myproc") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::myproc", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-mytypevar") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::mytypevar", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-myvar") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::myvar", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-itcl_hull") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::itcl_hull", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-callinstance") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::callinstance", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-getinstancevar") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::getinstancevar", + NULL, 0); + } + if (strcmp(cmdName, "@itcl-builtin-classunknown") == 0) { + return Tcl_FindCommand(interp, "::itcl::builtin::classunknown", NULL, 0); + } + return NULL; + } + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + return imPtr->accessCmd; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_VarAliasProc() + * + * ------------------------------------------------------------------------ + */ +Tcl_Var +Itcl_VarAliasProc( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *varName, + ClientData clientData) +{ + + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclObject *ioPtr; + ItclVarLookup *ivlPtr; + ItclResolveInfo *resolveInfoPtr; + ItclCallContext *callContextPtr; + Tcl_Var varPtr; + + varPtr = NULL; + hPtr = NULL; + callContextPtr = NULL; + resolveInfoPtr = (ItclResolveInfo *)clientData; + if (resolveInfoPtr->flags & ITCL_RESOLVE_OBJECT) { + ioPtr = resolveInfoPtr->ioPtr; + iclsPtr = ioPtr->iclsPtr; + } else { + ioPtr = NULL; + iclsPtr = resolveInfoPtr->iclsPtr; + } + infoPtr = iclsPtr->infoPtr; + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr != NULL) { + iclsPtr = Tcl_GetHashValue(hPtr); + } + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, varName); + if (hPtr == NULL) { + /* no class/object variable */ + return NULL; + } + ivlPtr = Tcl_GetHashValue(hPtr); + if (ivlPtr == NULL) { + return NULL; + } + if (!ivlPtr->accessible) { + return NULL; + } + + if (ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&ioPtr->objectVariables, + (char *)ivlPtr->ivPtr); + } else { + hPtr = Tcl_FindHashEntry(&iclsPtr->classCommons, + (char *)ivlPtr->ivPtr); + if (hPtr == NULL) { + if (callContextPtr != NULL) { + ioPtr = callContextPtr->ioPtr; + } + if (ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&ioPtr->objectVariables, + (char *)ivlPtr->ivPtr); + } + } + } + if (hPtr != NULL) { + varPtr = Tcl_GetHashValue(hPtr); + } + return varPtr; +} + +/* + * ------------------------------------------------------------------------ + * ItclCheckCallProc() + * + * + * ------------------------------------------------------------------------ + */ +int +ItclCheckCallProc( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext contextPtr, + Tcl_CallFrame *framePtr, + int *isFinished) +{ + int result; + ItclMemberFunc *imPtr; + + imPtr = (ItclMemberFunc *)clientData; + if (!imPtr->iclsPtr->infoPtr->useOldResolvers) { + Itcl_SetCallFrameResolver(interp, imPtr->iclsPtr->resolvePtr); + } + result = TCL_OK; + + if (isFinished != NULL) { + *isFinished = 0; + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclCheckCallMethod() + * + * + * ------------------------------------------------------------------------ + */ +int +ItclCheckCallMethod( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext contextPtr, + Tcl_CallFrame *framePtr, + int *isFinished) +{ + Itcl_Stack *stackPtr; + + Tcl_Object oPtr; + ItclObject *ioPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *const * cObjv; + Tcl_Namespace *currNsPtr; + ItclCallContext *callContextPtr; + ItclCallContext *callContextPtr2; + ItclMemberFunc *imPtr; + int result; + int isNew; + int cObjc; + int min_allowed_args; + + ItclObjectInfo *infoPtr; + + oPtr = NULL; + hPtr = NULL; + imPtr = (ItclMemberFunc *)clientData; + ItclPreserveIMF(imPtr); + if (imPtr->flags & ITCL_CONSTRUCTOR) { + ioPtr = imPtr->iclsPtr->infoPtr->currIoPtr; + } else { + if (contextPtr == NULL) { + if ((imPtr->flags & ITCL_COMMON) || + (imPtr->codePtr->flags & ITCL_BUILTIN)) { + if (!imPtr->iclsPtr->infoPtr->useOldResolvers) { + Itcl_SetCallFrameResolver(interp, + imPtr->iclsPtr->resolvePtr); + } + if (isFinished != NULL) { + *isFinished = 0; + } + return TCL_OK; + } + Tcl_AppendResult(interp, + "ItclCheckCallMethod cannot get context object (NULL)", + " for ", Tcl_GetString(imPtr->fullNamePtr), + NULL); + result = TCL_ERROR; + goto finishReturn; + } + oPtr = Tcl_ObjectContextObject(contextPtr); + ioPtr = Tcl_ObjectGetMetadata(oPtr, + imPtr->iclsPtr->infoPtr->object_meta_type); + } + if ((imPtr->codePtr != NULL) && + (imPtr->codePtr->flags & ITCL_IMPLEMENT_NONE)) { + Tcl_AppendResult(interp, "member function \"", + Tcl_GetString(imPtr->fullNamePtr), + "\" is not defined and cannot be autoloaded", NULL); + if (isFinished != NULL) { + *isFinished = 1; + } + result = TCL_ERROR; + goto finishReturn; + } + if (framePtr) { + /* + * This stanza is in place to seize control over usage error messages + * before TclOO examines the arguments and produces its own. This + * gives Itcl stability in its error messages at the cost of inconsistency + * with Tcl's evolving conventions. + */ + cObjc = Itcl_GetCallFrameObjc(interp); + cObjv = Itcl_GetCallFrameObjv(interp); + min_allowed_args = cObjc-2; + if (strcmp(Tcl_GetString(cObjv[0]), "next") == 0) { + min_allowed_args++; + } + if (min_allowed_args < imPtr->argcount) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_GetString(cObjv[0]), " ", Tcl_GetString(imPtr->namePtr), + " ", Tcl_GetString(imPtr->usagePtr), "\"", NULL); + if (isFinished != NULL) { + *isFinished = 1; + } + result = TCL_ERROR; + goto finishReturn; + } + } + isNew = 0; + callContextPtr = NULL; + currNsPtr = Tcl_GetCurrentNamespace(interp); + if (ioPtr != NULL) { + hPtr = Tcl_CreateHashEntry(&ioPtr->contextCache, (char *)imPtr, &isNew); + if (!isNew) { + callContextPtr2 = Tcl_GetHashValue(hPtr); + if (callContextPtr2->refCount == 0) { + callContextPtr = callContextPtr2; + callContextPtr->objectFlags = ioPtr->flags; + callContextPtr->nsPtr = Tcl_GetCurrentNamespace(interp); + callContextPtr->ioPtr = ioPtr; + callContextPtr->imPtr = imPtr; + callContextPtr->refCount = 1; + } else { + if ((callContextPtr2->objectFlags == ioPtr->flags) + && (callContextPtr2->nsPtr == currNsPtr)) { + callContextPtr = callContextPtr2; + callContextPtr->refCount++; + } + } + } + } + if (callContextPtr == NULL) { + callContextPtr = (ItclCallContext *)ckalloc( + sizeof(ItclCallContext)); + if (ioPtr == NULL) { + callContextPtr->objectFlags = 0; + callContextPtr->ioPtr = NULL; + } else { + callContextPtr->objectFlags = ioPtr->flags; + callContextPtr->ioPtr = ioPtr; + } + callContextPtr->nsPtr = Tcl_GetCurrentNamespace(interp); + callContextPtr->imPtr = imPtr; + callContextPtr->refCount = 1; + } + if (isNew) { + Tcl_SetHashValue(hPtr, callContextPtr); + } + + if (framePtr == NULL) { + framePtr = Itcl_GetUplevelCallFrame(interp, 0); + } + + isNew = 0; + infoPtr = imPtr->iclsPtr->infoPtr; + hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, + (char *)framePtr, &isNew); + if (isNew) { + stackPtr = (Itcl_Stack *)ckalloc(sizeof(Itcl_Stack)); + Itcl_InitStack(stackPtr); + Tcl_SetHashValue(hPtr, stackPtr); + } else { + stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); + } + + assert (callContextPtr) ; + Itcl_PushStack(callContextPtr, stackPtr); + + /* Ugly abuse alert. Two maps in one table */ + hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, + (char *)contextPtr, &isNew); + if (isNew) { + stackPtr = (Itcl_Stack *)ckalloc(sizeof(Itcl_Stack)); + Itcl_InitStack(stackPtr); + Tcl_SetHashValue(hPtr, stackPtr); + } else { + stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); + } + + Itcl_PushStack(framePtr, stackPtr); + + if (ioPtr != NULL) { + ioPtr->callRefCount++; + ItclPreserveObject(ioPtr); + } + imPtr->iclsPtr->callRefCount++; + if (!imPtr->iclsPtr->infoPtr->useOldResolvers) { + Itcl_SetCallFrameResolver(interp, ioPtr->resolvePtr); + } + result = TCL_OK; + + if (isFinished != NULL) { + *isFinished = 0; + } + return result; +finishReturn: + ItclReleaseIMF(imPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclAfterCallMethod() + * + * + * ------------------------------------------------------------------------ + */ +int +ItclAfterCallMethod( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext contextPtr, + Tcl_Namespace *nsPtr, + int call_result) +{ + Tcl_HashEntry *hPtr; + ItclObject *ioPtr; + ItclMemberFunc *imPtr; + ItclCallContext *callContextPtr; + int newEntry; + int result; + + imPtr = (ItclMemberFunc *)clientData; + callContextPtr = NULL; + if (contextPtr != NULL) { + ItclObjectInfo *infoPtr = imPtr->infoPtr; + Tcl_CallFrame *framePtr; + Itcl_Stack *stackPtr; + + hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)contextPtr); + assert(hPtr); + stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); + framePtr = Itcl_PopStack(stackPtr); + if (Itcl_GetStackSize(stackPtr) == 0) { + Itcl_DeleteStack(stackPtr); + ckfree((char *) stackPtr); + Tcl_DeleteHashEntry(hPtr); + } + + hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr); + assert(hPtr); + stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); + callContextPtr = Itcl_PopStack(stackPtr); + if (Itcl_GetStackSize(stackPtr) == 0) { + Itcl_DeleteStack(stackPtr); + ckfree((char *) stackPtr); + Tcl_DeleteHashEntry(hPtr); + } + } + if (callContextPtr == NULL) { + if ((imPtr->flags & ITCL_COMMON) || + (imPtr->codePtr->flags & ITCL_BUILTIN)) { + result = call_result; + goto finishReturn; + } + Tcl_AppendResult(interp, + "ItclAfterCallMethod cannot get context object (NULL)", + " for ", Tcl_GetString(imPtr->fullNamePtr), NULL); + result = TCL_ERROR; + goto finishReturn; + } + /* + * If this is a constructor or destructor, and if it is being + * invoked at the appropriate time, keep track of which methods + * have been called. This information is used to implicitly + * invoke constructors/destructors as needed. + */ + ioPtr = callContextPtr->ioPtr; + if (ioPtr != NULL) { + if (imPtr->iclsPtr) { + imPtr->iclsPtr->callRefCount--; + if (imPtr->flags & (ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR)) { + if ((imPtr->flags & ITCL_DESTRUCTOR) && ioPtr && + ioPtr->destructed) { + Tcl_CreateHashEntry(ioPtr->destructed, + (char *)imPtr->iclsPtr->namePtr, &newEntry); + } + if ((imPtr->flags & ITCL_CONSTRUCTOR) && ioPtr && + ioPtr->constructed) { + Tcl_CreateHashEntry(ioPtr->constructed, + (char *)imPtr->iclsPtr->namePtr, &newEntry); + } + } + } + ioPtr->callRefCount--; + if (ioPtr->flags & ITCL_OBJECT_SHOULD_VARNS_DELETE) { + ItclDeleteObjectVariablesNamespace(interp, ioPtr); + } + } + + callContextPtr->refCount--; + if (callContextPtr->refCount == 0) { + if (callContextPtr->ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&callContextPtr->ioPtr->contextCache, + (char *)callContextPtr->imPtr); + if (hPtr == NULL) { + ckfree((char *)callContextPtr); + } + ItclReleaseObject(ioPtr); + } else { + ckfree((char *)callContextPtr); + } + } + result = call_result; +finishReturn: + ItclReleaseIMF(imPtr); + return result; +} + +void +ItclProcErrorProc( + Tcl_Interp *interp, + Tcl_Obj *procNameObj) +{ + Tcl_Obj *objPtr; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclCallContext *callContextPtr; + ItclMemberFunc *imPtr; + ItclObject *contextIoPtr; + ItclClass *currIclsPtr; + char num[20]; + Itcl_Stack *stackPtr; + + /* Fetch the current call frame. That determines context. */ + Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0); + + /* Try to map it to a context stack. */ + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr); + if (hPtr == NULL) { + /* Can this happen? */ + return; + } + + /* Frame maps to a context stack. */ + stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); + callContextPtr = Itcl_PeekStack(stackPtr); + + if (callContextPtr == NULL) { + return; + } + + currIclsPtr = NULL; + objPtr = NULL; + { + imPtr = callContextPtr->imPtr; + contextIoPtr = callContextPtr->ioPtr; + objPtr = Tcl_NewStringObj("\n ", -1); + + if (imPtr->flags & ITCL_CONSTRUCTOR) { + currIclsPtr = imPtr->iclsPtr; + Tcl_AppendToObj(objPtr, "while constructing object \"", -1); + Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr); + Tcl_AppendToObj(objPtr, "\" in ", -1); + Tcl_AppendToObj(objPtr, currIclsPtr->nsPtr->fullName, -1); + Tcl_AppendToObj(objPtr, "::constructor", -1); + if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) { + Tcl_AppendToObj(objPtr, " (", -1); + } + } + if (imPtr->flags & ITCL_DESTRUCTOR) { + contextIoPtr->flags = 0; + Tcl_AppendToObj(objPtr, "while deleting object \"", -1); + Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr); + Tcl_AppendToObj(objPtr, "\" in ", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1); + if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) { + Tcl_AppendToObj(objPtr, " (", -1); + } + } + if (!(imPtr->flags & (ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR))) { + Tcl_AppendToObj(objPtr, "(", -1); + + hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)contextIoPtr); + if (hPtr != NULL) { + if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd)) { + Tcl_AppendToObj(objPtr, "object \"", -1); + Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr); + Tcl_AppendToObj(objPtr, "\" ", -1); + } + } + + if ((imPtr->flags & ITCL_COMMON) != 0) { + Tcl_AppendToObj(objPtr, "procedure", -1); + } else { + Tcl_AppendToObj(objPtr, "method", -1); + } + Tcl_AppendToObj(objPtr, " \"", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1); + Tcl_AppendToObj(objPtr, "\" ", -1); + } + + if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) { + Tcl_Obj *dictPtr; + Tcl_Obj *keyPtr; + Tcl_Obj *valuePtr; + int lineNo; + + keyPtr = Tcl_NewStringObj("-errorline", -1); + dictPtr = Tcl_GetReturnOptions(interp, TCL_ERROR); + if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { + /* how should we handle an error ? */ + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(objPtr); + return; + } + if (valuePtr == NULL) { + /* how should we handle an error ? */ + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(objPtr); + return; + } + if (Tcl_GetIntFromObj(interp, valuePtr, &lineNo) != TCL_OK) { + /* how should we handle an error ? */ + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(objPtr); + return; + } + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(valuePtr); + Tcl_AppendToObj(objPtr, "body line ", -1); + sprintf(num, "%d", lineNo); + Tcl_AppendToObj(objPtr, num, -1); + Tcl_AppendToObj(objPtr, ")", -1); + } else { + Tcl_AppendToObj(objPtr, ")", -1); + } + + Tcl_AppendObjToErrorInfo(interp, objPtr); + objPtr = NULL; + } + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.c new file mode 100644 index 0000000..9f035c8 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.c @@ -0,0 +1,287 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * This file contains procedures that belong in the Tcl/Tk core. + * Hopefully, they'll migrate there soon. + * + * ======================================================================== + * AUTHOR: Arnulf Wiedemann + * + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include <tclInt.h> +#include "itclInt.h" + +int +Itcl_SetCallFrameResolver( + Tcl_Interp *interp, + Tcl_Resolve *resolvePtr) +{ + CallFrame *framePtr = ((Interp *)interp)->framePtr; + if (framePtr != NULL) { +#ifdef ITCL_USE_MODIFIED_TCL_H + framePtr->isProcCallFrame |= FRAME_HAS_RESOLVER; + framePtr->resolvePtr = resolvePtr; +#endif + return TCL_OK; + } + return TCL_ERROR; +} + +int +_Tcl_SetNamespaceResolver( + Tcl_Namespace *nsPtr, + Tcl_Resolve *resolvePtr) +{ + if (nsPtr == NULL) { + return TCL_ERROR; + } +#ifdef ITCL_USE_MODIFIED_TCL_H + ((Namespace *)nsPtr)->resolvePtr = resolvePtr; +#endif + return TCL_OK; +} + +Tcl_Var +Tcl_NewNamespaceVar( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *varName) +{ + Var *varPtr = NULL; + int new; + + if ((nsPtr == NULL) || (varName == NULL)) { + return NULL; + } + + varPtr = TclVarHashCreateVar(&((Namespace *)nsPtr)->varTable, + varName, &new); + TclSetVarNamespaceVar(varPtr); + return (Tcl_Var)varPtr; +} + +void +Itcl_PreserveVar( + Tcl_Var var) +{ + Var *varPtr = (Var *)var; + + VarHashRefCount(varPtr)++; +} + +void +Itcl_ReleaseVar( + Tcl_Var var) +{ + Var *varPtr = (Var *)var; + + VarHashRefCount(varPtr)--; + TclCleanupVar(varPtr, NULL); +} + +Tcl_CallFrame * +Itcl_GetUplevelCallFrame( + Tcl_Interp *interp, + int level) +{ + CallFrame *framePtr; + if (level < 0) { + return NULL; + } + framePtr = ((Interp *)interp)->varFramePtr; + while ((framePtr != NULL) && (level-- > 0)) { + framePtr = framePtr->callerVarPtr; + } + if (framePtr == NULL) { + return NULL; + } + return (Tcl_CallFrame *)framePtr; +} + +Tcl_CallFrame * +Itcl_ActivateCallFrame( + Tcl_Interp *interp, + Tcl_CallFrame *framePtr) +{ + Interp *iPtr = (Interp*)interp; + CallFrame *oldFramePtr; + + oldFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = (CallFrame *) framePtr; + + return (Tcl_CallFrame *) oldFramePtr; +} + +Tcl_Namespace * +Itcl_GetUplevelNamespace( + Tcl_Interp *interp, + int level) +{ + CallFrame *framePtr; + if (level < 0) { + return NULL; + } + framePtr = ((Interp *)interp)->framePtr; + while ((framePtr != NULL) && (level-- > 0)) { + framePtr = framePtr->callerVarPtr; + } + if (framePtr == NULL) { + return NULL; + } + return (Tcl_Namespace *)framePtr->nsPtr; +} + +ClientData +Itcl_GetCallFrameClientData( + Tcl_Interp *interp) +{ + /* suggested fix for SF bug #250 use varFramePtr instead of framePtr + * seems to have no side effect concerning test suite, but does NOT fix the bug + */ + CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + if (framePtr == NULL) { + return NULL; + } + return framePtr->clientData; +} + +int +Itcl_SetCallFrameNamespace( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr) +{ + CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + if (framePtr == NULL) { + return TCL_ERROR; + } + ((Interp *)interp)->varFramePtr->nsPtr = (Namespace *)nsPtr; + return TCL_OK; +} + +int +Itcl_GetCallVarFrameObjc( + Tcl_Interp *interp) +{ + CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + if (framePtr == NULL) { + return 0; + } + return framePtr->objc; +} + +Tcl_Obj * const * +Itcl_GetCallVarFrameObjv( + Tcl_Interp *interp) +{ + CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + if (framePtr == NULL) { + return NULL; + } + return framePtr->objv; +} + +int +Itcl_GetCallFrameObjc( + Tcl_Interp *interp) +{ + CallFrame *framePtr = ((Interp *)interp)->framePtr; + if (framePtr == NULL) { + return 0; + } + return ((Interp *)interp)->framePtr->objc; +} + +Tcl_Obj * const * +Itcl_GetCallFrameObjv( + Tcl_Interp *interp) +{ + CallFrame *framePtr = ((Interp *)interp)->framePtr; + if (framePtr == NULL) { + return NULL; + } + return ((Interp *)interp)->framePtr->objv; +} + +int +Itcl_IsCallFrameArgument( + Tcl_Interp *interp, + const char *name) +{ + CallFrame *varFramePtr = ((Interp *)interp)->framePtr; + Proc *procPtr; + + if (varFramePtr == NULL) { + return 0; + } + if (!varFramePtr->isProcCallFrame) { + return 0; + } + procPtr = varFramePtr->procPtr; + /* + * Search through compiled locals first... + */ + if (procPtr) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + int nameLen = strlen(name); + + for (;localPtr != NULL; localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + register char *localName = localPtr->name; + if ((name[0] == localName[0]) + && (nameLen == localPtr->nameLength) + && (strcmp(name, localName) == 0)) { + return 1; + } + } + } + } + return 0; +} + +int +Itcl_IsCallFrameLinkVar( + Tcl_Interp *interp, + const char *name) +{ + CallFrame *varFramePtr = ((Interp *)interp)->framePtr; + Proc *procPtr; + + if (varFramePtr == NULL) { + return 0; + } + if (!varFramePtr->isProcCallFrame) { + return 0; + } + procPtr = varFramePtr->procPtr; + /* + * Search through compiled locals first... + */ + if (procPtr) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + int nameLen = strlen(name); + + for (;localPtr != NULL; localPtr = localPtr->nextPtr) { + if (TclIsVarLink(localPtr)) { + register char *localName = localPtr->name; + if ((name[0] == localName[0]) + && (nameLen == localPtr->nameLength) + && (strcmp(name, localName) == 0)) { + return 1; + } + } + } + } + return 0; +} + +int +Itcl_IsVarLink(Tcl_Var varPtr) { + return TclIsVarLink((Var *)varPtr); +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.h new file mode 100644 index 0000000..012ea0b --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.h @@ -0,0 +1,87 @@ +#ifndef ITCL_USE_MODIFIED_TCL_H +/* this is just to provide the definition. This struct is only used if + * infoPtr->useOldResolvers == 0 which is not the default + */ +#define FRAME_HAS_RESOLVER 0x100 +typedef Tcl_Command (Tcl_CmdAliasProc)(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *cmdName, + ClientData clientData); +typedef Tcl_Var (Tcl_VarAliasProc)(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *varName, + ClientData clientData); + +#ifndef _TCL_RESOLVE_DEFINED +typedef struct Tcl_Resolve { + Tcl_VarAliasProc *varProcPtr; + Tcl_CmdAliasProc *cmdProcPtr; + ClientData clientData; +} Tcl_Resolve; +#define _TCL_RESOLVE_DEFINED 1 +#endif +#endif + +#ifndef _TCLINT +struct Tcl_ResolvedVarInfo; + +typedef Tcl_Var (Tcl_ResolveRuntimeVarProc)(Tcl_Interp *interp, + struct Tcl_ResolvedVarInfo *vinfoPtr); + +typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr); + +/* + * The following structure encapsulates the routines needed to resolve a + * variable reference at runtime. Any variable specific state will typically + * be appended to this structure. + */ + +typedef struct Tcl_ResolvedVarInfo { + Tcl_ResolveRuntimeVarProc *fetchProc; + Tcl_ResolveVarDeleteProc *deleteProc; +} Tcl_ResolvedVarInfo; + +typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp *interp, + const char *name, int length, Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr); + +typedef int (Tcl_ResolveVarProc) (Tcl_Interp *interp, const char *name, + Tcl_Namespace *context, int flags, Tcl_Var *rPtr); + +typedef int (Tcl_ResolveCmdProc) (Tcl_Interp *interp, const char *name, + Tcl_Namespace *context, int flags, Tcl_Command *rPtr); + +typedef struct Tcl_ResolverInfo { + Tcl_ResolveCmdProc *cmdResProc; + /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; + /* Procedure handling variable name resolution + * for variables that can only be handled at + * runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name resolution + * at compile time. */ +} Tcl_ResolverInfo; +#endif + + +/* here come the definitions for code which should be migrated to Tcl core */ +/* these functions DO NOT exist and are not published */ +#ifndef _TCL_PROC_DEFINED +typedef struct Tcl_Proc_ *Tcl_Proc; +#define _TCL_PROC_DEFINED 1 +#endif + +#define Tcl_SetProcCmd _Tcl_SetProcCmd + +MODULE_SCOPE Tcl_Var Tcl_NewNamespaceVar(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *varName); +MODULE_SCOPE void Itcl_PreserveVar(Tcl_Var var); +MODULE_SCOPE void Itcl_ReleaseVar(Tcl_Var var); +MODULE_SCOPE int Itcl_IsCallFrameArgument(Tcl_Interp *interp, const char *name); +MODULE_SCOPE int Itcl_GetCallVarFrameObjc(Tcl_Interp *interp); +MODULE_SCOPE int Itcl_IsVarLink(Tcl_Var var); +MODULE_SCOPE int Itcl_IsCallFrameLinkVar(Tcl_Interp *interp, const char *name); +MODULE_SCOPE Tcl_Obj * const * Itcl_GetCallVarFrameObjv(Tcl_Interp *interp); +#define Tcl_SetNamespaceResolver _Tcl_SetNamespaceResolver +MODULE_SCOPE int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr, + struct Tcl_Resolve *resolvePtr); diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclObject.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclObject.c new file mode 100644 index 0000000..2e60c97 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclObject.c @@ -0,0 +1,3845 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This segment handles "objects" which are instantiated from class + * definitions. Objects contain public/protected/private data members + * from all classes in a derivation hierarchy. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann Copyright (c) 2007 + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include <tclInt.h> +#include "itclInt.h" + +/* + * FORWARD DECLARATIONS + */ +static char* ItclTraceThisVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceTypeVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceSelfVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceSelfnsVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceWinVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceOptionVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceComponentVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static char* ItclTraceItclHullVar(ClientData cdata, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); + +static void ItclDestroyObject(ClientData clientData); +static void ItclFreeObject(char * clientData); + +static int ItclDestructBase(Tcl_Interp *interp, ItclObject *contextObj, + ItclClass *contextClass, int flags); + +static int ItclInitObjectVariables(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr); +static int ItclInitObjectCommands(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr, const char *name); +static int ItclInitExtendedClassOptions(Tcl_Interp *interp, ItclObject *ioPtr); +static int ItclInitObjectOptions(Tcl_Interp *interp, ItclObject *ioPtr, + ItclClass *iclsPtr); +static const char * GetConstructorVar(Tcl_Interp *interp, ItclClass *iclsPtr, + const char *varName); +static ItclClass * GetClassFromClassName(Tcl_Interp *interp, + const char *className, ItclClass *iclsPtr); + +void +ItclPreserveObject( + ItclObject *ioPtr) +{ + ioPtr->refCount++; +} + +void +ItclReleaseObject( + ClientData clientData) +{ + ItclObject *ioPtr = (ItclObject *)clientData; + + if (--ioPtr->refCount == 0) { + ItclFreeObject((char *) clientData); + } +} + + +/* + * ------------------------------------------------------------------------ + * ItclDeleteObjectMetadata() + * + * Delete the metadata data if any + *------------------------------------------------------------------------- + */ +void +ItclDeleteObjectMetadata( + ClientData clientData) +{ + ItclObject *ioPtr = (ItclObject *)clientData; + Tcl_HashEntry *hPtr; + + if (ioPtr == NULL) return; /* Safety */ + if (ioPtr->oPtr == NULL) return; /* Safety */ + + hPtr = Tcl_FindHashEntry(&ioPtr->infoPtr->instances, + (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName); + + if (hPtr == NULL) return; + + if (clientData != Tcl_GetHashValue(hPtr)) { + Tcl_Panic("invalid instances entry"); + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + * ------------------------------------------------------------------------ + * ObjectRenamedTrace() + * + * ------------------------------------------------------------------------ + */ + +static void +ObjectRenamedTrace( + ClientData clientData, /* The object being deleted. */ + Tcl_Interp *interp, /* The interpreter containing the object. */ + const char *oldName, /* What the object was (last) called. */ + const char *newName, /* Always NULL ??. not for itk!! */ + int flags) /* Why was the object deleted? */ +{ + ItclObject *ioPtr = clientData; + Itcl_InterpState istate; + + if (newName != NULL) { + /* FIXME should enter the new name in the hashtables for objects etc. */ + return; + } + if (ioPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED) { + return; + } + ioPtr->flags |= ITCL_OBJECT_IS_RENAMED; + if (ioPtr->flags & ITCL_TCLOO_OBJECT_IS_DELETED) { + ioPtr->oPtr = NULL; + } + if (!(ioPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED)) { + /* + * Attempt to destruct the object, but ignore any errors. + */ + istate = Itcl_SaveInterpState(ioPtr->interp, 0); + Itcl_DestructObject(ioPtr->interp, ioPtr, ITCL_IGNORE_ERRS); + Itcl_RestoreInterpState(ioPtr->interp, istate); + ioPtr->flags |= ITCL_OBJECT_CLASS_DESTRUCTED; + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateObject() + * + */ +int +Itcl_CreateObject( + Tcl_Interp *interp, /* interpreter mananging new object */ + const char* name, /* name of new object */ + ItclClass *iclsPtr, /* class for new object */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[], /* argument objects */ + ItclObject **rioPtr) /* the created object */ +{ + int result; + ItclObjectInfo * infoPtr; + + result = ItclCreateObject(interp, name, iclsPtr, objc, objv); + if (result == TCL_OK) { + if (!(iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, name, NULL); + } + } + if (rioPtr != NULL) { + if (result == TCL_OK) { + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + *rioPtr = infoPtr->lastIoPtr; + } else { + *rioPtr = NULL; + } + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclCreateObject() + * + * Creates a new object instance belonging to the given class. + * Supports complex object names like "namesp::namesp::name" by + * following the namespace path and creating the object in the + * desired namespace. + * + * Automatically creates and initializes data members, including the + * built-in protected "this" variable containing the object name. + * Installs an access command in the current namespace, and invokes + * the constructor to initialize the object. + * + * If any errors are encountered, the object is destroyed and this + * procedure returns TCL_ERROR (along with an error message in the + * interpreter). Otherwise, it returns TCL_OK + * ------------------------------------------------------------------------ + */ +int +ItclCreateObject( + Tcl_Interp *interp, /* interpreter mananging new object */ + const char* name, /* name of new object */ + ItclClass *iclsPtr, /* class for new object */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + int result = TCL_OK; + + Tcl_DString buffer; + Tcl_CmdInfo cmdInfo; + Tcl_Command cmdPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj **newObjv; + Tcl_Obj *objPtr; + Tcl_Obj *saveNsNamePtr = NULL; + ItclObjectInfo *infoPtr; + ItclObject *saveCurrIoPtr; + ItclObject *ioPtr; + Itcl_InterpState istate; + const char *nsName; + const char *objName; + char unique[256]; /* buffer used for unique part of object names */ + int newEntry; + ItclResolveInfo *resolveInfoPtr; + /* objv[1]: class name */ + /* objv[2]: class full name */ + /* objv[3]: object name */ + + infoPtr = NULL; + ItclShowArgs(1, "ItclCreateObject", objc, objv); + saveCurrIoPtr = NULL; + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + /* check, if the object already exists and if yes delete it silently */ + cmdPtr = Tcl_FindCommand(interp, name, NULL, 0); + if (cmdPtr != NULL) { + Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo); + if (cmdInfo.deleteProc == ItclDestroyObject) { + Itcl_RenameCommand(interp, name, ""); + } + } + } + /* just init for the case of none ItclWidget objects */ + newObjv = (Tcl_Obj **)objv; + infoPtr = iclsPtr->infoPtr; + + if (infoPtr != NULL) { + infoPtr->lastIoPtr = NULL; + } + /* + * Create a new object and initialize it. + */ + ioPtr = (ItclObject*)ckalloc(sizeof(ItclObject)); + memset(ioPtr, 0, sizeof(ItclObject)); + ioPtr->iclsPtr = iclsPtr; + ioPtr->interp = interp; + ioPtr->infoPtr = infoPtr; + ItclPreserveClass(iclsPtr); + + ioPtr->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(ioPtr->constructed); + + ioPtr->oPtr = Tcl_NewObjectInstance(interp, iclsPtr->clsPtr, NULL, + /* nsName */ NULL, /* objc */ -1, /* objv */ NULL, /* skip */ 0); + if (ioPtr->oPtr == NULL) { + ckfree(ioPtr); + return TCL_ERROR; + } + + /* + * Add a command to the current namespace with the object name. + * This is done before invoking the constructors so that the + * command can be used during construction to query info. + */ + ItclPreserveObject(ioPtr); + + ioPtr->namePtr = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(ioPtr->namePtr); + nsName = Tcl_GetCurrentNamespace(interp)->fullName; + ioPtr->origNamePtr = Tcl_NewStringObj("", -1); + if ((name[0] != ':') && (name[1] != ':')) { + Tcl_AppendToObj(ioPtr->origNamePtr, nsName, -1); + if (strcmp(nsName, "::") != 0) { + Tcl_AppendToObj(ioPtr->origNamePtr, "::", -1); + } + } + Tcl_AppendToObj(ioPtr->origNamePtr, name, -1); + Tcl_IncrRefCount(ioPtr->origNamePtr); + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, -1); + ioPtr->varNsNamePtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + Tcl_IncrRefCount(ioPtr->varNsNamePtr); + Tcl_DStringFree(&buffer); + + Tcl_InitHashTable(&ioPtr->objectVariables, TCL_ONE_WORD_KEYS); + Tcl_InitObjHashTable(&ioPtr->objectOptions); + Tcl_InitObjHashTable(&ioPtr->objectComponents); + Tcl_InitObjHashTable(&ioPtr->objectDelegatedOptions); + Tcl_InitObjHashTable(&ioPtr->objectDelegatedFunctions); + Tcl_InitObjHashTable(&ioPtr->objectMethodVariables); + Tcl_InitHashTable(&ioPtr->contextCache, TCL_ONE_WORD_KEYS); + + ItclPreserveObject(ioPtr); + + /* + * Install the class namespace and object context so that + * the object's data members can be initialized via simple + * "set" commands. + */ + + /* first create the object's class variables namespaces + * and set all the init values for variables + */ + + if (ItclInitObjectVariables(interp, ioPtr, iclsPtr) != TCL_OK) { + ioPtr->hadConstructorError = 11; + result = TCL_ERROR; + goto errorReturn; + } + if (ItclInitObjectCommands(interp, ioPtr, iclsPtr, name) != TCL_OK) { + Tcl_AppendResult(interp, "error in ItclInitObjectCommands", NULL); + ioPtr->hadConstructorError = 12; + result = TCL_ERROR; + goto errorReturn; + } + if (iclsPtr->flags & (ITCL_ECLASS|ITCL_NWIDGET|ITCL_WIDGET| + ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + if (iclsPtr->flags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET| + ITCL_WIDGETADAPTOR)) { + ItclInitExtendedClassOptions(interp, ioPtr); + if (ItclInitObjectOptions(interp, ioPtr, iclsPtr) != TCL_OK) { + Tcl_AppendResult(interp, "error in ItclInitObjectOptions", + NULL); + ioPtr->hadConstructorError = 13; + result = TCL_ERROR; + goto errorReturn; + } + } + if (ItclInitObjectMethodVariables(interp, ioPtr, iclsPtr, name) + != TCL_OK) { + Tcl_AppendResult(interp, + "error in ItclInitObjectMethodVariables", NULL); + ioPtr->hadConstructorError = 14; + result = TCL_ERROR; + goto errorReturn; + } + + if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + saveNsNamePtr = Tcl_GetVar2Ex(interp, + "::itcl::internal::varNsName", name, 0); + if (saveNsNamePtr) { + Tcl_IncrRefCount(saveNsNamePtr); + } + Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name, + ioPtr->varNsNamePtr, 0); + } + + } + + saveCurrIoPtr = infoPtr->currIoPtr; + infoPtr->currIoPtr = ioPtr; + if (iclsPtr->flags & ITCL_WIDGET) { + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 5)); + newObjv[0] = Tcl_NewStringObj( + "::itcl::internal::commands::hullandoptionsinstall", -1); + newObjv[1] = ioPtr->namePtr; + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = ioPtr->iclsPtr->namePtr; + Tcl_IncrRefCount(newObjv[2]); + if (ioPtr->iclsPtr->widgetClassPtr != NULL) { + newObjv[3] = ioPtr->iclsPtr->widgetClassPtr; + } else { + newObjv[3] = Tcl_NewStringObj("", -1); + } + Tcl_IncrRefCount(newObjv[3]); + if (ioPtr->iclsPtr->hullTypePtr != NULL) { + newObjv[4] = ioPtr->iclsPtr->hullTypePtr; + } else { + newObjv[4] = Tcl_NewStringObj("", -1); + } + Tcl_IncrRefCount(newObjv[4]); + memcpy(newObjv + 5, objv, (objc * sizeof(Tcl_Obj *))); + result = Tcl_EvalObjv(interp, objc+5, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[2]); + Tcl_DecrRefCount(newObjv[3]); + Tcl_DecrRefCount(newObjv[4]); + ckfree((char *)newObjv); + if (result != TCL_OK) { + ioPtr->hadConstructorError = 15; + goto errorReturn; + } + } + objName = name; + if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { + /* use a temporary name here as widgetadaptors often hijack the + * name for use in installhull. Rename it after the constructor has + * been run to the wanted name + */ + /* + * Add a unique part, and keep + * incrementing a counter until a valid name is found. + */ + do { + Tcl_CmdInfo dummy; + + sprintf(unique,"%.200s_%d", name, iclsPtr->unique++); + unique[0] = tolower(UCHAR(unique[0])); + + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, unique, -1); + objName = Tcl_DStringValue(&buffer); + + /* + * [Fix 227811] Check for any command with the + * given name, not only objects. + */ + + if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) { + break; /* if an error is found, bail out! */ + } + } while (1); + ioPtr->createNamePtr = Tcl_NewStringObj(objName, -1); + } + + { + Tcl_Obj *tmp = Tcl_NewObj(); + + Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(ioPtr->oPtr), tmp); + Itcl_RenameCommand(interp, Tcl_GetString(tmp), objName); + Tcl_TraceCommand(interp, objName, + TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, ioPtr); + Tcl_DecrRefCount(tmp); + } + Tcl_ObjectSetMethodNameMapper(ioPtr->oPtr, ItclMapMethodNameProc); + + ioPtr->accessCmd = Tcl_GetObjectCommand(ioPtr->oPtr); + Tcl_GetCommandInfoFromToken(ioPtr->accessCmd, &cmdInfo); + cmdInfo.deleteProc = (void *)ItclDestroyObject; + cmdInfo.deleteData = ioPtr; + Tcl_SetCommandInfoFromToken(ioPtr->accessCmd, &cmdInfo); + ioPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve)); + ioPtr->resolvePtr->cmdProcPtr = Itcl_CmdAliasProc; + ioPtr->resolvePtr->varProcPtr = Itcl_VarAliasProc; + resolveInfoPtr = (ItclResolveInfo *)ckalloc(sizeof(ItclResolveInfo)); + memset (resolveInfoPtr, 0, sizeof(ItclResolveInfo)); + resolveInfoPtr->flags = ITCL_RESOLVE_OBJECT; + resolveInfoPtr->ioPtr = ioPtr; + ioPtr->resolvePtr->clientData = resolveInfoPtr; + + Tcl_ObjectSetMetadata(ioPtr->oPtr, iclsPtr->infoPtr->object_meta_type, + ioPtr); + + /* make the object known, if it is used in the constructor already! */ + hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objectCmds, + (char*)ioPtr->accessCmd, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + + hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objects, + (char*)ioPtr, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + + /* Use the TclOO object namespaces as a unique key in case the + * object is renamed. Used by mytypemethod, etc. */ + + hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->instances, + (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + + /* + * Now construct the object. Look for a constructor in the + * most-specific class, and if there is one, invoke it. + * This will cause a chain reaction, making sure that all + * base classes constructors are invoked as well, in order + * from least- to most-specific. Any constructors that are + * not called out explicitly in "initCode" code fragments are + * invoked implicitly without arguments. + */ + ItclShowArgs(1, "OBJECTCONSTRUCTOR", objc, objv); + ioPtr->hadConstructorError = 0; + result = Itcl_InvokeMethodIfExists(interp, "constructor", + iclsPtr, ioPtr, objc, objv); + if (ioPtr->hadConstructorError) { + result = TCL_ERROR; + } + ioPtr->hadConstructorError = -1; + if (result != TCL_OK) { + istate = Itcl_SaveInterpState(interp, result); + ItclDeleteObjectVariablesNamespace(interp, ioPtr); + if (ioPtr->accessCmd != (Tcl_Command) NULL) { + Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd); + ioPtr->accessCmd = NULL; + } + result = Itcl_RestoreInterpState(interp, istate); + infoPtr->currIoPtr = saveCurrIoPtr; + /* need this for 2 ReleaseData at errorReturn!! */ + ItclPreserveObject(ioPtr); + goto errorReturn; + } else { + /* a constructor cannot return a result as the object name + * is returned as result */ + Tcl_ResetResult(interp); + } + + /* + * If there is no constructor, construct the base classes + * in case they have constructors. This will cause the + * same chain reaction. + */ + objPtr = Tcl_NewStringObj("constructor", -1); + if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr) == NULL) { + result = Itcl_ConstructBase(interp, ioPtr, iclsPtr); + } + Tcl_DecrRefCount(objPtr); + + if (iclsPtr->flags & ITCL_ECLASS) { + ItclInitExtendedClassOptions(interp, ioPtr); + if (ItclInitObjectOptions(interp, ioPtr, iclsPtr) != TCL_OK) { + Tcl_AppendResult(interp, "error in ItclInitObjectOptions", + NULL); + result = TCL_ERROR; + goto errorReturn; + } + } + /* + * If construction failed, then delete the object access + * command. This will destruct the object and delete the + * object data. Be careful to save and restore the interpreter + * state, since the destructors may generate errors of their own. + */ + if (result != TCL_OK) { + istate = Itcl_SaveInterpState(interp, result); + + /* Bug 227824. + * The constructor may destroy the object, possibly indirectly + * through the destruction of the main widget in the iTk + * megawidget it tried to construct. If this happens we must + * not try to destroy the access command a second time. + */ + if (ioPtr->accessCmd != (Tcl_Command) NULL) { + Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd); + ioPtr->accessCmd = NULL; + } + result = Itcl_RestoreInterpState(interp, istate); + /* need this for 2 ReleaseData at errorReturn!! */ + ItclPreserveObject(ioPtr); + goto errorReturn; + } + + if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { + + if (saveNsNamePtr) { + Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name, + saveNsNamePtr, 0); + Tcl_DecrRefCount(saveNsNamePtr); + saveNsNamePtr = NULL; + } + + Itcl_RenameCommand(interp, objName, name); + ioPtr->createNamePtr = NULL; + Tcl_TraceCommand(interp, Tcl_GetString(ioPtr->namePtr), + TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, ioPtr); + } + if (iclsPtr->flags & (ITCL_WIDGETADAPTOR)) { + /* + * set all the init values for options + */ + + objPtr = Tcl_NewStringObj( + ITCL_NAMESPACE"::internal::commands::widgetinitobjectoptions ", + -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(ioPtr->varNsNamePtr), -1); + Tcl_AppendToObj(objPtr, " ", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(ioPtr->namePtr), -1); + Tcl_AppendToObj(objPtr, " ", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); + if (result != TCL_OK) { + infoPtr->currIoPtr = saveCurrIoPtr; + result = TCL_ERROR; + goto errorReturn; + } + } + if (iclsPtr->flags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + /* FIXME have to check for hierarchy if ITCL_ECLASS !! */ + result = ItclCheckForInitializedComponents(interp, ioPtr->iclsPtr, + ioPtr); + if (result != TCL_OK) { + istate = Itcl_SaveInterpState(interp, result); + if (ioPtr->accessCmd != (Tcl_Command) NULL) { + Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd); + ioPtr->accessCmd = NULL; + } + result = Itcl_RestoreInterpState(interp, istate); + /* need this for 2 ReleaseData at errorReturn!! */ + ItclPreserveObject(ioPtr); + goto errorReturn; + } + } + + /* + * Add it to the list of all known objects. The only + * tricky thing to watch out for is the case where the + * object deleted itself inside its own constructor. + * In that case, we don't want to add the object to + * the list of valid objects. We can determine that + * the object deleted itself by checking to see if + * its accessCmd member is NULL. + */ + if (result == TCL_OK && (ioPtr->accessCmd != NULL)) { + + if (!(ioPtr->iclsPtr->flags & ITCL_CLASS)) { + result = DelegationInstall(interp, ioPtr, iclsPtr); + if (result != TCL_OK) { + goto errorReturn; + } + } + hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objectCmds, + (char*)ioPtr->accessCmd, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objects, + (char*)ioPtr, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + + /* + * This is an inelegant hack, left behind until the need for it + * can be eliminated by getting the inheritance tree right. + */ + + if (iclsPtr->flags + & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + Tcl_NewInstanceMethod(interp, ioPtr->oPtr, + Tcl_NewStringObj("unknown", -1), 0, + &itclRootMethodType, ItclUnknownGuts); + } + + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); + if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { + /* skip over the leading :: */ + char *objName; + char *lastObjName; + lastObjName = Tcl_GetString(objPtr); + objName = lastObjName; + while (1) { + objName = strstr(objName, "::"); + if (objName == NULL) { + break; + } + objName += 2; + lastObjName = objName; + } + + Tcl_AppendResult(interp, lastObjName, NULL); + } else { + Tcl_AppendResult(interp, Tcl_GetString(objPtr), NULL); + } + Tcl_DecrRefCount(objPtr); + } + } else { + if (ioPtr->accessCmd != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->objectCmds, + (char*)ioPtr->accessCmd); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + } + } + + /* + * Release the object. If it was destructed above, it will + * die at this point. + */ + /* + * At this point, the object is fully constructed. + * Destroy the "constructed" table in the object data, since + * it is no longer needed. + */ + if (infoPtr != NULL) { + infoPtr->currIoPtr = saveCurrIoPtr; + } + infoPtr->lastIoPtr = ioPtr; + Tcl_DeleteHashTable(ioPtr->constructed); + ckfree((char*)ioPtr->constructed); + ioPtr->constructed = NULL; + ItclAddObjectsDictInfo(interp, ioPtr); + ItclReleaseObject(ioPtr); + return result; + +errorReturn: + /* + * At this point, the object is not constructed as there was an error. + * Destroy the "constructed" table in the object data, since + * it is no longer needed. + */ + if (saveNsNamePtr) { + Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name, + saveNsNamePtr, 0); + Tcl_DecrRefCount(saveNsNamePtr); + saveNsNamePtr = NULL; + } + if (infoPtr != NULL) { + infoPtr->lastIoPtr = ioPtr; + infoPtr->currIoPtr = saveCurrIoPtr; + } + if (ioPtr->constructed != NULL) { + Tcl_DeleteHashTable(ioPtr->constructed); + ckfree((char*)ioPtr->constructed); + ioPtr->constructed = NULL; + } + ItclDeleteObjectVariablesNamespace(interp, ioPtr); + ItclReleaseObject(ioPtr); + ItclReleaseObject(ioPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclInitObjectCommands() + * + * Init all instance commands. + * This is usually invoked automatically + * by Itcl_CreateObject(), when an object is created. + * ------------------------------------------------------------------------ + */ +static int +ItclInitObjectCommands( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr, + const char *name) +{ +#ifdef NEW_PROTO_RESOLVER + Tcl_HashEntry *hPtr; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Command cmdPtr; + Tcl_Obj *objPtr; + Tcl_Namespace *nsPtr; + ItclClass *iclsPtr2; + ItclClass *lastIclsPtr; + ItclHierIter hier; + ItclMemberFunc *imPtr; + ItclCmdLookup *clookup; + ItclCmdLookup *info_clookup; + + info_clookup = NULL; + lastIclsPtr = NULL; + Tcl_ResetResult(interp); + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + entry = Tcl_FirstHashEntry(&iclsPtr2->functions, &place); + while (entry) { + imPtr = (ItclMemberFunc *)Tcl_GetHashValue(entry); + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, + (char *)imPtr->namePtr); + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + cmdPtr = imPtr->accessCmd; + nsPtr = iclsPtr->nsPtr; + if ((imPtr->flags & ITCL_COMMON) == 0) { + cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, + Tcl_GetString(imPtr->namePtr), clookup->classCmdInfoPtr, + cmdPtr, iclsPtr->nsPtr); + } else { + cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, + Tcl_GetString(imPtr->namePtr), clookup->classCmdInfoPtr, + cmdPtr, iclsPtr->nsPtr); + } + entry = Tcl_NextHashEntry(&place); + } + lastIclsPtr = iclsPtr2; + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + + /* add some builtin functions to every class!! */ + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + objPtr = Tcl_NewStringObj("info", -1); + hPtr = Tcl_FindHashEntry(&iclsPtr2->resolveCmds, objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, "info", + clookup->classCmdInfoPtr, cmdPtr, iclsPtr->nsPtr); + } + objPtr = Tcl_NewStringObj("isa", -1); + hPtr = Tcl_FindHashEntry(&iclsPtr2->resolveCmds, objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, "isa", + clookup->classCmdInfoPtr, cmdPtr, iclsPtr->nsPtr); + } + objPtr = Tcl_NewStringObj("setget", -1); + hPtr = Tcl_FindHashEntry(&iclsPtr2->resolveCmds, objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr != NULL) { + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, "setget", + clookup->classCmdInfoPtr, cmdPtr, iclsPtr->nsPtr); + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); +#endif + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclInitObjectVariables() + * + * Init all instance variables and create the necessary variable namespaces + * for the given object instance. This is usually invoked automatically + * by Itcl_CreateObject(), when an object is created. + * ------------------------------------------------------------------------ + */ +static int +ItclInitObjectVariables( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr) +{ + Tcl_DString buffer; + Tcl_DString buffer2; + Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr2; + Tcl_HashSearch place; + Tcl_Namespace *varNsPtr; + Tcl_Namespace *varNsPtr2; + Tcl_CallFrame frame; + Tcl_Var varPtr; + ItclClass *iclsPtr2; + ItclHierIter hier; + ItclVariable *ivPtr; + ItclComponent *icPtr; +#ifdef NEW_PROTO_RESOLVER + ItclVarLookup *vlookup; +#endif + const char *varName; + const char *inheritComponentName; + int itclOptionsIsSet; + int isNew; + + ivPtr = NULL; + /* + * create all the variables for each class in the + * ::itcl::variables::<object namespace>::<class> namespace as an + * undefined variable using the Tcl "variable xx" command + */ + itclOptionsIsSet = 0; + inheritComponentName = NULL; + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + Tcl_ResetResult(interp); + while (iclsPtr2 != NULL) { + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, -1); + Tcl_DStringAppend(&buffer, iclsPtr2->nsPtr->fullName, -1); + varNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), + NULL, 0); + if (varNsPtr == NULL) { + varNsPtr = Tcl_CreateNamespace(interp, Tcl_DStringValue(&buffer), + NULL, 0); + } + /* now initialize the variables which have an init value */ + if (Itcl_PushCallFrame(interp, &frame, varNsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + goto errorCleanup2; + } + hPtr = Tcl_FirstHashEntry(&iclsPtr2->variables, &place); + while (hPtr) { + ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); + varName = Tcl_GetString(ivPtr->namePtr); + if ((ivPtr->flags & ITCL_OPTIONS_VAR) && !itclOptionsIsSet) { + /* this is the special code for the "itcl_options" variable */ + itclOptionsIsSet = 1; + Tcl_DStringInit(&buffer2); + Tcl_DStringAppend(&buffer2, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, -1); + varNsPtr2 = Tcl_FindNamespace(interp, + Tcl_DStringValue(&buffer2), NULL, 0); + if (varNsPtr2 == NULL) { + varNsPtr2 = Tcl_CreateNamespace(interp, + Tcl_DStringValue(&buffer2), NULL, 0); + } + Tcl_DStringFree(&buffer2); + Itcl_PopCallFrame(interp); + /* now initialize the variables which have an init value */ + if (Itcl_PushCallFrame(interp, &frame, varNsPtr2, + /*isProcCallFrame*/0) != TCL_OK) { + goto errorCleanup2; + } + Tcl_TraceVar2(interp, "itcl_options", + NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, + ItclTraceOptionVar, (ClientData)ioPtr); + Itcl_PopCallFrame(interp); + if (Itcl_PushCallFrame(interp, &frame, varNsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + goto errorCleanup2; + } + hPtr = Tcl_NextHashEntry(&place); + continue; + } + if (ivPtr->flags & ITCL_COMPONENT_VAR) { + hPtr2 = Tcl_FindHashEntry(&ivPtr->iclsPtr->components, + (char *)ivPtr->namePtr); + if (hPtr2 == NULL) { + Tcl_AppendResult(interp, "cannot find component \"", + Tcl_GetString(ivPtr->namePtr), "\" in class \"", + Tcl_GetString(ivPtr->iclsPtr->namePtr), NULL); + goto errorCleanup; + } + icPtr = Tcl_GetHashValue(hPtr2); + if (icPtr->flags & ITCL_COMPONENT_INHERIT) { + if (inheritComponentName != NULL) { + Tcl_AppendResult(interp, "object \"", + Tcl_GetString(ioPtr->namePtr), + "\" can only have one component with inherit.", + " Had already component \"", + inheritComponentName, + "\" now component \"", + Tcl_GetString(icPtr->namePtr), "\"", NULL); + goto errorCleanup; + + } else { + inheritComponentName = Tcl_GetString(icPtr->namePtr); + } + } + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectComponents, + (char *)ivPtr->namePtr, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr2, icPtr); + } + /* this is a component variable */ + /* FIXME initialize it to the empty string */ + /* the initialization is arguable, should it be done? */ + if (Tcl_SetVar2(interp, varName, NULL, + "", TCL_NAMESPACE_ONLY) == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR cannot set", + " variable \"", varName, "\"\n", NULL); + goto errorCleanup; + } + } + hPtr2 = Tcl_FindHashEntry(&ivPtr->iclsPtr->resolveVars, varName); + if (hPtr2 == NULL) { + hPtr = Tcl_NextHashEntry(&place); + continue; + } +#ifdef NEW_PROTO_RESOLVER + vlookup = Tcl_GetHashValue(hPtr2); +#endif + if ((ivPtr->flags & ITCL_COMMON) == 0) { +#ifndef NEW_PROTO_RESOLVER + varPtr = Tcl_NewNamespaceVar(interp, varNsPtr, + Tcl_GetString(ivPtr->namePtr)); +#else + varPtr = Itcl_RegisterObjectVariable(interp, ioPtr, + Tcl_GetString(ivPtr->namePtr), vlookup->classVarInfoPtr, + NULL, varNsPtr); +#endif + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectVariables, + (char *)ivPtr, &isNew); + if (isNew) { + Itcl_PreserveVar(varPtr); + Tcl_SetHashValue(hPtr2, varPtr); + } else { + } + if (ivPtr->flags & (ITCL_THIS_VAR|ITCL_TYPE_VAR| + ITCL_SELF_VAR|ITCL_SELFNS_VAR|ITCL_WIN_VAR)) { + int isDone = 0; + if (Tcl_SetVar2(interp, varName, NULL, + "", TCL_NAMESPACE_ONLY) == NULL) { + Tcl_AppendResult(interp, "INTERNAL ERROR cannot set", + " variable \"", varNsPtr->fullName, "::", + varName, "\"\n", NULL); + goto errorCleanup; + } + if (ivPtr->flags & ITCL_THIS_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar, + (ClientData)ioPtr); + isDone = 1; + } + if (!isDone && ivPtr->flags & ITCL_TYPE_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceTypeVar, + (ClientData)ioPtr); + isDone = 1; + } + if (!isDone && ivPtr->flags & ITCL_SELF_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceSelfVar, + (ClientData)ioPtr); + isDone = 1; + } + if (!isDone && ivPtr->flags & ITCL_SELFNS_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceSelfnsVar, + (ClientData)ioPtr); + isDone = 1; + } + if (!isDone && ivPtr->flags & ITCL_WIN_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceWinVar, + (ClientData)ioPtr); + isDone = 1; + } + } else { + if (ivPtr->flags & ITCL_HULL_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, + ItclTraceItclHullVar, + (ClientData)ioPtr); + } else { + if (ivPtr->init != NULL) { + if (Tcl_SetVar(interp, + Tcl_GetString(ivPtr->namePtr), + Tcl_GetString(ivPtr->init), + TCL_NAMESPACE_ONLY) == NULL) { + goto errorCleanup; + } + } + if (ivPtr->arrayInitPtr != NULL) { + Tcl_DString buffer3; + int i; + int argc; + const char **argv; + const char *val; + + Tcl_DStringInit(&buffer3); + Tcl_DStringAppend(&buffer3, varNsPtr->fullName, -1); + Tcl_DStringAppend(&buffer3, "::", -1); + Tcl_DStringAppend(&buffer3, + Tcl_GetString(ivPtr->namePtr), -1); + Tcl_SplitList(interp, + Tcl_GetString(ivPtr->arrayInitPtr), + &argc, &argv); + for (i = 0; i < argc; i++) { + val = Tcl_SetVar2(interp, + Tcl_DStringValue(&buffer3), argv[i], + argv[i + 1], TCL_NAMESPACE_ONLY); + if (!val) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot initialize variable \"", + Tcl_GetString(ivPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + i++; + } + Tcl_DStringFree(&buffer3); + ckfree((char *)argv); + } + } + } + } else { + if (ivPtr->flags & ITCL_HULL_VAR) { + Tcl_TraceVar2(interp, varName, NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, + ItclTraceItclHullVar, + (ClientData)ioPtr); + } + hPtr2 = Tcl_FindHashEntry(&iclsPtr2->classCommons, + (char *)ivPtr); + if (hPtr2 == NULL) { + goto errorCleanup; + } + varPtr = Tcl_GetHashValue(hPtr2); + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectVariables, + (char *)ivPtr, &isNew); + if (isNew) { + Itcl_PreserveVar(varPtr); + Tcl_SetHashValue(hPtr2, varPtr); + } else { +#ifdef NEW_PROTO_RESOLVER + varPtr = Itcl_RegisterObjectVariable(interp, ioPtr, + Tcl_GetString(ivPtr->namePtr), + vlookup->classVarInfoPtr, + varPtr, varNsPtr); +#endif + } + if (ivPtr->flags & ITCL_COMPONENT_VAR) { + if (ivPtr->flags & ITCL_COMMON) { + Tcl_Obj *objPtr2; + objPtr2 = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, + -1); + Tcl_AppendToObj(objPtr2, (Tcl_GetObjectNamespace( + ivPtr->iclsPtr->oPtr))->fullName, -1); + Tcl_AppendToObj(objPtr2, "::", -1); + Tcl_AppendToObj(objPtr2, varName, -1); + /* itcl_hull is traced in itclParse.c */ + if (strcmp(varName, "itcl_hull") == 0) { + Tcl_TraceVar2(interp, + Tcl_GetString(objPtr2), NULL, + TCL_TRACE_WRITES, ItclTraceItclHullVar, + (ClientData)ioPtr); + } else { + Tcl_TraceVar2(interp, + Tcl_GetString(objPtr2), NULL, + TCL_TRACE_WRITES, ItclTraceComponentVar, + (ClientData)ioPtr); + } + Tcl_DecrRefCount(objPtr2); + } else { + Tcl_TraceVar2(interp, + varName, NULL, + TCL_TRACE_WRITES, ItclTraceComponentVar, + (ClientData)ioPtr); + } + } + } + hPtr = Tcl_NextHashEntry(&place); + } + Itcl_PopCallFrame(interp); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Tcl_DStringFree(&buffer); + Itcl_DeleteHierIter(&hier); + return TCL_OK; +errorCleanup: + Itcl_PopCallFrame(interp); +errorCleanup2: + varNsPtr = Tcl_FindNamespace(interp, Tcl_GetString(ioPtr->varNsNamePtr), + NULL, 0); + if (varNsPtr != NULL) { + Tcl_DeleteNamespace(varNsPtr); + } + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * ItclInitObjectOptions() + * + * Collect all instance options for the given object instance to allow + * faster runtime access to the options. + * if the same option name is used in more than one class the first one + * found is used (for initializing and for the class name)!! + * # It is assumed, that an option can only exist in one class?? + * # So no duplicates allowed?? + * This is usually invoked automatically by Itcl_CreateObject(), + * when an object is created. + * ------------------------------------------------------------------------ + */ +int +ItclInitObjectOptions( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr) +{ + Tcl_DString buffer; + Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr2; + Tcl_HashSearch place; + Tcl_CallFrame frame; + Tcl_Namespace *varNsPtr; + ItclClass *iclsPtr2; + ItclHierIter hier; + ItclOption *ioptPtr; + ItclDelegatedOption *idoPtr; + int isNew; + + ioptPtr = NULL; + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + /* now initialize the options which have an init value */ + hPtr = Tcl_FirstHashEntry(&iclsPtr2->options, &place); + while (hPtr) { + ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectOptions, + (char *)ioptPtr->namePtr, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr2, ioptPtr); + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(ioPtr->oPtr)->fullName), -1); + varNsPtr = Tcl_FindNamespace(interp, + Tcl_DStringValue(&buffer), NULL, 0); + if (varNsPtr == NULL) { + varNsPtr = Tcl_CreateNamespace(interp, + Tcl_DStringValue(&buffer), NULL, 0); + } + Tcl_DStringFree(&buffer); + /* now initialize the options which have an init value */ + if (Itcl_PushCallFrame(interp, &frame, varNsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + return TCL_ERROR; + } + if ((ioptPtr != NULL) && (ioptPtr->namePtr != NULL) && + (ioptPtr->defaultValuePtr != NULL)) { + if (Tcl_SetVar2(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), + Tcl_GetString(ioptPtr->defaultValuePtr), + TCL_NAMESPACE_ONLY) == NULL) { + Itcl_PopCallFrame(interp); + return TCL_ERROR; + } + Tcl_TraceVar2(interp, "itcl_options", + NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, + ItclTraceOptionVar, (ClientData)ioPtr); + } + Itcl_PopCallFrame(interp); + } + hPtr = Tcl_NextHashEntry(&place); + } + /* now check for options which are delegated */ + hPtr = Tcl_FirstHashEntry(&iclsPtr2->delegatedOptions, &place); + while (hPtr) { + idoPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions, + (char *)idoPtr->namePtr, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr2, idoPtr); + } + hPtr = Tcl_NextHashEntry(&place); + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclInitObjectMethodVariables() + * + * Collect all instance methdovariables for the given object instance to allow + * faster runtime access to the methdovariables. + * This is usually invoked automatically by Itcl_CreateObject(), + * when an object is created. + * ------------------------------------------------------------------------ + */ +int +ItclInitObjectMethodVariables( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr, + const char *name) +{ + ItclClass *iclsPtr2; + ItclHierIter hier; + ItclMethodVariable *imvPtr; + Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr2; + Tcl_HashSearch place; + int isNew; + + imvPtr = NULL; + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + hPtr = Tcl_FirstHashEntry(&iclsPtr2->methodVariables, &place); + while (hPtr) { + imvPtr = (ItclMethodVariable*)Tcl_GetHashValue(hPtr); + hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectMethodVariables, + (char *)imvPtr->namePtr, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr2, imvPtr); + } + hPtr = Tcl_NextHashEntry(&place); + } + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteObject() + * + * Attempts to delete an object by invoking its destructor. + * + * If the destructor is successful, then the object is deleted by + * removing its access command, and this procedure returns TCL_OK. + * Otherwise, the object will remain alive, and this procedure + * returns TCL_ERROR (along with an error message in the interpreter). + * ------------------------------------------------------------------------ + */ +int +Itcl_DeleteObject( + Tcl_Interp *interp, /* interpreter mananging object */ + ItclObject *contextIoPtr) /* object to be deleted */ +{ + Tcl_CmdInfo cmdInfo; + Tcl_HashEntry *hPtr; + + + Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo); + + contextIoPtr->flags |= ITCL_OBJECT_IS_DELETED; + ItclPreserveObject(contextIoPtr); + + /* + * Invoke the object's destructors. + */ + if (Itcl_DestructObject(interp, contextIoPtr, 0) != TCL_OK) { + ItclReleaseObject(contextIoPtr); + contextIoPtr->flags |= + ITCL_TCLOO_OBJECT_IS_DELETED|ITCL_OBJECT_DESTRUCT_ERROR; + return TCL_ERROR; + } + /* + * Remove the object from the global list. + */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->infoPtr->objects, + (char*)contextIoPtr); + + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Change the object's access command so that it can be + * safely deleted without attempting to destruct the object + * again. Then delete the access command. If this is + * the last use of the object data, the object will die here. + */ + if ((contextIoPtr->accessCmd != NULL) && (!(contextIoPtr->flags & + (ITCL_OBJECT_IS_RENAMED)))) { + if (Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo) == 1) { + cmdInfo.deleteProc = ItclReleaseObject; + Tcl_SetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo); + + Tcl_DeleteCommandFromToken(interp, contextIoPtr->accessCmd); + } + } + contextIoPtr->oPtr = NULL; + contextIoPtr->accessCmd = NULL; + + ItclReleaseObject(contextIoPtr); + + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclDeleteObjectVariablesNamespace() + * + * ------------------------------------------------------------------------ + */ +void +ItclDeleteObjectVariablesNamespace( + Tcl_Interp *interp, + ItclObject *ioPtr) +{ + Tcl_Namespace *varNsPtr; + + if (ioPtr->callRefCount < 1) { + /* free the object's variables namespace and variables in it */ + ioPtr->flags &= ~ITCL_OBJECT_SHOULD_VARNS_DELETE; + varNsPtr = Tcl_FindNamespace(interp, Tcl_GetString(ioPtr->varNsNamePtr), + NULL, 0); + if (varNsPtr != NULL) { + Tcl_DeleteNamespace(varNsPtr); + } + } else { + ioPtr->flags |= ITCL_OBJECT_SHOULD_VARNS_DELETE; + } +} + +static int +FinalizeDeleteObject( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ItclObject *contextIoPtr = data[0]; + if (result == TCL_OK) { + ItclDeleteObjectVariablesNamespace(interp, contextIoPtr); + Tcl_ResetResult(interp); + } + + Tcl_DeleteHashTable(contextIoPtr->destructed); + ckfree((char*)contextIoPtr->destructed); + contextIoPtr->destructed = NULL; + return result; +} + +static int +CallDestructBase( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *objPtr; + ItclObject *contextIoPtr = data[0]; + int flags = PTR2INT(data[1]); + + if (result != TCL_OK) { + return result; + } + result = ItclDestructBase(interp, contextIoPtr, contextIoPtr->iclsPtr, + flags); + if (result != TCL_OK) { + return result; + } + /* destroy the hull */ + if (contextIoPtr->hullWindowNamePtr != NULL) { + objPtr = Tcl_NewStringObj("destroy ", -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(contextIoPtr->hullWindowNamePtr), -1); + result = Tcl_EvalObjEx(interp, objPtr, 0); + } + return result; +} +/* + * ------------------------------------------------------------------------ + * Itcl_DestructObject() + * + * Invokes the destructor for a particular object. Usually invoked + * by Itcl_DeleteObject() or Itcl_DestroyObject() as a part of the + * object destruction process. If the ITCL_IGNORE_ERRS flag is + * included, all destructors are invoked even if errors are + * encountered, and the result will always be TCL_OK. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_DestructObject( + Tcl_Interp *interp, /* interpreter mananging new object */ + ItclObject *contextIoPtr, /* object to be destructed */ + int flags) /* flags: ITCL_IGNORE_ERRS */ +{ + int result; + + if ((contextIoPtr->flags & (ITCL_OBJECT_IS_DESTRUCTED))) { + return TCL_OK; + } + contextIoPtr->flags |= ITCL_OBJECT_IS_DESTRUCTED; + /* + * If there is a "destructed" table, then this object is already + * being destructed. Flag an error, unless errors are being + * ignored. + */ + if (contextIoPtr->destructed) { + if ((flags & ITCL_IGNORE_ERRS) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't delete an object while it is being destructed", + (char*)NULL); + return TCL_ERROR; + } + return TCL_OK; + } + + result = TCL_OK; + if (contextIoPtr->oPtr != NULL) { + void *callbackPtr; + /* + * Create a "destructed" table to keep track of which destructors + * have been invoked. This is used in ItclDestructBase to make + * sure that all base class destructors have been called, + * explicitly or implicitly. + */ + contextIoPtr->destructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(contextIoPtr->destructed); + + /* + * Destruct the object starting from the most-specific class. + * If all goes well, return the null string as the result. + */ + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + Tcl_NRAddCallback(interp, FinalizeDeleteObject, contextIoPtr, + NULL, NULL, NULL); + Tcl_NRAddCallback(interp, CallDestructBase, contextIoPtr, + INT2PTR(flags), NULL, NULL); + result = Itcl_NRRunCallbacks(interp, callbackPtr); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclDestructBase() + * + * Invoked by Itcl_DestructObject() to recursively destruct an object + * from the specified class level. Finds and invokes the destructor + * for the specified class, and then recursively destructs all base + * classes. If the ITCL_IGNORE_ERRS flag is included, all destructors + * are invoked even if errors are encountered, and the result will + * always be TCL_OK. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in interp->result) on error. + * ------------------------------------------------------------------------ + */ +static int +ItclDestructBase( + Tcl_Interp *interp, /* interpreter */ + ItclObject *contextIoPtr, /* object being destructed */ + ItclClass *contextIclsPtr, /* current class being destructed */ + int flags) /* flags: ITCL_IGNORE_ERRS */ +{ + int result; + Itcl_ListElem *elem; + ItclClass *iclsPtr; + + if (contextIoPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED) { + return TCL_OK; + } + /* + * Look for a destructor in this class, and if found, + * invoke it. + */ + if (Tcl_FindHashEntry(contextIoPtr->destructed, + (char *)contextIclsPtr->namePtr) == NULL) { + result = Itcl_InvokeMethodIfExists(interp, "destructor", + contextIclsPtr, contextIoPtr, 0, (Tcl_Obj* const*)NULL); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + + /* + * Scan through the list of base classes recursively and destruct + * them. Traverse the list in normal order, so that we destruct + * from most- to least-specific. + */ + elem = Itcl_FirstListElem(&contextIclsPtr->bases); + while (elem) { + iclsPtr = (ItclClass*)Itcl_GetListValue(elem); + + if (ItclDestructBase(interp, contextIoPtr, iclsPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + elem = Itcl_NextListElem(elem); + } + + /* + * Throw away any result from the destructors and return. + */ + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_FindObject() + * + * Searches for an object with the specified name, which have + * namespace scope qualifiers like "namesp::namesp::name", or may + * be a scoped value such as "namespace inscope ::foo obj". + * + * If an error is encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK. If an object was found, "roPtr" returns a + * pointer to the object data. Otherwise, it returns NULL. + * ------------------------------------------------------------------------ + */ +int +Itcl_FindObject( + Tcl_Interp *interp, /* interpreter containing this object */ + const char *name, /* name of the object */ + ItclObject **roPtr) /* returns: object data or NULL */ +{ + Tcl_Command cmd; + Tcl_CmdInfo cmdInfo; + Tcl_Namespace *contextNs; + char *cmdName; + + contextNs = NULL; + cmdName = NULL; + /* + * The object name may be a scoped value of the form + * "namespace inscope <namesp> <command>". If it is, + * decode it. + */ + if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Look for the object's access command, and see if it has + * the appropriate command handler. + */ + cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0); + if (cmd != NULL && Itcl_IsObject(cmd)) { + if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) { + *roPtr = NULL; + } + *roPtr = cmdInfo.deleteData; + } else { + *roPtr = NULL; + } + + ckfree(cmdName); + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsObject() + * + * Checks the given Tcl command to see if it represents an itcl object. + * Returns non-zero if the command is associated with an object. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsObject( + Tcl_Command cmd) /* command being tested */ +{ + Tcl_CmdInfo cmdInfo; + + if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) { + return 0; + } + + if ((void *)cmdInfo.deleteProc == (void *)ItclDestroyObject) { + return 1; + } + + /* + * This may be an imported command. Try to get the real + * command and see if it represents an object. + */ + cmd = Tcl_GetOriginalCommand(cmd); + if (cmd != NULL) { + if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) { + return 0; + } + + if ((void *)cmdInfo.deleteProc == (void *)ItclDestroyObject) { + return 1; + } + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ObjectIsa() + * + * Checks to see if an object belongs to the given class. An object + * "is-a" member of the class if the class appears anywhere in its + * inheritance hierarchy. Returns non-zero if the object belongs to + * the class, and zero otherwise. + * ------------------------------------------------------------------------ + */ +int +Itcl_ObjectIsa( + ItclObject *contextIoPtr, /* object being tested */ + ItclClass *iclsPtr) /* class to test for "is-a" relationship */ +{ + Tcl_HashEntry *entry; + + if (contextIoPtr == NULL) { + return 0; + } + entry = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->heritage, (char*)iclsPtr); + return (entry != NULL); +} + +/* + * ------------------------------------------------------------------------ + * ItclGetInstanceVar() + * + * Returns the current value for an object data member. The member + * name is interpreted with respect to the given class scope, which + * is usually the most-specific class for the object. + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +const char* +ItclGetInstanceVar( + Tcl_Interp *interp, /* current interpreter */ + const char *name1, /* name of desired instance variable */ + const char *name2, /* array element or NULL */ + ItclObject *contextIoPtr, /* current object */ + ItclClass *contextIclsPtr) /* name is interpreted in this scope */ +{ + Tcl_HashEntry *hPtr; + Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; + Tcl_Namespace *nsPtr; + Tcl_DString buffer; + ItclClass *iclsPtr; + ItclVariable *ivPtr; + ItclVarLookup *vlookup; + const char *val; + int isItclOptions; + int doAppend; + + /* + * Make sure that the current namespace context includes an + * object that is being manipulated. + */ + if (contextIoPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot access object-specific info without an object context", + (char*)NULL); + return NULL; + } + + /* get the variable definition to check if that is an ITCL_COMMON */ + if (contextIclsPtr == NULL) { + iclsPtr = contextIoPtr->iclsPtr; + } else { + iclsPtr = contextIclsPtr; + } + ivPtr = NULL; + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)name1); + if (hPtr != NULL) { + vlookup = Tcl_GetHashValue(hPtr); + ivPtr = vlookup->ivPtr; + /* + * Install the object context and access the data member + * like any other variable. + */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr); + if (hPtr) { + Tcl_Obj *varName = Tcl_NewObj(); + Tcl_Var varPtr = Tcl_GetHashValue(hPtr); + Tcl_GetVariableFullName(interp, varPtr, varName); + + val = Tcl_GetVar2(interp, Tcl_GetString(varName), name2, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varName); + if (val) { + return val; + } + } + } + + isItclOptions = 0; + if (strcmp(name1, "itcl_options") == 0) { + isItclOptions = 1; + } + if (strcmp(name1, "itcl_option_components") == 0) { + isItclOptions = 1; + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->varNsNamePtr), -1); + doAppend = 1; + if ((contextIclsPtr == NULL) || (contextIclsPtr->flags & + (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + if (isItclOptions) { + doAppend = 0; + } + } + if ((ivPtr != NULL) && (ivPtr->flags & ITCL_COMMON)) { + if (!isItclOptions) { + Tcl_DStringSetLength(&buffer, 0); + if (ivPtr->protection != ITCL_PUBLIC) { + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + } + doAppend = 1; + } + } + if (doAppend) { + Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace( + contextIclsPtr->oPtr))->fullName, -1); + } + nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + val = NULL; + if (nsPtr != NULL) { + framePtr = &frame; + Itcl_PushCallFrame(interp, framePtr, nsPtr, /*isProcCallFrame*/0); + val = Tcl_GetVar2(interp, (const char *)name1, (char*)name2, + TCL_LEAVE_ERR_MSG); + Itcl_PopCallFrame(interp); + } + + return val; +} + +/* + * ------------------------------------------------------------------------ + * ItclGetCommonInstanceVar() + * + * Returns the current value for an object data member. The member + * name is interpreted with respect to the given class scope, which + * is usually the most-specific class for the object. + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +const char* +ItclGetCommonInstanceVar( + Tcl_Interp *interp, /* current interpreter */ + const char *name1, /* name of desired instance variable */ + const char *name2, /* array element or NULL */ + ItclObject *contextIoPtr, /* current object */ + ItclClass *contextIclsPtr) /* name is interpreted in this scope */ +{ + Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; + Tcl_Namespace *nsPtr; + Tcl_DString buffer; + const char *val; + int doAppend; + + /* + * Make sure that the current namespace context includes an + * object that is being manipulated. + */ + if (contextIoPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot access object-specific info without an object context", + (char*)NULL); + return NULL; + } + + /* + * Install the object context and access the data member + * like any other variable. + */ + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + doAppend = 1; + if ((contextIclsPtr == NULL) || (contextIclsPtr->flags & + (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR))) { + if (strcmp(name1, "itcl_options") == 0) { + doAppend = 0; + } + if (strcmp(name1, "itcl_option_components") == 0) { + doAppend = 0; + } + } + if (doAppend) { + Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace( + contextIclsPtr->oPtr))->fullName, -1); + } + nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + val = NULL; + if (nsPtr != NULL) { + framePtr = &frame; + Itcl_PushCallFrame(interp, framePtr, nsPtr, /*isProcCallFrame*/0); + val = Tcl_GetVar2(interp, (const char *)name1, (char*)name2, + TCL_LEAVE_ERR_MSG); + Itcl_PopCallFrame(interp); + } + + return val; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_GetInstanceVar() + * + * Returns the current value for an object data member. The member + * name is interpreted with respect to the given class scope, which + * is usually the most-specific class for the object. + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +const char* +Itcl_GetInstanceVar( + Tcl_Interp *interp, /* current interpreter */ + const char *name, /* name of desired instance variable */ + ItclObject *contextIoPtr, /* current object */ + ItclClass *contextIclsPtr) /* name is interpreted in this scope */ +{ + return ItclGetInstanceVar(interp, name, NULL, contextIoPtr, + contextIclsPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclSetInstanceVar() + * + * Sets the current value for an object data member. The member + * name is interpreted with respect to the given class scope, which + * is usually the most-specific class for the object. + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +const char* +ItclSetInstanceVar( + Tcl_Interp *interp, /* current interpreter */ + const char *name1, /* name of desired instance variable */ + const char *name2, /* array member or NULL */ + const char *value, /* the value to set */ + ItclObject *contextIoPtr, /* current object */ + ItclClass *contextIclsPtr) /* name is interpreted in this scope */ +{ + Tcl_HashEntry *hPtr; + Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; + Tcl_Namespace *nsPtr; + Tcl_DString buffer; + ItclVariable *ivPtr; + ItclVarLookup *vlookup; + ItclClass *iclsPtr; + const char *val; + int isItclOptions; + int doAppend; + + ivPtr = NULL; + /* + * Make sure that the current namespace context includes an + * object that is being manipulated. + */ + if (contextIoPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot access object-specific info without an object context", + (char*)NULL); + return NULL; + } + /* get the variable definition to check if that is an ITCL_COMMON */ + if (contextIclsPtr == NULL) { + iclsPtr = contextIoPtr->iclsPtr; + } else { + iclsPtr = contextIclsPtr; + } + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)name1); + if (hPtr != NULL) { + vlookup = Tcl_GetHashValue(hPtr); + ivPtr = vlookup->ivPtr; + } else { + return NULL; + } + /* + * Install the object context and access the data member + * like any other variable. + */ + + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr); + if (hPtr) { + Tcl_Obj *varName = Tcl_NewObj(); + Tcl_Var varPtr = Tcl_GetHashValue(hPtr); + Tcl_GetVariableFullName(interp, varPtr, varName); + + val = Tcl_SetVar2(interp, Tcl_GetString(varName), name2, value, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varName); + return val; + } + + isItclOptions = 0; + if (strcmp(name1, "itcl_options") == 0) { + isItclOptions = 1; + } + if (strcmp(name1, "itcl_option_components") == 0) { + isItclOptions = 1; + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->varNsNamePtr), -1); + doAppend = 1; + if ((contextIclsPtr == NULL) || + (contextIclsPtr->flags & (ITCL_ECLASS|ITCL_TYPE| + ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + if (isItclOptions) { + doAppend = 0; + } + } + if (ivPtr->flags & ITCL_COMMON) { + if (!isItclOptions) { + Tcl_DStringSetLength(&buffer, 0); + if (ivPtr->protection != ITCL_PUBLIC) { + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + } + doAppend = 1; + } + } + if (doAppend) { + Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace( + contextIclsPtr->oPtr))->fullName, -1); + } + nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + val = NULL; + if (nsPtr != NULL) { + framePtr = &frame; + Itcl_PushCallFrame(interp, framePtr, nsPtr, /*isProcCallFrame*/0); + val = Tcl_SetVar2(interp, (const char *)name1, (char*)name2, + value, TCL_LEAVE_ERR_MSG); + Itcl_PopCallFrame(interp); + } + + return val; +} + +/* + * ------------------------------------------------------------------------ + * ItclReportObjectUsage() + * + * Appends information to the given interp summarizing the usage + * for all of the methods available for this object. Useful when + * reporting errors in Itcl_HandleInstance(). + * ------------------------------------------------------------------------ + */ +void +ItclReportObjectUsage( + Tcl_Interp *interp, /* current interpreter */ + ItclObject *contextIoPtr, /* current object */ + Tcl_Namespace *callerNsPtr, + Tcl_Namespace *contextNsPtr) /* the context namespace */ +{ + Tcl_Obj *namePtr; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Obj *resultPtr; + ItclClass *iclsPtr = NULL; + Itcl_List cmdList; + Itcl_ListElem *elem; + ItclMemberFunc *imPtr; + ItclMemberFunc *cmpFunc; + ItclCmdLookup *clookup; + ItclObjectInfo * infoPtr = NULL; + char *name; + int ignore; + int cmp; + + if (contextIoPtr == NULL) { + resultPtr = Tcl_GetObjResult(interp); + infoPtr = (ClientData)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + if (infoPtr == NULL) { + Tcl_AppendResult(interp, " PANIC cannot get Itcl AssocData in ItclReportObjectUsage", NULL); + return; + } + if (contextNsPtr == NULL) { + Tcl_AppendResult(interp, " PANIC cannot get contextNsPtr in ItclReportObjectUsage", NULL); + return; + } + + entry = Tcl_FindHashEntry(&infoPtr->namespaceClasses, + (char *)contextNsPtr); + if (entry) { + iclsPtr = Tcl_GetHashValue(entry); + } + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, " PANIC cannot get class from contextNsPtr ItclReportObjectUsage", NULL); + return; + } + } else { + iclsPtr = (ItclClass*)contextIoPtr->iclsPtr; + } + ignore = ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR | ITCL_COMMON; + /* + * Scan through all methods in the virtual table and sort + * them in alphabetical order. Report only the methods + * that have simple names (no ::'s) and are accessible. + */ + Itcl_InitList(&cmdList); + entry = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place); + while (entry) { + namePtr = (Tcl_Obj *)Tcl_GetHashKey(&iclsPtr->resolveCmds, entry); + name = Tcl_GetString(namePtr); + clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); + imPtr = clookup->imPtr; + + if (strstr(name,"::") || (imPtr->flags & ignore) != 0) { + imPtr = NULL; + } else { + if (imPtr->protection != ITCL_PUBLIC) { + if (contextNsPtr != NULL) { + if (!Itcl_CanAccessFunc(imPtr, contextNsPtr)) { + imPtr = NULL; + } + } + } + } + if ((imPtr != NULL) && (imPtr->codePtr != NULL)) { + if (imPtr->codePtr->flags & ITCL_BUILTIN) { + char *body; + if (imPtr->codePtr != NULL) { + body = Tcl_GetString(imPtr->codePtr->bodyPtr); + if (*body == '@') { + if (strcmp(body, "@itcl-builtin-setget") == 0) { + if (!(imPtr->iclsPtr->flags & ITCL_ECLASS)) { + imPtr = NULL; + } + } + if (strcmp(body, "@itcl-builtin-installcomponent") + == 0) { + if (!(imPtr->iclsPtr->flags & + (ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { + imPtr = NULL; + } + } + } + } + } + } + + if (imPtr) { + elem = Itcl_FirstListElem(&cmdList); + while (elem) { + cmpFunc = (ItclMemberFunc*)Itcl_GetListValue(elem); + cmp = strcmp(Tcl_GetString(imPtr->namePtr), + Tcl_GetString(cmpFunc->namePtr)); + if (cmp < 0) { + Itcl_InsertListElem(elem, (ClientData)imPtr); + imPtr = NULL; + break; + } else { + if (cmp == 0) { + imPtr = NULL; + break; + } + } + elem = Itcl_NextListElem(elem); + } + if (imPtr) { + Itcl_AppendList(&cmdList, (ClientData)imPtr); + } + } + entry = Tcl_NextHashEntry(&place); + } + + /* + * Add a series of statements showing usage info. + */ + resultPtr = Tcl_GetObjResult(interp); + elem = Itcl_FirstListElem(&cmdList); + while (elem) { + imPtr = (ItclMemberFunc*)Itcl_GetListValue(elem); + Tcl_AppendToObj(resultPtr, "\n ", -1); + Itcl_GetMemberFuncUsage(imPtr, contextIoPtr, resultPtr); + + elem = Itcl_NextListElem(elem); + } + Itcl_DeleteList(&cmdList); +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceThisVar() + * + * Invoked to handle read/write traces on the "this" variable built + * into each object. + * + * On read, this procedure updates the "this" variable to contain the + * current object name. This is done dynamically, since an object's + * identity can change if its access command is renamed. + * + * On write, this procedure returns an error string, warning that + * the "this" variable cannot be set. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceThisVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + ItclObject *contextIoPtr = (ItclObject*)cdata; + Tcl_Obj *objPtr; + const char *objName; + + /* because of SF bug #187 use a different trace handler for "this", "win", "type" + * *self" and "selfns" + */ + + /* + * Handle read traces on "this" + */ + if ((flags & TCL_TRACE_READS) != 0) { + objPtr = Tcl_NewStringObj("", -1); + if (contextIoPtr->accessCmd) { + Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp, + contextIoPtr->accessCmd, objPtr); + } + objName = Tcl_GetString(objPtr); + Tcl_SetVar(interp, (const char *)name1, objName, 0); + + Tcl_DecrRefCount(objPtr); + return NULL; + } + + /* + * Handle write traces on "this" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return "variable \"this\" cannot be modified"; + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceWinVar() + * + * Invoked to handle read/write traces on the "win" variable built + * into each object. + * + * On read, this procedure updates the "win" variable to contain the + * current object name. This is done dynamically, since an object's + * identity can change if its access command is renamed. + * + * On write, this procedure returns an error string, warning that + * the "win" variable cannot be set. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceWinVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + ItclObject *contextIoPtr = (ItclObject*)cdata; + Tcl_DString buffer; + Tcl_Obj *objPtr; + const char *objName; + const char *head; + const char *tail; + + /* + * Handle read traces on "win" + */ + if ((flags & TCL_TRACE_READS) != 0) { + objPtr = Tcl_NewStringObj("", -1); + /* a window path name must not contain namespace parts !! */ + Itcl_ParseNamespPath(Tcl_GetString(contextIoPtr->origNamePtr), &buffer, &head, &tail); + if (tail == NULL) { + return " INTERNAL ERROR tail == NULL in ItclTraceThisVar for win"; + } + Tcl_SetStringObj(objPtr, tail, -1); + objName = Tcl_GetString(objPtr); + Tcl_SetVar(interp, (const char *)name1, objName, 0); + + Tcl_DecrRefCount(objPtr); + return NULL; + } + + /* + * Handle write traces on "win" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + if (!(contextIoPtr->iclsPtr->flags & ITCL_ECLASS)) { + return "variable \"win\" cannot be modified"; + } + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceTypeVar() + * + * Invoked to handle read/write traces on the "type" variable built + * into each object. + * + * On read, this procedure updates the "type" variable to contain the + * current object name. This is done dynamically, since an object's + * identity can change if its access command is renamed. + * + * On write, this procedure returns an error string, warning that + * the "type" variable cannot be set. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceTypeVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + ItclObject *contextIoPtr = (ItclObject*)cdata; + Tcl_Obj *objPtr; + const char *objName; + + /* + * Handle read traces on "type" + */ + if ((flags & TCL_TRACE_READS) != 0) { + objPtr = Tcl_NewStringObj("", -1); + Tcl_SetStringObj(objPtr, + Tcl_GetCurrentNamespace(contextIoPtr->iclsPtr->interp)->fullName, -1); + objName = Tcl_GetString(objPtr); + Tcl_SetVar(interp, (const char *)name1, objName, 0); + + Tcl_DecrRefCount(objPtr); + return NULL; + } + + /* + * Handle write traces on "type" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return "variable \"type\" cannot be modified"; + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceSelfVar() + * + * Invoked to handle read/write traces on the "self" variable built + * into each object. + * + * On read, this procedure updates the "self" variable to contain the + * current object name. This is done dynamically, since an object's + * identity can change if its access command is renamed. + * + * On write, this procedure returns an error string, warning that + * the "self" variable cannot be set. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceSelfVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + ItclObject *contextIoPtr = (ItclObject*)cdata; + Tcl_Obj *objPtr; + const char *objName; + + /* + * Handle read traces on "self" + */ + if ((flags & TCL_TRACE_READS) != 0) { + objPtr = Tcl_NewStringObj("", -1); + if (contextIoPtr->iclsPtr->flags & + (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + const char *objectName; + + objectName = ItclGetInstanceVar( + contextIoPtr->iclsPtr->interp, + "itcl_hull", NULL, contextIoPtr, + contextIoPtr->iclsPtr); + if (strlen(objectName) == 0) { + objPtr = contextIoPtr->namePtr; + Tcl_IncrRefCount(objPtr); + } else { + Tcl_SetStringObj(objPtr, objectName, -1); + } + } else { + Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp, + contextIoPtr->accessCmd, objPtr); + } + objName = Tcl_GetString(objPtr); + Tcl_SetVar(interp, (const char *)name1, objName, 0); + + Tcl_DecrRefCount(objPtr); + return NULL; + } + + /* + * Handle write traces on "self" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return "variable \"self\" cannot be modified"; + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceSelfnsVar() + * + * Invoked to handle read/write traces on the "selfns" variable built + * into each object. + * + * On read, this procedure updates the "selfns" variable to contain the + * current object name. This is done dynamically, since an object's + * identity can change if its access command is renamed. + * + * On write, this procedure returns an error string, warning that + * the "selfns" variable cannot be set. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceSelfnsVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + ItclObject *contextIoPtr = (ItclObject*)cdata; + Tcl_Obj *objPtr; + const char *objName; + + /* + * Handle read traces on "selfns" + */ + if ((flags & TCL_TRACE_READS) != 0) { + objPtr = Tcl_NewStringObj("", -1); + Tcl_SetStringObj(objPtr, Tcl_GetString(contextIoPtr->varNsNamePtr), -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(contextIoPtr->iclsPtr->fullNamePtr), -1); + objName = Tcl_GetString(objPtr); + Tcl_SetVar(interp, (const char *)name1, objName, 0); + + Tcl_DecrRefCount(objPtr); + return NULL; + } + + /* + * Handle write traces on "selfns" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return "variable \"selfns\" cannot be modified"; + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceOptionVar() + * + * Invoked to handle read/write traces on "option" variables + * + * On read, this procedure checks if there is a cgetMethodPtr and calls it + * On write, this procedure checks if there is a configureMethodPtr + * or validateMethodPtr and calls it + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceOptionVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + ItclObject *ioPtr; + ItclOption *ioptPtr; + +/* FIXME !!! */ +/* don't know yet if ItclTraceOptionVar is really needed !! */ +/* FIXME should free memory on unset or rename!! */ + if (cdata != NULL) { + ioPtr = (ItclObject*)cdata; + if (ioPtr == NULL) { + } + } else { + ioptPtr = (ItclOption*)cdata; + if (ioptPtr == NULL) { + } + /* + * Handle read traces "itcl_options" + */ + if ((flags & TCL_TRACE_READS) != 0) { + return NULL; + } + + /* + * Handle write traces "itcl_options" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return NULL; + } + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclTraceComponentVar() + * + * Invoked to handle read/write traces on "component" variables + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceComponentVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + FOREACH_HASH_DECLS; + Tcl_HashEntry *hPtr2; + Tcl_Obj *objPtr; + Tcl_Obj *namePtr; + Tcl_Obj *componentValuePtr; + ItclObjectInfo *infoPtr; + ItclObject *ioPtr; + ItclComponent *icPtr; + ItclDelegatedFunction *idmPtr; + const char *val; + +/* FIXME should free memory on unset or rename!! */ + if (cdata != NULL) { + ioPtr = (ItclObject*)cdata; + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)ioPtr); + if (hPtr == NULL) { + /* object does no longer exist or is being destructed */ + return NULL; + } + objPtr = Tcl_NewStringObj(name1, -1); + hPtr = Tcl_FindHashEntry(&ioPtr->objectComponents, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + + /* + * Handle write traces + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + if (ioPtr->noComponentTrace) { + return NULL; + } + /* need to redo the delegation for this component !! */ + if (hPtr == NULL) { + return " INTERNAL ERROR cannot get component to write to"; + } + icPtr = Tcl_GetHashValue(hPtr); + val = ItclGetInstanceVar(interp, name1, NULL, ioPtr, + ioPtr->iclsPtr); + if ((val == NULL) || (strlen(val) == 0)) { + return " INTERNAL ERROR cannot get value for component"; + } + componentValuePtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(componentValuePtr); + namePtr = Tcl_NewStringObj(name1, -1); + FOREACH_HASH_VALUE(idmPtr, &ioPtr->iclsPtr->delegatedFunctions) { + if (idmPtr->icPtr == icPtr) { + hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions, + (char *)namePtr); + if (hPtr2 == NULL) { + DelegateFunction(interp, ioPtr, ioPtr->iclsPtr, + componentValuePtr, idmPtr); + } + } + } + Tcl_DecrRefCount(componentValuePtr); + Tcl_DecrRefCount(namePtr); + return NULL; + } + /* + * Handle read traces + */ + if ((flags & TCL_TRACE_READS) != 0) { + } + + } else { + icPtr = (ItclComponent *)cdata; + /* + * Handle read traces + */ + if ((flags & TCL_TRACE_READS) != 0) { + return NULL; + } + + /* + * Handle write traces + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return NULL; + } + } + return NULL; +} +/* + * ------------------------------------------------------------------------ + * ItclTraceItclHullVar() + * + * Invoked to handle read/write traces on "itcl_hull" variables + * + * On write, this procedure returns an error as "itcl_hull" may not be modfied + * after the first initialization + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceItclHullVar( + ClientData cdata, /* object instance data */ + Tcl_Interp *interp, /* interpreter managing this variable */ + const char *name1, /* variable name */ + const char *name2, /* unused */ + int flags) /* flags indicating read/write */ +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + ItclObjectInfo *infoPtr; + ItclObject *ioPtr; + ItclVariable *ivPtr; + +/* FIXME !!! */ +/* FIXME should free memory on unset or rename!! */ + if (cdata != NULL) { + ioPtr = (ItclObject*)cdata; + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)ioPtr); + if (hPtr == NULL) { + /* object does no longer exist or is being destructed */ + return NULL; + } + objPtr = Tcl_NewStringObj(name1, -1); + hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr == NULL) { + return "INTERNAL ERROR cannot find itcl_hull variable in class definition!!"; + } + ivPtr = Tcl_GetHashValue(hPtr); + /* + * Handle write traces + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + if (ivPtr->initted == 0) { + ivPtr->initted = 1; + return NULL; + } else { + return "The itcl_hull component cannot be redefined"; + } + } + + } else { + ivPtr = (ItclVariable *)cdata; + /* + * Handle read traces + */ + if ((flags & TCL_TRACE_READS) != 0) { + return NULL; + } + + /* + * Handle write traces + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return NULL; + } + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * ItclDestroyObject() + * + * Invoked when the object access command is deleted to implicitly + * destroy the object. Invokes the object's destructors, ignoring + * any errors encountered along the way. Removes the object from + * the list of all known objects and releases the access command's + * claim to the object data. + * + * Note that the usual way to delete an object is via Itcl_DeleteObject(). + * This procedure is provided as a back-up, to handle the case when + * an object is deleted by removing its access command. + * ------------------------------------------------------------------------ + */ +static void +ItclDestroyObject( + ClientData cdata) /* object instance data */ +{ + ItclObject *contextIoPtr = (ItclObject*)cdata; + Tcl_HashEntry *hPtr; + Itcl_InterpState istate; + + if (contextIoPtr->flags & ITCL_OBJECT_IS_DESTROYED) { + return; + } + contextIoPtr->flags |= ITCL_OBJECT_IS_DESTROYED; + + if (!(contextIoPtr->flags & ITCL_OBJECT_IS_DESTRUCTED)) { + /* + * Attempt to destruct the object, but ignore any errors. + */ + istate = Itcl_SaveInterpState(contextIoPtr->interp, 0); + Itcl_DestructObject(contextIoPtr->interp, contextIoPtr, + ITCL_IGNORE_ERRS); + Itcl_RestoreInterpState(contextIoPtr->interp, istate); + } + + /* + * Now, remove the object from the global object list. + * We're careful to do this here, after calling the destructors. + * Once the access command is nulled out, the "this" variable + * won't work properly. + */ + if (contextIoPtr->accessCmd != NULL) { + hPtr = Tcl_FindHashEntry(&contextIoPtr->infoPtr->objects, + (char*)contextIoPtr); + + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + contextIoPtr->accessCmd = NULL; + } + ItclReleaseObject(contextIoPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclFreeObject() + * + * Deletes all instance variables and frees all memory associated with + * the given object instance. This is usually invoked automatically + * by ItclReleaseObject(), when an object's data is no longer being used. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeObject( + char * cdata) /* object instance data */ +{ + FOREACH_HASH_DECLS; + Tcl_HashSearch place; + ItclCallContext *callContextPtr; + ItclObject *ioPtr; + Tcl_Var var; + + ioPtr = (ItclObject*)cdata; + + /* + * Install the class namespace and object context so that + * the object's data members can be destroyed via simple + * "unset" commands. This makes sure that traces work properly + * and all memory gets cleaned up. + * + * NOTE: Be careful to save and restore the interpreter state. + * Data can get freed in the middle of any operation, and + * we can't affort to clobber the interpreter with any errors + * from below. + */ + + ItclReleaseClass(ioPtr->iclsPtr); + if (ioPtr->constructed) { + Tcl_DeleteHashTable(ioPtr->constructed); + ckfree((char*)ioPtr->constructed); + } + if (ioPtr->destructed) { + Tcl_DeleteHashTable(ioPtr->destructed); + ckfree((char*)ioPtr->destructed); + } + ItclDeleteObjectsDictInfo(ioPtr->interp, ioPtr); + /* + * Delete all context definitions. + */ + while (1) { + hPtr = Tcl_FirstHashEntry(&ioPtr->contextCache, &place); + if (hPtr == NULL) { + break; + } + callContextPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + ckfree((char *)callContextPtr); + } + FOREACH_HASH_VALUE(var, &ioPtr->objectVariables) { + Itcl_ReleaseVar(var); + } + + Tcl_DeleteHashTable(&ioPtr->contextCache); + Tcl_DeleteHashTable(&ioPtr->objectVariables); + Tcl_DeleteHashTable(&ioPtr->objectOptions); + Tcl_DeleteHashTable(&ioPtr->objectComponents); + Tcl_DeleteHashTable(&ioPtr->objectMethodVariables); + Tcl_DeleteHashTable(&ioPtr->objectDelegatedOptions); + Tcl_DeleteHashTable(&ioPtr->objectDelegatedFunctions); + Tcl_DecrRefCount(ioPtr->namePtr); + Tcl_DecrRefCount(ioPtr->origNamePtr); + if (ioPtr->createNamePtr != NULL) { + Tcl_DecrRefCount(ioPtr->createNamePtr); + } + if (ioPtr->hullWindowNamePtr != NULL) { + Tcl_DecrRefCount(ioPtr->hullWindowNamePtr); + } + Tcl_DecrRefCount(ioPtr->varNsNamePtr); + if (ioPtr->resolvePtr != NULL) { + ckfree((char *)ioPtr->resolvePtr->clientData); + ckfree((char*)ioPtr->resolvePtr); + } + ckfree((char*)ioPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclObjectCmd() + * + * ------------------------------------------------------------------------ + */ + +static int +CallPublicObjectCmd( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Object *oPtr = data[0]; + Tcl_Class clsPtr = data[1]; + Tcl_Obj *const* objv = data[3]; + int objc = PTR2INT(data[2]); + + ItclShowArgs(1, "CallPublicObjectCmd", objc, objv); + result = Itcl_PublicObjectCmd(oPtr, interp, clsPtr, objc, objv); + ItclShowArgs(1, "CallPublicObjectCmd DONE", objc, objv); + return result; +} + +int +ItclObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + Tcl_Object oPtr, + Tcl_Class clsPtr, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *methodNamePtr; + Tcl_Obj **newObjv; + Tcl_DString buffer; + Tcl_Obj *myPtr; + ItclMemberFunc *imPtr; + ItclClass *iclsPtr; + Itcl_ListElem *elem; + ItclClass *basePtr; + void *callbackPtr; + const char *className; + const char *tail; + const char *cp; + int isDirectCall; + int incr; + int result; + int found; + + ItclShowArgs(1, "ItclObjectCmd", objc, objv); + + incr = 0; + found = 0; + isDirectCall = 0; + myPtr = NULL; + imPtr = (ItclMemberFunc *)clientData; + iclsPtr = imPtr->iclsPtr; + if (oPtr == NULL) { + ItclClass *icPtr = NULL; + ItclObject *ioPtr = NULL; + + isDirectCall = (clsPtr == NULL); + + if ((imPtr->flags & ITCL_COMMON) + && (imPtr->codePtr != NULL) + && !(imPtr->codePtr->flags & ITCL_BUILTIN)) { + result = Itcl_InvokeProcedureMethod(imPtr->tmPtr, interp, + objc, objv); + return result; + } + + if (TCL_OK == Itcl_GetContext(interp, &icPtr, &ioPtr)) { + oPtr = ioPtr ? ioPtr->oPtr : icPtr->oPtr; + } else { + Tcl_Panic("No Context"); + } + } + methodNamePtr = NULL; + if (objv[0] != NULL) { + Itcl_ParseNamespPath(Tcl_GetString(objv[0]), &buffer, + &className, &tail); + if (className != NULL) { + methodNamePtr = Tcl_NewStringObj(tail, -1); + /* look for the class in the hierarchy */ + cp = className; + if ((*cp == ':') && (*(cp+1) == ':')) { + cp += 2; + } + elem = Itcl_FirstListElem(&iclsPtr->bases); + if (elem == NULL) { + /* check the class itself */ + if (strcmp((const char *)cp, + (const char *)Tcl_GetString(iclsPtr->namePtr)) == 0) { + found = 1; + clsPtr = iclsPtr->clsPtr; + } + } + while (elem != NULL) { + basePtr = (ItclClass*)Itcl_GetListValue(elem); + if (strcmp((const char *)cp, + (const char *)Tcl_GetString(basePtr->namePtr)) == 0) { + clsPtr = basePtr->clsPtr; + found = 1; + break; + } + elem = Itcl_NextListElem(elem); + } + if (!found) { + found = 1; + clsPtr = iclsPtr->clsPtr; + } + } + Tcl_DStringFree(&buffer); + } else { + /* Can this happen? */ + Tcl_Panic("objv[0] is NULL?!"); + /* Panic above replaces obviously broken line below. Creating + * a string value from uninitialized memory cannot possibly be + * a correct thing to do. + + methodNamePtr = Tcl_NewStringObj(tail, -1); + */ + } + if (isDirectCall) { + if (!found) { + if (methodNamePtr != NULL) { + Tcl_DecrRefCount(methodNamePtr); + } + methodNamePtr = objv[0]; + } + } + callbackPtr = Itcl_GetCurrentCallbackPtr(interp); + newObjv = NULL; + if (methodNamePtr != NULL) { + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + char *myName; + /* special handling for mytypemethod, mymethod, myproc */ + myName = Tcl_GetString(methodNamePtr); + if (strcmp(myName, "mytypemethod") == 0) { + result = Itcl_BiMyTypeMethodCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "mymethod") == 0) { + result = Itcl_BiMyMethodCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "myproc") == 0) { + result = Itcl_BiMyProcCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "mytypevar") == 0) { + result = Itcl_BiMyTypeVarCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "myvar") == 0) { + result = Itcl_BiMyVarCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "itcl_hull") == 0) { + result = Itcl_BiItclHullCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "callinstance") == 0) { + result = Itcl_BiCallInstanceCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "getinstancevar") == 0) { + result = Itcl_BiGetInstanceVarCmd(iclsPtr, interp, objc, objv); + return result; + } + if (strcmp(myName, "installcomponent") == 0) { + result = Itcl_BiInstallComponentCmd(iclsPtr, interp, objc, objv); + return result; + } + } + incr = 1; + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+incr)); + myPtr = Tcl_NewStringObj("my", 2); + Tcl_IncrRefCount(myPtr); + Tcl_IncrRefCount(methodNamePtr); + newObjv[0] = myPtr; + newObjv[1] = methodNamePtr; + memcpy(newObjv+incr+1, objv+1, (sizeof(Tcl_Obj*)*(objc-1))); + ItclShowArgs(1, "run CallPublicObjectCmd1", objc+incr, newObjv); + Tcl_NRAddCallback(interp, CallPublicObjectCmd, oPtr, clsPtr, + INT2PTR(objc+incr), newObjv); + + } else { + ItclShowArgs(1, "run CallPublicObjectCmd2", objc, objv); + Tcl_NRAddCallback(interp, CallPublicObjectCmd, oPtr, clsPtr, + INT2PTR(objc), (ClientData)objv); + } + + result = Itcl_NRRunCallbacks(interp, callbackPtr); + if (methodNamePtr != NULL) { + ckfree((char *)newObjv); + Tcl_DecrRefCount(methodNamePtr); + } + if (myPtr != NULL) { + Tcl_DecrRefCount(myPtr); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * GetClassFromClassName() + * ------------------------------------------------------------------------ + */ + +ItclClass * +GetClassFromClassName( + Tcl_Interp *interp, + const char *className, + ItclClass *iclsPtr) +{ + Tcl_Obj *objPtr; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *basePtr; + Itcl_ListElem *elem; + const char *chkPtr; + int chkLgth; + int lgth; + + /* look for the class in the hierarchy */ + /* first check the class itself */ + if (iclsPtr != NULL) { + if (strcmp(className, + (const char *)Tcl_GetString(iclsPtr->namePtr)) == 0) { + return iclsPtr; + } + elem = Itcl_FirstListElem(&iclsPtr->bases); + while (elem != NULL) { + basePtr = (ItclClass*)Itcl_GetListValue(elem); + basePtr = GetClassFromClassName(interp, className, basePtr); + if (basePtr != NULL) { + return basePtr; + } + elem = Itcl_NextListElem(elem); + } + /* now try to match the classes full name last part with the className */ + lgth = strlen(className); + elem = Itcl_FirstListElem(&iclsPtr->bases); + while (elem != NULL) { + basePtr = (ItclClass*)Itcl_GetListValue(elem); + chkPtr = basePtr->nsPtr->fullName; + chkLgth = strlen(chkPtr); + if (chkLgth >= lgth) { + chkPtr = chkPtr + chkLgth - lgth; + if (strcmp(chkPtr, className) == 0) { + return basePtr; + } + } + elem = Itcl_NextListElem(elem); + } + infoPtr = iclsPtr->infoPtr; + } else { + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + } + /* as a last chance try with className in hash table */ + objPtr = Tcl_NewStringObj(className, -1); + Tcl_IncrRefCount(objPtr); + hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objPtr); + if (hPtr != NULL) { + iclsPtr = Tcl_GetHashValue(hPtr); + } else { + iclsPtr = NULL; + } + Tcl_DecrRefCount(objPtr); + return iclsPtr; +} + +/* + * ------------------------------------------------------------------------ + * ItclMapMethodNameProc() + * ------------------------------------------------------------------------ + */ + +int +ItclMapMethodNameProc( + Tcl_Interp *interp, + Tcl_Object oPtr, + Tcl_Class *startClsPtr, + Tcl_Obj *methodObj) +{ + Tcl_Obj *methodName; + Tcl_Obj *className; + Tcl_DString buffer; + Tcl_HashEntry *hPtr; + Tcl_Namespace * myNsPtr; + ItclObject *ioPtr; + ItclClass *iclsPtr; + ItclClass *iclsPtr2; + ItclObjectInfo *infoPtr; + const char *head; + const char *tail; + const char *sp; + + iclsPtr = NULL; + iclsPtr2 = NULL; + methodName = NULL; + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->object_meta_type); + hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)ioPtr); + if ((hPtr == NULL) || (ioPtr == NULL)) { + /* try to get the class (if a class is creating an object) */ + iclsPtr = (ItclClass *)Tcl_ObjectGetMetadata(oPtr, + infoPtr->class_meta_type); + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); + if (hPtr == NULL) { + char str[20]; + sprintf(str, "%p", iclsPtr); + Tcl_AppendResult(interp, "context class has vanished 1", str, NULL); + return TCL_ERROR; + } + } else { + hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)ioPtr->iclsPtr); + if (hPtr == NULL) { + char str[20]; + sprintf(str, "%p", ioPtr->iclsPtr); + Tcl_AppendResult(interp, "context class has vanished 2", str, NULL); + return TCL_ERROR; + } + iclsPtr = ioPtr->iclsPtr; + } + sp = Tcl_GetString(methodObj); + Itcl_ParseNamespPath(sp, &buffer, &head, &tail); + if (head == NULL) { + /* itcl bug #3600923 call private method in class + * without namespace + */ + myNsPtr = Tcl_GetCurrentNamespace(iclsPtr->interp); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *) myNsPtr); + if (hPtr) { + iclsPtr2 = (ItclClass *) Tcl_GetHashValue(hPtr); + if (Itcl_IsMethodCallFrame(iclsPtr->interp) > 0) { + iclsPtr = iclsPtr2; + } + } + } + if (head != NULL) { + className = NULL; + methodName = Tcl_NewStringObj(tail, -1); + Tcl_IncrRefCount(methodName); + className = Tcl_NewStringObj(head, -1); + Tcl_IncrRefCount(className); + if (strlen(head) > 0) { + iclsPtr2 = GetClassFromClassName(interp, head, iclsPtr); + } else { + iclsPtr2 = NULL; + } + if (iclsPtr2 != NULL) { + *startClsPtr = iclsPtr2->clsPtr; + Tcl_SetStringObj(methodObj, Tcl_GetString(methodName), -1); + } + Tcl_DecrRefCount(className); + Tcl_DecrRefCount(methodName); + } + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)methodObj); + if (hPtr == NULL) { + /* special case: we found the class for the class command, + * for a relative or absolute class path name + * but we have no method in that class that fits. + * Problem of Rene Zaumseil when having the object + * for a class in a child namespace of the class + * fossil ticket id: 36577626c340ad59615f0a0238d67872c009a8c9 + */ + *startClsPtr = NULL; + } else { + ItclMemberFunc *imPtr; + Tcl_Namespace *nsPtr; + ItclCmdLookup *clookup; + + nsPtr = Tcl_GetCurrentNamespace(interp); + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + if (!Itcl_CanAccessFunc(imPtr, nsPtr)) { + char *token = Tcl_GetString(imPtr->namePtr); + if ((*token != 'i') || (strcmp(token, "info") != 0)) { + /* needed for test protect-2.5 */ + ItclMemberFunc *imPtr2 = NULL; + Tcl_HashEntry *hPtr; + Tcl_ObjectContext context; + context = Itcl_GetCallFrameClientData(interp); + if (context != NULL) { + hPtr = Tcl_FindHashEntry( + &imPtr->iclsPtr->infoPtr->procMethods, + (char *)Tcl_ObjectContextMethod(context)); + if (hPtr != NULL) { + imPtr2 = Tcl_GetHashValue(hPtr); + } + if ((imPtr->protection & ITCL_PRIVATE) && + (imPtr2 != NULL) && + (imPtr->iclsPtr->nsPtr != imPtr2->iclsPtr->nsPtr)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", + token, + "\"", NULL); + return TCL_ERROR; + } + } + /* END needed for test protect-2.5 */ + if (ioPtr == NULL) { + /* itcl in fossil ticket: 2cd667f270b68ef66d668338e09d144e20405e23 */ + Tcl_HashEntry *hPtr; + Tcl_Obj * objPtr; + ItclMemberFunc *imPtr2 = NULL; + ItclCmdLookup *clookupPtr; + + objPtr = Tcl_NewStringObj(token, -1); + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); + if (hPtr != NULL) { + clookupPtr = Tcl_GetHashValue(hPtr); + imPtr2 = clookupPtr->imPtr; + } + if ((imPtr->protection & ITCL_PRIVATE) && + (imPtr2 != NULL) && + (imPtr->iclsPtr->nsPtr == imPtr2->iclsPtr->nsPtr)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", + token, + "\"", NULL); + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, + "bad option \"", token, "\": should be one of...", + (char*)NULL); + ItclReportObjectUsage(interp, ioPtr, nsPtr, nsPtr); + return TCL_ERROR; + + } + } + } + } + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +int +ExpandDelegateAs( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr, + ItclDelegatedFunction *idmPtr, + const char *funcName, + Tcl_Obj *listPtr) +{ + Tcl_Obj *componentNamePtr; + Tcl_Obj *objPtr; + const char **argv; + const char *val; + int argc; + int j; + + + if (idmPtr->icPtr == NULL) { + componentNamePtr = NULL; + } else { + componentNamePtr = idmPtr->icPtr->namePtr; + } + if (idmPtr->asPtr != NULL) { + Tcl_SplitList(interp, Tcl_GetString(idmPtr->asPtr), + &argc, &argv); + for(j=0;j<argc;j++) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(argv[j], -1)); + } + ckfree((char *)argv); + } else { + if (idmPtr->usingPtr != NULL) { + char *cp; + char *ep; + int hadDoublePercent; + Tcl_Obj *strPtr; + + strPtr = NULL; + hadDoublePercent = 0; + cp = Tcl_GetString(idmPtr->usingPtr); + ep = cp; + strPtr = Tcl_NewStringObj("", -1); + while (*ep != '\0') { + if (*ep == '%') { + if (*(ep+1) == '%') { + cp++; + cp++; + ep++; + ep++; + hadDoublePercent = 1; + Tcl_AppendToObj(strPtr, "%", -1); + continue; + } + switch (*(ep+1)) { + case 'c': + if (componentNamePtr == NULL) { + ep++; + continue; + } + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace( + iclsPtr->oPtr))->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(componentNamePtr), -1); + val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), + NULL, 0); + Tcl_DecrRefCount(objPtr); + Tcl_AppendToObj(strPtr, + val, -1); + break; + case 'j': + case 'm': + case 'M': + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) { + Tcl_AppendToObj(strPtr, funcName, -1); + } else { + Tcl_AppendToObj(strPtr, + Tcl_GetString(idmPtr->namePtr), -1); + } + break; + case 'n': + if (iclsPtr->flags & ITCL_TYPE) { + ep++; + continue; + } else { + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + Tcl_AppendToObj(strPtr, iclsPtr->nsPtr->name, -1); + } + break; + case 's': + if (iclsPtr->flags & ITCL_TYPE) { + ep++; + continue; + } else { + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + Tcl_AppendToObj(strPtr, + Tcl_GetString(ioPtr->namePtr), -1); + } + break; + case 't': + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + Tcl_AppendToObj(strPtr, iclsPtr->nsPtr->fullName, -1); + break; + case 'w': + if (iclsPtr->flags & ITCL_TYPE) { + ep++; + continue; + } else { + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + } + break; + case ':': + /* substitute with contents of variable after ':' */ + if (iclsPtr->flags & ITCL_ECLASS) { + if (ep-cp-1 > 0) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + ep++; + cp = ep + 1; + while (*ep && (*ep != ' ')) { + ep++; + } + if (ep-cp > 0) { + Tcl_Obj *my_obj; + const char *cp2; + + my_obj = Tcl_NewStringObj(cp, ep-cp); + if (iclsPtr->infoPtr->currIoPtr != NULL) { + cp2 = GetConstructorVar(interp, iclsPtr, + Tcl_GetString(my_obj)); + } else { + cp2 = ItclGetInstanceVar(interp, + Tcl_GetString(my_obj), NULL, ioPtr, + iclsPtr); + } + if (cp2 != NULL) { + Tcl_AppendToObj(strPtr, cp2, -1); + } + ep -= 2; /* to fit for code after default !! */ + } + break; + } else { + /* fall through */ + } + default: + { + char buf[2]; + buf[1] = '\0'; + sprintf(buf, "%c", *(ep+1)); + Tcl_AppendResult(interp, + "there is no %%", buf, " substitution", + NULL); + if (strPtr != NULL) { + Tcl_DecrRefCount(strPtr); + } + return TCL_ERROR; + } + } + Tcl_ListObjAppendElement(interp, listPtr, strPtr); + hadDoublePercent = 0; + strPtr = Tcl_NewStringObj("", -1); + ep +=2; + cp = ep; + } else { + if (*ep == ' ') { + if (strlen(Tcl_GetString(strPtr)) > 0) { + if (ep-cp == 0) { + Tcl_ListObjAppendElement(interp, listPtr, + strPtr); + strPtr = Tcl_NewStringObj("", -1); + } + } + if (ep-cp > 0) { + Tcl_AppendToObj(strPtr, cp, ep-cp); + Tcl_ListObjAppendElement(interp, listPtr, strPtr); + strPtr = Tcl_NewStringObj("", -1); + } + while((*ep != '\0') && (*ep == ' ')) { + ep++; + } + cp = ep; + } else { + ep++; + } + } + } + if (hadDoublePercent) { + /* FIXME need code here */ + } + if (cp != ep) { + if (*ep == '\0') { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp)); + } else { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cp, ep-cp-1)); + } + } + if (strPtr != NULL) { + Tcl_DecrRefCount(strPtr); + } + } else { + Tcl_ListObjAppendElement(interp, listPtr, idmPtr->namePtr); + } + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * DelegationFunction() + * ------------------------------------------------------------------------ + */ + +int +DelegateFunction( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr, + Tcl_Obj *componentValuePtr, + ItclDelegatedFunction *idmPtr) +{ + Tcl_Obj *listPtr; + const char *val; + int result; + Tcl_Method mPtr; + + listPtr = Tcl_NewListObj(0, NULL); + if (componentValuePtr != NULL) { + if (idmPtr->usingPtr == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, componentValuePtr); + } + } + result = ExpandDelegateAs(interp, ioPtr, iclsPtr, idmPtr, + Tcl_GetString(idmPtr->namePtr), listPtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(listPtr); + return result; + } + val = Tcl_GetString(listPtr); + if (val == NULL) { + /* FIXME need code here */ + } + if (componentValuePtr != NULL) { + mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1, + idmPtr->namePtr, listPtr); + if (mPtr != NULL) { + return TCL_OK; + } + } + if (idmPtr->usingPtr != NULL) { + mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1, + idmPtr->namePtr, listPtr); + if (mPtr != NULL) { + return TCL_OK; + } + } + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * DelegatedOptionsInstall() + * ------------------------------------------------------------------------ + */ + +int +DelegatedOptionsInstall( + Tcl_Interp *interp, + ItclClass *iclsPtr) +{ + Tcl_HashEntry *hPtr2; + Tcl_HashSearch search2; + ItclDelegatedOption *idoPtr; + ItclOption *ioptPtr; + FOREACH_HASH_DECLS; + char *optionName; + + FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { + optionName = Tcl_GetString(idoPtr->namePtr); + if (*optionName == '*') { + /* allow nested FOREACH */ + search2 = search; + FOREACH_HASH_VALUE(ioptPtr, &iclsPtr->options) { + if (Tcl_FindHashEntry(&idoPtr->exceptions, + (char *)idoPtr->namePtr) == NULL) { + ioptPtr->idoPtr = idoPtr; + Itcl_PreserveData(ioptPtr->idoPtr); + } + } + search = search2; + } else { + hPtr2 = Tcl_FindHashEntry(&iclsPtr->options, + (char *)idoPtr->namePtr); + if (hPtr2 == NULL) { + ioptPtr = NULL; + } else { + ioptPtr = Tcl_GetHashValue(hPtr2); + ioptPtr->idoPtr = idoPtr; + } + idoPtr->ioptPtr = ioptPtr; + } + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * GetConstructorVar() + * get an object variable when in executing the constructor + * ------------------------------------------------------------------------ + */ + +static const char * +GetConstructorVar( + Tcl_Interp *interp, + ItclClass *iclsPtr, + const char *varName) + +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + Tcl_DString buffer; + ItclVarLookup *vlookup; + ItclVariable *ivPtr; + const char *val; + + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)varName); + if (hPtr == NULL) { + /* no such variable */ + return NULL; + } + vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr); + if (vlookup == NULL) { + return NULL; + } + ivPtr = vlookup->ivPtr; + if (ivPtr == NULL) { + return NULL; + } + if (ivPtr->flags & ITCL_COMMON) { + /* look for a common variable */ + objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace( + iclsPtr->oPtr))->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, varName, -1); + val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0); + Tcl_DecrRefCount(objPtr); + } else { + /* look for a normal variable */ + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetString(iclsPtr->infoPtr->currIoPtr->varNsNamePtr), -1); + Tcl_DStringAppend(&buffer, ivPtr->iclsPtr->nsPtr->fullName, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, varName, -1); + val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + } + return val; +} + +/* + * ------------------------------------------------------------------------ + * DelegationInstall() + * ------------------------------------------------------------------------ + */ + +int +DelegationInstall( + Tcl_Interp *interp, + ItclObject *ioPtr, + ItclClass *iclsPtr) +{ + Tcl_HashEntry *hPtr2; + Tcl_HashSearch search2; + Tcl_Obj *componentValuePtr; + Tcl_DString buffer; + ItclDelegatedFunction *idmPtr; + ItclMemberFunc *imPtr; + ItclVariable *ivPtr; + FOREACH_HASH_DECLS; + char *methodName; + const char *val; + int result; + int noDelegate; + int delegateAll; + + result = TCL_OK; + delegateAll = 0; + ioPtr->noComponentTrace = 1; + noDelegate = ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR|ITCL_COMPONENT; + componentValuePtr = NULL; + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + methodName = Tcl_GetString(idmPtr->namePtr); + if (*methodName == '*') { + delegateAll = 1; + } + if (idmPtr->icPtr != NULL) { + Tcl_Obj *objPtr; + /* we cannot use Itcl_GetInstanceVar here as the object is not + * yet completely built. So use the varNsNamePtr + */ + ivPtr = idmPtr->icPtr->ivPtr; + if (ivPtr->flags & ITCL_COMMON) { + objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); + + Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace( + ivPtr->iclsPtr->oPtr))->fullName, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(idmPtr->icPtr->namePtr), -1); + val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0); + Tcl_DecrRefCount(objPtr); + } else { + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetString(ioPtr->varNsNamePtr), -1); + Tcl_DStringAppend(&buffer, + Tcl_GetString(ivPtr->fullNamePtr), -1); + val = Tcl_GetVar2(interp, + Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + } + componentValuePtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(componentValuePtr); + } else { + componentValuePtr = NULL; + } + if (!delegateAll) { + result = DelegateFunction(interp, ioPtr, iclsPtr, + componentValuePtr, idmPtr); + if (result != TCL_OK) { + ioPtr->noComponentTrace = 0; + return result; + } + } else { + /* save to allow nested FOREACH */ + search2 = search; + FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { + methodName = Tcl_GetString(imPtr->namePtr); + if (imPtr->flags & noDelegate) { + continue; + } + if (strcmp(methodName, "info") == 0) { + continue; + } + if (strcmp(methodName, "isa") == 0) { + continue; + } + if (strcmp(methodName, "createhull") == 0) { + continue; + } + if (strcmp(methodName, "keepcomponentoption") == 0) { + continue; + } + if (strcmp(methodName, "ignorecomponentoption") == 0) { + continue; + } + if (strcmp(methodName, "renamecomponentoption") == 0) { + continue; + } + if (strcmp(methodName, "setupcomponent") == 0) { + continue; + } + if (strcmp(methodName, "itcl_initoptions") == 0) { + continue; + } + if (strcmp(methodName, "mytypemethod") == 0) { + continue; + } + if (strcmp(methodName, "mymethod") == 0) { + continue; + } + if (strcmp(methodName, "myproc") == 0) { + continue; + } + if (strcmp(methodName, "mytypevar") == 0) { + continue; + } + if (strcmp(methodName, "myvar") == 0) { + continue; + } + if (strcmp(methodName, "itcl_hull") == 0) { + continue; + } + if (strcmp(methodName, "callinstance") == 0) { + continue; + } + if (strcmp(methodName, "getinstancevar") == 0) { + continue; + } + hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions, + (char *)imPtr->namePtr); + if (hPtr2 != NULL) { + continue; + } + result = DelegateFunction(interp, ioPtr, iclsPtr, + componentValuePtr, idmPtr); + if (result != TCL_OK) { + break; + } + } + search = search2; + } + if (componentValuePtr != NULL) { + Tcl_DecrRefCount(componentValuePtr); + } + } + ioPtr->noComponentTrace = 0; + result = DelegatedOptionsInstall(interp, iclsPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclInitExtendedClassOptions() + * ------------------------------------------------------------------------ + */ + +static int +ItclInitExtendedClassOptions( + Tcl_Interp *interp, + ItclObject *ioPtr) +{ + ItclClass *iclsPtr; + ItclOption *ioptPtr; + ItclHierIter hier; + FOREACH_HASH_DECLS; + + iclsPtr = ioPtr->iclsPtr; + Itcl_InitHierIter(&hier, iclsPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + FOREACH_HASH_VALUE(ioptPtr, &iclsPtr->options) { + if (ioptPtr->defaultValuePtr != NULL) { + if (ItclGetInstanceVar(interp, "itcl_options", + Tcl_GetString(ioptPtr->namePtr), ioPtr, iclsPtr) + == NULL) { + } + } + } + } + Itcl_DeleteHierIter(&hier); + return TCL_OK; +} + +ItclClass * +ItclNamespace2Class(Tcl_Namespace *nsPtr) +{ + ItclObjectInfo * infoPtr; + Tcl_HashEntry *hPtr; + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(((Namespace *)nsPtr)->interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&(infoPtr->namespaceClasses), nsPtr); + if (hPtr == NULL) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclParse.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclParse.c new file mode 100644 index 0000000..9b34dc6 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclParse.c @@ -0,0 +1,4309 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * Procedures in this file support the new syntax for [incr Tcl] + * class definitions: + * + * itcl_class <className> { + * inherit <base-class>... + * + * constructor {<arglist>} ?{<init>}? {<body>} + * destructor {<body>} + * + * method <name> {<arglist>} {<body>} + * proc <name> {<arglist>} {<body>} + * variable <name> ?<init>? ?<config>? + * common <name> ?<init>? + * + * public <thing> ?<args>...? + * protected <thing> ?<args>...? + * private <thing> ?<args>...? + * } + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +static const char initWidgetScript[] = +"namespace eval ::itcl {\n" +" proc _find_widget_init {} {\n" +" global env tcl_library\n" +" variable library\n" +" variable patchLevel\n" +" rename _find_widget_init {}\n" +" if {[info exists library]} {\n" +" lappend dirs $library\n" +" } else {\n" +" if {[catch {uplevel #0 source -rsrc itcl}] == 0} {\n" +" return\n" +" }\n" +" set dirs {}\n" +" if {[info exists env(ITCL_LIBRARY)]} {\n" +" lappend dirs $env(ITCL_LIBRARY)\n" +" }\n" +" lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n" +" set bindir [file dirname [info nameofexecutable]]\n" +" lappend dirs [file join . library]\n" +" lappend dirs [file join $bindir .. lib itcl$patchLevel]\n" +" lappend dirs [file join $bindir .. library]\n" +" lappend dirs [file join $bindir .. .. library]\n" +" lappend dirs [file join $bindir .. .. itcl library]\n" +" lappend dirs [file join $bindir .. .. .. itcl library]\n" +" lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n" +" # On MacOSX, check the directories in the tcl_pkgPath\n" +" if {[string equal $::tcl_platform(platform) \"unix\"] &&" +" [string equal $::tcl_platform(os) \"Darwin\"]} {\n" +" foreach d $::tcl_pkgPath {\n" +" lappend dirs [file join $d itcl$patchLevel]\n" +" }\n" +" }\n" +" # On *nix, check the directories in the tcl_pkgPath\n" +" if {[string equal $::tcl_platform(platform) \"unix\"]} {\n" +" foreach d $::tcl_pkgPath {\n" +" lappend dirs $d\n" +" lappend dirs [file join $d itcl$patchLevel]\n" +" }\n" +" }\n" +" }\n" +" foreach i $dirs {\n" +" set library $i\n" +" set itclfile [file join $i itclWidget.tcl]\n" +" if {![catch {uplevel #0 [list source $itclfile]} msg]} {\n" +" return\n" +" }\n" +" }\n" +" set msg \"Can't find a usable itclWidget.tcl in the following directories:\n\"\n" +" append msg \" $dirs\n\"\n" +" append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n" +" append msg \"If you know where the Itcl library directory was installed,\n\"\n" +" append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n" +" append msg \"to the library directory.\n\"\n" +" error $msg\n" +" }\n" +" _find_widget_init\n" +"}"; + +/* + * Info needed for public/protected/private commands: + */ +typedef struct ProtectionCmdInfo { + int pLevel; /* protection level */ + ItclObjectInfo *infoPtr; /* info regarding all known objects */ +} ProtectionCmdInfo; + +/* + * FORWARD DECLARATIONS + */ +static Tcl_CmdDeleteProc ItclFreeParserCommandData; +static void ItclDelObjectInfo(char* cdata); +static int ItclInitClassCommon(Tcl_Interp *interp, ItclClass *iclsPtr, + ItclVariable *ivPtr, const char *initStr); + +static Tcl_ObjCmdProc Itcl_ClassTypeVariableCmd; +static Tcl_ObjCmdProc Itcl_ClassTypeMethodCmd; +static Tcl_ObjCmdProc Itcl_ClassFilterCmd; +static Tcl_ObjCmdProc Itcl_ClassMixinCmd; +static Tcl_ObjCmdProc Itcl_WidgetCmd; +static Tcl_ObjCmdProc Itcl_WidgetAdaptorCmd; +static Tcl_ObjCmdProc Itcl_ClassComponentCmd; +static Tcl_ObjCmdProc Itcl_ClassTypeComponentCmd; +static Tcl_ObjCmdProc Itcl_ClassDelegateMethodCmd; +static Tcl_ObjCmdProc Itcl_ClassDelegateOptionCmd; +static Tcl_ObjCmdProc Itcl_ClassDelegateTypeMethodCmd; +static Tcl_ObjCmdProc Itcl_ClassForwardCmd; +static Tcl_ObjCmdProc Itcl_ClassMethodVariableCmd; +static Tcl_ObjCmdProc Itcl_ClassTypeConstructorCmd; +static Tcl_ObjCmdProc ItclGenericClassCmd; + +static const struct { + const char *name; + Tcl_ObjCmdProc *objProc; +} parseCmds[] = { + {"common", Itcl_ClassCommonCmd}, + {"component", Itcl_ClassComponentCmd}, + {"constructor", Itcl_ClassConstructorCmd}, + {"destructor", Itcl_ClassDestructorCmd}, + {"filter", Itcl_ClassFilterCmd}, + {"forward", Itcl_ClassForwardCmd}, + {"handleClass", Itcl_HandleClass}, + {"hulltype", Itcl_ClassHullTypeCmd}, + {"inherit", Itcl_ClassInheritCmd}, + {"method", Itcl_ClassMethodCmd}, + {"methodvariable", Itcl_ClassMethodVariableCmd}, + {"mixin", Itcl_ClassMixinCmd}, + {"option", Itcl_ClassOptionCmd}, + {"proc", Itcl_ClassProcCmd}, + {"typecomponent", Itcl_ClassTypeComponentCmd }, + {"typeconstructor", Itcl_ClassTypeConstructorCmd}, + {"typemethod", Itcl_ClassTypeMethodCmd}, + {"typevariable", Itcl_ClassTypeVariableCmd}, + {"variable", Itcl_ClassVariableCmd}, + {"widgetclass", Itcl_ClassWidgetClassCmd}, + {NULL, NULL} +}; + +static const struct { + const char *name; + Tcl_ObjCmdProc *objProc; + int protection; +} protectionCmds[] = { + {"private", Itcl_ClassProtectionCmd, ITCL_PRIVATE}, + {"protected", Itcl_ClassProtectionCmd, ITCL_PROTECTED}, + {"public", Itcl_ClassProtectionCmd, ITCL_PUBLIC}, + {NULL, NULL, 0} +}; + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseInit() + * + * Invoked by Itcl_Init() whenever a new interpeter is created to add + * [incr Tcl] facilities. Adds the commands needed to parse class + * definitions. + * ------------------------------------------------------------------------ + */ +int +Itcl_ParseInit( + Tcl_Interp *interp, /* interpreter to be updated */ + ItclObjectInfo *infoPtr) /* info regarding all known objects and classes */ +{ + Tcl_Namespace *parserNs; + ProtectionCmdInfo *pInfoPtr; + Tcl_DString buffer; + int i; + + /* + * Create the "itcl::parser" namespace used to parse class + * definitions. + */ + parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", + (ClientData)infoPtr, Itcl_ReleaseData); + + if (!parserNs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " (cannot initialize itcl parser)", + (char*)NULL); + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + /* + * Add commands for parsing class definitions. + */ + Tcl_DStringInit(&buffer); + for (i=0 ; parseCmds[i].name ; i++) { + Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); + Tcl_DStringAppend(&buffer, parseCmds[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + parseCmds[i].objProc, (ClientData) infoPtr, NULL); + Tcl_DStringFree(&buffer); + } + + for (i=0 ; protectionCmds[i].name ; i++) { + Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); + Tcl_DStringAppend(&buffer, protectionCmds[i].name, -1); + pInfoPtr = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); + pInfoPtr->pLevel = protectionCmds[i].protection; + pInfoPtr->infoPtr = infoPtr; + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + protectionCmds[i].objProc, (ClientData) pInfoPtr, + (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); + Tcl_DStringFree(&buffer); + } + + /* + * Set the runtime variable resolver for the parser namespace, + * to control access to "common" data members while parsing + * the class definition. + */ + if (infoPtr->useOldResolvers) { + ItclSetParserResolver(parserNs); + } + /* + * Install the "class" command for defining new classes. + */ + Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Itcl_EventuallyFree((ClientData)infoPtr, ItclDelObjectInfo); + + /* + * Create the "itcl::find" command for high-level queries. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::find", + "classes", "?pattern?", + Itcl_FindClassesCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::find", + "objects", "?-class className? ?-isa className? ?pattern?", + Itcl_FindObjectsCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + + /* + * Create the "itcl::delete" command to delete objects + * and classes. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::delete", + "class", "name ?name...?", + Itcl_DelClassCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::delete", + "object", "name ?name...?", + Itcl_DelObjectCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::delete", + "ensemble", "name ?name...?", + Itcl_EnsembleDeleteCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + /* + * Create the "itcl::is" command to test object + * and classes existence. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::is") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::is", + "class", "name", Itcl_IsClassCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::is", + "object", "?-class classname? name", Itcl_IsObjectCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + + /* + * Add "code" and "scope" commands for handling scoped values. + */ + Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + /* + * Add the "filter" commands (add/delete) + */ + if (Itcl_CreateEnsemble(interp, "::itcl::filter") != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::filter", + "add", "objectOrClass filter ? ... ?", Itcl_FilterAddCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::filter", + "delete", "objectOrClass filter ? ... ?", Itcl_FilterDeleteCmd, + (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + + Itcl_PreserveData((ClientData)infoPtr); + + /* + * Add the "forward" commands (add/delete) + */ + if (Itcl_CreateEnsemble(interp, "::itcl::forward") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::forward", + "add", "objectOrClass srcCommand targetCommand ? options ... ?", + Itcl_ForwardAddCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::forward", + "delete", "objectOrClass targetCommand ? ... ?", + Itcl_ForwardDeleteCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + /* + * Add the "mixin" (add/delete) commands. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::mixin") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", + "add", "objectOrClass class ? class ... ?", + Itcl_MixinAddCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", + "delete", "objectOrClass class ? class ... ?", + Itcl_MixinDeleteCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + /* + * Add commands for handling import stubs at the Tcl level. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", + "create", "name", Itcl_StubCreateCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", + "exists", "name", Itcl_StubExistsCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_CreateObjCommand(interp, "::itcl::type", Itcl_TypeClassCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::widget", Itcl_WidgetCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::widgetadaptor", Itcl_WidgetAdaptorCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::nwidget", Itcl_NWidgetCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::addoption", Itcl_AddOptionCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::addobjectoption", + Itcl_AddObjectOptionCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::adddelegatedoption", + Itcl_AddDelegatedOptionCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::adddelegatedmethod", + Itcl_AddDelegatedFunctionCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::addcomponent", Itcl_AddComponentCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::setcomponent", Itcl_SetComponentCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, "::itcl::extendedclass", Itcl_ExtendedClassCmd, + (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::genericclass", + ItclGenericClassCmd, (ClientData)infoPtr, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)infoPtr); + + /* + * Add the "delegate" (method/option) commands. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::parser::delegate") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", + "method", "name to targetName as scipt using script", + Itcl_ClassDelegateMethodCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", + "typemethod", "name to targetName as scipt using script", + Itcl_ClassDelegateTypeMethodCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", + "option", "option to targetOption as script", + Itcl_ClassDelegateOptionCmd, (ClientData)infoPtr, + Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)infoPtr); + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::class" command to + * specify a class definition. Handles the following syntax: + * + * itcl::class <className> { + * inherit <base-class>... + * + * constructor {<arglist>} ?{<init>}? {<body>} + * destructor {<body>} + * + * method <name> {<arglist>} {<body>} + * proc <name> {<arglist>} {<body>} + * variable <varname> ?<init>? ?<config>? + * common <varname> ?<init>? + * + * public <args>... + * protected <args>... + * private <args>... + * } + * + * ------------------------------------------------------------------------ + */ +static int +ItclGenericClassCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *namePtr; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclComponent *icPtr; + const char *typeStr; + int result; + + + ItclShowArgs(1, "ItclGenericClassCmd", objc-1, objv); + if (objc != 4) { + Tcl_AppendResult(interp, "usage: genericclass <classtype> <classname> ", + "<body>", NULL); + return TCL_ERROR; + } + infoPtr = (ItclObjectInfo *)clientData; + typeStr = Tcl_GetString(objv[1]); + hPtr = Tcl_FindHashEntry(&infoPtr->classTypes, (char *)objv[1]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "genericclass bad classtype \"", typeStr, + "\"", NULL); + return TCL_ERROR; + } + result = ItclClassBaseCmd(clientData, interp, PTR2INT(Tcl_GetHashValue(hPtr)), + objc - 1, objv + 1, &iclsPtr); + if (result != TCL_OK) { + return result; + } + if (PTR2INT(Tcl_GetHashValue(hPtr)) == ITCL_WIDGETADAPTOR) { + /* create the itcl_hull variable */ + namePtr = Tcl_NewStringObj("itcl_hull", -1); + if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON, + &icPtr) != TCL_OK) { + return TCL_ERROR; + } + iclsPtr->numVariables++; + Itcl_BuildVirtualTables(iclsPtr); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::class" command to + * specify a class definition. Handles the following syntax: + * + * itcl::class <className> { + * inherit <base-class>... + * + * constructor {<arglist>} ?{<init>}? {<body>} + * destructor {<body>} + * + * method <name> {<arglist>} {<body>} + * proc <name> {<arglist>} {<body>} + * variable <varname> ?<init>? ?<config>? + * common <varname> ?<init>? + * + * public <args>... + * protected <args>... + * private <args>... + * } + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclClass *iclsPtr; + + return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, + &iclsPtr); +} + +/* + * ------------------------------------------------------------------------ + * ItclClassBaseCmd() + * + * ------------------------------------------------------------------------ + */ + +static Tcl_MethodCallProc ObjCallProc; +static Tcl_MethodCallProc ArgCallProc; +static Tcl_CloneProc CloneProc; + +static const Tcl_MethodType itclObjMethodType = { + TCL_OO_METHOD_VERSION_CURRENT, + "itcl objv method", + ObjCallProc, + ItclReleaseIMF, + CloneProc +}; + +static const Tcl_MethodType itclArgMethodType = { + TCL_OO_METHOD_VERSION_CURRENT, + "itcl argv method", + ArgCallProc, + ItclReleaseIMF, + CloneProc +}; + +static int +CloneProc( + Tcl_Interp *interp, + ClientData original, + ClientData *copyPtr) +{ + ItclPreserveIMF((ItclMemberFunc *)original); + *copyPtr = original; + return TCL_OK; +} + +static int +CallAfterCallMethod( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ClientData clientData = data[0]; + Tcl_ObjectContext context = data[1]; + + return ItclAfterCallMethod(clientData, interp, context, NULL, result); +} + +static int +ObjCallProc( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData; + + if (TCL_ERROR == ItclCheckCallMethod(clientData, interp, context, + NULL, NULL)) { + return TCL_ERROR; + } + + Tcl_NRAddCallback(interp, CallAfterCallMethod, clientData, context, + NULL, NULL); + + if ((imPtr->flags & ITCL_COMMON) == 0) { + return Itcl_ExecMethod(clientData, interp, objc-1, objv+1); + } else { + return Itcl_ExecProc(clientData, interp, objc-1, objv+1); + } +} + +static int +ArgCallProc( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + return TCL_ERROR; +} + +int +ItclClassBaseCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int flags, /* flags: ITCL_CLASS, ITCL_TYPE, + * ITCL_WIDGET or ITCL_WIDGETADAPTOR */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[], /* argument objects */ + ItclClass **iclsPtrPtr) /* for returning iclsPtr */ +{ + Tcl_Obj *argumentPtr; + Tcl_Obj *bodyPtr; + FOREACH_HASH_DECLS; + Tcl_HashEntry *hPtr2; + Tcl_Namespace *parserNs, *ooNs; + Tcl_CallFrame frame; + ItclClass *iclsPtr; + ItclVariable *ivPtr; + ItclObjectInfo* infoPtr; + char *className; + int isNewEntry; + int result; + int noCleanup; + ItclMemberFunc *imPtr; + + infoPtr = (ItclObjectInfo*)clientData; + if (iclsPtrPtr != NULL) { + *iclsPtrPtr = NULL; + } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); + return TCL_ERROR; + } + ItclShowArgs(1, "ItclClassBaseCmd", objc, objv); + className = Tcl_GetString(objv[1]); + + noCleanup = 0; + /* + * Find the namespace to use as a parser for the class definition. + * If for some reason it is destroyed, bail out here. + */ + parserNs = Tcl_FindNamespace(interp, "::itcl::parser", + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (parserNs == NULL) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while parsing class definition for \"%s\")", + className)); + return TCL_ERROR; + } + + /* + * Try to create the specified class and its namespace. + */ + /* need the workaround with infoPtr->currClassFlags to keep the stubs + * call interface compatible! + */ + infoPtr->currClassFlags = flags; + if (Itcl_CreateClass(interp, className, infoPtr, &iclsPtr) != TCL_OK) { + infoPtr->currClassFlags = 0; + return TCL_ERROR; + } + infoPtr->currClassFlags = 0; + iclsPtr->flags = flags; + + /* + * Import the built-in commands from the itcl::builtin namespace. + * Do this before parsing the class definition, so methods/procs + * can override the built-in commands. + */ + result = Tcl_Import(interp, iclsPtr->nsPtr, "::itcl::builtin::*", + /* allowOverwrite */ 1); + ooNs = Tcl_GetObjectNamespace(iclsPtr->oPtr); + if ( result == TCL_OK && ooNs != iclsPtr->nsPtr) { + result = Tcl_Import(interp, ooNs, "::itcl::builtin::*", 1); + } + + if (result != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while installing built-in commands for class \"%s\")", + className)); + goto errorReturn; + } + + /* + * Push this class onto the class definition stack so that it + * becomes the current context for all commands in the parser. + * Activate the parser and evaluate the class definition. + */ + Itcl_PushStack((ClientData)iclsPtr, &infoPtr->clsStack); + + result = Itcl_PushCallFrame(interp, &frame, parserNs, + /* isProcCallFrame */ 0); + + Itcl_SetCallFrameResolver(interp, iclsPtr->resolvePtr); + if (result == TCL_OK) { + result = Tcl_EvalObjEx(interp, objv[2], 0); + Itcl_PopCallFrame(interp); + } + Itcl_PopStack(&infoPtr->clsStack); + + noCleanup = 0; + if (result != TCL_OK) { + Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); + Tcl_Obj *key = Tcl_NewStringObj("-errorline", -1); + Tcl_Obj *stackTrace = NULL; + + Tcl_IncrRefCount(key); + Tcl_DictObjGet(NULL, options, key, &stackTrace); + Tcl_DecrRefCount(key); + if (stackTrace == NULL) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n error while parsing class \"%s\" body %s", + className, Tcl_GetString(objv[2]))); + noCleanup = 1; + } else { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (class \"%s\" body line %s)", + className, Tcl_GetString(stackTrace))); + } + result = TCL_ERROR; + goto errorReturn; + } + + if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) { + /* No [inherit]. Use default inheritance root. */ + Tcl_Obj *cmdPtr = Tcl_NewListObj(4, NULL); + + Tcl_ListObjAppendElement(NULL, cmdPtr, + Tcl_NewStringObj("::oo::define", -1)); + Tcl_ListObjAppendElement(NULL, cmdPtr, iclsPtr->fullNamePtr); + Tcl_ListObjAppendElement(NULL, cmdPtr, + Tcl_NewStringObj("superclass", -1)); + Tcl_ListObjAppendElement(NULL, cmdPtr, + Tcl_NewStringObj("::itcl::Root", -1)); + + Tcl_IncrRefCount(cmdPtr); + result = Tcl_EvalObj(interp, cmdPtr); + Tcl_DecrRefCount(cmdPtr); + if (result == TCL_ERROR) { + goto errorReturn; + } + } + + /* + * At this point, parsing of the class definition has succeeded. + * Add built-in methods such as "configure" and "cget"--as long + * as they don't conflict with those defined in the class. + */ + if (Itcl_InstallBiMethods(interp, iclsPtr) != TCL_OK) { + result = TCL_ERROR; + goto errorReturn; + } + + /* + * Build the name resolution tables for all data members. + */ + Itcl_BuildVirtualTables(iclsPtr); + + /* make the methods and procs known to TclOO */ + FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { + ClientData pmPtr; + argumentPtr = imPtr->codePtr->argumentPtr; + bodyPtr = imPtr->codePtr->bodyPtr; + +if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) { + /* Implementation of this member is coded in C expecting Tcl_Obj */ + + imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, + 1, &itclObjMethodType, (ClientData) imPtr); + ItclPreserveIMF(imPtr); + + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr, + imPtr->namePtr, 1, &itclObjMethodType, (ClientData) imPtr); + ItclPreserveIMF(imPtr); + } + +} else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) { + /* Implementation of this member is coded in C expecting (char *) */ + + imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, + 1, &itclArgMethodType, (ClientData) imPtr); + + ItclPreserveIMF(imPtr); + + + +} else { + if (imPtr->codePtr->flags & ITCL_BUILTIN) { + int isDone; + isDone = 0; + if (imPtr->builtinArgumentPtr == NULL) { +/* FIXME next lines are possibly a MEMORY leak not really sure!! */ + argumentPtr = Tcl_NewStringObj("args", -1); + imPtr->builtinArgumentPtr = argumentPtr; + Tcl_IncrRefCount(imPtr->builtinArgumentPtr); + } else { + argumentPtr = imPtr->builtinArgumentPtr; + } + bodyPtr = Tcl_NewStringObj("return [", -1); + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-cget") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::cget", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-configure") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::configure", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-isa") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::isa", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-createhull") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::createhull", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-keepcomponentoption") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepcomponentoption", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-ignorecomponentoption") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignorercomponentoption", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-renamecomponentoption") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renamecomponentoption", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-keepoptioncomponent") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepoptioncomponent", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-ignoreoptioncomponent") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignoreoptioncomponent", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-renameoptioncomponent") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renameoptioncomponent", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-setupcomponent") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setupcomponent", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-initoptions") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::initoptions", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-getinstancevar") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::getinstancevar", + -1); + isDone = 1; + } + if (iclsPtr->flags & + (ITCL_TYPE|ITCL_WIDGETADAPTOR| + ITCL_WIDGET|ITCL_ECLASS)) { + /* now the builtin stuff for snit functionality */ + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-mytypemethod") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypemethod", + -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-mymethod") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mymethod", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-myvar") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myvar", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-mytypevar") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypevar", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-itcl_hull") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::itcl_hull", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-callinstance") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::callinstance", + -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-myproc") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myproc", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-installhull") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installhull", + -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-installcomponent") == 0) { + Tcl_AppendToObj(bodyPtr, + "::itcl::builtin::installcomponent", -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-classunknown") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::classunknown", + -1); + isDone = 1; + } + if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-destroy") == 0) { + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::destroy", -1); + isDone = 1; + } + } + if (strncmp(Tcl_GetString(imPtr->codePtr->bodyPtr), + "@itcl-builtin-setget", 20) == 0) { + char *cp = Tcl_GetString(imPtr->codePtr->bodyPtr)+20; + Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setget ", -1); + Tcl_AppendToObj(bodyPtr, cp, -1); + Tcl_AppendToObj(bodyPtr, " ", 1); + isDone = 1; + } + if (!isDone) { + Tcl_AppendToObj(bodyPtr, + Tcl_GetString(imPtr->codePtr->bodyPtr), -1); + } + Tcl_AppendToObj(bodyPtr, " {*}$args]", -1); + } + imPtr->tmPtr = (ClientData)Itcl_NewProcClassMethod(interp, + iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, + ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, + bodyPtr, &pmPtr); + hPtr2 = Tcl_CreateHashEntry(&iclsPtr->infoPtr->procMethods, + (char *)imPtr->tmPtr, &isNewEntry); + if (isNewEntry) { + Tcl_SetHashValue(hPtr2, imPtr); + } + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + if (argumentPtr == NULL) { + argumentPtr = iclsPtr->infoPtr->typeDestructorArgumentPtr; + imPtr->codePtr->argumentPtr = argumentPtr; + Tcl_IncrRefCount(argumentPtr); + } + /* + * We're overwriting the tmPtr field, so yank out the + * entry in the procMethods map based on the old one. + */ + if (isNewEntry) { + Tcl_DeleteHashEntry(hPtr2); + } + imPtr->tmPtr = (ClientData)Itcl_NewProcMethod(interp, + iclsPtr->oPtr, ItclCheckCallMethod, ItclAfterCallMethod, + ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, + bodyPtr, &pmPtr); + } +} + if ((imPtr->flags & ITCL_COMMON) == 0) { + imPtr->accessCmd = Tcl_CreateObjCommand(interp, + Tcl_GetString(imPtr->fullNamePtr), + Itcl_ExecMethod, imPtr, ItclReleaseIMF); + ItclPreserveIMF(imPtr); + } else { + imPtr->accessCmd = Tcl_CreateObjCommand(interp, + Tcl_GetString(imPtr->fullNamePtr), + Itcl_ExecProc, imPtr, ItclReleaseIMF); + ItclPreserveIMF(imPtr); + } + } + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + /* initialize the typecomponents and typevariables */ + if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + result = TCL_ERROR; + goto errorReturn; + } + FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { + if ((ivPtr->flags & ITCL_COMMON) && (ivPtr->init != NULL)) { + if (Tcl_SetVar2(interp, Tcl_GetString(ivPtr->namePtr), NULL, + Tcl_GetString(ivPtr->init), + TCL_NAMESPACE_ONLY) == NULL) { + Itcl_PopCallFrame(interp); + result = TCL_ERROR; + goto errorReturn; + } + } + } + Itcl_PopCallFrame(interp); + } + if (iclsPtr->typeConstructorPtr != NULL) { + /* call the typeconstructor body */ + if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + result = TCL_ERROR; + goto errorReturn; + } + result = Tcl_EvalObjEx(interp, iclsPtr->typeConstructorPtr, + TCL_EVAL_DIRECT); + Itcl_PopCallFrame(interp); + if (result != TCL_OK) { + goto errorReturn; + } + } + result = TCL_OK; + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + if (ItclCheckForInitializedComponents(interp, iclsPtr, NULL) != + TCL_OK) { + result = TCL_ERROR; + goto errorReturn; + } + } + + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + if (iclsPtrPtr != NULL) { + *iclsPtrPtr = iclsPtr; + } + ItclAddClassesDictInfo(interp, iclsPtr); + return result; +errorReturn: + if (!noCleanup) { + Tcl_DeleteNamespace(iclsPtr->nsPtr); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclCheckForInitializedComponents() + * + * check if all components for delegation exist and are initialized + * ------------------------------------------------------------------------ + */ +int +ItclCheckForInitializedComponents( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclObject *ioPtr) +{ + FOREACH_HASH_DECLS; + Tcl_CallFrame frame; + Tcl_DString buffer; + ItclDelegatedFunction *idmPtr; + int result; + int doCheck; + + result = TCL_OK; + /* check if the typecomponents are initialized */ + if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, + /*isProcCallFrame*/0) != TCL_OK) { + return TCL_ERROR; + } + idmPtr = NULL; + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + const char *val; + /* check here for delegated typemethods only + * rest is done in ItclCreateObject + */ + doCheck = 1; + if (ioPtr == NULL) { + if (!(idmPtr->flags & ITCL_TYPE_METHOD)) { + doCheck = 0; + ioPtr = iclsPtr->infoPtr->currIoPtr; + } + } + if (doCheck) { + if (idmPtr->icPtr != NULL) { + if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) { + Tcl_Obj *objPtr; + objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace( + idmPtr->icPtr->ivPtr->iclsPtr->oPtr))->fullName, + -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString( + idmPtr->icPtr->ivPtr->namePtr), -1); + val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0); + Tcl_DecrRefCount(objPtr); + } else { + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetString(ioPtr->varNsNamePtr), -1); + Tcl_DStringAppend(&buffer, + Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), + -1); + val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), + NULL, 0); + Tcl_DStringFree(&buffer); + } + if ((ioPtr != NULL) && ((val != NULL) && (strlen(val) == 0))) { + val = ItclGetInstanceVar( + ioPtr->iclsPtr->interp, + "itcl_hull", NULL, ioPtr, + iclsPtr); + } + if ((val == NULL) || (strlen(val) == 0)) { + if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { + if (strcmp (Tcl_GetString(idmPtr->icPtr->namePtr), + "itcl_hull") == 0) { + /* maybe that will be initialized in constructor + * later on */ + continue; + } + } + result = TCL_ERROR; + break; + } + } + } + } + Itcl_PopCallFrame(interp); + if (result == TCL_ERROR) { + const char *startStr; + const char *sepStr; + const char *objectStr; + startStr = ""; + sepStr = ""; + objectStr = ""; + if (ioPtr != NULL) { + sepStr = " "; + objectStr = Tcl_GetString(ioPtr->origNamePtr); + } + if (idmPtr->flags & ITCL_TYPE_METHOD) { + startStr = "type"; + } + /* FIXME there somtimes is a message for widgetadaptor: + * can't read "itcl_hull": no such variable + * have to check why + */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), + sepStr, objectStr, " delegates ", startStr, "method \"", + Tcl_GetString(idmPtr->namePtr), + "\" to undefined ", startStr, "component \"", + Tcl_GetString(idmPtr->icPtr->ivPtr->namePtr), "\"", NULL); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassInheritCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "inherit" command is invoked to define one or more base classes. + * Handles the following syntax: + * + * inherit <baseclass> ?<baseclass>...? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassInheritCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + int result; + int i; + int newEntry; + int haveClasses; + const char *token; + Itcl_ListElem *elem; + Itcl_ListElem *elem2; + ItclClass *cdPtr; + ItclClass *baseClsPtr; + ItclClass *badCdPtr; + ItclHierIter hier; + Itcl_Stack stack; + Tcl_CallFrame frame; + Tcl_DString buffer; + + ItclShowArgs(2, "Itcl_InheritCmd", objc, objv); + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?"); + return TCL_ERROR; + } + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::inherit called from", + " not within a class", NULL); + return TCL_ERROR; + } + /* + * An "inherit" statement can only be included once in a + * class definition. + */ + elem = Itcl_FirstListElem(&iclsPtr->bases); + if (elem != NULL) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1); + + while (elem) { + cdPtr = (ItclClass*)Itcl_GetListValue(elem); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_GetString(cdPtr->namePtr), " ", (char*)NULL); + + elem = Itcl_NextListElem(elem); + } + + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\" already defined for class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Validate each base class and add it to the "bases" list. + */ + result = Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr->parentPtr, + /* isProcCallFrame */ 0); + + if (result != TCL_OK) { + return TCL_ERROR; + } + + for (objc--,objv++; objc > 0; objc--,objv++) { + + /* + * Make sure that the base class name is known in the + * parent namespace (currently active). If not, try + * to autoload its definition. + */ + token = Tcl_GetString(*objv); + baseClsPtr = Itcl_FindClass(interp, token, /* autoload */ 1); + if (!baseClsPtr) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + int errlen; + char *errmsg; + + Tcl_IncrRefCount(resultPtr); + errmsg = Tcl_GetStringFromObj(resultPtr, &errlen); + + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot inherit from \"", token, "\"", + (char*)NULL); + + if (errlen > 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " (", errmsg, ")", (char*)NULL); + } + Tcl_DecrRefCount(resultPtr); + goto inheritError; + } + + /* + * Make sure that the base class is not the same as the + * class that is being built. + */ + if (baseClsPtr == iclsPtr) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "class \"", Tcl_GetString(iclsPtr->namePtr), + "\" cannot inherit from itself", + (char*)NULL); + goto inheritError; + } + + Itcl_AppendList(&iclsPtr->bases, (ClientData)baseClsPtr); + ItclPreserveClass(baseClsPtr); + } + + /* + * Scan through the inheritance list to make sure that no + * class appears twice. + */ + elem = Itcl_FirstListElem(&iclsPtr->bases); + while (elem) { + elem2 = Itcl_NextListElem(elem); + while (elem2) { + if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) { + cdPtr = (ItclClass*)Itcl_GetListValue(elem); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "class \"", iclsPtr->fullNamePtr, + "\" cannot inherit base class \"", + cdPtr->fullNamePtr, "\" more than once", + (char*)NULL); + goto inheritError; + } + elem2 = Itcl_NextListElem(elem2); + } + elem = Itcl_NextListElem(elem); + } + + /* + * Add each base class and all of its base classes into + * the heritage for the current class. Along the way, make + * sure that no class appears twice in the heritage. + */ + Itcl_InitHierIter(&hier, iclsPtr); + cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */ + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + (void) Tcl_CreateHashEntry(&iclsPtr->heritage, + (char*)cdPtr, &newEntry); + + if (!newEntry) { + break; + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + /* + * Same base class found twice in the hierarchy? + * Then flag error. Show the list of multiple paths + * leading to the same base class. + */ + if (!newEntry) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + badCdPtr = cdPtr; + Tcl_AppendStringsToObj(resultPtr, + "class \"", Tcl_GetString(iclsPtr->fullNamePtr), + "\" inherits base class \"", + Tcl_GetString(badCdPtr->fullNamePtr), "\" more than once:", + (char*)NULL); + + cdPtr = iclsPtr; + Itcl_InitStack(&stack); + Itcl_PushStack((ClientData)cdPtr, &stack); + + /* + * Show paths leading to bad base class + */ + while (Itcl_GetStackSize(&stack) > 0) { + cdPtr = (ItclClass*)Itcl_PopStack(&stack); + + if (cdPtr == badCdPtr) { + Tcl_AppendToObj(resultPtr, "\n ", -1); + for (i=0; i < Itcl_GetStackSize(&stack); i++) { + if (Itcl_GetStackValue(&stack, i) == NULL) { + cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); + Tcl_AppendStringsToObj(resultPtr, + Tcl_GetString(cdPtr->namePtr), "->", + (char*)NULL); + } + } + Tcl_AppendToObj(resultPtr, + Tcl_GetString(badCdPtr->namePtr), -1); + } + else if (!cdPtr) { + (void)Itcl_PopStack(&stack); + } + else { + elem = Itcl_LastListElem(&cdPtr->bases); + if (elem) { + Itcl_PushStack((ClientData)cdPtr, &stack); + Itcl_PushStack((ClientData)NULL, &stack); + while (elem) { + Itcl_PushStack(Itcl_GetListValue(elem), &stack); + elem = Itcl_PrevListElem(elem); + } + } + } + } + Itcl_DeleteStack(&stack); + goto inheritError; + } + + /* + * At this point, everything looks good. + * Finish the installation of the base classes. Update + * each base class to recognize the current class as a + * derived class. + */ + Tcl_DStringInit(&buffer); + haveClasses = 0; + elem = Itcl_FirstListElem(&iclsPtr->bases); + Tcl_DStringAppend(&buffer, "::oo::define ", -1); + Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_DStringAppend(&buffer, " superclass", -1); + while (elem) { + baseClsPtr = (ItclClass*)Itcl_GetListValue(elem); + haveClasses++; + Tcl_DStringAppend(&buffer, " ", -1); + Tcl_DStringAppend(&buffer, Tcl_GetString(baseClsPtr->fullNamePtr), -1); + + Itcl_AppendList(&baseClsPtr->derived, (ClientData)iclsPtr); + ItclPreserveClass(iclsPtr); + + elem = Itcl_NextListElem(elem); + } + Itcl_PopCallFrame(interp); + if (haveClasses) { + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buffer), -1, 0); + } + Tcl_DStringFree(&buffer); + + return result; + + + /* + * If the "inherit" list cannot be built properly, tear it + * down and return an error. + */ +inheritError: + Itcl_PopCallFrame(interp); + + elem = Itcl_FirstListElem(&iclsPtr->bases); + while (elem) { + ItclReleaseClass( (ItclClass *)Itcl_GetListValue(elem) ); + elem = Itcl_DeleteListElem(elem); + } + return TCL_ERROR; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassProtectionCmd() + * + * Invoked by Tcl whenever the user issues a protection setting + * command like "public" or "private". Creates commands and + * variables, and assigns a protection level to them. Protection + * levels are defined as follows: + * + * public => accessible from any namespace + * protected => accessible from selected namespaces + * private => accessible only in the namespace where it was defined + * + * Handles the following syntax: + * + * public <command> ?<arg> <arg>...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassProtectionCmd( + ClientData clientData, /* protection level (public/protected/private) */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData; + int result; + int oldLevel; + + ItclShowArgs(2, "Itcl_ClassProtectionCmd", objc, objv); + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?"); + return TCL_ERROR; + } + + oldLevel = Itcl_Protection(interp, pInfo->pLevel); + + if (objc == 2) { + /* something like: public { variable a; variable b } */ + result = Tcl_EvalObjEx(interp, objv[1], 0); + } else { + /* something like: public variable a 123 456 */ + result = Itcl_EvalArgs(interp, objc-1, objv+1); + if (result == TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...? or wrong command name"); + return TCL_ERROR; + } + } + + if (result == TCL_BREAK) { + Tcl_SetResult(interp, "invoked \"break\" outside of a loop", + TCL_STATIC); + result = TCL_ERROR; + } else { + if (result == TCL_CONTINUE) { + Tcl_SetResult(interp, "invoked \"continue\" outside of a loop", + TCL_STATIC); + result = TCL_ERROR; + } else { + if (result != TCL_OK) { + Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); + Tcl_Obj *key = Tcl_NewStringObj("-errorline", -1); + Tcl_Obj *stackTrace = NULL; + + Tcl_IncrRefCount(key); + Tcl_DictObjGet(NULL, options, key, &stackTrace); + Tcl_DecrRefCount(key); + if (stackTrace == NULL) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n error while parsing class \"%s\"", + Tcl_GetString(objv[0]))); + } else { + char *token = Tcl_GetString(objv[0]); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%.100s body line %s)", + token, Tcl_GetString(stackTrace))); + } + } + } + } + + Itcl_Protection(interp, oldLevel); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassConstructorCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "constructor" command is invoked to define the constructor + * for an object. Handles the following syntax: + * + * constructor <arglist> ?<init>? <body> + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassConstructorCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + Tcl_Obj *namePtr; + char *arglist; + char *body; + + ItclShowArgs(2, "Itcl_ClassConstructorCmd", objc, objv); + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body"); + return TCL_ERROR; + } + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::constructor called from", + " not within a class", NULL); + return TCL_ERROR; + } + namePtr = objv[0]; + if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objv[0])) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(namePtr), "\" already defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If there is an object initialization statement, pick this + * out and take the last argument as the constructor body. + */ + arglist = Tcl_GetString(objv[1]); + if (objc == 3) { + body = Tcl_GetString(objv[2]); + } else { + iclsPtr->initCode = objv[2]; + Tcl_IncrRefCount(iclsPtr->initCode); + body = Tcl_GetString(objv[3]); + } + + if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassDestructorCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "destructor" command is invoked to define the destructor + * for an object. Handles the following syntax: + * + * destructor <body> + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassDestructorCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + Tcl_Obj *namePtr; + char *body; + + ItclShowArgs(2, "Itcl_ClassDestructorCmd", objc, objv); + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "body"); + return TCL_ERROR; + } + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::destructor called from", + " not within a class", NULL); + return TCL_ERROR; + } + namePtr = objv[0]; + body = Tcl_GetString(objv[1]); + + if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(namePtr), "\" already defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + if (Itcl_CreateMethod(interp, iclsPtr, namePtr, (char*)NULL, body) + != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "method" command is invoked to define an object method. + * Handles the following syntax: + * + * method <name> ?<arglist>? ?<body>? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassMethodCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *namePtr; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + char *arglist; + char *body; + + ItclShowArgs(2, "Itcl_ClassMethodCmd", objc, objv); + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); + return TCL_ERROR; + } + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::method called from", + " not within a class", NULL); + return TCL_ERROR; + } + namePtr = objv[1]; + + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "method \"", Tcl_GetString(namePtr), + "\" has been delegated", NULL); + return TCL_ERROR; + } + arglist = NULL; + body = NULL; + if (objc >= 3) { + arglist = Tcl_GetString(objv[2]); + } + if (objc >= 4) { + body = Tcl_GetString(objv[3]); + } + + if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassProcCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "proc" command is invoked to define a common class proc. + * A "proc" is like a "method", but only has access to "common" + * class variables. Handles the following syntax: + * + * proc <name> ?<arglist>? ?<body>? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassProcCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + char *arglist; + char *body; + + ItclShowArgs(1, "Itcl_ClassProcCmd", objc, objv); + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); + return TCL_ERROR; + } + + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + namePtr = objv[1]; + + arglist = NULL; + body = NULL; + if (objc >= 3) { + arglist = Tcl_GetString(objv[2]); + } + if (objc >= 4) { + body = Tcl_GetString(objv[3]); + } + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::proc called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + const char *name = Tcl_GetString(namePtr); + /* check if the typemethod is already delegated */ + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) { + Tcl_AppendResult(interp, "Error in \"typemethod ", name, + "...\", \"", name, "\" has been delegated", NULL); + return TCL_ERROR; + } + } + } + if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassTypeMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "proc" command is invoked to define a common class proc. + * A "proc" is like a "method", but only has access to "common" + * class variables. Handles the following syntax: + * + * typemethod <name> ?<arglist>? ?<body>? + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassTypeMethodCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + char *arglist; + char *body; + ItclMemberFunc *imPtr; + + ItclShowArgs(1, "Itcl_ClassTypeMethodCmd", objc, objv); + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); + return TCL_ERROR; + } + + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::typemethod called from", + " not within a class", NULL); + return TCL_ERROR; + } + namePtr = objv[1]; + + arglist = NULL; + body = NULL; + if (objc >= 3) { + arglist = Tcl_GetString(objv[2]); + } + if (objc >= 4) { + body = Tcl_GetString(objv[3]); + } + + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + const char *name = Tcl_GetString(namePtr); + /* check if the typemethod is already delegated */ + FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { + if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) { + Tcl_AppendResult(interp, "Error in \"typemethod ", name, + "...\", \"", name, "\" has been delegated", NULL); + return TCL_ERROR; + } + } + } + iclsPtr->infoPtr->functionFlags = ITCL_TYPE_METHOD; + if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { + iclsPtr->infoPtr->functionFlags = 0; + return TCL_ERROR; + } + iclsPtr->infoPtr->functionFlags = 0; + hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr); + imPtr = Tcl_GetHashValue(hPtr); + imPtr->flags |= ITCL_TYPE_METHOD; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassVariableCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "variable" command is invoked to define an instance variable. + * Handles the following syntax: + * + * variable <varname> ?<init>? ?<config>? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassVariableCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *namePtr; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + ItclVariable *ivPtr; + char *init; + char *config; + char *arrayInitStr; + const char *usageStr; + int pLevel; + int haveError; + int haveArrayInit; + int result; + + result = TCL_OK; + haveError = 0; + haveArrayInit = 0; + usageStr = NULL; + arrayInitStr = NULL; + ItclShowArgs(1, "Itcl_ClassVariableCmd", objc, objv); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::variable called from", + " not within a class", NULL); + return TCL_ERROR; + } + pLevel = Itcl_Protection(interp, 0); + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + if (objc > 2) { + if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) { + if (objc == 4) { + arrayInitStr = Tcl_GetString(objv[3]); + haveArrayInit = 1; + } else { + haveError = 1; + usageStr = "varname ?init|-array init?"; + } + } + } + } + if (!haveError && !haveArrayInit) { + if (pLevel == ITCL_PUBLIC) { + if (objc < 2 || objc > 4) { + usageStr = "name ?init? ?config?"; + haveError = 1; + } + } else { + if ((objc < 2) || (objc > 3)) { + usageStr = "name ?init?"; + haveError = 1; + } + } + } + + if (haveError) { + Tcl_WrongNumArgs(interp, 1, objv, usageStr); + return TCL_ERROR; + } + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + namePtr = objv[1]; + if (strstr(Tcl_GetString(namePtr), "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", Tcl_GetString(namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + init = NULL; + config = NULL; + if (!haveArrayInit) { + if (objc >= 3) { + init = Tcl_GetString(objv[2]); + } + if (objc >= 4) { + config = Tcl_GetString(objv[3]); + } + } + + if (Itcl_CreateVariable(interp, iclsPtr, namePtr, init, config, + &ivPtr) != TCL_OK) { + return TCL_ERROR; + } + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + ivPtr->flags |= ITCL_VARIABLE; + } + if (haveArrayInit) { + ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, -1); + Tcl_IncrRefCount(ivPtr->arrayInitPtr); + } else { + ivPtr->arrayInitPtr = NULL; + } + iclsPtr->numVariables++; + ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclInitClassCommon() + * + * initialize a class commen variable + * + * ------------------------------------------------------------------------ + */ +static int +ItclInitClassCommon( + Tcl_Interp *interp, + ItclClass *iclsPtr, + ItclVariable *ivPtr, + const char *initStr) +{ + Tcl_DString buffer; + Tcl_CallFrame frame; + Tcl_Namespace *commonNsPtr; + Tcl_HashEntry *hPtr; + Tcl_Var varPtr; + int result; + int isNew; + + result = TCL_OK; + ivPtr->flags |= ITCL_COMMON; + iclsPtr->numCommons++; + + /* + * Create the variable in the namespace associated with the + * class. Do this the hard way, to avoid the variable resolver + * procedures. These procedures won't work until we rebuild + * the virtual tables below. + */ + Tcl_DStringInit(&buffer); + if (ivPtr->protection != ITCL_PUBLIC) { + /* public commons go to the class namespace directly the others + * go to the variables namespace of the class */ + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + } + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(ivPtr->iclsPtr->oPtr))->fullName, -1); + commonNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); + if (commonNsPtr == NULL) { + Tcl_AppendResult(interp, "ITCL: cannot find common variables namespace", + " for class \"", Tcl_GetString(ivPtr->iclsPtr->fullNamePtr), + "\"", NULL); + return TCL_ERROR; + } + varPtr = Tcl_NewNamespaceVar(interp, commonNsPtr, + Tcl_GetString(ivPtr->namePtr)); + hPtr = Tcl_CreateHashEntry(&iclsPtr->classCommons, (char *)ivPtr, + &isNew); + if (isNew) { + Itcl_PreserveVar(varPtr); + Tcl_SetHashValue(hPtr, varPtr); + } + result = Itcl_PushCallFrame(interp, &frame, commonNsPtr, + /* isProcCallFrame */ 0); + Itcl_PopCallFrame(interp); + + /* + * TRICKY NOTE: Make sure to rebuild the virtual tables for this + * class so that this variable is ready to access. The variable + * resolver for the parser namespace needs this info to find the + * variable if the developer tries to set it within the class + * definition. + * + * If an initialization value was specified, then initialize + * the variable now. + */ + Itcl_BuildVirtualTables(iclsPtr); + + if (initStr != NULL) { + const char *val; + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); + val = Tcl_SetVar(interp, + Tcl_DStringValue(&buffer), initStr, + TCL_NAMESPACE_ONLY); + + if (!val) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot initialize common variable \"", + Tcl_GetString(ivPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + } + if (ivPtr->arrayInitPtr != NULL) { + int i; + int argc; + const char **argv; + const char *val; + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); + result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr), + &argc, &argv); + for (i = 0; i < argc; i++) { + val = Tcl_SetVar2(interp, Tcl_DStringValue(&buffer), argv[i], + argv[i + 1], TCL_NAMESPACE_ONLY); + if (!val) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot initialize common variable \"", + Tcl_GetString(ivPtr->namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + i++; + } + ckfree((char *)argv); + } + Tcl_DStringFree(&buffer); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCommonCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "common" command is invoked to define a variable that is + * common to all objects in the class. Handles the following syntax: + * + * common <varname> ?<init>? + * + * ------------------------------------------------------------------------ + */ +static int +ItclClassCommonCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[], /* argument objects */ + int protection, + ItclVariable **ivPtrPtr) +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + ItclVariable *ivPtr; + Tcl_Obj *namePtr; + char *arrayInitStr; + const char *usageStr; + char *initStr; + int haveError; + int haveArrayInit; + int result; + + result = TCL_OK; + haveError = 0; + haveArrayInit = 0; + usageStr = NULL; + arrayInitStr = NULL; + *ivPtrPtr = NULL; + ItclShowArgs(2, "Itcl_ClassCommonCmd", objc, objv); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::common called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { + if (objc > 2) { + if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) { + if (objc == 4) { + arrayInitStr = Tcl_GetString(objv[3]); + haveArrayInit = 1; + } else { + haveError = 1; + usageStr = "varname ?init|-array init?"; + } + } + } + } + if (!haveError && !haveArrayInit) { + if ((objc < 2) || (objc > 3)) { + usageStr = "varname ?init?"; + haveError = 1; + } + } + if (haveError) { + Tcl_WrongNumArgs(interp, 1, objv, usageStr); + return TCL_ERROR; + } + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + namePtr = objv[1]; + if (strstr(Tcl_GetString(namePtr), "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", Tcl_GetString(namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + initStr = NULL; + if (!haveArrayInit) { + if (objc >= 3) { + initStr = Tcl_GetString(objv[2]); + } + } + + if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, (char*)NULL, + &ivPtr) != TCL_OK) { + return TCL_ERROR; + } + if (protection != 0) { + ivPtr->protection = protection; + } + if (haveArrayInit) { + ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, -1); + Tcl_IncrRefCount(ivPtr->arrayInitPtr); + } else { + ivPtr->arrayInitPtr = NULL; + } + *ivPtrPtr = ivPtr; + result = ItclInitClassCommon(interp, iclsPtr, ivPtr, initStr); + ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassTypeVariableCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "typevariable" command is invoked to define a variable that is + * common to all objects in the class. Handles the following syntax: + * + * typevariable <varname> ?<init>? + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassTypeVariableCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclVariable *ivPtr; + int result; + + ivPtr = NULL; + ItclShowArgs(1, "Itcl_ClassTypeVariableCmd", objc, objv); + result = ItclClassCommonCmd(clientData, interp, objc, objv, ITCL_PUBLIC, + &ivPtr); + if (ivPtr != NULL) { + ivPtr->flags |= ITCL_TYPE_VARIABLE; + ItclAddClassVariableDictInfo(interp, ivPtr->iclsPtr, ivPtr); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCommonCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "common" command is invoked to define a variable that is + * common to all objects in the class. Handles the following syntax: + * + * common <varname> ?<init>? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCommonCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclVariable *ivPtr; + + ItclShowArgs(2, "Itcl_ClassTypeVariableCmd", objc, objv); + return ItclClassCommonCmd(clientData, interp, objc, objv, 0, &ivPtr); +} + + +/* + * ------------------------------------------------------------------------ + * ItclFreeParserCommandData() + * + * This callback will free() up memory dynamically allocated + * and passed as the ClientData argument to Tcl_CreateObjCommand. + * This callback is required because one can not simply pass + * a pointer to the free() or ckfree() to Tcl_CreateObjCommand. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeParserCommandData( + ClientData cdata) /* client data to be destroyed */ +{ + ckfree(cdata); +} + +/* + * ------------------------------------------------------------------------ + * ItclDelObjectInfo() + * + * Invoked when the management info for [incr Tcl] is no longer being + * used in an interpreter. This will only occur when all class + * manipulation commands are removed from the interpreter. + * ------------------------------------------------------------------------ + */ +static void +ItclDelObjectInfo( + char* cdata) /* client data for class command */ +{ + Tcl_HashSearch place; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)cdata; + ItclObject *ioPtr; + + /* + * Destroy all known objects by deleting their access + * commands. + */ + hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); + while (hPtr) { + ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(infoPtr->interp, ioPtr->accessCmd); + /* + * Fix 227804: Whenever an object to delete was found we + * have to reset the search to the beginning as the + * current entry in the search was deleted and accessing it + * is therefore not allowed anymore. + */ + + hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); + /*hPtr = Tcl_NextHashEntry(&place);*/ + } + Tcl_DeleteHashTable(&infoPtr->objects); + + Itcl_DeleteStack(&infoPtr->clsStack); +/* FIXME !!! + free class_meta_type and object_meta_type +*/ + ckfree((char*)infoPtr); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassFilterCmd() + * + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassFilterCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj **newObjv; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + int result; + + ItclShowArgs(1, "Itcl_ClassFilterCmd", objc, objv); + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::filter called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", + "/::itcl::extendedclass. Only these can have filters", NULL); + return TCL_ERROR; + } + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "<filterName> ?<filterName> ...?"); + return TCL_ERROR; + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2)); + newObjv[0] = Tcl_NewStringObj("::oo::define", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj(Tcl_GetString(iclsPtr->fullNamePtr), -1); + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = Tcl_NewStringObj("filter", -1); + Tcl_IncrRefCount(newObjv[2]); + memcpy(newObjv+3, objv+1, sizeof(Tcl_Obj *)*(objc-1)); +ItclShowArgs(1, "Itcl_ClassFilterCmd2", objc+2, newObjv); + result = Tcl_EvalObjv(interp, objc+2, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[2]); + ckfree((char *)newObjv); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassMixinCmd() + * + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassMixinCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclShowArgs(0, "Itcl_ClassMixinCmd", objc, objv); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_WidgetCmd() + * + * that is just a dummy command to load package ItclWidget + * and then to resend the command and execute it in that package + * package ItclWidget is renaming the Tcl command!! + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_WidgetCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr; + int result; + + ItclShowArgs(1, "Itcl_WidgetCmd", objc-1, objv); + infoPtr = (ItclObjectInfo *)clientData; + if (!infoPtr->itclWidgetInitted) { + result = Tcl_EvalEx(interp, initWidgetScript, -1, 0); + if (result != TCL_OK) { + return result; + } + infoPtr->itclWidgetInitted = 1; + } + return Tcl_EvalObjv(interp, objc, objv, 0); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_WidgetAdaptorCmd() + * + * that is just a dummy command to load package ItclWidget + * and then to resend the command and execute it in that package + * package ItclWidget is renaming the Tcl command!! + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_WidgetAdaptorCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr; + int result; + + ItclShowArgs(1, "Itcl_WidgetAdaptorCmd", objc-1, objv); + infoPtr = (ItclObjectInfo *)clientData; + if (!infoPtr->itclWidgetInitted) { + result = Tcl_EvalEx(interp, initWidgetScript, -1, 0); + if (result != TCL_OK) { + return result; + } + infoPtr->itclWidgetInitted = 1; + } + return Tcl_EvalObjv(interp, objc, objv, 0); +} + +/* + * ------------------------------------------------------------------------ + * ItclParseOption() + * + * Invoked by Tcl during the parsing whenever + * the "option" command is invoked to define an option + * Handles the following syntax: + * + * option + * + * ------------------------------------------------------------------------ + */ +int +ItclParseOption( + ItclObjectInfo *infoPtr, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[], /* argument objects */ + ItclClass *iclsPtr, + ItclObject *ioPtr, + ItclOption **ioptPtrPtr) /* where the otpion info is found */ +{ + Tcl_Obj *classNamePtr; + Tcl_Obj *nameSpecPtr; + Tcl_Obj **newObjv; + Tcl_HashEntry *hPtr; + ItclOption *ioptPtr; + char *init; + char *defaultValue; + char *cgetMethod; + char *cgetMethodVar; + char *configureMethod; + char *configureMethodVar; + char *validateMethod; + char *validateMethodVar; + const char *token; + const char *usage; + const char *optionName; + const char **argv; + const char *name; + const char *resourceName; + const char *className; + int argc; + int pLevel; + int readOnly; + int newObjc; + int foundOption; + int result; + int i; + const char *cp; + + ItclShowArgs(1, "ItclParseOption", objc, objv); + pLevel = Itcl_Protection(interp, 0); + + usage = "namespec \ +?init? \ +?-default value? \ +?-readonly? \ +?-cgetmethod methodName? \ +?-cgetmethodvar varName? \ +?-configuremethod methodName? \ +?-configuremethodvar varName? \ +?-validatemethod methodName? \ +?-validatemethodvar varName"; + + if (pLevel == ITCL_PUBLIC) { + if (objc < 2 || objc > 11) { + Tcl_WrongNumArgs(interp, 1, objv, usage); + return TCL_ERROR; + } + } else { + if ((objc < 2) || (objc > 12)) { + Tcl_WrongNumArgs(interp, 1, objv, usage); + return TCL_ERROR; + } + } + + argv = NULL; + newObjv = NULL; + defaultValue = NULL; + cgetMethod = NULL; + configureMethod = NULL; + validateMethod = NULL; + cgetMethodVar = NULL; + configureMethodVar = NULL; + validateMethodVar = NULL; + readOnly = 0; + newObjc = 0; + optionName = Tcl_GetString(objv[1]); + if (iclsPtr != NULL) { + /* check for already delegated!! */ + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)objv[1]); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "cannot define option \"", optionName, + "\" locally, it has already been delegated", NULL); + result = TCL_ERROR; + goto errorOut; + } + } + if (ioPtr != NULL) { + /* check for already delegated!! */ + hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions, + (char *)objv[1]); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "cannot define option \"", optionName, + "\" locally, it has already been delegated", NULL); + result = TCL_ERROR; + goto errorOut; + } + } + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*objc); + newObjv[newObjc] = objv[1]; + newObjc++; + for (i=2; i<objc; i++) { + token = Tcl_GetString(objv[i]); + foundOption = 0; + if (*token == '-') { + if (objc < i+1) { + Tcl_WrongNumArgs(interp, 1, objv, usage); + result = TCL_ERROR; + goto errorOut; + } + if (strcmp(token, "-default") == 0) { + foundOption = 1; + i++; + defaultValue = Tcl_GetString(objv[i]); + } else { + if (strcmp(token, "-readonly") == 0) { + foundOption = 1; + readOnly = 1; + } else { + if (strncmp(token, "-cgetmethod", 11) == 0) { + if (strcmp(token, "-cgetmethod") == 0) { + foundOption = 1; + i++; + cgetMethod = Tcl_GetString(objv[i]); + } + if (strcmp(token, "-cgetmethodvar") == 0) { + foundOption = 1; + i++; + cgetMethodVar = Tcl_GetString(objv[i]); + } + } else { + if (strncmp(token, "-configuremethod", 16) == 0) { + if (strcmp(token, "-configuremethod") == 0) { + foundOption = 1; + i++; + configureMethod = Tcl_GetString(objv[i]); + } + if (strcmp(token, "-configuremethodvar") == 0) { + foundOption = 1; + i++; + configureMethodVar = Tcl_GetString(objv[i]); + } + } else { + if (strncmp(token, "-validatemethod", 15) == 0) { + if (strcmp(token, "-validatemethod") == 0) { + foundOption = 1; + i++; + validateMethod = Tcl_GetString(objv[i]); + } + if (strcmp(token, "-validatemethodvar") == 0) { + foundOption = 1; + i++; + validateMethodVar = Tcl_GetString(objv[i]); + } + } + } + } + } + } + if (!foundOption) { + Tcl_AppendResult(interp, "funny option command option: \"", + token, "\"", NULL); + return TCL_ERROR; + } + } + if (!foundOption) { + newObjv[newObjc] = objv[i]; + newObjc++; + } + } + + if ((cgetMethod != NULL) && (cgetMethodVar != NULL)) { + Tcl_AppendResult(interp, + "option -cgetmethod and -cgetmethodvar cannot be used both", + NULL); + result = TCL_ERROR; + goto errorOut; + } + if ((configureMethod != NULL) && (configureMethodVar != NULL)) { + Tcl_AppendResult(interp, + "option -configuremethod and -configuremethodvar", + "cannot be used both", + NULL); + result = TCL_ERROR; + goto errorOut; + } + if ((validateMethod != NULL) && (validateMethodVar != NULL)) { + Tcl_AppendResult(interp, + "option -validatemethod and -validatemethodvar", + "cannot be used both", + NULL); + result = TCL_ERROR; + goto errorOut; + } + if (newObjc < 1) { + Tcl_AppendResult(interp, "usage: option ", usage, NULL); + result = TCL_ERROR; + goto errorOut; + } + resourceName = NULL; + className = NULL; + + nameSpecPtr = newObjv[0]; + token = Tcl_GetString(nameSpecPtr); + if (Tcl_SplitList(interp, (const char *)token, &argc, &argv) != TCL_OK) { + result = TCL_ERROR; + goto errorOut; + } + name = argv[0]; + if (*name != '-') { + Tcl_AppendResult(interp, "bad option name \"", name, + "\", options must start with a \"-\"", NULL); + result = TCL_ERROR; + goto errorOut; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + if (strstr(name, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option name \"", name, + "\", option names must not contain \"::\"", (char*)NULL); + result = TCL_ERROR; + goto errorOut; + } + if (strstr(name, " ")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option name \"", name, + "\", option names must not contain \" \"", (char*)NULL); + result = TCL_ERROR; + goto errorOut; + } + cp = name; + while (*cp) { + if (isupper(UCHAR(*cp))) { + Tcl_AppendResult(interp, "bad option name \"", name, "\" ", + ", options must not contain uppercase characters", NULL); + result = TCL_ERROR; + goto errorOut; + } + cp++; + } + if (argc > 1) { + resourceName = argv[1]; + } else { + /* resource name defaults to option name minus hyphen */ + resourceName = name+1; + } + if (argc > 2) { + className = argv[2]; + } else { + /* class name defaults to option name minus hyphen and capitalized */ + className = resourceName; + } + classNamePtr = ItclCapitalize(className); + init = defaultValue; + if ((newObjc > 1) && (init == NULL)) { + init = Tcl_GetString(newObjv[1]); + } + + ioptPtr = (ItclOption*)ckalloc(sizeof(ItclOption)); + memset(ioptPtr, 0, sizeof(ItclOption)); + ioptPtr->protection = Itcl_Protection(interp, 0); + if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) { + ioptPtr->protection = ITCL_PROTECTED; + } + ioptPtr->namePtr = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(ioptPtr->namePtr); + ioptPtr->resourceNamePtr = Tcl_NewStringObj(resourceName, -1); + Tcl_IncrRefCount(ioptPtr->resourceNamePtr); + ioptPtr->classNamePtr = Tcl_NewStringObj(Tcl_GetString(classNamePtr), -1); + Tcl_IncrRefCount(ioptPtr->classNamePtr); + Tcl_DecrRefCount(classNamePtr); + + if (init) { + ioptPtr->defaultValuePtr = Tcl_NewStringObj(init, -1); + Tcl_IncrRefCount(ioptPtr->defaultValuePtr); + } + if (cgetMethod != NULL) { + ioptPtr->cgetMethodPtr = Tcl_NewStringObj(cgetMethod, -1); + Tcl_IncrRefCount(ioptPtr->cgetMethodPtr); + } + if (configureMethod != NULL) { + ioptPtr->configureMethodPtr = Tcl_NewStringObj(configureMethod, -1); + Tcl_IncrRefCount(ioptPtr->configureMethodPtr); + } + if (validateMethod != NULL) { + ioptPtr->validateMethodPtr = Tcl_NewStringObj(validateMethod, -1); + Tcl_IncrRefCount(ioptPtr->validateMethodPtr); + } + if (cgetMethodVar != NULL) { + ioptPtr->cgetMethodVarPtr = Tcl_NewStringObj(cgetMethodVar, -1); + Tcl_IncrRefCount(ioptPtr->cgetMethodVarPtr); + } + if (configureMethodVar != NULL) { + ioptPtr->configureMethodVarPtr = Tcl_NewStringObj(configureMethodVar, -1); + Tcl_IncrRefCount(ioptPtr->configureMethodVarPtr); + } + if (validateMethodVar != NULL) { + ioptPtr->validateMethodVarPtr = Tcl_NewStringObj(validateMethodVar, -1); + Tcl_IncrRefCount(ioptPtr->validateMethodVarPtr); + } + if (readOnly != 0) { + ioptPtr->flags |= ITCL_OPTION_READONLY; + } + + *ioptPtrPtr = ioptPtr; + ItclAddOptionDictInfo(interp, iclsPtr, ioptPtr); + result = TCL_OK; +errorOut: + if (argv != NULL) { + ckfree((char *)argv); + } + if (newObjv != NULL) { + ckfree((char *)newObjv); + } + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassOptionCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "option" command is invoked to define an option + * Handles the following syntax: + * + * option + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassOptionCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclOption *ioptPtr; + const char *tkPackage; + const char *tkVersion; + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + + ItclShowArgs(1, "Itcl_ClassOptionCmd", objc, objv); + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::option called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "a \"class\" cannot have options", NULL); + return TCL_ERROR; + } + + if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "add") == 0)) { + tkVersion = "8.6"; + tkPackage = Tcl_PkgPresent(interp, "Tk", tkVersion, 0); + if (tkPackage == NULL) { + tkPackage = Tcl_PkgRequire(interp, "Tk", tkVersion, 0); + } + if (tkPackage == NULL) { + Tcl_AppendResult(interp, "cannot load package Tk", tkVersion, + NULL); + return TCL_ERROR; + } + return Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL); + } + if (ItclParseOption(infoPtr, interp, objc, objv, iclsPtr, NULL, + &ioptPtr) != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_CreateOption(interp, iclsPtr, ioptPtr) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclCreateComponent() + * + * + * ------------------------------------------------------------------------ + */ +int +ItclCreateComponent( + Tcl_Interp *interp, + ItclClass *iclsPtr, + Tcl_Obj *componentPtr, + int type, + ItclComponent **icPtrPtr) +{ + Tcl_HashEntry *hPtr; + ItclComponent *icPtr; + ItclVariable *ivPtr; + int result; + int isNew; + + if (iclsPtr == NULL) { + return TCL_OK; + } + hPtr = Tcl_CreateHashEntry(&iclsPtr->components, (char *)componentPtr, + &isNew); + if (isNew) { + if (Itcl_CreateVariable(interp, iclsPtr, componentPtr, NULL, NULL, + &ivPtr) != TCL_OK) { + return TCL_ERROR; + } + if (type & ITCL_COMMON) { + result = ItclInitClassCommon(interp, iclsPtr, ivPtr, ""); + if (result != TCL_OK) { + return result; + } + } + if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + if (strcmp(Tcl_GetString(componentPtr), "itcl_hull") == 0) { + /* special built in itcl_hull variable */ + ivPtr->initted = 1; + ivPtr->flags |= ITCL_HULL_VAR; + } + } + ivPtr->flags |= ITCL_COMPONENT_VAR; + icPtr = (ItclComponent *)ckalloc(sizeof(ItclComponent)); + memset(icPtr, 0, sizeof(ItclComponent)); + Tcl_InitObjHashTable(&icPtr->keptOptions); + icPtr->namePtr = componentPtr; + Tcl_IncrRefCount(icPtr->namePtr); + icPtr->ivPtr = ivPtr; + Tcl_SetHashValue(hPtr, icPtr); + ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); + } else { + icPtr =Tcl_GetHashValue(hPtr); + } + *icPtrPtr = icPtr; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclHandleClassComponent() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "component" command is invoked to define a component + * Handles the following syntax: + * + * component + * + * ------------------------------------------------------------------------ + */ +static int +ItclHandleClassComponent( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[], /* argument objects */ + ItclComponent **icPtrPtr) +{ + Tcl_Obj **newObjv; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclComponent *icPtr; + const char *usage; + const char *public; + int inherit; + int haveInherit; + int havePublic; + int newObjc; + int haveValue; + int storageClass; + int i; + + ItclShowArgs(1, "Itcl_ClassComponentCmd", objc, objv); + if (icPtrPtr != NULL) { + *icPtrPtr = NULL; + } + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::component called from", + " not within a class", NULL); + return TCL_ERROR; + } + usage = "component ?-public <typemethod>? ?-inherit ?<flag>??"; + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::extendedclass/::itcl::widget", + "/::itcl::widgetadaptor/::itcl::type.", + " Only these can have components", NULL); + return TCL_ERROR; + } + if ((objc < 2) && (objc > 6)) { + Tcl_AppendResult(interp, "wrong # args should be: ", usage, NULL); + return TCL_ERROR; + } + inherit = 0; + haveInherit = 0; + public = NULL; + havePublic = 0; + for (i = 2; i < objc; i++) { + if (strcmp(Tcl_GetString(objv[i]), "-inherit") == 0) { + if (haveInherit) { + Tcl_AppendResult(interp, "wrong syntax should be: ", + usage, NULL); + return TCL_ERROR; + } + haveValue = 0; + inherit = 1; + if (i < objc - 1) { + if (strcmp(Tcl_GetString(objv[i + 1]), "yes") == 0) { + haveValue = 1; + } + if (strcmp(Tcl_GetString(objv[i + 1]), "YES") == 0) { + haveValue = 1; + } + if (strcmp(Tcl_GetString(objv[i + 1]), "no") == 0) { + haveValue = 1; + inherit = 0; + } + if (strcmp(Tcl_GetString(objv[i + 1]), "NO") == 0) { + haveValue = 1; + inherit = 0; + } + } + if (haveValue) { + i++; + } + haveInherit = 1; + } else { + if (strcmp(Tcl_GetString(objv[i]), "-public") == 0) { + if (havePublic) { + Tcl_AppendResult(interp, "wrong syntax should be: ", + usage, NULL); + return TCL_ERROR; + } + havePublic = 1; + if (i >= objc - 1) { + Tcl_AppendResult(interp, "wrong syntax should be: ", + usage, NULL); + return TCL_ERROR; + } + public = Tcl_GetString(objv[i + 1]); + } else { + Tcl_AppendResult(interp, "wrong syntax should be: ", + usage, NULL); + return TCL_ERROR; + } + } + i++; + } + storageClass = ITCL_COMMON; + if (iclsPtr->flags & ITCL_ECLASS) { + storageClass = 0; + } + if (ItclCreateComponent(interp, iclsPtr, objv[1], storageClass, + &icPtr) != TCL_OK) { + return TCL_ERROR; + } + if (inherit) { + icPtr->flags |= ITCL_COMPONENT_INHERIT; + newObjc = 4; + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); + newObjv[0] = Tcl_NewStringObj("delegate::option", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj("*", -1); + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = Tcl_NewStringObj("to", -1); + Tcl_IncrRefCount(newObjv[2]); + newObjv[3] = objv[1]; + Tcl_IncrRefCount(newObjv[3]); + if (Itcl_ClassDelegateOptionCmd(infoPtr, interp, newObjc, newObjv) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetStringObj(newObjv[0] , "delegate::method", -1); + if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[2]); + Tcl_DecrRefCount(newObjv[3]); + ckfree((char *)newObjv); + } + if (public != NULL) { + icPtr->flags |= ITCL_COMPONENT_PUBLIC; + newObjc = 4; + newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); + newObjv[0] = Tcl_NewStringObj("delegate::method", -1); + Tcl_IncrRefCount(newObjv[0]); + newObjv[1] = Tcl_NewStringObj(public, -1); + Tcl_IncrRefCount(newObjv[1]); + newObjv[2] = Tcl_NewStringObj("to", -1); + Tcl_IncrRefCount(newObjv[2]); + newObjv[3] = objv[1]; + Tcl_IncrRefCount(newObjv[3]); + ItclShowArgs(1, "COMPPUB", newObjc, newObjv); + if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(newObjv[2]); + Tcl_DecrRefCount(newObjv[3]); + ckfree((char *)newObjv); + } + if (icPtrPtr != NULL) { + *icPtrPtr = icPtr; + } + ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassComponentCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "component" command is invoked to define a component + * Handles the following syntax: + * + * component + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassComponentCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclComponent *icPtr; + + return ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr); +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassTypeComponentCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "typecomponent" command is invoked to define a typecomponent + * Handles the following syntax: + * + * component + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassTypeComponentCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclComponent *icPtr; + int result; + + ItclShowArgs(1, "Itcl_ClassTypeComponentCmd", objc, objv); + result = ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr); + if (result != TCL_OK) { + return result; + } + icPtr->ivPtr->flags |= ITCL_COMMON; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclCreateDelegatedFunction() + * + * Install a delegated function for a class + * + * ------------------------------------------------------------------------ + */ +int +ItclCreateDelegatedFunction( + Tcl_Interp *interp, + ItclClass *iclsPtr, + Tcl_Obj *methodNamePtr, + ItclComponent *icPtr, + Tcl_Obj *targetPtr, + Tcl_Obj *usingPtr, + Tcl_Obj *exceptionsPtr, + ItclDelegatedFunction **idmPtrPtr) +{ + ItclDelegatedFunction *idmPtr; + const char **argv; + int argc; + int isNew; + int i; + + idmPtr = (ItclDelegatedFunction *)ckalloc(sizeof(ItclDelegatedFunction)); + memset(idmPtr, 0, sizeof(ItclDelegatedFunction)); + Tcl_InitObjHashTable(&idmPtr->exceptions); + idmPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(methodNamePtr), -1); + Tcl_IncrRefCount(idmPtr->namePtr); + idmPtr->icPtr = icPtr; + idmPtr->asPtr = targetPtr; + if (idmPtr->asPtr != NULL) { + Tcl_IncrRefCount(idmPtr->asPtr); + } + idmPtr->usingPtr = usingPtr; + if (idmPtr->usingPtr != NULL) { + Tcl_IncrRefCount(idmPtr->usingPtr); + } + if (exceptionsPtr != NULL) { + if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv) + != TCL_OK) { + return TCL_ERROR; + } + for(i = 0; i < argc; i++) { + Tcl_Obj *objPtr; + objPtr = Tcl_NewStringObj(argv[i], -1); + Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr, + &isNew); + } + ckfree((char *) argv); + } + if (idmPtrPtr != NULL) { + *idmPtrPtr = idmPtr; + } + ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_HandleDelegateMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "delegate method" command is invoked to define a + * Handles the following syntax: + * + * delegate method + * + * ------------------------------------------------------------------------ + */ +int +Itcl_HandleDelegateMethodCmd( + Tcl_Interp *interp, /* current interpreter */ + ItclObject *ioPtr, /* != NULL for ::itcl::adddelegatedmethod + otherwise NULL */ + ItclClass *iclsPtr, /* != NULL for delegate method otherwise NULL */ + ItclDelegatedFunction **idmPtrPtr, + /* where to return idoPtr */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *methodNamePtr; + Tcl_Obj *componentPtr; + Tcl_Obj *targetPtr; + Tcl_Obj *usingPtr; + Tcl_Obj *exceptionsPtr; + Tcl_HashEntry *hPtr; + ItclClass *iclsPtr2; + ItclComponent *icPtr; + ItclHierIter hier; + const char *usageStr; + const char *methodName; + const char *component; + const char *token; + int result; + int i; + int foundOpt; + + ItclShowArgs(1, "Itcl_HandleDelegateMethodCmd", objc, objv); + usageStr = "delegate method <methodName> to <componentName> ?as <targetName>?\n\ +delegate method <methodName> ?to <componentName>? using <pattern>\n\ +delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?"; + if (objc < 4) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + return TCL_ERROR; + } + componentPtr = NULL; + icPtr = NULL; + methodName = Tcl_GetString(objv[1]); + component = NULL; + targetPtr = NULL; + usingPtr = NULL; + exceptionsPtr = NULL; + for(i=2;i<objc;i++) { + token = Tcl_GetString(objv[i]); + if (i+1 == objc) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + return TCL_ERROR; + } + foundOpt = 0; + if (strcmp(token, "to") == 0) { + i++; + component = Tcl_GetString(objv[i]); + componentPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "as") == 0) { + i++; + targetPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "except") == 0) { + i++; + exceptionsPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "using") == 0) { + i++; + usingPtr = objv[i]; + foundOpt++; + } + if (!foundOpt) { + Tcl_AppendResult(interp, "bad option \"", token, "\" should be ", + usageStr, NULL); + return TCL_ERROR; + } + } + if ((exceptionsPtr != NULL) && (*methodName != '*')) { + Tcl_AppendResult(interp, + "can only specify \"except\" with \"delegate method *\"", NULL); + return TCL_ERROR; + } + if ((component == NULL) && (usingPtr == NULL)) { + Tcl_AppendResult(interp, "missing to should be: ", usageStr, NULL); + return TCL_ERROR; + } + if ((*methodName == '*') && (targetPtr != NULL)) { + Tcl_AppendResult(interp, + "cannot specify \"as\" with \"delegate method *\"", NULL); + return TCL_ERROR; + } + /* check for already delegated */ + methodNamePtr = Tcl_NewStringObj(methodName, -1); + if (ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedFunctions, (char *) + methodNamePtr); + } else { + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *) + methodNamePtr); + } + + hPtr = NULL; + if (ioPtr != NULL) { + if (componentPtr != NULL) { + Itcl_InitHierIter(&hier, ioPtr->iclsPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->components, + (char *)componentPtr); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + } + } else { + if (componentPtr != NULL) { + iclsPtr2 = iclsPtr; + Itcl_InitHierIter(&hier, iclsPtr2); + while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr2->components, + (char *)componentPtr); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + } + } + if (hPtr == NULL) { + if (componentPtr != NULL) { + if (ItclCreateComponent(interp, iclsPtr, componentPtr, + ITCL_COMMON, &icPtr) != TCL_OK) { + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iclsPtr->components, + (char *)componentPtr); + } + } + if (hPtr != NULL) { + icPtr = Tcl_GetHashValue(hPtr); + } + if (*methodName != '*') { + /* FIXME !!! */ + /* check for locally defined method */ + hPtr = NULL; + if (ioPtr != NULL) { + } else { + /* FIXME !! have to check the hierarchy !! */ + hPtr = Tcl_FindHashEntry(&iclsPtr->functions, + (char *)methodNamePtr); + + } + if (hPtr != NULL) { + Tcl_AppendResult(interp, "method \"", methodName, + "\" has been defined locally", NULL); + result = TCL_ERROR; + goto errorOut; + } + } + result = ItclCreateDelegatedFunction(interp, iclsPtr, methodNamePtr, icPtr, + targetPtr, usingPtr, exceptionsPtr, idmPtrPtr); + (*idmPtrPtr)->flags |= ITCL_METHOD; +errorOut: + Tcl_DecrRefCount(methodNamePtr); + return result; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassDelegateMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "delegate method" command is invoked to define a + * Handles the following syntax: + * + * delegate method + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassDelegateMethodCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclDelegatedFunction *idmPtr; + int isNew; + int result; + + ItclShowArgs(1, "Itcl_ClassDelegateMethodCmd", objc, objv); + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatemethod called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", + "/::itcl::extendedclass.", + " Only these can delegate methods", NULL); + return TCL_ERROR; + } + result = Itcl_HandleDelegateMethodCmd(interp, NULL, iclsPtr, &idmPtr, objc, + objv); + if (result != TCL_OK) { + return result; + } + idmPtr->flags |= ITCL_METHOD; + hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions, + (char *)idmPtr->namePtr, &isNew); + Tcl_SetHashValue(hPtr, idmPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_HandleDelegateOptionCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "delegate option" command is invoked to define a delegated option + * or if ::itcl::adddelegatedoption is called with an itcl object + * Handles the following syntax: + * + * delegate option ... + * + * ------------------------------------------------------------------------ + */ +int +Itcl_HandleDelegateOptionCmd( + Tcl_Interp *interp, /* current interpreter */ + ItclObject *ioPtr, /* != NULL for ::itcl::adddelgatedoption + otherwise NULL */ + ItclClass *iclsPtr, /* != NULL for delegate option otherwise NULL */ + ItclDelegatedOption **idoPtrPtr, + /* where to return idoPtr */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ + +{ + Tcl_Obj *allOptionNamePtr; + Tcl_Obj *optionNamePtr; + Tcl_Obj *componentPtr; + Tcl_Obj *targetPtr; + Tcl_Obj *exceptionsPtr; + Tcl_Obj *resourceNamePtr; + Tcl_Obj *classNamePtr; + Tcl_HashEntry *hPtr; + ItclComponent *icPtr; + ItclClass *iclsPtr2; + ItclDelegatedOption *idoPtr; + ItclHierIter hier; + const char *usageStr; + const char *option; + const char *component; + const char *token; + const char **argv; + int foundOpt; + int argc; + int isStarOption; + int isNew; + int i; + const char *cp; + + ItclShowArgs(1, "Itcl_HandleDelegatedOptionCmd", objc, objv); + usageStr = "<optionDef> to <targetDef> ?as <script>? ?except <script>?"; + if (objc < 4) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + return TCL_ERROR; + } + componentPtr = NULL; + icPtr = NULL; + isStarOption = 0; + token = Tcl_GetString(objv[1]); + if (Tcl_SplitList(interp, (const char *)token, &argc, &argv) != TCL_OK) { + return TCL_ERROR; + } + option = argv[0]; + if (strcmp(option, "*") == 0) { + isStarOption = 1; + } + if ((argc < 1) || (isStarOption && (argc > 1))) { + Tcl_AppendResult(interp, "<optionDef> must be either \"*\" or ", + "\"<optionName> <resourceName> <className>\"", NULL); + ckfree((char *)argv); + return TCL_ERROR; + } + if (isStarOption && (argc > 3)) { + Tcl_AppendResult(interp, "<optionDef> syntax should be: ", + "\"<optionName> <resourceName> <className>\"", NULL); + ckfree((char *)argv); + return TCL_ERROR; + } + if ((*option != '-') && !isStarOption) { + Tcl_AppendResult(interp, "bad delegated option name \"", option, + "\", options must start with a \"-\"", NULL); + ckfree((char *)argv); + return TCL_ERROR; + } + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + if (strstr(option, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option name \"", option, + "\", option names must not contain \"::\"", (char*)NULL); + ckfree((char *)argv); + return TCL_ERROR; + } + if (strstr(option, " ")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option name \"", option, + "\", option names must not contain \" \"", (char*)NULL); + ckfree((char *)argv); + return TCL_ERROR; + } + cp = option; + while (*cp) { + if (isupper(UCHAR(*cp))) { + Tcl_AppendResult(interp, "bad option name \"", option, "\" ", + ", options must not contain uppercase characters", NULL); + ckfree((char *)argv); + return TCL_ERROR; + } + cp++; + } + optionNamePtr = Tcl_NewStringObj(option, -1); + Tcl_IncrRefCount(optionNamePtr); + resourceNamePtr = NULL; + classNamePtr = NULL; + if (argc > 1) { + resourceNamePtr = Tcl_NewStringObj(argv[1], -1); + Tcl_IncrRefCount(resourceNamePtr); + } + if (argc > 2) { + classNamePtr = Tcl_NewStringObj(argv[2], -1); + } + component = NULL; + targetPtr = NULL; + exceptionsPtr = NULL; + for(i=2;i<objc;i++) { + token = Tcl_GetString(objv[i]); + if (i+1 == objc) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + goto errorOut1; + } + foundOpt = 0; + if (strcmp(token, "to") == 0) { + i++; + component = Tcl_GetString(objv[i]); + componentPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "as") == 0) { + i++; + targetPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "except") == 0) { + i++; + exceptionsPtr = objv[i]; + foundOpt++; + } + if (!foundOpt) { + Tcl_AppendResult(interp, "bad option \"", token, "\" should be ", + usageStr, NULL); + goto errorOut1; + } + } + if (component == NULL) { + Tcl_AppendResult(interp, "missing to should be: ", usageStr, NULL); + goto errorOut1; + } + if ((*option == '*') && (targetPtr != NULL)) { + Tcl_AppendResult(interp, + "cannot specify \"as\" with \"delegate option *\"", NULL); + goto errorOut1; + } + /* check for already delegated */ + allOptionNamePtr = Tcl_NewStringObj("*", -1); + Tcl_IncrRefCount(allOptionNamePtr); + if (ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions, (char *) + allOptionNamePtr); + } else { + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *) + allOptionNamePtr); + } + Tcl_DecrRefCount(allOptionNamePtr); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "option \"", option, + "\" is already delegated", NULL); + goto errorOut1; + } + + if (ioPtr != NULL) { + Itcl_InitHierIter(&hier, ioPtr->iclsPtr); + while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->components, + (char *)componentPtr); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + } else { + Itcl_InitHierIter(&hier, iclsPtr); + while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr2->components, + (char *)componentPtr); + if (hPtr != NULL) { + break; + } + } + Itcl_DeleteHierIter(&hier); + } + if (hPtr == NULL) { + if (componentPtr != NULL) { + if (ItclCreateComponent(interp, iclsPtr, componentPtr, + ITCL_COMMON, &icPtr) != TCL_OK) { + goto errorOut1; + } + hPtr = Tcl_FindHashEntry(&iclsPtr->components, + (char *)componentPtr); + } + } + if (hPtr != NULL) { + icPtr = Tcl_GetHashValue(hPtr); + } + if (*option != '*') { + /* FIXME !!! */ + /* check for valid option name */ + if (ioPtr != NULL) { + hPtr = Tcl_FindHashEntry(&ioPtr->objectOptions, + (char *)optionNamePtr); + } else { + Itcl_InitHierIter(&hier, iclsPtr); + while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr2->options, + (char *)optionNamePtr); + if (hPtr != NULL) { + break; + } + } + } + if (hPtr != NULL) { + Tcl_AppendResult(interp, "option \"", option, + "\" has been defined locally", NULL); + goto errorOut1; + return TCL_ERROR; + } + } + idoPtr = (ItclDelegatedOption *)ckalloc(sizeof(ItclDelegatedOption)); + memset(idoPtr, 0, sizeof(ItclDelegatedOption)); + Tcl_InitObjHashTable(&idoPtr->exceptions); + if (*option != '*') { + if (targetPtr == NULL) { + targetPtr = optionNamePtr; + } + if (resourceNamePtr == NULL) { + resourceNamePtr = Tcl_NewStringObj(option+1, -1); + Tcl_IncrRefCount(resourceNamePtr); + } + if (classNamePtr == NULL) { + classNamePtr = ItclCapitalize(Tcl_GetString(resourceNamePtr)); + } + idoPtr->namePtr = optionNamePtr; + idoPtr->resourceNamePtr = resourceNamePtr; + idoPtr->classNamePtr = Tcl_NewStringObj( + Tcl_GetString(classNamePtr), -1); + Tcl_IncrRefCount(idoPtr->classNamePtr); + Tcl_DecrRefCount(classNamePtr); + + } else { + idoPtr->namePtr = optionNamePtr; + } + Itcl_PreserveData(idoPtr); + Itcl_EventuallyFree((ClientData)idoPtr, ItclDeleteDelegatedOption); + idoPtr->icPtr = icPtr; + idoPtr->asPtr = targetPtr; + if (idoPtr->asPtr != NULL) { + Tcl_IncrRefCount(idoPtr->asPtr); + } + if (exceptionsPtr != NULL) { + ckfree((char *)argv); + argv = NULL; + if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv) + != TCL_OK) { + goto errorOut2; + } + for(i=0;i<argc;i++) { + Tcl_Obj *objPtr; + objPtr = Tcl_NewStringObj(argv[i], -1); + hPtr = Tcl_CreateHashEntry(&idoPtr->exceptions, (char *)objPtr, + &isNew); + } + } + if (idoPtrPtr != NULL) { + *idoPtrPtr = idoPtr; + } + ckfree((char *)argv); + ItclAddDelegatedOptionDictInfo(interp, iclsPtr, idoPtr); + return TCL_OK; +errorOut2: + /* FIXME need to decr additional refCount's !! */ +errorOut1: + Tcl_DecrRefCount(optionNamePtr); + if (resourceNamePtr != NULL) { + Tcl_DecrRefCount(resourceNamePtr); + } + if (classNamePtr != NULL) { + Tcl_DecrRefCount(classNamePtr); + } + if (argv) { + ckfree((char *)argv); + } + return TCL_ERROR; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassDelegateOptionCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "delegate option" command is invoked to define a + * Handles the following syntax: + * + * delegate option + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassDelegateOptionCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclDelegatedOption *idoPtr; + const char *usageStr; + int isNew; + int result; + + ItclShowArgs(1, "Itcl_ClassDelegateOptionCmd", objc, objv); + usageStr = "<optionDef> to <targetDef> ?as <script>? ?except <script>?"; + if (objc < 4) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + return TCL_ERROR; + } + infoPtr = (ItclObjectInfo *)clientData; + iclsPtr = (ItclClass *)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::delegateoption called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", + "/::itcl::extendedclass.", + " Only these can delegate options", NULL); + return TCL_ERROR; + } + result = Itcl_HandleDelegateOptionCmd(interp, NULL, iclsPtr, &idoPtr, + objc, objv); + if (result != TCL_OK) { + return result; + } + hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedOptions, + (char *)idoPtr->namePtr, &isNew); + Tcl_SetHashValue(hPtr, idoPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassDelegateTypeMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "delegate typemethod" command is invoked to define a + * Handles the following syntax: + * + * delegate typemethod + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassDelegateTypeMethodCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *typeMethodNamePtr; + Tcl_Obj *componentPtr; + Tcl_Obj *targetPtr; + Tcl_Obj *usingPtr; + Tcl_Obj *exceptionsPtr; + Tcl_HashEntry *hPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclComponent *icPtr; + ItclDelegatedFunction *idmPtr; + const char *usageStr; + const char *typeMethodName; + const char *component; + const char *token; + const char **argv; + int foundOpt; + int argc; + int isNew; + int i; + + ItclShowArgs(1, "Itcl_ClassDelegateTypeMethodCmd", objc, objv); + usageStr = "delegate typemethod <typeMethodName> to <componentName> ?as <targetName>?\n\ +delegate typemethod <typeMethodName> ?to <componentName>? using <pattern>\n\ +delegate typemethod * ?to <componentName>? ?using <pattern>? ?except <typemethods>?"; + componentPtr = NULL; + icPtr = NULL; + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatetypemethod called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type.", + " Only these can delegate typemethods", NULL); + return TCL_ERROR; + } + + if (objc < 4) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + return TCL_ERROR; + } + typeMethodName = Tcl_GetString(objv[1]); + /* check if typeMethodName has been delegated */ + component = NULL; + targetPtr = NULL; + usingPtr = NULL; + exceptionsPtr = NULL; + for(i=2;i<objc;i++) { + token = Tcl_GetString(objv[i]); + if (i+1 == objc) { + Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); + return TCL_ERROR; + } + foundOpt = 0; + if (strcmp(token, "to") == 0) { + i++; + component = Tcl_GetString(objv[i]); + componentPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "as") == 0) { + i++; + targetPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "except") == 0) { + i++; + exceptionsPtr = objv[i]; + foundOpt++; + } + if (strcmp(token, "using") == 0) { + i++; + usingPtr = objv[i]; + foundOpt++; + } + if (!foundOpt) { + Tcl_AppendResult(interp, "bad option \"", token, "\" should be ", + usageStr, NULL); + return TCL_ERROR; + } + } + if ((component == NULL) && (usingPtr == NULL)) { + Tcl_AppendResult(interp, "missing to should be: ", usageStr, NULL); + return TCL_ERROR; + } + if ((*typeMethodName == '*') && (targetPtr != NULL)) { + Tcl_AppendResult(interp, + "cannot specify \"as\" with \"delegate typemethod *\"", NULL); + return TCL_ERROR; + } + if (componentPtr != NULL) { + hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr); + if (hPtr == NULL) { + if (ItclCreateComponent(interp, iclsPtr, componentPtr, + ITCL_COMMON, &icPtr) != TCL_OK) { + return TCL_ERROR; + } + } else { + icPtr = Tcl_GetHashValue(hPtr); + } + } else { + icPtr = NULL; + } + idmPtr = (ItclDelegatedFunction *)ckalloc(sizeof(ItclDelegatedFunction)); + memset(idmPtr, 0, sizeof(ItclDelegatedFunction)); + Tcl_InitObjHashTable(&idmPtr->exceptions); + typeMethodNamePtr = Tcl_NewStringObj(typeMethodName, -1); + if (*typeMethodName != '*') { + /* FIXME !!! */ + /* check for locally defined typemethod */ + hPtr = Tcl_FindHashEntry(&iclsPtr->functions, + (char *)typeMethodNamePtr); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "Error in \"delegate typemethod ", + typeMethodName, "...\", \"", typeMethodName, + "\" has been defined locally.", NULL); + Tcl_DeleteHashTable(&idmPtr->exceptions); + ckfree((char *)idmPtr); + Tcl_DecrRefCount(typeMethodNamePtr); + return TCL_ERROR; + } + idmPtr->namePtr = Tcl_NewStringObj( + Tcl_GetString(typeMethodNamePtr), -1); + Tcl_IncrRefCount(idmPtr->namePtr); + } else { + Tcl_DecrRefCount(typeMethodNamePtr); + typeMethodNamePtr = Tcl_NewStringObj("*", -1); + Tcl_IncrRefCount(typeMethodNamePtr); + idmPtr->namePtr = typeMethodNamePtr; + Tcl_IncrRefCount(typeMethodNamePtr); + if (exceptionsPtr != NULL) { + if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), + &argc, &argv) != TCL_OK) { + return TCL_ERROR; + } + for(i = 0; i < argc; i++) { + Tcl_Obj *objPtr; + objPtr = Tcl_NewStringObj(argv[i], -1); + hPtr = Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr, + &isNew); + } + ckfree((char *) argv); + } + } + idmPtr->icPtr = icPtr; + idmPtr->asPtr = targetPtr; + if (idmPtr->asPtr != NULL) { + Tcl_IncrRefCount(idmPtr->asPtr); + } + idmPtr->usingPtr = usingPtr; + if (idmPtr->usingPtr != NULL) { + Tcl_IncrRefCount(idmPtr->usingPtr); + } + idmPtr->flags = ITCL_COMMON|ITCL_TYPE_METHOD; + hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions, + (char *)idmPtr->namePtr, &isNew); + if (!isNew) { + ItclDeleteDelegatedFunction((ItclDelegatedFunction *) + Tcl_GetHashValue(hPtr)); + } + Tcl_SetHashValue(hPtr, idmPtr); + Tcl_DecrRefCount(typeMethodNamePtr); + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_ClassForwardCmd() + * + * Used similar to interp alias to forward the call of a method + * to another method within the class + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_ClassForwardCmd( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *prefixObj; + Tcl_Method mPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + + ItclShowArgs(1, "Itcl_ClassForwardCmd", objc, objv); + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::forward called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::widget/::itcl::widgetadaptor/", + "::itcl::type/::itcl::extendedclass.", + " Only these can forward", NULL); + return TCL_ERROR; + } + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "<forwardName> <targetName> ?<arg> ...?"); + return TCL_ERROR; + } + prefixObj = Tcl_NewListObj(objc-2, objv+2); + mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1, + objv[1], prefixObj); + if (mPtr == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} +/* + * ------------------------------------------------------------------------ + * Itcl_ClassMethodVariableCmd() + * + * Used to similar to iterp alias to forward the call of a method + * to another method within the class + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +Itcl_ClassMethodVariableCmd( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Obj *namePtr; + Tcl_Obj *defaultPtr; + Tcl_Obj *callbackPtr; + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclVariable *ivPtr; + ItclMemberFunc *imPtr; + ItclMethodVariable *imvPtr; + const char *token; + const char *usageStr; + int i; + int foundOpt; + int result; + Tcl_Obj *objPtr; + + ItclShowArgs(1, "Itcl_ClassMethodVariableCmd", objc, objv); + infoPtr = (ItclObjectInfo*)clientData; + iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::methodvariable called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), + " is no ::itcl::widget/::itcl::widgetadaptor/", + "::itcl::type/::itcl::extendedclass.", + " Only these can have methodvariables", NULL); + return TCL_ERROR; + } + usageStr = "<name> ?-default value? ?-callback script?"; + if ((objc < 2) || (objc > 6)) { + Tcl_WrongNumArgs(interp, 1, objv, usageStr); + return TCL_ERROR; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + namePtr = objv[1]; + if (strstr(Tcl_GetString(namePtr), "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", Tcl_GetString(namePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + defaultPtr = NULL; + callbackPtr = NULL; + for (i=2;i<objc;i++) { + foundOpt = 0; + token = Tcl_GetString(objv[i]); + if (strcmp(token, "-default") == 0) { + if (i+1 > objc) { + Tcl_WrongNumArgs(interp, 1, objv, usageStr); + return TCL_ERROR; + } + defaultPtr = objv[i+1]; + i++; + foundOpt++; + } + if (strcmp(token, "-callback") == 0) { + if (i+1 > objc) { + Tcl_WrongNumArgs(interp, 1, objv, usageStr); + return TCL_ERROR; + } + callbackPtr = objv[i+1]; + i++; + foundOpt++; + } + if (!foundOpt) { + Tcl_WrongNumArgs(interp, 1, objv, usageStr); + return TCL_ERROR; + } + } + + if (Itcl_CreateVariable(interp, iclsPtr, namePtr, + Tcl_GetString(defaultPtr), NULL, &ivPtr) != TCL_OK) { + return TCL_ERROR; + } + iclsPtr->numVariables++; + result = Itcl_CreateMethodVariable(interp, iclsPtr, namePtr, defaultPtr, + callbackPtr, &imvPtr); + if (result != TCL_OK) { + return result; + } + objPtr = Tcl_NewStringObj("@itcl-builtin-setget ", -1); + Tcl_AppendToObj(objPtr, Tcl_GetString(namePtr), -1); + Tcl_AppendToObj(objPtr, " ", 1); + result = ItclCreateMethod(interp, iclsPtr, namePtr, "args", + Tcl_GetString(objPtr), &imPtr); + if (result != TCL_OK) { + return result; + } + /* install a write trace if callbackPtr != NULL */ + /* FIXME to be done */ + ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassTypeConstructorCmd() + * + * Invoked by Tcl during the parsing of a type class definition whenever + * the "typeconstructor" command is invoked to define the typeconstructor + * for an object. Handles the following syntax: + * + * typeconstructor <body> + * + * ------------------------------------------------------------------------ + */ +static int +Itcl_ClassTypeConstructorCmd( + ClientData clientData, /* info for all known objects */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + Tcl_Obj *namePtr; + + ItclShowArgs(1, "Itcl_ClassTypeConstructorCmd", objc, objv); + + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "Error: ::itcl::parser::typeconstructor called from", + " not within a class", NULL); + return TCL_ERROR; + } + if (iclsPtr->flags & ITCL_CLASS) { + Tcl_AppendResult(interp, "a \"class\" cannot have a typeconstructor", + NULL); + return TCL_ERROR; + } + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "body"); + return TCL_ERROR; + } + + namePtr = objv[0]; + if (iclsPtr->typeConstructorPtr != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(namePtr), "\" already defined in class \"", + Tcl_GetString(iclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + + iclsPtr->typeConstructorPtr = Tcl_NewStringObj(Tcl_GetString(objv[1]), -1); + Tcl_IncrRefCount(iclsPtr->typeConstructorPtr); + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve.c new file mode 100644 index 0000000..c22ced2 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve.c @@ -0,0 +1,697 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle command and variable resolution + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * This structure is a subclass of Tcl_ResolvedVarInfo that contains the + * ItclVarLookup info needed at runtime. + */ +typedef struct ItclResolvedVarInfo { + Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ + ItclVarLookup *vlookup; /* Pointer to lookup info. */ +} ItclResolvedVarInfo; + +static Tcl_Var ItclClassRuntimeVarResolver( + Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr); + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCmdResolver() + * + * Used by the class namespaces to handle name resolution for all + * commands. This procedure looks for references to class methods + * and procs, and returns TCL_OK along with the appropriate Tcl + * command in the rPtr argument. If a particular command is private, + * this procedure returns TCL_ERROR and access to the command is + * denied. If a command is not recognized, this procedure returns + * TCL_CONTINUE, and lookup continues via the normal Tcl name + * resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCmdResolver( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the command being accessed */ + Tcl_Namespace *nsPtr, /* namespace performing the resolution */ + int flags, /* TCL_LEAVE_ERR_MSG => leave error messages + * in interp if anything goes wrong */ + Tcl_Command *rPtr) /* returns: resolved command */ +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *objPtr; + Tcl_Obj *namePtr; + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + ItclMemberFunc *imPtr; + int inOptionHandling; + int isCmdDeleted; + + if ((name[0] == 't') && (strcmp(name, "this") == 0)) { + return TCL_CONTINUE; + } + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + iclsPtr = Tcl_GetHashValue(hPtr); + /* + * If the command is a member function + */ + imPtr = NULL; + objPtr = Tcl_NewStringObj(name, -1); + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + if (hPtr == NULL) { + ItclCmdLookup *clookup; + if ((iclsPtr->flags & ITCL_ECLASS)) { + namePtr = Tcl_NewStringObj(name, -1); + hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, + (char *)namePtr); + if (hPtr != NULL) { + objPtr = Tcl_NewStringObj("unknown", -1); + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); + Tcl_DecrRefCount(objPtr); + } + Tcl_DecrRefCount(namePtr); + } + if (hPtr == NULL) { + return TCL_CONTINUE; + } + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + } else { + ItclCmdLookup *clookup; + clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); + imPtr = clookup->imPtr; + } + + if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { + /* FIXME check if called from an (instance) method (not from a typemethod) and only then error */ + int isOk = 0; + if (strcmp(name, "info") == 0) { + isOk = 1; + } + if (strcmp(name, "mytypemethod") == 0) { + isOk = 1; + } + if (strcmp(name, "myproc") == 0) { + isOk = 1; + } + if (strcmp(name, "mymethod") == 0) { + isOk = 1; + } + if (strcmp(name, "mytypevar") == 0) { + isOk = 1; + } + if (strcmp(name, "myvar") == 0) { + isOk = 1; + } + if (strcmp(name, "itcl_hull") == 0) { + isOk = 1; + } + if (strcmp(name, "callinstance") == 0) { + isOk = 1; + } + if (strcmp(name, "getinstancevar") == 0) { + isOk = 1; + } + if (strcmp(name, "installcomponent") == 0) { + isOk = 1; + } + if (! isOk) { + if ((imPtr->flags & ITCL_TYPE_METHOD) != 0) { + Tcl_AppendResult(interp, "invalid command name \"", name, + "\"", NULL); + return TCL_ERROR; + } + inOptionHandling = imPtr->iclsPtr->infoPtr->inOptionHandling; + if (((imPtr->flags & ITCL_COMMON) == 0) && !inOptionHandling) { + /* a method cannot be called directly in ITCL_TYPE + * so look, if there is a corresponding proc in the + * namespace one level up (i.e. for example ::). If yes + * use that. + */ + Tcl_Namespace *nsPtr2; + Tcl_Command cmdPtr; + nsPtr2 = Itcl_GetUplevelNamespace(interp, 1); + cmdPtr = NULL; + if (nsPtr != nsPtr2) { + cmdPtr = Tcl_FindCommand(interp, name, nsPtr2, 0); + } + if (cmdPtr != NULL) { + *rPtr = cmdPtr; + return TCL_OK; + } + Tcl_AppendResult(interp, "invalid command name \"", name, + "\"", NULL); + return TCL_ERROR; + } + } + } + /* + * Looks like we found an accessible member function. + * + * TRICKY NOTE: Check to make sure that the command handle + * is still valid. If someone has deleted or renamed the + * command, it may not be. This is just the time to catch + * it--as it is being resolved again by the compiler. + */ + + /* + * The following #if is needed so itcl can be compiled with + * all versions of Tcl. The integer "deleted" was renamed to + * "flags" in tcl8.4a2. This #if is also found in itcl_ensemble.c . + * We're using a runtime check with itclCompatFlags to adjust for + * the behavior of this change, too. + * + */ +/* FIXME !!! */ +isCmdDeleted = 0; +/* isCmdDeleted = (!imPtr->accessCmd || imPtr->accessCmd->flags); */ + + if (isCmdDeleted) { + imPtr->accessCmd = NULL; + + if ((flags & TCL_LEAVE_ERR_MSG) != 0) { + Tcl_AppendResult(interp, + "can't access \"", name, "\": deleted or redefined\n", + "(use the \"body\" command to redefine methods/procs)", + (char*)NULL); + } + return TCL_ERROR; /* disallow access! */ + } + *rPtr = imPtr->accessCmd; + return TCL_OK; +} + +/* #define VAR_DEBUG */ + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassVarResolver() + * + * Used by the class namespaces to handle name resolution for runtime + * variable accesses. This procedure looks for references to both + * common variables and instance variables at runtime. It is used as + * a second line of defense, to handle references that could not be + * resolved as compiled locals. + * + * If a variable is found, this procedure returns TCL_OK along with + * the appropriate Tcl variable in the rPtr argument. If a particular + * variable is private, this procedure returns TCL_ERROR and access + * to the variable is denied. If a variable is not recognized, this + * procedure returns TCL_CONTINUE, and lookup continues via the normal + * Tcl name resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassVarResolver( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the variable being accessed */ + Tcl_Namespace *nsPtr, /* namespace performing the resolution */ + int flags, /* TCL_LEAVE_ERR_MSG => leave error messages + * in interp if anything goes wrong */ + Tcl_Var *rPtr) /* returns: resolved variable */ +{ + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclObject *contextIoPtr; + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + + contextIoPtr = NULL; + /* + * If this is a global variable, handle it in the usual + * Tcl manner. + */ + if (flags & TCL_GLOBAL_ONLY) { + return TCL_CONTINUE; + } + + /* + * See if this is a formal parameter in the current proc scope. + * If so, that variable has precedence. + */ + if ((strstr(name,"::") == NULL) && + Itcl_IsCallFrameArgument(interp, name)) { + return TCL_CONTINUE; + } + + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + iclsPtr = Tcl_GetHashValue(hPtr); + + /* + * See if the variable is a known data member and accessible. + */ + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (!vlookup->accessible) { + return TCL_CONTINUE; + } + + /* + * If this is a common data member, then its variable + * is easy to find. Return it directly. + */ + if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (hPtr != NULL) { + *rPtr = Tcl_GetHashValue(hPtr); + return TCL_OK; + } + } + + /* + * If this is an instance variable, then we have to + * find the object context, + */ + if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &contextIoPtr) + || (contextIoPtr == NULL)) { + return TCL_CONTINUE; + } + /* Check that the object hasn't already been destroyed. */ + hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)contextIoPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { + if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { + hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, + Tcl_GetString(vlookup->ivPtr->namePtr)); + + if (hPtr != NULL) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + } + } + } + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, + (char *)vlookup->ivPtr); + + if (hPtr == NULL) { + return TCL_CONTINUE; + } + if (strcmp(name, "this") == 0) { + Tcl_Var varPtr; + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); + if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) { + /* deletion of class is running */ + Tcl_DStringAppend(&buffer, + Tcl_GetCurrentNamespace(interp)->fullName, -1); + } else { + Tcl_DStringAppend(&buffer, + vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1); + } + Tcl_DStringAppend(&buffer, "::this", 6); + varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); + if (varPtr != NULL) { + *rPtr = varPtr; + return TCL_OK; + } + } + if (strcmp(name, "itcl_options") == 0) { + Tcl_Var varPtr; + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); + Tcl_DStringAppend(&buffer, "::itcl_options", -1); + varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + if (varPtr != NULL) { + *rPtr = varPtr; + return TCL_OK; + } + } + if (strcmp(name, "itcl_option_components") == 0) { + Tcl_Var varPtr; + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); + Tcl_DStringAppend(&buffer, "::itcl_option_components", -1); + varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + if (varPtr != NULL) { + *rPtr = varPtr; + return TCL_OK; + } + } + if (hPtr != NULL) { + *rPtr = Tcl_GetHashValue(hPtr); + return TCL_OK; + } + return TCL_CONTINUE; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCompiledVarResolver() + * + * Used by the class namespaces to handle name resolution for compile + * time variable accesses. This procedure looks for references to + * both common variables and instance variables at compile time. If + * the variables are found, they are characterized in a generic way + * by their ItclVarLookup record. At runtime, Tcl constructs the + * compiled local variables by calling ItclClassRuntimeVarResolver. + * + * If a variable is found, this procedure returns TCL_OK along with + * information about the variable in the rPtr argument. If a particular + * variable is private, this procedure returns TCL_ERROR and access + * to the variable is denied. If a variable is not recognized, this + * procedure returns TCL_CONTINUE, and lookup continues via the normal + * Tcl name resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCompiledVarResolver( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the variable being accessed */ + int length, /* number of characters in name */ + Tcl_Namespace *nsPtr, /* namespace performing the resolution */ + Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to + * resolve the variable at runtime */ +{ + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + char *buffer; + char storage[64]; + + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + iclsPtr = Tcl_GetHashValue(hPtr); + /* + * Copy the name to local storage so we can NULL terminate it. + * If the name is long, allocate extra space for it. + */ + if ((unsigned int)length < sizeof(storage)) { + buffer = storage; + } else { + buffer = (char*)ckalloc((unsigned)(length+1)); + } + memcpy((void*)buffer, (void*)name, (size_t)length); + buffer[length] = '\0'; + + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer); + + if (buffer != storage) { + ckfree(buffer); + } + + /* + * If the name is not found, or if it is inaccessible, + * continue on with the normal Tcl name resolution rules. + */ + if (hPtr == NULL) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (!vlookup->accessible) { + return TCL_CONTINUE; + } + + /* + * Return the ItclVarLookup record. At runtime, Tcl will + * call ItclClassRuntimeVarResolver with this record, to + * plug in the appropriate variable for the current object + * context. + */ + (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); + (*rPtr)->fetchProc = ItclClassRuntimeVarResolver; + (*rPtr)->deleteProc = NULL; + ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclClassRuntimeVarResolver() + * + * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc + * at runtime. Resolves data members identified earlier by + * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation + * for the data member. + * ------------------------------------------------------------------------ + */ +static Tcl_Var +ItclClassRuntimeVarResolver( + Tcl_Interp *interp, /* current interpreter */ + Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep + * for variable */ +{ + ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; + ItclClass *iclsPtr; + ItclObject *contextIoPtr; + Tcl_HashEntry *hPtr; + + /* + * If this is a common data member, then the associated + * variable is known directly. + */ + if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (hPtr != NULL) { + return Tcl_GetHashValue(hPtr); + } + } + + /* + * Otherwise, get the current object context and find the + * variable in its data table. + * + * TRICKY NOTE: Get the index for this variable using the + * virtual table for the MOST-SPECIFIC class. + */ + if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &contextIoPtr) + || (contextIoPtr == NULL)) { + return NULL; + } + + if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { + if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { + /* only for the this variable we need the one of the + * contextIoPtr class */ + hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, + Tcl_GetString(vlookup->ivPtr->namePtr)); + + if (hPtr != NULL) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + } + } + } + hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, + (char *)vlookup->ivPtr); + if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { + Tcl_Var varPtr; + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); + if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) { + Tcl_DStringAppend(&buffer, + Tcl_GetCurrentNamespace(interp)->fullName, -1); + } else { + Tcl_DStringAppend(&buffer, + vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1); + } + Tcl_DStringAppend(&buffer, "::this", 6); + varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), + NULL, 0); + if (varPtr != NULL) { + return varPtr; + } + } + if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), + "itcl_options") == 0) { + Tcl_Var varPtr; + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); + Tcl_DStringAppend(&buffer, "::itcl_options", -1); + varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), + NULL, 0); + Tcl_DStringFree(&buffer); + if (varPtr != NULL) { + return varPtr; + } + } + if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), + "itcl_option_components") == 0) { + Tcl_Var varPtr; + Tcl_DString buffer; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); + Tcl_DStringAppend(&buffer, "::itcl_option_components", -1); + varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), + NULL, 0); + Tcl_DStringFree(&buffer); + if (varPtr != NULL) { + return varPtr; + } + } + if (hPtr != NULL) { + return (Tcl_Var)Tcl_GetHashValue(hPtr); + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseVarResolver() + * + * Used by the "parser" namespace to resolve variable accesses to + * common variables. The runtime resolver procedure is consulted + * whenever a variable is accessed within the namespace. It can + * deny access to certain variables, or perform special lookups itself. + * + * This procedure allows access only to "common" class variables that + * have been declared within the class or inherited from another class. + * A "set" command can be used to initialized common data members within + * the body of the class definition itself: + * + * itcl::class Foo { + * common colors + * set colors(red) #ff0000 + * set colors(green) #00ff00 + * set colors(blue) #0000ff + * ... + * } + * + * itcl::class Bar { + * inherit Foo + * set colors(gray) #a0a0a0 + * set colors(white) #ffffff + * + * common numbers + * set numbers(0) zero + * set numbers(1) one + * } + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ParseVarResolver( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the variable being accessed */ + Tcl_Namespace *contextNs, /* namespace context */ + int flags, /* TCL_GLOBAL_ONLY => global variable + * TCL_NAMESPACE_ONLY => namespace variable */ + Tcl_Var* rPtr) /* returns: Tcl_Var for desired variable */ +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + + /* + * See if the requested variable is a recognized "common" member. + * If it is, make sure that access is allowed. + */ + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); + if (hPtr) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + + if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { + if (!vlookup->accessible) { + Tcl_AppendResult(interp, + "can't access \"", name, "\": ", + Itcl_ProtectionStr(vlookup->ivPtr->protection), + " variable", + (char*)NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (hPtr != NULL) { + *rPtr = Tcl_GetHashValue(hPtr); + return TCL_OK; + } + } + } + + /* + * If the variable is not recognized, return TCL_CONTINUE and + * let lookup continue via the normal name resolution rules. + * This is important for variables like "errorInfo" + * that might get set while the parser namespace is active. + */ + return TCL_CONTINUE; +} + + + +int +ItclSetParserResolver( + Tcl_Namespace *nsPtr) +{ + Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL, + Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve2.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve2.c new file mode 100644 index 0000000..b75a5a3 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve2.c @@ -0,0 +1,564 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * These procedures handle command and variable resolution + * + * ======================================================================== + * AUTHOR: Arnulf Wiedemann + * + * ======================================================================== + * Copyright (c) Arnulf Wiedemann + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include <tclInt.h> +#include "itclInt.h" +#include "itclVCInt.h" + +/* + * This structure is a subclass of Tcl_ResolvedVarInfo that contains the + * ItclVarLookup info needed at runtime. + */ +typedef struct ItclResolvedVarInfo { + Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ + ItclVarLookup *vlookup; /* Pointer to lookup info. */ +} ItclResolvedVarInfo; + +static Tcl_Var ItclClassRuntimeVarResolver2 ( + Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr); + +int +Itcl_CheckClassVariableProtection( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *varName, + ClientData clientData) +{ + ItclClassVarInfo *icviPtr; + + icviPtr = (ItclClassVarInfo *)clientData; + if (icviPtr->protection == ITCL_PRIVATE) { + if (icviPtr->declaringNsPtr != nsPtr) { + Tcl_AppendResult(interp, "can't read \"", varName, + "\": no such variable", NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +int +Itcl_CheckClassCommandProtection( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *commandName, + ClientData clientData) +{ + /* FIXME need code here !!! */ + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCmdResolver() + * + * Used by the class namespaces to handle name resolution for all + * commands. This procedure looks for references to class methods + * and procs, and returns TCL_OK along with the appropriate Tcl + * command in the rPtr argument. If a particular command is private, + * this procedure returns TCL_ERROR and access to the command is + * denied. If a command is not recognized, this procedure returns + * TCL_CONTINUE, and lookup continues via the normal Tcl name + * resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCmdResolver2( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the command being accessed */ + Tcl_Namespace *nsPtr, /* namespace performing the resolution */ + int flags, /* TCL_LEAVE_ERR_MSG => leave error messages + * in interp if anything goes wrong */ + Tcl_Command *rPtr) /* returns: resolved command */ +{ + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + ItclObject *contextIoPtr; + + Tcl_Command cmdPtr; + ItclResolvingInfo *iriPtr; + ObjectCmdTableInfo *octiPtr; + ObjectCmdInfo *ociPtr; + Tcl_HashEntry *hPtr; + + if ((name[0] == 't') && (strcmp(name, "this") == 0)) { + return TCL_CONTINUE; + } + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + iclsPtr = Tcl_GetHashValue(hPtr); + ItclCallContext *callContextPtr; + callContextPtr = Itcl_PeekStack(&infoPtr->contextStack); + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_FindHashEntry(&iriPtr->resolveCmds , nsPtr->fullName); + if (hPtr != NULL) { + Tcl_HashTable *tablePtr; + tablePtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(tablePtr, name); + if (hPtr != NULL) { + ItclClassCmdInfo *icciPtr = Tcl_GetHashValue(hPtr); + if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) { + contextIoPtr = callContextPtr->ioPtr; + hPtr = Tcl_FindHashEntry(&iriPtr->objectCmdsTables, + (char *)contextIoPtr); + if (hPtr != NULL) { + octiPtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(&octiPtr->cmdInfos, + (char *)icciPtr); + if (hPtr != NULL) { + int ret; + ociPtr = Tcl_GetHashValue(hPtr); + ret = (* iriPtr->cmdProtFcn)(interp, + Tcl_GetCurrentNamespace(interp), name, + (ClientData)icciPtr); + if (ret != TCL_OK) { + return ret; + } + cmdPtr = ociPtr->cmdPtr; + *rPtr = cmdPtr; + return TCL_OK; + } + } + } + } + } + return TCL_CONTINUE; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassVarResolver() + * + * Used by the class namespaces to handle name resolution for runtime + * variable accesses. This procedure looks for references to both + * common variables and instance variables at runtime. It is used as + * a second line of defense, to handle references that could not be + * resolved as compiled locals. + * + * If a variable is found, this procedure returns TCL_OK along with + * the appropriate Tcl variable in the rPtr argument. If a particular + * variable is private, this procedure returns TCL_ERROR and access + * to the variable is denied. If a variable is not recognized, this + * procedure returns TCL_CONTINUE, and lookup continues via the normal + * Tcl name resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassVarResolver2( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the variable being accessed */ + Tcl_Namespace *nsPtr, /* namespace performing the resolution */ + int flags, /* TCL_LEAVE_ERR_MSG => leave error messages + * in interp if anything goes wrong */ + Tcl_Var *rPtr) /* returns: resolved variable */ +{ + ItclObjectInfo *infoPtr; + ItclClass *iclsPtr; + ItclObject *contextIoPtr; + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + + Tcl_Var varPtr; + ItclResolvingInfo *iriPtr; + ObjectVarTableInfo *ovtiPtr; + ObjectVarInfo *oviPtr; + + Tcl_Namespace *upNsPtr; + upNsPtr = Itcl_GetUplevelNamespace(interp, 1); + + /* + * If this is a global variable, handle it in the usual + * Tcl manner. + */ + if (flags & TCL_GLOBAL_ONLY) { + return TCL_CONTINUE; + } + + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + iclsPtr = Tcl_GetHashValue(hPtr); + + /* + * See if this is a formal parameter in the current proc scope. + * If so, that variable has precedence. Look it up and return + * it here. This duplicates some of the functionality of + * TclLookupVar, but we return it here (instead of returning + * TCL_CONTINUE) to avoid looking it up again later. + */ + ItclCallContext *callContextPtr; + callContextPtr = Itcl_PeekStack(&infoPtr->contextStack); + if ((strstr(name,"::") == NULL) && + Itcl_IsCallFrameArgument(interp, name)) { + return TCL_CONTINUE; + } + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars , nsPtr->fullName); + if (hPtr != NULL) { + Tcl_HashTable *tablePtr; + tablePtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(tablePtr , name); + if (hPtr != NULL) { + int ret; + ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr); + ret = (* iriPtr->varProtFcn)(interp, + Tcl_GetCurrentNamespace(interp), name, + (ClientData)icviPtr); + if (ret != TCL_OK) { + return ret; + } + /* + * If this is an instance variable, then we have to + * find the object context, + */ + + if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) { + contextIoPtr = callContextPtr->ioPtr; + hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables, + (char *)contextIoPtr); + if (hPtr != NULL) { + ovtiPtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos, + (char *)icviPtr); + if (hPtr != NULL) { + oviPtr = Tcl_GetHashValue(hPtr); + varPtr = oviPtr->varPtr; + *rPtr = varPtr; + return TCL_OK; + } + } + } + } + } + /* + * See if the variable is a known data member and accessible. + */ + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (!vlookup->accessible) { + return TCL_CONTINUE; + } + + /* + * If this is a common data member, then its variable + * is easy to find. Return it directly. + */ + if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (hPtr != NULL) { + *rPtr = Tcl_GetHashValue(hPtr); + return TCL_OK; + } + } + + return TCL_CONTINUE; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCompiledVarResolver() + * + * Used by the class namespaces to handle name resolution for compile + * time variable accesses. This procedure looks for references to + * both common variables and instance variables at compile time. If + * the variables are found, they are characterized in a generic way + * by their ItclVarLookup record. At runtime, Tcl constructs the + * compiled local variables by calling ItclClassRuntimeVarResolver. + * + * If a variable is found, this procedure returns TCL_OK along with + * information about the variable in the rPtr argument. If a particular + * variable is private, this procedure returns TCL_ERROR and access + * to the variable is denied. If a variable is not recognized, this + * procedure returns TCL_CONTINUE, and lookup continues via the normal + * Tcl name resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCompiledVarResolver2( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the variable being accessed */ + int length, /* number of characters in name */ + Tcl_Namespace *nsPtr, /* namespace performing the resolution */ + Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to + * resolve the variable at runtime */ +{ + ItclClass *iclsPtr; + ItclObjectInfo *infoPtr; + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + char *buffer; + char storage[64]; + + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, + ITCL_INTERP_DATA, NULL); + hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); + if (hPtr == NULL) { + return TCL_CONTINUE; + } + iclsPtr = Tcl_GetHashValue(hPtr); + /* + * Copy the name to local storage so we can NULL terminate it. + * If the name is long, allocate extra space for it. + */ + if (length < sizeof(storage)) { + buffer = storage; + } else { + buffer = (char*)ckalloc((unsigned)(length+1)); + } + memcpy((void*)buffer, (void*)name, (size_t)length); + buffer[length] = '\0'; + + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer); + + if (buffer != storage) { + ckfree(buffer); + } + + /* + * If the name is not found, or if it is inaccessible, + * continue on with the normal Tcl name resolution rules. + */ + if (hPtr == NULL) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (!vlookup->accessible) { + return TCL_CONTINUE; + } + + /* + * Return the ItclVarLookup record. At runtime, Tcl will + * call ItclClassRuntimeVarResolver with this record, to + * plug in the appropriate variable for the current object + * context. + */ + (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); + (*rPtr)->fetchProc = ItclClassRuntimeVarResolver2; + (*rPtr)->deleteProc = NULL; + ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclClassRuntimeVarResolver() + * + * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc + * at runtime. Resolves data members identified earlier by + * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation + * for the data member. + * ------------------------------------------------------------------------ + */ +static Tcl_Var +ItclClassRuntimeVarResolver2( + Tcl_Interp *interp, /* current interpreter */ + Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep + * for variable */ +{ + ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; + + ItclClass *iclsPtr; + ItclObject *contextIoPtr; + Tcl_HashEntry *hPtr; + + Tcl_Var varPtr; + ItclResolvingInfo *iriPtr; + ObjectVarTableInfo *ovtiPtr; + ObjectVarInfo *oviPtr; + + /* + * If this is a common data member, then the associated + * variable is known directly. + */ + if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (hPtr != NULL) { + return Tcl_GetHashValue(hPtr); + } + } + iclsPtr = vlookup->ivPtr->iclsPtr; + + /* + * Otherwise, get the current object context and find the + * variable in its data table. + * + * TRICKY NOTE: Get the index for this variable using the + * virtual table for the MOST-SPECIFIC class. + */ + + ItclCallContext *callContextPtr; + + callContextPtr = Itcl_PeekStack(&iclsPtr->infoPtr->contextStack); + if (callContextPtr == NULL) { + return NULL; + } + if (callContextPtr->ioPtr == NULL) { + return NULL; + } + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars, + Tcl_GetCurrentNamespace(interp)->fullName); + if (hPtr != NULL) { + Tcl_HashTable *tablePtr; + tablePtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(tablePtr, + Tcl_GetString(vlookup->ivPtr->namePtr)); + if (hPtr != NULL) { + ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr); + int ret; + ret = (* iriPtr->varProtFcn)(interp, + Tcl_GetCurrentNamespace(interp), + Tcl_GetString(vlookup->ivPtr->namePtr), + (ClientData)icviPtr); + if (ret != TCL_OK) { + return NULL; + } + /* + * If this is an instance variable, then we have to + * find the object context, + */ + + contextIoPtr = callContextPtr->ioPtr; + hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables, (char *)contextIoPtr); + if (hPtr != NULL) { + ovtiPtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos, (char *)icviPtr); + if (hPtr != NULL) { + oviPtr = Tcl_GetHashValue(hPtr); + varPtr = oviPtr->varPtr; + return varPtr; + } + } + } + } + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseVarResolver() + * + * Used by the "parser" namespace to resolve variable accesses to + * common variables. The runtime resolver procedure is consulted + * whenever a variable is accessed within the namespace. It can + * deny access to certain variables, or perform special lookups itself. + * + * This procedure allows access only to "common" class variables that + * have been declared within the class or inherited from another class. + * A "set" command can be used to initialized common data members within + * the body of the class definition itself: + * + * itcl::class Foo { + * common colors + * set colors(red) #ff0000 + * set colors(green) #00ff00 + * set colors(blue) #0000ff + * ... + * } + * + * itcl::class Bar { + * inherit Foo + * set colors(gray) #a0a0a0 + * set colors(white) #ffffff + * + * common numbers + * set numbers(0) zero + * set numbers(1) one + * } + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ParseVarResolver2( + Tcl_Interp *interp, /* current interpreter */ + const char* name, /* name of the variable being accessed */ + Tcl_Namespace *contextNs, /* namespace context */ + int flags, /* TCL_GLOBAL_ONLY => global variable + * TCL_NAMESPACE_ONLY => namespace variable */ + Tcl_Var* rPtr) /* returns: Tcl_Var for desired variable */ +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData; + ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); + + Tcl_HashEntry *hPtr; + ItclVarLookup *vlookup; + + /* + * See if the requested variable is a recognized "common" member. + * If it is, make sure that access is allowed. + */ + hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); + if (hPtr) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + + if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { + if (!vlookup->accessible) { + Tcl_AppendResult(interp, + "can't access \"", name, "\": ", + Itcl_ProtectionStr(vlookup->ivPtr->protection), + " variable", + (char*)NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (hPtr != NULL) { + *rPtr = Tcl_GetHashValue(hPtr); + return TCL_OK; + } + } + } + + /* + * If the variable is not recognized, return TCL_CONTINUE and + * let lookup continue via the normal name resolution rules. + * This is important for variables like "errorInfo" + * that might get set while the parser namespace is active. + */ + return TCL_CONTINUE; +} + + + +int +ItclSetParserResolver2( + Tcl_Namespace *nsPtr) +{ + Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL, + Itcl_ParseVarResolver2, (Tcl_ResolveCompiledVarProc*)NULL); + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclStubInit.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclStubInit.c new file mode 100644 index 0000000..63d6437 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclStubInit.c @@ -0,0 +1,240 @@ +/* + * This file is (mostly) automatically generated from itcl.decls. + * It is compiled and linked in with the itcl package proper. + */ + +#include "itclInt.h" + +MODULE_SCOPE const ItclStubs itclStubs; +/* !BEGIN!: Do not edit below this line. */ + +static const ItclIntStubs itclIntStubs = { + TCL_STUB_MAGIC, + ITCLINT_STUBS_EPOCH, + ITCLINT_STUBS_REVISION, + 0, + Itcl_IsClassNamespace, /* 0 */ + Itcl_IsClass, /* 1 */ + Itcl_FindClass, /* 2 */ + Itcl_FindObject, /* 3 */ + Itcl_IsObject, /* 4 */ + Itcl_ObjectIsa, /* 5 */ + Itcl_Protection, /* 6 */ + Itcl_ProtectionStr, /* 7 */ + Itcl_CanAccess, /* 8 */ + Itcl_CanAccessFunc, /* 9 */ + 0, /* 10 */ + Itcl_ParseNamespPath, /* 11 */ + Itcl_DecodeScopedCommand, /* 12 */ + Itcl_EvalArgs, /* 13 */ + Itcl_CreateArgs, /* 14 */ + 0, /* 15 */ + 0, /* 16 */ + Itcl_GetContext, /* 17 */ + Itcl_InitHierIter, /* 18 */ + Itcl_DeleteHierIter, /* 19 */ + Itcl_AdvanceHierIter, /* 20 */ + Itcl_FindClassesCmd, /* 21 */ + Itcl_FindObjectsCmd, /* 22 */ + 0, /* 23 */ + Itcl_DelClassCmd, /* 24 */ + Itcl_DelObjectCmd, /* 25 */ + Itcl_ScopeCmd, /* 26 */ + Itcl_CodeCmd, /* 27 */ + Itcl_StubCreateCmd, /* 28 */ + Itcl_StubExistsCmd, /* 29 */ + Itcl_IsStub, /* 30 */ + Itcl_CreateClass, /* 31 */ + Itcl_DeleteClass, /* 32 */ + Itcl_FindClassNamespace, /* 33 */ + Itcl_HandleClass, /* 34 */ + 0, /* 35 */ + 0, /* 36 */ + 0, /* 37 */ + Itcl_BuildVirtualTables, /* 38 */ + Itcl_CreateVariable, /* 39 */ + Itcl_DeleteVariable, /* 40 */ + Itcl_GetCommonVar, /* 41 */ + 0, /* 42 */ + 0, /* 43 */ + Itcl_CreateObject, /* 44 */ + Itcl_DeleteObject, /* 45 */ + Itcl_DestructObject, /* 46 */ + 0, /* 47 */ + Itcl_GetInstanceVar, /* 48 */ + 0, /* 49 */ + Itcl_BodyCmd, /* 50 */ + Itcl_ConfigBodyCmd, /* 51 */ + Itcl_CreateMethod, /* 52 */ + Itcl_CreateProc, /* 53 */ + Itcl_CreateMemberFunc, /* 54 */ + Itcl_ChangeMemberFunc, /* 55 */ + Itcl_DeleteMemberFunc, /* 56 */ + Itcl_CreateMemberCode, /* 57 */ + Itcl_DeleteMemberCode, /* 58 */ + Itcl_GetMemberCode, /* 59 */ + 0, /* 60 */ + Itcl_EvalMemberCode, /* 61 */ + 0, /* 62 */ + 0, /* 63 */ + 0, /* 64 */ + 0, /* 65 */ + 0, /* 66 */ + Itcl_GetMemberFuncUsage, /* 67 */ + Itcl_ExecMethod, /* 68 */ + Itcl_ExecProc, /* 69 */ + 0, /* 70 */ + Itcl_ConstructBase, /* 71 */ + Itcl_InvokeMethodIfExists, /* 72 */ + 0, /* 73 */ + Itcl_ReportFuncErrors, /* 74 */ + Itcl_ParseInit, /* 75 */ + Itcl_ClassCmd, /* 76 */ + Itcl_ClassInheritCmd, /* 77 */ + Itcl_ClassProtectionCmd, /* 78 */ + Itcl_ClassConstructorCmd, /* 79 */ + Itcl_ClassDestructorCmd, /* 80 */ + Itcl_ClassMethodCmd, /* 81 */ + Itcl_ClassProcCmd, /* 82 */ + Itcl_ClassVariableCmd, /* 83 */ + Itcl_ClassCommonCmd, /* 84 */ + Itcl_ParseVarResolver, /* 85 */ + Itcl_BiInit, /* 86 */ + Itcl_InstallBiMethods, /* 87 */ + Itcl_BiIsaCmd, /* 88 */ + Itcl_BiConfigureCmd, /* 89 */ + Itcl_BiCgetCmd, /* 90 */ + Itcl_BiChainCmd, /* 91 */ + Itcl_BiInfoClassCmd, /* 92 */ + Itcl_BiInfoInheritCmd, /* 93 */ + Itcl_BiInfoHeritageCmd, /* 94 */ + Itcl_BiInfoFunctionCmd, /* 95 */ + Itcl_BiInfoVariableCmd, /* 96 */ + Itcl_BiInfoBodyCmd, /* 97 */ + Itcl_BiInfoArgsCmd, /* 98 */ + 0, /* 99 */ + Itcl_EnsembleInit, /* 100 */ + Itcl_CreateEnsemble, /* 101 */ + Itcl_AddEnsemblePart, /* 102 */ + Itcl_GetEnsemblePart, /* 103 */ + Itcl_IsEnsemble, /* 104 */ + Itcl_GetEnsembleUsage, /* 105 */ + Itcl_GetEnsembleUsageForObj, /* 106 */ + Itcl_EnsembleCmd, /* 107 */ + Itcl_EnsPartCmd, /* 108 */ + Itcl_EnsembleErrorCmd, /* 109 */ + 0, /* 110 */ + 0, /* 111 */ + 0, /* 112 */ + 0, /* 113 */ + 0, /* 114 */ + Itcl_Assert, /* 115 */ + Itcl_IsObjectCmd, /* 116 */ + Itcl_IsClassCmd, /* 117 */ + 0, /* 118 */ + 0, /* 119 */ + 0, /* 120 */ + 0, /* 121 */ + 0, /* 122 */ + 0, /* 123 */ + 0, /* 124 */ + 0, /* 125 */ + 0, /* 126 */ + 0, /* 127 */ + 0, /* 128 */ + 0, /* 129 */ + 0, /* 130 */ + 0, /* 131 */ + 0, /* 132 */ + 0, /* 133 */ + 0, /* 134 */ + 0, /* 135 */ + 0, /* 136 */ + 0, /* 137 */ + 0, /* 138 */ + 0, /* 139 */ + Itcl_FilterAddCmd, /* 140 */ + Itcl_FilterDeleteCmd, /* 141 */ + Itcl_ForwardAddCmd, /* 142 */ + Itcl_ForwardDeleteCmd, /* 143 */ + Itcl_MixinAddCmd, /* 144 */ + Itcl_MixinDeleteCmd, /* 145 */ + 0, /* 146 */ + 0, /* 147 */ + 0, /* 148 */ + 0, /* 149 */ + 0, /* 150 */ + Itcl_BiInfoUnknownCmd, /* 151 */ + Itcl_BiInfoVarsCmd, /* 152 */ + Itcl_CanAccess2, /* 153 */ + 0, /* 154 */ + 0, /* 155 */ + 0, /* 156 */ + 0, /* 157 */ + 0, /* 158 */ + 0, /* 159 */ + Itcl_SetCallFrameResolver, /* 160 */ + ItclEnsembleSubCmd, /* 161 */ + Itcl_GetUplevelNamespace, /* 162 */ + Itcl_GetCallFrameClientData, /* 163 */ + 0, /* 164 */ + Itcl_SetCallFrameNamespace, /* 165 */ + Itcl_GetCallFrameObjc, /* 166 */ + Itcl_GetCallFrameObjv, /* 167 */ + Itcl_NWidgetCmd, /* 168 */ + Itcl_AddOptionCmd, /* 169 */ + Itcl_AddComponentCmd, /* 170 */ + Itcl_BiInfoOptionCmd, /* 171 */ + Itcl_BiInfoComponentCmd, /* 172 */ + Itcl_RenameCommand, /* 173 */ + Itcl_PushCallFrame, /* 174 */ + Itcl_PopCallFrame, /* 175 */ + Itcl_GetUplevelCallFrame, /* 176 */ + Itcl_ActivateCallFrame, /* 177 */ + ItclSetInstanceVar, /* 178 */ + ItclCapitalize, /* 179 */ + ItclClassBaseCmd, /* 180 */ + ItclCreateComponent, /* 181 */ + Itcl_SetContext, /* 182 */ + Itcl_UnsetContext, /* 183 */ + ItclGetInstanceVar, /* 184 */ +}; + +static const ItclStubHooks itclStubHooks = { + &itclIntStubs +}; + +const ItclStubs itclStubs = { + TCL_STUB_MAGIC, + ITCL_STUBS_EPOCH, + ITCL_STUBS_REVISION, + &itclStubHooks, + 0, /* 0 */ + 0, /* 1 */ + Itcl_RegisterC, /* 2 */ + Itcl_RegisterObjC, /* 3 */ + Itcl_FindC, /* 4 */ + Itcl_InitStack, /* 5 */ + Itcl_DeleteStack, /* 6 */ + Itcl_PushStack, /* 7 */ + Itcl_PopStack, /* 8 */ + Itcl_PeekStack, /* 9 */ + Itcl_GetStackValue, /* 10 */ + Itcl_InitList, /* 11 */ + Itcl_DeleteList, /* 12 */ + Itcl_CreateListElem, /* 13 */ + Itcl_DeleteListElem, /* 14 */ + Itcl_InsertList, /* 15 */ + Itcl_InsertListElem, /* 16 */ + Itcl_AppendList, /* 17 */ + Itcl_AppendListElem, /* 18 */ + Itcl_SetListValue, /* 19 */ + Itcl_EventuallyFree, /* 20 */ + Itcl_PreserveData, /* 21 */ + Itcl_ReleaseData, /* 22 */ + Itcl_SaveInterpState, /* 23 */ + Itcl_RestoreInterpState, /* 24 */ + Itcl_DiscardInterpState, /* 25 */ +}; + +/* !END!: Do not edit above this line. */ diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclStubLib.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclStubLib.c new file mode 100644 index 0000000..50683b7 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclStubLib.c @@ -0,0 +1,69 @@ +/* + * SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 + */ + +#define USE_TCL_STUBS 1 +#define USE_ITCL_STUBS 1 +#include "itclInt.h" + +#undef Itcl_InitStubs + +MODULE_SCOPE const ItclStubs *itclStubsPtr; +MODULE_SCOPE const ItclIntStubs *itclIntStubsPtr; + +const ItclStubs *itclStubsPtr = NULL; +const ItclIntStubs *itclIntStubsPtr = NULL; + +/* + *---------------------------------------------------------------------- + * + * Itcl_InitStubs -- + * Load the tclOO package, initialize stub table pointer. Do not call + * this function directly, use Itcl_InitStubs() macro instead. + * + * Results: + * The actual version of the package that satisfies the request, or + * NULL to indicate that an error occurred. + * + * Side effects: + * Sets the stub table pointer. + * + */ + +const char * +Itcl_InitStubs( + Tcl_Interp *interp, + const char *version, + int exact) +{ + const char *packageName = "itcl"; + const char *errMsg = NULL; + ClientData clientData = NULL; + const ItclStubs *stubsPtr; + const ItclIntStubs *intStubsPtr; + const char *actualVersion; + + actualVersion = + Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData); + stubsPtr = clientData; + if ((actualVersion == NULL) || (clientData == NULL)) { + return NULL; + } + intStubsPtr = stubsPtr->hooks ? + stubsPtr->hooks->itclIntStubs : NULL; + + if (!stubsPtr || !intStubsPtr) { + errMsg = "missing stub table pointer"; + goto error; + } + itclStubsPtr = stubsPtr; + itclIntStubsPtr = intStubsPtr; + return actualVersion; + + error: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package", + " (requested version '", version, "', loaded version '", + actualVersion, "'): ", errMsg, NULL); + return NULL; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclStubs.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclStubs.c new file mode 100644 index 0000000..bc7189c --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclStubs.c @@ -0,0 +1,231 @@ +/* + * itclStubs.c -- + * + * This file contains the C-implemeted part of Itcl object-system + * Itcl + * + * Copyright (c) 2006 by Arnulf P. Wiedemann + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "itclInt.h" + +static void ItclDeleteStub(ClientData cdata); +static int ItclHandleStubCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsStub() + * + * Checks the given Tcl command to see if it represents an autoloading + * stub created by the "stub create" command. Returns non-zero if + * the command is indeed a stub. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsStub( + Tcl_Command cmdPtr) /* command being tested */ +{ + Tcl_CmdInfo cmdInfo; + + /* + * This may be an imported command, but don't try to get the + * original. Just check to see if this particular command + * is a stub. If we really want the original command, we'll + * find it at a higher level. + */ + if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) == 1) { + if (cmdInfo.deleteProc == ItclDeleteStub) { + return 1; + } + } + return 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_StubCreateCmd() + * + * Invoked by Tcl whenever the user issues a "stub create" command to + * create an autoloading stub for imported commands. Handles the + * following syntax: + * + * stub create <name> + * + * Creates a command called <name>. Executing this command will cause + * the real command <name> to be autoloaded. + * ------------------------------------------------------------------------ + */ +int +Itcl_StubCreateCmd( + ClientData clientData, /* not used */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Command cmdPtr; + char *cmdName; + Tcl_CmdInfo cmdInfo; + + ItclShowArgs(1, "Itcl_StubCreateCmd", objc, objv); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + cmdName = Tcl_GetString(objv[1]); + + /* + * Create a stub command with the characteristic ItclDeleteStub + * procedure. That way, we can recognize this command later + * on as a stub. Save the cmd token as client data, so we can + * get the full name of this command later on. + */ + cmdPtr = Tcl_CreateObjCommand(interp, cmdName, + ItclHandleStubCmd, (ClientData)NULL, + (Tcl_CmdDeleteProc*)ItclDeleteStub); + + Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo); + cmdInfo.objClientData = cmdPtr; + Tcl_SetCommandInfoFromToken(cmdPtr, &cmdInfo); + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_StubExistsCmd() + * + * Invoked by Tcl whenever the user issues a "stub exists" command to + * see if an existing command is an autoloading stub. Handles the + * following syntax: + * + * stub exists <name> + * + * Looks for a command called <name> and checks to see if it is an + * autoloading stub. Returns a boolean result. + * ------------------------------------------------------------------------ + */ +int +Itcl_StubExistsCmd( + ClientData clientData, /* not used */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Command cmdPtr; + char *cmdName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + cmdName = Tcl_GetString(objv[1]); + + cmdPtr = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace*)NULL, 0); + + if ((cmdPtr != NULL) && Itcl_IsStub(cmdPtr)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclHandleStubCmd() + * + * Invoked by Tcl to handle commands created by "stub create". + * Calls "auto_load" with the full name of the current command to + * trigger autoloading of the real implementation. Then, calls the + * command to handle its function. If successful, this command + * returns TCL_OK along with the result from the real implementation + * of this command. Otherwise, it returns TCL_ERROR, along with an + * error message in the interpreter. + * ------------------------------------------------------------------------ + */ +static int +ItclHandleStubCmd( + ClientData clientData, /* command token for this stub */ + Tcl_Interp *interp, /* current interpreter */ + int objc, /* number of arguments */ + Tcl_Obj *const objv[]) /* argument objects */ +{ + Tcl_Command cmdPtr; + Tcl_Obj **cmdlinev; + Tcl_Obj *objAutoLoad[2]; + Tcl_Obj *objPtr; + Tcl_Obj *cmdNamePtr; + Tcl_Obj *cmdlinePtr; + char *cmdName; + int result; + int loaded; + int cmdlinec; + + ItclShowArgs(1, "ItclHandleStubCmd", objc, objv); + cmdPtr = (Tcl_Command) clientData; + cmdNamePtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_IncrRefCount(cmdNamePtr); + Tcl_GetCommandFullName(interp, cmdPtr, cmdNamePtr); + cmdName = Tcl_GetString(cmdNamePtr); + + /* + * Try to autoload the real command for this stub. + */ + objAutoLoad[0] = Tcl_NewStringObj("::auto_load", -1); + objAutoLoad[1] = cmdNamePtr; + result = Tcl_EvalObjv(interp, 2, objAutoLoad, 0); + if (result != TCL_OK) { + Tcl_DecrRefCount(cmdNamePtr); + return TCL_ERROR; + } + + objPtr = Tcl_GetObjResult(interp); + result = Tcl_GetIntFromObj(interp, objPtr, &loaded); + if ((result != TCL_OK) || !loaded) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't autoload \"", cmdName, "\"", (char*)NULL); + Tcl_DecrRefCount(cmdNamePtr); + return TCL_ERROR; + } + + /* + * At this point, the real implementation has been loaded. + * Invoke the command again with the arguments passed in. + */ + cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc - 1, objv + 1); + (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &cmdlinec, &cmdlinev); + + Tcl_DecrRefCount(cmdNamePtr); + Tcl_ResetResult(interp); + ItclShowArgs(1, "ItclHandleStubCmd", cmdlinec - 1, cmdlinev + 1); + result = Tcl_EvalObjv(interp, cmdlinec - 1, cmdlinev + 1, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(cmdlinePtr); + Tcl_DecrRefCount(objAutoLoad[0]); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDeleteStub() + * + * Invoked by Tcl whenever a stub command is deleted. This procedure + * does nothing, but its presence identifies a command as a stub. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static void +ItclDeleteStub( + ClientData cdata) /* not used */ +{ + /* do nothing */ +} + diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.c new file mode 100644 index 0000000..7d3cdf4 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.c @@ -0,0 +1,143 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * This file contains procedures that use the internal Tcl core stubs + * entries. + * + * ======================================================================== + * AUTHOR: Arnulf Wiedemann + * + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include <tclInt.h> +#include "itclInt.h" + +Tcl_Command +_Tcl_GetOriginalCommand( + Tcl_Command command) +{ + return TclGetOriginalCommand(command); +} + +int +_Tcl_CreateProc( + Tcl_Interp *interp, /* Interpreter containing proc. */ + Tcl_Namespace *nsPtr, /* Namespace containing this proc. */ + const char *procName, /* Unqualified name of this proc. */ + Tcl_Obj *argsPtr, /* Description of arguments. */ + Tcl_Obj *bodyPtr, /* Command body. */ + Tcl_Proc *procPtrPtr) /* Returns: pointer to proc data. */ +{ + int code = TclCreateProc(interp, (Namespace *)nsPtr, procName, argsPtr, + bodyPtr, (Proc **)procPtrPtr); + (*(Proc **)procPtrPtr)->cmdPtr = NULL; + return code; +} + +void * +_Tcl_GetObjInterpProc( + void) +{ + return (void *)TclGetObjInterpProc(); +} + +void +_Tcl_ProcDeleteProc( + ClientData clientData) +{ + TclProcDeleteProc(clientData); +} + +int +Itcl_RenameCommand( + Tcl_Interp *interp, + const char *oldName, + const char *newName) +{ + return TclRenameCommand(interp, oldName, newName); +} + +int +Itcl_PushCallFrame( + Tcl_Interp * interp, + Tcl_CallFrame * framePtr, + Tcl_Namespace * nsPtr, + int isProcCallFrame) +{ + return Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame); +} + +void +Itcl_PopCallFrame( + Tcl_Interp * interp) +{ + Tcl_PopCallFrame(interp); +} + +void +Itcl_GetVariableFullName( + Tcl_Interp * interp, + Tcl_Var variable, + Tcl_Obj * objPtr) +{ + Tcl_GetVariableFullName(interp, variable, objPtr); +} + +Tcl_Var +Itcl_FindNamespaceVar( + Tcl_Interp * interp, + const char * name, + Tcl_Namespace * contextNsPtr, + int flags) +{ + return Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags); +} + +void +Itcl_SetNamespaceResolvers ( + Tcl_Namespace * namespacePtr, + Tcl_ResolveCmdProc * cmdProc, + Tcl_ResolveVarProc * varProc, + Tcl_ResolveCompiledVarProc * compiledVarProc) +{ + Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc); +} + +Tcl_HashTable * +Itcl_GetNamespaceCommandTable( + Tcl_Namespace *nsPtr) +{ + return TclGetNamespaceCommandTable(nsPtr); +} + +Tcl_HashTable * +Itcl_GetNamespaceChildTable( + Tcl_Namespace *nsPtr) +{ + return TclGetNamespaceChildTable(nsPtr); +} + +int +Itcl_InitRewriteEnsemble( + Tcl_Interp *interp, + int numRemoved, + int numInserted, + int objc, + Tcl_Obj *const *objv) +{ + return TclInitRewriteEnsemble(interp, numRemoved, numInserted, objv); +} + +void +Itcl_ResetRewriteEnsemble( + Tcl_Interp *interp, + int isRootEnsemble) +{ + TclResetRewriteEnsemble(interp, isRootEnsemble); +} + + diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.h new file mode 100644 index 0000000..b22ee06 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.h @@ -0,0 +1,38 @@ +/* these functions are Tcl internal stubs so make an Itcl_* wrapper */ +MODULE_SCOPE void Itcl_GetVariableFullName (Tcl_Interp * interp, + Tcl_Var variable, Tcl_Obj * objPtr); +MODULE_SCOPE Tcl_Var Itcl_FindNamespaceVar (Tcl_Interp * interp, + const char * name, Tcl_Namespace * contextNsPtr, int flags); +MODULE_SCOPE void Itcl_SetNamespaceResolvers (Tcl_Namespace * namespacePtr, + Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, + Tcl_ResolveCompiledVarProc * compiledVarProc); + +#ifndef _TCL_PROC_DEFINED +typedef struct Tcl_Proc_ *Tcl_Proc; +#define _TCL_PROC_DEFINED 1 +#endif +#ifndef _TCL_RESOLVE_DEFINED +struct Tcl_Resolve; +#endif + +#define Tcl_GetOriginalCommand _Tcl_GetOriginalCommand +#define Tcl_CreateProc _Tcl_CreateProc +#define Tcl_ProcDeleteProc _Tcl_ProcDeleteProc +#define Tcl_GetObjInterpProc _Tcl_GetObjInterpProc + +MODULE_SCOPE Tcl_Command _Tcl_GetOriginalCommand(Tcl_Command command); +MODULE_SCOPE int _Tcl_CreateProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, + Tcl_Proc *procPtrPtr); +MODULE_SCOPE void _Tcl_ProcDeleteProc(ClientData clientData); +MODULE_SCOPE void *_Tcl_GetObjInterpProc(void); +MODULE_SCOPE int Tcl_RenameCommand(Tcl_Interp *interp, const char *oldName, + const char *newName); +MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr); +MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr); +MODULE_SCOPE int Itcl_InitRewriteEnsemble(Tcl_Interp *interp, int numRemoved, + int numInserted, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE void Itcl_ResetRewriteEnsemble(Tcl_Interp *interp, + int isRootEnsemble); + + diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclTestRegisterC.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclTestRegisterC.c new file mode 100644 index 0000000..7489b89 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclTestRegisterC.c @@ -0,0 +1,128 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This part adds a mechanism for integrating C procedures into + * [incr Tcl] classes as methods and procs. Each C procedure must + * either be declared via Itcl_RegisterC() or dynamically loaded. + * + * ======================================================================== + * AUTHOR: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) Arnulf Wiedemann + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#ifdef ITCL_DEBUG_C_INTERFACE + +#include <stdio.h> +#include "itclInt.h" + +Tcl_CmdProc cArgFunc; +Tcl_ObjCmdProc cObjFunc; + +int +cArgFunc( + ClientData clientData, + Tcl_Interp *interp, + int argc, + const char **argv) +{ + int result; + ItclObjectInfo * infoPtr = NULL; + ItclClass *iclsPtr = NULL; + ItclClass * classPtr; + ItclObject * rioPtr = (ItclObject *)1; + Tcl_Obj * objv[4]; + FOREACH_HASH_DECLS; + +//fprintf(stderr, "argc: %d\n", argc); + if (argc != 4) { + Tcl_AppendResult(interp, "wrong #args: should be ::itcl::parser::handleClass className className objectName", NULL); + return TCL_ERROR; + } + objv[0] = Tcl_NewStringObj(argv[0], -1); + objv[1] = Tcl_NewStringObj(argv[1], -1); /* class name */ + objv[2] = Tcl_NewStringObj(argv[2], -1); /* full class name */ + objv[3] = Tcl_NewStringObj(argv[3], -1); /* object name */ + Tcl_IncrRefCount(objv[0]); + Tcl_IncrRefCount(objv[1]); + Tcl_IncrRefCount(objv[2]); + Tcl_IncrRefCount(objv[3]); + infoPtr = (ClientData)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { + if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || + strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { + iclsPtr = classPtr; + break; + } + } + if (iclsPtr == NULL) { + Tcl_AppendResult(interp, "no such class: ", Tcl_GetString(objv[2]), NULL); + return TCL_ERROR; + } + + /* try to create an object for a class as a test for calling a C function from + * an Itcl class. See file CreateItclObjectWithC_example.tcl in library directory + */ + result = Itcl_CreateObject(interp, Tcl_GetString(objv[3]), iclsPtr, 4, objv, &rioPtr); + return result; +} + +int +cObjFunc( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Namespace *nsPtr; + ItclObjectInfo * infoPtr = NULL; + ItclClass *iclsPtr = NULL; + ItclClass * classPtr; + FOREACH_HASH_DECLS; + int i; + + ItclShowArgs(0, "cObjFunc called", objc, objv); +fprintf(stderr, "objv: %d %p\n", objc, objv); +for(i = 0; i<objc;i++) { + fprintf(stderr, "arg:%d:%s:\n", i, Tcl_GetString(objv[i])); +} + nsPtr = Tcl_GetCurrentNamespace(interp); +fprintf(stderr, "IP:%p %p %p !%s!\n",interp, clientData, nsPtr, nsPtr->fullName); + infoPtr = (ClientData)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { + if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || + strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { + iclsPtr = classPtr; + break; + } + } +fprintf(stderr, "IP2:%p %p %p\n",interp, clientData, iclsPtr); + return TCL_OK; +} + + +void +RegisterDebugCFunctions(Tcl_Interp *interp) +{ + int result; + + /* args: interp, name, c-function, clientdata, deleteproc */ + result = Itcl_RegisterC(interp, "cArgFunc", cArgFunc, NULL, NULL); + result = Itcl_RegisterObjC(interp, "cObjFunc", cObjFunc, NULL, NULL); + if (result != 0) { + } +} +#endif diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclUtil.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclUtil.c new file mode 100644 index 0000000..057f01b --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclUtil.c @@ -0,0 +1,1202 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This segment provides common utility functions used throughout + * the other [incr Tcl] source files. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * overhauled version author: Arnulf Wiedemann + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +#ifdef ITCL_PRESERVE_DEBUG +#include <malloc.h> +#endif + +/* + * POOL OF LIST ELEMENTS FOR LINKED LIST + */ +static Itcl_ListElem *listPool = NULL; +static int listPoolLen = 0; + +#define ITCL_VALID_LIST 0x01face10 /* magic bit pattern for validation */ +#define ITCL_LIST_POOL_SIZE 200 /* max number of elements in listPool */ + +/* + * This structure is used to take a snapshot of the interpreter + * state in Itcl_SaveInterpState. You can snapshot the state, + * execute a command, and then back up to the result or the + * error that was previously in progress. + */ +typedef struct InterpState { + int validate; /* validation stamp */ + int status; /* return code status */ + Tcl_Obj *objResult; /* result object */ + char *errorInfo; /* contents of errorInfo variable */ + char *errorCode; /* contents of errorCode variable */ +} InterpState; + +#define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */ + +#ifdef ITCL_PRESERVE_DEBUG +static Tcl_HashTable itclPreserveInfos; +static int itclPreserveInfoInitted = 0; +#endif + + +/* + * ------------------------------------------------------------------------ + * Itcl_Assert() + * + * Called whenever an assert() test fails. Prints a diagnostic + * message and abruptly exits. + * ------------------------------------------------------------------------ + */ + +void +Itcl_Assert(testExpr, fileName, lineNumber) + const char *testExpr; /* string representing test expression */ + const char *fileName; /* file name containing this call */ + int lineNumber; /* line number containing this call */ +{ + Tcl_Panic("Itcl Assertion failed: \"%s\" (line %d of %s)", + testExpr, lineNumber, fileName); +} + + + +/* + * ------------------------------------------------------------------------ + * Itcl_InitStack() + * + * Initializes a stack structure, allocating a certain amount of memory + * for the stack and setting the stack length to zero. + * ------------------------------------------------------------------------ + */ +void +Itcl_InitStack(stack) + Itcl_Stack *stack; /* stack to be initialized */ +{ + stack->values = stack->space; + stack->max = sizeof(stack->space)/sizeof(ClientData); + stack->len = 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteStack() + * + * Destroys a stack structure, freeing any memory that may have been + * allocated to represent it. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteStack(stack) + Itcl_Stack *stack; /* stack to be deleted */ +{ + /* + * If memory was explicitly allocated (instead of using the + * built-in buffer) then free it. + */ + if (stack->values != stack->space) { + ckfree((char*)stack->values); + } + stack->values = NULL; + stack->len = stack->max = 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PushStack() + * + * Pushes a piece of client data onto the top of the given stack. + * If the stack is not large enough, it is automatically resized. + * ------------------------------------------------------------------------ + */ +void +Itcl_PushStack(cdata,stack) + ClientData cdata; /* data to be pushed onto stack */ + Itcl_Stack *stack; /* stack */ +{ + ClientData *newStack; + + if (stack->len+1 >= stack->max) { + stack->max = 2*stack->max; + newStack = (ClientData*) + ckalloc((unsigned)(stack->max*sizeof(ClientData))); + + if (stack->values) { + memcpy((char*)newStack, (char*)stack->values, + (size_t)(stack->len*sizeof(ClientData))); + + if (stack->values != stack->space) + ckfree((char*)stack->values); + } + stack->values = newStack; + } + stack->values[stack->len++] = cdata; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PopStack() + * + * Pops a bit of client data from the top of the given stack. + * ------------------------------------------------------------------------ + */ +ClientData +Itcl_PopStack(stack) + Itcl_Stack *stack; /* stack to be manipulated */ +{ + if (stack->values && (stack->len > 0)) { + stack->len--; + return stack->values[stack->len]; + } + return (ClientData)NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PeekStack() + * + * Gets the current value from the top of the given stack. + * ------------------------------------------------------------------------ + */ +ClientData +Itcl_PeekStack(stack) + Itcl_Stack *stack; /* stack to be examined */ +{ + if (stack->values && (stack->len > 0)) { + return stack->values[stack->len-1]; + } + return (ClientData)NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_GetStackValue() + * + * Gets a value at some index within the stack. Index "0" is the + * first value pushed onto the stack. + * ------------------------------------------------------------------------ + */ +ClientData +Itcl_GetStackValue(stack,pos) + Itcl_Stack *stack; /* stack to be examined */ + int pos; /* get value at this index */ +{ + if (stack->values && (stack->len > 0)) { + assert(pos < stack->len); + return stack->values[pos]; + } + return (ClientData)NULL; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InitList() + * + * Initializes a linked list structure, setting the list to the empty + * state. + * ------------------------------------------------------------------------ + */ +void +Itcl_InitList(listPtr) + Itcl_List *listPtr; /* list to be initialized */ +{ + listPtr->validate = ITCL_VALID_LIST; + listPtr->num = 0; + listPtr->head = NULL; + listPtr->tail = NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteList() + * + * Destroys a linked list structure, deleting all of its elements and + * setting it to an empty state. If the elements have memory associated + * with them, this memory must be freed before deleting the list or it + * will be lost. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteList(listPtr) + Itcl_List *listPtr; /* list to be deleted */ +{ + Itcl_ListElem *elemPtr; + + assert(listPtr->validate == ITCL_VALID_LIST); + + elemPtr = listPtr->head; + while (elemPtr) { + elemPtr = Itcl_DeleteListElem(elemPtr); + } + listPtr->validate = 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateListElem() + * + * Low-level routined used by procedures like Itcl_InsertList() and + * Itcl_AppendList() to create new list elements. If elements are + * available, one is taken from the list element pool. Otherwise, + * a new one is allocated. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_CreateListElem( + Itcl_List *listPtr) /* list that will contain this new element */ +{ + Itcl_ListElem *elemPtr; + + if (listPoolLen > 0) { + elemPtr = listPool; + listPool = elemPtr->next; + --listPoolLen; + } else { + elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem)); + } + elemPtr->owner = listPtr; + elemPtr->value = NULL; + elemPtr->next = NULL; + elemPtr->prev = NULL; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteListElem() + * + * Destroys a single element in a linked list, returning it to a pool of + * elements that can be later reused. Returns a pointer to the next + * element in the list. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_DeleteListElem(elemPtr) + Itcl_ListElem *elemPtr; /* list element to be deleted */ +{ + Itcl_List *listPtr; + Itcl_ListElem *nextPtr; + + nextPtr = elemPtr->next; + + if (elemPtr->prev) { + elemPtr->prev->next = elemPtr->next; + } + if (elemPtr->next) { + elemPtr->next->prev = elemPtr->prev; + } + + listPtr = elemPtr->owner; + if (elemPtr == listPtr->head) { + listPtr->head = elemPtr->next; + } + if (elemPtr == listPtr->tail) { + listPtr->tail = elemPtr->prev; + } + --listPtr->num; + + if (listPoolLen < ITCL_LIST_POOL_SIZE) { + elemPtr->next = listPool; + listPool = elemPtr; + ++listPoolLen; + } else { + ckfree((char*)elemPtr); + } + return nextPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_InsertList() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is inserted at the beginning of the + * specified list. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_InsertList(listPtr,val) + Itcl_List *listPtr; /* list being modified */ + ClientData val; /* value associated with new element */ +{ + Itcl_ListElem *elemPtr; + assert(listPtr->validate == ITCL_VALID_LIST); + + elemPtr = Itcl_CreateListElem(listPtr); + + elemPtr->value = val; + elemPtr->next = listPtr->head; + elemPtr->prev = NULL; + if (listPtr->head) { + listPtr->head->prev = elemPtr; + } + listPtr->head = elemPtr; + if (listPtr->tail == NULL) { + listPtr->tail = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_InsertListElem() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is inserted in the list just before + * the specified element. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_InsertListElem(pos,val) + Itcl_ListElem *pos; /* insert just before this element */ + ClientData val; /* value associated with new element */ +{ + Itcl_List *listPtr; + Itcl_ListElem *elemPtr; + + listPtr = pos->owner; + assert(listPtr->validate == ITCL_VALID_LIST); + assert(pos != NULL); + + elemPtr = Itcl_CreateListElem(listPtr); + elemPtr->value = val; + + elemPtr->prev = pos->prev; + if (elemPtr->prev) { + elemPtr->prev->next = elemPtr; + } + elemPtr->next = pos; + pos->prev = elemPtr; + + if (listPtr->head == pos) { + listPtr->head = elemPtr; + } + if (listPtr->tail == NULL) { + listPtr->tail = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AppendList() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is appended at the end of the + * specified list. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_AppendList(listPtr,val) + Itcl_List *listPtr; /* list being modified */ + ClientData val; /* value associated with new element */ +{ + Itcl_ListElem *elemPtr; + assert(listPtr->validate == ITCL_VALID_LIST); + + elemPtr = Itcl_CreateListElem(listPtr); + + elemPtr->value = val; + elemPtr->prev = listPtr->tail; + elemPtr->next = NULL; + if (listPtr->tail) { + listPtr->tail->next = elemPtr; + } + listPtr->tail = elemPtr; + if (listPtr->head == NULL) { + listPtr->head = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AppendListElem() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is inserted in the list just after + * the specified element. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_AppendListElem(pos,val) + Itcl_ListElem *pos; /* insert just after this element */ + ClientData val; /* value associated with new element */ +{ + Itcl_List *listPtr; + Itcl_ListElem *elemPtr; + + listPtr = pos->owner; + assert(listPtr->validate == ITCL_VALID_LIST); + assert(pos != NULL); + + elemPtr = Itcl_CreateListElem(listPtr); + elemPtr->value = val; + + elemPtr->next = pos->next; + if (elemPtr->next) { + elemPtr->next->prev = elemPtr; + } + elemPtr->prev = pos; + pos->next = elemPtr; + + if (listPtr->tail == pos) { + listPtr->tail = elemPtr; + } + if (listPtr->head == NULL) { + listPtr->head = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_SetListValue() + * + * Modifies the value associated with a list element. + * ------------------------------------------------------------------------ + */ +void +Itcl_SetListValue(elemPtr,val) + Itcl_ListElem *elemPtr; /* list element being modified */ + ClientData val; /* new value associated with element */ +{ + Itcl_List *listPtr = elemPtr->owner; + assert(listPtr->validate == ITCL_VALID_LIST); + assert(elemPtr != NULL); + + elemPtr->value = val; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FinishList() + * + * free all memory used in the list pool + * ------------------------------------------------------------------------ + */ +void +Itcl_FinishList() +{ + Itcl_ListElem *listPtr; + Itcl_ListElem *elemPtr; + + listPtr = listPool; + while (listPtr != NULL) { + elemPtr = listPtr; + listPtr = elemPtr->next; + ckfree((char *)elemPtr); + elemPtr = NULL; + } + listPool = NULL; + listPoolLen = 0; +} + + +/* + * ======================================================================== + * REFERENCE-COUNTED DATA + * + * The following procedures manage generic reference-counted data. + * They are similar in spirit to the Tcl_Preserve/Tcl_Release + * procedures defined in the Tcl/Tk core. But these procedures use + * a hash table instead of a linked list to maintain the references, + * so they scale better. Also, the Tcl procedures have a bad behavior + * during the "exit" command. Their exit handler shuts them down + * when other data is still being reference-counted and cleaned up. + * + * ------------------------------------------------------------------------ + * Itcl_EventuallyFree() + * + * Registers a piece of data so that it will be freed when no longer + * in use. The data is registered with an initial usage count of "0". + * Future calls to Itcl_PreserveData() increase this usage count, and + * calls to Itcl_ReleaseData() decrease the count until it reaches + * zero and the data is freed. + * ------------------------------------------------------------------------ + */ +void +Itcl_EventuallyFree( + ClientData cdata, /* data to be freed when not in use */ + Tcl_FreeProc *fproc) /* procedure called to free data */ +{ + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + Tcl_EventuallyFree(cdata, fproc); + return; + +} +#ifdef ITCL_PRESERVE_DEBUG +void +Itcl_DbDumpPreserveInfo( + const char *fileName) +{ + FOREACH_HASH_DECLS; + FILE *fd; + ItclPreserveInfo *ipiPtr; + ItclPreserveInfoEntry *ipiePtr; + size_t j; + + if (fileName == NULL) { + fd = stderr; + } else { + fd = fopen(fileName, "w"); + } + fprintf(fd, "type\taddr\tfile\tline\n"); + FOREACH_HASH_VALUE(ipiPtr, &itclPreserveInfos) { + if (ipiPtr->refCount == 0) { + continue; + } + fprintf(stderr, "DAT!%p!%" TCL_LL_MODIFIER "u!\n", ipiPtr->clientData, (Tcl_WideUInt) ipiPtr->refCount); + for (j = 0; j < ipiPtr->numEntries; j++) { + ipiePtr = &ipiPtr->entries[j]; + if (ipiePtr->type != ITCL_PRESERVE_DELETED) { + fprintf(fd, "%s\t%p\t%s\t%d\n", + ipiePtr->type == ITCL_PRESERVE_INCR ? "INCR" : "DECR", + ipiPtr->clientData, ipiePtr->fileName, ipiePtr->line); + } + } + } + if (fd != stderr) { + fclose(fd); + } +} +#endif + +/* + * ------------------------------------------------------------------------ + * Itcl_PreserveData() + * + * Increases the usage count for a piece of data that will be freed + * later when no longer needed. Each call to Itcl_PreserveData() + * puts one claim on a piece of data, and subsequent calls to + * Itcl_ReleaseData() remove those claims. When Itcl_EventuallyFree() + * is called, and when the usage count reaches zero, the data is + * freed. + * ------------------------------------------------------------------------ + */ +#ifdef ITCL_PRESERVE_DEBUG +void +ItclDbgPreserveData( + ClientData cdata, /* data to be preserved */ + int line, + const char *file) +{ + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + { + Tcl_HashEntry *hPtr; + ItclPreserveInfo *ipiPtr; + ItclPreserveInfoEntry *ipiePtr; + int isNew; + + if (!itclPreserveInfoInitted) { + Tcl_InitHashTable(&itclPreserveInfos, TCL_ONE_WORD_KEYS); + itclPreserveInfoInitted = 1; + } + hPtr = Tcl_CreateHashEntry(&itclPreserveInfos, cdata, &isNew); + if (isNew) { + ipiPtr = (ItclPreserveInfo *)ckalloc(sizeof(ItclPreserveInfo)); + ipiPtr->refCount = 0; + ipiPtr->size = ITCL_PRESERVE_BUCKET_SIZE; + ipiPtr->numEntries = 0; + ipiPtr->clientData = cdata; + ipiPtr->entries = (ItclPreserveInfoEntry *)malloc( + sizeof(ItclPreserveInfoEntry) * ipiPtr->size); + Tcl_SetHashValue(hPtr, ipiPtr); + } + ipiPtr = Tcl_GetHashValue(hPtr); + if (ipiPtr->numEntries >= ipiPtr->size) { + ipiPtr->size += ITCL_PRESERVE_BUCKET_SIZE; + ipiPtr->entries = (ItclPreserveInfoEntry *) + realloc((char *)ipiPtr->entries, + sizeof(ItclPreserveInfoEntry) * + ipiPtr->size); + } + ipiePtr = &ipiPtr->entries[ipiPtr->numEntries++]; + ipiePtr->type = ITCL_PRESERVE_INCR; + ipiePtr->line = line; + ipiePtr->fileName = file; + ipiPtr->refCount++; + } + + Tcl_Preserve(cdata); + return; +} +# else +void +Itcl_PreserveData( + ClientData cdata) /* data to be preserved */ +{ + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + Tcl_Preserve(cdata); + return; +} +#endif + +/* + * ------------------------------------------------------------------------ + * Itcl_ReleaseData() + * + * Decreases the usage count for a piece of data that was registered + * previously via Itcl_PreserveData(). After Itcl_EventuallyFree() + * is called and the usage count reaches zero, the data is + * automatically freed. + * ------------------------------------------------------------------------ + */ +#ifdef ITCL_PRESERVE_DEBUG +void +ItclDbgReleaseData( + ClientData cdata, /* data to be released */ + int line, + const char *file) +{ + + int noDelete = 0; + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + { + Tcl_HashEntry *hPtr; + ItclPreserveInfo *ipiPtr; + ItclPreserveInfoEntry *ipiePtr; + + if (!itclPreserveInfoInitted) { + Tcl_InitHashTable(&itclPreserveInfos, TCL_ONE_WORD_KEYS); + itclPreserveInfoInitted = 1; + } + hPtr = Tcl_FindHashEntry(&itclPreserveInfos, cdata); + if (hPtr != NULL) { + ipiPtr = Tcl_GetHashValue(hPtr); + if (ipiPtr->numEntries >= ipiPtr->size) { + ipiPtr->size += ITCL_PRESERVE_BUCKET_SIZE; + ipiPtr->entries = (ItclPreserveInfoEntry *) + realloc((char *)ipiPtr->entries, + sizeof(ItclPreserveInfoEntry) * + ipiPtr->size); + } + ipiePtr = &ipiPtr->entries[ipiPtr->numEntries++]; + ipiePtr->type = ITCL_PRESERVE_DECR; + ipiePtr->line = line; + ipiePtr->fileName = file; + if (ipiPtr->refCount-- == 0) { + fprintf(stderr, "REFCOUNT < 0 for: %p!\n", cdata); + noDelete = 1; + } + } + } + if (!noDelete) { + Tcl_Release(cdata); + } + return; +} +#else +void +Itcl_ReleaseData( + ClientData cdata) /* data to be released */ +{ + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + Tcl_Release(cdata); + return; +} +#endif + +/* + * ------------------------------------------------------------------------ + * Itcl_SaveInterpState() + * + * Takes a snapshot of the current result state of the interpreter. + * The snapshot can be restored at any point by Itcl_RestoreInterpState. + * So if you are in the middle of building a return result, you can + * snapshot the interpreter, execute a command that might generate an + * error, restore the snapshot, and continue building the result string. + * + * Once a snapshot is saved, it must be restored by calling + * Itcl_RestoreInterpState, or discarded by calling + * Itcl_DiscardInterpState. Otherwise, memory will be leaked. + * + * Returns a token representing the state of the interpreter. + * ------------------------------------------------------------------------ + */ +Itcl_InterpState +Itcl_SaveInterpState(interp, status) + Tcl_Interp* interp; /* interpreter being modified */ + int status; /* integer status code for current operation */ +{ + return (Itcl_InterpState) Tcl_SaveInterpState(interp, status); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_RestoreInterpState() + * + * Restores the state of the interpreter to a snapshot taken by + * Itcl_SaveInterpState. This affects variables such as "errorInfo" + * and "errorCode". After this call, the token for the interpreter + * state is no longer valid. + * + * Returns the status code that was pending at the time the state was + * captured. + * ------------------------------------------------------------------------ + */ +int +Itcl_RestoreInterpState(interp, state) + Tcl_Interp* interp; /* interpreter being modified */ + Itcl_InterpState state; /* token representing interpreter state */ +{ + return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DiscardInterpState() + * + * Frees the memory associated with an interpreter snapshot taken by + * Itcl_SaveInterpState. If the snapshot is not restored, this + * procedure must be called to discard it, or the memory will be lost. + * After this call, the token for the interpreter state is no longer + * valid. + * ------------------------------------------------------------------------ + */ +void +Itcl_DiscardInterpState(state) + Itcl_InterpState state; /* token representing interpreter state */ +{ + Tcl_DiscardInterpState((Tcl_InterpState)state); + return; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_Protection() + * + * Used to query/set the protection level used when commands/variables + * are defined within a class. The default protection level (when + * no public/protected/private command is active) is ITCL_DEFAULT_PROTECT. + * In the default case, new commands are treated as public, while new + * variables are treated as protected. + * + * If the specified level is 0, then this procedure returns the + * current value without changing it. Otherwise, it sets the current + * value to the specified protection level, and returns the previous + * value. + * ------------------------------------------------------------------------ + */ +int +Itcl_Protection(interp, newLevel) + Tcl_Interp *interp; /* interpreter being queried */ + int newLevel; /* new protection level or 0 */ +{ + int oldVal; + ItclObjectInfo *infoPtr; + + /* + * If a new level was specified, then set the protection level. + * In any case, return the protection level as it stands right now. + */ + infoPtr = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA, + (Tcl_InterpDeleteProc**)NULL); + + assert(infoPtr != NULL); + oldVal = infoPtr->protection; + + if (newLevel != 0) { + assert(newLevel == ITCL_PUBLIC || + newLevel == ITCL_PROTECTED || + newLevel == ITCL_PRIVATE || + newLevel == ITCL_DEFAULT_PROTECT); + infoPtr->protection = newLevel; + } + return oldVal; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseNamespPath() + * + * Parses a reference to a namespace element of the form: + * + * namesp::namesp::namesp::element + * + * Returns pointers to the head part ("namesp::namesp::namesp") + * and the tail part ("element"). If the head part is missing, + * a NULL pointer is returned and the rest of the string is taken + * as the tail. + * + * Both head and tail point to locations within the given dynamic + * string buffer. This buffer must be uninitialized when passed + * into this procedure, and it must be freed later on, when the + * strings are no longer needed. + * ------------------------------------------------------------------------ + */ +void +Itcl_ParseNamespPath( + const char *name, /* path name to class member */ + Tcl_DString *buffer, /* dynamic string buffer (uninitialized) */ + const char **head, /* returns "namesp::namesp::namesp" part */ + const char **tail) /* returns "element" part */ +{ + register char *sep, *newname; + + Tcl_DStringInit(buffer); + + /* + * Copy the name into the buffer and parse it. Look + * backward from the end of the string to the first '::' + * scope qualifier. + */ + Tcl_DStringAppend(buffer, name, -1); + newname = Tcl_DStringValue(buffer); + + for (sep=newname; *sep != '\0'; sep++) + ; + + while (--sep > newname) { + if (*sep == ':' && *(sep-1) == ':') { + break; + } + } + + /* + * Found head/tail parts. If there are extra :'s, keep backing + * up until the head is found. This supports the Tcl namespace + * behavior, which allows names like "foo:::bar". + */ + if (sep > newname) { + *tail = sep+1; + while (sep > newname && *(sep-1) == ':') { + sep--; + } + *sep = '\0'; + *head = newname; + } else { + + /* + * No :: separators--the whole name is treated as a tail. + */ + *tail = newname; + *head = NULL; + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CanAccess2() + * + * Checks to see if a class member can be accessed from a particular + * namespace context. Public things can always be accessed. Protected + * things can be accessed if the "from" namespace appears in the + * inheritance hierarchy of the class namespace. Private things + * can be accessed only if the "from" namespace is the same as the + * class that contains them. + * + * Returns 1/0 indicating true/false. + * ------------------------------------------------------------------------ + */ +int +Itcl_CanAccess2( + ItclClass *iclsPtr, /* class being tested */ + int protection, /* protection level being tested */ + Tcl_Namespace* fromNsPtr) /* namespace requesting access */ +{ + ItclClass* fromIclsPtr; + Tcl_HashEntry *entry; + + /* + * If the protection level is "public" or "private", then the + * answer is known immediately. + */ + if (protection == ITCL_PUBLIC) { + return 1; + } else { + if (protection == ITCL_PRIVATE) { + entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, + fromNsPtr); + if (entry == NULL) { + return 0; + } + return (iclsPtr == Tcl_GetHashValue(entry)); + } + } + + /* + * If the protection level is "protected", then check the + * heritage of the namespace requesting access. If cdefnPtr + * is in the heritage, then access is allowed. + */ + assert (protection == ITCL_PROTECTED); + + if (Itcl_IsClassNamespace(fromNsPtr)) { + entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, + fromNsPtr); + if (entry == NULL) { + return 0; + } + fromIclsPtr = Tcl_GetHashValue(entry); + + entry = Tcl_FindHashEntry(&fromIclsPtr->heritage, + (char*)iclsPtr); + + if (entry) { + return 1; + } + } + return 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CanAccess() + * + * Checks to see if a class member can be accessed from a particular + * namespace context. Public things can always be accessed. Protected + * things can be accessed if the "from" namespace appears in the + * inheritance hierarchy of the class namespace. Private things + * can be accessed only if the "from" namespace is the same as the + * class that contains them. + * + * Returns 1/0 indicating true/false. + * ------------------------------------------------------------------------ + */ +int +Itcl_CanAccess( + ItclMemberFunc* imPtr, /* class member being tested */ + Tcl_Namespace* fromNsPtr) /* namespace requesting access */ +{ + return Itcl_CanAccess2(imPtr->iclsPtr, imPtr->protection, fromNsPtr); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CanAccessFunc() + * + * Checks to see if a member function with the specified protection + * level can be accessed from a particular namespace context. This + * follows the same rules enforced by Itcl_CanAccess, but adds one + * special case: If the function is a protected method, and if the + * current context is a base class that has the same method, then + * access is allowed. + * + * Returns 1/0 indicating true/false. + * ------------------------------------------------------------------------ + */ +int +Itcl_CanAccessFunc( + ItclMemberFunc* imPtr, /* member function being tested */ + Tcl_Namespace* fromNsPtr) /* namespace requesting access */ +{ + ItclClass *iclsPtr; + ItclClass *fromIclsPtr; + ItclMemberFunc *ovlfunc; + Tcl_HashEntry *entry; + + /* + * Apply the usual rules first. + */ + if (Itcl_CanAccess(imPtr, fromNsPtr)) { + return 1; + } + + /* + * As a last resort, see if the namespace is really a base + * class of the class containing the method. Look for a + * method with the same name in the base class. If there + * is one, then this method overrides it, and the base class + * has access. + */ + if ((imPtr->flags & ITCL_COMMON) == 0 && + Itcl_IsClassNamespace(fromNsPtr)) { + Tcl_HashEntry *hPtr; + + iclsPtr = imPtr->iclsPtr; + hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, + (char *)fromNsPtr); + if (hPtr == NULL) { + return 0; + } + fromIclsPtr = Tcl_GetHashValue(hPtr); + + if (Tcl_FindHashEntry(&iclsPtr->heritage, (char*)fromIclsPtr)) { + entry = Tcl_FindHashEntry(&fromIclsPtr->resolveCmds, + (char *)imPtr->namePtr); + + if (entry) { + ItclCmdLookup *clookup; + clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); + ovlfunc = clookup->imPtr; + if ((ovlfunc->flags & ITCL_COMMON) == 0 && + ovlfunc->protection < ITCL_PRIVATE) { + return 1; + } + } + } + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DecodeScopedCommand() + * + * Decodes a scoped command of the form: + * + * namespace inscope <namesp> <command> + * + * If the given string is not a scoped value, this procedure does + * nothing and returns TCL_OK. If the string is a scoped value, + * then it is decoded, and the namespace, and the simple command + * string are returned as arguments; the simple command should + * be freed when no longer in use. If anything goes wrong, this + * procedure returns TCL_ERROR, along with an error message in + * the interpreter. + * ------------------------------------------------------------------------ + */ +int +Itcl_DecodeScopedCommand( + Tcl_Interp *interp, /* current interpreter */ + const char *name, /* string to be decoded */ + Tcl_Namespace **rNsPtr, /* returns: namespace for scoped value */ + char **rCmdPtr) /* returns: simple command word */ +{ + Tcl_Namespace *nsPtr; + char *cmdName; + const char *pos; + const char **listv; + int listc; + int result; + int len; + + nsPtr = NULL; + len = strlen(name); + cmdName = ckalloc((unsigned)strlen(name)+1); + strcpy(cmdName, name); + + if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) { + for (pos = (name + 9); (*pos == ' '); pos++) { + /* empty body: skip over spaces */ + } + if ((*pos == 'i') && ((pos + 7) <= (name + len)) + && (strncmp(pos, "inscope", 7) == 0)) { + + result = Tcl_SplitList(interp, (const char *)name, &listc, + &listv); + if (result == TCL_OK) { + if (listc != 4) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "malformed command \"", name, "\": should be \"", + "namespace inscope namesp command\"", + (char*)NULL); + result = TCL_ERROR; + } else { + nsPtr = Tcl_FindNamespace(interp, listv[2], + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (nsPtr == NULL) { + result = TCL_ERROR; + } else { + ckfree(cmdName); + cmdName = ckalloc((unsigned)(strlen(listv[3])+1)); + strcpy(cmdName, listv[3]); + } + } + } + ckfree((char*)listv); + + if (result != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (while decoding scoped command \"%s\")", + name)); + ckfree(cmdName); + return TCL_ERROR; + } + } + } + + *rNsPtr = nsPtr; + *rCmdPtr = cmdName; + return TCL_OK; +} + +#ifdef ITCL_PRESERVE_DEBUG +#undef Itcl_PreserveData +#undef Itcl_ReleaseData + +void +Itcl_PreserveData( + ClientData cdata) +{ + ItclDbgPreserveData(cdata, 0, ""); +} + +void +Itcl_ReleaseData( + ClientData cdata) +{ + ItclDbgReleaseData(cdata, 0, ""); +} +#endif diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclVCInt.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclVCInt.h new file mode 100644 index 0000000..93ba54f --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclVCInt.h @@ -0,0 +1,37 @@ +#define ITCL_RESOLVE_DATA "ITCL_Resolve_Info" + +typedef struct ItclResolvngInfo { + Tcl_Interp *interp; + Tcl_HashTable resolveVars; /* all possible names for variables in + * this class (e.g., x, foo::x, etc.) */ + Tcl_HashTable resolveCmds; /* all possible names for functions in + * this class (e.g., x, foo::x, etc.) */ + ItclCheckClassProtection *varProtFcn; + ItclCheckClassProtection *cmdProtFcn; + Tcl_HashTable objectVarsTables; + Tcl_HashTable objectCmdsTables; +} ItclResolvingInfo; + +typedef struct ObjectVarInfo { + ClientData clientData; + ItclObject *ioPtr; + Tcl_Var varPtr; +} ObjectVarInfo; + +typedef struct ObjectVarTableInfo { + Tcl_HashTable varInfos; + TclVarHashTable *tablePtr; +} ObjectVarTableInfo; + +typedef struct ObjectCmdInfo { + ClientData clientData; + ItclObject *ioPtr; + Tcl_Command cmdPtr; +} ObjectCmdInfo; + +typedef struct ObjectCmdTableInfo { + Tcl_HashTable cmdInfos; + Tcl_HashTable *tablePtr; +} ObjectCmdTableInfo; + + diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.c b/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.c new file mode 100644 index 0000000..0511d14 --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.c @@ -0,0 +1,234 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * These procedures handle command and variable resolution + * + * ======================================================================== + * AUTHOR: Arnulf Wiedemann + * + * ======================================================================== + * Copyright (c) Arnulf Wiedemann + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include <tclInt.h> +#include "itclInt.h" +#include "itclVCInt.h" + +#ifdef NEW_PROTO_RESOLVER +static void +ItclDeleteResolveInfo( + ClientData clientData, + Tcl_Interp *interp) +{ + ckfree((char *)clientData); +} +#endif + +int +ItclVarsAndCommandResolveInit( + Tcl_Interp *interp) +{ +#ifdef NEW_PROTO_RESOLVER + ItclResolvingInfo *iriPtr; + + /* + * Create the top-level data structure for tracking objects. + * Store this as "associated data" for easy access, but link + * it to the itcl namespace for ownership. + */ + iriPtr = (ItclResolvingInfo*)ckalloc(sizeof(ItclResolvingInfo)); + memset(iriPtr, 0, sizeof(ItclResolvingInfo)); + iriPtr->interp = interp; + Tcl_InitHashTable(&iriPtr->resolveVars, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iriPtr->resolveCmds, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iriPtr->objectVarsTables, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iriPtr->objectCmdsTables, TCL_ONE_WORD_KEYS); + + Tcl_SetAssocData(interp, ITCL_RESOLVE_DATA, + (Tcl_InterpDeleteProc*)ItclDeleteResolveInfo, (ClientData)iriPtr); + Tcl_Preserve((ClientData)iriPtr); + + Itcl_SetClassCommandProtectionCallback(interp, NULL, + Itcl_CheckClassCommandProtection); + Itcl_SetClassVariableProtectionCallback(interp, NULL, + Itcl_CheckClassVariableProtection); +#endif + return TCL_OK; +} + +ClientData +Itcl_RegisterClassVariable( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *varName, + ClientData clientData) +{ + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ItclResolvingInfo *iriPtr; + int isNew; + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_CreateHashEntry(&iriPtr->resolveVars, nsPtr->fullName, &isNew); + if (isNew) { + tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, tablePtr); + + } else { + tablePtr = Tcl_GetHashValue(hPtr); + } + hPtr = Tcl_CreateHashEntry(tablePtr, varName, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, clientData); + } + return Tcl_GetHashValue(hPtr); +} + +ClientData +Itcl_RegisterClassCommand( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + const char *cmdName, + ClientData clientData) +{ + Tcl_HashEntry *hPtr; + Tcl_HashTable *tablePtr; + ItclResolvingInfo *iriPtr; + int isNew; + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_CreateHashEntry(&iriPtr->resolveCmds, nsPtr->fullName, &isNew); + if (isNew) { + tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, tablePtr); + + } else { + tablePtr = Tcl_GetHashValue(hPtr); + } + hPtr = Tcl_CreateHashEntry(tablePtr, cmdName, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, clientData); + } + return Tcl_GetHashValue(hPtr); +} + +Tcl_Var +Itcl_RegisterObjectVariable( + Tcl_Interp *interp, + ItclObject *ioPtr, + const char *varName, + ClientData clientData, + Tcl_Var varPtr, + Tcl_Namespace *nsPtr) +{ + Tcl_HashEntry *hPtr; + ItclResolvingInfo *iriPtr; + ObjectVarTableInfo *ovtiPtr; + ObjectVarInfo *oviPtr; + int isNew; + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_CreateHashEntry(&iriPtr->objectVarsTables, + (char *)ioPtr, &isNew); + if (isNew) { + ovtiPtr = (ObjectVarTableInfo *)ckalloc(sizeof(ObjectVarTableInfo)); + Tcl_InitHashTable(&ovtiPtr->varInfos, TCL_ONE_WORD_KEYS); + ovtiPtr->tablePtr = &((Namespace *)nsPtr)->varTable; + Tcl_SetHashValue(hPtr, ovtiPtr); + } else { + ovtiPtr = Tcl_GetHashValue(hPtr); + } + hPtr = Tcl_CreateHashEntry(&ovtiPtr->varInfos, (char *)clientData, &isNew); + if (isNew) { + oviPtr = (ObjectVarInfo *)ckalloc(sizeof(ObjectVarInfo)); + memset(oviPtr, 0, sizeof(ObjectVarInfo)); + Tcl_SetHashValue(hPtr, oviPtr); + } else { + oviPtr = Tcl_GetHashValue(hPtr); + } + oviPtr->clientData = clientData; + oviPtr->ioPtr = ioPtr; + if (varPtr == NULL) { + varPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName); + } + oviPtr->varPtr = varPtr; + return varPtr; +} + +Tcl_Command +Itcl_RegisterObjectCommand( + Tcl_Interp *interp, + ItclObject *ioPtr, + const char *cmdName, + ClientData clientData, + Tcl_Command cmdPtr, + Tcl_Namespace *nsPtr) +{ + Tcl_HashEntry *hPtr; + ItclResolvingInfo *iriPtr; + ObjectCmdTableInfo *octiPtr; + ObjectCmdInfo *ociPtr; + int isNew; + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + hPtr = Tcl_CreateHashEntry(&iriPtr->objectCmdsTables, + (char *)ioPtr, &isNew); + if (isNew) { + octiPtr = (ObjectCmdTableInfo *)ckalloc(sizeof(ObjectCmdTableInfo)); + Tcl_InitHashTable(&octiPtr->cmdInfos, TCL_ONE_WORD_KEYS); + octiPtr->tablePtr = &((Namespace *)nsPtr)->cmdTable; + Tcl_SetHashValue(hPtr, octiPtr); + } else { + octiPtr = Tcl_GetHashValue(hPtr); + } + hPtr = Tcl_CreateHashEntry(&octiPtr->cmdInfos, (char *)clientData, &isNew); + if (isNew) { + ociPtr = (ObjectCmdInfo *)ckalloc(sizeof(ObjectCmdInfo)); + memset(ociPtr, 0, sizeof(ObjectCmdInfo)); + Tcl_SetHashValue(hPtr, ociPtr); + } else { + ociPtr = Tcl_GetHashValue(hPtr); + } + ociPtr->clientData = clientData; + ociPtr->ioPtr = ioPtr; + if (cmdPtr == NULL) { +/* + cmdPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName); +*/ + } + ociPtr->cmdPtr = cmdPtr; + return cmdPtr; +} + +int +Itcl_SetClassVariableProtectionCallback( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + ItclCheckClassProtection *fcnPtr) +{ + ItclResolvingInfo *iriPtr; + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + iriPtr->varProtFcn = fcnPtr; + return TCL_OK; +} + +int +Itcl_SetClassCommandProtectionCallback( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + ItclCheckClassProtection *fcnPtr) +{ + ItclResolvingInfo *iriPtr; + + iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); + iriPtr->cmdProtFcn = fcnPtr; + return TCL_OK; +} diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.h b/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.h new file mode 100644 index 0000000..966806b --- /dev/null +++ b/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.h @@ -0,0 +1,46 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * These procedures handle command and variable resolution + * + * ======================================================================== + * AUTHOR: Arnulf Wiedemann + * + * ======================================================================== + * Copyright (c) Arnulf Wiedemann + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +typedef int (ItclCheckClassProtection)(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *varName, ClientData clientData); + +ClientData Itcl_RegisterClassVariable(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *varName, ClientData clientData); + +Tcl_Var Itcl_RegisterObjectVariable( Tcl_Interp *interp, ItclObject *ioPtr, + const char *varName, ClientData clientData, Tcl_Var varPtr, + Tcl_Namespace *nsPtr); + +ClientData Itcl_RegisterClassCommand(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *cmdName, ClientData clientData); + +Tcl_Command Itcl_RegisterObjectCommand( Tcl_Interp *interp, ItclObject *ioPtr, + const char *cmdName, ClientData clientData, Tcl_Command cmdPtr, + Tcl_Namespace *nsPtr); + +int Itcl_CheckClassVariableProtection(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *varName, ClientData clientData); + +int Itcl_CheckClassCommandProtection(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *cmdName, ClientData clientData); + +int Itcl_SetClassVariableProtectionCallback(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, ItclCheckClassProtection *fcnPtr); + +int Itcl_SetClassCommandProtectionCallback(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, ItclCheckClassProtection *fcnPtr); + |