diff options
| author | William Joye <wjoye@cfa.harvard.edu> | 2019-07-31 17:50:24 (GMT) |
|---|---|---|
| committer | William Joye <wjoye@cfa.harvard.edu> | 2019-07-31 17:50:24 (GMT) |
| commit | de0c57b4383a4d7ced5058c2c50580a0f4ba5477 (patch) | |
| tree | ed9f83c4262ccc3cd22a3cf8ad5ad18f197f7d63 /tcl8.6/pkgs/itcl4.1.1/generic | |
| parent | 4f9885152c6e8eef1a01e2cc50fa4e3db8bbcb5c (diff) | |
| download | blt-de0c57b4383a4d7ced5058c2c50580a0f4ba5477.zip blt-de0c57b4383a4d7ced5058c2c50580a0f4ba5477.tar.gz blt-de0c57b4383a4d7ced5058c2c50580a0f4ba5477.tar.bz2 | |
upgrade tcl/tk 8.6.10
Diffstat (limited to 'tcl8.6/pkgs/itcl4.1.1/generic')
33 files changed, 0 insertions, 37079 deletions
diff --git a/tcl8.6/pkgs/itcl4.1.1/generic/clientData b/tcl8.6/pkgs/itcl4.1.1/generic/clientData deleted file mode 100644 index 62e3f3c..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/clientData +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 index 1530464..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itcl.decls +++ /dev/null @@ -1,621 +0,0 @@ -# -*- 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 deleted file mode 100644 index 23a84a6..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itcl.h +++ /dev/null @@ -1,203 +0,0 @@ -/* - * 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 deleted file mode 100644 index 30ea887..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.c +++ /dev/null @@ -1,377 +0,0 @@ -/* - * 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 deleted file mode 100644 index 4f9df0a..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itcl2TclOO.h +++ /dev/null @@ -1,34 +0,0 @@ - -#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 deleted file mode 100644 index 450074a..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclBase.c +++ /dev/null @@ -1,838 +0,0 @@ -/* - * 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 deleted file mode 100644 index e605762..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclBuiltin.c +++ /dev/null @@ -1,3783 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index af02d6e..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclClass.c +++ /dev/null @@ -1,2640 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 1111953..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclCmd.c +++ /dev/null @@ -1,2182 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 4af4200..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclDecls.h +++ /dev/null @@ -1,201 +0,0 @@ -/* - * 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 deleted file mode 100644 index 1d5ac19..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclEnsemble.c +++ /dev/null @@ -1,2243 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index a3f136b..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclHelpers.c +++ /dev/null @@ -1,1510 +0,0 @@ -/* - * 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 deleted file mode 100644 index bbd7513..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclInfo.c +++ /dev/null @@ -1,5327 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 5134023..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclInt.h +++ /dev/null @@ -1,854 +0,0 @@ -/* - * 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 deleted file mode 100644 index 5c68fb3..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclIntDecls.h +++ /dev/null @@ -1,1046 +0,0 @@ -/* - * 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 deleted file mode 100644 index b0e87d8..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclLinkage.c +++ /dev/null @@ -1,326 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index e33e62b..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclMethod.c +++ /dev/null @@ -1,2721 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 9f035c8..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.c +++ /dev/null @@ -1,287 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 012ea0b..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclMigrate2TclCore.h +++ /dev/null @@ -1,87 +0,0 @@ -#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 deleted file mode 100644 index 2e60c97..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclObject.c +++ /dev/null @@ -1,3845 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 9b34dc6..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclParse.c +++ /dev/null @@ -1,4309 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index c22ced2..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve.c +++ /dev/null @@ -1,697 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index b75a5a3..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclResolve2.c +++ /dev/null @@ -1,564 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 63d6437..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclStubInit.c +++ /dev/null @@ -1,240 +0,0 @@ -/* - * 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 deleted file mode 100644 index 50683b7..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclStubLib.c +++ /dev/null @@ -1,69 +0,0 @@ -/* - * 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 deleted file mode 100644 index bc7189c..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclStubs.c +++ /dev/null @@ -1,231 +0,0 @@ -/* - * 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 deleted file mode 100644 index 7d3cdf4..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.c +++ /dev/null @@ -1,143 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index b22ee06..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclTclIntStubsFcn.h +++ /dev/null @@ -1,38 +0,0 @@ -/* 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 deleted file mode 100644 index 7489b89..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclTestRegisterC.c +++ /dev/null @@ -1,128 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 057f01b..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclUtil.c +++ /dev/null @@ -1,1202 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 93ba54f..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclVCInt.h +++ /dev/null @@ -1,37 +0,0 @@ -#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 deleted file mode 100644 index 0511d14..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.c +++ /dev/null @@ -1,234 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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 deleted file mode 100644 index 966806b..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/generic/itclVarsAndCmds.h +++ /dev/null @@ -1,46 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * 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); - |