Index: generic/xotcl.c =================================================================== diff -u -re7e4c556bc1221bc39a9c2de6e2597f832562471 -r2111020b49da8ce57758e51accf0b6073037f0d2 --- generic/xotcl.c (.../xotcl.c) (revision e7e4c556bc1221bc39a9c2de6e2597f832562471) +++ generic/xotcl.c (.../xotcl.c) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) @@ -2,7 +2,7 @@ * * XOTcl - Extended Object Tcl * - * Copyright (C) 1999-2007 Gustaf Neumann (a), Uwe Zdun (a) + * Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (a) * * (a) Vienna University of Economics and Business Administration * Institute. of Information Systems and New Media @@ -11,7 +11,7 @@ * * (b) University of Essen * Specification of Software Systems - * Altendorferstra�e 97-101 + * Altendorferstrasse 97-101 * D-45143 Essen, Germany * * Permission to use, copy, modify, distribute, and sell this @@ -65,18 +65,18 @@ */ #ifdef USE_TCL_STUBS -# define XOTcl_ExprObjCmd(clientData, interp, objc, objv) \ - XOTclCallCommand(interp, XOTE_EXPR, objc, objv) -# define XOTcl_SubstObjCmd(clientData, interp, objc, objv) \ - XOTclCallCommand(interp, XOTE_SUBST, objc, objv) +# define XOTcl_ExprObjCmd(clientData, interp, objc, objv) \ + XOTclCallCommand(interp, XOTE_EXPR, objc, objv) +# define XOTcl_SubstObjCmd(clientData, interp, objc, objv) \ + XOTclCallCommand(interp, XOTE_SUBST, objc, objv) #else -# define XOTcl_ExprObjCmd(clientData, interp, objc, objv) \ - Tcl_ExprObjCmd(clientData, interp, objc, objv) -# define XOTcl_SubstObjCmd(clientData, interp, objc, objv) \ - Tcl_SubstObjCmd(clientData, interp, objc, objv) +# define XOTcl_ExprObjCmd(clientData, interp, objc, objv) \ + Tcl_ExprObjCmd(clientData, interp, objc, objv) +# define XOTcl_SubstObjCmd(clientData, interp, objc, objv) \ + Tcl_SubstObjCmd(clientData, interp, objc, objv) #endif -static int createMethod(Tcl_Interp *interp, XOTclClass *cl, ClientData clientData, +static int createMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int SetXOTclObjectFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfXOTclObject(Tcl_Obj *objPtr); @@ -86,6 +86,9 @@ static Tcl_Obj *NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *ns); static Tcl_Namespace *callingNameSpace(Tcl_Interp *interp); XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, char *name, Tcl_Namespace *ns); +#ifdef EXPERIMENTAL_CMD_RESOLVER +static int NSisXOTclNamespace(Tcl_Namespace *nsPtr); +#endif XOTCLINLINE static void GuardAdd(Tcl_Interp *interp, XOTclCmdList *filterCL, Tcl_Obj *guard); static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guards); @@ -98,107 +101,111 @@ static void MixinComputeDefined(Tcl_Interp *interp, XOTclObject *obj); static Tcl_ObjType XOTclObjectType = { - "XOTclObject", - FreeXOTclObjectInternalRep, - DupXOTclObjectInternalRep, - UpdateStringOfXOTclObject, - SetXOTclObjectFromAny + "XOTclObject", + FreeXOTclObjectInternalRep, + DupXOTclObjectInternalRep, + UpdateStringOfXOTclObject, + SetXOTclObjectFromAny }; typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; typedef struct callFrameContext { - int framesSaved; - Tcl_CallFrame *framePtr; - Tcl_CallFrame *varFramePtr; + int framesSaved; + Tcl_CallFrame *framePtr; + Tcl_CallFrame *varFramePtr; } callFrameContext; + typedef struct tclCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; + XOTclObject *obj; + Tcl_Obj *cmdName; } tclCmdClientData; + typedef struct forwardCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; - Tcl_ObjCmdProc *objProc; - int passthrough; - int needobjmap; - int verbose; - ClientData clientData; - int nr_args; - Tcl_Obj *args; - int objscope; - Tcl_Obj *onerror; - Tcl_Obj *prefix; - int nr_subcommands; - Tcl_Obj *subcommands; + XOTclObject *obj; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + int passthrough; + int needobjmap; + int verbose; + ClientData clientData; + int nr_args; + Tcl_Obj *args; + int objscope; + Tcl_Obj *onerror; + Tcl_Obj *prefix; + int nr_subcommands; + Tcl_Obj *subcommands; } forwardCmdClientData; + typedef struct aliasCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; - Tcl_ObjCmdProc *objProc; - ClientData clientData; + XOTclObject *obj; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + ClientData clientData; } aliasCmdClientData; -static int ObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], int flags); XOTCLINLINE static int DoDispatch(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], int flags); + Tcl_Obj *CONST objv[], int flags); static int XOTclNextMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclClass *givenCl, - char *givenMethod, int objc, Tcl_Obj *CONST objv[], - int useCSObjs); + char *givenMethod, int objc, Tcl_Obj *CONST objv[], + int useCSObjs); static int XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *CONST objv[]); static int XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *CONST objv[]); static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *CONST objv[]); static int callDestroyMethod(ClientData clientData, Tcl_Interp *interp, XOTclObject *obj, int flags); static int XOTclObjConvertObject(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj); - static XOTclObject *XOTclpGetObject(Tcl_Interp *interp, char *name); static XOTclClass *XOTclpGetClass(Tcl_Interp *interp, char *name); static XOTclCallStackContent *CallStackGetFrame(Tcl_Interp *interp); #if !defined(NDEBUG) static void checkAllInstances(Tcl_Interp *interp, XOTclClass *startCl, int lvl); #endif +#if defined(PRE85) +# define XOTcl_FindHashEntry(tablePtr, key) Tcl_FindHashEntry(tablePtr, key) +#else +# define XOTcl_FindHashEntry(tablePtr, key) Tcl_CreateHashEntry(tablePtr, key, NULL) +#endif - #ifdef PRE81 /* for backward compatibility only */ static int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) { - int i, result; - Tcl_DString ds, *dsp = &ds; + int i, result; + Tcl_DString ds, *dsp = &ds; - assert(flags == 0); - DSTRING_INIT(dsp); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(dsp, ObjStr(objv[i])); - } - result = Tcl_Eval(interp, Tcl_DStringValue(dsp)); - DSTRING_FREE(dsp); - return result; + assert(flags == 0); + DSTRING_INIT(dsp); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(dsp, ObjStr(objv[i])); + } + result = Tcl_Eval(interp, Tcl_DStringValue(dsp)); + DSTRING_FREE(dsp); + return result; } static int Tcl_EvalEx(Tcl_Interp *interp, char *cmd, int len, int flags) { - return Tcl_Eval(interp, cmd); + return Tcl_Eval(interp, cmd); } static int Tcl_SubstObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - char *ov[20]; - int i; - assert(objc<19); - for (i=0; ientry.key.objPtr) + (((VarInHash *)(varPtr))->entry.key.objPtr) #define VAR_TRACED_READ85 0x10 /* TCL_TRACE_READS */ #define VAR_TRACED_WRITE85 0x20 /* TCL_TRACE_WRITES */ @@ -322,81 +329,81 @@ #define VAR_TRACE_ACTIVE85 0x2000 #define VAR_SEARCH_ACTIVE85 0x4000 #define VAR_ALL_TRACES85 \ - (VAR_TRACED_READ85|VAR_TRACED_WRITE85|VAR_TRACED_ARRAY85|VAR_TRACED_UNSET85) + (VAR_TRACED_READ85|VAR_TRACED_WRITE85|VAR_TRACED_ARRAY85|VAR_TRACED_UNSET85) #define VAR_ARRAY85 0x1 #define VAR_LINK85 0x2 #define varFlags(varPtr) \ - (forwardCompatibleMode ? \ - ((Var85 *)varPtr)->flags : \ - (varPtr)->flags \ - ) + (forwardCompatibleMode ? \ + ((Var85 *)varPtr)->flags : \ + (varPtr)->flags \ + ) #undef TclIsVarScalar -#define TclIsVarScalar(varPtr) \ - (forwardCompatibleMode ? \ - !(((Var85 *)varPtr)->flags & (VAR_ARRAY85|VAR_LINK85)) : \ - ((varPtr)->flags & VAR_SCALAR) \ - ) +#define TclIsVarScalar(varPtr) \ + (forwardCompatibleMode ? \ + !(((Var85 *)varPtr)->flags & (VAR_ARRAY85|VAR_LINK85)) : \ + ((varPtr)->flags & VAR_SCALAR) \ + ) #undef TclIsVarArray #define TclIsVarArray(varPtr) \ - (forwardCompatibleMode ? \ - (((Var85 *)varPtr)->flags & VAR_ARRAY85) : \ - ((varPtr)->flags & VAR_ARRAY) \ - ) -#define TclIsVarNamespaceVar(varPtr) \ - (forwardCompatibleMode ? \ - (((Var85 *)varPtr)->flags & VAR_NAMESPACE_VAR) : \ - ((varPtr)->flags & VAR_NAMESPACE_VAR) \ - ) + (forwardCompatibleMode ? \ + (((Var85 *)varPtr)->flags & VAR_ARRAY85) : \ + ((varPtr)->flags & VAR_ARRAY) \ + ) +#define TclIsVarNamespaceVar(varPtr) \ + (forwardCompatibleMode ? \ + (((Var85 *)varPtr)->flags & VAR_NAMESPACE_VAR) : \ + ((varPtr)->flags & VAR_NAMESPACE_VAR) \ + ) -#define TclIsVarTraced(varPtr) \ - (forwardCompatibleMode ? \ - (((Var85 *)varPtr)->flags & VAR_ALL_TRACES85) : \ - (varPtr->tracePtr != NULL) \ - ) +#define TclIsVarTraced(varPtr) \ + (forwardCompatibleMode ? \ + (((Var85 *)varPtr)->flags & VAR_ALL_TRACES85) : \ + (varPtr->tracePtr != NULL) \ + ) #undef TclIsVarLink #define TclIsVarLink(varPtr) \ - (forwardCompatibleMode ? \ - (((Var85 *)varPtr)->flags & VAR_LINK85) : \ - (varPtr->flags & VAR_LINK) \ - ) + (forwardCompatibleMode ? \ + (((Var85 *)varPtr)->flags & VAR_LINK85) : \ + (varPtr->flags & VAR_LINK) \ + ) #undef TclIsVarUndefined -#define TclIsVarUndefined(varPtr) \ - (forwardCompatibleMode ? \ - (((Var85 *)varPtr)->value.objPtr == NULL) : \ - (varPtr->flags & VAR_UNDEFINED) \ - ) +#define TclIsVarUndefined(varPtr) \ + (forwardCompatibleMode ? \ + (((Var85 *)varPtr)->value.objPtr == NULL) : \ + (varPtr->flags & VAR_UNDEFINED) \ + ) #undef TclSetVarLink #define TclSetVarLink(varPtr) \ - if (forwardCompatibleMode) \ - ((Var85 *)varPtr)->flags = (((Var85 *)varPtr)->flags & ~VAR_ARRAY85) | VAR_LINK85; \ - else \ - (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK + if (forwardCompatibleMode) \ + ((Var85 *)varPtr)->flags = (((Var85 *)varPtr)->flags & ~VAR_ARRAY85) | VAR_LINK85; \ + else \ + (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK #undef TclClearVarUndefined #define TclClearVarUndefined(varPtr) \ - if (!forwardCompatibleMode) \ - (varPtr)->flags &= ~VAR_UNDEFINED + if (!forwardCompatibleMode) \ + (varPtr)->flags &= ~VAR_UNDEFINED #undef Tcl_CallFrame_compiledLocals -#define Tcl_CallFrame_compiledLocals(cf) \ - (forwardCompatibleMode ? \ - (Var *)(((CallFrame85 *)cf)->compiledLocals) : \ - (((CallFrame*)cf)->compiledLocals) \ - ) +#define Tcl_CallFrame_compiledLocals(cf) \ + (forwardCompatibleMode ? \ + (Var *)(((CallFrame85 *)cf)->compiledLocals) : \ + (((CallFrame*)cf)->compiledLocals) \ + ) -#define getNthVar(varPtr, i) \ - (forwardCompatibleMode ? \ - (Var *)(((Var85 *)varPtr)+(i)) : \ - (((Var *)varPtr)+(i)) \ - ) +#define getNthVar(varPtr, i) \ + (forwardCompatibleMode ? \ + (Var *)(((Var85 *)varPtr)+(i)) : \ + (((Var *)varPtr)+(i)) \ + ) -#define valueOfVar(type, varPtr, field) \ - (forwardCompatibleMode ? \ - (type *)(((Var85 *)varPtr)->value.field) : \ - (type *)(((Var *)varPtr)->value.field) \ - ) +#define valueOfVar(type, varPtr, field) \ + (forwardCompatibleMode ? \ + (type *)(((Var85 *)varPtr)->value.field) : \ + (type *)(((Var *)varPtr)->value.field) \ + ) #endif @@ -405,10 +412,10 @@ #endif -#define TclIsCompiledLocalArgument(compiledLocalPtr) \ - ((compiledLocalPtr)->flags & VAR_ARGUMENT) +#define TclIsCompiledLocalArgument(compiledLocalPtr) \ + ((compiledLocalPtr)->flags & VAR_ARGUMENT) #define TclIsCompiledLocalTemporary(compiledLocalPtr) \ - ((compiledLocalPtr)->flags & VAR_TEMPORARY) + ((compiledLocalPtr)->flags & VAR_TEMPORARY) #if defined(PRE85) && !FORWARD_COMPATIBLE # define VarHashGetValue(hPtr) (Var *)Tcl_GetHashValue(hPtr) @@ -425,78 +432,78 @@ * We need NewVar from tclVar.c ... but its not exported */ static Var *NewVar84() { - register Var *varPtr; + register Var *varPtr; - varPtr = (Var *) ckalloc(sizeof(Var)); - varPtr->value.objPtr = NULL; - varPtr->name = NULL; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); - return varPtr; + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->value.objPtr = NULL; + varPtr->name = NULL; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); + return varPtr; } static Var * VarHashCreateVar84(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { - char *newName = ObjStr(key); - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, newName, newPtr); - Var *varPtr; + char *newName = ObjStr(key); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, newName, newPtr); + Var *varPtr; - if (newPtr && *newPtr) { - varPtr = NewVar84(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = NULL; /* a local variable */ - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } + if (newPtr && *newPtr) { + varPtr = NewVar84(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = NULL; /* a local variable */ + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } - return varPtr; + return varPtr; } static void InitVarHashTable84(TclVarHashTable *tablePtr, Namespace *nsPtr) { - /* fprintf(stderr,"InitVarHashTable84\n"); */ - Tcl_InitHashTable((tablePtr), TCL_STRING_KEYS); + /* fprintf(stderr,"InitVarHashTable84\n"); */ + Tcl_InitHashTable((tablePtr), TCL_STRING_KEYS); } static void TclCleanupVar84(Var * varPtr, Var *arrayPtr) { - if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) - && (varPtr->tracePtr == NULL) - && (varPtr->flags & VAR_IN_HASHTABLE)) { - if (varPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(varPtr->hPtr); - } - ckfree((char *) varPtr); + if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) + && (varPtr->tracePtr == NULL) + && (varPtr->flags & VAR_IN_HASHTABLE)) { + if (varPtr->hPtr) { + Tcl_DeleteHashEntry(varPtr->hPtr); } - if (arrayPtr != NULL) { - if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) - && (arrayPtr->tracePtr == NULL) - && (arrayPtr->flags & VAR_IN_HASHTABLE)) { - if (arrayPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(arrayPtr->hPtr); - } - ckfree((char *) arrayPtr); - } + ckfree((char *) varPtr); + } + if (arrayPtr) { + if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) + && (arrayPtr->tracePtr == NULL) + && (arrayPtr->flags & VAR_IN_HASHTABLE)) { + if (arrayPtr->hPtr) { + Tcl_DeleteHashEntry(arrayPtr->hPtr); + } + ckfree((char *) arrayPtr); } + } } static Var * LookupVarFromTable84(TclVarHashTable *varTable, CONST char *simpleName, XOTclObject *obj) { - Var *varPtr = NULL; - Tcl_HashEntry *entryPtr; + Var *varPtr = NULL; + Tcl_HashEntry *entryPtr; - if (varTable) { - entryPtr = Tcl_FindHashEntry(varTable, simpleName); - if (entryPtr) { - varPtr = VarHashGetValue(entryPtr); - } + if (varTable) { + entryPtr = XOTcl_FindHashEntry(varTable, simpleName); + if (entryPtr) { + varPtr = VarHashGetValue(entryPtr); } - return varPtr; + } + return varPtr; } #endif @@ -537,66 +544,66 @@ int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr) { - return TclLookupVar(interp, ObjStr(part1Ptr), part2, flags, msg, - createPart1, createPart2, arrayPtrPtr); + return TclLookupVar(interp, ObjStr(part1Ptr), part2, flags, msg, + createPart1, createPart2, arrayPtrPtr); } -#define ObjFindNamespace(interp, objPtr) \ - Tcl_FindNamespace((interp), ObjStr(objPtr), NULL, 0); +#define ObjFindNamespace(interp, objPtr) \ + Tcl_FindNamespace((interp), ObjStr(objPtr), NULL, 0); #else /* * definitions for tcl 8.5 */ -#define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) +#define VarHashGetValue(hPtr) \ + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) #define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) + (((VarInHash *)(varPtr))->entry.key.objPtr) #define VarHashTable(varTable) \ - &(varTable)->table + &(varTable)->table #define XOTclObjLookupVar TclObjLookupVar #define varHashTableSize sizeof(TclVarHashTable) #define valueOfVar(type, varPtr, field) (type *)(varPtr)->value.field XOTCLINLINE static Tcl_Namespace * ObjFindNamespace(Tcl_Interp *interp, Tcl_Obj *objPtr) { - Tcl_Namespace *nsPtr; + Tcl_Namespace *nsPtr; - if (TclGetNamespaceFromObj(interp, objPtr, &nsPtr) == TCL_OK) { - return nsPtr; - } else { - return NULL; - } + if (TclGetNamespaceFromObj(interp, objPtr, &nsPtr) == TCL_OK) { + return nsPtr; + } else { + return NULL; + } } #endif #if !defined(PRE85) || FORWARD_COMPATIBLE static XOTCLINLINE Var * VarHashCreateVar85(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { - Var *varPtr = NULL; - Tcl_HashEntry *hPtr; - hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, - (char *) key, newPtr); - if (hPtr) { - varPtr = VarHashGetValue(hPtr); - } - return varPtr; + Var *varPtr = NULL; + Tcl_HashEntry *hPtr; + hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, + (char *) key, newPtr); + if (hPtr) { + varPtr = VarHashGetValue(hPtr); + } + return varPtr; } static XOTCLINLINE Var * LookupVarFromTable85(TclVarHashTable *tablePtr, CONST char *simpleName, XOTclObject *obj) { - Var *varPtr = NULL; - if (tablePtr) { - Tcl_Obj *keyPtr = Tcl_NewStringObj(simpleName, -1); - Tcl_IncrRefCount(keyPtr); - varPtr = VarHashCreateVar85(tablePtr, keyPtr, NULL); - Tcl_DecrRefCount(keyPtr); - } - return varPtr; + Var *varPtr = NULL; + if (tablePtr) { + Tcl_Obj *keyPtr = Tcl_NewStringObj(simpleName, -1); + Tcl_IncrRefCount(keyPtr); + varPtr = VarHashCreateVar85(tablePtr, keyPtr, NULL); + Tcl_DecrRefCount(keyPtr); + } + return varPtr; } #endif @@ -609,52 +616,52 @@ */ static int callMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *method, - int objc, Tcl_Obj *CONST objv[], int flags) { - XOTclObject *obj = (XOTclObject*) clientData; - int result; - ALLOC_ON_STACK(Tcl_Obj *, objc, tov); - /*fprintf(stderr, "%%%% callmethod called with method %p\n", method),*/ + int objc, Tcl_Obj *CONST objv[], int flags) { + XOTclObject *obj = (XOTclObject*) clientData; + int result; + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); + /*fprintf(stderr, "%%%% callmethod called with method %p\n", method),*/ - tov[0] = obj->cmdName; - tov[1] = method; + tov[0] = obj->cmdName; + tov[1] = method; - if (objc>2) - memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc-2)); + if (objc>2) + memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc-2)); - /*fprintf(stderr, "%%%% callMethod cmdname=%s, method=%s, objc=%d\n", - ObjStr(tov[0]), ObjStr(tov[1]), objc); - {int i; fprintf(stderr, "\t CALL: %s ", ObjStr(method));for(i=0; i1); - tov[0] = obj->cmdName; - tov[1] = method; - if (objc>2) { - tov[2] = arg; - } - if (objc>3) - memcpy(tov+3, objv, sizeof(Tcl_Obj *)*(objc-3)); + assert(objc>1); + tov[0] = obj->cmdName; + tov[1] = method; + if (objc>2) { + tov[2] = arg; + } + if (objc>3) + memcpy(tov+3, objv, sizeof(Tcl_Obj *)*(objc-3)); - /*fprintf(stderr, "%%%% callMethodWithArg cmdname=%s, method=%s, objc=%d\n", - ObjStr(tov[0]), ObjStr(tov[1]), objc);*/ - result = DoDispatch(clientData, interp, objc, tov, flags); + /*fprintf(stderr, "%%%% callMethodWithArg cmdname=%s, method=%s, objc=%d\n", + ObjStr(tov[0]), ObjStr(tov[1]), objc);*/ + result = DoDispatch(clientData, interp, objc, tov, flags); - FREE_ON_STACK(tov); - return result; + FREE_ON_STACK(tov); + return result; } /* @@ -663,32 +670,32 @@ XOTCLINLINE static CONST84 char * GetSelfProc(Tcl_Interp *interp) { - /*return Tcl_GetCommandName(interp, RUNTIME_STATE(interp)->cs.top->cmdPtr);*/ - return Tcl_GetCommandName(interp, CallStackGetFrame(interp)->cmdPtr); + /*return Tcl_GetCommandName(interp, RUNTIME_STATE(interp)->cs.top->cmdPtr);*/ + return Tcl_GetCommandName(interp, CallStackGetFrame(interp)->cmdPtr); } XOTCLINLINE static XOTclClass* GetSelfClass(Tcl_Interp *interp) { - /*return RUNTIME_STATE(interp)->cs.top->cl;*/ - return CallStackGetFrame(interp)->cl; + /*return RUNTIME_STATE(interp)->cs.top->cl;*/ + return CallStackGetFrame(interp)->cl; } XOTCLINLINE static XOTclObject* GetSelfObj(Tcl_Interp *interp) { - return CallStackGetFrame(interp)->self; + return CallStackGetFrame(interp)->self; } /* extern callable GetSelfObj */ XOTcl_Object* XOTclGetSelfObj(Tcl_Interp *interp) { - return (XOTcl_Object*)GetSelfObj(interp); + return (XOTcl_Object*)GetSelfObj(interp); } XOTCLINLINE static Tcl_Command GetSelfProcCmdPtr(Tcl_Interp *interp) { - /*return RUNTIME_STATE(interp)->cs.top->cmdPtr;*/ - return CallStackGetFrame(interp)->cmdPtr; + /*return RUNTIME_STATE(interp)->cs.top->cmdPtr;*/ + return CallStackGetFrame(interp)->cmdPtr; } /* @@ -697,44 +704,44 @@ */ extern void XOTclDeprecatedMsg(char *oldCmd, char *newCmd) { - fprintf(stderr, "**\n**\n** The command/method <%s> is deprecated.\n", oldCmd); - if (newCmd) - fprintf(stderr, "** Use <%s> instead.\n", newCmd); - fprintf(stderr, "**\n"); + fprintf(stderr, "**\n**\n** The command/method <%s> is deprecated.\n", oldCmd); + if (newCmd) + fprintf(stderr, "** Use <%s> instead.\n", newCmd); + fprintf(stderr, "**\n"); } static int XOTcl_DeprecatedCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - char *new; - if (objc == 2) - new = 0; - else if (objc == 3) - new = ObjStr(objv[2]); - else - return XOTclObjErrArgCnt(interp, NULL, NULL, "deprecated oldcmd ?newcmd?"); - XOTclDeprecatedMsg(ObjStr(objv[1]), new); - return TCL_OK; + char *new; + if (objc == 2) + new = 0; + else if (objc == 3) + new = ObjStr(objv[2]); + else + return XOTclObjErrArgCnt(interp, NULL, NULL, "deprecated oldcmd ?newcmd?"); + XOTclDeprecatedMsg(ObjStr(objv[1]), new); + return TCL_OK; } #ifdef DISPATCH_TRACE static void printObjv(int objc, Tcl_Obj *CONST objv[]) { - int i, j; - fprintf(stderr, "(%d)", objc); - if (objc <= 3) j = objc; else j = 3; - for (i=0;i 3) fprintf(stderr," ..."); - fprintf(stderr," (objc=%d)", objc); + int i, j; + fprintf(stderr, "(%d)", objc); + if (objc <= 3) j = objc; else j = 3; + for (i=0;i 3) fprintf(stderr," ..."); + fprintf(stderr," (objc=%d)", objc); } static void printCall(Tcl_Interp *interp, char *string, int objc, Tcl_Obj *CONST objv[]) { - fprintf(stderr, " (%d) >%s: ", Tcl_Interp_numLevels(interp), string); - printObjv(objc, objv); - fprintf(stderr, "\n"); + fprintf(stderr, " (%d) >%s: ", Tcl_Interp_numLevels(interp), string); + printObjv(objc, objv); + fprintf(stderr, "\n"); } static void printExit(Tcl_Interp *interp, char *string, - int objc, Tcl_Obj *CONST objv[], int result) { - fprintf(stderr, " (%d) <%s: ", Tcl_Interp_numLevels(interp), string); - /*printObjv(objc, objv);*/ - fprintf(stderr, " result=%d '%s'\n", result, ObjStr(Tcl_GetObjResult(interp))); + int objc, Tcl_Obj *CONST objv[], int result) { + fprintf(stderr, " (%d) <%s: ", Tcl_Interp_numLevels(interp), string); + /*printObjv(objc, objv);*/ + fprintf(stderr, " result=%d '%s'\n", result, ObjStr(Tcl_GetObjResult(interp))); } #endif @@ -744,94 +751,94 @@ */ #if defined(XOTCLOBJ_TRACE) # define XOTclObjectRefCountIncr(obj) \ - obj->refCount++; \ - fprintf(stderr, "RefCountIncr %p count=%d %s\n", obj, obj->refCount, obj->cmdName?ObjStr(obj->cmdName):"no name"); \ - MEM_COUNT_ALLOC("XOTclObject RefCount", obj) -# define XOTclObjectRefCountDecr(obj) \ - obj->refCount--; \ - fprintf(stderr, "RefCountDecr %p count=%d\n", obj, obj->refCount); \ - MEM_COUNT_FREE("XOTclObject RefCount", obj) + obj->refCount++; \ + fprintf(stderr, "RefCountIncr %p count=%d %s\n", obj, obj->refCount, obj->cmdName?ObjStr(obj->cmdName):"no name"); \ + MEM_COUNT_ALLOC("XOTclObject RefCount", obj) +# define XOTclObjectRefCountDecr(obj) \ + obj->refCount--; \ + fprintf(stderr, "RefCountDecr %p count=%d\n", obj, obj->refCount); \ + MEM_COUNT_FREE("XOTclObject RefCount", obj) #else # define XOTclObjectRefCountIncr(obj) \ - obj->refCount++; \ - MEM_COUNT_ALLOC("XOTclObject RefCount", obj) + obj->refCount++; \ + MEM_COUNT_ALLOC("XOTclObject RefCount", obj) # define XOTclObjectRefCountDecr(obj) \ - obj->refCount--; \ - MEM_COUNT_FREE("XOTclObject RefCount", obj) + obj->refCount--; \ + MEM_COUNT_FREE("XOTclObject RefCount", obj) #endif #if defined(XOTCLOBJ_TRACE) void objTrace(char *string, XOTclObject *obj) { - if (obj) - fprintf(stderr,"--- %s tcl %p %s (%d %p) xotcl %p (%d) %s \n", string, - obj->cmdName, obj->cmdName->typePtr ? obj->cmdName->typePtr->name : "NULL", - obj->cmdName->refCount, obj->cmdName->internalRep.twoPtrValue.ptr1, - obj, obj->refCount, ObjStr(obj->cmdName)); - else - fprintf(stderr,"--- No object: %s\n", string); + if (obj) + fprintf(stderr,"--- %s tcl %p %s (%d %p) xotcl %p (%d) %s \n", string, + obj->cmdName, obj->cmdName->typePtr ? obj->cmdName->typePtr->name : "NULL", + obj->cmdName->refCount, obj->cmdName->internalRep.twoPtrValue.ptr1, + obj, obj->refCount, ObjStr(obj->cmdName)); + else + fprintf(stderr,"--- No object: %s\n", string); } #else # define objTrace(a, b) #endif /* search for tail of name */ -static char * -NSTail(char *string) { - register char *p = string + strlen(string); - while (p > string) { - if (*p == ':' && *(p-1) == ':') return p+1; - p--; - } - return string; +static CONST char * +NSTail(CONST char *string) { + register char *p = (char *)string+strlen(string); + while (p > string) { + if (*p == ':' && *(p-1) == ':') return p+1; + p--; + } + return string; } XOTCLINLINE static int isClassName(char *string) { - return (strncmp((string), "::xotcl::classes", 16) == 0); + return (strncmp((string), "::xotcl::classes", 16) == 0); } /* removes preceding ::xotcl::classes from a string */ XOTCLINLINE static char * NSCutXOTclClasses(char *string) { - assert(strncmp((string), "::xotcl::classes", 16) == 0); - return string+16; + assert(strncmp((string), "::xotcl::classes", 16) == 0); + return string+16; } XOTCLINLINE static char * NSCmdFullName(Tcl_Command cmd) { - Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); - return nsPtr ? nsPtr->fullName : ""; + Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); + return nsPtr ? nsPtr->fullName : ""; } static void XOTclCleanupObject(XOTclObject *obj) { - XOTclObjectRefCountDecr(obj); + XOTclObjectRefCountDecr(obj); #if REFCOUNT_TRACE - fprintf(stderr,"###CLNO %p refcount = %d\n", obj, obj->refCount); + fprintf(stderr,"###CLNO %p refcount = %d\n", obj, obj->refCount); #endif - if (obj->refCount <= 0) { - assert(obj->refCount == 0); - assert(obj->flags & XOTCL_DESTROYED); + if (obj->refCount <= 0) { + assert(obj->refCount == 0); + assert(obj->flags & XOTCL_DESTROYED); #if REFCOUNT_TRACE - fprintf(stderr,"###CLNO %p flags %x rc %d destr %d dc %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0 - ); + fprintf(stderr,"###CLNO %p flags %x rc %d destr %d dc %d\n", + obj, obj->flags, + (obj->flags & XOTCL_REFCOUNTED) != 0, + (obj->flags & XOTCL_DESTROYED) != 0, + (obj->flags & XOTCL_DESTROY_CALLED) != 0 + ); #endif - MEM_COUNT_FREE("XOTclObject/XOTclClass", obj); + MEM_COUNT_FREE("XOTclObject/XOTclClass", obj); #if defined(XOTCLOBJ_TRACE) || defined(REFCOUNT_TRACE) - fprintf(stderr, "CKFREE Object %p refcount=%d\n", obj, obj->refCount); + fprintf(stderr, "CKFREE Object %p refcount=%d\n", obj, obj->refCount); #endif #if !defined(NDEBUG) - memset(obj, 0, sizeof(XOTclObject)); + memset(obj, 0, sizeof(XOTclObject)); #endif - /* fprintf(stderr,"CKFREE obj %p\n", obj);*/ - ckfree((char *) obj); - } + /* fprintf(stderr,"CKFREE obj %p\n", obj);*/ + ckfree((char *) obj); + } } @@ -841,492 +848,517 @@ */ static void RegisterObjTypes() { - Tcl_RegisterObjType(&XOTclObjectType); + Tcl_RegisterObjType(&XOTclObjectType); } static void FreeXOTclObjectInternalRep(register Tcl_Obj *objPtr) { - XOTclObject *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; + XOTclObject *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; - /* fprintf(stderr,"FIP objPtr %p obj %p obj->cmd %p '%s', bytes='%s'\n", - objPtr, obj, obj->cmdName, ObjStr(obj->cmdName), objPtr->bytes); - */ + /* fprintf(stderr,"FIP objPtr %p obj %p obj->cmd %p '%s', bytes='%s'\n", + objPtr, obj, obj->cmdName, ObjStr(obj->cmdName), objPtr->bytes); + */ #if defined(XOTCLOBJ_TRACE) - if (obj) - fprintf(stderr,"FIP --- tcl %p (%d)\n", objPtr, objPtr->refCount); + if (obj) + fprintf(stderr,"FIP --- tcl %p (%d)\n", objPtr, objPtr->refCount); #endif #if !defined(REFCOUNTED) - if (obj != NULL) { - XOTclCleanupObject(obj); - } + if (obj) { + XOTclCleanupObject(obj); + } #else - if (obj != NULL) { + if (obj) { #if REFCOUNT_TRACE - fprintf(stderr, "FIP in %p\n", obj->teardown); - fprintf(stderr, "FIP call is destroy %d\n", RUNTIME_STATE(obj->teardown)->callIsDestroy); - fprintf(stderr,"FIP %p flags %x rc %d destr %d dc %d refcount = %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0, - obj->refCount - ); + fprintf(stderr, "FIP in %p\n", obj->teardown); + fprintf(stderr, "FIP call is destroy %d\n", RUNTIME_STATE(obj->teardown)->callIsDestroy); + fprintf(stderr,"FIP %p flags %x rc %d destr %d dc %d refcount = %d\n", + obj, obj->flags, + (obj->flags & XOTCL_REFCOUNTED) != 0, + (obj->flags & XOTCL_DESTROYED) != 0, + (obj->flags & XOTCL_DESTROY_CALLED) != 0, + obj->refCount + ); #endif - if (obj->flags & XOTCL_REFCOUNTED && - !(obj->flags & XOTCL_DESTROY_CALLED)) { - Tcl_Interp *interp = obj->teardown; - INCR_REF_COUNT(obj->cmdName); - callDestroyMethod((ClientData)obj, interp, obj, 0); - /* the call to cleanup is the counterpart of the - INCR_REF_COUNT(obj->cmdName) above */ - XOTclCleanupObject(obj); - } else { - fprintf(stderr, "BEFORE CLEANUPOBJ %x\n", (obj->flags & XOTCL_REFCOUNTED)); - XOTclCleanupObject(obj); - fprintf(stderr, "AFTER CLEANUPOBJ\n"); - } + if (obj->flags & XOTCL_REFCOUNTED && + !(obj->flags & XOTCL_DESTROY_CALLED)) { + Tcl_Interp *interp = obj->teardown; + INCR_REF_COUNT(obj->cmdName); + callDestroyMethod((ClientData)obj, interp, obj, 0); + /* the call to cleanup is the counterpart of the + INCR_REF_COUNT(obj->cmdName) above */ + XOTclCleanupObject(obj); + } else { + fprintf(stderr, "BEFORE CLEANUPOBJ %x\n", (obj->flags & XOTCL_REFCOUNTED)); + XOTclCleanupObject(obj); + fprintf(stderr, "AFTER CLEANUPOBJ\n"); } + } #endif - objPtr->internalRep.otherValuePtr = NULL; - objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; + objPtr->typePtr = NULL; } static void DupXOTclObjectInternalRep(Tcl_Obj *src, Tcl_Obj *cpy) { - XOTclObject *obj = (XOTclObject*)src->internalRep.otherValuePtr; + XOTclObject *obj = (XOTclObject*)src->internalRep.otherValuePtr; #if defined(XOTCLOBJ_TRACE) - if (obj) fprintf(stderr,"DIP --- tcl %p (%d)\n", src, src->refCount); + if (obj) fprintf(stderr,"DIP --- tcl %p (%d)\n", src, src->refCount); #endif - XOTclObjectRefCountIncr(obj); - cpy->internalRep.otherValuePtr = src->internalRep.otherValuePtr; - cpy->typePtr = src->typePtr; + XOTclObjectRefCountIncr(obj); + cpy->internalRep.otherValuePtr = src->internalRep.otherValuePtr; + cpy->typePtr = src->typePtr; } static int SetXOTclObjectFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr) { - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string = ObjStr(objPtr); - XOTclObject *obj; - Tcl_Obj *tmpName = NULL; - int result = TCL_OK; + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string = ObjStr(objPtr); + XOTclObject *obj; + Tcl_Obj *tmpName = NULL; + int result = TCL_OK; + /*fprintf(stderr,"SetXOTclObjectFromAny %p '%s' %p\n", + objPtr, string, objPtr->typePtr);*/ #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"SetXOTclObjectFromAny %p '%s' %p\n", - objPtr, string, objPtr->typePtr); - if (oldTypePtr) - fprintf(stderr," convert %s to XOTclObject\n", oldTypePtr->name); + fprintf(stderr,"SetXOTclObjectFromAny %p '%s' %p\n", + objPtr, string, objPtr->typePtr); + if (oldTypePtr) + fprintf(stderr," convert %s to XOTclObject\n", oldTypePtr->name); #endif - if (!isAbsolutePath(string)) { - char *nsString; - tmpName = NameInNamespaceObj(interp, string, callingNameSpace(interp)); + if (!isAbsolutePath(string)) { + char *nsString; + tmpName = NameInNamespaceObj(interp, string, callingNameSpace(interp)); - nsString = ObjStr(tmpName); - INCR_REF_COUNT(tmpName); - obj = XOTclpGetObject(interp, nsString); - DECR_REF_COUNT(tmpName); - if (!obj) { - /* retry with global namespace */ - tmpName = Tcl_NewStringObj("::", 2); - Tcl_AppendToObj(tmpName, string,-1); - INCR_REF_COUNT(tmpName); - obj = XOTclpGetObject(interp, ObjStr(tmpName)); - DECR_REF_COUNT(tmpName); - } - } else { - obj = XOTclpGetObject(interp, string); + nsString = ObjStr(tmpName); + INCR_REF_COUNT(tmpName); + obj = XOTclpGetObject(interp, nsString); + DECR_REF_COUNT(tmpName); + if (!obj) { + /* retry with global namespace */ + tmpName = Tcl_NewStringObj("::", 2); + Tcl_AppendToObj(tmpName, string,-1); + INCR_REF_COUNT(tmpName); + obj = XOTclpGetObject(interp, ObjStr(tmpName)); + DECR_REF_COUNT(tmpName); } + } else { + obj = XOTclpGetObject(interp, string); + } + /*fprintf(stderr,"getObject '%s' returned %p\n",string,obj);*/ + #if 0 - obj = XOTclpGetObject(interp, string); + obj = XOTclpGetObject(interp, string); #endif - if (obj) { - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + if (obj) { + if (oldTypePtr && oldTypePtr->freeIntRepProc) { #ifdef XOTCLOBJ_TRACE - fprintf(stderr," freeing type=%p, type=%s\n", - objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : ""); + fprintf(stderr," freeing type=%p, type=%s\n", + objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : ""); #endif - oldTypePtr->freeIntRepProc(objPtr); - } - XOTclObjectRefCountIncr(obj); + oldTypePtr->freeIntRepProc(objPtr); + } + XOTclObjectRefCountIncr(obj); #if defined(XOTCLOBJ_TRACE) - fprintf(stderr, "SetXOTclObjectFromAny tcl %p (%d) xotcl %p (%d)\n", - objPtr, objPtr->refCount, obj, obj->refCount); + fprintf(stderr, "SetXOTclObjectFromAny tcl %p (%d) xotcl %p (%d)\n", + objPtr, objPtr->refCount, obj, obj->refCount); #endif - objPtr->internalRep.otherValuePtr = (XOTclObject*) obj; - objPtr->typePtr = &XOTclObjectType; - } else - result = TCL_ERROR; + objPtr->internalRep.otherValuePtr = (XOTclObject*) obj; + objPtr->typePtr = &XOTclObjectType; + } else + result = TCL_ERROR; - return result; + return result; } static void UpdateStringOfXOTclObject(register Tcl_Obj *objPtr) { - XOTclObject *obj = (XOTclObject *)objPtr->internalRep.otherValuePtr; - char *nsFullName = NULL; + XOTclObject *obj = (XOTclObject *)objPtr->internalRep.otherValuePtr; + char *nsFullName = NULL; #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"UpdateStringOfXOTclObject %p refCount %d\n", - objPtr, objPtr->refCount); - fprintf(stderr," teardown %p id %p destroyCalled %d\n", - obj->teardown, obj->id, (obj->flags & XOTCL_DESTROY_CALLED)); + fprintf(stderr,"UpdateStringOfXOTclObject %p refCount %d\n", + objPtr, objPtr->refCount); + fprintf(stderr," teardown %p id %p destroyCalled %d\n", + obj->teardown, obj->id, (obj->flags & XOTCL_DESTROY_CALLED)); #endif - /* Here we use GetCommandName, because it doesnt need - Interp*, but Tcl_GetCommandFullName(interp, obj->id, ObjName); does*/ - if (obj && !(obj->flags & XOTCL_DESTROY_CALLED)) { - Tcl_DString ds, *dsp = &ds; - unsigned l; - DSTRING_INIT(dsp); - nsFullName = NSCmdFullName(obj->id); - if (!(*nsFullName==':' && *(nsFullName+1)==':' && - *(nsFullName+2)=='\0')) { - Tcl_DStringAppend(dsp, nsFullName, -1); - } - Tcl_DStringAppend(dsp, "::", 2); - Tcl_DStringAppend(dsp, Tcl_GetCommandName(NULL, obj->id), -1); - - l = (unsigned) Tcl_DStringLength(dsp)+1; - objPtr->bytes = (char *) ckalloc(l); - memcpy(objPtr->bytes, Tcl_DStringValue(dsp), l); - objPtr->length = Tcl_DStringLength(dsp); - DSTRING_FREE(dsp); - } else if (obj) { - fprintf(stderr,"try to read string of deleted command\n"); - FreeXOTclObjectInternalRep(objPtr); - objPtr->bytes = NULL; - objPtr->length = 0; - } else { - objPtr->bytes = NULL; - objPtr->length = 0; + /* Here we use GetCommandName, because it doesnt need + Interp*, but Tcl_GetCommandFullName(interp, obj->id, ObjName); does*/ + if (obj && !(obj->flags & XOTCL_DESTROY_CALLED)) { + Tcl_DString ds, *dsp = &ds; + unsigned l; + DSTRING_INIT(dsp); + nsFullName = NSCmdFullName(obj->id); + if (!(*nsFullName==':' && *(nsFullName+1)==':' && + *(nsFullName+2)=='\0')) { + Tcl_DStringAppend(dsp, nsFullName, -1); } - /* - fprintf(stderr, "+++UpdateStringOfXOTclObject bytes='%s', length=%d\n", - objPtr->bytes, objPtr->length); - */ + Tcl_DStringAppend(dsp, "::", 2); + Tcl_DStringAppend(dsp, Tcl_GetCommandName(NULL, obj->id), -1); + + l = (unsigned) Tcl_DStringLength(dsp)+1; + objPtr->bytes = (char *) ckalloc(l); + memcpy(objPtr->bytes, Tcl_DStringValue(dsp), l); + objPtr->length = Tcl_DStringLength(dsp); + DSTRING_FREE(dsp); + } else if (obj) { + /*fprintf(stderr,"try to read string of deleted command\n");*/ + FreeXOTclObjectInternalRep(objPtr); + objPtr->bytes = NULL; + objPtr->length = 0; + } else { + objPtr->bytes = NULL; + objPtr->length = 0; + } + /* + fprintf(stderr, "+++UpdateStringOfXOTclObject bytes='%s', length=%d\n", + objPtr->bytes, objPtr->length); + */ } #ifdef NOTUSED static Tcl_Obj * NewXOTclObjectObj(register XOTclObject *obj) { - register Tcl_Obj *objPtr = 0; - XOTclNewObj(objPtr); - objPtr->bytes = NULL; - objPtr->internalRep.otherValuePtr = obj; - objPtr->typePtr = &XOTclObjectType; + register Tcl_Obj *objPtr; + + XOTclNewObj(objPtr); + objPtr->bytes = NULL; + objPtr->internalRep.otherValuePtr = obj; + objPtr->typePtr = &XOTclObjectType; #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"NewXOTclObjectObj %p\n", objPtr); + fprintf(stderr,"NewXOTclObjectObj %p\n", objPtr); #endif - return objPtr; + return objPtr; } #endif static Tcl_Obj * NewXOTclObjectObjName(register XOTclObject *obj, char *name, unsigned l) { - register Tcl_Obj *objPtr = 0; + register Tcl_Obj *objPtr; - XOTclNewObj(objPtr); + XOTclNewObj(objPtr); + objPtr->length = l; + objPtr->bytes = ckalloc(l+1); + memcpy(objPtr->bytes, name, l); + *(objPtr->bytes+l) = 0; + objPtr->internalRep.otherValuePtr = obj; + objPtr->typePtr = &XOTclObjectType; - objPtr->length = l; - objPtr->bytes = ckalloc(l+1); - memcpy(objPtr->bytes, name, l); - *(objPtr->bytes+l) = 0; - objPtr->internalRep.otherValuePtr = obj; - objPtr->typePtr = &XOTclObjectType; - #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"NewXOTclObjectObjName tcl %p (%d) xotcl %p (%d) %s\n", - objPtr, objPtr->refCount, obj, obj->refCount, objPtr->bytes); + fprintf(stderr,"NewXOTclObjectObjName tcl %p (%d) xotcl %p (%d) %s\n", + objPtr, objPtr->refCount, obj, obj->refCount, objPtr->bytes); #endif - XOTclObjectRefCountIncr(obj); + XOTclObjectRefCountIncr(obj); - return objPtr; + return objPtr; } #ifdef KEEP_TCL_CMD_TYPE XOTCLINLINE static Tcl_ObjType * GetCmdNameType(Tcl_ObjType *cmdType) { - static Tcl_ObjType *tclCmdNameType = NULL; + static Tcl_ObjType *tclCmdNameType = NULL; - if (tclCmdNameType == NULL) { + if (tclCmdNameType == NULL) { # if defined(PRE82) - if (cmdType - && cmdType != &XOTclObjectType - && !strcmp(cmdType->name,"cmdName")) { - tclCmdNameType = cmdType; - } + if (cmdType + && cmdType != &XOTclObjectType + && !strcmp(cmdType->name,"cmdName")) { + tclCmdNameType = cmdType; + } # else - static XOTclMutex initMutex = 0; - XOTclMutexLock(&initMutex); - if (tclCmdNameType == NULL) - tclCmdNameType = Tcl_GetObjType("cmdName"); - XOTclMutexUnlock(&initMutex); + static XOTclMutex initMutex = 0; + XOTclMutexLock(&initMutex); + if (tclCmdNameType == NULL) + tclCmdNameType = Tcl_GetObjType("cmdName"); + XOTclMutexUnlock(&initMutex); # endif - } - return tclCmdNameType; + } + return tclCmdNameType; } #endif #if NOTUSED static int XOTclObjGetObject(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj) { - int result; - register Tcl_ObjType *cmdType = objPtr->typePtr; - XOTclObject *o; + int result; + register Tcl_ObjType *cmdType = objPtr->typePtr; + XOTclObject *o; - if (cmdType == &XOTclObjectType) { - o = (XOTclObject*) objPtr->internalRep.otherValuePtr; - if (!(o->flags & XOTCL_DESTROYED)) { - *obj = o; - return TCL_OK; - } + if (cmdType == &XOTclObjectType) { + o = (XOTclObject*) objPtr->internalRep.otherValuePtr; + if (!(o->flags & XOTCL_DESTROYED)) { + *obj = o; + return TCL_OK; } + } - if (cmdType == GetCmdNameType(cmdType)) { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); - /*fprintf(stderr,"obj is of type tclCmd\n");*/ - if (cmd) { - o = XOTclGetObjectFromCmdPtr(cmd); - if (o) { - *obj = o; - return TCL_OK; - } - } - } - - o = XOTclpGetObject(interp, ObjStr(objPtr)); - if (o) { + if (cmdType == GetCmdNameType(cmdType)) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); + /*fprintf(stderr,"obj is of type tclCmd\n");*/ + if (cmd) { + o = XOTclGetObjectFromCmdPtr(cmd); + if (o) { *obj = o; return TCL_OK; + } } - return TCL_ERROR; + } + + o = XOTclpGetObject(interp, ObjStr(objPtr)); + if (o) { + *obj = o; + return TCL_OK; + } + return TCL_ERROR; } #endif static int XOTclObjConvertObject(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **obj) { - int result; - register Tcl_ObjType *cmdType = objPtr->typePtr; - /* - * Only really share the "::x" Tcl_Objs but not "x" because we so not have - * references upon object kills and then will get dangling - * internalRep references to killed XOTclObjects - */ - if (cmdType == &XOTclObjectType) { - /*fprintf(stderr,"obj is of type XOTclObjectType\n");*/ - if (obj) { - XOTclObject *o = (XOTclObject*) objPtr->internalRep.otherValuePtr; - int refetch = 0; - if (o->flags & XOTCL_DESTROYED) { - /* fprintf(stderr,"????? calling free by hand\n"); */ - FreeXOTclObjectInternalRep(objPtr); - refetch = 1; - result = SetXOTclObjectFromAny(interp, objPtr); - if (result == TCL_OK) { - o = (XOTclObject*) objPtr->internalRep.otherValuePtr; - assert(o && !(o->flags & XOTCL_DESTROYED)); - } - } else { - result = TCL_OK; - } + int result; + register Tcl_ObjType *cmdType = objPtr->typePtr; + /* + * Only really share the "::x" Tcl_Objs but not "x" because we so not have + * references upon object kills and then will get dangling + * internalRep references to killed XOTclObjects + */ + if (cmdType == &XOTclObjectType) { + /* fprintf(stderr,"obj is of type XOTclObjectType\n");*/ + if (obj) { + XOTclObject *o = (XOTclObject*) objPtr->internalRep.otherValuePtr; + int refetch = 0; + if (o->flags & XOTCL_DESTROYED) { + /* fprintf(stderr,"????? calling free by hand\n"); */ + FreeXOTclObjectInternalRep(objPtr); + refetch = 1; + result = SetXOTclObjectFromAny(interp, objPtr); + if (result == TCL_OK) { + o = (XOTclObject*) objPtr->internalRep.otherValuePtr; + assert(o && !(o->flags & XOTCL_DESTROYED)); + } + } else { + result = TCL_OK; + } - *obj = o; + *obj = o; #ifdef XOTCLOBJ_TRACE - if (result == TCL_OK) - fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) xotcl %p (%d) r=%d %s\n", - objPtr, objPtr->refCount, o, o->refCount, refetch, objPtr->bytes); - else - fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) **** rc=%d r=%d %s\n", - objPtr, objPtr->refCount, result, refetch, objPtr->bytes); + if (result == TCL_OK) + fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) xotcl %p (%d) r=%d %s\n", + objPtr, objPtr->refCount, o, o->refCount, refetch, objPtr->bytes); + else + fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) **** rc=%d r=%d %s\n", + objPtr, objPtr->refCount, result, refetch, objPtr->bytes); #endif - } else { - result = TCL_OK; - } + } else { + result = TCL_OK; + } #ifdef KEEP_TCL_CMD_TYPE - } else if (cmdType == GetCmdNameType(cmdType)) { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); - /*fprintf(stderr,"obj %s is of type tclCmd, cmd=%p\n", ObjStr(objPtr), cmd);*/ - if (cmd) { - XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); + } else if (cmdType == GetCmdNameType(cmdType)) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); + /*fprintf(stderr,"obj %s is of type tclCmd, cmd=%p\n", ObjStr(objPtr), cmd);*/ + if (cmd) { + XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); - /*fprintf(stderr,"Got Object from '%s' %p\n", objPtr->bytes, o); - fprintf(stderr,"cmd->objProc %p == %p, proc=%p\n", - Tcl_Command_objProc(cmd), XOTclObjDispatch, - Tcl_Command_proc(cmd) );*/ + /*fprintf(stderr,"Got Object from '%s' %p\n", objPtr->bytes, o); + fprintf(stderr,"cmd->objProc %p == %p, proc=%p\n", + Tcl_Command_objProc(cmd), XOTclObjDispatch, + Tcl_Command_proc(cmd) );*/ - if (o) { - if (obj) *obj = o; - result = TCL_OK; - } else { - goto convert_to_xotcl_object; - } - } else goto convert_to_xotcl_object; + if (o) { + if (obj) *obj = o; + result = TCL_OK; + } else { + goto convert_to_xotcl_object; + } + } else goto convert_to_xotcl_object; #endif - } else { + } else { #ifdef KEEP_TCL_CMD_TYPE - convert_to_xotcl_object: + convert_to_xotcl_object: #endif - result = SetXOTclObjectFromAny(interp, objPtr); - if (result == TCL_OK && obj) { - *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; - } + result = SetXOTclObjectFromAny(interp, objPtr); + if (result == TCL_OK && obj) { + *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; } - return result; + } + return result; } #ifndef NAMESPACEINSTPROCS static Tcl_Namespace * GetCallerVarFrame(Tcl_Interp *interp, Tcl_CallFrame *varFramePtr) { - Tcl_Namespace *nsPtr = NULL; - if (varFramePtr) { - Tcl_CallFrame *callerVarPtr = Tcl_CallFrame_callerVarPtr(varFramePtr); - if (callerVarPtr) { - nsPtr = (Tcl_Namespace *)callerVarPtr->nsPtr; - } + Tcl_Namespace *nsPtr = NULL; + if (varFramePtr) { + Tcl_CallFrame *callerVarPtr = Tcl_CallFrame_callerVarPtr(varFramePtr); + if (callerVarPtr) { + nsPtr = (Tcl_Namespace *)callerVarPtr->nsPtr; } - if (nsPtr == NULL) - nsPtr = Tcl_Interp_globalNsPtr(interp); + } + if (nsPtr == NULL) + nsPtr = Tcl_Interp_globalNsPtr(interp); - return nsPtr; + return nsPtr; } #endif static Tcl_Obj * NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *ns) { - Tcl_Obj *objName; - int len; - char *p; + Tcl_Obj *objName; + int len; + char *p; - /*fprintf(stderr,"NameInNamespaceObj %s (%p) ", name, ns);*/ - if (!ns) - ns = Tcl_GetCurrentNamespace(interp); - objName = Tcl_NewStringObj(ns->fullName,-1); - len = Tcl_GetCharLength(objName); - p = ObjStr(objName); - if (len == 2 && p[0] == ':' && p[1] == ':') { - } else { - Tcl_AppendToObj(objName,"::", 2); - } - Tcl_AppendToObj(objName, name, -1); + /*fprintf(stderr,"NameInNamespaceObj %s (%p) ", name, ns);*/ + if (!ns) + ns = Tcl_GetCurrentNamespace(interp); + objName = Tcl_NewStringObj(ns->fullName,-1); + len = Tcl_GetCharLength(objName); + p = ObjStr(objName); + if (len == 2 && p[0] == ':' && p[1] == ':') { + } else { + Tcl_AppendToObj(objName,"::", 2); + } + Tcl_AppendToObj(objName, name, -1); - /*fprintf(stderr,"returns %s\n", ObjStr(objName));*/ - return objName; + /*fprintf(stderr,"returns %s\n", ObjStr(objName));*/ + return objName; } static int GetXOTclClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclClass **cl, XOTclClass *base) { - XOTclObject *obj; - XOTclClass *cls = NULL; - int result = TCL_OK; - char *objName = ObjStr(objPtr); + XOTclObject *obj; + XOTclClass *cls = NULL; + int result = TCL_OK; + char *objName = ObjStr(objPtr); + Tcl_Command cmd ; - /*fprintf(stderr, "GetXOTclClassFromObj %s base %p\n", objName, base);*/ + /*fprintf(stderr, "GetXOTclClassFromObj %s base %p\n", objName, base);*/ - if (base) { - /* we refer to an existing object; use command resolver */ - if (!isAbsolutePath(objName)) { - Tcl_Command cmd = NSFindCommand(interp, objName, callingNameSpace(interp)); + /* todo: is this better than the lookup below? + maybe, we forget our XOTclObjConvertObject, and just convert to + a tcl command with the "right clientData" + */ + cmd = Tcl_GetCommandFromObj(interp, objPtr); + if (cmd) { + /* we refer to an existing object; use command resolver */ + /*if (isAbsolutePath(objName)) { + Tcl_Command cmd = NSFindCommand(interp, objName, callingNameSpace(interp));*/ - /*fprintf(stderr, "GetXOTclClassFromObj %s cmd = %p cl=%p base=%p\n", - objName, cmd, cmd ? XOTclGetClassFromCmdPtr(cmd) : NULL, base);*/ - if (cmd) { - cls = XOTclGetClassFromCmdPtr(cmd); - if (cl) *cl = cls; - } - } + /*fprintf(stderr, "GetXOTclClassFromObj %s cmd = %p cl=%p base=%p\n", + objName, cmd, cmd ? XOTclGetClassFromCmdPtr(cmd) : NULL, base);*/ + if (cmd) { + cls = XOTclGetClassFromCmdPtr(cmd); + if (cl) *cl = cls; } + } - if (!cls) { - result = XOTclObjConvertObject(interp, objPtr, &obj); - if (result == TCL_OK) { - cls = XOTclObjectToClass(obj); - if (cls) { - if (cl) *cl = cls; - } else { - /* we have an object, but no class */ - result = TCL_ERROR; - } - } + if (!cls) { + result = XOTclObjConvertObject(interp, objPtr, &obj); + + if (result == TCL_OK) { + cls = XOTclObjectToClass(obj); + if (cls) { + if (cl) *cl = cls; + } else { + /*fprintf(stderr, "GetXOTclClassFromObj: we have an object, but no class \n");*/ + /* we have an object, but no class */ + result = TCL_ERROR; + } } + } + /*fprintf(stderr,"try unknown\n");*/ + if (!cls && base) { + Tcl_Obj *ov[3]; + ov[0] = base->object.cmdName; + ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; + if (isAbsolutePath(objName)) { + ov[2] = objPtr; + } else { + ov[2] = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); + } + INCR_REF_COUNT(ov[2]); + /*fprintf(stderr,"+++ calling %s __unknown for %s, objPtr=%s\n", + ObjStr(ov[0]), ObjStr(ov[2]), ObjStr(objPtr)); */ - if (!cls && base) { - Tcl_Obj *ov[3]; - ov[0] = base->object.cmdName; - ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; - if (isAbsolutePath(objName)) { - ov[2] = objPtr; - } else { - ov[2] = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); - } - INCR_REF_COUNT(ov[2]); - /*fprintf(stderr,"+++ calling %s __unknown for %s, objPtr=%s\n", - ObjStr(ov[0]), ObjStr(ov[2]), ObjStr(objPtr)); */ - - result = Tcl_EvalObjv(interp, 3, ov, 0); - if (result == TCL_OK) { - result = GetXOTclClassFromObj(interp, objPtr, cl, 0); - } - DECR_REF_COUNT(ov[2]); + result = Tcl_EvalObjv(interp, 3, ov, 0); + if (result == TCL_OK) { + result = GetXOTclClassFromObj(interp, objPtr, cl, 0); } + DECR_REF_COUNT(ov[2]); + } - /*fprintf(stderr, "GetXOTclClassFromObj %s returns %d cls = %p *cl = %p\n", - objName, result, cls, cl?*cl:NULL);*/ - return result; + /*fprintf(stderr, "GetXOTclClassFromObj %s returns %d cls = %p *cl = %p\n", + objName, result, cls, cl?*cl:NULL);*/ + return result; } extern void XOTclClassListFree(XOTclClasses *sl) { - XOTclClasses *n; - for (; sl; sl = n) { - n = sl->nextPtr; - FREE(XOTclClasses, sl); - } + XOTclClasses *n; + for (; sl; sl = n) { + n = sl->nextPtr; + FREE(XOTclClasses, sl); + } } +/* reverse class list, caller is responsible for freeing data */ +static XOTclClasses* +XOTclReverseClasses(XOTclClasses *sl) { + XOTclClasses *firstPtr = NULL; + for (; sl; sl = sl->nextPtr) { + XOTclClasses *element = NEW(XOTclClasses); + element->cl = sl->cl; + element->clientData = sl->clientData; + element->nextPtr = firstPtr; + firstPtr = element; + } + return firstPtr; +} + extern XOTclClasses** XOTclClassListAdd(XOTclClasses **cList, XOTclClass *cl, ClientData clientData) { - XOTclClasses *l = *cList, *element = NEW(XOTclClasses); - element->cl = cl; - element->clientData = clientData; - element->nextPtr = NULL; + XOTclClasses *l = *cList, *element = NEW(XOTclClasses); + element->cl = cl; + element->clientData = clientData; + element->nextPtr = NULL; - if (l) { - while (l->nextPtr) l = l->nextPtr; - l->nextPtr = element; - } else - *cList = element; - return &(element->nextPtr); + if (l) { + while (l->nextPtr) l = l->nextPtr; + l->nextPtr = element; + } else + *cList = element; + return &(element->nextPtr); } void XOTclObjectListFree(XOTclObjects *sl) { - XOTclObjects *n; - for (; sl; sl = n) { - n = sl->nextPtr; - FREE(XOTclObjects, sl); - } + XOTclObjects *n; + for (; sl; sl = n) { + n = sl->nextPtr; + FREE(XOTclObjects, sl); + } } XOTclObjects** XOTclObjectListAdd(XOTclObjects **cList, XOTclObject *obj) { - XOTclObjects *l = *cList, *element = NEW(XOTclObjects); - element->obj = obj; - element->nextPtr = NULL; + XOTclObjects *l = *cList, *element = NEW(XOTclObjects); + element->obj = obj; + element->nextPtr = NULL; - if (l) { - while (l->nextPtr) l = l->nextPtr; - l->nextPtr = element; - } else - *cList = element; - return &(element->nextPtr); + if (l) { + while (l->nextPtr) l = l->nextPtr; + l->nextPtr = element; + } else + *cList = element; + return &(element->nextPtr); } @@ -1342,108 +1374,107 @@ static int TopoSort(XOTclClass *cl, XOTclClass *base, XOTclClasses *(*next)(XOTclClass*)) { - /*XOTclClasses *sl = (*next)(cl);*/ - XOTclClasses *sl = next == Super ? cl->super : cl->sub; - XOTclClasses *pl; + /*XOTclClasses *sl = (*next)(cl);*/ + XOTclClasses *sl = next == Super ? cl->super : cl->sub; + XOTclClasses *pl; - /* - * careful to reset the color of unreported classes to - * white in case we unwind with error, and on final exit - * reset color of reported classes to white - */ + /* + * careful to reset the color of unreported classes to + * white in case we unwind with error, and on final exit + * reset color of reported classes to white + */ - cl->color = GRAY; - for (; sl != 0; sl = sl->nextPtr) { - XOTclClass *sc = sl->cl; - if (sc->color == GRAY) { cl->color = WHITE; return 0; } - if (sc->color == WHITE && !TopoSort(sc, base, next)) { - cl->color = WHITE; - if (cl == base) { - XOTclClasses *pc = cl->order; - while (pc != 0) { pc->cl->color = WHITE; pc = pc->nextPtr; } - } - return 0; - } + cl->color = GRAY; + for (; sl; sl = sl->nextPtr) { + XOTclClass *sc = sl->cl; + if (sc->color == GRAY) { cl->color = WHITE; return 0; } + if (sc->color == WHITE && !TopoSort(sc, base, next)) { + cl->color = WHITE; + if (cl == base) { + register XOTclClasses *pc; + for (pc = cl->order; pc; pc = pc->nextPtr) { pc->cl->color = WHITE; } + } + return 0; } - cl->color = BLACK; - pl = NEW(XOTclClasses); - pl->cl = cl; - pl->nextPtr = base->order; - base->order = pl; - if (cl == base) { - XOTclClasses *pc = cl->order; - while (pc != 0) { pc->cl->color = WHITE; pc = pc->nextPtr; } - } - return 1; + } + cl->color = BLACK; + pl = NEW(XOTclClasses); + pl->cl = cl; + pl->nextPtr = base->order; + base->order = pl; + if (cl == base) { + register XOTclClasses *pc; + for (pc = cl->order; pc; pc = pc->nextPtr) { pc->cl->color = WHITE; } + } + return 1; } static XOTclClasses* TopoOrder(XOTclClass *cl, XOTclClasses *(*next)(XOTclClass*)) { - if (TopoSort(cl, cl, next)) - return cl->order; - XOTclClassListFree(cl->order); - cl->order = 0; - return 0; + if (TopoSort(cl, cl, next)) + return cl->order; + XOTclClassListFree(cl->order); + return cl->order = NULL; } static XOTclClasses* ComputeOrder(XOTclClass *cl, XOTclClasses *order, XOTclClasses *(*direction)(XOTclClass*)) { - if (order) - return order; - return (cl->order = TopoOrder(cl, direction)); + if (order) + return order; + return cl->order = TopoOrder(cl, direction); } extern XOTclClasses* XOTclComputePrecedence(XOTclClass *cl) { - return ComputeOrder(cl, cl->order, Super); + return ComputeOrder(cl, cl->order, Super); } extern XOTclClasses* XOTclComputeDependents(XOTclClass *cl) { - return ComputeOrder(cl, cl->order, Sub); + return ComputeOrder(cl, cl->order, Sub); } static void -FlushPrecedences(XOTclClass *cl) { - XOTclClasses *pc; - XOTclClassListFree(cl->order); - cl->order = 0; - pc = ComputeOrder(cl, cl->order, Sub); +FlushPrecedencesOnSubclasses(XOTclClass *cl) { + XOTclClasses *pc; + XOTclClassListFree(cl->order); + cl->order = NULL; + pc = ComputeOrder(cl, cl->order, Sub); - /* - * ordering doesn't matter here - we're just using toposort - * to find all lower classes so we can flush their caches - */ + /* + * ordering doesn't matter here - we're just using toposort + * to find all lower classes so we can flush their caches + */ - if (pc) pc = pc->nextPtr; - for (; pc; pc = pc->nextPtr) { - XOTclClassListFree(pc->cl->order); - pc->cl->order = 0; - } - XOTclClassListFree(cl->order); - cl->order = 0; + if (pc) pc = pc->nextPtr; + for (; pc; pc = pc->nextPtr) { + XOTclClassListFree(pc->cl->order); + pc->cl->order = NULL; + } + XOTclClassListFree(cl->order); + cl->order = NULL; } static void AddInstance(XOTclObject *obj, XOTclClass *cl) { - obj->cl = cl; - if (cl != 0) { - int nw; - (void) Tcl_CreateHashEntry(&cl->instances, (char *)obj, &nw); - } + obj->cl = cl; + if (cl) { + int nw; + (void) Tcl_CreateHashEntry(&cl->instances, (char *)obj, &nw); + } } static int RemoveInstance(XOTclObject *obj, XOTclClass *cl) { - if (cl) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cl->instances, (char *)obj); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - return 1; - } + if (cl) { + Tcl_HashEntry *hPtr = XOTcl_FindHashEntry(&cl->instances, (char *)obj); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + return 1; } - return 0; + } + return 0; } /* @@ -1452,55 +1483,55 @@ static void AS(XOTclClass *cl, XOTclClass *s, XOTclClasses **sl) { - register XOTclClasses *l = *sl; - while (l && l->cl != s) l = l->nextPtr; - if (!l) { - XOTclClasses *sc = NEW(XOTclClasses); - sc->cl = s; - sc->nextPtr = *sl; - *sl = sc; - } + register XOTclClasses *l = *sl; + while (l && l->cl != s) l = l->nextPtr; + if (!l) { + XOTclClasses *sc = NEW(XOTclClasses); + sc->cl = s; + sc->nextPtr = *sl; + *sl = sc; + } } static void AddSuper(XOTclClass *cl, XOTclClass *super) { - if (cl && super) { - /* - * keep corresponding sub in step with super - */ - AS(cl, super, &cl->super); - AS(super, cl, &super->sub); - } + if (cl && super) { + /* + * keep corresponding sub in step with super + */ + AS(cl, super, &cl->super); + AS(super, cl, &super->sub); + } } static int RemoveSuper1(XOTclClass *cl, XOTclClass *s, XOTclClasses **sl) { - XOTclClasses *l = *sl; - if (!l) return 0; - if (l->cl == s) { - *sl = l->nextPtr; - FREE(XOTclClasses, l); - return 1; - } - while (l->nextPtr && l->nextPtr->cl != s) l = l->nextPtr; - if (l->nextPtr) { - XOTclClasses *n = l->nextPtr->nextPtr; - FREE(XOTclClasses, l->nextPtr); - l->nextPtr = n; - return 1; - } - return 0; + XOTclClasses *l = *sl; + if (!l) return 0; + if (l->cl == s) { + *sl = l->nextPtr; + FREE(XOTclClasses, l); + return 1; + } + while (l->nextPtr && l->nextPtr->cl != s) l = l->nextPtr; + if (l->nextPtr) { + XOTclClasses *n = l->nextPtr->nextPtr; + FREE(XOTclClasses, l->nextPtr); + l->nextPtr = n; + return 1; + } + return 0; } static int RemoveSuper(XOTclClass *cl, XOTclClass *super) { - /* - * keep corresponding sub in step with super - */ - int sp = RemoveSuper1(cl, super, &cl->super); - int sb = RemoveSuper1(super, cl, &super->sub); + /* + * keep corresponding sub in step with super + */ + int sp = RemoveSuper1(cl, super, &cl->super); + int sb = RemoveSuper1(super, cl, &super->sub); - return sp && sb; + return sp && sb; } /* @@ -1509,106 +1540,110 @@ extern XOTcl_Class* XOTclIsClass(Tcl_Interp *interp, ClientData clientData) { - if (clientData && XOTclObjectIsClass((XOTclObject *)clientData)) - return (XOTcl_Class*) clientData; - return 0; + if (clientData && XOTclObjectIsClass((XOTclObject *)clientData)) + return (XOTcl_Class*) clientData; + return 0; } /* * methods lookup */ -/*XOTCLINLINE*/ +XOTCLINLINE static Tcl_Command FindMethod(char *methodName, Tcl_Namespace *nsPtr) { - Tcl_HashEntry *entryPtr; - - /* if somebody messes around with the deleteProc, we could conclude that the - entries of the cmdTable are not ours ... we did that in earlier versions */ - /*fprintf(stderr,"FindMethod '%s', ns=%p \n", methodName, nsPtr);*/ - - if ((entryPtr = Tcl_FindHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName))) { - return (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - return NULL; + register Tcl_HashEntry *entryPtr; + if ((entryPtr = XOTcl_FindHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName))) { + return (Tcl_Command) Tcl_GetHashValue(entryPtr); + } + /*fprintf(stderr, "find %s in %p returns %p\n", methodName, cmdTable, cmd);*/ + return NULL; } static XOTclClass* -SearchPLMethod(register XOTclClasses *pl, char *nm, Tcl_Command *cmd) { - /* Search the class hierarchy */ - for (; pl; pl = pl->nextPtr) { - Tcl_Command pi = FindMethod(nm, pl->cl->nsPtr); - if (pi) { - *cmd = pi; - return pl->cl; - } - } - return NULL; +SearchPLMethod(XOTclClasses *pl, char *methodName, Tcl_Command *cmd) { + /* Search the precedence list (class hierarchy) */ +#if 0 + Tcl_HashEntry *entryPtr; + if ((entryPtr = XOTcl_FindHashEntry(Tcl_Namespace_cmdTable(pl->cl->nsPtr), methodName))) { + *cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + return pl->cl; + } } +#else +for (; pl; pl = pl->nextPtr) { + if ((*cmd = FindMethod(methodName, pl->cl->nsPtr))) { + return pl->cl; + } + } +#endif +return NULL; +} static XOTclClass* SearchCMethod(XOTclClass *cl, char *nm, Tcl_Command *cmd) { - assert(cl); - return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); + assert(cl); + return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); } static int callDestroyMethod(ClientData clientData, Tcl_Interp *interp, XOTclObject *obj, int flags) { - int result; + int result; - /* don't call destroy after exit handler started physical - destruction */ - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == - XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) - return TCL_OK; + /* don't call destroy after exit handler started physical + destruction */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == + XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) + return TCL_OK; - /* fprintf(stderr," obj %p flags %.4x %d\n", obj, obj->flags, - RUNTIME_STATE(interp)->callDestroy);*/ - /* we don't call destroy, if we're in the exit handler - during destruction of Object and Class */ - if (!RUNTIME_STATE(interp)->callDestroy) { - obj->flags |= XOTCL_DESTROY_CALLED; - /* return TCL_ERROR so that clients know we haven't deleted the - associated command yet */ - return TCL_ERROR; - } - /*fprintf(stderr, "+++ calldestroy flags=%d\n", flags);*/ - if (obj->flags & XOTCL_DESTROY_CALLED) - return TCL_OK; + /* fprintf(stderr," obj %p flags %.4x %d\n", obj, obj->flags, + RUNTIME_STATE(interp)->callDestroy);*/ + /* we don't call destroy, if we're in the exit handler + during destruction of Object and Class */ + if (!RUNTIME_STATE(interp)->callDestroy) { + obj->flags |= XOTCL_DESTROY_CALLED; + /* return TCL_ERROR so that clients know we haven't deleted the + associated command yet */ + return TCL_ERROR; + } + /*fprintf(stderr, "+++ calldestroy flags=%d\n", flags);*/ + if (obj->flags & XOTCL_DESTROY_CALLED) + return TCL_OK; + #if !defined(NDEBUG) - {char *cmdName = ObjStr(obj->cmdName); - assert(cmdName != NULL); - /*fprintf(stderr,"findCommand %s -> %p obj->id %p\n", cmdName, - Tcl_FindCommand(interp, cmdName, NULL, 0), obj->id);*/ - /*assert(Tcl_FindCommand(interp, cmdName, NULL, 0) != NULL);*/ - /*fprintf(stderr,"callDestroyMethod: %p command to be destroyed '%s' does not exist\n", - obj, cmdName);*/ - } + {char *cmdName = ObjStr(obj->cmdName); + assert(cmdName); + /*fprintf(stderr,"findCommand %s -> %p obj->id %p\n", cmdName, + Tcl_FindCommand(interp, cmdName, NULL, 0), obj->id);*/ + /*assert(Tcl_FindCommand(interp, cmdName, NULL, 0) != NULL);*/ + /*fprintf(stderr,"callDestroyMethod: %p command to be destroyed '%s' does not exist\n", + obj, cmdName);*/ + } #endif #ifdef OBJDELETION_TRACE - fprintf(stderr, " command found\n"); - PRINTOBJ("callDestroy", obj); + fprintf(stderr, " command found\n"); + PRINTOBJ("callDestroy", obj); #endif - result = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, flags); - if (result != TCL_OK) { - static char cmd[] = - "puts stderr \"[self]: Error in method destroy\n\ + result = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, flags); + if (result != TCL_OK) { + static char cmd[] = + "puts stderr \"[self]: Error in method destroy\n\ $::errorCode $::errorInfo\""; - Tcl_EvalEx(interp, cmd, -1, 0); - if (++RUNTIME_STATE(interp)->errorCount > 20) - panic("too many destroy errors occured. Endless loop?", NULL); - } else { - if (RUNTIME_STATE(interp)->errorCount > 0) - RUNTIME_STATE(interp)->errorCount--; - } + Tcl_EvalEx(interp, cmd, -1, 0); + if (++RUNTIME_STATE(interp)->errorCount > 20) + Tcl_Panic("too many destroy errors occured. Endless loop?", NULL); + } else { + if (RUNTIME_STATE(interp)->errorCount > 0) + RUNTIME_STATE(interp)->errorCount--; + } #ifdef OBJDELETION_TRACE - fprintf(stderr, "callDestroyMethod for %p exit\n", obj); + fprintf(stderr, "callDestroyMethod for %p exit\n", obj); #endif - return result; + return result; } /* @@ -1617,21 +1652,24 @@ extern XOTclObjectOpt * XOTclRequireObjectOpt(XOTclObject *obj) { - if (!obj->opt) { - obj->opt = NEW(XOTclObjectOpt); - memset(obj->opt, 0, sizeof(XOTclObjectOpt)); - } - return obj->opt; + if (!obj->opt) { + obj->opt = NEW(XOTclObjectOpt); + memset(obj->opt, 0, sizeof(XOTclObjectOpt)); + } + return obj->opt; } extern XOTclClassOpt* XOTclRequireClassOpt(XOTclClass *cl) { - assert(cl); - if (!cl->opt) { - cl->opt = NEW(XOTclClassOpt); - memset(cl->opt, 0, sizeof(XOTclClassOpt)); + assert(cl); + if (!cl->opt) { + cl->opt = NEW(XOTclClassOpt); + memset(cl->opt, 0, sizeof(XOTclClassOpt)); + if (cl->object.flags & XOTCL_IS_CLASS) { + cl->opt->id = cl->object.id; /* probably a temporary solution */ } - return cl->opt; + } + return cl->opt; } @@ -1643,78 +1681,155 @@ static void makeObjNamespace(Tcl_Interp *interp, XOTclObject *obj) { #ifdef NAMESPACE_TRACE - fprintf(stderr, "+++ Make Namespace for %s\n", ObjStr(obj->cmdName)); + fprintf(stderr, "+++ Make Namespace for %s\n", ObjStr(obj->cmdName)); #endif - if (!obj->nsPtr) { - Tcl_Namespace *nsPtr; - char *cmdName = ObjStr(obj->cmdName); - obj->nsPtr = NSGetFreshNamespace(interp, (ClientData)obj, cmdName); - if (!obj->nsPtr) - panic("makeObjNamespace: Unable to make namespace", 0); - nsPtr = obj->nsPtr; + if (!obj->nsPtr) { + Tcl_Namespace *nsPtr; + char *cmdName = ObjStr(obj->cmdName); + obj->nsPtr = NSGetFreshNamespace(interp, (ClientData)obj, cmdName); + if (!obj->nsPtr) + Tcl_Panic("makeObjNamespace: Unable to make namespace", NULL); + nsPtr = obj->nsPtr; - /* - * Copy all obj variables to the newly created namespace - */ - if (obj->varTable) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); - Tcl_HashTable *varHashTable = VarHashTable(varTable); - Tcl_HashTable *objHashTable = VarHashTable(obj->varTable); + /* + * Copy all obj variables to the newly created namespace + */ + if (obj->varTable) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); + Tcl_HashTable *varHashTable = VarHashTable(varTable); + Tcl_HashTable *objHashTable = VarHashTable(obj->varTable); - *varHashTable = *objHashTable; /* copy the table */ + *varHashTable = *objHashTable; /* copy the table */ - if (objHashTable->buckets == objHashTable->staticBuckets) { - varHashTable->buckets = varHashTable->staticBuckets; - } - for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { + if (objHashTable->buckets == objHashTable->staticBuckets) { + varHashTable->buckets = varHashTable->staticBuckets; + } + for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { #if defined(PRE85) - Var *varPtr; + Var *varPtr; # if FORWARD_COMPATIBLE - if (!forwardCompatibleMode) { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - varPtr->nsPtr = (Namespace *)nsPtr; - } + if (!forwardCompatibleMode) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + varPtr->nsPtr = (Namespace *)nsPtr; + } # else - varPtr = (Var *) Tcl_GetHashValue(hPtr); - varPtr->nsPtr = (Namespace *)nsPtr; + varPtr = (Var *) Tcl_GetHashValue(hPtr); + varPtr->nsPtr = (Namespace *)nsPtr; # endif #endif - hPtr->tablePtr = varHashTable; - } + hPtr->tablePtr = varHashTable; + } - ckfree((char *) obj->varTable); - obj->varTable = 0; - } + ckfree((char *) obj->varTable); + obj->varTable = NULL; } + } } + /* typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - * Tcl_Interp *interp, CONST char *name, Tcl_Namespace *context, + * Tcl_Interp *interp, CONST char * name, Tcl_Namespace *context, * int flags, Tcl_Var *rPtr)); */ int varResolver(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns, int flags, Tcl_Var *varPtr) { - *varPtr = (Tcl_Var)LookupVarFromTable(Tcl_Namespace_varTable(ns), name, NULL); - /*fprintf(stderr,"lookup '%s' successful %d\n", name, *varPtr != NULL);*/ - return *varPtr ? TCL_OK : TCL_ERROR; + int new; + Tcl_Obj *key; + Tcl_CallFrame *varFramePtr; + Var *newVar; + + /* Case 1: The variable is to be resolved in global scope, proceed in + * resolver chain (i.e. return TCL_CONTINUE) + * + * Note: For now, I am not aware of this case to become effective, + * it is a mere safeguard measure. + * + * TODO: Can it be omitted safely? + */ + + if (flags & TCL_GLOBAL_ONLY) { + /*fprintf(stderr, "global-scoped var detected '%s' in NS '%s'\n", name, \ + varFramePtr->nsPtr->fullName);*/ + return TCL_CONTINUE; + } + + /* Case 2: The variable appears as to be proc-local, so proceed in + * resolver chain (i.e. return TCL_CONTINUE) + * + * Note 1: This happens to be a rare occurrence, e.g. for nested + * object structures which are shadowed by nested Tcl namespaces. + * + * TODO: Cannot reproduce the issue found with xotcl::package->require() + * + * Note 2: It would be possible to resolve the proc-local variable + * directly (by digging into compiled and non-compiled locals etc.), + * however, it would cause further code redundance. + */ + varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + /* + fprintf(stderr,"varFramePtr=%p, isProcCallFrame=%d %p\n",varFramePtr, + varFramePtr != NULL ? Tcl_CallFrame_isProcCallFrame(varFramePtr): 0, + varFramePtr != NULL ? Tcl_CallFrame_procPtr(varFramePtr): 0 + ); + */ + if (varFramePtr && Tcl_CallFrame_isProcCallFrame(varFramePtr)) { + /*fprintf(stderr, "proc-scoped var detected '%s' in NS '%s'\n", name, + varFramePtr->nsPtr->fullName);*/ + return TCL_CONTINUE; + } + + /* + * Check for absolutely/relatively qualified variable names, i.e. + * make sure that the variable name does not contain any namespace qualifiers. + * Proceed with a TCL_CONTINUE, otherwise. + */ + + if ((*name == ':' && *(name+1) == ':') || NSTail(name) != name) { + return TCL_CONTINUE; + } + + /* Case 3: Does the variable exist in the per-object namespace? */ + *varPtr = (Tcl_Var)LookupVarFromTable(Tcl_Namespace_varTable(ns),name,NULL); + + if(*varPtr == NULL) { + /* We failed to find the variable so far, therefore we create it + * here in the namespace. Note that the cases (1), (2) and (3) + * TCL_CONTINUE care for variable creation if necessary. + */ + + key = Tcl_NewStringObj(name, -1); + + INCR_REF_COUNT(key); + newVar = VarHashCreateVar(Tcl_Namespace_varTable(ns), key, &new); + DECR_REF_COUNT(key); + +#if defined(PRE85) + newVar->nsPtr = (Namespace *)ns; +#endif + *varPtr = (Tcl_Var)newVar; + } + return *varPtr ? TCL_OK : TCL_ERROR; } static Tcl_Namespace * requireObjNamespace(Tcl_Interp *interp, XOTclObject *obj) { - if (!obj->nsPtr) makeObjNamespace(interp, obj); - /* - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - varResolver, (Tcl_ResolveCompiledVarProc*)NULL); - */ - return obj->nsPtr; + if (!obj->nsPtr) makeObjNamespace(interp, obj); + + /* This puts a per-object namespace resolver into position upon + * acquiring the namespace. Works for object-scoped commands/procs + * and object-only ones (set, unset, ...) + */ + Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, + varResolver, (Tcl_ResolveCompiledVarProc*)NULL); + return obj->nsPtr; } extern void XOTclRequireObjNamespace(Tcl_Interp *interp, XOTcl_Object *obj) { - requireObjNamespace(interp,(XOTclObject*) obj); + requireObjNamespace(interp,(XOTclObject*) obj); } @@ -1724,15 +1839,15 @@ static int NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *ns, char *name) { - /* a simple deletion would delete a global command with - the same name, if the command is not existing, so - we use the CmdToken */ - Tcl_Command token; - assert(ns); - if ((token = FindMethod(name, ns))) { - return Tcl_DeleteCommandFromToken(interp, token); - } - return -1; + /* a simple deletion would delete a global command with + the same name, if the command is not existing, so + we use the CmdToken */ + Tcl_Command token; + assert(ns); + if ((token = FindMethod(name, ns))) { + return Tcl_DeleteCommandFromToken(interp, token); + } + return -1; } static void @@ -1744,57 +1859,58 @@ static void NSDeleteChildren(Tcl_Interp *interp, Tcl_Namespace *ns) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; #ifdef OBJDELETION_TRACE - fprintf(stderr, "NSDeleteChildren %s\n", ns->fullName); + fprintf(stderr, "NSDeleteChildren %s\n", ns->fullName); #endif - Tcl_ForgetImport(interp, ns, "*"); /* don't destroy namespace imported objects */ + Tcl_ForgetImport(interp, ns, "*"); /* don't destroy namespace imported objects */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr != 0; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - if (!Tcl_Command_cmdEpoch(cmd)) { - char *oname = Tcl_GetHashKey(cmdTable, hPtr); - Tcl_DString name; - XOTclObject *obj; - /* fprintf(stderr, " ... child %s\n", oname); */ + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + if (!Tcl_Command_cmdEpoch(cmd)) { + char *oname = Tcl_GetHashKey(cmdTable, hPtr); + Tcl_DString name; + XOTclObject *obj; + /* fprintf(stderr, " ... child %s\n", oname); */ - ALLOC_NAME_NS(&name, ns->fullName, oname); - obj = XOTclpGetObject(interp, Tcl_DStringValue(&name)); + ALLOC_NAME_NS(&name, ns->fullName, oname); + obj = XOTclpGetObject(interp, Tcl_DStringValue(&name)); - if (obj) { - /* fprintf(stderr, " ... obj= %s\n", ObjStr(obj->cmdName));*/ + if (obj) { + /* fprintf(stderr, " ... obj= %s\n", ObjStr(obj->cmdName));*/ - /* in the exit handler physical destroy --> directly call destroy */ - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound - == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { - if (XOTclObjectIsClass(obj)) - PrimitiveCDestroy((ClientData) obj); - else - PrimitiveODestroy((ClientData) obj); - } else { - if (obj->teardown != 0 && obj->id && - !(obj->flags & XOTCL_DESTROY_CALLED)) { - if (callDestroyMethod((ClientData)obj, interp, obj, 0) != TCL_OK) { - /* destroy method failed, but we have to remove the command - anyway. */ - obj->flags |= XOTCL_DESTROY_CALLED; + /* in the exit handler physical destroy --> directly call destroy */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound + == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { + if (XOTclObjectIsClass(obj)) + PrimitiveCDestroy((ClientData) obj); + else + PrimitiveODestroy((ClientData) obj); + } else { + if (obj->teardown && obj->id && + !(obj->flags & XOTCL_DESTROY_CALLED)) { + + if (callDestroyMethod((ClientData)obj, interp, obj, 0) != TCL_OK) { + /* destroy method failed, but we have to remove the command + anyway. */ + obj->flags |= XOTCL_DESTROY_CALLED; - if (obj->teardown) { - CallStackDestroyObject(interp, obj); - } - /*(void*) Tcl_DeleteCommandFromToken(interp, oid);*/ - } - } - } + if (obj->teardown) { + CallStackDestroyObject(interp, obj); + } + /*(void*) Tcl_DeleteCommandFromToken(interp, oid);*/ } - DSTRING_FREE(&name); + } } + } + DSTRING_FREE(&name); } + } } /* @@ -1803,138 +1919,124 @@ */ static Var * NSRequireVariableOnObj(Tcl_Interp *interp, XOTclObject *obj, char *name, int flgs) { - XOTcl_FrameDecls; - Var *varPtr, *arrayPtr; + XOTcl_FrameDecls; + Var *varPtr, *arrayPtr; - XOTcl_PushFrame(interp, obj); - varPtr = TclLookupVar(interp, name, 0, flgs, "obj vwait", - /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); - XOTcl_PopFrame(interp, obj); - return varPtr; + XOTcl_PushFrame(interp, obj); + varPtr = TclLookupVar(interp, name, 0, flgs, "obj vwait", + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + XOTcl_PopFrame(interp, obj); + return varPtr; } -/* delete a namespace recursively, but check whether the - namespace is an object or not */ -static void -NSDeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *ns) { - Tcl_HashTable *childTable = Tcl_Namespace_childTable(ns); - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - - NSDeleteChildren(interp, ns); - for (hPtr = Tcl_FirstHashEntry(childTable, &hSrch); hPtr != 0; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Namespace *child = ((Tcl_Namespace*)Tcl_GetHashValue(hPtr)); - NSDeleteNamespace(interp, child); - } - /* - fprintf(stderr, "NSDeleteNamespace deleting %s\n", ns->fullName); - */ - MEM_COUNT_FREE("TclNamespace", ns); - Tcl_DeleteNamespace(ns); -} - static int XOTcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command cmd) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc = cs->top; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc = cs->top; - for (; csc > cs->content; csc--) { - if (csc->cmdPtr == cmd) { - csc->cmdPtr = NULL; - } + for (; csc > cs->content; csc--) { + if (csc->cmdPtr == cmd) { + csc->cmdPtr = NULL; } - return Tcl_DeleteCommandFromToken(interp, cmd); + } + return Tcl_DeleteCommandFromToken(interp, cmd); } /* * delete all vars & procs in a namespace */ static void NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *ns) { - TclVarHashTable *varTable = Tcl_Namespace_varTable(ns); - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - Tcl_Command cmd; - /* - * Delete all variables and initialize var table again - * (DeleteVars frees the vartable) - */ - TclDeleteVars((Interp *)interp, varTable); - InitVarHashTable(varTable, (Namespace *)ns); + TclVarHashTable *varTable = Tcl_Namespace_varTable(ns); + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + Tcl_Command cmd; + /* + * Delete all variables and initialize var table again + * (DeleteVars frees the vartable) + */ + TclDeleteVars((Interp *)interp, varTable); + InitVarHashTable(varTable, (Namespace *)ns); - /* - * Delete all user-defined procs in the namespace - */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr != 0; - hPtr = Tcl_NextHashEntry(&hSrch)) { - cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); - /* objects should not be deleted here to preseve children deletion order*/ - if (!XOTclGetObjectFromCmdPtr(cmd)) { - /*fprintf(stderr,"NSCleanupNamespace deleting %s %p\n", - Tcl_Command_nsPtr(cmd)->fullName, cmd);*/ - XOTcl_DeleteCommandFromToken(interp, cmd); - } + /* + * Delete all user-defined procs in the namespace + */ + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); + /* objects should not be deleted here to preseve children deletion order*/ + if (!XOTclGetObjectFromCmdPtr(cmd)) { + /*fprintf(stderr,"NSCleanupNamespace deleting %s %p\n", + Tcl_Command_nsPtr(cmd)->fullName, cmd);*/ + XOTcl_DeleteCommandFromToken(interp, cmd); } + } } static void NSNamespaceDeleteProc(ClientData clientData) { - /* dummy for ns identification by pointer comparison */ - XOTclObject *obj = (XOTclObject*) clientData; - /* fprintf(stderr,"namespacedeleteproc obj=%p\n", clientData);*/ - if (obj) { - obj->flags |= XOTCL_NS_DESTROYED; - obj->nsPtr = NULL; - } + /* dummy for ns identification by pointer comparison */ + XOTclObject *obj = (XOTclObject*) clientData; + /*fprintf(stderr,"namespacedeleteproc obj=%p\n", clientData);*/ + if (obj) { + obj->flags |= XOTCL_NS_DESTROYED; + obj->nsPtr = NULL; + } } +#ifdef EXPERIMENTAL_CMD_RESOLVER +static int +NSisXOTclNamespace(Tcl_Namespace *nsPtr) { + return nsPtr->deleteProc == NSNamespaceDeleteProc; +} +#endif + void XOTcl_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { - int activationCount = 0; - Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); + int activationCount = 0; + Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); - /* - fprintf(stderr, " ... correcting ActivationCount for %s was %d ", - nsPtr->fullName, nsp->activationCount); - */ - while (f) { - if (f->nsPtr == nsPtr) - activationCount++; - f = Tcl_CallFrame_callerPtr(f); - } + /* + fprintf(stderr, " ... correcting ActivationCount for %s was %d ", + nsPtr->fullName, nsp->activationCount); + */ + while (f) { + if (f->nsPtr == nsPtr) + activationCount++; + f = Tcl_CallFrame_callerPtr(f); + } - Tcl_Namespace_activationCount(nsPtr) = activationCount; + Tcl_Namespace_activationCount(nsPtr) = activationCount; - /* - fprintf(stderr, "to %d. \n", nsp->activationCount); - */ - MEM_COUNT_FREE("TclNamespace", nsPtr); - if (Tcl_Namespace_deleteProc(nsPtr) != NULL) { - /*fprintf(stderr,"calling deteteNamespace\n");*/ - Tcl_DeleteNamespace(nsPtr); - } + /* + fprintf(stderr, "to %d. \n", nsp->activationCount); + */ + MEM_COUNT_FREE("TclNamespace", nsPtr); + if (Tcl_Namespace_deleteProc(nsPtr)) { + /*fprintf(stderr,"calling deteteNamespace\n");*/ + Tcl_DeleteNamespace(nsPtr); + } } static Tcl_Namespace* NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, char *name) { - Tcl_Namespace *ns = Tcl_FindNamespace(interp, name, NULL, 0); + Tcl_Namespace *ns = Tcl_FindNamespace(interp, name, NULL, 0); - if (ns) { - if (ns->deleteProc != NULL || ns->clientData != NULL) { - panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace", - name, ns->deleteProc, ns->clientData); - } - ns->clientData = clientData; - ns->deleteProc = (Tcl_NamespaceDeleteProc*) NSNamespaceDeleteProc; - } else { - ns = Tcl_CreateNamespace(interp, name, clientData, - (Tcl_NamespaceDeleteProc*) NSNamespaceDeleteProc); + if (ns) { + if (ns->deleteProc || ns->clientData) { + Tcl_Panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace", + name, ns->deleteProc, ns->clientData); } - MEM_COUNT_ALLOC("TclNamespace", ns); - return ns; + ns->clientData = clientData; + ns->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc; + } else { + ns = Tcl_CreateNamespace(interp, name, clientData, + (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc); + } + MEM_COUNT_ALLOC("TclNamespace", ns); + return ns; } @@ -1943,74 +2045,74 @@ */ XOTCLINLINE static int NSCheckColons(char *name, unsigned l) { - register char *n = name; - if (*n == '\0') return 0; /* empty name */ - if (l==0) l=strlen(name); - if (*(n+l-1) == ':') return 0; /* name ends with : */ - if (*n == ':' && *(n+1) != ':') return 0; /* name begins with single : */ - for (; *n != '\0'; n++) { - if (*n == ':' && *(n+1) == ':' && *(n+2) == ':') - return 0; /* more than 2 colons in series in a name */ - } - return 1; + register char *n = name; + if (*n == '\0') return 0; /* empty name */ + if (l == 0) l=strlen(name); + if (*(n+l-1) == ':') return 0; /* name ends with : */ + if (*n == ':' && *(n+1) != ':') return 0; /* name begins with single : */ + for (; *n != '\0'; n++) { + if (*n == ':' && *(n+1) == ':' && *(n+2) == ':') + return 0; /* more than 2 colons in series in a name */ + } + return 1; } /* * check for parent namespace existance (used before commands are created) */ XOTCLINLINE static int NSCheckForParent(Tcl_Interp *interp, char *name, unsigned l) { - register char *n = name+l; - int result = 1; + register char *n = name+l; + int result = 1; - /*search for last '::'*/ - while ((*n != ':' || *(n-1) != ':') && n-1 > name) {n--; } - if (*n == ':' && n > name && *(n-1) == ':') {n--;} + /*search for last '::'*/ + while ((*n != ':' || *(n-1) != ':') && n-1 > name) {n--; } + if (*n == ':' && n > name && *(n-1) == ':') {n--;} - if ((n-name)>0) { - Tcl_DString parentNSName, *dsp = &parentNSName; - char *parentName; - DSTRING_INIT(dsp); + if ((n-name)>0) { + Tcl_DString parentNSName, *dsp = &parentNSName; + char *parentName; + DSTRING_INIT(dsp); - Tcl_DStringAppend(dsp, name, (n-name)); - parentName = Tcl_DStringValue(dsp); + Tcl_DStringAppend(dsp, name, (n-name)); + parentName = Tcl_DStringValue(dsp); - if (Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) == 0) { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); - if (parentObj) { - /* this is for classes */ - requireObjNamespace(interp, parentObj); - } else { - /* call unknown and try again */ - Tcl_Obj *ov[3]; - int rc; - ov[0] = RUNTIME_STATE(interp)->theClass->object.cmdName; - ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; - ov[2] = Tcl_NewStringObj(parentName,-1); - INCR_REF_COUNT(ov[2]); - /*fprintf(stderr,"+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/ - rc = Tcl_EvalObjv(interp, 3, ov, 0); - if (rc == TCL_OK) { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); - if (parentObj) { - requireObjNamespace(interp, parentObj); - } - result = (Tcl_FindNamespace(interp, parentName, - (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != 0); - } else { - result = 0; - } - DECR_REF_COUNT(ov[2]); - } + if (Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) == NULL) { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + /* this is for classes */ + requireObjNamespace(interp, parentObj); + } else { + /* call unknown and try again */ + Tcl_Obj *ov[3]; + int rc; + ov[0] = RUNTIME_STATE(interp)->theClass->object.cmdName; + ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; + ov[2] = Tcl_NewStringObj(parentName,-1); + INCR_REF_COUNT(ov[2]); + /*fprintf(stderr,"+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/ + rc = Tcl_EvalObjv(interp, 3, ov, 0); + if (rc == TCL_OK) { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + requireObjNamespace(interp, parentObj); + } + result = (Tcl_FindNamespace(interp, parentName, + (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != NULL); } else { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); - if (parentObj) { - requireObjNamespace(interp, parentObj); - } + result = 0; } - DSTRING_FREE(dsp); + DECR_REF_COUNT(ov[2]); + } + } else { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + requireObjNamespace(interp, parentObj); + } } - return result; + DSTRING_FREE(dsp); + } + return result; } /* @@ -2020,13 +2122,13 @@ */ XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, char *name, Tcl_Namespace *ns) { - Tcl_Command cmd; - if ((cmd = Tcl_FindCommand(interp, name, ns, 0))) { - Tcl_Command importedCmd; - if ((importedCmd = TclGetOriginalCommand(cmd))) - cmd = importedCmd; - } - return cmd; + Tcl_Command cmd; + if ((cmd = Tcl_FindCommand(interp, name, ns, 0))) { + Tcl_Command importedCmd; + if ((importedCmd = TclGetOriginalCommand(cmd))) + cmd = importedCmd; + } + return cmd; } @@ -2038,27 +2140,33 @@ extern XOTcl_Object* XOTclGetObject(Tcl_Interp *interp, char *name) { - return (XOTcl_Object*) XOTclpGetObject(interp, name); + return (XOTcl_Object*) XOTclpGetObject(interp, name); } /* * Find an object using a char *name */ static XOTclObject* XOTclpGetObject(Tcl_Interp *interp, char *name) { - register Tcl_Command cmd; - assert(name); - cmd = NSFindCommand(interp, name, NULL); + register Tcl_Command cmd; + assert(name); + /*fprintf(stderr, "XOTclpGetObject name = '%s'\n",name);*/ + + cmd = NSFindCommand(interp, name, NULL); - /*if (cmd) { - fprintf(stderr,"+++ XOTclGetObject from %s -> objProc=%p, dispatch=%p\n", - name, Tcl_Command_objProc(cmd), XOTclObjDispatch); - }*/ + /* + if (cmd) { + fprintf(stderr,"+++ XOTclGetObject from %s -> objProc=%p, dispatch=%p\n", + name, Tcl_Command_objProc(cmd), XOTclObjDispatch); + } + fprintf(stderr, "XOTclpGetObject objProc=%p %p\n",cmd?Tcl_Command_objProc(cmd):NULL,XOTclObjDispatch); + */ - if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) { - return (XOTclObject*)Tcl_Command_objClientData(cmd); - } - return 0; + if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) { + /*fprintf(stderr, "XOTclpGetObject cd %p\n",Tcl_Command_objClientData(cmd));*/ + return (XOTclObject*)Tcl_Command_objClientData(cmd); + } + return 0; } /* @@ -2067,74 +2175,75 @@ extern XOTcl_Class* XOTclGetClass(Tcl_Interp *interp, char *name) { - return (XOTcl_Class*)XOTclpGetClass(interp, name); + return (XOTcl_Class*)XOTclpGetClass(interp, name); } static XOTclClass* XOTclpGetClass(Tcl_Interp *interp, char *name) { - XOTclObject *obj = XOTclpGetObject(interp, name); - return (obj && XOTclObjectIsClass(obj)) ? (XOTclClass*)obj : NULL; + XOTclObject *obj = XOTclpGetObject(interp, name); + return (obj && XOTclObjectIsClass(obj)) ? (XOTclClass*)obj : NULL; } - - Tcl_Command -XOTclAddObjectMethod(Tcl_Interp *interp, XOTcl_Object *object, char *methodName, +XOTclAddObjectMethod(Tcl_Interp *interp, XOTcl_Object *object, CONST char *methodName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, int flags) { - XOTclObject *obj = (XOTclObject *)object; - Tcl_DString newCmdName, *dsPtr = &newCmdName; - Tcl_Command newCmd; - Tcl_Namespace *ns = requireObjNamespace(interp, obj); - ALLOC_NAME_NS(dsPtr, ns->fullName, methodName); - newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); - if (flags) { - ((Command *) newCmd)->flags |= flags; - } - DSTRING_FREE(dsPtr); - return newCmd; + XOTclObject *obj = (XOTclObject *)object; + Tcl_DString newCmdName, *dsPtr = &newCmdName; + Tcl_Command newCmd; + Tcl_Namespace *ns = requireObjNamespace(interp, obj); + + ALLOC_NAME_NS(dsPtr, ns->fullName, methodName); + + newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); + if (flags) { + ((Command *) newCmd)->flags |= flags; + } + DSTRING_FREE(dsPtr); + return newCmd; } Tcl_Command -XOTclAddPMethod(Tcl_Interp *interp, XOTcl_Object *object, char *methodName, +XOTclAddPMethod(Tcl_Interp *interp, XOTcl_Object *object, CONST char *methodName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp) { - int flags = 0; - if (clientData == (ClientData) XOTCL_NONLEAF_METHOD) { - fprintf(stderr, "XOTclAddPMethod(,,,, XOTCL_NONLEAF_METHOD,) deprecated.\n" - "Use XOTclAddObjectMethod(,,,,,, XOTCL_NONLEAF_METHOD) instead.\n"); - flags = XOTCL_NONLEAF_METHOD; - clientData = NULL; - } - return XOTclAddObjectMethod(interp, object, methodName, proc, clientData, dp, flags); + int flags = 0; + if (clientData == (ClientData) XOTCL_NONLEAF_METHOD) { + fprintf(stderr, "XOTclAddPMethod(,,,, XOTCL_NONLEAF_METHOD,) deprecated.\n" + "Use XOTclAddObjectMethod(,,,,,, XOTCL_NONLEAF_METHOD) instead.\n"); + flags = XOTCL_NONLEAF_METHOD; + clientData = NULL; + } + return XOTclAddObjectMethod(interp, object, methodName, proc, clientData, dp, flags); } + Tcl_Command -XOTclAddInstanceMethod(Tcl_Interp *interp, XOTcl_Class *class, char *methodName, +XOTclAddInstanceMethod(Tcl_Interp *interp, XOTcl_Class *class, CONST char *methodName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, int flags) { - XOTclClass *cl = (XOTclClass*) class; - Tcl_DString newCmdName, *dsPtr = &newCmdName; - Tcl_Command newCmd; - ALLOC_NAME_NS(dsPtr, cl->nsPtr->fullName, methodName); - newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); - if (flags) { - ((Command *) newCmd)->flags |= flags; - } - DSTRING_FREE(dsPtr); - return newCmd; + XOTclClass *cl = (XOTclClass*) class; + Tcl_DString newCmdName, *dsPtr = &newCmdName; + Tcl_Command newCmd; + ALLOC_NAME_NS(dsPtr, cl->nsPtr->fullName, methodName); + newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); + if (flags) { + ((Command *) newCmd)->flags |= flags; + } + DSTRING_FREE(dsPtr); + return newCmd; } Tcl_Command -XOTclAddIMethod(Tcl_Interp *interp, XOTcl_Class *class, char *methodName, +XOTclAddIMethod(Tcl_Interp *interp, XOTcl_Class *class, CONST char *methodName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp) { - int flags = 0; - if (clientData == (ClientData) XOTCL_NONLEAF_METHOD) { - fprintf(stderr, "XOTclAddIMethod(,,,, XOTCL_NONLEAF_METHOD,) deprecated.\n" - "Use XOTclAddInstanceMethod(,,,,,, XOTCL_NONLEAF_METHOD) instead.\n"); - flags = XOTCL_NONLEAF_METHOD; - clientData = NULL; - } - return XOTclAddInstanceMethod(interp, class, methodName, proc, clientData, dp, flags); + int flags = 0; + if (clientData == (ClientData) XOTCL_NONLEAF_METHOD) { + fprintf(stderr, "XOTclAddIMethod(,,,, XOTCL_NONLEAF_METHOD,) deprecated.\n" + "Use XOTclAddInstanceMethod(,,,,,, XOTCL_NONLEAF_METHOD) instead.\n"); + flags = XOTCL_NONLEAF_METHOD; + clientData = NULL; + } + return XOTclAddInstanceMethod(interp, class, methodName, proc, clientData, dp, flags); } @@ -2145,23 +2254,23 @@ static void TclObjListFreeList(XOTclTclObjList *list) { - XOTclTclObjList *del; - while (list) { - del = list; - list = list->nextPtr; - DECR_REF_COUNT(del->content); - FREE(XOTclTclObjList, del); - } + XOTclTclObjList *del; + while (list) { + del = list; + list = list->nextPtr; + DECR_REF_COUNT(del->content); + FREE(XOTclTclObjList, del); + } } static Tcl_Obj * TclObjListNewElement(XOTclTclObjList **list, Tcl_Obj *ov) { - XOTclTclObjList *elt = NEW(XOTclTclObjList); - INCR_REF_COUNT(ov); - elt->content = ov; - elt->nextPtr = *list; - *list = elt; - return ov; + XOTclTclObjList *elt = NEW(XOTclTclObjList); + INCR_REF_COUNT(ov); + elt->content = ov; + elt->nextPtr = *list; + *list = elt; + return ov; } /* @@ -2170,111 +2279,111 @@ static Tcl_Obj * AutonameIncr(Tcl_Interp *interp, Tcl_Obj *name, XOTclObject *obj, - int instanceOpt, int resetOpt) { - int valueLength, mustCopy = 1, format = 0; - char *valueString, *c; - Tcl_Obj *valueObject, *result = NULL, *savedResult = NULL; + int instanceOpt, int resetOpt) { + int valueLength, mustCopy = 1, format = 0; + char *valueString, *c; + Tcl_Obj *valueObject, *result = NULL, *savedResult = NULL; #ifdef PRE83 - int flgs = 0; + int flgs = 0; #else - int flgs = TCL_LEAVE_ERR_MSG; + int flgs = TCL_LEAVE_ERR_MSG; #endif - XOTcl_FrameDecls; + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); - if (obj->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, obj); + if (obj->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - valueObject = Tcl_ObjGetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name, flgs); - if (valueObject != NULL ) { - long autoname_counter; - /* should probably do an overflow check here */ - Tcl_GetLongFromObj(interp, valueObject,&autoname_counter); - autoname_counter++; - if (Tcl_IsShared(valueObject)) { - valueObject = Tcl_DuplicateObj(valueObject); - } - Tcl_SetLongObj(valueObject, autoname_counter); + valueObject = Tcl_ObjGetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name, flgs); + if (valueObject) { + long autoname_counter; + /* should probably do an overflow check here */ + Tcl_GetLongFromObj(interp, valueObject,&autoname_counter); + autoname_counter++; + if (Tcl_IsShared(valueObject)) { + valueObject = Tcl_DuplicateObj(valueObject); } - Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name, - valueObject, flgs); + Tcl_SetLongObj(valueObject, autoname_counter); + } + Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name, + valueObject, flgs); - if (resetOpt) { - if (valueObject != NULL) { /* we have an entry */ - Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(name), flgs); - } - result = XOTclGlobalObjects[XOTE_EMPTY]; + if (resetOpt) { + if (valueObject) { /* we have an entry */ + Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(name), flgs); + } + result = XOTclGlobalObjects[XOTE_EMPTY]; + INCR_REF_COUNT(result); + } else { + if (valueObject == NULL) { + valueObject = Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], + name, XOTclGlobalObjects[XOTE_ONE], flgs); + } + if (instanceOpt) { + char buffer[1], firstChar, *nextChars; + nextChars = ObjStr(name); + firstChar = *(nextChars ++); + if (isupper((int)firstChar)) { + buffer[0] = tolower((int)firstChar); + result = Tcl_NewStringObj(buffer, 1); INCR_REF_COUNT(result); - } else { - if (valueObject == NULL) { - valueObject = Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], - name, XOTclGlobalObjects[XOTE_ONE], flgs); - } - if (instanceOpt) { - char buffer[1], firstChar, *nextChars; - nextChars = ObjStr(name); - firstChar = *(nextChars ++); - if (isupper((int)firstChar)) { - buffer[0] = tolower((int)firstChar); - result = Tcl_NewStringObj(buffer, 1); - INCR_REF_COUNT(result); - Tcl_AppendToObj(result, nextChars, -1); - mustCopy = 0; - } - } - if (mustCopy) { - result = Tcl_DuplicateObj(name); - INCR_REF_COUNT(result); - /* - fprintf(stderr,"*** copy %p %s = %p\n", name, ObjStr(name), result); - */ - } - /* if we find a % in the autoname -> We use Tcl_FormatObjCmd - to let the autoname string be formated, like Tcl "format" - command, with the value. E.g.: - autoname a%06d --> a000000, a000001, a000002, ... - */ - for (c = ObjStr(result); *c != '\0'; c++) { - if (*c == '%') { - if (*(c+1) != '%') { - format = 1; - break; - } else { - /* when we find a %% we format and then append autoname, e.g. - autoname a%% --> a%1, a%2, ... */ - c++; - } - } - } - if (format) { - ALLOC_ON_STACK(Tcl_Obj *, 3, ov); - savedResult = Tcl_GetObjResult(interp); - INCR_REF_COUNT(savedResult); - ov[0] = XOTclGlobalObjects[XOTE_FORMAT]; - ov[1] = result; - ov[2] = valueObject; - if (Tcl_EvalObjv(interp, 3, ov, 0) != TCL_OK) { - XOTcl_PopFrame(interp, obj); - DECR_REF_COUNT(savedResult); - FREE_ON_STACK(ov); - return 0; - } - DECR_REF_COUNT(result); - result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); - INCR_REF_COUNT(result); - Tcl_SetObjResult(interp, savedResult); - DECR_REF_COUNT(savedResult); - FREE_ON_STACK(ov); + Tcl_AppendToObj(result, nextChars, -1); + mustCopy = 0; + } + } + if (mustCopy) { + result = Tcl_DuplicateObj(name); + INCR_REF_COUNT(result); + /* + fprintf(stderr,"*** copy %p %s = %p\n", name, ObjStr(name), result); + */ + } + /* if we find a % in the autoname -> We use Tcl_FormatObjCmd + to let the autoname string be formated, like Tcl "format" + command, with the value. E.g.: + autoname a%06d --> a000000, a000001, a000002, ... + */ + for (c = ObjStr(result); *c != '\0'; c++) { + if (*c == '%') { + if (*(c+1) != '%') { + format = 1; + break; } else { - valueString = Tcl_GetStringFromObj(valueObject,&valueLength); - Tcl_AppendToObj(result, valueString, valueLength); - /*fprintf(stderr,"+++ append to obj done\n");*/ + /* when we find a %% we format and then append autoname, e.g. + autoname a%% --> a%1, a%2, ... */ + c++; } + } } + if (format) { + ALLOC_ON_STACK(Tcl_Obj*, 3, ov); + savedResult = Tcl_GetObjResult(interp); + INCR_REF_COUNT(savedResult); + ov[0] = XOTclGlobalObjects[XOTE_FORMAT]; + ov[1] = result; + ov[2] = valueObject; + if (Tcl_EvalObjv(interp, 3, ov, 0) != TCL_OK) { + XOTcl_PopFrame(interp, obj); + DECR_REF_COUNT(savedResult); + FREE_ON_STACK(ov); + return 0; + } + DECR_REF_COUNT(result); + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + INCR_REF_COUNT(result); + Tcl_SetObjResult(interp, savedResult); + DECR_REF_COUNT(savedResult); + FREE_ON_STACK(ov); + } else { + valueString = Tcl_GetStringFromObj(valueObject,&valueLength); + Tcl_AppendToObj(result, valueString, valueLength); + /*fprintf(stderr,"+++ append to obj done\n");*/ + } + } - XOTcl_PopFrame(interp, obj); - assert((resetOpt && result->refCount>=1) || (result->refCount == 1)); - return result; + XOTcl_PopFrame(interp, obj); + assert((resetOpt && result->refCount>=1) || (result->refCount == 1)); + return result; } /* @@ -2283,264 +2392,269 @@ XOTclCallStackContent * XOTclCallStackFindLastInvocation(Tcl_Interp *interp, int offset) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - register XOTclCallStackContent *csc = cs->top; - int topLevel = csc->currentFramePtr ? Tcl_CallFrame_level(csc->currentFramePtr) :0; - int deeper = offset; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *csc = cs->top; + int topLevel = csc->currentFramePtr ? Tcl_CallFrame_level(csc->currentFramePtr) : 0; + int deeper = offset; - /* skip through toplevel inactive filters, do this offset times */ - for (csc=cs->top; csc > cs->content; csc--) { - if ((csc->callType & XOTCL_CSC_CALL_IS_NEXT) || - (csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) - continue; - if (offset) - offset--; - else { - if (!deeper) { - return csc; - } - if (csc->currentFramePtr && Tcl_CallFrame_level(csc->currentFramePtr) < topLevel) { - return csc; - } - } + /* skip through toplevel inactive filters, do this offset times */ + for (csc=cs->top; csc > cs->content; csc--) { + /* fprintf(stderr, "csc %p callType = %x, frameType = %x, offset=%d\n", + csc,csc->callType,csc->frameType,offset); */ + if ((csc->callType & XOTCL_CSC_CALL_IS_NEXT) || + (csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) + continue; + if (offset) + offset--; + else { + /* fprintf(stderr, "csc %p offset ok, deeper=%d\n",csc,deeper); */ + if (!deeper || cs->top->callType & XOTCL_CSC_CALL_IS_GUARD) { + return csc; + } + if (csc->currentFramePtr && Tcl_CallFrame_level(csc->currentFramePtr) < topLevel) { + return csc; + } } - /* for some reasons, we could not find invocation (topLevel, destroy) */ - return NULL; + } + /* for some reasons, we could not find invocation (topLevel, destroy) */ + /* fprintf(stderr, "csc %p could not find invocation\n",csc);*/ + return NULL; } static XOTclCallStackContent * CallStackFindActiveFilter(Tcl_Interp *interp) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - register XOTclCallStackContent *csc; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *csc; - /* search for first active frame and set tcl frame pointers */ - for (csc=cs->top; csc > cs->content; csc --) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) return csc; - } - /* for some reasons, we could not find invocation (topLevel, destroy) */ - return NULL; + /* search for first active frame and set tcl frame pointers */ + for (csc=cs->top; csc > cs->content; csc --) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) return csc; + } + /* for some reasons, we could not find invocation (topLevel, destroy) */ + return NULL; } XOTclCallStackContent * XOTclCallStackFindActiveFrame(Tcl_Interp *interp, int offset) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - register XOTclCallStackContent *csc; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *csc; - /* search for first active frame and set tcl frame pointers */ - for (csc=cs->top-offset; csc > cs->content; csc --) { - if (!(csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) { - /* we found the highest active frame */ - return csc; - } + /* search for first active frame and set tcl frame pointers */ + for (csc=cs->top-offset; csc > cs->content; csc --) { + if (!(csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) { + /* we found the highest active frame */ + return csc; } - /* we could not find an active frame; called from toplevel? */ - return NULL; + } + /* we could not find an active frame; called from toplevel? */ + return NULL; } static void CallStackUseActiveFrames(Tcl_Interp *interp, callFrameContext *ctx) { - XOTclCallStackContent *active, *top = RUNTIME_STATE(interp)->cs.top; - Tcl_CallFrame *inFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); + XOTclCallStackContent *active, *top = RUNTIME_STATE(interp)->cs.top; + Tcl_CallFrame *inFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); - active = XOTclCallStackFindActiveFrame(interp, 0); - /*fprintf(stderr,"active %p, varFrame(interp) %p, topVarFrame %p, active->curr %p\n", - active, inFramePtr, top->currentFramePtr, - active? active->currentFramePtr : NULL);*/ + active = XOTclCallStackFindActiveFrame(interp, 0); + /*fprintf(stderr,"active %p, varFrame(interp) %p, topVarFrame %p, active->curr %p\n", + active, inFramePtr, top->currentFramePtr, + active? active->currentFramePtr : NULL);*/ - if (active == top || inFramePtr == NULL || Tcl_CallFrame_level(inFramePtr) == 0) { - /* top frame is a active frame, or we could not find a calling - frame, call frame pointers are fine */ - ctx->framesSaved = 0; - } else if (active == NULL) { - Tcl_CallFrame *cf = inFramePtr; - /*fprintf(stderr,"active == NULL\n"); */ - /* find a proc frame, which is not equal the top level cmd */ - /* XOTclStackDump(interp);*/ - for (; cf && Tcl_CallFrame_level(cf); cf = Tcl_CallFrame_callerPtr(cf)) { - if (Tcl_CallFrame_isProcCallFrame(cf) && cf != top->currentFramePtr) - break; - } - ctx->varFramePtr = inFramePtr; - Tcl_Interp_varFramePtr(interp) = (CallFrame *) cf; - ctx->framesSaved = 1; - } else { - Tcl_CallFrame *framePtr; - /*fprintf(stderr,"active == deeper active=%p frame %p, active+1 %p frame %p\n", - active, active->currentFramePtr, - active+1, (active+1)->currentFramePtr);*/ - /* search returned a deeper pointer, use stored tcl frame pointers; - If Tcl is mixed with XOTcl it is needed to use instead of - active->currentFrame the callerPtr of the last inactive frame - unless the last inactive is NULL */ - if ((framePtr = (active+1)->currentFramePtr)) - framePtr = Tcl_CallFrame_callerPtr(framePtr); - else - framePtr = active->currentFramePtr; - ctx->varFramePtr = inFramePtr; - Tcl_Interp_varFramePtr(interp) = (CallFrame *) framePtr; - ctx->framesSaved = 1; + if (active == top || inFramePtr == NULL || Tcl_CallFrame_level(inFramePtr) == 0) { + /* top frame is a active frame, or we could not find a calling + frame, call frame pointers are fine */ + ctx->framesSaved = 0; + } else if (active == NULL) { + Tcl_CallFrame *cf = inFramePtr; + /*fprintf(stderr,"active == NULL\n"); */ + /* find a proc frame, which is not equal the top level cmd */ + /* XOTclStackDump(interp);*/ + for (; cf && Tcl_CallFrame_level(cf); cf = Tcl_CallFrame_callerPtr(cf)) { + if (Tcl_CallFrame_isProcCallFrame(cf) && cf != top->currentFramePtr) + break; } + ctx->varFramePtr = inFramePtr; + Tcl_Interp_varFramePtr(interp) = (CallFrame *) cf; + ctx->framesSaved = 1; + } else { + Tcl_CallFrame *framePtr; + /*fprintf(stderr,"active == deeper active=%p frame %p, active+1 %p frame %p\n", + active, active->currentFramePtr, + active+1, (active+1)->currentFramePtr);*/ + /* search returned a deeper pointer, use stored tcl frame pointers; + If Tcl is mixed with XOTcl it is needed to use instead of + active->currentFrame the callerPtr of the last inactive frame + unless the last inactive is NULL */ + if ((framePtr = (active+1)->currentFramePtr)) + framePtr = Tcl_CallFrame_callerPtr(framePtr); + else + framePtr = active->currentFramePtr; + ctx->varFramePtr = inFramePtr; + Tcl_Interp_varFramePtr(interp) = (CallFrame *) framePtr; + ctx->framesSaved = 1; + } } static void CallStackRestoreSavedFrames(Tcl_Interp *interp, callFrameContext *ctx) { - if (ctx->framesSaved) { - Tcl_Interp_varFramePtr(interp) = (CallFrame *)ctx->varFramePtr; - /*RUNTIME_STATE(interp)->varFramePtr = ctx->varFramePtr;*/ + if (ctx->framesSaved) { + Tcl_Interp_varFramePtr(interp) = (CallFrame *)ctx->varFramePtr; + /*RUNTIME_STATE(interp)->varFramePtr = ctx->varFramePtr;*/ - } + } } XOTCLINLINE static int CallStackPush(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl, - Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int frameType) { - XOTclCallStack *cs; - register XOTclCallStackContent *csc; + Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int frameType) { + XOTclCallStack *cs; + register XOTclCallStackContent *csc; - cs = &RUNTIME_STATE(interp)->cs; - if (cs->top >= &cs->content[MAX_NESTING_DEPTH-1]) { - Tcl_SetResult(interp, "too many nested calls to Tcl_EvalObj (infinite loop?)", - TCL_STATIC); - return TCL_ERROR; - } - /*fprintf(stderr, "CallStackPush sets self\n");*/ - csc = ++cs->top; - csc->self = obj; - csc->cl = cl; - csc->cmdPtr = cmd; - csc->destroyedCmd = 0; - csc->frameType = frameType; - csc->callType = 0; - csc->currentFramePtr = NULL; /* this will be set by InitProcNSCmd */ + cs = &RUNTIME_STATE(interp)->cs; + if (cs->top >= &cs->content[MAX_NESTING_DEPTH-1]) { + Tcl_SetResult(interp, "too many nested calls to Tcl_EvalObj (infinite loop?)", + TCL_STATIC); + return TCL_ERROR; + } + /*fprintf(stderr, "CallStackPush sets self\n");*/ + csc = ++cs->top; + csc->self = obj; + csc->cl = cl; + csc->cmdPtr = cmd; + csc->destroyedCmd = NULL; + csc->frameType = frameType; + csc->callType = 0; + csc->currentFramePtr = NULL; /* this will be set by InitProcNSCmd */ - if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) - csc->filterStackEntry = obj->filterStack; - else - csc->filterStackEntry = 0; + if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) + csc->filterStackEntry = obj->filterStack; + else + csc->filterStackEntry = NULL; - /*fprintf(stderr, "PUSH obj %s, self=%p cmd=%p (%s) id=%p (%s) frame=%p\n", - ObjStr(obj->cmdName), obj, - cmd, (char *) Tcl_GetCommandName(interp, cmd), - obj->id, Tcl_GetCommandName(interp, obj->id), csc);*/ + /*fprintf(stderr, "PUSH obj %s, self=%p cmd=%p (%s) id=%p (%s) frame=%p\n", + ObjStr(obj->cmdName), obj, + cmd, (char *) Tcl_GetCommandName(interp, cmd), + obj->id, Tcl_GetCommandName(interp, obj->id), csc);*/ - MEM_COUNT_ALLOC("CallStack", NULL); - return TCL_OK; + MEM_COUNT_ALLOC("CallStack", NULL); + return TCL_OK; } XOTCLINLINE static void CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *obj) { - Tcl_Command oid; + Tcl_Command oid; - PRINTOBJ("CallStackDoDestroy", obj); - oid = obj->id; - obj->id = 0; - if (obj->teardown && oid) { - Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); - INCR_REF_COUNT(savedObjResult); - Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ - Tcl_SetObjResult(interp, savedObjResult); - DECR_REF_COUNT(savedObjResult); - } + PRINTOBJ("CallStackDoDestroy", obj); + oid = obj->id; + obj->id = NULL; + if (obj->teardown && oid) { + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + INCR_REF_COUNT(savedObjResult); + Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ + Tcl_SetObjResult(interp, savedObjResult); + DECR_REF_COUNT(savedObjResult); + } } static void CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *obj) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc; - int countSelfs = 0; - Tcl_Command oid = obj->id; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + int countSelfs = 0; + Tcl_Command oid = obj->id; - for (csc = &cs->content[1]; csc <= cs->top; csc++) { - if (csc->self == obj) { - csc->destroyedCmd = oid; - csc->callType |= XOTCL_CSC_CALL_IS_DESTROY; - /*fprintf(stderr,"setting destroy on frame %p for obj %p\n", csc, obj);*/ - if (csc->destroyedCmd) { - Tcl_Command_refCount(csc->destroyedCmd)++; - MEM_COUNT_ALLOC("command refCount", csc->destroyedCmd); - } - countSelfs++; - } + for (csc = &cs->content[1]; csc <= cs->top; csc++) { + if (csc->self == obj) { + csc->destroyedCmd = oid; + csc->callType |= XOTCL_CSC_CALL_IS_DESTROY; + /*fprintf(stderr,"setting destroy on frame %p for obj %p\n", csc, obj);*/ + if (csc->destroyedCmd) { + Tcl_Command_refCount(csc->destroyedCmd)++; + MEM_COUNT_ALLOC("command refCount", csc->destroyedCmd); + } + countSelfs++; } - /* if the object is not referenced at the callstack anymore - we have to directly destroy it, because CallStackPop won't - find the object destroy */ - if (countSelfs == 0) { - /*fprintf(stderr,"directdestroy %p\n", obj);*/ - CallStackDoDestroy(interp, obj); - } else { - /*fprintf(stderr,"selfcount for %p = %d\n", obj, countSelfs);*/ - /* to prevail the deletion order call delete children now - -> children destructors are called before parent's - destructor */ - if (obj->teardown && obj->nsPtr) { - NSDeleteChildren(interp, obj->nsPtr); - } + } + /* if the object is not referenced at the callstack anymore + we have to directly destroy it, because CallStackPop won't + find the object destroy */ + if (countSelfs == 0) { + /*fprintf(stderr,"directdestroy %p\n", obj);*/ + CallStackDoDestroy(interp, obj); + } else { + /*fprintf(stderr,"selfcount for %p = %d\n", obj, countSelfs);*/ + /* to prevail the deletion order call delete children now + -> children destructors are called before parent's + destructor */ + if (obj->teardown && obj->nsPtr) { + NSDeleteChildren(interp, obj->nsPtr); } + } } XOTCLINLINE static int CallStackIsDestroyed(Tcl_Interp *interp) { - return (RUNTIME_STATE(interp)->cs.top->destroyedCmd == NULL) ? 0 : 1; + return (RUNTIME_STATE(interp)->cs.top->destroyedCmd == NULL) ? 0 : 1; } XOTCLINLINE static void CallStackPop(Tcl_Interp *interp) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc; - XOTclCallStackContent *h = cs->top; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + XOTclCallStackContent *h = cs->top; - assert(cs->top > cs->content); - csc = cs->top; + assert(cs->top > cs->content); + csc = cs->top; - /*fprintf(stderr, "POP frame=%p\n", csc);*/ + /*fprintf(stderr, "POP frame=%p\n", csc);*/ - if (csc->destroyedCmd != 0) { - int destroy = 1; - TclCleanupCommand((Command *)csc->destroyedCmd); - MEM_COUNT_FREE("command refCount", csc->destroyedCmd); - /* do not physically destroy, when callstack still contains "self" - entries of the object */ - while (--h > cs->content) { - if (h->self == csc->self) { - destroy = 0; - break; - } - } - if (destroy) { - CallStackDoDestroy(interp, csc->self); - } + if (csc->destroyedCmd) { + int destroy = 1; + TclCleanupCommand((Command *)csc->destroyedCmd); + MEM_COUNT_FREE("command refCount", csc->destroyedCmd); + /* do not physically destroy, when callstack still contains "self" + entries of the object */ + while (--h > cs->content) { + if (h->self == csc->self) { + destroy = 0; + break; + } } + if (destroy) { + CallStackDoDestroy(interp, csc->self); + } + } - cs->top--; - MEM_COUNT_FREE("CallStack", NULL); + cs->top--; + MEM_COUNT_FREE("CallStack", NULL); } XOTCLINLINE static XOTclCallStackContent* CallStackGetTopFrame(Tcl_Interp *interp) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - return cs->top; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + return cs->top; } static XOTclCallStackContent* CallStackGetFrame(Tcl_Interp *interp) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - register XOTclCallStackContent *top = cs->top; - Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *top = cs->top; + Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - if (Tcl_Interp_framePtr(interp) != varFramePtr && top->currentFramePtr) { - XOTclCallStackContent *bot = cs->content + 1; + /* fprintf(stderr, "Tcl_Interp_framePtr(interp) %p != varFramePtr %p && top->currentFramePtr %p\n", Tcl_Interp_framePtr(interp), varFramePtr, top->currentFramePtr);*/ + if (Tcl_Interp_framePtr(interp) != varFramePtr && top->currentFramePtr) { + XOTclCallStackContent *bot = cs->content + 1; - /* we are in a uplevel */ - while (varFramePtr != top->currentFramePtr && top>bot) { - top--; - } + /* we are in a uplevel */ + while (varFramePtr != top->currentFramePtr && top>bot) { + top--; } - return top; + } + return top; } /* @@ -2552,73 +2666,73 @@ */ static XOTclCmdList* CmdListAdd(XOTclCmdList **cList, Tcl_Command c, XOTclClass *clorobj, int noDuplicates) { - XOTclCmdList *l = *cList, *new; + XOTclCmdList *l = *cList, *new; - /* - * check for duplicates, if necessary - */ - if (noDuplicates) { - XOTclCmdList *h = l, **end = NULL; - while (h) { - if (h->cmdPtr == c) - return h; - end = &(h->nextPtr); - h = h->nextPtr; - } - if (end) { - /* no duplicates, no need to search below, we are at the end of the list */ - cList = end; - l = NULL; - } + /* + * check for duplicates, if necessary + */ + if (noDuplicates) { + XOTclCmdList *h = l, **end = NULL; + while (h) { + if (h->cmdPtr == c) + return h; + end = &(h->nextPtr); + h = h->nextPtr; } + if (end) { + /* no duplicates, no need to search below, we are at the end of the list */ + cList = end; + l = NULL; + } + } - /* - * ok, we have no duplicates -> append "new" - * to the end of the list - */ - new = NEW(XOTclCmdList); - new->cmdPtr = c; - Tcl_Command_refCount(new->cmdPtr)++; - MEM_COUNT_ALLOC("command refCount", new->cmdPtr); - new->clientData = NULL; - new->clorobj = clorobj; - new->nextPtr = NULL; + /* + * ok, we have no duplicates -> append "new" + * to the end of the list + */ + new = NEW(XOTclCmdList); + new->cmdPtr = c; + Tcl_Command_refCount(new->cmdPtr)++; + MEM_COUNT_ALLOC("command refCount", new->cmdPtr); + new->clientData = NULL; + new->clorobj = clorobj; + new->nextPtr = NULL; - if (l) { - while (l->nextPtr) - l = l->nextPtr; - l->nextPtr = new; - } else - *cList = new; - return new; + if (l) { + while (l->nextPtr) + l = l->nextPtr; + l->nextPtr = new; + } else + *cList = new; + return new; } static void CmdListReplaceCmd(XOTclCmdList *replace, Tcl_Command cmd, XOTclClass *clorobj) { - Tcl_Command del = replace->cmdPtr; - replace->cmdPtr = cmd; - replace->clorobj = clorobj; - Tcl_Command_refCount(cmd)++; - MEM_COUNT_ALLOC("command refCount", cmd); - TclCleanupCommand((Command *)del); - MEM_COUNT_FREE("command refCount", cmd); + Tcl_Command del = replace->cmdPtr; + replace->cmdPtr = cmd; + replace->clorobj = clorobj; + Tcl_Command_refCount(cmd)++; + MEM_COUNT_ALLOC("command refCount", cmd); + TclCleanupCommand((Command *)del); + MEM_COUNT_FREE("command refCount", cmd); } #if 0 /** for debug purposes only */ static void CmdListPrint(Tcl_Interp *interp, char *title, XOTclCmdList *cmdList) { - if (cmdList) - fprintf(stderr, title); - while (cmdList) { - fprintf(stderr, " CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n", - cmdList, - cmdList->cmdPtr, - in ? Tcl_GetCommandName(interp, cmdList->cmdPtr) : "", - cmdList->clorobj, - cmdList->clientData); - cmdList = cmdList->nextPtr; - } + if (cmdList) + fprintf(stderr, title); + while (cmdList) { + fprintf(stderr, " CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n", + cmdList, + cmdList->cmdPtr, + in ? Tcl_GetCommandName(interp, cmdList->cmdPtr) : "", + cmdList->clorobj, + cmdList->clientData); + cmdList = cmdList->next; + } } #endif @@ -2627,11 +2741,11 @@ */ static void CmdListDeleteCmdListEntry(XOTclCmdList *del, XOTclFreeCmdListClientData *freeFct) { - if (freeFct) - (*freeFct)(del); - MEM_COUNT_FREE("command refCount", del->cmdPtr); - TclCleanupCommand((Command *)del->cmdPtr); - FREE(XOTclCmdList, del); + if (freeFct) + (*freeFct)(del); + MEM_COUNT_FREE("command refCount", del->cmdPtr); + TclCleanupCommand((Command *)del->cmdPtr); + FREE(XOTclCmdList, del); } /* @@ -2640,39 +2754,39 @@ */ static XOTclCmdList* CmdListRemoveFromList(XOTclCmdList **cmdList, XOTclCmdList *delCL) { - register XOTclCmdList *c = *cmdList, *del = 0; - if (c == 0) - return NULL; - if (c == delCL) { - *cmdList = c->nextPtr; - del = c; - } else { - while (c->nextPtr && c->nextPtr != delCL) { - c = c->nextPtr; - } - if (c->nextPtr == delCL) { - del = delCL; - c->nextPtr = delCL->nextPtr; - } + register XOTclCmdList *c = *cmdList, *del = NULL; + if (c == NULL) + return NULL; + if (c == delCL) { + *cmdList = c->nextPtr; + del = c; + } else { + while (c->nextPtr && c->nextPtr != delCL) { + c = c->nextPtr; } - return del; + if (c->nextPtr == delCL) { + del = delCL; + c->nextPtr = delCL->nextPtr; + } + } + return del; } /* * remove all command pointers from a list that have a bumped epoch */ static void CmdListRemoveEpoched(XOTclCmdList **cmdList, XOTclFreeCmdListClientData *freeFct) { - XOTclCmdList *f = *cmdList, *del; - while (f) { - if (Tcl_Command_cmdEpoch(f->cmdPtr)) { - del = f; - f = f->nextPtr; - del = CmdListRemoveFromList(cmdList, del); - CmdListDeleteCmdListEntry(del, freeFct); - } else - f = f->nextPtr; - } + XOTclCmdList *f = *cmdList, *del; + while (f) { + if (Tcl_Command_cmdEpoch(f->cmdPtr)) { + del = f; + f = f->nextPtr; + del = CmdListRemoveFromList(cmdList, del); + CmdListDeleteCmdListEntry(del, freeFct); + } else + f = f->nextPtr; + } } @@ -2682,42 +2796,43 @@ static void CmdListRemoveContextClassFromList(XOTclCmdList **cmdList, XOTclClass *clorobj, XOTclFreeCmdListClientData *freeFct) { - XOTclCmdList *c, *del = 0; - /* - CmdListRemoveEpoched(cmdList, freeFct); - */ + XOTclCmdList *c, *del = NULL; + /* + CmdListRemoveEpoched(cmdList, freeFct); + */ + c = *cmdList; + while (c && c->clorobj == clorobj) { + del = c; + *cmdList = c->nextPtr; + CmdListDeleteCmdListEntry(del, freeFct); c = *cmdList; - while (c && c->clorobj == clorobj) { - del = c; - *cmdList = c->nextPtr; - CmdListDeleteCmdListEntry(del, freeFct); - c = *cmdList; + } + + while (c) { + if (c->clorobj == clorobj) { + del = c; + c = *cmdList; + while (c->nextPtr && c->nextPtr != del) + c = c->nextPtr; + if (c->nextPtr == del) + c->nextPtr = del->nextPtr; + CmdListDeleteCmdListEntry(del, freeFct); } - while (c) { - if (c->clorobj == clorobj) { - del = c; - c = *cmdList; - while (c->nextPtr && c->nextPtr != del) - c = c->nextPtr; - if (c->nextPtr == del) - c->nextPtr = del->nextPtr; - CmdListDeleteCmdListEntry(del, freeFct); - } - c = c->nextPtr; - } + c = c->nextPtr; + } } /* * free the memory of a whole 'cmdList' */ static void CmdListRemoveList(XOTclCmdList **cmdList, XOTclFreeCmdListClientData *freeFct) { - XOTclCmdList *del; - while (*cmdList) { - del = *cmdList; - *cmdList = (*cmdList)->nextPtr; - CmdListDeleteCmdListEntry(del, freeFct); - } + XOTclCmdList *del; + while (*cmdList) { + del = *cmdList; + *cmdList = (*cmdList)->nextPtr; + CmdListDeleteCmdListEntry(del, freeFct); + } } /* @@ -2726,13 +2841,12 @@ */ static XOTclCmdList* CmdListFindCmdInList(Tcl_Command cmd, XOTclCmdList *l) { - register XOTclCmdList *h = l; - while (h != 0) { - if (h->cmdPtr == cmd) - return h; - h = h->nextPtr; - } - return 0; + register XOTclCmdList *h; + for (h = l; h; h = h->nextPtr) { + if (h->cmdPtr == cmd) + return h; + } + return 0; } /* @@ -2741,145 +2855,143 @@ */ static XOTclCmdList* CmdListFindNameInList(Tcl_Interp *interp, char *name, XOTclCmdList *l) { - register XOTclCmdList *h = l; - while (h != 0) { - CONST84 char *cmdName = Tcl_GetCommandName(interp, h->cmdPtr); - if (cmdName[0] == name[0] && !strcmp(cmdName, name)) - return h; - h = h->nextPtr; - } - return 0; + register XOTclCmdList *h; + for (h = l; h; h = h->nextPtr) { + CONST84 char *cmdName = Tcl_GetCommandName(interp, h->cmdPtr); + if (cmdName[0] == name[0] && !strcmp(cmdName, name)) + return h; + } + return 0; } /* * Assertions */ static XOTclTclObjList* AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj) { - Tcl_Obj **ov; int oc; - XOTclTclObjList *last = NULL; + Tcl_Obj **ov; int oc; + XOTclTclObjList *last = NULL; - if (Tcl_ListObjGetElements(interp, aObj, &oc, &ov) == TCL_OK) { - if (oc > 0) { - int i; - for (i=oc-1; i>=0; i--) { - TclObjListNewElement(&last, ov[i]); - } - } + if (Tcl_ListObjGetElements(interp, aObj, &oc, &ov) == TCL_OK) { + if (oc > 0) { + int i; + for (i=oc-1; i>=0; i--) { + TclObjListNewElement(&last, ov[i]); + } } - return last; + } + return last; } static Tcl_Obj * AssertionList(Tcl_Interp *interp, XOTclTclObjList *alist) { - Tcl_Obj *newAssStr = Tcl_NewStringObj("", 0); - for (; alist!=NULL; alist = alist->nextPtr) { - Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content), - "}", (char *) NULL); - if (alist->nextPtr != NULL) - Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL); - } - return newAssStr; + Tcl_Obj *newAssStr = Tcl_NewStringObj("", 0); + for (; alist; alist = alist->nextPtr) { + Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content), + "}", (char *) NULL); + if (alist->nextPtr) + Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL); + } + return newAssStr; } /* append a string of pre and post assertions to a proc or instproc body */ static void AssertionAppendPrePost(Tcl_Interp *interp, Tcl_DString *dsPtr, XOTclProcAssertion *procs) { - if (procs) { - Tcl_Obj *preAss = AssertionList(interp, procs->pre); - Tcl_Obj *postAss = AssertionList(interp, procs->post); - INCR_REF_COUNT(preAss); INCR_REF_COUNT(postAss); - Tcl_DStringAppendElement(dsPtr, ObjStr(preAss)); - Tcl_DStringAppendElement(dsPtr, ObjStr(postAss)); - DECR_REF_COUNT(preAss); DECR_REF_COUNT(postAss); - } + if (procs) { + Tcl_Obj *preAss = AssertionList(interp, procs->pre); + Tcl_Obj *postAss = AssertionList(interp, procs->post); + INCR_REF_COUNT(preAss); INCR_REF_COUNT(postAss); + Tcl_DStringAppendElement(dsPtr, ObjStr(preAss)); + Tcl_DStringAppendElement(dsPtr, ObjStr(postAss)); + DECR_REF_COUNT(preAss); DECR_REF_COUNT(postAss); + } } static int AssertionListCheckOption(Tcl_Interp *interp, XOTclObject *obj) { - XOTclObjectOpt *opt = obj->opt; - if (!opt) - return TCL_OK; - if (opt->checkoptions & CHECK_OBJINVAR) - Tcl_AppendElement(interp, "invar"); - if (opt->checkoptions & CHECK_CLINVAR) - Tcl_AppendElement(interp, "instinvar"); - if (opt->checkoptions & CHECK_PRE) - Tcl_AppendElement(interp, "pre"); - if (opt->checkoptions & CHECK_POST) - Tcl_AppendElement(interp, "post"); + XOTclObjectOpt *opt = obj->opt; + if (!opt) return TCL_OK; + if (opt->checkoptions & CHECK_OBJINVAR) + Tcl_AppendElement(interp, "invar"); + if (opt->checkoptions & CHECK_CLINVAR) + Tcl_AppendElement(interp, "instinvar"); + if (opt->checkoptions & CHECK_PRE) + Tcl_AppendElement(interp, "pre"); + if (opt->checkoptions & CHECK_POST) + Tcl_AppendElement(interp, "post"); + return TCL_OK; } static XOTclProcAssertion* AssertionFindProcs(XOTclAssertionStore *aStore, char *name) { - Tcl_HashEntry *hPtr; - if (aStore == NULL) return NULL; - hPtr = Tcl_FindHashEntry(&aStore->procs, name); - if (hPtr == NULL) return NULL; - return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); + Tcl_HashEntry *hPtr; + if (aStore == NULL) return NULL; + hPtr = XOTcl_FindHashEntry(&aStore->procs, name); + if (hPtr == NULL) return NULL; + return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); } static void AssertionRemoveProc(XOTclAssertionStore *aStore, char *name) { - Tcl_HashEntry *hPtr; - if (aStore) { - hPtr = Tcl_FindHashEntry(&aStore->procs, name); - if (hPtr) { - XOTclProcAssertion *procAss = - (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); - TclObjListFreeList(procAss->pre); - TclObjListFreeList(procAss->post); - FREE(XOTclProcAssertion, procAss); - Tcl_DeleteHashEntry(hPtr); - } + Tcl_HashEntry *hPtr; + if (aStore) { + hPtr = XOTcl_FindHashEntry(&aStore->procs, name); + if (hPtr) { + XOTclProcAssertion *procAss = + (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); + TclObjListFreeList(procAss->pre); + TclObjListFreeList(procAss->post); + FREE(XOTclProcAssertion, procAss); + Tcl_DeleteHashEntry(hPtr); } + } } static void AssertionAddProc(Tcl_Interp *interp, char *name, XOTclAssertionStore *aStore, - Tcl_Obj *pre, Tcl_Obj *post) { - int nw = 0; - Tcl_HashEntry *hPtr = NULL; - XOTclProcAssertion *procs = NEW(XOTclProcAssertion); + Tcl_Obj *pre, Tcl_Obj *post) { + int nw = 0; + Tcl_HashEntry *hPtr = NULL; + XOTclProcAssertion *procs = NEW(XOTclProcAssertion); - AssertionRemoveProc(aStore, name); - procs->pre = AssertionNewList(interp, pre); - procs->post = AssertionNewList(interp, post); - hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &nw); - if (nw) Tcl_SetHashValue(hPtr, (ClientData)procs); + AssertionRemoveProc(aStore, name); + procs->pre = AssertionNewList(interp, pre); + procs->post = AssertionNewList(interp, post); + hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &nw); + if (nw) Tcl_SetHashValue(hPtr, (ClientData)procs); } static XOTclAssertionStore* AssertionCreateStore() { - XOTclAssertionStore *aStore = NEW(XOTclAssertionStore); - aStore->invariants = NULL; - Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",&aStore->procs); - return aStore; + XOTclAssertionStore *aStore = NEW(XOTclAssertionStore); + aStore->invariants = NULL; + Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",&aStore->procs); + return aStore; } static void AssertionRemoveStore(XOTclAssertionStore *aStore) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; - if (aStore) { - hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); - while (hPtr) { - /* - * AssertionRemoveProc calls Tcl_DeleteHashEntry(hPtr), thus - * we get the FirstHashEntry afterwards again to proceed - */ - AssertionRemoveProc(aStore, Tcl_GetHashKey(&aStore->procs, hPtr)); - hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); - } - Tcl_DeleteHashTable(&aStore->procs); - MEM_COUNT_FREE("Tcl_InitHashTable",&aStore->procs); - TclObjListFreeList(aStore->invariants); - FREE(XOTclAssertionStore, aStore); + if (aStore) { + for (hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); hPtr; + hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch)) { + /* + * AssertionRemoveProc calls Tcl_DeleteHashEntry(hPtr), thus + * we get the FirstHashEntry afterwards again to proceed + */ + AssertionRemoveProc(aStore, Tcl_GetHashKey(&aStore->procs, hPtr)); } + Tcl_DeleteHashTable(&aStore->procs); + MEM_COUNT_FREE("Tcl_InitHashTable",&aStore->procs); + TclObjListFreeList(aStore->invariants); + FREE(XOTclAssertionStore, aStore); + } } /* @@ -2888,163 +3000,163 @@ */ static int checkConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition) { - int result, success; - Tcl_Obj *ov[2] = {NULL, condition}; + int result, success; + Tcl_Obj *ov[2] = {NULL, condition}; - INCR_REF_COUNT(condition); - result = XOTcl_ExprObjCmd(NULL, interp, 2, ov); - DECR_REF_COUNT(condition); - - if (result == TCL_OK) { - result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp),&success); - if (result == TCL_OK && success == 0) - result = XOTCL_CHECK_FAILED; - } - return result; + INCR_REF_COUNT(condition); + result = XOTcl_ExprObjCmd(NULL, interp, 2, ov); + DECR_REF_COUNT(condition); + + if (result == TCL_OK) { + result = Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp),&success); + + if (result == TCL_OK && success == 0) + result = XOTCL_CHECK_FAILED; + } + return result; } static int AssertionCheckList(Tcl_Interp *interp, XOTclObject *obj, - XOTclTclObjList *alist, char *methodName) { - XOTclTclObjList *checkFailed = NULL; - Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); - int savedCheckoptions, acResult = TCL_OK; + XOTclTclObjList *alist, char *methodName) { + XOTclTclObjList *checkFailed = NULL; + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + int savedCheckoptions, acResult = TCL_OK; - /* - * no obj->opt -> checkoption == CHECK_NONE - */ - if (!obj->opt) - return TCL_OK; + /* + * no obj->opt -> checkoption == CHECK_NONE + */ + if (!obj->opt) + return TCL_OK; - /* we do not check assertion modifying methods, otherwise - we can not react in catch on a runtime assertion check failure */ - if (isCheckString(methodName) || isInfoString(methodName) || - isInvarString(methodName) || isInstinvarString(methodName) || - isProcString(methodName) || isInstprocString(methodName)) - return TCL_OK; + /* we do not check assertion modifying methods, otherwise + we can not react in catch on a runtime assertion check failure */ + if (isCheckString(methodName) || isInfoString(methodName) || + isInvarString(methodName) || isInstinvarString(methodName) || + isProcString(methodName) || isInstprocString(methodName)) + return TCL_OK; - INCR_REF_COUNT(savedObjResult); + INCR_REF_COUNT(savedObjResult); - Tcl_ResetResult(interp); + Tcl_ResetResult(interp); - while (alist != NULL) { - /* Eval instead of IfObjCmd => the substitutions in the - conditions will be done by Tcl */ - char *assStr = ObjStr(alist->content), *c = assStr; - int comment = 0; + while (alist) { + /* Eval instead of IfObjCmd => the substitutions in the + conditions will be done by Tcl */ + char *assStr = ObjStr(alist->content), *c = assStr; + int comment = 0; - while (c != 0 && *c != '\0') { - if (*c == '#') { - comment = 1; break; - } - c++; - } - if (!comment) { - XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); - CallStackPush(interp, obj, 0, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); + for (; c && *c != '\0'; c++) { + if (*c == '#') { + comment = 1; break; + } + } - /* don't check assertion during assertion check */ - savedCheckoptions = obj->opt->checkoptions; - obj->opt->checkoptions = CHECK_NONE; + if (!comment) { + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); + CallStackPush(interp, obj, 0, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); - /*fprintf(stderr, "Checking Assertion %s ", assStr);*/ + /* don't check assertion during assertion check */ + savedCheckoptions = obj->opt->checkoptions; + obj->opt->checkoptions = CHECK_NONE; - /* - * now check the assertion in the pushed callframe's scope - */ - acResult = checkConditionInScope(interp, alist->content); - if (acResult != TCL_OK) - checkFailed = alist; + /* fprintf(stderr, "Checking Assertion %s ", assStr); */ - obj->opt->checkoptions = savedCheckoptions; + /* + * now check the assertion in the pushed callframe's scope + */ + acResult = checkConditionInScope(interp, alist->content); + if (acResult != TCL_OK) + checkFailed = alist; - /*fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok");*/ + obj->opt->checkoptions = savedCheckoptions; - CallStackPop(interp); - XOTcl_PopFrame(interp, obj); - } - if (checkFailed) - break; - alist = alist->nextPtr; + /* fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok"); */ + + CallStackPop(interp); + XOTcl_PopFrame(interp, obj); } + if (checkFailed) + break; + alist = alist->nextPtr; + } - if (checkFailed != NULL) { - DECR_REF_COUNT(savedObjResult); - if (acResult == TCL_ERROR) { - Tcl_Obj *sr = Tcl_GetObjResult(interp); - INCR_REF_COUNT(sr); - XOTclVarErrMsg(interp, "Error in Assertion: {", - ObjStr(checkFailed->content), "} in proc '", - GetSelfProc(interp), "'\n\n", ObjStr(sr), (char *) NULL); - DECR_REF_COUNT(sr); - return TCL_ERROR; - } - - return XOTclVarErrMsg(interp, "Assertion failed check: {", - ObjStr(checkFailed->content), "} in proc '", - GetSelfProc(interp), "'", (char *) NULL); + if (checkFailed) { + DECR_REF_COUNT(savedObjResult); + if (acResult == TCL_ERROR) { + Tcl_Obj *sr = Tcl_GetObjResult(interp); + INCR_REF_COUNT(sr); + XOTclVarErrMsg(interp, "Error in Assertion: {", + ObjStr(checkFailed->content), "} in proc '", + GetSelfProc(interp), "'\n\n", ObjStr(sr), (char *) NULL); + DECR_REF_COUNT(sr); + return TCL_ERROR; } + return XOTclVarErrMsg(interp, "Assertion failed check: {", + ObjStr(checkFailed->content), "} in proc '", + GetSelfProc(interp), "'", (char *) NULL); + } - Tcl_SetObjResult(interp, savedObjResult); - DECR_REF_COUNT(savedObjResult); - return TCL_OK; + Tcl_SetObjResult(interp, savedObjResult); + DECR_REF_COUNT(savedObjResult); + return TCL_OK; } static int AssertionCheckInvars(Tcl_Interp *interp, XOTclObject *obj, char *method, - CheckOptions checkoptions) { - int result = TCL_OK; + CheckOptions checkoptions) { + int result = TCL_OK; - if (checkoptions & CHECK_OBJINVAR && obj->opt->assertions) { - result = AssertionCheckList(interp, obj, obj->opt->assertions->invariants, - method); - } + if (checkoptions & CHECK_OBJINVAR && obj->opt->assertions) { + result = AssertionCheckList(interp, obj, obj->opt->assertions->invariants, + method); + } - if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { - XOTclClasses *clPtr; - clPtr = ComputeOrder(obj->cl, obj->cl->order, Super); - while (clPtr != 0 && result != TCL_ERROR) { - XOTclAssertionStore *aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0; - if (aStore) { - result = AssertionCheckList(interp, obj, aStore->invariants, method); - } - clPtr = clPtr->nextPtr; - } + if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { + XOTclClasses *clPtr; + clPtr = ComputeOrder(obj->cl, obj->cl->order, Super); + while (clPtr && result != TCL_ERROR) { + XOTclAssertionStore *aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0; + if (aStore) { + result = AssertionCheckList(interp, obj, aStore->invariants, method); + } + clPtr = clPtr->nextPtr; } - return result; + } + return result; } static int AssertionCheck(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl, - char *method, int checkOption) { - XOTclProcAssertion *procs; - int result = TCL_OK; - XOTclAssertionStore *aStore; + char *method, int checkOption) { + XOTclProcAssertion *procs; + int result = TCL_OK; + XOTclAssertionStore *aStore; - if (cl) - aStore = cl->opt ? cl->opt->assertions : 0; - else - aStore = obj->opt ? obj->opt->assertions : 0; + if (cl) + aStore = cl->opt ? cl->opt->assertions : 0; + else + aStore = obj->opt ? obj->opt->assertions : 0; - assert(obj->opt); + assert(obj->opt); - if (checkOption & obj->opt->checkoptions) { - procs = AssertionFindProcs(aStore, method); - if (procs) { - switch (checkOption) { - case CHECK_PRE: - result = AssertionCheckList(interp, obj, procs->pre, method); - break; - case CHECK_POST: - result = AssertionCheckList(interp, obj, procs->post, method); - break; - } - } - if (result != TCL_ERROR) - result = AssertionCheckInvars(interp, obj, method, obj->opt->checkoptions); + if (checkOption & obj->opt->checkoptions) { + procs = AssertionFindProcs(aStore, method); + if (procs) { + switch (checkOption) { + case CHECK_PRE: + result = AssertionCheckList(interp, obj, procs->pre, method); + break; + case CHECK_POST: + result = AssertionCheckList(interp, obj, procs->post, method); + break; + } } - return result; + if (result != TCL_ERROR) + result = AssertionCheckInvars(interp, obj, method, obj->opt->checkoptions); + } + return result; } @@ -3059,85 +3171,83 @@ */ static int MixinStackPush(XOTclObject *obj) { - register XOTclMixinStack *h = NEW(XOTclMixinStack); - h->currentCmdPtr = 0; - h->nextPtr = obj->mixinStack; - obj->mixinStack = h; - return 1; + register XOTclMixinStack *h = NEW(XOTclMixinStack); + h->currentCmdPtr = NULL; + h->nextPtr = obj->mixinStack; + obj->mixinStack = h; + return 1; } /* * pop a mixin stack information on this object */ static void MixinStackPop(XOTclObject *obj) { - register XOTclMixinStack *h = obj->mixinStack; - obj->mixinStack = h->nextPtr; - FREE(XOTclMixinStack, h); + register XOTclMixinStack *h = obj->mixinStack; + obj->mixinStack = h->nextPtr; + FREE(XOTclMixinStack, h); } /* - * Appends XOTclClasses* containing the mixin classes and their + * Appends XOTclClasses *containing the mixin classes and their * superclasses to 'mixinClasses' list from a given mixinList */ static void MixinComputeOrderFullList(Tcl_Interp *interp, XOTclCmdList **mixinList, - XOTclClasses **mixinClasses, - XOTclClasses **checkList, int level) { - XOTclCmdList *m; - XOTclClasses *pl, **clPtr = mixinClasses; + XOTclClasses **mixinClasses, + XOTclClasses **checkList, int level) { + XOTclCmdList *m; + XOTclClasses *pl, **clPtr = mixinClasses; - CmdListRemoveEpoched(mixinList, GuardDel); - m = *mixinList; + CmdListRemoveEpoched(mixinList, GuardDel); - while (m) { - XOTclClass *mCl = XOTclGetClassFromCmdPtr(m->cmdPtr); - if (mCl) { - for (pl = ComputeOrder(mCl, mCl->order, Super); pl; pl = pl->nextPtr) { - /*fprintf(stderr, " %s, ", ObjStr(pl->cl->object.cmdName));*/ - if (!(pl->cl == RUNTIME_STATE(interp)->theObject)) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->instmixins != 0) { - /* compute transitively the instmixin classes of this added - class */ - XOTclClasses *cls; - int i, found=0; - for (i=0, cls = *checkList; cls; i++, cls = cls->nextPtr) { - /* fprintf(stderr,"+++ c%d: %s\n", i, - ObjStr(cls->cl->object.cmdName));*/ - if (pl->cl == cls->cl) { - found = 1; - break; - } - } - if (!found) { - XOTclClassListAdd(checkList, pl->cl, NULL); - /*fprintf(stderr, "+++ transitive %s\n", - ObjStr(pl->cl->object.cmdName));*/ + for (m = *mixinList; m; m = m->nextPtr) { + XOTclClass *mCl = XOTclGetClassFromCmdPtr(m->cmdPtr); + if (mCl) { + for (pl = ComputeOrder(mCl, mCl->order, Super); pl; pl = pl->nextPtr) { + /*fprintf(stderr, " %s, ", ObjStr(pl->cl->object.cmdName));*/ + if (pl->cl != RUNTIME_STATE(interp)->theObject) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instmixins) { + /* compute transitively the instmixin classes of this added + class */ + XOTclClasses *cls; + int i, found = 0; + for (i=0, cls = *checkList; cls; i++, cls = cls->nextPtr) { + /* fprintf(stderr,"+++ c%d: %s\n", i, + ObjStr(cls->cl->object.cmdName));*/ + if (pl->cl == cls->cl) { + found = 1; + break; + } + } + if (!found) { + XOTclClassListAdd(checkList, pl->cl, NULL); + /*fprintf(stderr, "+++ transitive %s\n", + ObjStr(pl->cl->object.cmdName));*/ - MixinComputeOrderFullList(interp, &opt->instmixins, mixinClasses, - checkList, level+1); - } - } - /* fprintf(stderr,"+++ add to mixinClasses %p path: %s clPtr %p\n", - mixinClasses, ObjStr(pl->cl->object.cmdName), clPtr);*/ - clPtr = XOTclClassListAdd(clPtr, pl->cl, m->clientData); - } + MixinComputeOrderFullList(interp, &opt->instmixins, mixinClasses, + checkList, level+1); } + } + /* fprintf(stderr,"+++ add to mixinClasses %p path: %s clPtr %p\n", + mixinClasses, ObjStr(pl->cl->object.cmdName), clPtr);*/ + clPtr = XOTclClassListAdd(clPtr, pl->cl, m->clientData); } - m = m->nextPtr; + } } - if (level == 0 && *checkList) { - XOTclClassListFree(*checkList); - *checkList = NULL; - } + } + if (level == 0 && *checkList) { + XOTclClassListFree(*checkList); + *checkList = NULL; + } } static void MixinResetOrder(XOTclObject *obj) { - /*fprintf(stderr,"removeList %s \n", ObjStr(obj->cmdName));*/ - CmdListRemoveList(&obj->mixinOrder, NULL /*GuardDel*/); - obj->mixinOrder = 0; + /*fprintf(stderr,"removeList %s \n", ObjStr(obj->cmdName));*/ + CmdListRemoveList(&obj->mixinOrder, NULL /*GuardDel*/); + obj->mixinOrder = NULL; } /* @@ -3149,74 +3259,74 @@ */ static void MixinComputeOrder(Tcl_Interp *interp, XOTclObject *obj) { - XOTclClasses *fullList, *checkList=0, *mixinClasses = 0, *nextCl, *pl, - *checker, *guardChecker; + XOTclClasses *fullList, *checkList = NULL, *mixinClasses = NULL, *nextCl, *pl, + *checker, *guardChecker; - if (obj->mixinOrder) MixinResetOrder(obj); - /*fprintf(stderr, "Mixin Order:\n First List: ");*/ + if (obj->mixinOrder) MixinResetOrder(obj); + /*fprintf(stderr, "Mixin Order:\n First List: ");*/ - /* append per-obj mixins */ - if (obj->opt) { - MixinComputeOrderFullList(interp, &obj->opt->mixins, &mixinClasses, - &checkList, 0); - } + /* append per-obj mixins */ + if (obj->opt) { + MixinComputeOrderFullList(interp, &obj->opt->mixins, &mixinClasses, + &checkList, 0); + } - /* append per-class mixins */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->instmixins) { - MixinComputeOrderFullList(interp, &opt->instmixins, &mixinClasses, - &checkList, 0); - } + /* append per-class mixins */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instmixins) { + MixinComputeOrderFullList(interp, &opt->instmixins, &mixinClasses, + &checkList, 0); } - fullList = mixinClasses; + } + fullList = mixinClasses; - /* use no duplicates & no classes of the precedence order - on the resulting list */ - while (mixinClasses) { - checker = nextCl = mixinClasses->nextPtr; - /* fprintf(stderr,"--- checking %s\n", - ObjStr(mixinClasses->cl->object.cmdName));*/ + /* use no duplicates & no classes of the precedence order + on the resulting list */ + while (mixinClasses) { + checker = nextCl = mixinClasses->nextPtr; + /* fprintf(stderr,"--- checking %s\n", + ObjStr(mixinClasses->cl->object.cmdName));*/ - while (checker) { - if (checker->cl == mixinClasses->cl) break; - checker = checker->nextPtr; - } - /* if checker is set, it is a duplicate and ignored */ + while (checker) { + if (checker->cl == mixinClasses->cl) break; + checker = checker->nextPtr; + } + /* if checker is set, it is a duplicate and ignored */ - if (checker == 0) { - /* check obj->cl hierachy */ - for (checker = ComputeOrder(obj->cl, obj->cl->order, Super); checker; checker = checker->nextPtr) { - if (checker->cl == mixinClasses->cl) - break; - } - /* if checker is set, it was found in the class hierarchy - and it is ignored */ - } - if (checker == 0) { - /* add the class to the mixinOrder list */ - XOTclCmdList *new; - /* fprintf(stderr,"--- adding to mixinlist %s\n", - ObjStr(mixinClasses->cl->object.cmdName));*/ - new = CmdListAdd(&obj->mixinOrder, mixinClasses->cl->object.id, NULL, - /*noDuplicates*/ 0); + if (checker == NULL) { + /* check obj->cl hierachy */ + for (checker = ComputeOrder(obj->cl, obj->cl->order, Super); checker; checker = checker->nextPtr) { + if (checker->cl == mixinClasses->cl) + break; + } + /* if checker is set, it was found in the class hierarchy + and it is ignored */ + } + if (checker == NULL) { + /* add the class to the mixinOrder list */ + XOTclCmdList *new; + /* fprintf(stderr,"--- adding to mixinlist %s\n", + ObjStr(mixinClasses->cl->object.cmdName));*/ + new = CmdListAdd(&obj->mixinOrder, mixinClasses->cl->object.id, NULL, + /*noDuplicates*/ 0); - /* in the client data of the order list, we require the first - matching guard ... scan the full list for it. */ - for (guardChecker = fullList; guardChecker; guardChecker = guardChecker->nextPtr) { - if (guardChecker->cl == mixinClasses->cl) { - new->clientData = guardChecker->clientData; - break; - } - } + /* in the client data of the order list, we require the first + matching guard ... scan the full list for it. */ + for (guardChecker = fullList; guardChecker; guardChecker = guardChecker->nextPtr) { + if (guardChecker->cl == mixinClasses->cl) { + new->clientData = guardChecker->clientData; + break; } - mixinClasses = nextCl; + } } + mixinClasses = nextCl; + } - /* ... and free the memory of the full list */ - XOTclClassListFree(fullList); + /* ... and free the memory of the full list */ + XOTclClassListFree(fullList); - /*CmdListPrint(interp,"mixin order\n", obj->mixinOrder);*/ + /*CmdListPrint(interp,"mixin order\n", obj->mixinOrder);*/ } @@ -3225,331 +3335,594 @@ */ static int MixinAdd(Tcl_Interp *interp, XOTclCmdList **mixinList, Tcl_Obj *name, XOTclClass *base) { - XOTclClass *mixin; - Tcl_Obj *guard = NULL; - int ocName; Tcl_Obj **ovName; - XOTclCmdList *new; + XOTclClass *mixin; + Tcl_Obj *guard = NULL; + int ocName; Tcl_Obj **ovName; + XOTclCmdList *new; - if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) { - if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { - name = ovName[0]; - guard = ovName[2]; - /*fprintf(stderr,"mixinadd name = '%s', guard = '%s'\n", ObjStr(name), ObjStr(guard));*/ - } /*else return XOTclVarErrMsg(interp, "mixin registration '", ObjStr(name), - "' has too many elements.", (char *) NULL);*/ - } + if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) { + if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { + name = ovName[0]; + guard = ovName[2]; + /*fprintf(stderr,"mixinadd name = '%s', guard = '%s'\n", ObjStr(name), ObjStr(guard));*/ + } /*else return XOTclVarErrMsg(interp, "mixin registration '", ObjStr(name), + "' has too many elements.", (char *) NULL);*/ + } - if (GetXOTclClassFromObj(interp, name, &mixin, base) != TCL_OK) - return XOTclErrBadVal(interp, "mixin", "a class as mixin", ObjStr(name)); + if (GetXOTclClassFromObj(interp, name, &mixin, base) != TCL_OK) + return XOTclErrBadVal(interp, "mixin", "a class as mixin", ObjStr(name)); - new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1); + new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1); - if (guard) { - GuardAdd(interp, new, guard); - } else { - if (new->clientData) - GuardDel(new); + if (guard) { + GuardAdd(interp, new, guard); + } else { + if (new->clientData) + GuardDel(new); + } + + return TCL_OK; +} + +/* + * call AppendElement for matching values + */ +static void +AppendMatchingElement(Tcl_Interp *interp, Tcl_Obj *name, char *pattern) { + char *string = ObjStr(name); + if (!pattern || Tcl_StringMatch(string, pattern)) { + Tcl_AppendElement(interp, string); + } +} + +/* + * apply AppendMatchingElement to CmdList + */ +static int +AppendMatchingElementsFromCmdList(Tcl_Interp *interp, XOTclCmdList *cmdl, + char *pattern, XOTclObject *matchObject) { + int rc = 0; + for ( ; cmdl; cmdl = cmdl->nextPtr) { + XOTclObject *obj = XOTclGetObjectFromCmdPtr(cmdl->cmdPtr); + if (obj) { + if (matchObject == obj) { + return 1; + } else { + AppendMatchingElement(interp, obj->cmdName, pattern); + } } + } + return rc; +} - return TCL_OK; +/* + * apply AppendMatchingElement to + */ +static int +AppendMatchingElementsFromClasses(Tcl_Interp *interp, XOTclClasses *cls, + char *pattern, XOTclObject *matchObject) { + int rc = 0; + + for ( ; cls; cls = cls->nextPtr) { + XOTclObject *obj = (XOTclObject *)cls->cl; + if (obj) { + if (matchObject && obj == matchObject) { + /* we have a matchObject and it is identical to obj, + just return true and don't continue search + */ + return 1; + break; + } else { + AppendMatchingElement(interp, obj->cmdName, pattern); + } + } + } + return rc; } /* * get all instances of a class recursively into an initialized * String key hashtable */ +static int +listInstances(Tcl_Interp *interp, XOTclClass *startCl, + char *pattern, int closure, XOTclObject *matchObject) { + Tcl_HashTable *table = &startCl->instances; + XOTclClasses *sc; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + int rc = 0; + + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); + if (matchObject && inst == matchObject) { + return 1; + } + AppendMatchingElement(interp, inst->cmdName, pattern); + } + if (closure) { + for (sc = startCl->sub; sc; sc = sc->nextPtr) { + rc = listInstances(interp, sc->cl, pattern, closure, matchObject); + if (rc) break; + } + } + return rc; +} + +/* + * get all instances of a class recursively into an initialized + * String key hashtable + */ static void -getAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, int onlyWithMixins) { - Tcl_HashTable *table = &startCl->instances; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - int collect = 1; +getAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl) { + Tcl_HashTable *table = &startCl->instances; + XOTclClasses *sc; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; - for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); - Tcl_HashEntry *hPtrDest; - int new = 0; + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject *)Tcl_GetHashKey(table, hPtr); + int new; - if (onlyWithMixins) { - if (! (collect = XOTclObjectIsClass(inst))) { - if (!(inst->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, inst); - if ((inst->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - collect = (inst->mixinOrder != NULL); - } - } - } - if (collect) { - hPtrDest = Tcl_CreateHashEntry(destTable, ObjStr(inst->cmdName), &new); - - /*fprintf (stderr, " -- %s (%s) opt %d instopt %d\n", - ObjStr(inst->cmdName), ObjStr(startCl->object.cmdName), - inst->opt != NULL, (XOTclObjectIsClass(inst) && ((XOTclClass*)inst)->opt));*/ - } - - if (new) { - if (XOTclObjectIsClass(inst)) { - XOTclClasses *sl = ((XOTclClass*)inst)->sub, *sc; - getAllInstances(interp, destTable, (XOTclClass*) inst, onlyWithMixins); - for (sc = sl; sc != 0; sc = sc->nextPtr) - getAllInstances(interp, destTable, sc->cl, onlyWithMixins); - } - } + Tcl_CreateHashEntry(destTable, ObjStr(inst->cmdName), &new); + /* + fprintf (stderr, " -- %s (%s)\n", ObjStr(inst->cmdName), ObjStr(startCl->object.cmdName)); + */ + } + for (sc = startCl->sub; sc; sc = sc->nextPtr) { + getAllInstances(interp, destTable, sc->cl); + } +} + +/* + * helper function for getAllClassMixinsOf to add classes to the + * result set, flagging test for matchObject as result + */ + +static int +addToResultSet(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclObject *obj, int *new, + int appendResult, char *pattern, XOTclObject *matchObject) { + Tcl_CreateHashEntry(destTable, (char *)obj, new); + if (*new) { + if (matchObject && matchObject == obj) { + return 1; } + if (appendResult) { + AppendMatchingElement(interp, obj->cmdName, pattern); + } + } + return 0; } /* - * recursively get all mixinofs of a class into an initialized - * String key hashtable + * helper function for getAllClassMixins to add classes with guards + * to the result set, flagging test for matchObject as result */ + +static int +addToResultSetWithGuards(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *cl, ClientData clientData, int *new, + int appendResult, char *pattern, XOTclObject *matchObject) { + Tcl_CreateHashEntry(destTable, (char *)cl, new); + if (*new) { + if (appendResult) { + if (!pattern || Tcl_StringMatch(ObjStr(cl->object.cmdName), pattern)) { + Tcl_Obj *l = Tcl_NewListObj(0, NULL); + Tcl_Obj *g = (Tcl_Obj*) clientData; + Tcl_ListObjAppendElement(interp, l, cl->object.cmdName); + Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, l, g); + Tcl_AppendElement(interp, ObjStr(l)); + DECR_REF_COUNT(l); + } + } + if (matchObject && matchObject == (XOTclObject *)cl) { + return 1; + } + } + return 0; +} + +/* + * recursively get all per object mixins from an class and its subclasses/isClassMixinOf + * into an initialized object ptr hashtable (TCL_ONE_WORD_KEYS) + */ -static void -getAllMixinofs(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl) { +static int +getAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int isMixin, + int appendResult, char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClasses *sc; + + /*fprintf(stderr, "startCl = %s, opt %p, isMixin %d\n", + ObjStr(startCl->object.cmdName),startCl->opt, isMixin);*/ - if (startCl->opt) { - XOTclClass *cl; - XOTclCmdList *m; - int new; - - for (m = startCl->opt->mixinofs; m; m = m->nextPtr) { - Tcl_CreateHashEntry(destTable, Tcl_GetCommandName(interp, m->cmdPtr), &new); - /*if (new) fprintf (stderr, " -- %s (%s)\n", Tcl_GetCommandName(in, m->cmdPtr), ObjStr(startCl->object.cmdName));*/ - cl = XOTclGetClassFromCmdPtr(m->cmdPtr); - if (cl) { - getAllMixinofs(interp, destTable, cl); - } - } + /* + * check all subclasses of startCl for mixins + */ + for (sc = startCl->sub; sc; sc = sc->nextPtr) { + rc = getAllObjectMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); + if (rc) {return rc;} + } + /*fprintf(stderr, "check subclasses of %s done\n",ObjStr(startCl->object.cmdName));*/ + + if (startCl->opt) { + XOTclCmdList *m; + XOTclClass *cl; + for (m = startCl->opt->isClassMixinOf; m; m = m->nextPtr) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == NULL); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + /* fprintf(stderr, "check %s mixinof %s\n", + ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName));*/ + rc = getAllObjectMixinsOf(interp, destTable, cl, isMixin, appendResult, pattern, matchObject); + /*fprintf(stderr, "check %s mixinof %s done\n", + ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName));*/ + if (rc) {return rc;} } + } + + /* + * check, if startCl has associated per-object mixins + */ + if (startCl->opt) { + XOTclCmdList *m; + XOTclObject *obj; + + for (m = startCl->opt->isObjectMixinOf; m; m = m->nextPtr) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == NULL); + + obj = XOTclGetObjectFromCmdPtr(m->cmdPtr); + assert(obj); + + rc = addToResultSet(interp, destTable, obj, &new, appendResult, pattern, matchObject); + if (rc == 1) {return rc;} + } + } + return rc; } +/* + * recursively get all isClassMixinOf of a class into an initialized + * object ptr hashtable (TCL_ONE_WORD_KEYS) + */ + +static int +getAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int isMixin, + int appendResult, char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClass *cl; + XOTclClasses *sc; + + /* + fprintf(stderr, "startCl = %s, opt %p, isMixin %d\n", + ObjStr(startCl->object.cmdName),startCl->opt, isMixin); + */ + + /* + * the startCl is a per class mixin, add it to the result set + */ + if (isMixin) { + rc = addToResultSet(interp, destTable, &startCl->object, &new, appendResult, pattern, matchObject); + if (rc == 1) {return rc;} + + /* + * check all subclasses of startCl for mixins + */ + for (sc = startCl->sub; sc; sc = sc->nextPtr) { + rc = getAllClassMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); + if (rc) {return rc;} + } + } + + /* + * check, if startCl is a per-class mixin of some other classes + */ + if (startCl->opt) { + XOTclCmdList *m; + + for (m = startCl->opt->isClassMixinOf; m; m = m->nextPtr) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == NULL); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + + rc = addToResultSet(interp, destTable, &cl->object, &new, appendResult, pattern, matchObject); + if (rc == 1) {return rc;} + if (new) { + rc = getAllClassMixinsOf(interp, destTable, cl, 1, appendResult, pattern, matchObject); + if (rc) {return rc;} + } + } + } + + return rc; +} + +/* + * recursively get all instmixins of a class into an initialized + * object ptr hashtable (TCL_ONE_WORD_KEYS) + */ + +static int +getAllClassMixins(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int withGuards, char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClass *cl; + XOTclClasses *sc; + + /* + * check this class for instmixins + */ + if (startCl->opt) { + XOTclCmdList *m; + + for (m = startCl->opt->instmixins; m; m = m->nextPtr) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == NULL); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + + /* fprintf(stderr,"Instmixin found: %s\n", ObjStr(cl->object.cmdName)); */ + + if ((withGuards) && (m->clientData)) { + /* fprintf(stderr,"addToResultSetWithGuards: %s\n", ObjStr(cl->object.cmdName)); */ + rc = addToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject); + } else { + /* fprintf(stderr,"addToResultSet: %s\n", ObjStr(cl->object.cmdName)); */ + rc = addToResultSet(interp, destTable, &cl->object, &new, 1, pattern, matchObject); + } + if (rc == 1) {return rc;} + + if (new) { + /* fprintf(stderr,"Instmixin getAllClassMixins for: %s (%s)\n",ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName)); */ + rc = getAllClassMixins(interp, destTable, cl, withGuards, pattern, matchObject); + if (rc) {return rc;} + } + } + } + + + /* + * check all superclasses of startCl for instmixins + */ + for (sc = startCl->super; sc; sc = sc->nextPtr) { + /* fprintf(stderr,"Superclass getAllClassMixins for %s (%s)\n",ObjStr(sc->cl->object.cmdName),ObjStr(startCl->object.cmdName)); */ + rc = getAllClassMixins(interp, destTable, sc->cl, withGuards, pattern, matchObject); + if (rc) {return rc;} + } + return rc; +} + + static void -RemoveFromInstmixinsofs(Tcl_Command cmd, XOTclCmdList *cmdlist) { - for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { - XOTclClass *ncl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); - XOTclClassOpt *nclopt = ncl ? ncl->opt : NULL; - if (nclopt) { - XOTclCmdList *del = CmdListFindCmdInList(cmd, nclopt->instmixinofs); - if (del) { - /* fprintf(stderr,"Removing class %s from instmixinofs of class %s\n", - ObjStr(cl->object.cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ - del = CmdListRemoveFromList(&nclopt->instmixinofs, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } +RemoveFromClassMixinsOf(Tcl_Command cmd, XOTclCmdList *cmdlist) { + + for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { + XOTclClass *ncl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); + XOTclClassOpt *nclopt = ncl ? ncl->opt : NULL; + if (nclopt) { + XOTclCmdList *del = CmdListFindCmdInList(cmd, nclopt->isClassMixinOf); + if (del) { + /* fprintf(stderr,"Removing class %s from isClassMixinOf of class %s\n", + ObjStr(cl->object.cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + del = CmdListRemoveFromList(&nclopt->isClassMixinOf, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } } + } } static void -RemoveFromMixinofs(Tcl_Command cmd, XOTclCmdList *cmdlist) { - for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { - XOTclClass *cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); - XOTclClassOpt *clopt = cl ? cl->opt : NULL; - if (clopt) { - XOTclCmdList *del = CmdListFindCmdInList(cmd, clopt->mixinofs); - if (del) { - /* fprintf(stderr,"Removing object %s from mixinofs of Class %s\n", - ObjStr(obj->cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ - del = CmdListRemoveFromList(&clopt->mixinofs, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } /* else fprintf(stderr,"CleanupDestroyObject %s: NULL pointer in mixins!\n", ObjStr(obj->cmdName)); */ - } +removeFromObjectMixinsOf(Tcl_Command cmd, XOTclCmdList *cmdlist) { + for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { + XOTclClass *cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); + XOTclClassOpt *clopt = cl ? cl->opt : NULL; + if (clopt) { + XOTclCmdList *del = CmdListFindCmdInList(cmd, clopt->isObjectMixinOf); + if (del) { + /* fprintf(stderr,"Removing object %s from isObjectMixinOf of Class %s\n", + ObjStr(obj->cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } + } /* else fprintf(stderr,"CleanupDestroyObject %s: NULL pointer in mixins!\n", ObjStr(obj->cmdName)); */ + } } static void RemoveFromInstmixins(Tcl_Command cmd, XOTclCmdList *cmdlist) { - for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { - XOTclClass *cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); - XOTclClassOpt *clopt = cl ? cl->opt : NULL; - if (clopt) { - XOTclCmdList *del = CmdListFindCmdInList(cmd, clopt->instmixins); - if (del) { - /* fprintf(stderr,"Removing class %s from mixins of object %s\n", - ObjStr(cl->object.cmdName), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */ - del = CmdListRemoveFromList(&clopt->instmixins, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } + for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { + XOTclClass *cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); + XOTclClassOpt *clopt = cl ? cl->opt : NULL; + if (clopt) { + XOTclCmdList *del = CmdListFindCmdInList(cmd, clopt->instmixins); + if (del) { + /* fprintf(stderr,"Removing class %s from mixins of object %s\n", + ObjStr(cl->object.cmdName), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */ + del = CmdListRemoveFromList(&clopt->instmixins, del); + CmdListDeleteCmdListEntry(del, GuardDel); + if (cl->object.mixinOrder) MixinResetOrder(&cl->object); + } } + } } static void RemoveFromMixins(Tcl_Command cmd, XOTclCmdList *cmdlist) { - for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { - XOTclObject *nobj = XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr); - XOTclObjectOpt *objopt = nobj ? nobj->opt : NULL; - if (objopt) { - XOTclCmdList *del = CmdListFindCmdInList(cmd, objopt->mixins); - if (del) { - /* fprintf(stderr,"Removing class %s from mixins of object %s\n", - ObjStr(cl->object.cmdName), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */ - del = CmdListRemoveFromList(&objopt->mixins, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } + for ( ; cmdlist; cmdlist = cmdlist->nextPtr) { + XOTclObject *nobj = XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr); + XOTclObjectOpt *objopt = nobj ? nobj->opt : NULL; + if (objopt) { + XOTclCmdList *del = CmdListFindCmdInList(cmd, objopt->mixins); + if (del) { + /* fprintf(stderr,"Removing class %s from mixins of object %s\n", + ObjStr(cl->object.cmdName), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */ + del = CmdListRemoveFromList(&objopt->mixins, del); + CmdListDeleteCmdListEntry(del, GuardDel); + if (nobj->mixinOrder) MixinResetOrder(nobj); + } } + } } +/* + * Reset mixin order for instances of a class + */ + +static void +MixinResetOrderForInstances(Tcl_Interp *interp, XOTclClass *cl) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + hPtr = Tcl_FirstHashEntry(&cl->instances, &hSrch); + + /*fprintf(stderr,"invalidating instances of class %s\n", + ObjStr(clPtr->cl->object.cmdName));*/ + + /* here we should check, whether this class is used as + a mixin / instmixin somewhere else and invalidate + the objects of these as well -- */ + + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&cl->instances, hPtr); + if (obj + && !(obj->flags & XOTCL_DESTROY_CALLED) + && (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + MixinResetOrder(obj); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + } + } +} + +/* reset mixin order for all objects having this class as per object mixin */ +static void +ResetOrderOfClassesUsedAsMixins(XOTclClass *cl) { + /*fprintf(stderr,"ResetOrderOfClassesUsedAsMixins %s - %p\n", + ObjStr(cl->object.cmdName), cl->opt);*/ + + if (cl->opt) { + XOTclCmdList *ml; + for (ml = cl->opt->isObjectMixinOf; ml; ml = ml->nextPtr) { + XOTclObject *obj = XOTclGetObjectFromCmdPtr(ml->cmdPtr); + if (obj) { + if (obj->mixinOrder) { MixinResetOrder(obj); } + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + } + } + } +} + + + /* * if the class hierarchy or class mixins have changed -> * invalidate mixin entries in all dependent instances */ static void MixinInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) { - XOTclClasses *saved = cl->order, *clPtr; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - Tcl_HashTable objTable, *commandTable = &objTable; - XOTclObject *obj; + XOTclClasses *saved = cl->order, *clPtr; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + Tcl_HashTable objTable, *commandTable = &objTable; - cl->order = 0; + cl->order = NULL; - for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->nextPtr) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; + /* reset mixin order for all instances of the class and the + instances of its subclasses + */ + for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->nextPtr) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = &clPtr->cl->instances ? + Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : NULL; - /*fprintf(stderr,"invalidating instances of class %s\n", - ObjStr(clPtr->cl->object.cmdName));*/ + /* reset mixin order for all objects having this class as per object mixin */ + ResetOrderOfClassesUsedAsMixins(clPtr->cl); - /* here we should check, whether this class is used as - a mixin / instmixin somewhere else and invalidate - the objects of these as well -- */ + /* fprintf(stderr,"invalidating instances of class %s\n", ObjStr(clPtr->cl->object.cmdName)); + */ - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*) - Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - MixinResetOrder(obj); - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - } + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + if (obj->mixinOrder) { MixinResetOrder(obj); } + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; } + } - XOTclClassListFree(cl->order); - cl->order = saved; -#if 1 - /*fprintf(stderr,"invalidate order brute force %d\n", - (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF));*/ + XOTclClassListFree(cl->order); + cl->order = saved; - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { - /* invalidate the mixins on all instances that have this mixin (cl) - at the moment - */ - Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + /* Reset mixin order for all objects having this class as a per + class mixin (instmixin). This means that we have to work through + the instmixin hierarchy with its corresponding instances. + */ + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + getAllClassMixinsOf(interp, commandTable, cl, 1, 0, NULL, NULL); - /*getAllInstances(interp, commandTable, RUNTIME_STATE(interp)->theClass, 0);*/ - getAllMixinofs(interp, commandTable, cl); - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - - obj = XOTclpGetObject(interp, key); - /*fprintf(stderr,"invalidate order brute force check %s\n", key);*/ - if (obj && !XOTclObjectIsClass(obj) - && !(obj->flags & XOTCL_DESTROY_CALLED) - && (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - XOTclCmdList *ml; - for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin == cl) { - /*fprintf(stderr,"invalidate order brute force reset %s\n", ObjStr(obj->cmdName));*/ - MixinResetOrder(obj); - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - break; - } - } - } - hPtr = Tcl_NextHashEntry(&hSrch); - } - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); - Tcl_DeleteHashTable(commandTable); + for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclClass *ncl = (XOTclClass *)Tcl_GetHashKey(commandTable, hPtr); + /*fprintf(stderr,"Got %s, reset for ncl %p\n",ncl?ObjStr(ncl->object.cmdName):"NULL",ncl);*/ + if (ncl) { + MixinResetOrderForInstances(interp, ncl); } -#endif + } + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); } -static int -MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern, int withGuards); + +static int MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern, + int withGuards, XOTclObject *matchObject); /* * the mixin order is either * DEFINED (there are mixins on the instance), * NONE (there are no mixins for the instance), * or INVALID (a class re-strucuturing has occured, thus it is not clear * whether mixins are defined or not). * If it is INVALID MixinComputeDefined can be used to compute the order - * and set the instance to DEFINE or NONE + * and set the instance to DEFINED or NONE */ static void MixinComputeDefined(Tcl_Interp *interp, XOTclObject *obj) { - MixinComputeOrder(interp, obj); - obj->flags |= XOTCL_MIXIN_ORDER_VALID; - if (obj->mixinOrder) - obj->flags |= XOTCL_MIXIN_ORDER_DEFINED; - else - obj->flags &= ~XOTCL_MIXIN_ORDER_DEFINED; + MixinComputeOrder(interp, obj); + obj->flags |= XOTCL_MIXIN_ORDER_VALID; + if (obj->mixinOrder) + obj->flags |= XOTCL_MIXIN_ORDER_DEFINED; + else + obj->flags &= ~XOTCL_MIXIN_ORDER_DEFINED; } /* - * walk through the mixin order until the current mixin is reached. - * then use the next mixin as current mixin. + * Walk through the command list until the current command is reached. + * return the next entry. * - * precondition: obj->mixinStack is not NULL */ -static void -MixinSeekCurrent(Tcl_Interp *interp, XOTclObject *obj, XOTclCmdList **cmdList) { - Tcl_Command currentCmdPtr; - - /* ensure that the mixin order is not invalid, otherwise compute order */ - assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); - /*MixinComputeDefined(interp, obj);*/ - currentCmdPtr = obj->mixinStack->currentCmdPtr; - - /* - { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc = cs->top; - fprintf(stderr, "%p == %p ==> %d \n", csc->cl, currentCmdPtr, - csc->cmdPtr == currentCmdPtr); - } - */ - - /*** - { Tcl_Obj *sr; - - MixinInfo(interp, obj->mixinOrder, NULL, 0); - sr = Tcl_GetObjResult(interp); - fprintf(stderr,"INFO->%s order %p next %p\n", ObjStr(sr), obj->mixinOrder, obj->mixinOrder->nextPtr); - } - ***/ - - *cmdList = obj->mixinOrder; - /* - fprintf(stderr, "->1 mixin seek current = %p next = %p %s\n", - currentCmdPtr, - (*cmdList)->nextPtr, - (*cmdList)->nextPtr ? Tcl_GetCommandName(interp, (*cmdList)->nextPtr->cmdPtr) : ""); - */ - -#if defined(ACTIVEMIXIN) - /*RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->nextPtr ? (*cmdList)->nextPtr->cmdPtr : NULL;*/ - RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->cmdPtr; -#endif - +static XOTclCmdList * +seekCurrent(Tcl_Command currentCmd, register XOTclCmdList *cmdl) { + if (currentCmd) { /* go forward to current class */ - while (*cmdList && currentCmdPtr) { - /* fprintf(stderr, "->2 mixin seek current = %p next = %p\n", currentCmdPtr, (*cmdList)->nextPtr);*/ - if ((*cmdList)->cmdPtr == currentCmdPtr) - currentCmdPtr = 0; - *cmdList = (*cmdList)->nextPtr; - -#if defined(ACTIVEMIXIN) - /*RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->nextPtr ? (*cmdList)->nextPtr->cmdPtr : NULL;*/ - RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->cmdPtr; -#endif + for (; cmdl; cmdl = cmdl->nextPtr) { + if (cmdl->cmdPtr == currentCmd) { + return cmdl->nextPtr; + } } + } + return cmdl; } /* @@ -3558,126 +3931,117 @@ */ static Tcl_Command MixinSearchProc(Tcl_Interp *interp, XOTclObject *obj, char *methodName, - XOTclClass **cl, Tcl_ObjCmdProc **proc, ClientData *cp, - Tcl_Command *currentCmdPtr) { - Tcl_Command cmd = NULL; - XOTclCmdList *cmdList; - XOTclClass *cls; - - assert(obj); - assert(obj->mixinStack); - - MixinSeekCurrent(interp, obj, &cmdList); - - /* - fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName, cmdList); - */ - /*CmdListPrint(interp,"MixinSearch CL = \n", cmdList);*/ + XOTclClass **cl, Tcl_Command *currentCmdPtr) { + Tcl_Command cmd = NULL; + XOTclCmdList *cmdList; + XOTclClass *cls; + assert(obj); + assert(obj->mixinStack); + + /* ensure that the mixin order is not invalid, otherwise compute order */ + assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); + /*MixinComputeDefined(interp, obj);*/ + cmdList = seekCurrent(obj->mixinStack->currentCmdPtr, obj->mixinOrder); - while (cmdList) { - if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { - cmdList = cmdList->nextPtr; - } else { - cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr); - /* - fprintf(stderr,"+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n", - ObjStr(obj->cmdName), methodName, cmdList, - cmdList->cmdPtr, cmdList->clientData); - */ - if (cls) { - int guardOk = TCL_OK; - cmd = FindMethod(methodName, cls->nsPtr); - if (cmd && cmdList->clientData) { - if (!RUNTIME_STATE(interp)->cs.guardCount) { - guardOk = GuardCall(obj, cls, (Tcl_Command) cmd, interp, - (Tcl_Obj*)cmdList->clientData, 1); - } - } - if (cmd && guardOk == TCL_OK) { - /* - * on success: compute mixin call data - */ - *cl = cls; - *proc = Tcl_Command_objProc(cmd); - *cp = Tcl_Command_objClientData(cmd); - *currentCmdPtr = cmdList->cmdPtr; - break; - } else { - cmd = NULL; - cmdList = cmdList->nextPtr; - } - } +#if defined(ACTIVEMIXIN) + RUNTIME_STATE(interp)->cmdPtr = cmdList->cmdPtr; +#endif + + /* + fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName, cmdList); + */ + /*CmdListPrint(interp,"MixinSearch CL = \n", cmdList);*/ + + while (cmdList) { + if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { + cmdList = cmdList->nextPtr; + } else { + cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr); + /* + fprintf(stderr,"+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n", + ObjStr(obj->cmdName), methodName, cmdList, + cmdList->cmdPtr, cmdList->clientData); + */ + if (cls) { + int guardOk = TCL_OK; + cmd = FindMethod(methodName, cls->nsPtr); + if (cmd && cmdList->clientData) { + if (!RUNTIME_STATE(interp)->cs.guardCount) { + guardOk = GuardCall(obj, cls, (Tcl_Command) cmd, interp, + (Tcl_Obj*)cmdList->clientData, 1); + } } + if (cmd && guardOk == TCL_OK) { + /* + * on success: compute mixin call data + */ + *cl = cls; + *currentCmdPtr = cmdList->cmdPtr; + break; + } else { + cmd = NULL; + cmdList = cmdList->nextPtr; + } + } } + } - return cmd; + return cmd; } /* * info option for mixins and instmixins */ static int -MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern, int withGuards) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclClass *mixinClass; - while (m) { - /* fprintf(stderr," mixin info m=%p, next=%p\n", m, m->nextPtr); */ - mixinClass = XOTclGetClassFromCmdPtr(m->cmdPtr); - if (mixinClass && - (!pattern || - Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern))) { - if (withGuards && m->clientData) { - Tcl_Obj *l = Tcl_NewListObj(0, NULL); - Tcl_Obj *g = (Tcl_Obj *) m->clientData; - Tcl_ListObjAppendElement(interp, l, mixinClass->object.cmdName); - Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]); - Tcl_ListObjAppendElement(interp, l, g); - Tcl_ListObjAppendElement(interp, list, l); - } else - Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName); - } - m = m->nextPtr; +MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern, + int withGuards, XOTclObject *matchObject) { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclClass *mixinClass; + + while (m) { + /* fprintf(stderr," mixin info m=%p, next=%p, pattern %s, matchObject %p\n", + m, m->next, pattern, matchObject);*/ + mixinClass = XOTclGetClassFromCmdPtr(m->cmdPtr); + if (mixinClass && + (!pattern + || (matchObject && &(mixinClass->object) == matchObject) + || (!matchObject && Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern)))) { + if (withGuards && m->clientData) { + Tcl_Obj *l = Tcl_NewListObj(0, NULL); + Tcl_Obj *g = (Tcl_Obj*) m->clientData; + Tcl_ListObjAppendElement(interp, l, mixinClass->object.cmdName); + Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, l, g); + Tcl_ListObjAppendElement(interp, list, l); + } else { + Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName); + } + if (matchObject) break; } - Tcl_SetObjResult(interp, list); - return TCL_OK; + m = m->nextPtr; + } + Tcl_SetObjResult(interp, list); + return TCL_OK; } /* - * info option for mixinofs and instmixinofs + * info option for mixinofs and isClassMixinOf */ -static int -MixinOfInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclObject *mixinObject; - for ( ; m; m = m->nextPtr) { - /* fprintf(stderr," mixinof info m=%p, next=%p\n", m, m->nextPtr); */ - mixinObject = XOTclGetObjectFromCmdPtr(m->cmdPtr); - if (mixinObject && - (!pattern || - Tcl_StringMatch(ObjStr(mixinObject->cmdName), pattern))) { - Tcl_ListObjAppendElement(interp, list, mixinObject->cmdName); - } - } - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - static Tcl_Command MixinSearchMethodByName(Tcl_Interp *interp, XOTclCmdList *mixinList, char *name, XOTclClass **cl) { - Tcl_Command cmd; - while (mixinList) { - XOTclClass *foundCl, *mcl = - XOTclpGetClass(interp, (char *) Tcl_GetCommandName(interp, mixinList->cmdPtr)); - if (mcl && (foundCl = SearchCMethod(mcl, name, &cmd))) { - if (cl) *cl = foundCl; - return cmd; - } + Tcl_Command cmd; - mixinList = mixinList->nextPtr; + for (; mixinList; mixinList = mixinList->nextPtr) { + XOTclClass *foundCl = + XOTclpGetClass(interp, (char *) Tcl_GetCommandName(interp, mixinList->cmdPtr)); + if (foundCl && SearchCMethod(foundCl, name, &cmd)) { + if (cl) *cl = foundCl; + return cmd; } - return 0; + } + return 0; } @@ -3696,63 +4060,64 @@ static Tcl_Command FilterSearch(Tcl_Interp *interp, char *name, XOTclObject *startingObj, - XOTclClass *startingCl, XOTclClass **cl) { - Tcl_Command cmd = NULL; + XOTclClass *startingCl, XOTclClass **cl) { + Tcl_Command cmd = NULL; - if (startingObj) { - XOTclObjectOpt *opt = startingObj->opt; - /* - * the object-specific filter can also be defined on the object's - * class, its hierarchy, or the respective instmixins; thus use the - * object's class as start point for the class-specific search then ... - */ - startingCl = startingObj->cl; - - /* - * search for filters on object mixins - */ - if (opt && opt->mixins) { - if ((cmd = MixinSearchMethodByName(interp, opt->mixins, name, cl))) { - return cmd; - } - } - } - + if (startingObj) { + XOTclObjectOpt *opt = startingObj->opt; /* - * search for instfilters on instmixins + * the object-specific filter can also be defined on the object's + * class, its hierarchy, or the respective instmixins; thus use the + * object's class as start point for the class-specific search then ... */ - if (startingCl) { - XOTclClassOpt *opt = startingCl->opt; - if (opt && opt->instmixins) { - if ((cmd = MixinSearchMethodByName(interp, opt->instmixins, name, cl))) { - return cmd; - } - } - } + startingCl = startingObj->cl; /* - * seach for object procs that are used as filters + * search for filters on object mixins */ - if (startingObj && startingObj->nsPtr) { - if ((cmd = FindMethod(name, startingObj->nsPtr))) { - *cl = (XOTclClass*)startingObj; - return cmd; - } + if (opt && opt->mixins) { + if ((cmd = MixinSearchMethodByName(interp, opt->mixins, name, cl))) { + return cmd; + } } + } - /* - * ok, no filter on obj or mixins -> search class - */ - if (startingCl) { - *cl = SearchCMethod(startingCl, name, &cmd); - if (!*cl) { - /* - * If no filter is found yet -> search the meta-class - */ - *cl = SearchCMethod(startingCl->object.cl, name, &cmd); - } + /* + * search for instfilters on instmixins + */ + if (startingCl) { + XOTclClassOpt *opt = startingCl->opt; + if (opt && opt->instmixins) { + if ((cmd = MixinSearchMethodByName(interp, opt->instmixins, name, cl))) { + return cmd; + } } - return cmd; + } + + /* + * seach for object procs that are used as filters + */ + if (startingObj && startingObj->nsPtr) { + /*fprintf(stderr,"search filter %s as proc \n",name);*/ + if ((cmd = FindMethod(name, startingObj->nsPtr))) { + *cl = (XOTclClass*)startingObj; + return cmd; + } + } + + /* + * ok, no filter on obj or mixins -> search class + */ + if (startingCl) { + *cl = SearchCMethod(startingCl, name, &cmd); + if (!*cl) { + /* + * If no filter is found yet -> search the meta-class + */ + *cl = SearchCMethod(startingCl->object.cl, name, &cmd); + } + } + return cmd; } /* @@ -3762,44 +4127,44 @@ /* check a filter guard, return 1 if ok */ static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guard) { - int rc; - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + int rc; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - if (guard) { - /* - * if there are more than one filter guard for this filter - * (i.e. they are inherited), then they are OR combined - * -> if one check succeeds => return 1 - */ + if (guard) { + /* + * if there are more than one filter guard for this filter + * (i.e. they are inherited), then they are OR combined + * -> if one check succeeds => return 1 + */ + + /*fprintf(stderr, "checking guard **%s**\n", ObjStr(guard));*/ - /*fprintf(stderr, "checking guard **%s**\n", ObjStr(guard));*/ + cs->guardCount++; + rc = checkConditionInScope(interp, guard); + cs->guardCount--; - cs->guardCount++; - rc = checkConditionInScope(interp, guard); - cs->guardCount--; + /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", + ObjStr(fr->content), rc);*/ - /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", - ObjStr(fr->content), rc);*/ - - if (rc == TCL_OK) { - /* fprintf(stderr, " +++ OK\n"); */ - return TCL_OK; - } else if (rc == TCL_ERROR) { - Tcl_Obj *sr = Tcl_GetObjResult(interp); - INCR_REF_COUNT(sr); - - /* fprintf(stderr, " +++ ERROR\n");*/ - - XOTclVarErrMsg(interp, "Guard Error: '", ObjStr(guard), "'\n\n", - ObjStr(sr), (char *) NULL); - DECR_REF_COUNT(sr); - return TCL_ERROR; - } + if (rc == TCL_OK) { + /* fprintf(stderr, " +++ OK\n"); */ + return TCL_OK; + } else if (rc == TCL_ERROR) { + Tcl_Obj *sr = Tcl_GetObjResult(interp); + INCR_REF_COUNT(sr); + + /* fprintf(stderr, " +++ ERROR\n");*/ + + XOTclVarErrMsg(interp, "Guard Error: '", ObjStr(guard), "'\n\n", + ObjStr(sr), (char *) NULL); + DECR_REF_COUNT(sr); + return TCL_ERROR; } - /* - fprintf(stderr, " +++ FAILED\n"); - */ - return XOTCL_CHECK_FAILED; + } + /* + fprintf(stderr, " +++ FAILED\n"); + */ + return XOTCL_CHECK_FAILED; } /* @@ -3816,216 +4181,225 @@ static void GuardDel(XOTclCmdList *CL) { - /*fprintf(stderr, "GuardDel %p clientData = %p\n", - CL, CL? CL->clientData : NULL);*/ - if (CL && CL->clientData) { - DECR_REF_COUNT((Tcl_Obj *)CL->clientData); - CL->clientData = NULL; - } + /*fprintf(stderr, "GuardDel %p clientData = %p\n", + CL, CL? CL->clientData : NULL);*/ + if (CL && CL->clientData) { + DECR_REF_COUNT((Tcl_Obj *)CL->clientData); + CL->clientData = NULL; + } } XOTCLINLINE static void GuardAdd(Tcl_Interp *interp, XOTclCmdList *CL, Tcl_Obj *guard) { - if (guard) { - GuardDel(CL); - if (strlen(ObjStr(guard)) != 0) { - INCR_REF_COUNT(guard); - CL->clientData = (ClientData) guard; - /*fprintf(stderr,"guard added to %p cmdPtr=%p, clientData= %p\n", - CL, CL->cmdPtr, CL->clientData); - */ - } + if (guard) { + GuardDel(CL); + if (strlen(ObjStr(guard)) != 0) { + INCR_REF_COUNT(guard); + CL->clientData = (ClientData) guard; + /*fprintf(stderr,"guard added to %p cmdPtr=%p, clientData= %p\n", + CL, CL->cmdPtr, CL->clientData); + */ } + } } +/* + static void + GuardAddList(Tcl_Interp *interp, XOTclCmdList *dest, ClientData source) { + XOTclTclObjList *s = (XOTclTclObjList*) source; + GuardAdd(interp, dest, (Tcl_Obj*) s->content); + s = s->nextPtr; + } */ static int GuardCall(XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, - Tcl_Interp *interp, Tcl_Obj *guard, int push) { - int rc = TCL_OK; + Tcl_Interp *interp, Tcl_Obj *guard, int push) { + int rc = TCL_OK; + + if (guard) { + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(res); + + csc->callType |= XOTCL_CSC_CALL_IS_GUARD; - if (guard) { - Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ - INCR_REF_COUNT(res); - - /* GuardPrint(interp, cmdList->clientData); */ - /* - * ok, there is a guard ... we have to push a - * fake callframe on the tcl stack so that uplevel - * is in sync with the XOTcl callstack, and we can uplevel - * into the above pushed CallStack entry - */ - if (push) { - CallStackPush(interp, obj, cl, cmd, 0, 0, XOTCL_CSC_TYPE_GUARD); - rc = GuardCheck(interp, guard); - CallStackPop(interp); - } else { - rc = GuardCheck(interp, guard); - } - Tcl_SetObjResult(interp, res); /* restore the result */ - DECR_REF_COUNT(res); + /* GuardPrint(interp, cmdList->clientData); */ + /* + * ok, there is a guard ... we have to push a + * fake callframe on the tcl stack so that uplevel + * is in sync with the XOTcl callstack, and we can uplevel + * into the above pushed CallStack entry + */ + if (push) { + CallStackPush(interp, obj, cl, cmd, 0, 0, XOTCL_CSC_TYPE_GUARD); + rc = GuardCheck(interp, guard); + CallStackPop(interp); + } else { + rc = GuardCheck(interp, guard); } - - return rc; + Tcl_SetObjResult(interp, res); /* restore the result */ + DECR_REF_COUNT(res); + } + + return rc; } static int GuardAddFromDefinitionList(Tcl_Interp *interp, XOTclCmdList *dest, - XOTclObject *obj, Tcl_Command interceptorCmd, - XOTclCmdList *interceptorDefList) { - XOTclCmdList *h; - if (interceptorDefList != 0) { - h = CmdListFindCmdInList(interceptorCmd, interceptorDefList); - if (h) { - GuardAdd(interp, dest, (Tcl_Obj *) h->clientData); - /* - * 1 means we have added a guard successfully "interceptorCmd" - */ - return 1; - } + XOTclObject *obj, Tcl_Command interceptorCmd, + XOTclCmdList *interceptorDefList) { + XOTclCmdList *h; + if (interceptorDefList) { + h = CmdListFindCmdInList(interceptorCmd, interceptorDefList); + if (h) { + GuardAdd(interp, dest, (Tcl_Obj*) h->clientData); + /* + * 1 means we have added a guard successfully "interceptorCmd" + */ + return 1; } - /* - * 0 means we have not added a guard successfully "interceptorCmd" - */ - return 0; + } + /* + * 0 means we have not added a guard successfully "interceptorCmd" + */ + return 0; } static void GuardAddInheritedGuards(Tcl_Interp *interp, XOTclCmdList *dest, XOTclObject *obj, Tcl_Command filterCmd) { - XOTclClasses *pl; - int guardAdded = 0; - XOTclObjectOpt *opt; + XOTclClasses *pl; + int guardAdded = 0; + XOTclObjectOpt *opt; - /* search guards for instfilters registered on mixins */ - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - XOTclClass *mixin; - while (ml && ! guardAdded) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin && mixin->opt) { - guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, - mixin->opt->instfilters); - } - ml = ml->nextPtr; - } + /* search guards for instfilters registered on mixins */ + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml; + XOTclClass *mixin; + for (ml = obj->mixinOrder; ml && !guardAdded; ml = ml->nextPtr) { + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin && mixin->opt) { + guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, + mixin->opt->instfilters); + } } + } - /* search per-object filters */ - opt = obj->opt; - if (!guardAdded && opt && opt->filters) { - guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, opt->filters); + /* search per-object filters */ + opt = obj->opt; + if (!guardAdded && opt && opt->filters) { + guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, opt->filters); + } + + if (!guardAdded) { + /* search per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); !guardAdded && pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt) { + guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, + opt->instfilters); + } } - if (!guardAdded) { - /* search per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); !guardAdded && pl; pl = pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt) { - guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, - opt->instfilters); - } - } - - /* - * if this is not a registered filter, it is an inherited filter, like: - * Class A - * A instproc f ... - * Class B -superclass A - * B instproc {{f {}}} - * B instfilter f - * -> get the guard from the filter that inherits it (here B->f) - */ - if (!guardAdded) { - XOTclCmdList *registeredFilter = - CmdListFindNameInList(interp,(char *) Tcl_GetCommandName(interp, filterCmd), - obj->filterOrder); - if (registeredFilter) { - GuardAdd(interp, dest, (Tcl_Obj *) registeredFilter->clientData); - } - } + /* + * if this is not a registered filter, it is an inherited filter, like: + * Class A + * A instproc f ... + * Class B -superclass A + * B instproc {{f {}}} + * B instfilter f + * -> get the guard from the filter that inherits it (here B->f) + */ + if (!guardAdded) { + XOTclCmdList *registeredFilter = + CmdListFindNameInList(interp,(char *) Tcl_GetCommandName(interp, filterCmd), + obj->filterOrder); + if (registeredFilter) { + GuardAdd(interp, dest, (Tcl_Obj*) registeredFilter->clientData); + } } + } } static int GuardList(Tcl_Interp *interp, XOTclCmdList *frl, char *interceptorName) { - XOTclCmdList *h; - if (frl) { - /* try to find simple name first */ - h = CmdListFindNameInList(interp, interceptorName, frl); - if (!h) { - /* maybe it is a qualified name */ - Tcl_Command cmd = NSFindCommand(interp, interceptorName, NULL); - if (cmd) { - h = CmdListFindCmdInList(cmd, frl); - } - } - if (h) { - Tcl_ResetResult(interp); - if (h->clientData) { - Tcl_Obj *g = (Tcl_Obj *) h->clientData; - Tcl_SetObjResult(interp, g); - } - return TCL_OK; - } + XOTclCmdList *h; + if (frl) { + /* try to find simple name first */ + h = CmdListFindNameInList(interp, interceptorName, frl); + if (!h) { + /* maybe it is a qualified name */ + Tcl_Command cmd = NSFindCommand(interp, interceptorName, NULL); + if (cmd) { + h = CmdListFindCmdInList(cmd, frl); + } } - return XOTclVarErrMsg(interp, "info (*)guard: can't find filter/mixin ", - interceptorName, (char *) NULL); + if (h) { + Tcl_ResetResult(interp); + if (h->clientData) { + Tcl_Obj *g = (Tcl_Obj*) h->clientData; + Tcl_SetObjResult(interp, g); + } + return TCL_OK; + } + } + return XOTclVarErrMsg(interp, "info (*)guard: can't find filter/mixin ", + interceptorName, (char *) NULL); } /* * append a filter command to the 'filterList' of an obj/class */ static int FilterAdd(Tcl_Interp *interp, XOTclCmdList **filterList, Tcl_Obj *name, - XOTclObject *startingObj, XOTclClass *startingCl) { - Tcl_Command cmd; - int ocName; Tcl_Obj **ovName; - Tcl_Obj *guard = NULL; - XOTclCmdList *new; - XOTclClass *cl; + XOTclObject *startingObj, XOTclClass *startingCl) { + Tcl_Command cmd; + int ocName; Tcl_Obj **ovName; + Tcl_Obj *guard = NULL; + XOTclCmdList *new; + XOTclClass *cl; - if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) { - if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { - name = ovName[0]; - guard = ovName[2]; - } + if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) { + if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { + name = ovName[0]; + guard = ovName[2]; } + } - if (!(cmd = FilterSearch(interp, ObjStr(name), startingObj, startingCl, &cl))) { - if (startingObj) - return XOTclVarErrMsg(interp, "filter: can't find filterproc on: ", - ObjStr(startingObj->cmdName), " - proc: ", - ObjStr(name), (char *) NULL); - else - return XOTclVarErrMsg(interp, "instfilter: can't find filterproc on: ", - ObjStr(startingCl->object.cmdName), " - proc: ", - ObjStr(name), (char *) NULL); - } + if (!(cmd = FilterSearch(interp, ObjStr(name), startingObj, startingCl, &cl))) { + if (startingObj) + return XOTclVarErrMsg(interp, "filter: can't find filterproc on: ", + ObjStr(startingObj->cmdName), " - proc: ", + ObjStr(name), (char *) NULL); + else + return XOTclVarErrMsg(interp, "instfilter: can't find filterproc on: ", + ObjStr(startingCl->object.cmdName), " - proc: ", + ObjStr(name), (char *) NULL); + } - /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(name), cl);*/ + /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(name), cl);*/ - new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1); + new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1); - if (guard) { - GuardAdd(interp, new, guard); - } else { - if (new->clientData) - GuardDel(new); - } + if (guard) { + GuardAdd(interp, new, guard); + } else { + if (new->clientData) + GuardDel(new); + } - return TCL_OK; + return TCL_OK; } /* * reset the filter order cached in obj->filterOrder */ static void FilterResetOrder(XOTclObject *obj) { - CmdListRemoveList(&obj->filterOrder, GuardDel); - obj->filterOrder = 0; + CmdListRemoveList(&obj->filterOrder, GuardDel); + obj->filterOrder = NULL; } /* @@ -4035,33 +4409,32 @@ */ static void FilterSearchAgain(Tcl_Interp *interp, XOTclCmdList **filters, - XOTclObject *startingObj, XOTclClass *startingCl) { - char *simpleName; - Tcl_Command cmd; - XOTclCmdList *cmdList, *del; - XOTclClass *cl = NULL; + XOTclObject *startingObj, XOTclClass *startingCl) { + char *simpleName; + Tcl_Command cmd; + XOTclCmdList *cmdList, *del; + XOTclClass *cl = NULL; - CmdListRemoveEpoched(filters, GuardDel); - cmdList = *filters; - while (cmdList) { - simpleName = (char *) Tcl_GetCommandName(interp, cmdList->cmdPtr); - cmd = FilterSearch(interp, simpleName, startingObj, startingCl, &cl); - if (cmd == NULL) { - del = cmdList; - cmdList = cmdList->nextPtr; - del = CmdListRemoveFromList(filters, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } else { - if (cmd != cmdList->cmdPtr) - CmdListReplaceCmd(cmdList, cmd, cl); - cmdList = cmdList->nextPtr; - } + CmdListRemoveEpoched(filters, GuardDel); + for (cmdList = *filters; cmdList; ) { + simpleName = (char *) Tcl_GetCommandName(interp, cmdList->cmdPtr); + cmd = FilterSearch(interp, simpleName, startingObj, startingCl, &cl); + if (cmd == NULL) { + del = CmdListRemoveFromList(filters, cmdList); + cmdList = cmdList->nextPtr; + CmdListDeleteCmdListEntry(del, GuardDel); + } else if (cmd != cmdList->cmdPtr) { + CmdListReplaceCmd(cmdList, cmd, cl); + cmdList = cmdList->nextPtr; + } else { + cmdList = cmdList->nextPtr; } - /* some entries might be NULL now, if they are not found anymore - -> delete those - CmdListRemoveNulledEntries(filters, GuardDel); - */ + } + /* some entries might be NULL now, if they are not found anymore + -> delete those + CmdListRemoveNulledEntries(filters, GuardDel); + */ } /* @@ -4071,34 +4444,33 @@ */ static void FilterInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) { - XOTclClasses *saved = cl->order, *clPtr, *savePtr; + XOTclClasses *saved = cl->order, *clPtr, *savePtr; - cl->order = 0; - savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); - cl->order = saved; + cl->order = NULL; + savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); + cl->order = saved; - while (clPtr != 0) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; + for ( ; clPtr; clPtr = clPtr->nextPtr) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = &clPtr->cl->instances ? + Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; - /* recalculate the commands of all instfilter registrations */ - if (clPtr->cl->opt) { - FilterSearchAgain(interp, &clPtr->cl->opt->instfilters, 0, clPtr->cl); - } - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - FilterResetOrder(obj); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + /* recalculate the commands of all instfilter registrations */ + if (clPtr->cl->opt) { + FilterSearchAgain(interp, &clPtr->cl->opt->instfilters, 0, clPtr->cl); + } + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + FilterResetOrder(obj); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - /* recalculate the commands of all object filter registrations */ - if (obj->opt) { - FilterSearchAgain(interp, &obj->opt->filters, obj, 0); - } - } - clPtr = clPtr->nextPtr; + /* recalculate the commands of all object filter registrations */ + if (obj->opt) { + FilterSearchAgain(interp, &obj->opt->filters, obj, 0); + } } - XOTclClassListFree(savePtr); + } + XOTclClassListFree(savePtr); } /* @@ -4109,31 +4481,31 @@ */ static void FilterRemoveDependentFilterCmds(XOTclClass *cl, XOTclClass *removeClass) { - XOTclClasses *saved = cl->order, *clPtr; - cl->order = 0; + XOTclClasses *saved = cl->order, *clPtr; + cl->order = NULL; - /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n", - cl, ObjStr(cl->object.cmdName), - removeClass, ObjStr(removeClass->object.cmdName));*/ + /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n", + cl, ObjStr(cl->object.cmdName), + removeClass, ObjStr(removeClass->object.cmdName));*/ - for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->nextPtr) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; - XOTclClassOpt *opt = clPtr->cl->opt; - if (opt) { - CmdListRemoveContextClassFromList(&opt->instfilters, removeClass, GuardDel); - } - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - if (obj->opt) { - CmdListRemoveContextClassFromList(&obj->opt->filters, removeClass, GuardDel); - } - } + for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->nextPtr) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = &clPtr->cl->instances ? + Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : NULL; + XOTclClassOpt *opt = clPtr->cl->opt; + if (opt) { + CmdListRemoveContextClassFromList(&opt->instfilters, removeClass, GuardDel); } + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + if (obj->opt) { + CmdListRemoveContextClassFromList(&obj->opt->filters, removeClass, GuardDel); + } + } + } - XOTclClassListFree(cl->order); - cl->order = saved; + XOTclClassListFree(cl->order); + cl->order = saved; } /* @@ -4143,40 +4515,40 @@ */ static Tcl_Obj * getFullProcQualifier(Tcl_Interp *interp, CONST84 char *cmdName, - XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_Obj *procObj = Tcl_NewStringObj(cmdName, -1); - Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); - int isTcl = (TclIsProc((Command *)cmd) != NULL); + XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd) { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_Obj *procObj = Tcl_NewStringObj(cmdName, -1); + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + int isTcl = (TclIsProc((Command *)cmd) != NULL); - if (cl) { - Tcl_ListObjAppendElement(interp, list, cl->object.cmdName); - /*fprintf(stderr,"current %p, dispatch %p, forward %p, parametermcd %p, is tcl %p\n", - objProc, XOTclObjDispatch, XOTclForwardMethod, - XOTclSetterMethod, TclIsProc((Command *)cmd)); */ - if (isTcl) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPROC]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPARAMETERCMD]); - } else { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTCMD]); - } + if (cl) { + Tcl_ListObjAppendElement(interp, list, cl->object.cmdName); + /*fprintf(stderr,"current %p, dispatch %p, forward %p, parametermcd %p, is tcl %p\n", + objProc, XOTclObjDispatch, XOTclForwardMethod, + XOTclSetterMethod, TclIsProc((Command *)cmd)); */ + if (isTcl) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPROC]); + } else if (objProc == XOTclForwardMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFORWARD]); + } else if (objProc == XOTclSetterMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPARAMETERCMD]); } else { - Tcl_ListObjAppendElement(interp, list, obj->cmdName); - if (isTcl) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PROC]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PARAMETERCMD]); - } else { - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_CMD]); - } + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTCMD]); } - Tcl_ListObjAppendElement(interp, list, procObj); - return list; + } else { + Tcl_ListObjAppendElement(interp, list, obj->cmdName); + if (isTcl) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PROC]); + } else if (objProc == XOTclForwardMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FORWARD]); + } else if (objProc == XOTclSetterMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PARAMETERCMD]); + } else { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_CMD]); + } + } + Tcl_ListObjAppendElement(interp, list, procObj); + return list; } /* @@ -4186,104 +4558,104 @@ */ static int FilterInfo(Tcl_Interp *interp, XOTclCmdList *f, char *pattern, - int withGuards, int fullProcQualifiers) { - CONST84 char *simpleName; - Tcl_Obj *list = Tcl_NewListObj(0, NULL); + int withGuards, int fullProcQualifiers) { + CONST84 char *simpleName; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); - /*fprintf(stderr,"FilterInfo %p %s %d %d\n", pattern, pattern, withGuards, fullProcQualifiers);*/ + /*fprintf(stderr,"FilterInfo %p %s %d %d\n", pattern, pattern, withGuards, fullProcQualifiers);*/ - /* guard lists should only have unqualified filter lists - when withGuards is activated, fullProcQualifiers has not - effect */ - if (withGuards) { - fullProcQualifiers = 0; - } + /* guard lists should only have unqualified filter lists + when withGuards is activated, fullProcQualifiers has not + effect */ + if (withGuards) { + fullProcQualifiers = 0; + } - while (f) { - simpleName = Tcl_GetCommandName(interp, f->cmdPtr); - if (!pattern || Tcl_StringMatch(simpleName, pattern)) { - if (withGuards && f->clientData) { - Tcl_Obj *innerList = Tcl_NewListObj(0, NULL); - Tcl_Obj *g = (Tcl_Obj *) f->clientData; - Tcl_ListObjAppendElement(interp, innerList, - Tcl_NewStringObj(simpleName, -1)); - Tcl_ListObjAppendElement(interp, innerList, XOTclGlobalObjects[XOTE_GUARD_OPTION]); - Tcl_ListObjAppendElement(interp, innerList, g); - Tcl_ListObjAppendElement(interp, list, innerList); - } else { - if (fullProcQualifiers) { - XOTclClass *fcl; - XOTclObject *fobj; - if (f->clorobj && !XOTclObjectIsClass(&f->clorobj->object)) { - fobj = (XOTclObject *)f->clorobj; - fcl = NULL; - } else { - fobj = NULL; - fcl = f->clorobj; - } - Tcl_ListObjAppendElement(interp, list, - getFullProcQualifier(interp, simpleName, - fobj, fcl, f->cmdPtr)); - } else { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1)); - } - } + while (f) { + simpleName = Tcl_GetCommandName(interp, f->cmdPtr); + if (!pattern || Tcl_StringMatch(simpleName, pattern)) { + if (withGuards && f->clientData) { + Tcl_Obj *innerList = Tcl_NewListObj(0, NULL); + Tcl_Obj *g = (Tcl_Obj*) f->clientData; + Tcl_ListObjAppendElement(interp, innerList, + Tcl_NewStringObj(simpleName, -1)); + Tcl_ListObjAppendElement(interp, innerList, XOTclGlobalObjects[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, innerList, g); + Tcl_ListObjAppendElement(interp, list, innerList); + } else { + if (fullProcQualifiers) { + XOTclClass *fcl; + XOTclObject *fobj; + if (f->clorobj && !XOTclObjectIsClass(&f->clorobj->object)) { + fobj = (XOTclObject *)f->clorobj; + fcl = NULL; + } else { + fobj = NULL; + fcl = f->clorobj; + } + Tcl_ListObjAppendElement(interp, list, + getFullProcQualifier(interp, simpleName, + fobj, fcl, f->cmdPtr)); + } else { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1)); } - f = f->nextPtr; + } } - Tcl_SetObjResult(interp, list); - return TCL_OK; + f = f->nextPtr; + } + Tcl_SetObjResult(interp, list); + return TCL_OK; } /* - * Appends XOTclCmdPtr* containing the filter cmds and their + * Appends XOTclCmdPtr *containing the filter cmds and their * superclass specializations to 'filterList' */ static void FilterComputeOrderFullList(Tcl_Interp *interp, XOTclCmdList **filters, - XOTclCmdList **filterList) { - XOTclCmdList *f ; - char *simpleName; - XOTclClass *fcl; - XOTclClasses *pl; + XOTclCmdList **filterList) { + XOTclCmdList *f ; + char *simpleName; + XOTclClass *fcl; + XOTclClasses *pl; - /* - * ensure that no epoched command is in the filters list - */ - CmdListRemoveEpoched(filters, GuardDel); + /* + * ensure that no epoched command is in the filters list + */ + CmdListRemoveEpoched(filters, GuardDel); - for (f = *filters; f; f = f->nextPtr) { - simpleName = (char *) Tcl_GetCommandName(interp, f->cmdPtr); - fcl = f->clorobj; - CmdListAdd(filterList, f->cmdPtr, fcl, /*noDuplicates*/ 0); + for (f = *filters; f; f = f->nextPtr) { + simpleName = (char *) Tcl_GetCommandName(interp, f->cmdPtr); + fcl = f->clorobj; + CmdListAdd(filterList, f->cmdPtr, fcl, /*noDuplicates*/ 0); - if (fcl && !XOTclObjectIsClass(&fcl->object)) { - /* get the object for per-object filter */ - XOTclObject *fObj = (XOTclObject *)fcl; - /* and then get class */ - fcl = fObj->cl; - } + if (fcl && !XOTclObjectIsClass(&fcl->object)) { + /* get the object for per-object filter */ + XOTclObject *fObj = (XOTclObject *)fcl; + /* and then get class */ + fcl = fObj->cl; + } - /* if we have a filter class -> search up the inheritance hierarchy*/ - if (fcl) { - pl = ComputeOrder(fcl, fcl->order, Super); - if (pl && pl->nextPtr) { - /* don't search on the start class again */ - pl = pl->nextPtr; - /* now go up the hierarchy */ - for(; pl; pl = pl->nextPtr) { - Tcl_Command pi = FindMethod(simpleName, pl->cl->nsPtr); - if (pi) { - CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0); - /* - fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName); - */ - } - } - } + /* if we have a filter class -> search up the inheritance hierarchy*/ + if (fcl) { + pl = ComputeOrder(fcl, fcl->order, Super); + if (pl && pl->nextPtr) { + /* don't search on the start class again */ + pl = pl->nextPtr; + /* now go up the hierarchy */ + for(; pl; pl = pl->nextPtr) { + Tcl_Command pi = FindMethod(simpleName, pl->cl->nsPtr); + if (pi) { + CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0); + /* + fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName); + */ + } } + } } - /*CmdListPrint(interp,"FilterComputeOrderFullList....\n", *filterList);*/ + } + /*CmdListPrint(interp,"FilterComputeOrderFullList....\n", *filterList);*/ } /* @@ -4295,72 +4667,72 @@ */ static void FilterComputeOrder(Tcl_Interp *interp, XOTclObject *obj) { - XOTclCmdList *filterList = 0, *next, *checker, *newlist; - XOTclClasses *pl; + XOTclCmdList *filterList = NULL, *next, *checker, *newlist; + XOTclClasses *pl; - if (obj->filterOrder) FilterResetOrder(obj); - /* - fprintf(stderr, " List: ", ObjStr(obj->cmdName)); - */ + if (obj->filterOrder) FilterResetOrder(obj); + /* + fprintf(stderr, " List: ", ObjStr(obj->cmdName)); + */ - /* append instfilters registered for mixins */ - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); + /* append instfilters registered for mixins */ + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - XOTclClass *mixin; - while (ml) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin && mixin->opt && mixin->opt->instfilters) - FilterComputeOrderFullList(interp, &mixin->opt->instfilters, &filterList); - ml = ml->nextPtr; - } + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml; + XOTclClass *mixin; + + for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin && mixin->opt && mixin->opt->instfilters) + FilterComputeOrderFullList(interp, &mixin->opt->instfilters, &filterList); } + } - /* append per-obj filters */ - if (obj->opt) - FilterComputeOrderFullList(interp, &obj->opt->filters, &filterList); + /* append per-obj filters */ + if (obj->opt) + FilterComputeOrderFullList(interp, &obj->opt->filters, &filterList); - /* append per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl=pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->instfilters) { - FilterComputeOrderFullList(interp, &opt->instfilters, &filterList); - } + /* append per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl=pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instfilters) { + FilterComputeOrderFullList(interp, &opt->instfilters, &filterList); } + } - /* - fprintf(stderr, "\n"); - */ - /* use no duplicates & no classes of the precedence order - on the resulting list */ - while (filterList) { - checker = next = filterList->nextPtr; - while (checker) { - if (checker->cmdPtr == filterList->cmdPtr) break; - checker = checker->nextPtr; - } - if (checker == 0) { - newlist = CmdListAdd(&obj->filterOrder, filterList->cmdPtr, filterList->clorobj, - /*noDuplicates*/ 0); - GuardAddInheritedGuards(interp, newlist, obj, filterList->cmdPtr); - /* - fprintf(stderr, " Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(interp, filterList->cmdPtr)); - */ - /* - GuardPrint(interp, newlist->clientData); - */ + /* + fprintf(stderr, "\n"); + */ + /* use no duplicates & no classes of the precedence order + on the resulting list */ + while (filterList) { + checker = next = filterList->nextPtr; + while (checker) { + if (checker->cmdPtr == filterList->cmdPtr) break; + checker = checker->nextPtr; + } + if (checker == NULL) { + newlist = CmdListAdd(&obj->filterOrder, filterList->cmdPtr, filterList->clorobj, + /*noDuplicates*/ 0); + GuardAddInheritedGuards(interp, newlist, obj, filterList->cmdPtr); + /* + fprintf(stderr, " Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(interp, filterList->cmdPtr)); + */ + /* + GuardPrint(interp, newlist->clientData); + */ - } + } - CmdListDeleteCmdListEntry(filterList, GuardDel); + CmdListDeleteCmdListEntry(filterList, GuardDel); - filterList = next; - } - /* - fprintf(stderr, "\n"); - */ + filterList = next; + } + /* + fprintf(stderr, "\n"); + */ } /* @@ -4374,86 +4746,61 @@ */ static void FilterComputeDefined(Tcl_Interp *interp, XOTclObject *obj) { - FilterComputeOrder(interp, obj); - obj->flags |= XOTCL_FILTER_ORDER_VALID; - if (obj->filterOrder) - obj->flags |= XOTCL_FILTER_ORDER_DEFINED; - else - obj->flags &= ~XOTCL_FILTER_ORDER_DEFINED; + FilterComputeOrder(interp, obj); + obj->flags |= XOTCL_FILTER_ORDER_VALID; + if (obj->filterOrder) + obj->flags |= XOTCL_FILTER_ORDER_DEFINED; + else + obj->flags &= ~XOTCL_FILTER_ORDER_DEFINED; } /* * push a filter stack information on this object */ static int FilterStackPush(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *calledProc) { - register XOTclFilterStack *h = NEW(XOTclFilterStack); + register XOTclFilterStack *h = NEW(XOTclFilterStack); - h->currentCmdPtr = 0; - h->calledProc = calledProc; - INCR_REF_COUNT(h->calledProc); - h->nextPtr = obj->filterStack; - obj->filterStack = h; - return 1; + h->currentCmdPtr = NULL; + h->calledProc = calledProc; + INCR_REF_COUNT(h->calledProc); + h->nextPtr = obj->filterStack; + obj->filterStack = h; + return 1; } /* * pop a filter stack information on this object */ static void FilterStackPop(XOTclObject *obj) { - register XOTclFilterStack *h = obj->filterStack; - obj->filterStack = h->nextPtr; + register XOTclFilterStack *h = obj->filterStack; + obj->filterStack = h->nextPtr; - /* free stack entry */ - DECR_REF_COUNT(h->calledProc); - FREE(XOTclFilterStack, h); + /* free stack entry */ + DECR_REF_COUNT(h->calledProc); + FREE(XOTclFilterStack, h); } /* - * walk through the filter order until the current filter is reached. - * then use the next filter as current filter. - * - * precondition: obj->filterStack is not NULL - */ -static void -FilterSeekCurrent(Tcl_Interp *interp, XOTclObject *obj, XOTclCmdList **cmdList) { - Tcl_Command currentCmd = obj->filterStack->currentCmdPtr; - - assert(obj->flags & XOTCL_FILTER_ORDER_VALID); - /* ensure that the filter order is not invalid, otherwise compute order - FilterComputeDefined(interp, obj); - */ - - *cmdList = obj->filterOrder; - - /* go forward to current class */ - while (*cmdList && currentCmd) { - if ((*cmdList)->cmdPtr == currentCmd) - currentCmd = 0; - *cmdList = (*cmdList)->nextPtr; - } -} - -/* * seek through the filters active for "obj" and check whether cmdPtr * is among them */ XOTCLINLINE static int FilterActiveOnObj(Tcl_Interp *interp, XOTclObject *obj, Tcl_Command cmd) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *bot = cs->content; - register XOTclCallStackContent *csc = cs->top; - while (csc > bot) { - /* only check the callstack entries for this object && - only check the callstack entries for the given cmd */ - if (obj == csc->self && cmd == csc->cmdPtr && - csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - return 1; - } - csc--; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *bot = cs->content; + register XOTclCallStackContent *csc = cs->top; + while (csc > bot) { + /* only check the callstack entries for this object && + only check the callstack entries for the given cmd */ + if (obj == csc->self && cmd == csc->cmdPtr && + csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + return 1; } - return 0; + csc--; + } + return 0; } /* @@ -4467,2740 +4814,2794 @@ */ static Tcl_Obj * FilterFindReg(Tcl_Interp *interp, XOTclObject *obj, Tcl_Command cmd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclClasses *pl; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclClasses *pl; - /* search per-object filters */ - if (obj->opt && CmdListFindCmdInList(cmd, obj->opt->filters)) { - Tcl_ListObjAppendElement(interp, list, obj->cmdName); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FILTER]); + /* search per-object filters */ + if (obj->opt && CmdListFindCmdInList(cmd, obj->opt->filters)) { + Tcl_ListObjAppendElement(interp, list, obj->cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FILTER]); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); + return list; + } + + /* search per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instfilters) { + if (CmdListFindCmdInList(cmd, opt->instfilters)) { + Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFILTER]); Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); return list; + } } - - /* search per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->instfilters) { - if (CmdListFindCmdInList(cmd, opt->instfilters)) { - Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFILTER]); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); - return list; - } - } - } - return list; + } + return list; } /* * before we can perform a filter dispatch, FilterSearchProc seeks the * current filter and the relevant calling information */ static Tcl_Command -FilterSearchProc(Tcl_Interp *interp, XOTclObject *obj, Tcl_ObjCmdProc **proc, ClientData *cp, - Tcl_Command *currentCmd, XOTclClass **cl) { - XOTclCmdList *cmdList; +FilterSearchProc(Tcl_Interp *interp, XOTclObject *obj, + Tcl_Command *currentCmd, XOTclClass **cl) { + XOTclCmdList *cmdList; - assert(obj); - assert(obj->filterStack); + assert(obj); + assert(obj->filterStack); - *currentCmd = 0; - *proc = 0; - *cp = 0; + *currentCmd = NULL; - FilterSeekCurrent(interp, obj, &cmdList); - while (cmdList) { - if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { - cmdList = cmdList->nextPtr; - } else if (FilterActiveOnObj(interp, obj, cmdList->cmdPtr)) { - /* fprintf(stderr, "Filter <%s> -- Active on: %s\n", - Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), ObjStr(obj->cmdName)); - */ - obj->filterStack->currentCmdPtr = cmdList->cmdPtr; - FilterSeekCurrent(interp, obj, &cmdList); - } else { - /* ok. we found it */ - *proc = Tcl_Command_objProc(cmdList->cmdPtr); - *cp = Tcl_Command_objClientData(cmdList->cmdPtr); - if (cmdList->clorobj && !XOTclObjectIsClass(&cmdList->clorobj->object)) { - *cl = NULL; - } else { - *cl = cmdList->clorobj; - } - *currentCmd = cmdList->cmdPtr; - /* fprintf(stderr, "FilterSearchProc - found: %s, %p\n", - Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), cmdList->cmdPtr); - */ - return cmdList->cmdPtr; - } + /* Ensure that the filter order is not invalid, otherwise compute order + FilterComputeDefined(interp, obj); + */ + assert(obj->flags & XOTCL_FILTER_ORDER_VALID); + cmdList = seekCurrent(obj->filterStack->currentCmdPtr, obj->filterOrder); + + while (cmdList) { + if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { + cmdList = cmdList->nextPtr; + } else if (FilterActiveOnObj(interp, obj, cmdList->cmdPtr)) { + /* fprintf(stderr, "Filter <%s> -- Active on: %s\n", + Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), ObjStr(obj->cmdName)); + */ + obj->filterStack->currentCmdPtr = cmdList->cmdPtr; + cmdList = seekCurrent(obj->filterStack->currentCmdPtr, obj->filterOrder); + } else { + /* ok. we found it */ + if (cmdList->clorobj && !XOTclObjectIsClass(&cmdList->clorobj->object)) { + *cl = NULL; + } else { + *cl = cmdList->clorobj; + } + *currentCmd = cmdList->cmdPtr; + /* fprintf(stderr, "FilterSearchProc - found: %s, %p\n", + Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), cmdList->cmdPtr); + */ + return cmdList->cmdPtr; } - return 0; + } + return NULL; } static int SuperclassAdd(Tcl_Interp *interp, XOTclClass *cl, int oc, Tcl_Obj **ov, Tcl_Obj *arg, XOTclClass *base) { - XOTclClasses *filterCheck, *osl = 0; - XOTclClass **scl = 0; - int reversed = 0; - int i, j; - - filterCheck = ComputeOrder(cl, cl->order, Super); - /* - * we have to remove all dependent superclass filter referenced - * by class or one of its subclasses - * - * do not check the class "cl" itself (first entry in - * filterCheck class list) - */ - if (filterCheck) - filterCheck = filterCheck->nextPtr; - while (filterCheck) { - FilterRemoveDependentFilterCmds(cl, filterCheck->cl); - filterCheck = filterCheck->nextPtr; + XOTclClasses *filterCheck, *osl = NULL; + XOTclClass **scl; + int reversed = 0; + int i, j; + + filterCheck = ComputeOrder(cl, cl->order, Super); + /* + * we have to remove all dependent superclass filter referenced + * by class or one of its subclasses + * + * do not check the class "cl" itself (first entry in + * filterCheck class list) + */ + if (filterCheck) + filterCheck = filterCheck->nextPtr; + for (; filterCheck; filterCheck = filterCheck->nextPtr) { + FilterRemoveDependentFilterCmds(cl, filterCheck->cl); + } + + /* invalidate all interceptors orders of instances of this + and of all depended classes */ + MixinInvalidateObjOrders(interp, cl); + FilterInvalidateObjOrders(interp, cl); + + scl = NEW_ARRAY(XOTclClass*, oc); + for (i = 0; i < oc; i++) { + if (GetXOTclClassFromObj(interp, ov[i], &scl[i], base) != TCL_OK) { + FREE(XOTclClass**, scl); + return XOTclErrBadVal(interp, "superclass", "a list of classes", + ObjStr(arg)); } - - /* invalidate all interceptors orders of instances of this - and of all depended classes */ - MixinInvalidateObjOrders(interp, cl); - FilterInvalidateObjOrders(interp, cl); - - scl = NEW_ARRAY(XOTclClass*, oc); - for (i = 0; i < oc; i++) { - if (GetXOTclClassFromObj(interp, ov[i], &scl[i], base) != TCL_OK) { - FREE(XOTclClass**, scl); - return XOTclErrBadVal(interp, "superclass", "a list of classes", - ObjStr(arg)); - } + } + + /* + * check that superclasses don't precede their classes + */ + + for (i = 0; i < oc; i++) { + if (reversed) break; + for (j = i+1; j < oc; j++) { + XOTclClasses *dl = ComputeOrder(scl[j], scl[j]->order, Super); + if (reversed) break; + while (dl) { + if (dl->cl == scl[i]) break; + dl = dl->nextPtr; + } + if (dl) reversed = 1; } - + } + + if (reversed) { + return XOTclErrBadVal(interp, "superclass", "classes in dependence order", + ObjStr(arg)); + } + + while (cl->super) { /* - * check that superclasses don't precede their classes + * build up an old superclass list in case we need to revert */ - - for (i = 0; i < oc; i++) { - if (reversed != 0) break; - for (j = i+1; j < oc; j++) { - XOTclClasses *dl = ComputeOrder(scl[j], scl[j]->order, Super); - if (reversed != 0) break; - while (dl != 0) { - if (dl->cl == scl[i]) break; - dl = dl->nextPtr; - } - if (dl != 0) reversed = 1; - } - } - - if (reversed != 0) { - return XOTclErrBadVal(interp, "superclass", "classes in dependence order", - ObjStr(arg)); - } - - while (cl->super != 0) { - - /* - * build up an old superclass list in case we need to revert - */ - - XOTclClass *sc = cl->super->cl; - XOTclClasses *l = osl; - osl = NEW(XOTclClasses); - osl->cl = sc; - osl->nextPtr = l; - (void)RemoveSuper(cl, cl->super->cl); - } - for (i = 0; i < oc; i++) - AddSuper(cl, scl[i]); - FREE(XOTclClass**, scl); - FlushPrecedences(cl); - - if (!ComputeOrder(cl, cl->order, Super)) { - - /* - * cycle in the superclass graph, backtrack - */ - - XOTclClasses *l; - while (cl->super != 0) (void)RemoveSuper(cl, cl->super->cl); - for (l = osl; l != 0; l = l->nextPtr) AddSuper(cl, l->cl); - XOTclClassListFree(osl); - return XOTclErrBadVal(interp, "superclass", "a cycle-free graph", ObjStr(arg)); - } + + XOTclClass *sc = cl->super->cl; + XOTclClasses *l = osl; + osl = NEW(XOTclClasses); + osl->cl = sc; + osl->nextPtr = l; + (void)RemoveSuper(cl, cl->super->cl); + } + for (i = 0; i < oc; i++) { + AddSuper(cl, scl[i]); + } + FREE(XOTclClass**, scl); + FlushPrecedencesOnSubclasses(cl); + + if (!ComputeOrder(cl, cl->order, Super)) { + + /* + * cycle in the superclass graph, backtrack + */ + + XOTclClasses *l; + while (cl->super) (void)RemoveSuper(cl, cl->super->cl); + for (l = osl; l; l = l->nextPtr) AddSuper(cl, l->cl); XOTclClassListFree(osl); - - /* if there are no more super classes add the Object - class as superclasses */ - if (cl->super == 0) - AddSuper(cl, RUNTIME_STATE(interp)->theObject); - - Tcl_ResetResult(interp); - return TCL_OK; + return XOTclErrBadVal(interp, "superclass", "a cycle-free graph", ObjStr(arg)); + } + XOTclClassListFree(osl); + + /* if there are no more super classes add the Object + class as superclasses */ + if (cl->super == NULL) + AddSuper(cl, RUNTIME_STATE(interp)->theObject); + + Tcl_ResetResult(interp); + return TCL_OK; } extern Tcl_Obj * XOTcl_ObjSetVar2(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, Tcl_Obj *value, int flgs) { - Tcl_Obj *result; - XOTcl_FrameDecls; + Tcl_Obj *result; + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, (XOTclObject*)obj); - if (((XOTclObject*)obj)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_ObjSetVar2(interp, name1, name2, value, flgs); - XOTcl_PopFrame(interp, (XOTclObject*)obj); - return result; + result = Tcl_ObjSetVar2(interp, name1, name2, value, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); + return result; } extern Tcl_Obj * XOTcl_SetVar2Ex(XOTcl_Object *obj, Tcl_Interp *interp, CONST char *name1, CONST char *name2, Tcl_Obj *value, int flgs) { - Tcl_Obj *result; - XOTcl_FrameDecls; + Tcl_Obj *result; + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, (XOTclObject*)obj); - if (((XOTclObject*)obj)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_SetVar2Ex(interp, name1, name2, value, flgs); - XOTcl_PopFrame(interp, (XOTclObject*)obj); - return result; + result = Tcl_SetVar2Ex(interp, name1, name2, value, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); + return result; } Tcl_Obj * XOTclOSetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name, Tcl_Obj *value, int flgs) { - return XOTcl_ObjSetVar2(obj, interp, name, (Tcl_Obj *)NULL, value, (flgs|TCL_PARSE_PART1)); + return XOTcl_ObjSetVar2(obj, interp, name, (Tcl_Obj *)NULL, value, (flgs|TCL_PARSE_PART1)); } extern Tcl_Obj * XOTcl_ObjGetVar2(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, int flgs) { - Tcl_Obj *result; - XOTcl_FrameDecls; + Tcl_Obj *result; + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, (XOTclObject*)obj); - if (((XOTclObject*)obj)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_ObjGetVar2(interp, name1, name2, flgs); - XOTcl_PopFrame(interp, (XOTclObject*)obj); + result = Tcl_ObjGetVar2(interp, name1, name2, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); - return result; + return result; } extern Tcl_Obj * XOTcl_GetVar2Ex(XOTcl_Object *obj, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flgs) { - Tcl_Obj *result; - XOTcl_FrameDecls; + Tcl_Obj *result; + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, (XOTclObject*)obj); - if (((XOTclObject*)obj)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_GetVar2Ex(interp, name1, name2, flgs); - XOTcl_PopFrame(interp, (XOTclObject*)obj); - return result; + result = Tcl_GetVar2Ex(interp, name1, name2, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); + return result; } Tcl_Obj * XOTclOGetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name, int flgs) { - return XOTcl_ObjGetVar2(obj, interp, name, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1)); + return XOTcl_ObjGetVar2(obj, interp, name, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1)); } int XOTclUnsetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, char *name, int flgs) { - return XOTclUnsetInstVar2 (obj, interp, name,(char *)NULL, flgs); + return XOTclUnsetInstVar2 (obj, interp, name,(char *)NULL, flgs); } - - static int varExists(Tcl_Interp *interp, XOTclObject *obj, CONST char *varName, char *index, - int triggerTrace, int requireDefined) { - XOTcl_FrameDecls; - Var *varPtr, *arrayPtr; - int result; - int flags; + int triggerTrace, int requireDefined) { + XOTcl_FrameDecls; + Var *varPtr, *arrayPtr; + int result; + int flags = 0; - flags = (index == NULL) ? TCL_PARSE_PART1 : 0; - - if (obj->nsPtr) { - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - varResolver, (Tcl_ResolveCompiledVarProc*)NULL); - } + flags = (index == NULL) ? TCL_PARSE_PART1 : 0; + + XOTcl_PushFrame(interp, obj); - XOTcl_PushFrame(interp, obj); - #if defined(PRE83) + varPtr = TclLookupVar(interp, varName, index, flags, "access", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); +#else + if (triggerTrace) + varPtr = TclVarTraceExists(interp, varName); + else varPtr = TclLookupVar(interp, varName, index, flags, "access", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); -#else - if (triggerTrace) - varPtr = TclVarTraceExists(interp, varName); - else - varPtr = TclLookupVar(interp, varName, index, flags, "access", - /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); #endif - result = ((varPtr != NULL) && - (!requireDefined || !TclIsVarUndefined(varPtr))); + /* + fprintf(stderr, "varExists %s varPtr %p requireDefined %d, triggerTrace %d, isundef %d\n", + varName, + varPtr, + requireDefined, triggerTrace, + varPtr ? TclIsVarUndefined(varPtr) : 0); + */ + result = (varPtr && (!requireDefined || !TclIsVarUndefined(varPtr))); - XOTcl_PopFrame(interp, obj); - - if (obj->nsPtr) { - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - (Tcl_ResolveVarProc *)NULL, - (Tcl_ResolveCompiledVarProc*)NULL); - } - return result; + XOTcl_PopFrame(interp, obj); + + return result; } static int evalValueIfNeeded(Tcl_Interp *interp, XOTclObject *obj, CONST char *varName, Tcl_Obj **newValue) { - int rc = TCL_OK; - int doSubst = 0; - char *value = ObjStr(*newValue), *v; - /*fprintf(stderr,"+++++ %s.%s got '%s''\n", ObjStr(obj->cmdName), varName, ObjStr(newValue));*/ - - /* TODO: maybe we can do this more elegantely without the need to parse the vars */ - for (v=value; *v; v++) { - if (*v == '[' && doSubst == 0) - doSubst = 1; - else if ((doSubst == 1 && *v == ']') || *v == '$') { - doSubst = 2; - break; - } + int rc = TCL_OK; + int doSubst = 0; + char *value = ObjStr(*newValue), *v; + /*fprintf(stderr,"+++++ %s.%s got '%s''\n", ObjStr(obj->cmdName), varName, ObjStr(newValue));*/ + + /* TODO: maybe we can do this more elegantely without the need to parse the vars */ + for (v=value; *v; v++) { + if (*v == '[' && doSubst == 0) + doSubst = 1; + else if ((doSubst == 1 && *v == ']') || *v == '$') { + doSubst = 2; + break; } + } + + if (doSubst == 2) { /* we have to subst, we overwrite newValue */ + Tcl_Obj *ov[2]; + ov[1] = *newValue; + Tcl_ResetResult(interp); - if (doSubst == 2) { /* we have to subst, we overwrite newValue */ - Tcl_Obj *ov[2]; - ov[1] = *newValue; - Tcl_ResetResult(interp); - - CallStackPush(interp, obj, NULL, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); - rc = XOTcl_SubstObjCmd(NULL, interp, 2, ov); - CallStackPop(interp); - - /*fprintf(stderr,"+++++ %s.%s subst returned %d OK %d\n", - ObjStr(obj->cmdName), varName, rc, TCL_OK);*/ - - if (rc == TCL_OK) { - *newValue = Tcl_GetObjResult(interp); - } + CallStackPush(interp, obj, NULL, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); + rc = XOTcl_SubstObjCmd(NULL, interp, 2, ov); + CallStackPop(interp); + + /*fprintf(stderr,"+++++ %s.%s subst returned %d OK %d\n", + ObjStr(obj->cmdName), varName, rc, TCL_OK);*/ + + if (rc == TCL_OK) { + *newValue = Tcl_GetObjResult(interp); } - return rc; + } + return rc; } static int setDefaultValue(Tcl_Interp *interp, XOTclObject *obj, XOTclObject *slotObj) { - CONST char *varName = Tcl_GetCommandName(interp, slotObj->id); - Tcl_Obj *oldValue; - int rc = TCL_OK; + CONST char *varName = Tcl_GetCommandName(interp, slotObj->id); + Tcl_Obj *oldValue; + int rc = TCL_OK; - XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); /* make instvars of obj accessible */ + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); /* make instvars of obj accessible */ - /* - * caller did a XOTcl_PushFrame(interp, obj), - * so we have the instvars already accessible; - */ - oldValue = Tcl_GetVar2Ex(interp, varName, NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + /* + * caller did a XOTcl_PushFrame(interp, obj), + * so we have the instvars already accessible; + */ + oldValue = Tcl_GetVar2Ex(interp, varName, NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - /* Check whether the variable is already set. - * If yes, we do not set it again. - */ - if (oldValue == NULL) { - Tcl_Obj *newValue = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj, interp, "default", NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - /*fprintf(stderr,"+++++ %s.%s undefined'\n", ObjStr(obj->cmdName), varName);*/ - if (newValue) { - rc = evalValueIfNeeded(interp, obj, varName, &newValue); - if (rc != TCL_OK) { - goto leavesetdefaultvalue; - } + /* Check whether the variable is already set. + * If yes, we do not set it again. + */ + if (oldValue == NULL) { + Tcl_Obj *newValue = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj, interp, "default", NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + /*fprintf(stderr,"+++++ %s.%s undefined'\n", ObjStr(obj->cmdName), varName);*/ + if (newValue) { + rc = evalValueIfNeeded(interp, obj, varName, &newValue); + if (rc != TCL_OK) { + goto leavesetdefaultvalue; + } - /* - * just set the variable, checking is happening later - */ - /*fprintf(stderr,"+++++ %s.%s := '%s'\n", ObjStr(obj->cmdName), varName, ObjStr(newValue));*/ + /* + * just set the variable, checking is happening later + */ + /*fprintf(stderr,"+++++ %s.%s := '%s'\n", ObjStr(obj->cmdName), varName, ObjStr(newValue));*/ - Tcl_SetVar2Ex(interp, varName, NULL, newValue, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + Tcl_SetVar2Ex(interp, varName, NULL, newValue, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - } else { - /*fprintf(stderr, "----- we have no new value %s\n", varName);*/ - } - /* - * we set the initCmd for the time being unconditionally, if it is available - */ - { - /* try to get initcmd - */ - Tcl_Obj *initCmd = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj, interp, "initcmd", NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - if (initCmd) { - char *cmd = ObjStr(initCmd); - /*fprintf(stderr, "----- we have an initcmd %s\n", cmd);*/ - if (*cmd) { - CallStackPush(interp, obj, NULL, 0, 0, - 0, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/ + } else { + /*fprintf(stderr, "----- we have no new value %s\n", varName);*/ + } + /* + * we set the initCmd for the time being unconditionally, if it is available + */ + { + /* try to get initcmd + */ + Tcl_Obj *initCmd = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj, interp, "initcmd", NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + if (initCmd) { + char *cmd = ObjStr(initCmd); + /*fprintf(stderr, "----- we have an initcmd %s\n", cmd);*/ + if (*cmd) { + CallStackPush(interp, obj, NULL, 0, 0, + 0, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/ - /*fprintf(stderr,"!!!! evaluating '%s'\n", cmd); */ - rc = Tcl_EvalObjEx(interp, initCmd, TCL_EVAL_DIRECT); - CallStackPop(interp); + /*fprintf(stderr,"!!!! evaluating '%s'\n", cmd); */ + rc = Tcl_EvalObjEx(interp, initCmd, TCL_EVAL_DIRECT); + CallStackPop(interp); - if (rc != TCL_OK) { - goto leavesetdefaultvalue; - } - } - } - } - } else { - /* fprintf(stderr, "+++ value for %s.%s already set\n", ObjStr(obj->cmdName), varName);*/ + if (rc != TCL_OK) { + goto leavesetdefaultvalue; + } + } + } } + } else { + /* fprintf(stderr, "+++ value for %s.%s already set\n", ObjStr(obj->cmdName), varName);*/ + } leavesetdefaultvalue: - XOTcl_PopFrame(interp, obj); - return rc; + XOTcl_PopFrame(interp, obj); + return rc; } static int checkRequiredValue(Tcl_Interp *interp, XOTclObject *obj, XOTclObject *slotObj) { - CONST char *varName = Tcl_GetCommandName(interp, slotObj->id); - int rc = TCL_OK, bool; - Tcl_Obj *requiredFlag = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj, interp, "required", NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - if (requiredFlag) { - rc = Tcl_GetBooleanFromObj(interp, requiredFlag, &bool); - if (rc == TCL_OK && bool) { - /*fprintf(stderr,"+++++ %s.%s must check'\n", ObjStr(obj->cmdName), varName);*/ - if (!varExists(interp, obj, varName, NULL, 0, 1)) { - return XOTclVarErrMsg(interp, - "required parameter '", varName, "' missing", - (char *) NULL); - } - } + CONST char *varName = Tcl_GetCommandName(interp, slotObj->id); + int rc = TCL_OK, bool; + Tcl_Obj *requiredFlag = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj, interp, "required", NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + if (requiredFlag) { + rc = Tcl_GetBooleanFromObj(interp, requiredFlag, &bool); + if (rc == TCL_OK && bool) { + /*fprintf(stderr,"+++++ %s.%s must check'\n", ObjStr(obj->cmdName), varName);*/ + if (!varExists(interp, obj, varName, NULL, 0, 1)) { + return XOTclVarErrMsg(interp, + "required parameter '", varName, "' missing", + (char *) NULL); + } } - return rc; + } + return rc; } +#if !defined(PRE85) +# if defined(WITH_TCL_COMPILE) +# include +# endif + static void +MakeProcError( + Tcl_Interp *interp, /* The interpreter in which the procedure was + * called. */ + Tcl_Obj *procNameObj) /* Name of the procedure. Used for error + * messages and trace information. */ +{ + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + + overflow = (nameLen > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (procedure \"%.*s%s\" line %d)", + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine)); +} + +static int PushProcCallFrame( + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *CONST objv[], /* Argument value objects. */ + int isLambda) /* 1 if this is a call by ApplyObjCmd: it + * needs special rules for error msg */ +{ + Proc *procPtr = (Proc *) clientData; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; + CallFrame *framePtr, **framePtrPtr = &framePtr; + int result; + static Tcl_ObjType *byteCodeType = NULL; + + if (byteCodeType == NULL) { + static XOTclMutex initMutex = 0; + XOTclMutexLock(&initMutex); + if (byteCodeType == NULL) { + byteCodeType = Tcl_GetObjType("bytecode"); + } + XOTclMutexUnlock(&initMutex); + } + + if (procPtr->bodyPtr->typePtr == byteCodeType) { +# if defined(WITH_TCL_COMPILE) + ByteCode *codePtr; + Interp *iPtr = (Interp *) interp; + + /* + * When we've got bytecode, this is the check for validity. That is, + * the bytecode must be for the right interpreter (no cross-leaks!), + * the code must be from the current epoch (so subcommand compilation + * is up-to-date), the namespace must match (so variable handling + * is right) and the resolverEpoch must match (so that new shadowed + * commands and/or resolver changes are considered). + */ + + codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr) + || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { + goto doCompilation; + } +# endif + } else { +# if defined(WITH_TCL_COMPILE) + doCompilation: +# endif + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) nsPtr, "body of proc", TclGetString(objv[isLambda])); + /*fprintf(stderr,"compile returned %d",result);*/ + if (result != TCL_OK) { + return result; + } + } + /* + * Set up and push a new call frame for the new procedure invocation. + * This call frame will execute in the proc's namespace, which might be + * different than the current namespace. The proc's namespace is that of + * its command, which can change if the command is renamed from one + * namespace to another. + */ + + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (Tcl_Namespace *) nsPtr, + (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); + + if (result != TCL_OK) { + return result; + } + + framePtr->objc = objc; + framePtr->objv = objv; + framePtr->procPtr = procPtr; + + return TCL_OK; +} +#endif + +static void getVarAndNameFromHash(Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) { - *val = VarHashGetValue(hPtr); + *val = VarHashGetValue(hPtr); #if defined(PRE85) # if FORWARD_COMPATIBLE - if (forwardCompatibleMode) { - *varNameObj = VarHashGetKey(*val); - } else { - *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); - } -# else + if (forwardCompatibleMode) { + *varNameObj = VarHashGetKey(*val); + } else { *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); + } +# else + *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); # endif #else - *varNameObj = VarHashGetKey(*val); + *varNameObj = VarHashGetKey(*val); #endif } + /* * method dispatch */ /* actually call a method (with assertion checking) */ static int callProcCheck(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, - char *methodName, int frameType, int isTclProc) { - int result = TCL_OK; - XOTclRuntimeState *rst = RUNTIME_STATE(interp); - CheckOptions co; + Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName, + int frameType, int isTclProc) { + int result = TCL_OK; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + CheckOptions co; #if defined(PROFILE) - long int startUsec, startSec; - struct timeval trt; + long int startUsec, startSec; + struct timeval trt; - gettimeofday(&trt, NULL); - startSec = trt.tv_sec; - startUsec = trt.tv_usec; + gettimeofday(&trt, NULL); + startSec = trt.tv_sec; + startUsec = trt.tv_usec; #endif - assert(obj); + assert(obj); - rst->callIsDestroy = 0; - /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 0, m=%s obj=%p (%s)\n", - methodName, obj, ObjStr(obj->cmdName));*/ + rst->callIsDestroy = 0; + /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 0, m=%s obj=%p (%s) is TclProc %d\n", + methodName, obj, ObjStr(obj->cmdName), isTclProc);*/ - /*fprintf(stderr,"*** callProcCheck: cmd = %p objproc = %p\n", cmd, Tcl_Command_objProc(cmd)); - fprintf(stderr, - "cp=%p, isTclProc=%d %p %s, dispatch=%d %p, forward=%d %p, scoped %p, ov[0]=%p oc=%d\n", - cp, - isTclProc, cmd, - Tcl_GetCommandName(interp, cmd), - Tcl_Command_objProc(cmd) == XOTclObjDispatch, XOTclObjDispatch, - Tcl_Command_objProc(cmd) == XOTclForwardMethod, XOTclForwardMethod, - XOTclObjscopedMethod, - objv[0], objc - ); - {int i; fprintf(stderr, "\tCALL ");for(i=0; iteardown) { - co = 0; - if (obj->opt) co = obj->opt->checkoptions; - if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) { - goto finish; - } - + /*fprintf(stderr, "+++ callProcCheck teardown %p, method=%s, isTclProc %d\n",obj->teardown,methodName,isTclProc);*/ + if (!obj->teardown) { + goto finish; + } + + if (isTclProc == 0) { + if (obj->opt) { + co = obj->opt->checkoptions; + if ((co & CHECK_INVAR) && + ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) { + goto finish; + } + } + #ifdef DISPATCH_TRACE - printCall(interp,"callProcCheck cmd", objc, objv); - /*fprintf(stderr,"\tproc=%s\n", Tcl_GetCommandName(interp, cmd));*/ + printCall(interp,"callProcCheck cmd", objc, objv); + fprintf(stderr,"\tcmd=%s\n", Tcl_GetCommandName(interp, cmd)); #endif - result = (*Tcl_Command_objProc(cmd))(cp, interp, objc, objv); - + + result = (*Tcl_Command_objProc(cmd))(cp, interp, objc, objv); + #ifdef DISPATCH_TRACE - printExit(interp,"callProcCheck cmd", objc, objv, result); - /*fprintf(stderr, " returnCode %d xotcl rc %d\n", - Tcl_Interp_returnCode(interp), rst->returnCode);*/ + printExit(interp,"callProcCheck cmd", objc, objv, result); + /*fprintf(stderr, " returnCode %d xotcl rc %d\n", + Tcl_Interp_returnCode(interp), rst->returnCode);*/ #endif - - /* - if (obj && obj->teardown && cl && !(obj->flags & XOTCL_DESTROY_CALLED)) { - fprintf(stderr, "Obj= %s ", ObjStr(obj->cmdName)); - fprintf(stderr, "CL= %s ", ObjStr(cl->object.cmdName)); - fprintf(stderr, "method=%s\n", methodName); - } - */ - co = 0; - if (!rst->callIsDestroy && obj->opt) co = obj->opt->checkoptions; - if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) { - goto finish; - } - } else { - /* isTclProc == 1 - * if this is a filter, check whether its guard applies, - * if not: just step forward to the next filter - */ - if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - XOTclCmdList *cmdList; + + /* + if (obj && obj->teardown && cl && !(obj->flags & XOTCL_DESTROY_CALLED)) { + fprintf(stderr, "Obj= %s ", ObjStr(obj->cmdName)); + fprintf(stderr, "CL= %s ", ObjStr(cl->object.cmdName)); + fprintf(stderr, "method=%s\n", methodName); + } + */ + /* The order of the check is important, since obj might be already + freed in case the call was a instdestroy */ + if (!rst->callIsDestroy && obj->opt) { + co = obj->opt->checkoptions; + if ((co & CHECK_INVAR) && + ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) { + goto finish; + } + } + } else { + /* isTclProc == 1 + * if this is a filter, check whether its guard applies, + * if not: just step forward to the next filter + */ + /*fprintf(stderr,"calling proc %s isTclProc %d tearDown %d\n",methodName,isTclProc,obj->teardown);*/ + + if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + XOTclCmdList *cmdList; + /* + * seek cmd in obj's filterOrder + */ + assert(obj->flags & XOTCL_FILTER_ORDER_VALID); + /* otherwise: FilterComputeDefined(interp, obj);*/ + + for (cmdList = obj->filterOrder; cmdList && cmdList->cmdPtr != cmd; cmdList = cmdList->nextPtr); + + /* + * when it is found, check whether it has a filter guard + */ + if (cmdList) { + int rc = GuardCall(obj, cl, (Tcl_Command) cmdList->cmdPtr, interp, + cmdList->clientData, 0); + if (rc != TCL_OK) { + if (rc != TCL_ERROR) { /* - * seek cmd in obj's filterOrder + * call next, use the given objv's, not the callstack objv + * we may not be in a method, thus there may be wrong or + * no callstackobjs */ - assert(obj->flags & XOTCL_FILTER_ORDER_VALID); - /* otherwise: FilterComputeDefined(interp, obj);*/ - - cmdList = obj->filterOrder; - while (cmdList && cmdList->cmdPtr != cmd) - cmdList = cmdList->nextPtr; - - /* - * when it is found, check whether it has a filter guard - */ - if (cmdList) { - int rc = GuardCall(obj, cl, (Tcl_Command) cmdList->cmdPtr, interp, - (Tcl_Obj*)cmdList->clientData, 0); - if (rc != TCL_OK) { - if (rc != TCL_ERROR) { - /* - * call next, use the given objv's, not the callstack objv - * we may not be in a method, thus there may be wrong or - * no callstackobjs - */ - /*fprintf(stderr, "... calling nextmethod\n"); XOTclCallStackDump(interp);*/ - - rc = XOTclNextMethod(obj, interp, cl, methodName, - objc, objv, /*useCallStackObjs*/ 0); - /*fprintf(stderr, "... after nextmethod\n"); - XOTclCallStackDump(interp);*/ - - } - - return rc; - } - } + /*fprintf(stderr, "... calling nextmethod\n"); XOTclCallStackDump(interp);*/ + + rc = XOTclNextMethod(obj, interp, cl, methodName, + objc, objv, /*useCallStackObjs*/ 0); + /*fprintf(stderr, "... after nextmethod\n"); + XOTclCallStackDump(interp);*/ + + } + + return rc; } + } + } - if (!rst->callIsDestroy && obj->teardown - && !(obj->flags & XOTCL_DESTROY_CALLED)) { - if (obj->opt && - (obj->opt->checkoptions & CHECK_PRE) && - (result = AssertionCheck(interp, obj, cl, methodName, CHECK_PRE)) == TCL_ERROR) { - goto finish; - } - } + /*fprintf(stderr, "AFTER FILTER, teardown=%p call is destroy %d\n",obj->teardown,rst->callIsDestroy);*/ + + /* + if (!obj->teardown || rst->callIsDestroy) { + goto finish; + } + */ - if (Tcl_Interp_numLevels(interp) <= 2) - rst->returnCode = TCL_OK; + if (obj->opt && + (obj->opt->checkoptions & CHECK_PRE) && + (result = AssertionCheck(interp, obj, cl, methodName, CHECK_PRE)) == TCL_ERROR) { + goto finish; + } + +#if defined(RST_RETURNCODE) + if (Tcl_Interp_numLevels(interp) <= 2) + rst->returnCode = TCL_OK; +#endif + #ifdef DISPATCH_TRACE - printCall(interp,"callProcCheck tclCmd", objc, objv); - fprintf(stderr,"\tproc=%s\n", Tcl_GetCommandName(interp, cmd)); + printCall(interp,"callProcCheck tclCmd", objc, objv); + fprintf(stderr,"\tproc=%s\n", Tcl_GetCommandName(interp, cmd)); #endif - result = (*Tcl_Command_objProc(cmd))(cp, interp, objc, objv); - -#ifdef DISPATCH_TRACE - printExit(interp,"callProcCheck tclCmd", objc, objv, result); - /* fprintf(stderr, " returnCode %d xotcl rc %d\n", - Tcl_Interp_returnCode(interp), rst->returnCode);*/ + /* + * In case, we have Tcl 8.5.* or better, we can avoid calling the + * standard TclObjInterpProc() and ::xotcl::initProcNS defined in + * the method, since Tcl 8.5 has a separate functions + * PushProcCallFrame() and TclObjInterpProcCore(), where the + * latter is callable from the outside (e.g. from XOTcl). This new + * interface allows us to setup the XOTcl callframe before the + * bytecode of the method body (provisioned by PushProcCallFrame) + * is executed. On the medium range, we do not need the xotcl + * callframe when we stop supporting Tcl 8.4 (we should simply use + * the calldata field in the callstack), which should be managed + * here or in PushProcCallFrame. At the same time, we could do the + * non-pos-arg handling here as well. + */ +#if !defined(PRE85) + /*fprintf(stderr,"\tproc=%s cp=%p %d\n", Tcl_GetCommandName(interp, cmd),cp, isTclProc);*/ + + result = PushProcCallFrame(cp, interp, objc, objv, /*isLambda*/ 0); + + if (result == TCL_OK) { + rst->cs.top->currentFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); + result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); + } else { + result = TCL_ERROR; + } +#else + result = (*Tcl_Command_objProc(cmd))(cp, interp, objc, objv); #endif - if (result == TCL_BREAK && rst->returnCode == TCL_OK) { - rst->returnCode = result; - } - /* fprintf(stderr, "dispatch returned %d rst = %d\n", result, rst->returnCode);*/ +#ifdef DISPATCH_TRACE + printExit(interp,"callProcCheck tclCmd", objc, objv, result); + /* fprintf(stderr, " returnCode %d xotcl rc %d\n", + Tcl_Interp_returnCode(interp), result);*/ +#endif - /* we give the information whether the call has destroyed the - object back to the caller, because after CallStackPop it - cannot be retrieved via the call stack */ - /* if the object is destroyed -> the assertion structs's are already - destroyed */ - if (rst->cs.top->callType & XOTCL_CSC_CALL_IS_DESTROY) { - rst->callIsDestroy = 1; - /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 1 method = %s\n", - methodName);*/ - } - - if (obj->opt && !rst->callIsDestroy && obj->teardown && - (obj->opt->checkoptions & CHECK_POST) && - (result = AssertionCheck(interp, obj, cl, methodName, CHECK_POST) == TCL_ERROR)) { - goto finish; - } +#if defined(RST_RETURNCODE) + if (result == TCL_BREAK && rst->returnCode == TCL_OK) + rst->returnCode = result; +#endif + + /* fprintf(stderr, "dispatch returned %d rst = %d\n", result, rst->returnCode);*/ + + /* we give the information whether the call has destroyed the + object back to the caller, because after CallStackPop it + cannot be retrieved via the call stack */ + /* if the object is destroyed -> the assertion structs's are already + destroyed */ + if (rst->cs.top->callType & XOTCL_CSC_CALL_IS_DESTROY) { + rst->callIsDestroy = 1; + /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 1 method = %s\n", + methodName);*/ } + + if (obj->opt && !rst->callIsDestroy && obj->teardown && + (obj->opt->checkoptions & CHECK_POST) && + (result = AssertionCheck(interp, obj, cl, methodName, CHECK_POST) == TCL_ERROR)) { + goto finish; + } + } finish: - #if defined(PROFILE) - if (rst->callIsDestroy == 0) { - XOTclProfileEvaluateData(interp, startSec, startUsec, obj, cl, methodName); - } + if (rst->callIsDestroy == 0) { + XOTclProfileEvaluateData(interp, startSec, startUsec, obj, cl, methodName); + } #endif - return result; + return result; } static int -DoCallProcCheck(ClientData cp, ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], - Tcl_Command cmd, XOTclObject *obj, - XOTclClass *cl, char *methodName, - int frameType, int fromNext, int forcePush) { - int rc, push = 1, isTclProc = 0; +DoCallProcCheck(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], + Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, + char *methodName, int frameType) { + int rc, push, isTclProc = 0; + ClientData cp = Tcl_Command_objClientData(cmd); + + /*fprintf(stderr, "DoCallProcCheck method '%s' cmd %p cp=%p\n",methodName,cmd, cp);*/ - /*fprintf(stderr,"DoCallProcCheck %s cp %p cmd %p proc %p\n", methodName, cp, cmd, Tcl_Command_objProc(cmd));*/ - if (Tcl_Command_flags(cmd) & XOTCL_NONLEAF_METHOD) { - cp = clientData; - } else if (cp) { - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (proc == XOTclObjDispatch) { - assert((TclIsProc((Command *)cmd) == NULL)); - /*fprintf(stderr,"\t ObjDispatch\n");*/ - } else if (proc == XOTclForwardMethod || - proc == XOTclObjscopedMethod) { - tclCmdClientData *tcd = (tclCmdClientData *)cp; - tcd->obj = obj; - assert((TclIsProc((Command *)cmd) == NULL)); - /*fprintf(stderr,"\t forwarder\n");*/ - } else { - /*fprintf(stderr,"\t isproc\n");*/ - assert((TclIsProc((Command *)cmd) != NULL)); - isTclProc = 1; - } - } else { - push = forcePush; - assert((TclIsProc((Command *)cmd) == NULL)); - cp = clientData; - } + if (cp) { + register Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (!fromNext) { - objc--; - objv++; + if (proc == TclObjInterpProc) { + assert((TclIsProc((Command *)cmd))); + isTclProc = 1; + } else if (proc == XOTclObjDispatch) { + assert((TclIsProc((Command *)cmd) == NULL)); + /*fprintf(stderr,"\t ObjDispatch\n");*/ + } else if (proc == XOTclForwardMethod || + proc == XOTclObjscopedMethod) { + tclCmdClientData *tcd = (tclCmdClientData *)cp; + tcd->obj = obj; + assert((TclIsProc((Command *)cmd) == NULL)); + } else if (cp == (ClientData)XOTCL_NONLEAF_METHOD) { + cp = clientData; + assert((TclIsProc((Command *)cmd) == NULL)); } - /*fprintf(stderr,"DoCallProcCheck push=%d (%d), obj=%s fromNext %d\n", - push, forcePush, ObjStr(obj->cmdName), fromNext);*/ - - if (push) { - /* push the xotcl info */ - if ((CallStackPush(interp, obj, cl, cmd, objc, objv, frameType)) != TCL_OK) - return TCL_ERROR; + /* push the xotcl info */ + push = 1; + if ((CallStackPush(interp, obj, cl, cmd, objc, objv, frameType)) != TCL_OK) { + return TCL_ERROR; } + + } else { + push = 0; + assert((TclIsProc((Command *)cmd) == NULL)); + cp = clientData; + } - /*{int i; fprintf(stderr, "\tCALL ");for(i=0; icmdName), fromNext);*/ - rc = callProcCheck(cp, interp, objc, objv, cmd, obj, cl, - methodName, frameType, isTclProc); - if (push) { - CallStackPop(interp); - } - return rc; + /*{int i; fprintf(stderr, "\tCALL ");for(i=0; icmdName; - XOTclCallStack *cs = &rst->cs; + char *methodName; + XOTclClass *cl = NULL; + Tcl_Command cmd = NULL; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + Tcl_Obj *cmdName = obj->cmdName; + XOTclCallStack *cs = &rst->cs; + /* int isdestroy = (objv[1] == XOTclGlobalObjects[XOTE_DESTROY]); */ #ifdef AUTOVARS - int isNext; + int isNext; #endif - assert(objc>0); - methodName = ObjStr(objv[1]); + assert(objc>0); + methodName = ObjStr(objv[1]); - /*fprintf(stderr,"DoDispatch obj = %s objc = %d 0=%s\n", - ObjStr(obj->cmdName), objc, ObjStr(objv[0]));*/ - + /*fprintf(stderr,"DoDispatch obj = %s objc = %d 0=%s methodName=%s\n", + ObjStr(obj->cmdName), objc, ObjStr(objv[0]), methodName);*/ + #ifdef AUTOVARS - isNext = isNextString(methodName); + isNext = isNextString(methodName); #endif #ifdef DISPATCH_TRACE - printCall(interp,"DISPATCH", objc, objv); + printCall(interp,"DISPATCH", objc, objv); #endif #ifdef OBJDELETION_TRACE - method = objv[1]; - if (method == XOTclGlobalObjects[XOTE_CLEANUP] || - method == XOTclGlobalObjects[XOTE_DESTROY]) { - fprintf(stderr, "%s->%s id=%p destroyCalled=%d\n", - ObjStr(cmdName), methodName, obj, - (obj->flags & XOTCL_DESTROY_CALLED)); - } + method = objv[1]; + if (method == XOTclGlobalObjects[XOTE_CLEANUP] || + method == XOTclGlobalObjects[XOTE_DESTROY]) { + fprintf(stderr, "%s->%s id=%p destroyCalled=%d\n", + ObjStr(cmdName), methodName, obj, + (obj->flags & XOTCL_DESTROY_CALLED)); + } #endif - objflags = obj->flags; /* avoid stalling */ - INCR_REF_COUNT(cmdName); - - if (!(objflags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(interp, obj); - - if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - - callMethod = methodName; + objflags = obj->flags; /* avoid stalling */ + INCR_REF_COUNT(cmdName); + + if (!(objflags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + + if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + #ifdef AUTOVARS - if (!isNext) { + if (!isNext) { #endif - /* Only start new filter chain, if - (a) filters are defined and - (b) the toplevel csc entry is not an filter on self - */ - if (RUNTIME_STATE(interp)->doFilters && - !(flags & XOTCL_CM_NO_FILTERS) && !cs->guardCount && - ((obj->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == - XOTCL_FILTER_ORDER_DEFINED_AND_VALID)) { - XOTclObject *self = GetSelfObj(interp); - if (obj != self || - cs->top->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /* Only start new filter chain, if + (a) filters are defined and + (b) the toplevel csc entry is not an filter on self + */ + + if (((obj->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == XOTCL_FILTER_ORDER_DEFINED_AND_VALID) + && RUNTIME_STATE(interp)->doFilters + && !(flags & XOTCL_CM_NO_FILTERS) + && !cs->guardCount) { + XOTclObject *self = GetSelfObj(interp); + if (obj != self || + cs->top->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { - filterStackPushed = FilterStackPush(interp, obj, objv[1]); - cmd = FilterSearchProc(interp, obj, &proc, &cp, - &obj->filterStack->currentCmdPtr, &cl); - /*fprintf(stderr,"filterSearchProc returned cmd %p proc %p\n", cmd, proc);*/ - if (cmd) { /* 'proc' and the other output vars are set as well */ - frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - callMethod = (char *) Tcl_GetCommandName(interp, cmd); - } else { - FilterStackPop(obj); - filterStackPushed = 0; - } - } + filterStackPushed = FilterStackPush(interp, obj, objv[1]); + cmd = FilterSearchProc(interp, obj, &obj->filterStack->currentCmdPtr,&cl); + if (cmd) { + /*fprintf(stderr,"filterSearchProc returned cmd %p proc %p\n", cmd, proc);*/ + frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + methodName = (char *)Tcl_GetCommandName(interp, cmd); + } else { + FilterStackPop(obj); + filterStackPushed = 0; } - - /* check if a mixin is to be called. - don't use mixins on next method calls, since normally it is not - intercepted (it is used as a primitive command). - don't use mixins on init calls, since init is invoked on mixins - during mixin registration (in XOTclOMixinMethod) - */ - - if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == - XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - - mixinStackPushed = MixinStackPush(obj); - - if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { - cmd = MixinSearchProc(interp, obj, methodName, &cl, &proc, &cp, - &obj->mixinStack->currentCmdPtr); - if (cmd) { /* 'proc' and the other output vars are set as well */ - frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - } else { /* the else branch could be deleted */ - MixinStackPop(obj); - mixinStackPushed = 0; - } - } + } + } + + /* check if a mixin is to be called. + don't use mixins on next method calls, since normally it is not + intercepted (it is used as a primitive command). + don't use mixins on init calls, since init is invoked on mixins + during mixin registration (in XOTclOMixinMethod) + */ + if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + + mixinStackPushed = MixinStackPush(obj); + + if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { + cmd = MixinSearchProc(interp, obj, methodName, &cl, + &obj->mixinStack->currentCmdPtr); + if (cmd) { + frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + } else { /* the else branch could be deleted */ + MixinStackPop(obj); + mixinStackPushed = 0; } -#ifdef AUTOVARS + } } + +#ifdef AUTOVARS + } #endif + + /* if no filter/mixin is found => do ordinary method lookup */ + if (cmd == NULL) { + + if (obj->nsPtr) { + cmd = FindMethod(methodName, obj->nsPtr); + /* fprintf(stderr,"lookup for proc in obj %p method %s nsPtr %p => %p\n", + obj, methodName, obj->nsPtr, cmd);*/ + } + + /*fprintf(stderr,"findMethod for proc '%s' in %p returned %p\n", methodName, obj->nsPtr, cmd);*/ + + if (cmd == NULL) { + if (obj->cl->order == NULL) obj->cl->order = TopoOrder(obj->cl, Super); + cl = SearchPLMethod(obj->cl->order, methodName, &cmd); + } + } + + if (cmd) { + result = TCL_OK; - /* if no filter/mixin is found => do ordinary method lookup */ - if (proc == 0) { + /*fprintf(stderr,"cmd %p %s flags %x\n", cmd, methodName, + ((Command *) cmd)->flags && 0x00010000);*/ + + /* check, whether we have a protected method, and whether the + protected method, called on a different object. In this case, + we call as well the unknown method */ - /*fprintf(stderr,"ordinary lookup for obj %p method %s nsPtr %p\n", - obj, methodName, obj->nsPtr);*/ - - /*if (obj->nsPtr && !(obj->flags & XOTCL_NS_DESTROYED))*/ - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); - /*fprintf(stderr,"findMethod for proc '%s' in %p returned %p\n", methodName, obj->nsPtr, cmd);*/ - - if (cmd == NULL) - cl = SearchCMethod(obj->cl, methodName, &cmd); - - if (cmd) { - proc = Tcl_Command_objProc(cmd); - cp = Tcl_Command_objClientData(cmd); - } else { - assert(cp == 0); - } + if ((Tcl_Command_flags(cmd) & XOTCL_PROTECTED_METHOD) && + (flags & XOTCL_CM_NO_UNKNOWN) == 0) { + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + XOTclObject *o = NULL; + XOTclObjConvertObject(interp, objv[0], &o); + /*XOTclCallStackDump(interp);*/ + /*fprintf(stderr,"+++ %s is protected, therefore maybe unknown %p %s self=%p o=%p\n", + methodName, objv[0], ObjStr(objv[0]), + csc->self, o);*/ + if (o != csc->self) { + /*fprintf(stderr,"+++ protected method %s is not invoked\n", methodName);*/ + unknown = 1; + } } - if (proc) { - result = TCL_OK; - - /*fprintf(stderr,"cmd %p %s flags %x\n", cmd, methodName, - ((Command *) cmd)->flags && 0x00010000);*/ - - if ((Tcl_Command_flags(cmd) & XOTCL_PROTECTED_METHOD) && - (flags & XOTCL_CM_NO_UNKNOWN) == 0) { - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - XOTclObject *o = NULL; - XOTclObjConvertObject(interp, objv[0], &o); - /*XOTclCallStackDump(interp);*/ - /*fprintf(stderr,"+++ %s is protected, therefore maybe unknown %p %s self=%p o=%p\n", - methodName, objv[0], ObjStr(objv[0]), - csc->self, o);*/ - if (o != csc->self) { - /*fprintf(stderr,"+++ protected method %s is not invoked\n", methodName);*/ - unknown = 1; - } - } - if (!unknown) { - /*fprintf(stderr,"DoDispatch calls DoCallProcCheck with obj = %s frameType %d\n", - ObjStr(obj->cmdName), frameType);*/ - if ((result = DoCallProcCheck(cp, clientData, interp, objc, objv, cmd, obj, cl, - callMethod, frameType, - 0 /* fromNext */, 0)) == TCL_ERROR) { - result = XOTclErrInProc(interp, cmdName, - cl ? cl->object.cmdName : NULL, - callMethod); - } - unknown = RUNTIME_STATE(interp)->unknown; - } - } else { - unknown = 1; + if (!unknown) { + /*fprintf(stderr,"DoDispatch calls DoCallProcCheck with obj = %s frameType %d\n", + ObjStr(obj->cmdName), frameType);*/ + if ((result = DoCallProcCheck(clientData, interp, objc-1, objv+1, cmd, obj, cl, + methodName, frameType)) == TCL_ERROR) { + result = XOTclErrInProc(interp, cmdName, + cl ? cl->object.cmdName : NULL, + methodName); + } + unknown = RUNTIME_STATE(interp)->unknown; } + } else { + unknown = 1; + } - if (result == TCL_OK) { - /* fprintf(stderr,"after doCallProcCheck %s unknown == %d\n", methodName, unknown);*/ - if (unknown) { + if (result == TCL_OK) { + /*fprintf(stderr,"after doCallProcCheck unknown == %d\n", unknown);*/ + if (unknown) { - if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) { - return XOTclVarErrMsg(interp, ObjStr(objv[0]), - ": unable to dispatch method '", - callMethod, "'", (char *) NULL); - } else if (objv[1] != XOTclGlobalObjects[XOTE_UNKNOWN]) { - /* - * back off and try unknown; - */ - XOTclObject *obj = (XOTclObject*)clientData; - ALLOC_ON_STACK(Tcl_Obj *, objc+1, tov); - /* - fprintf(stderr,"calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s\n", - ObjStr(obj->cmdName), ObjStr(objv[1]), flags, XOTCL_CM_NO_UNKNOWN, - XOTclObjectIsClass(obj), obj, ObjStr(obj->cmdName)); - */ - tov[0] = obj->cmdName; - tov[1] = XOTclGlobalObjects[XOTE_UNKNOWN]; - if (objc>1) - memcpy(tov+2, objv+1, sizeof(Tcl_Obj *)*(objc-1)); - /* - fprintf(stderr,"?? %s unknown %s\n", ObjStr(obj->cmdName), ObjStr(tov[2])); - */ - result = DoDispatch(clientData, interp, objc+1, tov, flags | XOTCL_CM_NO_UNKNOWN); - FREE_ON_STACK(tov); + if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) { + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + ": unable to dispatch method '", + methodName, "'", (char *) NULL); + } else if (objv[1] != XOTclGlobalObjects[XOTE_UNKNOWN]) { + /* + * back off and try unknown; + */ + XOTclObject *obj = (XOTclObject*)clientData; + ALLOC_ON_STACK(Tcl_Obj*, objc+1, tov); + /* + fprintf(stderr,"calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s\n", + ObjStr(obj->cmdName), ObjStr(objv[1]), flags, XOTCL_CM_NO_UNKNOWN, + XOTclObjectIsClass(obj), obj, ObjStr(obj->cmdName)); + */ + tov[0] = obj->cmdName; + tov[1] = XOTclGlobalObjects[XOTE_UNKNOWN]; + if (objc>1) + memcpy(tov+2, objv+1, sizeof(Tcl_Obj *)*(objc-1)); + /* + fprintf(stderr,"?? %s unknown %s\n", ObjStr(obj->cmdName), ObjStr(tov[2])); + */ + result = DoDispatch(clientData, interp, objc+1, tov, flags | XOTCL_CM_NO_UNKNOWN); + FREE_ON_STACK(tov); - } else { /* unknown failed */ - /*fprintf(stderr,"unknown fails\n");*/ - return XOTclVarErrMsg(interp, ObjStr(objv[0]), - ": unable to dispatch method '", - ObjStr(objv[2]), "'", (char *) NULL); - } + } else { /* unknown failed */ + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + ": unable to dispatch method '", + ObjStr(objv[2]), "'", (char *) NULL); + } - } } - /* be sure to reset unknown flag */ - if (unknown) - RUNTIME_STATE(interp)->unknown = 0; + } + /* be sure to reset unknown flag */ + if (unknown) + RUNTIME_STATE(interp)->unknown = 0; #ifdef DISPATCH_TRACE - printExit(interp,"DISPATCH", objc, objv, result); + printExit(interp,"DISPATCH", objc, objv, result); + fprintf(stderr,"obj=%p isDestroy %d\n",obj, rst->callIsDestroy); + if (!rst->callIsDestroy) { fprintf(stderr,"obj %p mixinStackPushed %d mixinStack %p\n", - obj, mixinStackPushed, obj->mixinStack); + obj, mixinStackPushed, obj->mixinStack); + } #endif - /*if (!rst->callIsDestroy ) - fprintf(stderr, "obj freed? %p destroy %p self %p %s %d [%d] reference=%d,%d\n", obj, - cs->top->destroyedCmd, cs->top->self, ObjStr(objv[1]), - rst->callIsDestroy, - cs->top->callType & XOTCL_CSC_CALL_IS_DESTROY, - !rst->callIsDestroy, - isdestroy);*/ + /*if (!rst->callIsDestroy) + fprintf(stderr, "obj freed? %p destroy %p self %p %s %d [%d] reference=%d,%d\n", obj, + cs->top->destroyedCmd, cs->top->self, ObjStr(objv[1]), + rst->callIsDestroy, + cs->top->callType & XOTCL_CSC_CALL_IS_DESTROY, + !rst->callIsDestroy, + isdestroy);*/ + if (!rst->callIsDestroy) { + /*!(obj->flags & XOTCL_DESTROY_CALLED)) {*/ + if (mixinStackPushed && obj->mixinStack) + MixinStackPop(obj); - if (!rst->callIsDestroy) { - /*!(obj->flags & XOTCL_DESTROY_CALLED)) {*/ - if (mixinStackPushed && obj->mixinStack) - MixinStackPop(obj); + if (filterStackPushed && obj->filterStack) + FilterStackPop(obj); + } - if (filterStackPushed && obj->filterStack) - FilterStackPop(obj); - } - - DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */ - return result; + DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */ + return result; } -static int -ObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - int flags) { - int result; +int +XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int result; #ifdef STACK_TRACE - XOTclStackDump(interp); + XOTclStackDump(interp); #endif #ifdef CALLSTACK_TRACE - XOTclCallStackDump(interp); + XOTclCallStackDump(interp); #endif - if (objc == 1) { - Tcl_Obj *tov[2]; - tov[0] = objv[0]; - tov[1] = XOTclGlobalObjects[XOTE_DEFAULTMETHOD]; - result = DoDispatch(clientData, interp, 2, tov, flags); - } else { - /* normal dispatch */ - result = DoDispatch(clientData, interp, objc, objv, flags); - } + if (objc == 1) { + Tcl_Obj *tov[2]; + tov[0] = objv[0]; + tov[1] = XOTclGlobalObjects[XOTE_DEFAULTMETHOD]; + result = DoDispatch(clientData, interp, 2, tov, 0); + } else { + /* normal dispatch */ + result = DoDispatch(clientData, interp, objc, objv, 0); + } - return result; + return result; } #ifdef XOTCL_BYTECODE int XOTclDirectSelfDispatch(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - int result; + int objc, Tcl_Obj *CONST objv[]) { + int result; #ifdef XOTCLOBJ_TRACE - XOTclObject *obj; + XOTclObject *obj; #endif - objTrace("BEFORE SELF DISPATCH", obj); - result = ObjDispatch((ClientData)GetSelfObj(interp), interp, objc, objv, 0); - objTrace("AFTER SELF DISPATCH", obj); - return result; + objTrace("BEFORE SELF DISPATCH", obj); + result = XOTclObjDispatch((ClientData)GetSelfObj(interp), interp, objc, objv); + objTrace("AFTER SELF DISPATCH", obj); + return result; } #endif -int -XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - return ObjDispatch(clientData, interp, objc, objv, 0); -} - /* * Non Positional Args */ static void NonposArgsDeleteHashEntry(Tcl_HashEntry *hPtr) { - XOTclNonposArgs *nonposArg = (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); - if (nonposArg) { - if (nonposArg->nonposArgs) { - DECR_REF_COUNT(nonposArg->nonposArgs); - } - if (nonposArg->ordinaryArgs) { - DECR_REF_COUNT(nonposArg->ordinaryArgs); - } - if (nonposArg->slotObj) { - DECR_REF_COUNT(nonposArg->slotObj); - } - MEM_COUNT_FREE("nonposArg", nonposArg); - ckfree((char *) nonposArg); - Tcl_DeleteHashEntry(hPtr); + XOTclNonposArgs *nonposArg = (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); + if (nonposArg) { + if (nonposArg->nonposArgs) { + DECR_REF_COUNT(nonposArg->nonposArgs); } + if (nonposArg->ordinaryArgs) { + DECR_REF_COUNT(nonposArg->ordinaryArgs); + } + if (nonposArg->slotObj) { + DECR_REF_COUNT(nonposArg->slotObj); + } + MEM_COUNT_FREE("nonposArg", nonposArg); + ckfree((char *) nonposArg); + Tcl_DeleteHashEntry(hPtr); + } } static Tcl_HashTable* NonposArgsCreateTable() { - Tcl_HashTable *nonposArgsTable = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - MEM_COUNT_ALLOC("Tcl_HashTable", nonposArgsTable); - Tcl_InitHashTable(nonposArgsTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", nonposArgsTable); - return nonposArgsTable; + Tcl_HashTable *nonposArgsTable = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + MEM_COUNT_ALLOC("Tcl_HashTable", nonposArgsTable); + Tcl_InitHashTable(nonposArgsTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", nonposArgsTable); + return nonposArgsTable; } static void NonposArgsFreeTable(Tcl_HashTable *nonposArgsTable) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = nonposArgsTable ? - Tcl_FirstHashEntry(nonposArgsTable, &hSrch) : 0; - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - NonposArgsDeleteHashEntry(hPtr); - } + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = nonposArgsTable ? + Tcl_FirstHashEntry(nonposArgsTable, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + NonposArgsDeleteHashEntry(hPtr); + } } static XOTclNonposArgs* -NonposArgsGet(Tcl_HashTable *nonposArgsTable, char *methodName) { - Tcl_HashEntry *hPtr; - if (nonposArgsTable && - ((hPtr = Tcl_FindHashEntry(nonposArgsTable, methodName)))) { - return (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); - } - return NULL; +NonposArgsGet(Tcl_HashTable *nonposArgsTable, char * methodName) { + Tcl_HashEntry *hPtr; + if (nonposArgsTable && + ((hPtr = XOTcl_FindHashEntry(nonposArgsTable, methodName)))) { + return (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); + } + return NULL; } static Tcl_Obj * NonposArgsFormat(Tcl_Interp *interp, Tcl_Obj *nonposArgsData) { - int r1, npalistc, npac, checkc, i, j, first; - Tcl_Obj **npalistv, **npav, **checkv, - *list = Tcl_NewListObj(0, NULL), *innerlist, - *nameStringObj; + int r1, npalistc, npac, checkc, i, j, first; + Tcl_Obj **npalistv, **npav, **checkv, + *list = Tcl_NewListObj(0, NULL), *innerlist, + *nameStringObj; - /*fprintf(stderr, "nonposargsformat '%s'\n", ObjStr(nonposArgsData));*/ + /*fprintf(stderr, "nonposargsformat '%s'\n", ObjStr(nonposArgsData));*/ - if (nonposArgsData) { - r1 = Tcl_ListObjGetElements(interp, nonposArgsData, &npalistc, &npalistv); - if (r1 == TCL_OK) { - for (i=0; i < npalistc; i++) { - r1 = Tcl_ListObjGetElements(interp, npalistv[i], &npac, &npav); - if (r1 == TCL_OK) { - nameStringObj = Tcl_NewStringObj("-", 1); - Tcl_AppendStringsToObj(nameStringObj, ObjStr(npav[0]), (char *) NULL); - if (npac > 1 && *(ObjStr(npav[1])) != '\0') { - first = 1; - r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv); - if (r1 == TCL_OK) { - for (j=0; j < checkc; j++) { - if (first) { - Tcl_AppendToObj(nameStringObj,":", 1); - first = 0; - } else { - Tcl_AppendToObj(nameStringObj,",", 1); - } - Tcl_AppendToObj(nameStringObj, ObjStr(checkv[j]), -1); - } - } - } - /* fprintf(stderr, "nonposargsformat namestring '%s'\n", - ObjStr(nameStringObj));*/ + r1 = Tcl_ListObjGetElements(interp, nonposArgsData, &npalistc, &npalistv); + if (r1 == TCL_OK) { + for (i=0; i < npalistc; i++) { + r1 = Tcl_ListObjGetElements(interp, npalistv[i], &npac, &npav); + if (r1 == TCL_OK) { + nameStringObj = Tcl_NewStringObj("-", 1); + Tcl_AppendStringsToObj(nameStringObj, ObjStr(npav[0]), + (char *) NULL); + if (npac > 1 && *(ObjStr(npav[1])) != '\0') { + first = 1; + r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv); + if (r1 == TCL_OK) { + for (j=0; j < checkc; j++) { + if (first) { + Tcl_AppendToObj(nameStringObj,":", 1); + first = 0; + } else { + Tcl_AppendToObj(nameStringObj,",", 1); + } + Tcl_AppendToObj(nameStringObj, ObjStr(checkv[j]), -1); + } + } + } + /* fprintf(stderr, "nonposargsformat namestring '%s'\n", + ObjStr(nameStringObj));*/ #if 1 - innerlist = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, innerlist, nameStringObj); - if (npac > 2) { - Tcl_ListObjAppendElement(interp, innerlist, npav[2]); - } + innerlist = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, innerlist, nameStringObj); + if (npac > 2) { + Tcl_ListObjAppendElement(interp, innerlist, npav[2]); + } #else - { - Tcl_DString ds, *dsPtr = &ds; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, ObjStr(nameStringObj), -1); - if (npac > 2) { - Tcl_DStringAppendElement(dsPtr, ObjStr(npav[2])); - } - innerlist = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), - Tcl_DStringLength(dsPtr)); - DSTRING_FREE(dsPtr); - } + { + Tcl_DString ds, *dsPtr = &ds; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, ObjStr(nameStringObj), -1); + if (npac > 2) { + Tcl_DStringAppendElement(dsPtr, ObjStr(npav[2])); + } + innerlist = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), + Tcl_DStringLength(dsPtr)); + DSTRING_FREE(dsPtr); + } #endif - Tcl_ListObjAppendElement(interp, list, innerlist); - } - } - } + Tcl_ListObjAppendElement(interp, list, innerlist); + } } - return list; + } + return list; } /* * Proc-Creation */ static Tcl_Obj *addPrefixToBody(Tcl_Obj *body, int nonposArgs) { - Tcl_Obj *resultBody; - resultBody = Tcl_NewStringObj("", 0); - INCR_REF_COUNT(resultBody); - Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", (char *) NULL); - if (nonposArgs) { - Tcl_AppendStringsToObj(resultBody, - "::xotcl::interpretNonpositionalArgs $args\n", - (char *) NULL); - } - Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); - return resultBody; + Tcl_Obj *resultBody; + resultBody = Tcl_NewStringObj("", 0); + INCR_REF_COUNT(resultBody); +#if defined(PRE85) + Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", (char *) NULL); +#endif + if (nonposArgs) { + Tcl_AppendStringsToObj(resultBody, + "::xotcl::interpretNonpositionalArgs $args\n", + (char *) NULL); + } + Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); + return resultBody; } static Tcl_Obj* nonposargType(char *start, int len) { - Tcl_Obj *result = Tcl_NewStringObj("type=", 5); - Tcl_AppendToObj(result, start, len); - fprintf(stderr, "TYPE = '%s'\n", ObjStr(result)); - return result; + Tcl_Obj *result = Tcl_NewStringObj("type=", 5); + Tcl_AppendToObj(result, start, len); + /*fprintf(stderr, "nonposargType TYPE = '%s'\n", ObjStr(result));*/ + return result; } static int parseNonposArgs(Tcl_Interp *interp, - char *procName, Tcl_Obj *npArgs, Tcl_Obj *ordinaryArgs, - Tcl_HashTable **nonposArgsTable, - int *haveNonposArgs) { - int rc, nonposArgsDefc, npac; - Tcl_Obj **nonposArgsDefv; + char *procName, Tcl_Obj *npArgs, Tcl_Obj *ordinaryArgs, + Tcl_HashTable **nonposArgsTable, + int *haveNonposArgs) { + int rc, nonposArgsDefc, npac; + Tcl_Obj **nonposArgsDefv; - rc = Tcl_ListObjGetElements(interp, npArgs, &nonposArgsDefc, &nonposArgsDefv); - if (rc != TCL_OK) { - return XOTclVarErrMsg(interp, "cannot break down non-positional args: ", - ObjStr(npArgs), (char *) NULL); - } - if (nonposArgsDefc > 0) { - int start, end, length, i, j, nw = 0; - char *arg; - Tcl_Obj *npaObj, **npav, *nonposArgsObj = Tcl_NewListObj(0, NULL); - Tcl_HashEntry *hPtr; + rc = Tcl_ListObjGetElements(interp, npArgs, &nonposArgsDefc, &nonposArgsDefv); + if (rc != TCL_OK) { + return XOTclVarErrMsg(interp, "cannot break down non-positional args: ", + ObjStr(npArgs), (char *) NULL); + } + if (nonposArgsDefc > 0) { + int start, end, length, i, j, nw = 0; + char *arg; + Tcl_Obj *npaObj, **npav, *nonposArgsObj = Tcl_NewListObj(0, NULL); + Tcl_HashEntry *hPtr; - INCR_REF_COUNT(nonposArgsObj); - for (i=0; i < nonposArgsDefc; i++) { - rc = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); - if (rc == TCL_ERROR || npac < 1 || npac > 2) { - DECR_REF_COUNT(nonposArgsObj); - return XOTclVarErrMsg(interp, "wrong # of elements in non-positional args ", - "(should be 1 or 2 list elements): ", - ObjStr(npArgs), (char *) NULL); - } - npaObj = Tcl_NewListObj(0, NULL); - arg = ObjStr(npav[0]); - if (arg[0] != '-') { - DECR_REF_COUNT(npaObj); - DECR_REF_COUNT(nonposArgsObj); - return XOTclVarErrMsg(interp, "non-positional args does not start with '-': ", - arg, " in: ", ObjStr(npArgs), (char *) NULL); - } + INCR_REF_COUNT(nonposArgsObj); + for (i=0; i < nonposArgsDefc; i++) { + rc = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); + if (rc == TCL_ERROR || npac < 1 || npac > 2) { + DECR_REF_COUNT(nonposArgsObj); + return XOTclVarErrMsg(interp, "wrong # of elements in non-positional args ", + "(should be 1 or 2 list elements): ", + ObjStr(npArgs), (char *) NULL); + } + npaObj = Tcl_NewListObj(0, NULL); + arg = ObjStr(npav[0]); + if (arg[0] != '-') { + DECR_REF_COUNT(npaObj); + DECR_REF_COUNT(nonposArgsObj); + return XOTclVarErrMsg(interp, "non-positional args does not start with '-': ", + arg, " in: ", ObjStr(npArgs), (char *) NULL); + } - length = strlen(arg); - for (j=0; j0 && isspace((int)arg[end-1]); end--); - - Tcl_ListObjAppendElement(interp, list, - nonposargType(arg+start, end-start)); - l++; - start = l; - while(start0 && isspace((int)arg[end-1]); end--); - Tcl_ListObjAppendElement(interp, list, - nonposargType(arg+start, end-start)); - /* append the whole thing to the list */ - Tcl_ListObjAppendElement(interp, npaObj, list); - /* fprintf(stderr," appending list npa='%s'\n", ObjStr(npaObj));*/ - } else { - Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj(arg+1, length)); - Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj("", 0)); - /* fprintf(stderr," no colon npa='%s'\n", ObjStr(npaObj));*/ - } - if (npac == 2) { - Tcl_ListObjAppendElement(interp, npaObj, npav[1]); - /* fprintf(stderr," npac==2 ='%s'\n", ObjStr(npaObj)); */ - } - Tcl_ListObjAppendElement(interp, nonposArgsObj, npaObj); - *haveNonposArgs = 1; + start = j+1; + while(start0 && isspace((int)arg[end-1]); end--); + Tcl_ListObjAppendElement(interp, list, + nonposargType(arg+start, end-start)); + l++; + start = l; + while (start0 && isspace((int)arg[end-1]); end--); + Tcl_ListObjAppendElement(interp, list, + nonposargType(arg+start, end-start)); + /* append the whole thing to the list */ + Tcl_ListObjAppendElement(interp, npaObj, list); + /* fprintf(stderr," appending list npa='%s'\n", ObjStr(npaObj));*/ + } else { + Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj(arg+1, length)); + Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj("", 0)); + /* fprintf(stderr," no colon npa='%s'\n", ObjStr(npaObj));*/ + } + if (npac == 2) { + Tcl_ListObjAppendElement(interp, npaObj, npav[1]); + /* fprintf(stderr," npac==2 ='%s'\n", ObjStr(npaObj)); */ + } + Tcl_ListObjAppendElement(interp, nonposArgsObj, npaObj); + *haveNonposArgs = 1; + } - if (*haveNonposArgs) { - XOTclNonposArgs *nonposArg; + if (*haveNonposArgs) { + XOTclNonposArgs *nonposArg; - if (*nonposArgsTable == 0) { - *nonposArgsTable = NonposArgsCreateTable(); - } - - hPtr = Tcl_CreateHashEntry(*nonposArgsTable, procName, &nw); - assert(nw); - - MEM_COUNT_ALLOC("nonposArg", nonposArg); - nonposArg = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); - nonposArg->slotObj = NULL; - nonposArg->nonposArgs = nonposArgsObj; - { /* FIX AND REMOVE ME */ - int i, r2, ordinaryArgsDefc; - Tcl_Obj **ordinaryArgsDefv; - - r2 = Tcl_ListObjGetElements(interp, ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); - if (r2 == TCL_OK) { - Tcl_Obj *objv[ordinaryArgsDefc]; - for (i=0; i< ordinaryArgsDefc; i++) { - objv[i] = Tcl_DuplicateObj(ordinaryArgsDefv[i]); - } - nonposArg->ordinaryArgs = Tcl_NewListObj(ordinaryArgsDefc, objv); - INCR_REF_COUNT(nonposArg->ordinaryArgs); - } else { - fprintf(stderr, "could not split ordinaryArgs\n"); - } - } - Tcl_SetHashValue(hPtr, (ClientData)nonposArg); - } else { - /* for strange reasons, we did not find nonpos-args, although we - have definitions */ - DECR_REF_COUNT(nonposArgsObj); - } + if (*nonposArgsTable == NULL) { + *nonposArgsTable = NonposArgsCreateTable(); + } + + hPtr = Tcl_CreateHashEntry(*nonposArgsTable, procName, &nw); + assert(nw); + + MEM_COUNT_ALLOC("nonposArg", nonposArg); + nonposArg = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); + nonposArg->slotObj = NULL; + nonposArg->nonposArgs = nonposArgsObj; + { /* FIX AND REMOVE ME */ + int i, r2, ordinaryArgsDefc; + Tcl_Obj **ordinaryArgsDefv; + + r2 = Tcl_ListObjGetElements(interp, ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + if (r2 == TCL_OK) { + Tcl_Obj *objv[ordinaryArgsDefc]; + for (i=0; i< ordinaryArgsDefc; i++) { + objv[i] = Tcl_DuplicateObj(ordinaryArgsDefv[i]); + } + nonposArg->ordinaryArgs = Tcl_NewListObj(ordinaryArgsDefc, objv); + INCR_REF_COUNT(nonposArg->ordinaryArgs); + } else { + fprintf(stderr, "could not split ordinaryArgs\n"); + } + } + Tcl_SetHashValue(hPtr, (ClientData)nonposArg); + } else { + /* for strange reasons, we did not find nonpos-args, although we + have definitions */ + DECR_REF_COUNT(nonposArgsObj); } - return TCL_OK; + } + return TCL_OK; } + static int MakeProc(Tcl_Namespace *ns, XOTclAssertionStore *aStore, - Tcl_HashTable **nonposArgsTable, - Tcl_Interp *interp, int objc, Tcl_Obj *objv[], XOTclObject *obj, int clsns) { - int result, incr, haveNonposArgs=0; - TclCallFrame frame, *framePtr = &frame; - Tcl_Obj *ov[4]; - Tcl_HashEntry *hPtr = NULL; - char *procName = ObjStr(objv[1]); + Tcl_HashTable **nonposArgsTable, + Tcl_Interp *interp, int objc, Tcl_Obj *objv[], XOTclObject *obj, int clsns) { + int result, incr, haveNonposArgs = 0; + TclCallFrame frame, *framePtr = &frame; + Tcl_Obj *ov[4]; + Tcl_HashEntry *hPtr = NULL; + char *procName = ObjStr(objv[1]); - if (*nonposArgsTable && (hPtr = Tcl_FindHashEntry(*nonposArgsTable, procName))) { - NonposArgsDeleteHashEntry(hPtr); - } + if (*nonposArgsTable && (hPtr = XOTcl_FindHashEntry(*nonposArgsTable, procName))) { + NonposArgsDeleteHashEntry(hPtr); + } - ov[0] = objv[0]; - ov[1] = objv[1]; + ov[0] = objv[0]; + ov[1] = objv[1]; - if (objc == 5 || objc == 7) { - if ((result = parseNonposArgs(interp, procName, objv[2], objv[3], - nonposArgsTable, &haveNonposArgs)) != TCL_OK) - return result; + if (objc == 5 || objc == 7) { + if ((result = parseNonposArgs(interp, procName, objv[2], objv[3], + nonposArgsTable, &haveNonposArgs)) != TCL_OK) + return result; - if (haveNonposArgs) { - ov[2] = XOTclGlobalObjects[XOTE_ARGS]; - ov[3] = addPrefixToBody(objv[4], 1); - } else { /* no explicit nonpos arguments */ - ov[2] = objv[3]; - ov[3] = addPrefixToBody(objv[4], 0); - } - } else { - int argsc, i; - Tcl_Obj **argsv; + if (haveNonposArgs) { + ov[2] = XOTclGlobalObjects[XOTE_ARGS]; + ov[3] = addPrefixToBody(objv[4], 1); + } else { /* no explicit nonpos arguments */ + ov[2] = objv[3]; + ov[3] = addPrefixToBody(objv[4], 0); + } + } else { + int argsc, i; + Tcl_Obj **argsv; - /**** begin joined nonpos + pos argument list ***/ + /**** begin joined nonpos + pos argument list ***/ - /* see, if we have nonposArgs in the ordinary argument list */ - result = Tcl_ListObjGetElements(interp, objv[2], &argsc, &argsv); - if (result != TCL_OK) { - return XOTclVarErrMsg(interp, "cannot break args into list: ", - ObjStr(objv[2]), (char *) NULL); - } - for (i=0; i 0) { - arg = ObjStr(npav[0]); - /*fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n", arg, rc);*/ - if (*arg == '-') { - haveNonposArgs = 1; - continue; - } - } - break; - } - if (haveNonposArgs) { - int nrOrdinaryArgs = argsc - i; - Tcl_Obj *ordinaryArgs = Tcl_NewListObj(nrOrdinaryArgs, &argsv[i]); - Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]); - INCR_REF_COUNT(ordinaryArgs); - INCR_REF_COUNT(nonposArgs); - /*fprintf(stderr, "nonpos <%s> ordinary <%s>\n", - ObjStr(nonposArgs), ObjStr(ordinaryArgs));*/ - result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs, - nonposArgsTable, &haveNonposArgs); - DECR_REF_COUNT(ordinaryArgs); - DECR_REF_COUNT(nonposArgs); - if (result != TCL_OK) - return result; - } + rc = Tcl_ListObjGetElements(interp, argsv[i], &npac, &npav); + if (rc == TCL_OK && npac > 0) { + arg = ObjStr(npav[0]); + /* fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n", arg, rc);*/ + if (*arg == '-') { + haveNonposArgs = 1; + continue; + } + } + break; + } + if (haveNonposArgs) { + int nrOrdinaryArgs = argsc - i; + Tcl_Obj *ordinaryArgs = Tcl_NewListObj(nrOrdinaryArgs, &argsv[i]); + Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]); + INCR_REF_COUNT(ordinaryArgs); + INCR_REF_COUNT(nonposArgs); + result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs, + nonposArgsTable, &haveNonposArgs); + DECR_REF_COUNT(ordinaryArgs); + DECR_REF_COUNT(nonposArgs); + if (result != TCL_OK) + return result; + } - /**** end joined nonpos + pos argument list ***/ + /**** end joined nonpos + pos argument list ***/ - if (haveNonposArgs) { - ov[2] = XOTclGlobalObjects[XOTE_ARGS]; - ov[3] = addPrefixToBody(objv[3], 1); - } else { /* no nonpos arguments */ - ov[2] = objv[2]; - ov[3] = addPrefixToBody(objv[3], 0); - } - + if (haveNonposArgs) { + ov[2] = XOTclGlobalObjects[XOTE_ARGS]; + ov[3] = addPrefixToBody(objv[3], 1); + } else { /* no nonpos arguments */ + ov[2] = objv[2]; + ov[3] = addPrefixToBody(objv[3], 0); } + } + #ifdef AUTOVARS - { char *p, *body; - body = ObjStr(ov[3]); - if ((p = strstr(body, "self")) && p != body && *(p-1) != '[') - Tcl_AppendStringsToObj(ov[3], "::set self [self]\n", (char *) NULL); - if (strstr(body, "proc")) - Tcl_AppendStringsToObj(ov[3], "::set proc [self proc]\n", (char *) NULL); - if (strstr(body, "class")) - Tcl_AppendStringsToObj(ov[3], "::set class [self class]\n", (char *) NULL); - } + { char *p, *body; + body = ObjStr(ov[3]); + if ((p = strstr(body, "self")) && p != body && *(p-1) != '[') + Tcl_AppendStringsToObj(ov[3], "::set self [self]\n", (char *) NULL); + if (strstr(body, "proc")) + Tcl_AppendStringsToObj(ov[3], "::set proc [self proc]\n", (char *) NULL); + if (strstr(body, "class")) + Tcl_AppendStringsToObj(ov[3], "::set class [self class]\n", (char *) NULL); + } #endif - Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, ns, 0); + Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, ns, 0); - result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; + result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; #if defined(NAMESPACEINSTPROCS) - { - Proc *procPtr = TclFindProc((Interp *)interp, procName); - /* - fprintf(stderr,"proc=%p cmd=%p\n", procPtr, procPtr->cmdPtr); - fprintf(stderr,"proc=%p cmd=%p ns='%s' objns=%s clsns=%s\n", procPtr, procPtr->cmdPtr, - procPtr->cmdPtr->nsPtr->fullName,((Command*)obj->id)->nsPtr->fullName, - ((Command*)obj->cl->object.id)->nsPtr->fullName); - */ - /*** patch the command ****/ - if (procPtr) { - if (clsns) { - /* set the namespace of the method as inside of the class */ - if (!obj->nsPtr) { - makeObjNamespace(interp, obj); - } - /*fprintf(stderr,"obj %s\n", ObjStr(obj->cmdName)); - fprintf(stderr,"ns %p obj->ns %p\n", ns, obj->nsPtr); - fprintf(stderr,"ns %s obj->ns %s\n", ns->fullName, obj->nsPtr->fullName);*/ - procPtr->cmdPtr->nsPtr = (Namespace*) obj->nsPtr; - } else { - /* set the namespace of the method to the same namespace the class has */ - procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; - } - } + { + Proc *procPtr = TclFindProc((Interp *)interp, procName); + /*fprintf(stderr,"proc=%p cmd=%p ns='%s' objns=%s\n", procPtr, procPtr->cmdPtr, + procPtr->cmdPtr->nsPtr->fullName, cmd->nsPtr->fullName);*/ + /*** patch the command ****/ + if (procPtr) { + if (clsns) { + /* set the namespace of the method as inside of the class */ + if (!obj->nsPtr) { + makeObjNamespace(interp, obj); + } + /*fprintf(stderr,"obj %s\n", ObjStr(obj->cmdName)); + fprintf(stderr,"ns %p obj->ns %p\n", ns, obj->nsPtr); + fprintf(stderr,"ns %s obj->ns %s\n", ns->fullName, obj->nsPtr->fullName);*/ + procPtr->cmdPtr->nsPtr = (Namespace*) obj->nsPtr; + } else { + /* set the namespace of the method to the same namespace the class has */ + procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; + } } + } #endif - Tcl_PopCallFrame(interp); + Tcl_PopCallFrame(interp); - if (objc == 6 || objc == 7) { - incr = (objc == 6) ? 0:1; - AssertionAddProc(interp, ObjStr(objv[1]), aStore, objv[4+incr], objv[5+incr]); - } + if (objc == 6 || objc == 7) { + incr = (objc == 6) ? 0:1; + AssertionAddProc(interp, ObjStr(objv[1]), aStore, objv[4+incr], objv[5+incr]); + } - DECR_REF_COUNT(ov[3]); + DECR_REF_COUNT(ov[3]); - return result; + return result; } /* * List-Functions for Info */ static int ListInfo(Tcl_Interp *interp, int isclass) { - Tcl_ResetResult(interp); - Tcl_AppendElement(interp, "vars"); Tcl_AppendElement(interp, "body"); - Tcl_AppendElement(interp, "default"); Tcl_AppendElement(interp, "args"); - Tcl_AppendElement(interp, "procs"); Tcl_AppendElement(interp, "commands"); - Tcl_AppendElement(interp, "class"); Tcl_AppendElement(interp, "children"); - Tcl_AppendElement(interp, "filter"); Tcl_AppendElement(interp, "filterguard"); - Tcl_AppendElement(interp, "forward"); - Tcl_AppendElement(interp, "info"); - Tcl_AppendElement(interp, "invar"); Tcl_AppendElement(interp, "mixin"); - Tcl_AppendElement(interp, "methods"); - Tcl_AppendElement(interp, "parent"); - Tcl_AppendElement(interp, "pre"); Tcl_AppendElement(interp, "post"); - Tcl_AppendElement(interp, "precedence"); - if (isclass) { - Tcl_AppendElement(interp, "superclass"); Tcl_AppendElement(interp, "subclass"); - Tcl_AppendElement(interp, "heritage"); Tcl_AppendElement(interp, "instances"); - Tcl_AppendElement(interp, "instcommands"); Tcl_AppendElement(interp, "instprocs"); - Tcl_AppendElement(interp, "instdefault"); Tcl_AppendElement(interp, "instbody"); - Tcl_AppendElement(interp, "instmixin"); - Tcl_AppendElement(interp, "instforward"); - Tcl_AppendElement(interp, "instmixinof"); Tcl_AppendElement(interp, "mixinof"); - Tcl_AppendElement(interp, "classchildren"); Tcl_AppendElement(interp, "classparent"); - Tcl_AppendElement(interp, "instfilter"); Tcl_AppendElement(interp, "instfilterguard"); - Tcl_AppendElement(interp, "instinvar"); - Tcl_AppendElement(interp, "instpre"); Tcl_AppendElement(interp, "instpost"); - Tcl_AppendElement(interp, "parameter"); - } - return TCL_OK; + Tcl_ResetResult(interp); + Tcl_AppendElement(interp, "vars"); Tcl_AppendElement(interp, "body"); + Tcl_AppendElement(interp, "default"); Tcl_AppendElement(interp, "args"); + Tcl_AppendElement(interp, "procs"); Tcl_AppendElement(interp, "commands"); + Tcl_AppendElement(interp, "class"); Tcl_AppendElement(interp, "children"); + Tcl_AppendElement(interp, "filter"); Tcl_AppendElement(interp, "filterguard"); + Tcl_AppendElement(interp, "forward"); + Tcl_AppendElement(interp, "info"); + Tcl_AppendElement(interp, "invar"); Tcl_AppendElement(interp, "mixin"); + Tcl_AppendElement(interp, "methods"); + Tcl_AppendElement(interp, "parent"); + Tcl_AppendElement(interp, "pre"); Tcl_AppendElement(interp, "post"); + Tcl_AppendElement(interp, "precedence"); + if (isclass) { + Tcl_AppendElement(interp, "superclass"); Tcl_AppendElement(interp, "subclass"); + Tcl_AppendElement(interp, "heritage"); Tcl_AppendElement(interp, "instances"); + Tcl_AppendElement(interp, "instcommands"); Tcl_AppendElement(interp, "instprocs"); + Tcl_AppendElement(interp, "instdefault"); Tcl_AppendElement(interp, "instbody"); + Tcl_AppendElement(interp, "instmixin"); + Tcl_AppendElement(interp, "instforward"); + Tcl_AppendElement(interp, "instmixinof"); Tcl_AppendElement(interp, "mixinof"); + Tcl_AppendElement(interp, "classchildren"); Tcl_AppendElement(interp, "classparent"); + Tcl_AppendElement(interp, "instfilter"); Tcl_AppendElement(interp, "instfilterguard"); + Tcl_AppendElement(interp, "instinvar"); + Tcl_AppendElement(interp, "instpre"); Tcl_AppendElement(interp, "instpost"); + Tcl_AppendElement(interp, "parameter"); + } + return TCL_OK; } XOTCLINLINE static int noMetaChars(char *pattern) { - register char c, *p = pattern; - assert(pattern); - for (c=*p; c; c = *++p) { - if (c == '*' || c == '?' || c == '[') { - return 0; - } + register char c, *p = pattern; + assert(pattern); + for (c=*p; c; c = *++p) { + if (c == '*' || c == '?' || c == '[') { + return 0; } - return 1; + } + return 1; } static int +getMatchObject(Tcl_Interp *interp, char **pattern, XOTclObject **matchObject, Tcl_DString *dsPtr) { + if (*pattern && noMetaChars(*pattern)) { + *matchObject = XOTclpGetObject(interp, *pattern); + if (*matchObject) { + *pattern = ObjStr((*matchObject)->cmdName); + return 1; + } else { + /* object does not exist */ + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + return -1; + } + } else { + *matchObject = NULL; + if (*pattern) { + /* + * we have a pattern and meta characters, we might have + * to prefix it to ovoid abvious errors: since all object + * names are prefixed with ::, we add this prefix automatically + * to the match pattern, if it does not exist + */ + if (**pattern && **pattern != ':' && **pattern+1 && **pattern+1 != ':') { + /*fprintf(stderr, "pattern is not prefixed '%s'\n",*pattern);*/ + Tcl_DStringAppend(dsPtr, "::", -1); + Tcl_DStringAppend(dsPtr, *pattern, -1); + *pattern = Tcl_DStringValue(dsPtr); + /*fprintf(stderr, "prefixed pattern = '%s'\n",*pattern);*/ + } + } + } + return 0; +} + +static int ListKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { - Tcl_HashEntry *hPtr; - char *key; + Tcl_HashEntry *hPtr; + char *key; - if (pattern && noMetaChars(pattern)) { - hPtr = table ? Tcl_FindHashEntry(table, pattern) : 0; - if (hPtr) { - key = Tcl_GetHashKey(table, hPtr); - Tcl_SetResult(interp, key, TCL_VOLATILE); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - } + if (pattern && noMetaChars(pattern)) { + hPtr = table ? XOTcl_FindHashEntry(table, pattern) : 0; + if (hPtr) { + key = Tcl_GetHashKey(table, hPtr); + Tcl_SetResult(interp, key, TCL_VOLATILE); } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(table, hPtr); - if (!pattern || Tcl_StringMatch(key, pattern)) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(key,-1)); - } - } - Tcl_SetObjResult(interp, list); + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); } - return TCL_OK; + } else { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + key = Tcl_GetHashKey(table, hPtr); + if (!pattern || Tcl_StringMatch(key, pattern)) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(key,-1)); + } + } + Tcl_SetObjResult(interp, list); + } + return TCL_OK; } #if !defined(PRE85) || FORWARD_COMPATIBLE static int ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, char *pattern) { - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; - if (pattern && noMetaChars(pattern)) { - Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); - INCR_REF_COUNT(patternObj); + if (pattern && noMetaChars(pattern)) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + INCR_REF_COUNT(patternObj); - hPtr = tablePtr ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : 0; - if (hPtr) { - Var *val = VarHashGetValue(hPtr); - Tcl_SetObjResult(interp, VarHashGetKey(val)); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - } - DECR_REF_COUNT(patternObj); + hPtr = tablePtr ? XOTcl_FindHashEntry(tablePtr, (char *)patternObj) : 0; + if (hPtr) { + Var *val = VarHashGetValue(hPtr); + Tcl_SetObjResult(interp, VarHashGetKey(val)); } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - hPtr = tablePtr ? Tcl_FirstHashEntry(tablePtr, &hSrch) : 0; - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - Var *val = VarHashGetValue(hPtr); - Tcl_Obj *key = VarHashGetKey(val); - if (!pattern || Tcl_StringMatch(ObjStr(key), pattern)) { - Tcl_ListObjAppendElement(interp, list, key); - } - } - Tcl_SetObjResult(interp, list); + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); } - return TCL_OK; + DECR_REF_COUNT(patternObj); + } else { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + hPtr = tablePtr ? Tcl_FirstHashEntry(tablePtr, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + Var *val = VarHashGetValue(hPtr); + Tcl_Obj *key = VarHashGetKey(val); + if (!pattern || Tcl_StringMatch(ObjStr(key), pattern)) { + Tcl_ListObjAppendElement(interp, list, key); + } + } + Tcl_SetObjResult(interp, list); + } + return TCL_OK; } #endif static int ListVars(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { - Tcl_Obj *varlist, *okList, *element; - int i, length; - TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; + Tcl_Obj *varlist, *okList, *element; + int i, length; + TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; #if defined(PRE85) # if FORWARD_COMPATIBLE - if (forwardCompatibleMode) { - ListVarKeys(interp, VarHashTable(varTable), pattern); - } else { - ListKeys(interp, varTable, pattern); - } -# else + if (forwardCompatibleMode) { + ListVarKeys(interp, VarHashTable(varTable), pattern); + } else { ListKeys(interp, varTable, pattern); + } +# else + ListKeys(interp, varTable, pattern); # endif #else - ListVarKeys(interp, VarHashTable(varTable), pattern); + ListVarKeys(interp, VarHashTable(varTable), pattern); #endif - varlist = Tcl_GetObjResult(interp); + varlist = Tcl_GetObjResult(interp); - Tcl_ListObjLength(interp, varlist, &length); - okList = Tcl_NewListObj(0, NULL); - for (i=0; icmdName); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - } + Tcl_ListObjLength(interp, varlist, &length); + okList = Tcl_NewListObj(0, NULL); + for (i=0; icmdName), pattern)) { - Tcl_ListObjAppendElement(interp, list, obj->cmdName); - } - } - Tcl_SetObjResult(interp, list); + /*fprintf(stderr,"must ignore '%s' %d\n", ObjStr(element), i);*/ + /*Tcl_ListObjReplace(interp, varlist, i, 1, 0, NULL);*/ } - return TCL_OK; + } + Tcl_SetObjResult(interp, okList); + return TCL_OK; } +/* static int */ +/* ListObjPtrHashTable(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { */ +/* Tcl_HashEntry *hPtr; */ +/* if (pattern && noMetaChars(pattern)) { */ +/* XOTclObject *childobj = XOTclpGetObject(interp, pattern); */ +/* hPtr = XOTcl_FindHashEntry(table, (char *)childobj); */ +/* if (hPtr) { */ +/* Tcl_SetObjResult(interp, childobj->cmdName); */ +/* } else { */ +/* Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); */ +/* } */ +/* } else { */ +/* Tcl_Obj *list = Tcl_NewListObj(0, NULL); */ +/* Tcl_HashSearch hSrch; */ +/* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; */ +/* for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { */ +/* XOTclObject *obj = (XOTclObject*)Tcl_GetHashKey(table, hPtr); */ +/* if (!pattern || Tcl_StringMatch(ObjStr(obj->cmdName), pattern)) { */ +/* Tcl_ListObjAppendElement(interp, list, obj->cmdName); */ +/* } */ +/* } */ +/* Tcl_SetObjResult(interp, list); */ +/* } */ +/* return TCL_OK; */ +/* } */ + static int ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, - int noProcs, int noCmds, Tcl_HashTable *dups, int onlyForwarder) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(table, hPtr); - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - - if (pattern && !Tcl_StringMatch(key, pattern)) continue; - if (noCmds && proc != RUNTIME_STATE(interp)->objInterpProc) continue; - if (noProcs && proc == RUNTIME_STATE(interp)->objInterpProc) continue; - if (onlyForwarder && proc != XOTclForwardMethod) continue; - /* XOTclObjscopedMethod ??? */ + int noProcs, int noCmds, Tcl_HashTable *dups, int onlyForwarder, int onlySetter) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(table, hPtr); + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (dups) { - int new; - Tcl_HashEntry *duphPtr; - duphPtr = Tcl_CreateHashEntry(dups, key, &new); - if (!new) { - /*fprintf(stderr,"preexisting entry %s\n", key);*/ - continue; - } else { - /*fprintf(stderr,"new entry %s\n", key);*/ - } - } + if (pattern && !Tcl_StringMatch(key, pattern)) continue; + if (noCmds && proc != RUNTIME_STATE(interp)->objInterpProc) continue; + if (noProcs && proc == RUNTIME_STATE(interp)->objInterpProc) continue; + if (onlyForwarder && proc != XOTclForwardMethod) continue; + if (onlySetter && proc != XOTclSetterMethod) continue; + /* XOTclObjscopedMethod ??? */ + + if (dups) { + int new; + Tcl_HashEntry *duphPtr; + duphPtr = Tcl_CreateHashEntry(dups, key, &new); + if (!new) { + /*fprintf(stderr,"preexisting entry %s\n", key);*/ + continue; + } else { + /*fprintf(stderr,"new entry %s\n", key);*/ + } + } - if (((Command *) cmd)->flags & XOTCL_PROTECTED_METHOD) { - /*fprintf(stderr, "--- dont list protected name '%s'\n", key);*/ - continue; - } - Tcl_AppendElement(interp, key); + if (((Command *) cmd)->flags & XOTCL_PROTECTED_METHOD) { + /*fprintf(stderr, "--- dont list protected name '%s'\n", key);*/ + continue; } - /*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/ - return TCL_OK; + Tcl_AppendElement(interp, key); + } + /*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/ + return TCL_OK; } - + static int forwardList(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, - int definition) { - int rc; - if (definition) { - Tcl_HashEntry *hPtr = table ? Tcl_FindHashEntry(table, pattern) : 0; - if (hPtr) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - ClientData clientData = cmd? Tcl_Command_objClientData(cmd) : NULL; - forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; - if (tcd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - if (tcd->prefix) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-methodprefix",-1)); - Tcl_ListObjAppendElement(interp, list, tcd->prefix); - } - if (tcd->subcommands) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-default",-1)); - Tcl_ListObjAppendElement(interp, list, tcd->subcommands); - } - if (tcd->objscope) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-objscope",-1)); - } - Tcl_ListObjAppendElement(interp, list, tcd->cmdName); - if (tcd->args) { - Tcl_Obj **args; - int nrArgs, i; - Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); - for (i=0; iprefix) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-methodprefix",-1)); + Tcl_ListObjAppendElement(interp, list, tcd->prefix); } - rc = TCL_OK; + if (tcd->subcommands) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-default",-1)); + Tcl_ListObjAppendElement(interp, list, tcd->subcommands); + } + if (tcd->objscope) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-objscope",-1)); + } + Tcl_ListObjAppendElement(interp, list, tcd->cmdName); + if (tcd->args) { + Tcl_Obj **args; + int nrArgs, i; + Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); + for (i=0; insPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0); - } - - if (!noMixins) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - XOTclClass *mixin; - while (ml) { - int guardOk = TCL_OK; - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (inContext) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - if (!cs->guardCount) { - guardOk = GuardCall(obj, 0, 0, interp, (Tcl_Obj*)ml->clientData, 1); - } - } - if (mixin && guardOk == TCL_OK) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0); - } - ml = ml->nextPtr; - } + if (obj->nsPtr) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + } + + if (!noMixins) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml; + XOTclClass *mixin; + for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { + int guardOk = TCL_OK; + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (inContext) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + if (!cs->guardCount) { + guardOk = GuardCall(obj, 0, 0, interp, ml->clientData, 1); + } } + if (mixin && guardOk == TCL_OK) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + } + } } - - /* append per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0); - } - Tcl_DeleteHashTable(dups); - return TCL_OK; + } + + /* append per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + } + Tcl_DeleteHashTable(dups); + return TCL_OK; } static int XOTclCInfoMethod(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST v[]); static int -ListClass(Tcl_Interp *interp, XOTclObject *obj, char *pattern, - int objc, Tcl_Obj *CONST objv[]) { - if (pattern == NULL) { - Tcl_SetObjResult(interp, obj->cl->object.cmdName); - return TCL_OK; - } else { - int result; - ALLOC_ON_STACK(Tcl_Obj *, objc, ov); - - memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); - ov[1] = Tcl_NewStringObj("superclass", 10); - INCR_REF_COUNT(ov[1]); - result = XOTclCInfoMethod((ClientData)obj->cl, interp, objc, ov); - DECR_REF_COUNT(ov[1]); - FREE_ON_STACK(ov); - return result; - } +ListClass(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) { + Tcl_SetObjResult(interp, obj->cl->object.cmdName); + return TCL_OK; } static int -ListSuperclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { - XOTclClasses *sl = cl->super; - XOTclClasses *sc = 0; +ListHeritage(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { + XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); + Tcl_ResetResult(interp); + if (pl) pl=pl->nextPtr; + for (; pl; pl = pl->nextPtr) { + AppendMatchingElement(interp, pl->cl->object.cmdName, pattern); + } + return TCL_OK; +} - if (pattern == NULL) { - /* - * reverse the list to obtain presentation order - */ - - Tcl_ResetResult(interp); - while (sc != sl) { - XOTclClasses *nl = sl; - while (nl->nextPtr != sc) nl = nl->nextPtr; - Tcl_AppendElement(interp, className(nl->cl)); - sc = nl; - } - } else if (!noMetaChars(pattern)) { - char *key; - Tcl_ResetResult(interp); - while (sc != sl) { - XOTclClasses *nl = sl; - while (nl->nextPtr != sc) nl = nl->nextPtr; - key = className(nl->cl); - if (Tcl_StringMatch(key, pattern)) { - Tcl_AppendElement(interp, key); - } - sc = nl; - } - } else { - XOTclClass *isc = XOTclpGetClass(interp, pattern); - if (isc == 0) { - /* return XOTclErrBadVal(interp, "info superclass", "a class", pattern); */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } else { - XOTclClasses *pl; - /* - * search precedence to see if we're related or not - */ - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - break; - } - } - if (pl == NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } - } +static XOTclClasses * +ComputePrecedenceList(Tcl_Interp *interp, XOTclObject *obj, char *pattern, + int withMixins) { + XOTclClasses *precedenceList = NULL, *pcl, **npl = &precedenceList; + + if (withMixins) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml = obj->mixinOrder; + + while (ml) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (pattern) { + char *name = className(mixin); + if (!Tcl_StringMatch(name, pattern)) continue; + } + npl = XOTclClassListAdd(npl, mixin, NULL); + ml = ml->nextPtr; + } } - return TCL_OK; + } + + pcl = ComputeOrder(obj->cl, obj->cl->order, Super); + for (; pcl != 0; pcl = pcl->nextPtr) { + if (pattern) { + char *name = className(pcl->cl); + if (!Tcl_StringMatch(name, pattern)) continue; + } + npl = XOTclClassListAdd(npl, pcl->cl, NULL); + } + return precedenceList; } static int -ListSubclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { - XOTclClasses *sl = cl->sub; - XOTclClasses *sc = 0; +ListSuperclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern, int withClosure) { + int rc; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; - if (pattern == NULL) { - /* - * order unimportant - */ - Tcl_ResetResult(interp); - for (sc = sl; sc != 0; sc = sc->nextPtr) - Tcl_AppendElement(interp, className(sc->cl)); - } else if (!noMetaChars(pattern)) { - Tcl_ResetResult(interp); - for (sc = sl; sc != 0; sc = sc->nextPtr) { - char *key = className(sc->cl); - if (Tcl_StringMatch(key, pattern)) { - Tcl_AppendElement(interp, key); - } - } - } else { - XOTclClass *isc = XOTclpGetClass(interp, pattern); - XOTclClasses *pl; - XOTclClasses *saved; - - if (isc == 0) - return XOTclErrBadVal(interp, "info subclass", "a class", pattern); - saved = cl->order; - cl->order = 0; - - /* - * search precedence to see if we're related or not - */ - for (pl = ComputeOrder(cl, cl->order, Sub); pl; pl = pl->nextPtr) { - if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - break; - } - } - if (pl == 0) - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - - XOTclClassListFree(cl->order); - cl->order = saved; - } + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { return TCL_OK; -} + } - - -static int -ListHeritage(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { + if (withClosure) { XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); - Tcl_ResetResult(interp); if (pl) pl=pl->nextPtr; - for (; pl != 0; pl = pl->nextPtr) { - char *name = className(pl->cl); - if (pattern && !Tcl_StringMatch(name, pattern)) continue; - Tcl_AppendElement(interp, name); - } - return TCL_OK; + rc = AppendMatchingElementsFromClasses(interp, pl, pattern, matchObject); + } else { + XOTclClasses *clSuper = XOTclReverseClasses(cl->super); + rc = AppendMatchingElementsFromClasses(interp, clSuper, pattern, matchObject); + XOTclClassListFree(clSuper); + } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); + return TCL_OK; } -static XOTclClasses * -ComputePrecedenceWithMixins(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { - XOTclClasses *precedenceList = NULL, *pcl, **npl = &precedenceList; - - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - - while (ml) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (pattern) { - char *name = className(mixin); - if (!Tcl_StringMatch(name, pattern)) continue; - } - npl = XOTclClassListAdd(npl, mixin, NULL); - ml = ml->nextPtr; - } - } - pcl = ComputeOrder(obj->cl, obj->cl->order, Super); - for (; pcl != 0; pcl = pcl->nextPtr) { - if (pattern) { - char *name = className(pcl->cl); - if (!Tcl_StringMatch(name, pattern)) continue; - } - npl = XOTclClassListAdd(npl, pcl->cl, NULL); - } - return precedenceList; -} - - static int -ListPrecedence(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { - XOTclClasses *pl, *precedenceList; - Tcl_ResetResult(interp); - precedenceList = ComputePrecedenceWithMixins(interp, obj, pattern); - for (pl = precedenceList; pl != 0; pl = pl->nextPtr) { - char *name = className(pl->cl); - Tcl_AppendElement(interp, name); - } - XOTclClassListFree(pl); - return TCL_OK; +ListPrecedence(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int intrinsicOnly) { + XOTclClasses *pl, *precedenceList; + Tcl_ResetResult(interp); + precedenceList = ComputePrecedenceList(interp, obj, pattern, !intrinsicOnly); + for (pl = precedenceList; pl != 0; pl = pl->nextPtr) { + char *name = className(pl->cl); + Tcl_AppendElement(interp, name); + } + XOTclClassListFree(pl); + return TCL_OK; } - static Proc* FindProc(Tcl_Interp *interp, Tcl_HashTable *table, char *name) { - Tcl_HashEntry *hPtr = table ? Tcl_FindHashEntry(table, name) : 0; - if (hPtr) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (proc == RUNTIME_STATE(interp)->objInterpProc) - return (Proc*) Tcl_Command_objClientData(cmd); + Tcl_HashEntry *hPtr = table ? XOTcl_FindHashEntry(table, name) : 0; + if (hPtr) { + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + if (proc == RUNTIME_STATE(interp)->objInterpProc) + return (Proc*) Tcl_Command_objClientData(cmd); #if USE_INTERP_PROC - else if ((Tcl_CmdProc*)proc == RUNTIME_STATE(interp)->interpProc) - return (Proc*) Tcl_Command_clientData(cmd); + else if ((Tcl_CmdProc*)proc == RUNTIME_STATE(interp)->interpProc) + return (Proc*) Tcl_Command_clientData(cmd); #endif - } - return 0; + } + return 0; } static int ListProcArgs(Tcl_Interp *interp, Tcl_HashTable *table, char *name) { - Proc *proc = FindProc(interp, table, name); - if (proc) { - CompiledLocal *args = proc->firstLocalPtr; - Tcl_ResetResult(interp); - for (;args != NULL; args = args->nextPtr) { - if (TclIsCompiledLocalArgument(args)) - Tcl_AppendElement(interp, args->name); + Proc *proc = FindProc(interp, table, name); + if (proc) { + CompiledLocal *args = proc->firstLocalPtr; + Tcl_ResetResult(interp); + for ( ; args; args = args->nextPtr) { + if (TclIsCompiledLocalArgument(args)) + Tcl_AppendElement(interp, args->name); - } - return TCL_OK; } - return XOTclErrBadVal(interp, "info args", "a tcl method name", name); + return TCL_OK; + } + return XOTclErrBadVal(interp, "info args", "a tcl method name", name); } -static int -ListArgsFromOrdinaryArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) { - int i, rc, ordinaryArgsDefc, defaultValueObjc; - Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg, - *argList = Tcl_NewListObj(0, NULL); - rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); +static void +AppendOrdinaryArgsFromNonposArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs, + int varsOnly, + Tcl_Obj *argList) { + int i, rc, ordinaryArgsDefc, defaultValueObjc; + Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg; + rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + for (i=0; i < ordinaryArgsDefc; i++) { + ordinaryArg = ordinaryArgsDefv[i]; + rc = Tcl_ListObjGetElements(interp, ordinaryArg, + &defaultValueObjc, &defaultValueObjv); if (rc == TCL_OK) { - for (i=0; i < ordinaryArgsDefc; i++) { - ordinaryArg = ordinaryArgsDefv[i]; - rc = Tcl_ListObjGetElements(interp, ordinaryArg, - &defaultValueObjc, &defaultValueObjv); - if (rc == TCL_OK && defaultValueObjc == 2) { - ordinaryArg = defaultValueObjv[0]; - } - Tcl_ListObjAppendElement(interp, argList, ordinaryArg); - } - Tcl_SetObjResult(interp, argList); + if (varsOnly && defaultValueObjc == 2) { + Tcl_ListObjAppendElement(interp, argList, defaultValueObjv[0]); + } else { + Tcl_ListObjAppendElement(interp, argList, ordinaryArg); + } } - return rc; + } } + static int +ListArgsFromOrdinaryArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) { + Tcl_Obj *argList = argList = Tcl_NewListObj(0, NULL); + AppendOrdinaryArgsFromNonposArgs(interp, nonposArgs, 1, argList); + Tcl_SetObjResult(interp, argList); + return TCL_OK; +} + +static int GetProcDefault(Tcl_Interp *interp, Tcl_HashTable *table, - char *name, char *arg, Tcl_Obj **resultObj) { - Proc *proc = FindProc(interp, table, name); - *resultObj = 0; - if (proc) { - CompiledLocal *ap; - for (ap = proc->firstLocalPtr; ap != 0; ap = ap->nextPtr) { - if (!TclIsCompiledLocalArgument(ap)) continue; - if (strcmp(arg, ap->name) != 0) continue; + char *name, char *arg, Tcl_Obj **resultObj) { + Proc *proc = FindProc(interp, table, name); + *resultObj = NULL; + if (proc) { + CompiledLocal *ap; + for (ap = proc->firstLocalPtr; ap; ap = ap->nextPtr) { + if (!TclIsCompiledLocalArgument(ap)) continue; + if (strcmp(arg, ap->name) != 0) continue; - if (ap->defValuePtr != NULL) { - *resultObj = ap->defValuePtr; - return TCL_OK; - } - return TCL_OK; - } + if (ap->defValuePtr) { + *resultObj = ap->defValuePtr; + return TCL_OK; + } + return TCL_OK; } - return TCL_ERROR; + } + return TCL_ERROR; } static int SetProcDefault(Tcl_Interp *interp, Tcl_Obj *var, Tcl_Obj *defVal) { - int result = TCL_OK; - callFrameContext ctx = {0}; - CallStackUseActiveFrames(interp,&ctx); + int result = TCL_OK; + callFrameContext ctx = {0}; + CallStackUseActiveFrames(interp,&ctx); - if (defVal != NULL) { - if (Tcl_ObjSetVar2(interp, var, NULL, defVal, 0) != NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - result = TCL_ERROR; - } + if (defVal) { + if (Tcl_ObjSetVar2(interp, var, NULL, defVal, 0)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { - if (Tcl_ObjSetVar2(interp, var, NULL, - XOTclGlobalObjects[XOTE_EMPTY], 0) != NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } else { - result = TCL_ERROR; - } + result = TCL_ERROR; } - CallStackRestoreSavedFrames(interp, &ctx); - - if (result == TCL_ERROR) { - XOTclVarErrMsg(interp, "couldn't store default value in variable '", - var, "'", (char *) NULL); + } else { + if (Tcl_ObjSetVar2(interp, var, NULL, + XOTclGlobalObjects[XOTE_EMPTY], 0)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + result = TCL_ERROR; } - return result; + } + CallStackRestoreSavedFrames(interp, &ctx); + + if (result == TCL_ERROR) { + XOTclVarErrMsg(interp, "couldn't store default value in variable '", + var, "'", (char *) NULL); + } + return result; } static int ListProcDefault(Tcl_Interp *interp, Tcl_HashTable *table, char *name, char *arg, Tcl_Obj *var) { - Tcl_Obj *defVal; - int result; - if (GetProcDefault(interp, table, name, arg, &defVal) == TCL_OK) { - result = SetProcDefault(interp, var, defVal); - } else { - XOTclVarErrMsg(interp, "method '", name, - "' doesn't exist or doesn't have an argument '", - arg, "'", (char *) NULL); - result = TCL_ERROR; - } - return result; + Tcl_Obj *defVal; + int result; + if (GetProcDefault(interp, table, name, arg, &defVal) == TCL_OK) { + result = SetProcDefault(interp, var, defVal); + } else { + XOTclVarErrMsg(interp, "method '", name, + "' doesn't exist or doesn't have an argument '", + arg, "'", (char *) NULL); + result = TCL_ERROR; + } + return result; } static int ListDefaultFromOrdinaryArgs(Tcl_Interp *interp, char *procName, - XOTclNonposArgs *nonposArgs, char *arg, Tcl_Obj *var) { - int i, rc, ordinaryArgsDefc, defaultValueObjc; - Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg; + XOTclNonposArgs *nonposArgs, char *arg, Tcl_Obj *var) { + int i, rc, ordinaryArgsDefc, defaultValueObjc; + Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg; - rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); - if (rc != TCL_OK) - return TCL_ERROR; + rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + if (rc != TCL_OK) + return TCL_ERROR; - for (i=0; i < ordinaryArgsDefc; i++) { - ordinaryArg = ordinaryArgsDefv[i]; - rc = Tcl_ListObjGetElements(interp, ordinaryArg, - &defaultValueObjc, &defaultValueObjv); - if (rc == TCL_OK && !strcmp(arg, ObjStr(defaultValueObjv[0]))) { - return SetProcDefault(interp, var, defaultValueObjc == 2 ? - defaultValueObjv[1] : NULL); - } + for (i=0; i < ordinaryArgsDefc; i++) { + ordinaryArg = ordinaryArgsDefv[i]; + rc = Tcl_ListObjGetElements(interp, ordinaryArg, + &defaultValueObjc, &defaultValueObjv); + /*fprintf(stderr, "arg='%s', *arg==0 %d, defaultValueObjc=%d\n", arg, *arg==0, defaultValueObjc);*/ + if (rc == TCL_OK) { + if (defaultValueObjc > 0 && !strcmp(arg, ObjStr(defaultValueObjv[0]))) { + return SetProcDefault(interp, var, defaultValueObjc == 2 ? defaultValueObjv[1] : NULL); + } else if (defaultValueObjc == 0 && *arg == 0) { + return SetProcDefault(interp, var, NULL); + } } - XOTclVarErrMsg(interp, "method '", procName, "' doesn't have an argument '", - arg, "'", (char *) NULL); - return TCL_ERROR; + } + XOTclVarErrMsg(interp, "method '", procName, "' doesn't have an argument '", + arg, "'", (char *) NULL); + return TCL_ERROR; } static char * StripBodyPrefix(char *body) { - if (strncmp(body, "::xotcl::initProcNS\n", 20) == 0) - body+=20; - if (strncmp(body, "::xotcl::interpretNonpositionalArgs $args\n", 42) == 0) - body+=42; - return body; +#if defined(PRE85) + if (strncmp(body, "::xotcl::initProcNS\n", 20) == 0) + body+=20; +#endif + if (strncmp(body, "::xotcl::interpretNonpositionalArgs $args\n", 42) == 0) + body+=42; + return body; } static int ListProcBody(Tcl_Interp *interp, Tcl_HashTable *table, char *name) { - Proc *proc = FindProc(interp, table, name); + Proc *proc = FindProc(interp, table, name); - if (proc) { - char *body = ObjStr(proc->bodyPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); - return TCL_OK; - } - return XOTclErrBadVal(interp, "info body", "a tcl method name", name); + if (proc) { + char *body = ObjStr(proc->bodyPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); + return TCL_OK; + } + return XOTclErrBadVal(interp, "info body", "a tcl method name", name); } static int ListChildren(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int classesOnly) { - XOTclObject *childobj; - Tcl_HashTable *cmdTable; - XOTcl_FrameDecls; + XOTclObject *childobj; + Tcl_HashTable *cmdTable; + XOTcl_FrameDecls; - if (!obj->nsPtr) return TCL_OK; + if (!obj->nsPtr) return TCL_OK; - cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); - if (pattern && noMetaChars(pattern)) { - XOTcl_PushFrame(interp, obj); - if ((childobj = XOTclpGetObject(interp, pattern)) && + cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); + if (pattern && noMetaChars(pattern)) { + XOTcl_PushFrame(interp, obj); + if ((childobj = XOTclpGetObject(interp, pattern)) && + (!classesOnly || XOTclObjectIsClass(childobj)) && + (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ + ) { + Tcl_SetObjResult(interp, childobj->cmdName); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } + XOTcl_PopFrame(interp, obj); + } else { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + char *key; + XOTcl_PushFrame(interp, obj); + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + key = Tcl_GetHashKey(cmdTable, hPtr); + if (!pattern || Tcl_StringMatch(key, pattern)) { + if ((childobj = XOTclpGetObject(interp, key)) && (!classesOnly || XOTclObjectIsClass(childobj)) && (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ ) { - Tcl_SetObjResult(interp, childobj->cmdName); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + Tcl_ListObjAppendElement(interp, list, childobj->cmdName); } - XOTcl_PopFrame(interp, obj); - } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - char *key; - XOTcl_PushFrame(interp, obj); - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(cmdTable, hPtr); - if (!pattern || Tcl_StringMatch(key, pattern)) { - if ((childobj = XOTclpGetObject(interp, key)) && - (!classesOnly || XOTclObjectIsClass(childobj)) && - (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ - ) { - Tcl_ListObjAppendElement(interp, list, childobj->cmdName); - } - } - } - XOTcl_PopFrame(interp, obj); - Tcl_SetObjResult(interp, list); + } } - return TCL_OK; + XOTcl_PopFrame(interp, obj); + Tcl_SetObjResult(interp, list); + } + return TCL_OK; } static XOTclObjects * computeSlotObjects(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { - XOTclObjects *slotObjects = NULL, **npl = &slotObjects; - XOTclClasses *pl; - XOTclObject *childobj, *o; - Tcl_HashTable slotTable; + XOTclObjects *slotObjects = NULL, **npl = &slotObjects; + XOTclClasses *pl; + XOTclObject *childobj, *o; + Tcl_HashTable slotTable; - assert(obj); + assert(obj); - Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", slotTable); + Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", slotTable); - pl = ComputePrecedenceWithMixins(interp, obj, NULL /* pattern*/ ); - for (; pl != 0; pl = pl->nextPtr) { - Tcl_DString ds, *dsPtr = &ds; + pl = ComputePrecedenceList(interp, obj, NULL /* pattern*/, 1); + for (; pl != 0; pl = pl->nextPtr) { + Tcl_DString ds, *dsPtr = &ds; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(pl->cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr, *slotEntry; - /*fprintf(stderr,"we have slots %s\n", Tcl_DStringValue(dsPtr));*/ - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(o->nsPtr); - Tcl_Command cmd; - int new; - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(cmdTable, hPtr); - slotEntry = Tcl_CreateHashEntry(&slotTable, key, &new); - if (!new) continue; - cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); - childobj = XOTclGetObjectFromCmdPtr(cmd); - /* (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) true children */ - /*fprintf(stderr,"we have true child obj %s\n", ObjStr(childobj->cmdName));*/ - npl = XOTclObjectListAdd(npl, childobj); - } - } - DSTRING_FREE(dsPtr); + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(pl->cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr, *slotEntry; + /*fprintf(stderr,"we have slots %s\n", Tcl_DStringValue(dsPtr));*/ + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(o->nsPtr); + Tcl_Command cmd; + int new; + hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(cmdTable, hPtr); + slotEntry = Tcl_CreateHashEntry(&slotTable, key, &new); + if (!new) continue; + cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); + childobj = XOTclGetObjectFromCmdPtr(cmd); + /* (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) true children */ + /*fprintf(stderr,"we have true child obj %s\n", ObjStr(childobj->cmdName));*/ + npl = XOTclObjectListAdd(npl, childobj); + } } + DSTRING_FREE(dsPtr); + } - Tcl_DeleteHashTable(&slotTable); - MEM_COUNT_FREE("Tcl_InitHashTable", slotTable); + Tcl_DeleteHashTable(&slotTable); + MEM_COUNT_FREE("Tcl_InitHashTable", slotTable); - XOTclClassListFree(pl); + XOTclClassListFree(pl); - return slotObjects; + return slotObjects; } static int ListSlotObjects(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { - XOTclObjects *pl; - Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclObjects *pl; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); - assert(obj); + assert(obj); - pl = computeSlotObjects(interp, obj, pattern /* not used */ ); - for (; pl != 0; pl = pl->nextPtr) { - Tcl_ListObjAppendElement(interp, list, pl->obj->cmdName); - } + pl = computeSlotObjects(interp, obj, pattern /* not used */ ); + for (; pl != 0; pl = pl->nextPtr) { + Tcl_ListObjAppendElement(interp, list, pl->obj->cmdName); + } - XOTclObjectListFree(pl); - Tcl_SetObjResult(interp, list); + XOTclObjectListFree(pl); + Tcl_SetObjResult(interp, list); - return TCL_OK; + return TCL_OK; } static int ListParent(Tcl_Interp *interp, XOTclObject *obj) { - if (obj->id) { - Tcl_SetResult(interp, NSCmdFullName(obj->id), TCL_VOLATILE); - } - return TCL_OK; + if (obj->id) { + Tcl_SetResult(interp, NSCmdFullName(obj->id), TCL_VOLATILE); + } + return TCL_OK; } static XOTclClass* FindCalledClass(Tcl_Interp *interp, XOTclObject *obj) { - char *methodName = 0; - XOTclClass *cl; - Tcl_Command cmd = NULL; - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + char *methodName; + Tcl_Command cmd; - if (csc->frameType == XOTCL_CSC_TYPE_PLAIN) - return GetSelfClass(interp); + if (csc->frameType == XOTCL_CSC_TYPE_PLAIN) + return GetSelfClass(interp); - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) - methodName = ObjStr(csc->filterStackEntry->calledProc); - else if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && obj->mixinStack) - methodName = (char *) GetSelfProc(interp); + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) + methodName = ObjStr(csc->filterStackEntry->calledProc); + else if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && obj->mixinStack) + methodName = (char *) GetSelfProc(interp); + else + methodName = ""; - if (!methodName) methodName = ""; - - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); - + if (obj->nsPtr) { + cmd = FindMethod(methodName, obj->nsPtr); if (cmd) { - cl = 0; - } else { - cl = SearchCMethod(obj->cl, methodName, &cmd); + return NULL; } - return cl; + } + + return SearchCMethod(obj->cl, methodName, &cmd); } /* * Next Primitive Handling */ XOTCLINLINE static void NextSearchMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclCallStackContent *csc, - XOTclClass **cl, char **method, Tcl_ObjCmdProc **proc, Tcl_Command *cmd, - ClientData *cp, int *isMixinEntry, int *isFilterEntry, - int *endOfFilterChain, Tcl_Command *currentCmd) { - XOTclClasses *pl = 0; - int endOfChain = 0; - *endOfFilterChain = 0; + XOTclClass **cl, char **method, Tcl_Command *cmd, + int *isMixinEntry, int *isFilterEntry, + int *endOfFilterChain, Tcl_Command *currentCmd) { + XOTclClasses *pl = 0; + int endOfChain = 0; - /* - * Next in filters - */ - /*assert(obj->flags & XOTCL_FILTER_ORDER_VALID); *** strange, worked before ****/ + *endOfFilterChain = 0; - FilterComputeDefined(interp, obj); + /* + * Next in filters + */ + /*assert(obj->flags & XOTCL_FILTER_ORDER_VALID); *** strange, worked before ****/ - if ((obj->flags & XOTCL_FILTER_ORDER_VALID) && - obj->filterStack && - obj->filterStack->currentCmdPtr) { - *cmd = FilterSearchProc(interp, obj, proc, cp, currentCmd, cl); - /*fprintf(stderr,"EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ - /* XOTclCallStackDump(interp); XOTclStackDump(interp);*/ + FilterComputeDefined(interp, obj); - if (*proc == 0) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - /* reset the information to the values of method, cl - to the values they had before calling the filters */ - *method = ObjStr(obj->filterStack->calledProc); - endOfChain = 1; - *endOfFilterChain = 1; - *cl = 0; - /*fprintf(stderr,"EndOfChain resetting cl\n");*/ - } - } else { - *method = (char *) Tcl_GetCommandName(interp, *cmd); - *isFilterEntry = 1; - return; - } - } + if ((obj->flags & XOTCL_FILTER_ORDER_VALID) && + obj->filterStack && + obj->filterStack->currentCmdPtr) { + *cmd = FilterSearchProc(interp, obj, currentCmd, cl); + /*fprintf(stderr,"EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ + /* XOTclCallStackDump(interp); XOTclStackDump(interp);*/ - /* - * Next in Mixins - */ - assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); - /* otherwise: MixinComputeDefined(interp, obj); */ - - /*fprintf(stderr,"nextsearch: mixinorder valid %d stack=%p\n", - obj->flags & XOTCL_MIXIN_ORDER_VALID, obj->mixinStack);*/ - - - if ((obj->flags & XOTCL_MIXIN_ORDER_VALID) && obj->mixinStack) { - *cmd = MixinSearchProc(interp, obj, *method, cl, proc, cp, currentCmd); - /*fprintf(stderr,"nextsearch: mixinsearch cmd %p, proc=%p\n",*cmd,*proc);*/ - if (*proc == 0) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) { - endOfChain = 1; - *cl = 0; - } - } else { - *isMixinEntry = 1; - return; - } + if (*cmd == 0) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /* reset the information to the values of method, cl + to the values they had before calling the filters */ + *method = ObjStr(obj->filterStack->calledProc); + endOfChain = 1; + *endOfFilterChain = 1; + *cl = 0; + /*fprintf(stderr,"EndOfChain resetting cl\n");*/ + } + } else { + *method = (char *) Tcl_GetCommandName(interp, *cmd); + *isFilterEntry = 1; + return; } + } - /* - * otherwise: normal method dispatch - * - * if we are already in the precedence ordering, then advance - * past our last point; otherwise (if cl==0) begin from the start - */ + /* + * Next in Mixins + */ + assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); + /* otherwise: MixinComputeDefined(interp, obj); */ - /* if a mixin or filter chain has ended -> we have to search - the obj-specific methods as well */ + /*fprintf(stderr,"nextsearch: mixinorder valid %d stack=%p\n", + obj->flags & XOTCL_MIXIN_ORDER_VALID, obj->mixinStack);*/ - if (obj->nsPtr && endOfChain) { - *cmd = FindMethod(*method, obj->nsPtr); + if ((obj->flags & XOTCL_MIXIN_ORDER_VALID) && obj->mixinStack) { + *cmd = MixinSearchProc(interp, obj, *method, cl, currentCmd); + /*fprintf(stderr,"nextsearch: mixinsearch cmd %p, currentCmd %p\n",*cmd, *currentCmd);*/ + if (*cmd == 0) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) { + endOfChain = 1; + *cl = 0; + } } else { - *cmd = 0; + *isMixinEntry = 1; + return; } + } + /* + * otherwise: normal method dispatch + * + * if we are already in the precedence ordering, then advance + * past our last point; otherwise (if cl==0) begin from the start + */ - if (!*cmd) { - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl && *cl; pl = pl->nextPtr) { - if (pl->cl == *cl) - *cl = 0; - } + /* if a mixin or filter chain has ended -> we have to search + the obj-specific methods as well */ - /* - * search for a further class method - */ - *cl = SearchPLMethod(pl, *method, cmd); - /*fprintf(stderr, "no cmd, cl = %p %s\n",*cl, ObjStr((*cl)->object.cmdName));*/ - } else { + if (obj->nsPtr && endOfChain) { + *cmd = FindMethod(*method, obj->nsPtr); + } else { + *cmd = 0; + } + + + if (!*cmd) { + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl && *cl; pl = pl->nextPtr) { + if (pl->cl == *cl) *cl = 0; } - if (*cmd) { - *proc = Tcl_Command_objProc(*cmd); - *cp = Tcl_Command_objClientData(*cmd); - } + /* + * search for a further class method + */ + *cl = SearchPLMethod(pl, *method, cmd); + /*fprintf(stderr, "no cmd, cl = %p %s\n",*cl, ObjStr((*cl)->object.cmdName));*/ + } else { + *cl = 0; + } - return; + return; } static int XOTclNextMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclClass *givenCl, - char *givenMethod, int objc, Tcl_Obj *CONST objv[], - int useCallstackObjs) { - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - Tcl_ObjCmdProc *proc = 0; - Tcl_Command cmd, currentCmd = NULL; - ClientData cp = 0; - int result = TCL_OK, - frameType = XOTCL_CSC_TYPE_PLAIN, - isMixinEntry = 0, isFilterEntry = 0, - endOfFilterChain = 0; - int nobjc; Tcl_Obj **nobjv; - XOTclClass **cl = &givenCl; - char **method = &givenMethod; + char *givenMethod, int objc, Tcl_Obj *CONST objv[], + int useCallstackObjs) { + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + Tcl_Command cmd, currentCmd = NULL; + int result = TCL_OK, + frameType = XOTCL_CSC_TYPE_PLAIN, + isMixinEntry = 0, isFilterEntry = 0, + endOfFilterChain = 0, decrObjv0 = 0; + int nobjc; Tcl_Obj **nobjv; + XOTclClass **cl = &givenCl; + char **methodName = &givenMethod; #if !defined(NDEBUG) - if (useCallstackObjs) { - Tcl_CallFrame *cf = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - int found = 0; - while (cf) { - /* fprintf(stderr, " ... compare fp = %p and cfp %p procFrame %p oc=%d\n", - cf, csc->currentFramePtr, - Tcl_Interp_framePtr(interp), Tcl_CallFrame_objc(Tcl_Interp_framePtr(interp)) - );*/ - if (cf == csc->currentFramePtr) { - found = 1; - break; - } - cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr; - } - /* - if (!found) { - if (Tcl_Interp_varFramePtr(interp)) { - fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n", - csc->currentFramePtr, found, - Tcl_CallFrame_level(Tcl_Interp_varFramePtr(interp))); - } else { - fprintf(stderr,"no varFramePtr\n"); - } - return TCL_OK; - } - */ + if (useCallstackObjs) { + Tcl_CallFrame *cf = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + int found = 0; + while (cf) { + /* fprintf(stderr, " ... compare fp = %p and cfp %p procFrame %p oc=%d\n", + cf, csc->currentFramePtr, + Tcl_Interp_framePtr(interp), Tcl_CallFrame_objc(Tcl_Interp_framePtr(interp)) + );*/ + if (cf == csc->currentFramePtr) { + found = 1; + break; + } + cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr; } + /* + if (!found) { + if (Tcl_Interp_varFramePtr(interp)) { + fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n", + csc->currentFramePtr, found, + Tcl_CallFrame_level(Tcl_Interp_varFramePtr(interp))); + } else { + fprintf(stderr,"no varFramePtr\n"); + } + return TCL_OK; + } + */ + } #endif - /*fprintf(stderr,"Next givenMethod = %s, csc = %p, useCallstackObj %d, objc %d\n", - givenMethod, csc, useCallstackObjs, objc);*/ + /*fprintf(stderr,"givenMethod = %s, csc = %p, useCallstackObj %d, objc %d\n", + givenMethod, csc, useCallstackObjs, objc);*/ - /* if no args are given => use args from stack */ - if (objc < 2 && useCallstackObjs && csc->currentFramePtr) { - nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); - } else { - nobjc = objc; - nobjv = (Tcl_Obj **)objv; + /* if no args are given => use args from stack */ + if (objc < 2 && useCallstackObjs && csc->currentFramePtr) { + nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); + } else { + nobjc = objc; + nobjv = (Tcl_Obj **)objv; + /* We do not want to have "next" as the procname, since this can + lead to unwanted results e.g. in a forwarder using %proc. So, we + replace the first word with the value from the callstack to be + compatible with the case where next is called without args. + */ + if (useCallstackObjs && csc->currentFramePtr) { + nobjv[0] = Tcl_CallFrame_objv(csc->currentFramePtr)[0]; + INCR_REF_COUNT(nobjv[0]); /* we seem to need this here */ + decrObjv0 = 1; } + } - /* - * Search the next method & compute its method data - */ - NextSearchMethod(obj, interp, csc, cl, method, &proc, &cmd, &cp, - &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); + /* + * Search the next method & compute its method data + */ + NextSearchMethod(obj, interp, csc, cl, methodName, &cmd, + &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - - /*fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", - *method, endOfFilterChain); + /* + fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", + *methodName, endOfFilterChain); - if (obj) - fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName)); - if ((*cl)) - fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName); - fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n", - isMixinEntry, isFilterEntry, proc); - */ + if (obj) + fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName)); + if ((*cl)) + fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName); + fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n", + isMixinEntry, isFilterEntry, proc); + */ - Tcl_ResetResult(interp); /* needed for bytecode support */ + Tcl_ResetResult(interp); /* needed for bytecode support */ - if (proc != 0) { - /* - * change mixin state - */ - if (obj->mixinStack) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) - csc->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN; + if (cmd) { + /* + * change mixin state + */ + if (obj->mixinStack) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) + csc->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN; - /* otherwise move the command pointer forward */ - if (isMixinEntry) { - frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - obj->mixinStack->currentCmdPtr = currentCmd; - } - } - /* - * change filter state - */ - if (obj->filterStack) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - /*fprintf(stderr,"next changes filter state\n");*/ - csc->frameType = XOTCL_CSC_TYPE_INACTIVE_FILTER; - } + /* otherwise move the command pointer forward */ + if (isMixinEntry) { + frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + obj->mixinStack->currentCmdPtr = currentCmd; + } + } + /* + * change filter state + */ + if (obj->filterStack) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /*fprintf(stderr,"next changes filter state\n");*/ + csc->frameType = XOTCL_CSC_TYPE_INACTIVE_FILTER; + } - /* otherwise move the command pointer forward */ - if (isFilterEntry) { - /*fprintf(stderr,"next moves filter forward\n");*/ - frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - obj->filterStack->currentCmdPtr = currentCmd; - } - } + /* otherwise move the command pointer forward */ + if (isFilterEntry) { + /*fprintf(stderr,"next moves filter forward\n");*/ + frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + obj->filterStack->currentCmdPtr = currentCmd; + } + } - /* - * now actually call the "next" method - */ + /* + * now actually call the "next" method + */ - /* cut the flag, that no stdargs should be used, if it is there */ - if (nobjc > 1) { - char *nobjv1 = ObjStr(nobjv[1]); - if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs")) - nobjc = 1; - } - csc->callType |= XOTCL_CSC_CALL_IS_NEXT; - RUNTIME_STATE(interp)->unknown = 0; - - /*{int i; fprintf(stderr, "N\tCALL ");for(i=0; i 1) { + char *nobjv1 = ObjStr(nobjv[1]); + if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs")) + nobjc = 1; + } + csc->callType |= XOTCL_CSC_CALL_IS_NEXT; + RUNTIME_STATE(interp)->unknown = 0; + result = DoCallProcCheck((ClientData)obj, interp, nobjc, nobjv, cmd, + obj, *cl, *methodName, frameType); - csc->callType &= ~XOTCL_CSC_CALL_IS_NEXT; + csc->callType &= ~XOTCL_CSC_CALL_IS_NEXT; - if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER) - csc->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - else if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN) - csc->frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - } else if (result == TCL_OK && endOfFilterChain) { - /*fprintf(stderr,"setting unknown to 1\n");*/ - RUNTIME_STATE(interp)->unknown = 1; - } + if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER) + csc->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + else if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN) + csc->frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + } else if (result == TCL_OK && endOfFilterChain) { + /*fprintf(stderr,"setting unknown to 1\n");*/ + RUNTIME_STATE(interp)->unknown = 1; + } + if (decrObjv0) { + INCR_REF_COUNT(nobjv[0]); + } - return result; + return result; } int XOTclNextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - if (!csc->self) - return XOTclVarErrMsg(interp, "next: can't find self", (char *) NULL); - - if (!csc->cmdPtr) - return XOTclErrMsg(interp, "next: no executing proc", TCL_STATIC); - - if (!csc->destroyedCmd && !Tcl_Command_cmdEpoch(csc->cmdPtr)) { - return XOTclNextMethod(csc->self, interp, csc->cl, - (char *)Tcl_GetCommandName(interp, csc->cmdPtr), - objc, objv, 1); - } else { - /* also TCL_ERROR would be defensible, but next is as well silent on the "last" next*/ - return TCL_OK; - } + if (!csc->self) + return XOTclVarErrMsg(interp, "next: can't find self", (char *) NULL); + + if (!csc->cmdPtr) + return XOTclErrMsg(interp, "next: no executing proc", TCL_STATIC); + + return XOTclNextMethod(csc->self, interp, csc->cl, + (char *)Tcl_GetCommandName(interp, csc->cmdPtr), + objc, objv, 1); } int XOTclQualifyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - char *string; - if (objc != 2) - return XOTclVarErrMsg(interp, "wrong # of args for __qualify", (char *) NULL); + char *string; + if (objc != 2) + return XOTclVarErrMsg(interp, "wrong # of args for __qualify", (char *) NULL); - string = ObjStr(objv[1]); - if (!isAbsolutePath(string)) { - Tcl_SetObjResult(interp, NameInNamespaceObj(interp, string, callingNameSpace(interp))); - } else { - Tcl_SetObjResult(interp, objv[1]); - } - return TCL_OK; + string = ObjStr(objv[1]); + if (!isAbsolutePath(string)) { + Tcl_SetObjResult(interp, NameInNamespaceObj(interp, string, callingNameSpace(interp))); + } else { + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; } /* method for calling e.g. $obj __next */ static int XOTclONextMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - char *methodName; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + char *methodName; - for (; csc >= cs->content; csc--) { - if (csc->self == obj) break; - } - if (csccontent) - return XOTclVarErrMsg(interp, "__next: can't find object", - ObjStr(obj->cmdName), (char *) NULL); - methodName = (char *)Tcl_GetCommandName(interp, csc->cmdPtr); - /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ - return XOTclNextMethod(obj, interp, csc->cl, methodName, objc-1, &objv[1], 0); + for (; csc >= cs->content; csc--) { + if (csc->self == obj) break; + } + if (csccontent) + return XOTclVarErrMsg(interp, "__next: can't find object", + ObjStr(obj->cmdName), (char *) NULL); + methodName = (char *)Tcl_GetCommandName(interp, csc->cmdPtr); + /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ + return XOTclNextMethod(obj, interp, csc->cl, methodName, objc-1, &objv[1], 0); } -#if 0 -/* method next for calling e.g. $obj next */ -static int -XOTclONextMethod2(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - int result, nobjc; - /*XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;*/ - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - Tcl_Obj **nobjv; - - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - - /* if no args are given => use args from stack */ - if (objc < 2) { - nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); - } else { - nobjc = objc; - nobjv = (Tcl_Obj **)objv; - } - { - ALLOC_ON_STACK(Tcl_Obj *, nobjc + 1, ov); - memcpy(ov+1, nobjv, sizeof(Tcl_Obj *)*nobjc); - ov[0] = obj->cmdName; - result = ObjDispatch(clientData, interp, nobjc+1, ov, 0); - FREE_ON_STACK(ov); - } - /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ - /*result = Tcl_EvalObjv(interp, objc, ov, 0);*/ - return result; -} -#endif - /* * "self" object command */ static int FindSelfNext(Tcl_Interp *interp, XOTclObject *obj) { - XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - Tcl_ObjCmdProc *proc = 0; - Tcl_Command cmd, currentCmd = 0; - ClientData cp = 0; - int isMixinEntry = 0, - isFilterEntry = 0, - endOfFilterChain = 0; - XOTclClass *cl = csc->cl; - XOTclObject *o = csc->self; - char *methodName; + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + Tcl_Command cmd, currentCmd = 0; + int isMixinEntry = 0, + isFilterEntry = 0, + endOfFilterChain = 0; + XOTclClass *cl = csc->cl; + XOTclObject *o = csc->self; + char *methodName; - Tcl_ResetResult(interp); + Tcl_ResetResult(interp); - methodName = (char *) GetSelfProc(interp); - if (!methodName) - return TCL_OK; + methodName = (char *)GetSelfProc(interp); + if (!methodName) + return TCL_OK; - NextSearchMethod(o, interp, csc, &cl, &methodName, &proc, &cmd, &cp, - &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); + NextSearchMethod(o, interp, csc, &cl, &methodName, &cmd, + &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - if (cmd) { - Tcl_SetObjResult(interp, getFullProcQualifier(interp, Tcl_GetCommandName(interp, cmd), - o, cl, cmd)); - } - return TCL_OK; + if (cmd) { + Tcl_SetObjResult(interp, getFullProcQualifier(interp, Tcl_GetCommandName(interp, cmd), + o, cl, cmd)); + } + return TCL_OK; } static Tcl_Obj * computeLevelObj(Tcl_Interp *interp, CallStackLevel level) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc; - Tcl_Obj *resultObj; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + Tcl_Obj *resultObj; - switch (level) { - case CALLING_LEVEL: csc = XOTclCallStackFindLastInvocation(interp, 1); break; - case ACTIVE_LEVEL: csc = XOTclCallStackFindActiveFrame(interp, 1); break; - default: csc = NULL; - } + switch (level) { + case CALLING_LEVEL: csc = XOTclCallStackFindLastInvocation(interp, 1); break; + case ACTIVE_LEVEL: csc = XOTclCallStackFindActiveFrame(interp, 1); break; + default: csc = NULL; + } - if (cs->top->currentFramePtr == ((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)) - && csc && csc < cs->top && csc->currentFramePtr) { - /* this was from an xotcl frame, return absolute frame number */ - char buffer[LONG_AS_STRING]; - int l; - buffer[0] = '#'; - /* fprintf(stderr,"*** csc=%p\n", csc);*/ - XOTcl_ltoa(buffer+1,(long)Tcl_CallFrame_level(csc->currentFramePtr),&l); - resultObj = Tcl_NewStringObj(buffer, l+1); - } else { - /* If not called from an xotcl frame, return 1 as default */ - resultObj = Tcl_NewIntObj(1); - } - /*XOTclStackDump(interp);XOTclCallStackDump(interp);*/ + if (cs->top->currentFramePtr == ((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)) + && csc && csc < cs->top && csc->currentFramePtr) { + /* this was from an xotcl frame, return absolute frame number */ + char buffer[LONG_AS_STRING]; + int l; + buffer[0] = '#'; + /* fprintf(stderr,"*** csc=%p\n", csc);*/ + XOTcl_ltoa(buffer+1,(long)Tcl_CallFrame_level(csc->currentFramePtr),&l); + resultObj = Tcl_NewStringObj(buffer, l+1); + } else { + /* If not called from an xotcl frame, return 1 as default */ + resultObj = Tcl_NewIntObj(1); + } + /*XOTclStackDump(interp);XOTclCallStackDump(interp);*/ - return resultObj; + return resultObj; } static int XOTclSelfSubCommand(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *option) { - int rc = TCL_OK; - int opt; - XOTclCallStackContent *csc = NULL; + int rc = TCL_OK; + int opt; + XOTclCallStackContent *csc = NULL; - static CONST char *opts[] = { - "proc", "class", - "activelevel", "args", + static CONST char *opts[] = { + "proc", "class", + "activelevel", "args", #if defined(ACTIVEMIXIN) - "activemixin", + "activemixin", #endif - "calledproc", "calledmethod", - "calledclass", "callingproc", - "callingclass", "callinglevel", - "callingobject", "filterreg", - "isnextcall", "next", - NULL - }; + "calledproc", "calledmethod", + "calledclass", "callingproc", + "callingclass", "callinglevel", + "callingobject", "filterreg", + "isnextcall", "next", + NULL + }; - enum selfOptionIdx { - procIdx, classIdx, - activelevelIdx, argsIdx, + enum selfOptionIdx { + procIdx, classIdx, + activelevelIdx, argsIdx, #if defined(ACTIVEMIXIN) - activemixinIdx, + activemixinIdx, #endif - calledprocIdx, calledmethodIdx, - calledclassIdx, callingprocIdx, - callingclassIdx, callinglevelIdx, - callingobjectIdx, filterregIdx, - isnextcallIdx, nextIdx - }; + calledprocIdx, calledmethodIdx, + calledclassIdx, callingprocIdx, + callingclassIdx, callinglevelIdx, + callingobjectIdx, filterregIdx, + isnextcallIdx, nextIdx + }; - assert(option); + assert(option); - if (Tcl_GetIndexFromObj(interp, option, opts, "self option", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(interp, option, opts, "self option", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } - if (!obj && opt != callinglevelIdx) { - return XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); - } + if (!obj && opt != callinglevelIdx) { + return XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); + } - switch (opt) { - case procIdx: { /* proc subcommand */ - csc = CallStackGetTopFrame(interp); - if (csc->currentFramePtr) { - CONST char *procName = Tcl_GetCommandName(interp, (Tcl_Command)csc->cmdPtr); - Tcl_SetResult(interp, (char *)procName, TCL_VOLATILE); - } else { - char *procName = (char *)GetSelfProc(interp); - if (procName) { - Tcl_SetResult(interp, procName, TCL_VOLATILE); - } else { - rc = XOTclVarErrMsg(interp, "Can't find proc", (char *) NULL); - } - } - break; - } - case classIdx: { /* class subcommand */ - XOTclClass *cl = GetSelfClass(interp); - Tcl_SetObjResult(interp, cl ? cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - break; - } - case activelevelIdx: { - Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); - break; + switch (opt) { + case procIdx: { /* proc subcommand */ + csc = CallStackGetTopFrame(interp); + if (csc->currentFramePtr) { + CONST char *procName = Tcl_GetCommandName(interp, (Tcl_Command)csc->cmdPtr); + Tcl_SetResult(interp, (char *)procName, TCL_VOLATILE); + } else { + char *procName = (char *)GetSelfProc(interp); + if (procName) { + Tcl_SetResult(interp, procName, TCL_VOLATILE); + } else { + return XOTclVarErrMsg(interp, "Can't find proc", (char *) NULL); + } } - case argsIdx: { - int nobjc; - Tcl_Obj **nobjv; - csc = CallStackGetTopFrame(interp); - nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); - Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1)); - break; - } + break; + } + + case classIdx: { /* class subcommand */ + XOTclClass *cl = GetSelfClass(interp); + Tcl_SetObjResult(interp, cl ? cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + break; + } + + case activelevelIdx: { + Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); + break; + } + + case argsIdx: { + int nobjc; + Tcl_Obj **nobjv; + csc = CallStackGetTopFrame(interp); + nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); + Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1)); + break; + } + #if defined(ACTIVEMIXIN) - case activemixinIdx: { - XOTclObject *o = NULL; - csc = CallStackGetTopFrame(interp); - /*CmdListPrint(interp,"self a....\n", obj->mixinOrder); - fprintf(stderr,"current cmdPtr = %p cl = %p, mo=%p %p\n", csc->cmdPtr, csc->cl, - obj->mixinOrder, RUNTIME_STATE(interp)->cmdPtr);*/ - if (RUNTIME_STATE(interp)->cmdPtr) { - o = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); - } - Tcl_SetObjResult(interp, o ? o->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - break; + case activemixinIdx: { + XOTclObject *o = NULL; + csc = CallStackGetTopFrame(interp); + /*CmdListPrint(interp,"self a....\n", obj->mixinOrder); + fprintf(stderr,"current cmdPtr = %p cl = %p, mo=%p %p\n", csc->cmdPtr, csc->cl, + obj->mixinOrder, RUNTIME_STATE(interp)->cmdPtr);*/ + if (RUNTIME_STATE(interp)->cmdPtr) { + o = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); } + Tcl_SetObjResult(interp, o ? o->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + break; + } #endif - case calledprocIdx: - case calledmethodIdx: { - if (!(csc = CallStackFindActiveFilter(interp))) - rc = XOTclVarErrMsg(interp, "self ", ObjStr(option)," called from outside of a filter", - (char *) NULL); - else - Tcl_SetObjResult(interp, csc->filterStackEntry->calledProc); - break; - + case calledprocIdx: + case calledmethodIdx: { + if (!(csc = CallStackFindActiveFilter(interp))) { + rc = XOTclVarErrMsg(interp, "self ", ObjStr(option), + " called from outside of a filter", + (char *) NULL); + } else { + Tcl_SetObjResult(interp, csc->filterStackEntry->calledProc); } - case calledclassIdx: - Tcl_SetResult(interp, className(FindCalledClass(interp, obj)), TCL_VOLATILE); - break; - - case callingprocIdx: - csc = XOTclCallStackFindLastInvocation(interp, 1); - Tcl_SetResult(interp, csc ? (char *)Tcl_GetCommandName(interp, csc->cmdPtr) : "", - TCL_VOLATILE); - break; + break; + } - case callingclassIdx: - csc = XOTclCallStackFindLastInvocation(interp, 1); - Tcl_SetObjResult(interp, csc && csc->cl ? csc->cl->object.cmdName : - XOTclGlobalObjects[XOTE_EMPTY]); - break; - - case callinglevelIdx: - if (!obj) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); - } - break; + case calledclassIdx: + Tcl_SetResult(interp, className(FindCalledClass(interp, obj)), TCL_VOLATILE); + break; - case callingobjectIdx: - csc = XOTclCallStackFindLastInvocation(interp, 1); - Tcl_SetObjResult(interp, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - break; - - case filterregIdx: - if (!(csc = CallStackFindActiveFilter(interp))) { - rc = XOTclVarErrMsg(interp, - "self filterreg called from outside of a filter", - (char *) NULL); - } else - Tcl_SetObjResult(interp, FilterFindReg(interp, obj, GetSelfProcCmdPtr(interp))); - break; - - case isnextcallIdx: { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - csc = cs->top; - csc--; - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (csc > cs->content && - (csc->callType & XOTCL_CSC_CALL_IS_NEXT))); - break; + case callingprocIdx: + csc = XOTclCallStackFindLastInvocation(interp, 1); + Tcl_SetResult(interp, csc ? (char *)Tcl_GetCommandName(interp, csc->cmdPtr) : "", + TCL_VOLATILE); + break; + + case callingclassIdx: + csc = XOTclCallStackFindLastInvocation(interp, 1); + Tcl_SetObjResult(interp, csc && csc->cl ? csc->cl->object.cmdName : + XOTclGlobalObjects[XOTE_EMPTY]); + break; + + case callinglevelIdx: + if (!obj) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); } - case nextIdx: - rc = FindSelfNext(interp, obj); - break; + break; + + case callingobjectIdx: + csc = XOTclCallStackFindLastInvocation(interp, 1); + Tcl_SetObjResult(interp, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + break; + + case filterregIdx: + if (!(csc = CallStackFindActiveFilter(interp))) { + rc = XOTclVarErrMsg(interp, + "self filterreg called from outside of a filter", + (char *) NULL); + } else { + Tcl_SetObjResult(interp, FilterFindReg(interp, obj, GetSelfProcCmdPtr(interp))); } - - return rc; + break; + + case isnextcallIdx: { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + csc = cs->top; + csc--; + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (csc > cs->content && + (csc->callType & XOTCL_CSC_CALL_IS_NEXT))); + break; + } + + case nextIdx: + rc = FindSelfNext(interp, obj); + break; + } + + return rc; } - + /* int - XOTclKObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclKObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { if (objc < 2) return XOTclVarErrMsg(interp, "wrong # of args for K", (char *) NULL); @@ -7211,27 +7612,28 @@ int XOTclGetSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - int rc; + XOTclObject *obj; + int rc; - if (objc > 2) - return XOTclVarErrMsg(interp, "wrong # of args for self", (char *) NULL); + if (objc > 2) + return XOTclVarErrMsg(interp, "wrong # of args for self", (char *) NULL); - obj = GetSelfObj(interp); + obj = GetSelfObj(interp); - /*fprintf(stderr,"getSelfObj returns %p\n", obj);XOTclCallStackDump(interp);*/ + /*fprintf(stderr,"getSelfObj returns %p\n", obj);XOTclCallStackDump(interp);*/ - if (objc == 1) { - if (obj) { - Tcl_SetObjResult(interp, obj->cmdName); - rc = TCL_OK; - } else { - rc = XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); - } + if (objc == 1) { + if (obj) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + rc = TCL_OK; } else { - rc = XOTclSelfSubCommand(interp, obj, objv[1]); + return XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); } - return rc; + Tcl_SetObjResult(interp, obj->cmdName); + } else { + return XOTclSelfSubCommand(interp, obj, objv[1]); + } + return rc; } @@ -7240,552 +7642,605 @@ */ static int -unsetInAllNamespaces(Tcl_Interp *in, Namespace *nsPtr, char *name) { - int rc = 0; - fprintf(stderr, "### unsetInAllNamespaces %s\n", name); - if (nsPtr != NULL) { - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - Tcl_Var *varPtr; - int rc = 0; +unsetInAllNamespaces(Tcl_Interp *interp, Namespace *nsPtr, CONST char *name) { + int rc = 0; + fprintf(stderr, "### unsetInAllNamespaces variable '%s', current namespace '%s'\n", + name, nsPtr ? nsPtr->fullName : "NULL"); + + if (nsPtr) { + Tcl_HashSearch search; + Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + Tcl_Var *varPtr; + int result; - varPtr = (Tcl_Var *) Tcl_FindNamespaceVar(in, name, (Tcl_Namespace *) nsPtr, 0); - /*fprintf(stderr, "found %s in %s -> %p\n", name, nsPtr->fullName, varPtr);*/ - if (varPtr) { - Tcl_DString dFullname, *dsPtr = &dFullname; - Tcl_DStringInit(dsPtr); - Tcl_DStringAppend(dsPtr, "unset ", -1); - Tcl_DStringAppend(dsPtr, nsPtr->fullName, -1); - Tcl_DStringAppend(dsPtr, "::", 2); - Tcl_DStringAppend(dsPtr, name, -1); - /*rc = Tcl_UnsetVar2(in, Tcl_DStringValue(dsPtr), NULL, TCL_LEAVE_ERR_MSG);*/ - rc = Tcl_Eval(in, Tcl_DStringValue(dsPtr)); - /* fprintf(stderr, "fqName = '%s' unset => %d %d\n", Tcl_DStringValue(dsPtr), rc, TCL_OK);*/ - if (rc == TCL_OK) { - rc = 1; - } else { - Tcl_Obj *resultObj = Tcl_GetObjResult(in); - fprintf(stderr, " err = '%s'\n", ObjStr(resultObj)); - } - Tcl_DStringFree(dsPtr); - } - - while (entryPtr != NULL) { - Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); - /*fprintf(stderr, "child = %s\n", childNsPtr->fullName);*/ - entryPtr = Tcl_NextHashEntry(&search); - rc |= unsetInAllNamespaces(in, childNsPtr, name); - } + varPtr = (Tcl_Var *) Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) nsPtr, 0); + /*fprintf(stderr, "found %s in %s -> %p\n", name, nsPtr->fullName, varPtr);*/ + if (varPtr) { + Tcl_DString dFullname, *dsPtr = &dFullname; + Tcl_DStringInit(dsPtr); + Tcl_DStringAppend(dsPtr, "unset ", -1); + Tcl_DStringAppend(dsPtr, nsPtr->fullName, -1); + Tcl_DStringAppend(dsPtr, "::", 2); + Tcl_DStringAppend(dsPtr, name, -1); + /*rc = Tcl_UnsetVar2(interp, Tcl_DStringValue(dsPtr), NULL, TCL_LEAVE_ERR_MSG);*/ + result = Tcl_Eval(interp, Tcl_DStringValue(dsPtr)); + /* fprintf(stderr, "fqName = '%s' unset => %d %d\n", Tcl_DStringValue(dsPtr), rc, TCL_OK);*/ + if (result == TCL_OK) { + rc = 1; + } else { + Tcl_Obj *resultObj = Tcl_GetObjResult(interp); + fprintf(stderr, " err = '%s'\n", ObjStr(resultObj)); + } + Tcl_DStringFree(dsPtr); } - return rc; + + while (rc == 0 && entryPtr) { + Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + /*fprintf(stderr, "child = %s\n", childNsPtr->fullName);*/ + entryPtr = Tcl_NextHashEntry(&search); + rc |= unsetInAllNamespaces(interp, childNsPtr, name); + } + } + return rc; } static int -freeUnsetTraceVariable(Tcl_Interp *in, XOTclObject *obj) { - int rc = TCL_OK; - if (obj->opt && obj->opt->volatileVarName) { - /* - Somebody destroys a volatile object manually while - the vartrace is still active. Destroying the object will - be a problem in case the variable is deleted later - and fires the trace. So, we unset the variable here - which will cause a destroy via var trace, which in - turn clears the volatileVarName flag. - */ - /*fprintf(stderr,"### freeUnsetTraceVariable %s\n", obj->opt->volatileVarName);*/ +freeUnsetTraceVariable(Tcl_Interp *interp, XOTclObject *obj) { + int rc = TCL_OK; + if (obj->opt && obj->opt->volatileVarName) { + /* + Somebody destroys a volatile object manually while + the vartrace is still active. Destroying the object will + be a problem in case the variable is deleted later + and fires the trace. So, we unset the variable here + which will cause a destroy via var trace, which in + turn clears the volatileVarName flag. + */ + /*fprintf(stderr,"### freeUnsetTraceVariable %s\n", obj->opt->volatileVarName);*/ - rc = Tcl_UnsetVar2(in, obj->opt->volatileVarName, NULL, 0); - if (rc != TCL_OK) { - int rc = Tcl_UnsetVar2(in, obj->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY); - if (rc != TCL_OK) { - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(in); - if (unsetInAllNamespaces(in, nsPtr, obj->opt->volatileVarName) == 0) { - fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n", - obj->opt->volatileVarName); - } - } - } - if (rc == TCL_OK) { - /*fprintf(stderr, "### success unset\n");*/ - } + rc = Tcl_UnsetVar2(interp, obj->opt->volatileVarName, NULL, 0); + if (rc != TCL_OK) { + int rc = Tcl_UnsetVar2(interp, obj->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY); + if (rc != TCL_OK) { + Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (unsetInAllNamespaces(interp, nsPtr, obj->opt->volatileVarName) == 0) { + fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n", + obj->opt->volatileVarName); + } + } } - return rc; + if (rc == TCL_OK) { + /*fprintf(stderr, "### success unset\n");*/ + } + } + return rc; } static char * -XOTclUnsetTrace(ClientData cd, Tcl_Interp *interp, CONST84 char *name, CONST84 char *name2, int flags) +XOTclUnsetTrace(ClientData clientData, Tcl_Interp *interp, CONST84 char *name, CONST84 char *name2, int flags) { - Tcl_Obj *obj = (Tcl_Obj *)cd; - XOTclObject *o; - char *result = NULL; + Tcl_Obj *obj = (Tcl_Obj *)clientData; + XOTclObject *o; + char *result = NULL; - /*fprintf(stderr,"XOTclUnsetTrace %s flags %x %x\n", name, flags, - flags & TCL_INTERP_DESTROYED); */ + /*fprintf(stderr,"XOTclUnsetTrace %s flags %x %x\n", name, flags, + flags & TCL_INTERP_DESTROYED); */ - if ((flags & TCL_INTERP_DESTROYED) == 0) { - if (XOTclObjConvertObject(interp, obj, &o) == TCL_OK) { - Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ - INCR_REF_COUNT(res); + if ((flags & TCL_INTERP_DESTROYED) == 0) { + if (XOTclObjConvertObject(interp, obj, &o) == TCL_OK) { + Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(res); - /* clear variable, destroy is called from trace */ - if (o->opt && o->opt->volatileVarName) { - o->opt->volatileVarName = NULL; - } + /* clear variable, destroy is called from trace */ + if (o->opt && o->opt->volatileVarName) { + o->opt->volatileVarName = NULL; + } - if (callMethod((ClientData)o, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0) != TCL_OK) { - result = "Destroy for volatile object failed"; - } else - result = "No XOTcl Object passed"; + if (callMethod((ClientData)o, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0) != TCL_OK) { + result = "Destroy for volatile object failed"; + } else + result = "No XOTcl Object passed"; - Tcl_SetObjResult(interp, res); /* restore the result */ - DECR_REF_COUNT(res); - } - DECR_REF_COUNT(obj); - } else { - /*fprintf(stderr, "omitting destroy on %s %p\n", name);*/ + Tcl_SetObjResult(interp, res); /* restore the result */ + DECR_REF_COUNT(res); } - return result; + DECR_REF_COUNT(obj); + } else { + /*fprintf(stderr, "omitting destroy on %s %p\n", name);*/ + } + return result; } /* * mark an obj on the existing callstack, as not destroyed */ static void UndestroyObj(Tcl_Interp *interp, XOTclObject *obj) { - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; - /* - * mark the object on the whole callstack as not destroyed - */ - for (csc = &cs->content[1]; csc <= cs->top; csc++) { - if (obj == csc->self && csc->destroyedCmd) { - /* - * The ref count was incremented, when csc->destroyedCmd - * was set. We revert this first before forgetting the - * destroyedCmd. - */ - if (Tcl_Command_refCount(csc->destroyedCmd) > 1) { - Tcl_Command_refCount(csc->destroyedCmd)--; - MEM_COUNT_FREE("command refCount", csc->destroyedCmd); - } - csc->destroyedCmd = 0; - } + /* + * mark the object on the whole callstack as not destroyed + */ + for (csc = &cs->content[1]; csc <= cs->top; csc++) { + if (obj == csc->self && csc->destroyedCmd) { + /* + * The ref count was incremented, when csc->destroyedCmd + * was set. We revert this first before forgetting the + * destroyedCmd. + */ + if (Tcl_Command_refCount(csc->destroyedCmd) > 1) { + Tcl_Command_refCount(csc->destroyedCmd)--; + MEM_COUNT_FREE("command refCount", csc->destroyedCmd); + } + csc->destroyedCmd = 0; } - /* - * mark obj->flags XOTCL_DESTROY_CALLED as NOT CALLED (0) - */ - obj->flags &= ~XOTCL_DESTROY_CALLED; + } + /* + * mark obj->flags XOTCL_DESTROY_CALLED as NOT CALLED (0) + */ + obj->flags &= ~XOTCL_DESTROY_CALLED; } /* * bring an object into a state, as after initialization */ static void CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *obj, int softrecreate) { - XOTclClass *thecls, *theobj; + XOTclClass *thecls, *theobj; - thecls = RUNTIME_STATE(interp)->theClass; - theobj = RUNTIME_STATE(interp)->theObject; - /* remove the instance, but not for ::Class/::Object */ - if (obj != &(thecls->object) && obj != &(theobj->object)) { + thecls = RUNTIME_STATE(interp)->theClass; + theobj = RUNTIME_STATE(interp)->theObject; + /* remove the instance, but not for ::Class/::Object */ + if (obj != &(thecls->object) && obj != &(theobj->object)) { - if (!softrecreate) { - (void)RemoveInstance(obj, obj->cl); - } + if (!softrecreate) { + (void)RemoveInstance(obj, obj->cl); } + } - if (obj->nsPtr) { - NSCleanupNamespace(interp, obj->nsPtr); - NSDeleteChildren(interp, obj->nsPtr); - } + if (obj->nsPtr) { + NSCleanupNamespace(interp, obj->nsPtr); + NSDeleteChildren(interp, obj->nsPtr); + } - if (obj->varTable) { - TclDeleteVars((Interp *)interp, obj->varTable); - ckfree((char *)obj->varTable); - /* FREE(obj->varTable, obj->varTable);*/ - obj->varTable = 0; - } + if (obj->varTable) { + TclDeleteVars(((Interp *)interp), obj->varTable); + ckfree((char *)obj->varTable); + /*FREE(obj->varTable, obj->varTable);*/ + obj->varTable = 0; + } - if (obj->opt) { - XOTclObjectOpt *opt = obj->opt; - AssertionRemoveStore(opt->assertions); - opt->assertions = NULL; + if (obj->opt) { + XOTclObjectOpt *opt = obj->opt; + AssertionRemoveStore(opt->assertions); + opt->assertions = NULL; #ifdef XOTCL_METADATA - XOTclMetaDataDestroy(obj); + XOTclMetaDataDestroy(obj); #endif - if (!softrecreate) { - /* - * Remove this object from all mixinof lists and clear the mixin list - */ - RemoveFromMixinofs(obj->id, opt->mixins); - - CmdListRemoveList(&opt->mixins, GuardDel); - CmdListRemoveList(&opt->filters, GuardDel); + if (!softrecreate) { + /* + * Remove this object from all per object mixin lists and clear the mixin list + */ + removeFromObjectMixinsOf(obj->id, opt->mixins); + + CmdListRemoveList(&opt->mixins, GuardDel); + CmdListRemoveList(&opt->filters, GuardDel); - FREE(XOTclObjectOpt, opt); - opt = obj->opt = 0; - } + FREE(XOTclObjectOpt, opt); + opt = obj->opt = 0; } + } - if (obj->nonposArgsTable) { - NonposArgsFreeTable(obj->nonposArgsTable); - Tcl_DeleteHashTable(obj->nonposArgsTable); - MEM_COUNT_FREE("Tcl_InitHashTable", obj->nonposArgsTable); - ckfree((char *) obj->nonposArgsTable); - MEM_COUNT_FREE("Tcl_HashTable", obj->nonposArgsTable); - } + if (obj->nonposArgsTable) { + NonposArgsFreeTable(obj->nonposArgsTable); + Tcl_DeleteHashTable(obj->nonposArgsTable); + MEM_COUNT_FREE("Tcl_InitHashTable", obj->nonposArgsTable); + ckfree((char *) obj->nonposArgsTable); + MEM_COUNT_FREE("Tcl_HashTable", obj->nonposArgsTable); + } - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - if (obj->mixinOrder) MixinResetOrder(obj); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - if (obj->filterOrder) FilterResetOrder(obj); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + if (obj->mixinOrder) MixinResetOrder(obj); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + if (obj->filterOrder) FilterResetOrder(obj); } /* * do obj initialization & namespace creation */ static void CleanupInitObject(Tcl_Interp *interp, XOTclObject *obj, - XOTclClass *cl, Tcl_Namespace *namespacePtr, int softrecreate) { + XOTclClass *cl, Tcl_Namespace *namespacePtr, int softrecreate) { #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ CleanupInitObject\n"); + fprintf(stderr,"+++ CleanupInitObject\n"); #endif - obj->teardown = interp; - obj->nsPtr = namespacePtr; - if (!softrecreate) { - AddInstance(obj, cl); - } - if (obj->flags & XOTCL_RECREATE) { - obj->opt = 0; - obj->varTable = 0; - obj->nonposArgsTable = 0; - obj->mixinOrder = 0; - obj->filterOrder = 0; - obj->flags = 0; - } - /* - fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", - obj->cmdName ? ObjStr(obj->cmdName) : "", obj, obj->cl);*/ + obj->teardown = interp; + obj->nsPtr = namespacePtr; + if (!softrecreate) { + AddInstance(obj, cl); + } + if (obj->flags & XOTCL_RECREATE) { + obj->opt = 0; + obj->varTable = 0; + obj->nonposArgsTable = 0; + obj->mixinOrder = 0; + obj->filterOrder = 0; + obj->flags = 0; + } + /* + fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", + obj->cmdName ? ObjStr(obj->cmdName) : "", obj, obj->cl);*/ } /* * physical object destroy */ static void PrimitiveODestroy(ClientData clientData) { - XOTclObject *obj = (XOTclObject*)clientData; - Tcl_Interp *interp; + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Interp *interp; - /*fprintf(stderr, "****** PrimitiveODestroy %p\n", obj);*/ - assert(obj && !(obj->flags & XOTCL_DESTROYED)); + /* fprintf(stderr, "****** PrimitiveODestroy %p\n", obj);*/ + assert(obj && !(obj->flags & XOTCL_DESTROYED)); - /* - * check and latch against recurrent calls with obj->teardown - */ - PRINTOBJ("PrimitiveODestroy", obj); + /* + * check and latch against recurrent calls with obj->teardown + */ + PRINTOBJ("PrimitiveODestroy", obj); - if (!obj || !obj->teardown) return; - interp = obj->teardown; - obj->teardown = 0; + if (!obj || !obj->teardown) return; + interp = obj->teardown; - /* - * Don't destroy, if the interpreter is destroyed already - * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed - */ - if (Tcl_InterpDeleted(interp)) return; - /* - * call and latch user destroy with obj->id if we haven't - */ - if (!(obj->flags & XOTCL_DESTROY_CALLED)) { - callDestroyMethod(clientData, interp, obj, 0); - obj->id = 0; - } + /* + * Don't destroy, if the interpreter is destroyed already + * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed + */ + if (Tcl_InterpDeleted(interp)) return; + /* + * call and latch user destroy with obj->id if we haven't + */ + if (!(obj->flags & XOTCL_DESTROY_CALLED)) { + callDestroyMethod(clientData, interp, obj, 0); + obj->id = NULL; + } #ifdef OBJDELETION_TRACE - fprintf(stderr," physical delete of %p id=%p destroyCalled=%d '%s'\n", - obj, obj->id, (obj->flags & XOTCL_DESTROY_CALLED), ObjStr(obj->cmdName)); + fprintf(stderr," physical delete of %p id=%p destroyCalled=%d '%s'\n", + obj, obj->id, (obj->flags & XOTCL_DESTROY_CALLED), ObjStr(obj->cmdName)); #endif - CleanupDestroyObject(interp, obj, 0); + CleanupDestroyObject(interp, obj, 0); - while (obj->mixinStack != NULL) - MixinStackPop(obj); - while (obj->filterStack != NULL) - FilterStackPop(obj); + while (obj->mixinStack) + MixinStackPop(obj); -#if 0 - { - /* Prevent that PrimitiveODestroy is called more than once. - This code was used in earlier versions of XOTcl - but does not seem necessary any more. If it has to be used - again in the future, don't use Tcl_GetCommandFromObj() - in Tcl 8.4.* versions. - */ - Tcl_Command cmd = Tcl_FindCommand(in, ObjStr(obj->cmdName), 0, 0); + while (obj->filterStack) + FilterStackPop(obj); - if (cmd != NULL) - Tcl_Command_deleteProc(cmd) = 0; - } + obj->teardown = NULL; + +#if 0 + { + /* Prevent that PrimitiveODestroy is called more than once. + This code was used in earlier versions of XOTcl + but does not seem necessary any more. If it has to be used + again in the future, don't use Tcl_GetCommandFromObj() + in Tcl 8.4.* versions. + */ + Tcl_Command cmd = Tcl_FindCommand(interp, ObjStr(obj->cmdName), 0, 0); + if (cmd) + Tcl_Command_deleteProc(cmd) = NULL; + } #endif - if (obj->nsPtr) { - /*fprintf(stderr,"primitive odestroy calls deletenamespace for obj %p\n", obj);*/ - XOTcl_DeleteNamespace(interp, obj->nsPtr); - obj->nsPtr = 0; - } + if (obj->nsPtr) { + /*fprintf(stderr,"primitive odestroy calls deletenamespace for obj %p\n", obj);*/ + XOTcl_DeleteNamespace(interp, obj->nsPtr); + obj->nsPtr = NULL; + } - /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", ObjStr(obj->cmdName));*/ + /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", ObjStr(obj->cmdName));*/ - obj->flags |= XOTCL_DESTROYED; - objTrace("ODestroy", obj); + obj->flags |= XOTCL_DESTROYED; + objTrace("ODestroy", obj); #if REFCOUNT_TRACE - fprintf(stderr,"ODestroy %p flags %d rc %d destr %d dc %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0 - ); + fprintf(stderr,"ODestroy %p flags %d rc %d destr %d dc %d\n", + obj, obj->flags, + (obj->flags & XOTCL_REFCOUNTED) != 0, + (obj->flags & XOTCL_DESTROYED) != 0, + (obj->flags & XOTCL_DESTROY_CALLED) != 0 + ); #endif #if REFCOUNTED - if (!(obj->flags & XOTCL_REFCOUNTED)) { - DECR_REF_COUNT(obj->cmdName); - } -#else + if (!(obj->flags & XOTCL_REFCOUNTED)) { DECR_REF_COUNT(obj->cmdName); + } +#else + DECR_REF_COUNT(obj->cmdName); #endif - XOTclCleanupObject(obj); + XOTclCleanupObject(obj); #if !defined(NDEBUG) - if (obj != (XOTclObject*)RUNTIME_STATE(interp)->theClass) - checkAllInstances(interp, RUNTIME_STATE(interp)->theClass, 0); + if (obj != (XOTclObject*)RUNTIME_STATE(interp)->theClass) + checkAllInstances(interp, RUNTIME_STATE(interp)->theClass, 0); #endif } static void PrimitiveOInit(void *mem, Tcl_Interp *interp, char *name, XOTclClass *cl) { - XOTclObject *obj = (XOTclObject*)mem; + XOTclObject *obj = (XOTclObject*)mem; + Tcl_Namespace *nsPtr = NULL; #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ PrimitiveOInit\n"); + fprintf(stderr,"+++ PrimitiveOInit\n"); #endif #ifdef XOTCLOBJ_TRACE - fprintf(stderr, "OINIT %s = %p\n", name, obj); + fprintf(stderr, "OINIT %s = %p\n", name, obj); #endif - XOTclObjectRefCountIncr(obj); + XOTclObjectRefCountIncr(obj); - /* if the command of the obj was used before, we have to clean - * up the callstack from set "destroyedCmd" flags - */ - UndestroyObj(interp, obj); + /* if the command of the obj was used before, we have to clean + * up the callstack from set "destroyedCmd" flags + */ + UndestroyObj(interp, obj); - if (Tcl_FindNamespace(interp, name, NULL, 0)) { - CleanupInitObject(interp, obj, cl, - NSGetFreshNamespace(interp, (ClientData)obj, name), 0); - } else { - CleanupInitObject(interp, obj, cl, NULL, 0); - } - /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/ - obj->mixinStack = 0; - obj->filterStack = 0; + if (Tcl_FindNamespace(interp, name, NULL, 0)) { + nsPtr = NSGetFreshNamespace(interp, (ClientData)obj, name); + } + CleanupInitObject(interp, obj, cl, nsPtr, 0); + + /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/ + obj->mixinStack = NULL; + obj->filterStack = NULL; } /* * Object creation: create object name (full name) and Tcl command */ static XOTclObject* PrimitiveOCreate(Tcl_Interp *interp, char *name, XOTclClass *cl) { - XOTclObject *obj = (XOTclObject*)ckalloc(sizeof(XOTclObject)); - unsigned length; + XOTclObject *obj = (XOTclObject*)ckalloc(sizeof(XOTclObject)); + unsigned length; - /*fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);*/ + /*fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);*/ #if defined(XOTCLOBJ_TRACE) - fprintf(stderr, "CKALLOC Object %p %s\n", obj, name); + fprintf(stderr, "CKALLOC Object %p %s\n", obj, name); #endif #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ PrimitiveOCreate\n"); + fprintf(stderr,"+++ PrimitiveOCreate\n"); #endif - memset(obj, 0, sizeof(XOTclObject)); - MEM_COUNT_ALLOC("XOTclObject/XOTclClass", obj); - assert(obj); /* ckalloc panics, if malloc fails */ - assert(isAbsolutePath(name)); + memset(obj, 0, sizeof(XOTclObject)); + MEM_COUNT_ALLOC("XOTclObject/XOTclClass", obj); + assert(obj); /* ckalloc panics, if malloc fails */ + assert(isAbsolutePath(name)); - length = strlen(name); - if (!NSCheckForParent(interp, name, length)) { - ckfree((char *) obj); - return 0; - } - obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch, - (ClientData)obj, PrimitiveODestroy); + length = strlen(name); + if (!NSCheckForParent(interp, name, length)) { + ckfree((char *) obj); + return 0; + } + obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch, + (ClientData)obj, PrimitiveODestroy); - PrimitiveOInit(obj, interp, name, cl); + PrimitiveOInit(obj, interp, name, cl); #if 0 - /*defined(KEEP_TCL_CMD_TYPE)*/ - /*TclNewObj(obj->cmdName);*/ - obj->cmdName = Tcl_NewStringObj(name, length); - TclSetCmdNameObj(interp, obj->cmdName, (Command*)obj->id); - /*fprintf(stderr, "new command has name '%s'\n", ObjStr(obj->cmdName));*/ + /*defined(KEEP_TCL_CMD_TYPE)*/ + /*TclNewObj(obj->cmdName);*/ + obj->cmdName = Tcl_NewStringObj(name, length); + TclSetCmdNameObj(interp, obj->cmdName, (Command*)obj->id); + /*fprintf(stderr, "new command has name '%s'\n", ObjStr(obj->cmdName));*/ #else - obj->cmdName = NewXOTclObjectObjName(obj, name, length); + obj->cmdName = NewXOTclObjectObjName(obj, name, length); #endif - INCR_REF_COUNT(obj->cmdName); + INCR_REF_COUNT(obj->cmdName); - objTrace("PrimitiveOCreate", obj); + objTrace("PrimitiveOCreate", obj); - return obj; + return obj; } -static XOTclClass *DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *topcl) { - XOTclObject *obj = (XOTclObject*)cl; - XOTclClass *defaultClass = topcl; - if (obj->cl) { - int result; - /*fprintf(stderr, "mcl= %s\n", ObjStr(obj->cl->object.cmdName));*/ - result = setInstVar(interp, (XOTclObject *)obj->cl, - XOTclGlobalObjects[XOTE_DEFAULTSUPERCLASS], NULL); - if (result == TCL_OK) { - Tcl_Obj *nameObj = Tcl_GetObjResult(interp); - if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { - XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); - } - } else { - Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::xotcl::bootstrap", NULL, - TCL_GLOBAL_ONLY); - if (bootstrap) { - Tcl_Obj *nameObj = Tcl_NewStringObj("::xotcl::Object", -1); - INCR_REF_COUNT(nameObj); - if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { - XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); - } - DECR_REF_COUNT(nameObj); - } else { - /*fprintf(stderr, "no default_superclass for cl %s found, returning %s\n", - ObjStr(cl->object.cmdName), - ObjStr(defaultClass->object.cmdName));*/ - } - } +static XOTclClass * +DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, XOTclClass *topcl) { + XOTclClass *defaultClass = topcl; + + /*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s\n", + ObjStr(cl->object.cmdName), + mcl ? ObjStr(mcl->object.cmdName) : "NULL" + );*/ + if (mcl) { + int result; + result = setInstVar(interp, (XOTclObject *)mcl, + XOTclGlobalObjects[XOTE_DEFAULTSUPERCLASS], NULL); + + if (result == TCL_OK) { + Tcl_Obj *nameObj = Tcl_GetObjResult(interp); + if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { + XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); + } + /* fprintf(stderr, "DefaultSuperClass got from var %s\n",ObjStr(nameObj));*/ + } else { - /* during bootstrapping, there might be no meta class defined yet */ - /*fprintf(stderr, "no meta class\n");*/ + Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::xotcl::bootstrap", NULL, + TCL_GLOBAL_ONLY); + if (bootstrap) { + Tcl_Obj *nameObj = Tcl_NewStringObj("::xotcl::Object", -1); + INCR_REF_COUNT(nameObj); + if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { + XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); + } + DECR_REF_COUNT(nameObj); + } else { + XOTclClass *result; + XOTclClasses *sc; + /* check superclasses of metaclass */ + /*fprintf(stderr,"DefaultSuperClass: search in superclasses starting with %p\n",cl->super);*/ + for (sc = mcl->super; sc && sc->cl != cl; sc = sc->nextPtr) { + /*fprintf(stderr, " ... check %s\n",ObjStr(sc->cl->object.cmdName));*/ + result = DefaultSuperClass(interp, cl, sc->cl, topcl); + if (result != topcl) { + return result; + } + } + } } - return defaultClass; + } else { + /* during bootstrapping, there might be no meta class defined yet */ + /*fprintf(stderr, "no meta class\n");*/ + } + return defaultClass; } /* * Cleanup class: remove filters, mixins, assertions, instances ... * and remove class from class hierarchy */ static void -CleanupDestroyClass(Tcl_Interp *interp, XOTclClass *cl, int softrecreate) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - XOTclClass *theobj = RUNTIME_STATE(interp)->theObject; - XOTclClassOpt *clopt = cl->opt; - XOTclClass *defaultClass = NULL; +CleanupDestroyClass(Tcl_Interp *interp, XOTclClass *cl, int softrecreate, int recreate) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + XOTclClass *theobj = RUNTIME_STATE(interp)->theObject; + XOTclClassOpt *clopt = cl->opt; + XOTclClass *defaultClass = NULL; - if (clopt) { - /* - * Remove this class from all instmixinofs and clear the instmixin list - */ - - RemoveFromInstmixinsofs(cl->object.id, clopt->instmixins); + assert(softrecreate? recreate == 1 : 1); + + /* fprintf(stderr, "CleanupDestroyClass softrecreate=%d,recreate=%d, %p\n", + softrecreate,recreate,clopt); */ - CmdListRemoveList(&clopt->instmixins, GuardDel); - MixinInvalidateObjOrders(interp, cl); + /* do this even with no clopt, since the class might be used as a + superclass of a per object mixin, so it has no clopt... + */ + MixinInvalidateObjOrders(interp, cl); + FilterInvalidateObjOrders(interp, cl); + + if (clopt) { + /* + * Remove this class from all isClassMixinOf lists and clear the instmixin list + */ + RemoveFromClassMixinsOf(clopt->id, clopt->instmixins); + + CmdListRemoveList(&clopt->instmixins, GuardDel); + /*MixinInvalidateObjOrders(interp, cl);*/ - CmdListRemoveList(&clopt->instfilters, GuardDel); - FilterInvalidateObjOrders(interp, cl); - - /* - * Remove this class from all mixin lists and clear the mixinofs list - */ - - RemoveFromMixins(cl->object.id, clopt->mixinofs); - CmdListRemoveList(&clopt->mixinofs, GuardDel); + CmdListRemoveList(&clopt->instfilters, GuardDel); + /*FilterInvalidateObjOrders(interp, cl);*/ - /* - * Remove this class from all instmixin lists and clear the instmixinofs list - */ - - RemoveFromInstmixins(cl->object.id, clopt->instmixinofs); - CmdListRemoveList(&clopt->instmixinofs, GuardDel); - - /* remove dependent filters of this class from all subclasses*/ - FilterRemoveDependentFilterCmds(cl, cl); - AssertionRemoveStore(clopt->assertions); + if (!recreate) { + /* + * Remove this class from all mixin lists and clear the isObjectMixinOf list + */ + + RemoveFromMixins(clopt->id, clopt->isObjectMixinOf); + CmdListRemoveList(&clopt->isObjectMixinOf, GuardDel); + + /* + * Remove this class from all instmixin lists and clear the isClassMixinOf list + */ + + RemoveFromInstmixins(clopt->id, clopt->isClassMixinOf); + CmdListRemoveList(&clopt->isClassMixinOf, GuardDel); + } + /* remove dependent filters of this class from all subclasses*/ + FilterRemoveDependentFilterCmds(cl, cl); + AssertionRemoveStore(clopt->assertions); + clopt->assertions = NULL; #ifdef XOTCL_OBJECTDATA - XOTclFreeObjectData(cl); + XOTclFreeObjectData(cl); #endif - } + } + + Tcl_ForgetImport(interp, cl->nsPtr, "*"); /* don't destroy namespace imported objects */ + NSCleanupNamespace(interp, cl->nsPtr); + NSDeleteChildren(interp, cl->nsPtr); - Tcl_ForgetImport(interp, cl->nsPtr, "*"); /* don't destroy namespace imported objects */ - NSCleanupNamespace(interp, cl->nsPtr); - NSDeleteChildren(interp, cl->nsPtr); + if (!softrecreate) { + /* maybe todo: do we need an defaultclass for the metaclass as well ? */ + defaultClass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject); - if (!softrecreate) { - defaultClass = DefaultSuperClass(interp, cl, RUNTIME_STATE(interp)->theObject); - /* reset all instances to the class ::xotcl::Object, that makes no sense - for ::Object itself */ - if (cl != theobj) { - hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); - if (inst && inst != (XOTclObject*)cl && inst->id) { - if (inst != &(theobj->object)) { - (void)RemoveInstance(inst, cl->object.cl); - AddInstance(inst, defaultClass); - } - } - } + /* Reclass all instances of the current class the the appropriate + most general class ("baseClass"). The most general class of a + metaclass is ::xotcl::Class, the most general class of an + object is ::xotcl::Object. Instances of metaclasses can be only + reset to ::xotcl::Class (and not to ::xotcl::Object as in + earlier versions), since otherwise their instances can't be + deleted, because ::xotcl::Object has no method "instdestroy". + + We do not have to reclassing in case, cl == ::xotcl::Object + */ + if (cl != theobj) { + XOTclClass *baseClass = IsMetaClass(interp, cl) ? RUNTIME_STATE(interp)->theClass : defaultClass; + if (baseClass == cl) { + /* During final cleanup, we delete ::xotcl::Class; there are + no more Classes or user objects available at that time, so + we reclass to ::xotcl::Object. + */ + baseClass = theobj; + } + hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); + if (inst && inst != (XOTclObject*)cl && inst->id) { + if (inst != &(baseClass->object)) { + (void)RemoveInstance(inst, cl->object.cl); + AddInstance(inst, baseClass); + } } - Tcl_DeleteHashTable(&cl->instances); - MEM_COUNT_FREE("Tcl_InitHashTable",&cl->instances); - } + } + } + Tcl_DeleteHashTable(&cl->instances); + MEM_COUNT_FREE("Tcl_InitHashTable",&cl->instances); + } - if (cl->nonposArgsTable) { - NonposArgsFreeTable(cl->nonposArgsTable); - Tcl_DeleteHashTable(cl->nonposArgsTable); - MEM_COUNT_FREE("Tcl_InitHashTable", cl->nonposArgsTable); - ckfree((char *) cl->nonposArgsTable); - MEM_COUNT_FREE("Tcl_HashTable", cl->nonposArgsTable); - } + if (cl->nonposArgsTable) { + NonposArgsFreeTable(cl->nonposArgsTable); + Tcl_DeleteHashTable(cl->nonposArgsTable); + MEM_COUNT_FREE("Tcl_InitHashTable", cl->nonposArgsTable); + ckfree((char *) cl->nonposArgsTable); + MEM_COUNT_FREE("Tcl_HashTable", cl->nonposArgsTable); + } - if (cl->parameters) { - DECR_REF_COUNT(cl->parameters); - } + if (cl->parameters) { + DECR_REF_COUNT(cl->parameters); + } - if (clopt) { - if (clopt->parameterClass) { - DECR_REF_COUNT(clopt->parameterClass); - } - FREE(XOTclClassOpt, clopt); - clopt = cl->opt = 0; + if ((clopt) && (!recreate)) { + if (clopt->parameterClass) { + DECR_REF_COUNT(clopt->parameterClass); } + FREE(XOTclClassOpt, clopt); + clopt = cl->opt = 0; + } - if (!softrecreate) { - /* - * flush all caches, unlink superclasses - */ - - FlushPrecedences(cl); - while (cl->sub) { - XOTclClass *subClass = cl->sub->cl; - (void)RemoveSuper(subClass, cl); - /* if there are no more super classes add the Object - * class as superclasses - * -> don't do that for Object itself! - */ - if (subClass->super == 0 && cl != theobj) - AddSuper(subClass, defaultClass); - } - while (cl->super) - (void)RemoveSuper(cl, cl->super->cl); + /* On a recreate, it might be possible that the newly created class + has a different superclass. So we have to flush the precedence list + on a recreate as well. + */ + FlushPrecedencesOnSubclasses(cl); + while (cl->super) (void)RemoveSuper(cl, cl->super->cl); + + if (!softrecreate) { + /* + * flush all caches, unlink superclasses + */ + + while (cl->sub) { + XOTclClass *subClass = cl->sub->cl; + (void)RemoveSuper(subClass, cl); + /* if there are no more super classes add the Object + * class as superclasses + * -> don't do that for Object itself! + */ + if (subClass->super == 0 && cl != theobj) + AddSuper(subClass, defaultClass); } + /*(void)RemoveSuper(cl, cl->super->cl);*/ + } } @@ -7795,125 +8250,137 @@ */ static void CleanupInitClass(Tcl_Interp *interp, XOTclClass *cl, Tcl_Namespace *namespacePtr, - int softrecreate) { - XOTclObject *obj = (XOTclObject*)cl; - XOTclClass *defaultSuperclass = RUNTIME_STATE(interp)->theObject; + int softrecreate, int recreate) { + XOTclObject *obj = (XOTclObject*)cl; + XOTclClass *defaultSuperclass; - /* fprintf(stderr,"+++ CleanupInitClass\n"); */ + assert(softrecreate? recreate == 1 : 1); + #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ CleanupInitClass\n"); + fprintf(stderr,"+++ CleanupInitClass\n"); #endif - /* - * during init of Object and Class the theClass value is not set - */ - /* - if (RUNTIME_STATE(interp)->theClass != 0) - obj->type = RUNTIME_STATE(interp)->theClass; - */ - XOTclObjectSetClass(obj); + /* + * during init of Object and Class the theClass value is not set + */ + /* + if (RUNTIME_STATE(interp)->theClass != 0) + obj->type = RUNTIME_STATE(interp)->theClass; + */ + XOTclObjectSetClass(obj); - cl->nsPtr = namespacePtr; - cl->super = 0; - cl->sub = 0; - /* Look for a configured default superclass */ - defaultSuperclass = DefaultSuperClass(interp, cl, RUNTIME_STATE(interp)->theObject); + cl->nsPtr = namespacePtr; + if (!softrecreate) { + /* subclasses are preserved during recreate, superclasses not (since + the creation statement defined the superclass, might be different + the second time) + */ + cl->sub = NULL; + } + cl->super = NULL; + + /* Look for a configured default superclass */ + defaultSuperclass = DefaultSuperClass(interp, cl, cl->object.cl, RUNTIME_STATE(interp)->theObject); /* if (defaultSuperclass) { fprintf(stderr, "default superclass= %s\n", ObjStr(defaultSuperclass->object.cmdName)); } else { fprintf(stderr, "empty super class\n"); }*/ - AddSuper(cl, defaultSuperclass); - cl->color = WHITE; - cl->order = 0; - cl->parameters = 0; + AddSuper(cl, defaultSuperclass); + cl->color = WHITE; + cl->order = NULL; + cl->parameters = NULL; - if (!softrecreate) { - Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",&cl->instances); - } + if (!softrecreate) { + Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",&cl->instances); + } - cl->opt = 0; - cl->nonposArgsTable = 0; + if (!recreate) { + cl->opt = NULL; + } + + cl->nonposArgsTable = NULL; } /* * class physical destruction */ static void PrimitiveCDestroy(ClientData clientData) { - XOTclClass *cl = (XOTclClass*)clientData; - XOTclObject *obj = (XOTclObject*)clientData; - Tcl_Interp *interp; - Tcl_Namespace *saved; + XOTclClass *cl = (XOTclClass*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Interp *interp; + Tcl_Namespace *saved; - /* - * check and latch against recurrent calls with obj->teardown - */ - if (!obj || !obj->teardown) return; - interp = obj->teardown; + /* + * check and latch against recurrent calls with obj->teardown + */ + if (!obj || !obj->teardown) return; + interp = obj->teardown; - /* - * Don't destroy, if the interpreted is destroyed already - * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed - */ - if (Tcl_InterpDeleted(interp)) return; + /* + * Don't destroy, if the interpreted is destroyed already + * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed + */ + if (Tcl_InterpDeleted(interp)) return; - /* - * call and latch user destroy with obj->id if we haven't - */ - /*fprintf(stderr,"PrimitiveCDestroy %s flags %x\n", ObjStr(obj->cmdName), obj->flags);*/ - if (!(obj->flags & XOTCL_DESTROY_CALLED)) - /*fprintf(stderr,"PrimitiveCDestroy call destroy\n");*/ - callDestroyMethod(clientData, interp, obj, 0); + /* + * call and latch user destroy with obj->id if we haven't + */ + /*fprintf(stderr,"PrimitiveCDestroy %s flags %x\n", ObjStr(obj->cmdName), obj->flags);*/ - obj->teardown = 0; + if (!(obj->flags & XOTCL_DESTROY_CALLED)) + /*fprintf(stderr,"PrimitiveCDestroy call destroy\n");*/ + callDestroyMethod(clientData, interp, obj, 0); - CleanupDestroyClass(interp, cl, 0); + obj->teardown = 0; - /* - * handoff the primitive teardown - */ + CleanupDestroyClass(interp, cl, 0, 0); - saved = cl->nsPtr; - obj->teardown = interp; + /* + * handoff the primitive teardown + */ - /* - * class object destroy + physical destroy - */ - /*fprintf(stderr,"primitive cdestroy calls primitive odestroy\n");*/ - PrimitiveODestroy(clientData); + saved = cl->nsPtr; + obj->teardown = interp; - /*fprintf(stderr,"primitive cdestroy calls deletenamespace for obj %p\n", cl);*/ - saved->clientData = 0; - XOTcl_DeleteNamespace(interp, saved); + /* + * class object destroy + physical destroy + */ + /* fprintf(stderr,"primitive cdestroy calls primitive odestroy\n");*/ + PrimitiveODestroy(clientData); - return; + /*fprintf(stderr,"primitive cdestroy calls deletenamespace for obj %p\n", cl);*/ + saved->clientData = NULL; + XOTcl_DeleteNamespace(interp, saved); + + return; } /* * class init */ static void PrimitiveCInit(XOTclClass *cl, Tcl_Interp *interp, char *name) { - TclCallFrame frame, *framePtr = &frame; - Tcl_Namespace *ns; + TclCallFrame frame, *framePtr = &frame; + Tcl_Namespace *ns; - /* - * ensure that namespace is newly created during CleanupInitClass - * ie. kill it, if it exists already - */ - if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, - RUNTIME_STATE(interp)->XOTclClassesNS, 0)!= TCL_OK) - return; - ns = NSGetFreshNamespace(interp, (ClientData)cl, name); - Tcl_PopCallFrame(interp); - - CleanupInitClass(interp, cl, ns, 0); + /* + * ensure that namespace is newly created during CleanupInitClass + * ie. kill it, if it exists already + */ + if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, + RUNTIME_STATE(interp)->XOTclClassesNS, 0) != TCL_OK) return; + ns = NSGetFreshNamespace(interp, (ClientData)cl, name); + Tcl_PopCallFrame(interp); + + CleanupInitClass(interp, cl, ns, 0, 0); + return; } /* @@ -7922,61 +8389,79 @@ */ static XOTclClass* PrimitiveCCreate(Tcl_Interp *interp, char *name, XOTclClass *class) { - XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass)); - unsigned length; - XOTclObject *obj = (XOTclObject*)cl; + XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass)); + unsigned length; + XOTclObject *obj = (XOTclObject*)cl; - /*fprintf(stderr, "CKALLOC Class %p %s\n", cl, name);*/ + /*fprintf(stderr, "CKALLOC Class %p %s\n", cl, name);*/ - memset(cl, 0, sizeof(XOTclClass)); - MEM_COUNT_ALLOC("XOTclObject/XOTclClass", cl); - /* - fprintf(stderr, " +++ CLS alloc: %s\n", name); - */ - assert(isAbsolutePath(name)); - length = strlen(name); - /* - fprintf(stderr,"Class alloc %p '%s'\n", cl, name); - */ - /* check whether Object parent NS already exists, - otherwise: error */ - if (!NSCheckForParent(interp, name, length)) { - ckfree((char *) cl); - return 0; - } - obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch, - (ClientData)cl, PrimitiveCDestroy); + memset(cl, 0, sizeof(XOTclClass)); + MEM_COUNT_ALLOC("XOTclObject/XOTclClass", cl); + /* + fprintf(stderr, " +++ CLS alloc: %s\n", name); + */ + assert(isAbsolutePath(name)); + length = strlen(name); + /* + fprintf(stderr,"Class alloc %p '%s'\n", cl, name); + */ + /* check whether Object parent NS already exists, + otherwise: error */ + if (!NSCheckForParent(interp, name, length)) { + ckfree((char *) cl); + return 0; + } + obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch, + (ClientData)cl, PrimitiveCDestroy); - PrimitiveOInit(obj, interp, name, class); + PrimitiveOInit(obj, interp, name, class); - obj->cmdName = NewXOTclObjectObjName(obj, name, length); - INCR_REF_COUNT(obj->cmdName); - PrimitiveCInit(cl, interp, name+2); + obj->cmdName = NewXOTclObjectObjName(obj, name, length); + INCR_REF_COUNT(obj->cmdName); + PrimitiveCInit(cl, interp, name+2); - objTrace("PrimitiveCCreate", obj); - return cl; + objTrace("PrimitiveCCreate", obj); + return cl; } /* change XOTcl class conditionally; obj must not be NULL */ XOTCLINLINE static int changeClass(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) { - assert(obj); + assert(obj); + + if (cl != obj->cl) { + if (IsMetaClass(interp, cl)) { + /* Do not allow upgrading from a class to a meta-class (in + other words, don't make an object to a class). To allow + this, it would be necessary to reallocate the base + structures. + */ + if (!IsMetaClass(interp, obj->cl)) { + return XOTclVarErrMsg(interp, "cannot turn object into a class", + (char *) NULL); + } + } else { + /* The target class is not a meta class. Changing meta-class to + meta-class, or class to class, or object to object is fine, + but upgrading/downgrading is not allowed */ - if (cl != obj->cl) { - if (IsMetaClass(interp, cl) && !IsMetaClass(interp, obj->cl)) { - return XOTclVarErrMsg(interp, "cannot change class of object ", - ObjStr(obj->cmdName), - " to metaclass ", - ObjStr(cl->object.cmdName),(char *) NULL); - } - (void)RemoveInstance(obj, obj->cl); - AddInstance(obj, cl); + /*fprintf(stderr,"target class %s not a meta class, am i a class %d\n", + ObjStr(cl->object.cmdName), + XOTclObjectIsClass(obj) );*/ - MixinComputeDefined(interp, obj); - FilterComputeDefined(interp, obj); + if (XOTclObjectIsClass(obj)) { + return XOTclVarErrMsg(interp, "cannot turn class into an object ", + (char *) NULL); + } } - return TCL_OK; + (void)RemoveInstance(obj, obj->cl); + AddInstance(obj, cl); + + MixinComputeDefined(interp, obj); + FilterComputeDefined(interp, obj); + } + return TCL_OK; } @@ -7985,35 +8470,35 @@ */ static int doCleanup(Tcl_Interp *interp, XOTclObject *newobj, XOTclObject *classobj, - int objc, Tcl_Obj *CONST objv[]) { - int destroyed = 0, result; - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *csc; - /* - * we check whether the object to be re-created is destroyed or not - */ - for (csc = &cs->content[1]; csc <= cs->top; csc++) { - if (newobj == csc->self && csc->destroyedCmd) { - destroyed = 1; break; - } + int objc, Tcl_Obj *CONST objv[]) { + int destroyed = 0, result; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + /* + * we check whether the object to be re-created is destroyed or not + */ + for (csc = &cs->content[1]; csc <= cs->top; csc++) { + if (newobj == csc->self && csc->destroyedCmd) { + destroyed = 1; break; } + } - if (destroyed) - UndestroyObj(interp, newobj); + if (destroyed) + UndestroyObj(interp, newobj); - /* - * re-create, first ensure correct class for newobj - */ + /* + * re-create, first ensure correct class for newobj + */ - result = changeClass(interp, newobj, (XOTclClass*) classobj); + result = changeClass(interp, newobj, (XOTclClass*) classobj); - if (result == TCL_OK) { - /* - * dispatch "cleanup" - */ - result = callMethod((ClientData) newobj, interp, XOTclGlobalObjects[XOTE_CLEANUP], 2, 0, 0); - } - return result; + if (result == TCL_OK) { + /* + * dispatch "cleanup" + */ + result = callMethod((ClientData) newobj, interp, XOTclGlobalObjects[XOTE_CLEANUP], 2, 0, 0); + } + return result; } /* @@ -8024,139 +8509,140 @@ */ static int doObjInitialization(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) { - int result; - Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); /* save the result */ - INCR_REF_COUNT(savedObjResult); + int result; + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(savedObjResult); - /* - * clear INIT_CALLED flag - */ - obj->flags &= ~XOTCL_INIT_CALLED; + /* + * clear INIT_CALLED flag + */ + obj->flags &= ~XOTCL_INIT_CALLED; + + /* + * call configure methods (starting with '-') + */ + result = callMethod((ClientData) obj, interp, + XOTclGlobalObjects[XOTE_CONFIGURE], objc, objv+2, 0); + if (result != TCL_OK) { + goto objinitexit; + } + /* + * check, whether init was called already + */ + if (!(obj->flags & XOTCL_INIT_CALLED)) { + int nobjc = 0; + Tcl_Obj **nobjv, *resultObj = Tcl_GetObjResult(interp); + /* - * call configure methods (starting with '-') + * Call the user-defined constructor 'init' and pass the result of + * configure to it as arguments */ - result = callMethod((ClientData) obj, interp, - XOTclGlobalObjects[XOTE_CONFIGURE], objc, objv+2, 0); - if (result != TCL_OK) { - goto objinitexit; - } - - /* - * check, whether init was called already - */ - if (!(obj->flags & XOTCL_INIT_CALLED)) { - int nobjc = 0; - Tcl_Obj **nobjv, *resultObj = Tcl_GetObjResult(interp); - /* - * Call the user-defined constructor 'init' and pass the result of - * configure to it as arguments - */ - INCR_REF_COUNT(resultObj); - Tcl_ListObjGetElements(interp, resultObj, &nobjc, &nobjv); - result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_INIT], - nobjc+2, nobjv, 0); - obj->flags |= XOTCL_INIT_CALLED; - DECR_REF_COUNT(resultObj); - } - - if (result == TCL_OK) { - Tcl_SetObjResult(interp, savedObjResult); - } + INCR_REF_COUNT(resultObj); + Tcl_ListObjGetElements(interp, resultObj, &nobjc, &nobjv); + result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_INIT], + nobjc+2, nobjv, 0); + obj->flags |= XOTCL_INIT_CALLED; + DECR_REF_COUNT(resultObj); + } + + if (result == TCL_OK) { + Tcl_SetObjResult(interp, savedObjResult); + } objinitexit: - DECR_REF_COUNT(savedObjResult); - return result; + DECR_REF_COUNT(savedObjResult); + return result; } /* * experimental resolver implementation -> not used at the moment */ -#ifdef NOT_USED +#ifdef EXPERIMENTAL_CMD_RESOLVER static int XOTclResolveCmd(Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, - int flags, Tcl_Command *rPtr) { + int flags, Tcl_Command *rPtr) { - Tcl_Namespace *nsPtr[2], *cxtNsPtr; - char *simpleName; - register Tcl_HashEntry *entryPtr; - register Tcl_Command cmd; - register int search; + Tcl_Namespace *nsPtr[2], *cxtNsPtr; + char *simpleName; + register Tcl_HashEntry *entryPtr; + register Tcl_Command cmd; + register int search; - /*fprintf(stderr, " ***%s->%s\n", contextNsPtr->fullName, name);*/ + /*fprintf(stderr, " ***%s->%s\n", contextNsPtr->fullName, name);*/ - /* - * Find the namespace(s) that contain the command. - */ - if ((flags & TCL_GLOBAL_ONLY) != 0) { - cxtNsPtr = Tcl_GetGlobalNamespace(interp); - } - else if (contextNsPtr != NULL) { - cxtNsPtr = contextNsPtr; - } - else { - cxtNsPtr = Tcl_GetCurrentNamespace(interp); - } + /* + * Find the namespace(s) that contain the command. + */ + if (flags & TCL_GLOBAL_ONLY) { + cxtNsPtr = Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr) { + cxtNsPtr = contextNsPtr; + } + else { + cxtNsPtr = Tcl_GetCurrentNamespace(interp); + } - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,flags, + &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - /*fprintf(stderr, " ***Found %s, %s\n", nsPtr[0]->fullName, nsPtr[0]->fullName);*/ + /*fprintf(stderr, " ***Found %s, %s\n", nsPtr[0]->fullName, nsPtr[0]->fullName);*/ - /* - * Look for the command in the command table of its namespace. - * Be sure to check both possible search paths: from the specified - * namespace context and from the global namespace. - */ + /* + * Look for the command in the command table of its namespace. + * Be sure to check both possible search paths: from the specified + * namespace context and from the global namespace. + */ - cmd = NULL; - for (search = 0; (search < 2) && (cmd == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - cmdTable = Tcl_Namespace_cmdTable(nsPtr[search]); - entryPtr = Tcl_FindHashEntry(cmdTable, simpleName); - if (entryPtr != NULL) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - } + cmd = NULL; + for (search = 0; (search < 2) && (cmd == NULL); search++) { + if (nsPtr[search] && simpleName) { + cmdTable = Tcl_Namespace_cmdTable(nsPtr[search]); + entryPtr = XOTcl_FindHashEntry(cmdTable, simpleName); + if (entryPtr) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + } } - if (cmd != NULL) { - Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); - if (cxtNsPtr->deleteProc == NSNamespaceDeleteProc && - objProc != XOTclObjDispatch && - objProc != XOTclNextObjCmd && - objProc != XOTclGetSelfObjCmd) { + } + if (cmd) { + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + if (NSisXOTclNamespace(cxtNsPtr) && + objProc != XOTclObjDispatch && + objProc != XOTclNextObjCmd && + objProc != XOTclGetSelfObjCmd) { - /* - * the cmd is defined in an XOTcl object or class namespace, but - * not an object & not self/next -> redispatch in - * global namespace - */ - cmd = 0; - nsPtr[0] = Tcl_GetGlobalNamespace(interp); - if ((nsPtr[0] != NULL) && (simpleName != NULL)) { - cmdTable = Tcl_Namespace_cmdTable(nsPtr[0]); - if ((entryPtr = Tcl_FindHashEntry(cmdTable, simpleName))) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - } - - /* - XOTclStackDump(interp); - XOTclCallStackDump(interp); - */ + /* + * the cmd is defined in an XOTcl object or class namespace, but + * not an object & not self/next -> redispatch in + * global namespace + */ + cmd = 0; + nsPtr[0] = Tcl_GetGlobalNamespace(interp); + if (nsPtr[0] && simpleName) { + cmdTable = Tcl_Namespace_cmdTable(nsPtr[0]); + if ((entryPtr = XOTcl_FindHashEntry(cmdTable, simpleName))) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); } - *rPtr = cmd; - return TCL_OK; + } + + /* + XOTclStackDump(interp); + XOTclCallStackDump(interp); + */ } + *rPtr = cmd; + return TCL_OK; + } - return TCL_CONTINUE; + return TCL_CONTINUE; } static int XOTclResolveVar(Tcl_Interp *interp, char *name, Tcl_Namespace *context, - Tcl_ResolvedVarInfo *rPtr) { - /*fprintf(stderr, "Resolving %s in %s\n", name, context->fullName);*/ + Tcl_ResolvedVarInfo *rPtr) { + /*fprintf(stderr, "Resolving %s in %s\n", name, context->fullName);*/ - return TCL_CONTINUE; + return TCL_CONTINUE; } #endif @@ -8166,318 +8652,319 @@ static int XOTclODestroyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - PRINTOBJ("XOTclODestroyMethod", obj); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - /* - * call instdestroy for [self] - */ - return XOTclCallMethodWithArgs((ClientData)obj->cl, interp, - XOTclGlobalObjects[XOTE_INSTDESTROY], obj->cmdName, - objc, objv+1, 0); + PRINTOBJ("XOTclODestroyMethod", obj); + + /* + * call instdestroy for [self] + */ + return XOTclCallMethodWithArgs((ClientData)obj->cl, interp, + XOTclGlobalObjects[XOTE_INSTDESTROY], obj->cmdName, + objc, objv+1, 0); } static int XOTclOCleanupMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclClass *cl = XOTclObjectToClass(obj); - char *fn; - int softrecreate; - Tcl_Obj *savedNameObj; - + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *cl = XOTclObjectToClass(obj); + char *fn; + int softrecreate; + Tcl_Obj *savedNameObj; + #if defined(OBJDELETION_TRACE) - fprintf(stderr,"+++ XOTclOCleanupMethod\n"); + fprintf(stderr,"+++ XOTclOCleanupMethod\n"); #endif - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - PRINTOBJ("XOTclOCleanupMethod", obj); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); + + PRINTOBJ("XOTclOCleanupMethod", obj); + + fn = ObjStr(obj->cmdName); + savedNameObj = obj->cmdName; + INCR_REF_COUNT(savedNameObj); + + /* save and pass around softrecreate*/ + softrecreate = obj->flags & XOTCL_RECREATE && RUNTIME_STATE(interp)->doSoftrecreate; + + CleanupDestroyObject(interp, obj, softrecreate); + CleanupInitObject(interp, obj, obj->cl, obj->nsPtr, softrecreate); - fn = ObjStr(obj->cmdName); - savedNameObj = obj->cmdName; - INCR_REF_COUNT(savedNameObj); - - /* save and pass around softrecreate*/ - softrecreate = obj->flags & XOTCL_RECREATE&& RUNTIME_STATE(interp)->doSoftrecreate; - - CleanupDestroyObject(interp, obj, softrecreate); - CleanupInitObject(interp, obj, obj->cl, obj->nsPtr, softrecreate); - - if (cl) { - CleanupDestroyClass(interp, cl, softrecreate); - CleanupInitClass(interp, cl, cl->nsPtr, softrecreate); - } - - DECR_REF_COUNT(savedNameObj); - - return TCL_OK; + if (cl) { + CleanupDestroyClass(interp, cl, softrecreate, 1); + CleanupInitClass(interp, cl, cl->nsPtr, softrecreate, 1); + } + + DECR_REF_COUNT(savedNameObj); + + return TCL_OK; } static int XOTclOIsClassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj *className; - XOTclObject *obj = (XOTclObject*)clientData, *o; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "?className?"); - className = (objc == 2) ? objv[1] : obj->cmdName; - - Tcl_SetIntObj(Tcl_GetObjResult(interp), - (XOTclObjConvertObject(interp, className, &o) == TCL_OK - && XOTclObjectIsClass(o) )); - return TCL_OK; + Tcl_Obj *className; + XOTclObject *obj = (XOTclObject*)clientData, *o; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?className?"); + className = (objc == 2) ? objv[1] : obj->cmdName; + + Tcl_SetIntObj(Tcl_GetObjResult(interp), + (XOTclObjConvertObject(interp, className, &o) == TCL_OK + && XOTclObjectIsClass(o) )); + return TCL_OK; } static int XOTclOIsObjectMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData, *o; + XOTclObject *obj = (XOTclObject*)clientData, *o; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - - if (XOTclObjConvertObject(interp, objv[1], &o) == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } - return TCL_OK; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + + if (XOTclObjConvertObject(interp, objv[1], &o) == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; } static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl) { - /* check if cl is a meta-class by checking is Class is a superclass of cl*/ - XOTclClasses *pl, *checkList=0, *mixinClasses = 0, *mc; - int hasMCM = 0; + /* check if cl is a meta-class by checking is Class is a superclass of cl*/ + XOTclClasses *pl, *checkList = NULL, *mixinClasses = NULL, *mc; + int hasMCM = 0; - if (cl == RUNTIME_STATE(interp)->theClass) - return 1; - - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - if (pl->cl == RUNTIME_STATE(interp)->theClass) - return 1; + if (cl == RUNTIME_STATE(interp)->theClass) + return 1; + + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + if (pl->cl == RUNTIME_STATE(interp)->theClass) + return 1; + } + + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *clopt = pl->cl->opt; + if (clopt && clopt->instmixins) { + MixinComputeOrderFullList(interp, + &clopt->instmixins, + &mixinClasses, + &checkList, 0); } - - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *clopt = pl->cl->opt; - if (clopt && clopt->instmixins) { - MixinComputeOrderFullList(interp, - &clopt->instmixins, - &mixinClasses, - &checkList, 0); - } + } + + for (mc=mixinClasses; mc; mc = mc->nextPtr) { + /*fprintf(stderr,"- got %s\n", ObjStr(mc->cl->object.cmdName));*/ + if (isSubType(mc->cl, RUNTIME_STATE(interp)->theClass)) { + hasMCM = 1; + break; } - - for (mc=mixinClasses; mc; mc = mc->nextPtr) { - /*fprintf(stderr,"- got %s\n", ObjStr(mc->cl->object.cmdName));*/ - if (isSubType(mc->cl, RUNTIME_STATE(interp)->theClass)) { - hasMCM = 1; - break; - } - } - XOTclClassListFree(mixinClasses); - XOTclClassListFree(checkList); - /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n", - hasMCM, mixinClasses);*/ - - return hasMCM; + } + XOTclClassListFree(mixinClasses); + XOTclClassListFree(checkList); + /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n", + hasMCM, mixinClasses);*/ + + return hasMCM; } static int XOTclOIsMetaClassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData, *o; - Tcl_Obj *className; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "?metaClassName?"); + XOTclObject *obj = (XOTclObject*)clientData, *o; + Tcl_Obj *className; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?metaClassName?"); + + className = (objc == 2) ? objv[1] : obj->cmdName; - className = (objc == 2) ? objv[1] : obj->cmdName; - - if (XOTclObjConvertObject(interp, className, &o) == TCL_OK - && XOTclObjectIsClass(o) - && IsMetaClass(interp, (XOTclClass*)o)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } - return TCL_OK; + if (XOTclObjConvertObject(interp, className, &o) == TCL_OK + && XOTclObjectIsClass(o) + && IsMetaClass(interp, (XOTclClass*)o)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; } static int isSubType(XOTclClass *subcl, XOTclClass *cl) { - XOTclClasses *t; - int success = 1; - assert(cl && subcl); + XOTclClasses *t; + int success = 1; + assert(cl && subcl); - if (cl != subcl) { - success = 0; - for (t = ComputeOrder(subcl, subcl->order, Super); t && t->cl; t = t->nextPtr) { - if (t->cl == cl) { - success = 1; - break; - } - } + if (cl != subcl) { + success = 0; + for (t = ComputeOrder(subcl, subcl->order, Super); t && t->cl; t = t->nextPtr) { + if (t->cl == cl) { + success = 1; + break; + } } - return success; + } + return success; } static int XOTclOIsTypeMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclClass *cl; - int success = 0; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *cl; + int success = 0; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - if (obj->cl && GetXOTclClassFromObj(interp, objv[1], &cl, 0) == TCL_OK) { - success = isSubType(obj->cl, cl); - } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + if (obj->cl && GetXOTclClassFromObj(interp, objv[1], &cl, obj->cl) == TCL_OK) { + success = isSubType(obj->cl, cl); + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; } static int XOTclIsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - int success = 0, opt; + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + int success = 0, opt; - static CONST char *opts[] = { - "type", "object", "class", "metaclass", "mixin", - NULL - }; - enum subCmdIdx { - typeIdx, objectIdx, classIdx, metaclassIdx, mixinIdx - }; + static CONST char *opts[] = { + "type", "object", "class", "metaclass", "mixin", + NULL + }; + enum subCmdIdx { + typeIdx, objectIdx, classIdx, metaclassIdx, mixinIdx + }; - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } - switch (opt) { - case typeIdx: - if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "type "); - success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK - && GetXOTclClassFromObj(interp, objv[3], &cl, 0) == TCL_OK - && isSubType(obj->cl, cl)); - break; + switch (opt) { + case typeIdx: + if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "type "); + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK + && GetXOTclClassFromObj(interp, objv[3], &cl, 0) == TCL_OK + && isSubType(obj->cl, cl)); + break; - case objectIdx: - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "object "); - success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK); - break; + case objectIdx: + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "object "); + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK); + break; - case classIdx: - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "class "); - success = (GetXOTclClassFromObj(interp, objv[1], &cl, 0) == TCL_OK); - break; + case classIdx: + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "class "); + success = (GetXOTclClassFromObj(interp, objv[1], &cl, 0) == TCL_OK); + break; - case metaclassIdx: - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "metaclass "); + case metaclassIdx: + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "metaclass "); - success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK - && XOTclObjectIsClass(obj) - && IsMetaClass(interp, (XOTclClass*)obj)); - break; + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK + && XOTclObjectIsClass(obj) + && IsMetaClass(interp, (XOTclClass*)obj)); + break; - case mixinIdx: - if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "mixin "); + case mixinIdx: + if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "mixin "); - success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK - && GetXOTclClassFromObj(interp, objv[3], &cl, 0) == TCL_OK - && hasMixin(interp, obj, cl)); - break; - } + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK + && GetXOTclClassFromObj(interp, objv[3], &cl, 0) == TCL_OK + && hasMixin(interp, obj, cl)); + break; + } - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; } static int hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - XOTclCmdList *ml; - for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin == cl) { - return 1; - } - } + if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + XOTclCmdList *ml; + for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin == cl) { + return 1; + } } - return 0; + } + return 0; } static int XOTclOIsMixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclClass *cl; - int success = 0; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *cl; + int success = 0; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - if (GetXOTclClassFromObj(interp, objv[1],&cl, 0) == TCL_OK) { - success = hasMixin(interp, obj, cl); - } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; + if (GetXOTclClassFromObj(interp, objv[1],&cl, obj->cl) == TCL_OK) { + success = hasMixin(interp, obj, cl); + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; } static int XOTclOExistsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "var"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "var"); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - varExists(interp, obj, ObjStr(objv[1]), NULL, 1, 1)); - return TCL_OK; + Tcl_SetIntObj(Tcl_GetObjResult(interp), + varExists(interp, obj, ObjStr(objv[1]), NULL, 1, 1)); + return TCL_OK; } static int countModifiers(int objc, Tcl_Obj *CONST objv[]) { - int i, count = 0; - char *to; - for (i = 2; i < objc; i++) { - to = ObjStr(objv[i]); - if (to[0] == '-') { - count++; - /* '--' stops modifiers */ - if (to[1] == '-') break; - } + int i, count = 0; + char *to; + for (i = 2; i < objc; i++) { + to = ObjStr(objv[i]); + if (to[0] == '-') { + count++; + /* '--' stops modifiers */ + if (to[1] == '-') break; } - return count; + } + return count; } static int checkForModifier(Tcl_Obj *CONST objv[], int numberModifiers, char *modifier) { - int i; - if (numberModifiers == 0) return 0; - for (i = 2; i-2 < numberModifiers; i++) { - char *ov = ObjStr(objv[i]); - /* all start with a "-", so there must be a ov[1] */ - if (ov[1] == modifier[1] && !strcmp(ov, modifier)) - return 1; - } - return 0; + int i; + if (numberModifiers == 0) return 0; + for (i = 2; i-2 < numberModifiers; i++) { + char *ov = ObjStr(objv[i]); + /* all start with a "-", so there must be a ov[1] */ + if (ov[1] == modifier[1] && !strcmp(ov, modifier)) + return 1; + } + return 0; } /************ info commands xxx ******/ - static int XOTclObjInfoArgsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj; @@ -8500,1559 +8987,1608 @@ static int XOTclObjInfoBodyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - Tcl_Namespace *nsp; + XOTclObject *obj; + Tcl_Namespace *nsp; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - nsp = obj->nsPtr; - return nsp ? ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])) : TCL_OK; + nsp = obj->nsPtr; + return nsp ? ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])) : TCL_OK; } static int XOTclObjInfoClassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - Tcl_SetObjResult(interp, obj->cl->object.cmdName); - return TCL_OK; + Tcl_SetObjResult(interp, obj->cl->object.cmdName); + return TCL_OK; } static int XOTclObjInfoCommandsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - Tcl_Namespace *nsp; + XOTclObject *obj; + Tcl_Namespace *nsp; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - nsp = obj->nsPtr; - return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), objc == 3 ? ObjStr(objv[2]) : NULL); + nsp = obj->nsPtr; + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), objc == 3 ? ObjStr(objv[2]) : NULL); } static int XOTclObjInfoChildrenMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListChildren(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL, 0); + return ListChildren(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL, 0); } static int XOTclObjInfoSlotObjectsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListSlotObjects(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); + return ListSlotObjects(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); } static int XOTclObjInfoCheckMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return AssertionListCheckOption(interp, obj); + return AssertionListCheckOption(interp, obj); } static int XOTclObjInfoDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - Tcl_Namespace *nsp; + XOTclObject *obj; + Tcl_Namespace *nsp; - if (objc != 5) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 5) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (obj->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListDefaultFromOrdinaryArgs(interp, ObjStr(objv[2]), nonposArgs, ObjStr(objv[3]), objv[4]); - } + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListDefaultFromOrdinaryArgs(interp, ObjStr(objv[2]), nonposArgs, ObjStr(objv[3]), objv[4]); } - nsp = obj->nsPtr; - return nsp ? - ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2]), ObjStr(objv[3]), objv[4]) : - TCL_OK; + } + nsp = obj->nsPtr; + return nsp ? + ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2]), ObjStr(objv[3]), objv[4]) : + TCL_OK; } static int XOTclObjInfoFilterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt;; - int idx, nobjc, withGuards = 0, withOrder = 0; - static CONST char *options[] = {"-guards", "-order", NULL}; - enum options {guardsIdx, orderIdx}; + XOTclObject *obj; + XOTclObjectOpt *opt;; + int idx, nobjc, withGuards = 0, withOrder = 0; + static CONST char *options[] = {"-guards", "-order", NULL}; + enum options {guardsIdx, orderIdx}; - for (idx = 2; idx < objc; idx++) { - char *name; - int index; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - name = Tcl_GetString(objv[idx]); - if (name[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum options) index) { - case guardsIdx: withGuards = 1; break; - case orderIdx: withOrder = 1; break; - } + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; } - nobjc = objc - idx; + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + case orderIdx: withOrder = 1; break; + } + } + nobjc = objc - idx; - if (objc < 2 || nobjc > 1 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards|-order? ?pattern?"); + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards|-order? ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (withOrder) { - if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(interp, obj); - return FilterInfo(interp, obj->filterOrder, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 1); - } - opt = obj->opt; - return opt ? FilterInfo(interp, opt->filters, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 0) : TCL_OK; + if (withOrder) { + if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + return FilterInfo(interp, obj->filterOrder, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 1); + } + opt = obj->opt; + return opt ? FilterInfo(interp, opt->filters, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 0) : TCL_OK; } static int XOTclObjInfoFilterguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt; + XOTclObject *obj; + XOTclObjectOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " filter"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " filter"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - opt = obj->opt; - return opt ? GuardList(interp, opt->filters, ObjStr(objv[2])) : TCL_OK; + opt = obj->opt; + return opt ? GuardList(interp, opt->filters, ObjStr(objv[2])) : TCL_OK; } static int XOTclObjInfoForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - Tcl_Namespace *nsp; - int withDefinition = 0; - char *name = NULL; + XOTclObject *obj; + Tcl_Namespace *nsp; + int withDefinition = 0; + char *name = NULL; - if (objc < 2 || objc > 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-definition? ?name?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-definition? ?name?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (objc > 2) { - name = ObjStr(objv[2]); - if (*name == '-' && !strcmp("-definition", name)) { - withDefinition = 1; - name = ObjStr(objv[3]); - } + if (objc > 2) { + name = ObjStr(objv[2]); + if (*name == '-' && !strcmp("-definition", name)) { + withDefinition = 1; + name = ObjStr(objv[3]); } + } - nsp = obj->nsPtr; - return nsp ? forwardList(interp, Tcl_Namespace_cmdTable(nsp), name, withDefinition) : TCL_OK; + nsp = obj->nsPtr; + return nsp ? forwardList(interp, Tcl_Namespace_cmdTable(nsp), name, withDefinition) : TCL_OK; } static int XOTclObjInfoHasnamespaceMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - Tcl_Namespace *nsp;; + XOTclObject *obj; + Tcl_Namespace *nsp;; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - nsp = obj->nsPtr; - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL); - return TCL_OK; + nsp = obj->nsPtr; + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL); + return TCL_OK; } static int XOTclObjInfoInfoMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListInfo(interp, GetXOTclClassFromObj(interp, obj->cmdName, NULL, 0) == TCL_OK); + return ListInfo(interp, GetXOTclClassFromObj(interp, obj->cmdName, NULL, 0) == TCL_OK); } static int XOTclObjInfoInvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt; + XOTclObject *obj; + XOTclObjectOpt *opt; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - opt = obj->opt; - if (opt && opt->assertions) { - Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); - } - return TCL_OK; + opt = obj->opt; + if (opt && opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); + } + return TCL_OK; } static int XOTclObjInfoMixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt; - int idx, nobjc, withGuards = 0, withOrder = 0; - static CONST char *options[] = {"-guards", "-order", NULL}; - enum options {guardsIdx, orderIdx}; + XOTclObject *obj, *matchObject; + XOTclObjectOpt *opt; + int idx, nobjc, withGuards = 0, withOrder = 0; + static CONST char *options[] = {"-guards", "-order", NULL}; + enum options {guardsIdx, orderIdx}; + Tcl_DString ds, *dsPtr = &ds; + char *pattern = NULL; - for (idx = 2; idx < objc; idx++) { - char *name; - int index; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - name = Tcl_GetString(objv[idx]); - if (name[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum options) index) { - case guardsIdx: withGuards = 1; break; - case orderIdx: withOrder = 1; break; - } + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; } - nobjc = objc-idx; + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + case orderIdx: withOrder = 1; break; + } + } + nobjc = objc-idx; - if (objc < 2 || nobjc > 1 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards|-order? ?pattern?"); + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards|-order? ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + if (idxflags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - return MixinInfo(interp, obj->mixinOrder, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards); - } + if (withOrder) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + return MixinInfo(interp, obj->mixinOrder, pattern, + withGuards, matchObject); + } - opt = obj->opt; - return opt ? MixinInfo(interp, opt->mixins, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards) : TCL_OK; + opt = obj->opt; + return opt ? MixinInfo(interp, opt->mixins, pattern, withGuards, matchObject) : TCL_OK; } static int XOTclObjInfoMixinguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt; + XOTclObject *obj; + XOTclObjectOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " mixin"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " mixin"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - opt = obj->opt; - return opt ? GuardList(interp, opt->mixins, ObjStr(objv[2])) : TCL_OK; + opt = obj->opt; + return opt ? GuardList(interp, opt->mixins, ObjStr(objv[2])) : TCL_OK; } static int XOTclObjInfoMethodsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - int idx, nobj, noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; - static CONST char *options[] = {"-noprocs", "-nocmds", "-nomixins", "-incontext", NULL}; - enum options {noprocsIdx, nocmdsIdx, nomixinsIdx, incontextIdx}; + XOTclObject *obj; + int idx, nobj, noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; + static CONST char *options[] = {"-noprocs", "-nocmds", "-nomixins", "-incontext", NULL}; + enum options {noprocsIdx, nocmdsIdx, nomixinsIdx, incontextIdx}; - for (idx = 2; idx < objc; idx++) { - char *name; - int index; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - name = Tcl_GetString(objv[idx]); - if (name[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum options) index) { - case noprocsIdx: noprocs = 1; break; - case nocmdsIdx: nocmds = 1; break; - case nomixinsIdx: nomixins = 1; break; - case incontextIdx: inContext = 1; break; - } + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; } - nobj = objc-idx; + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case noprocsIdx: noprocs = 1; break; + case nocmdsIdx: nocmds = 1; break; + case nomixinsIdx: nomixins = 1; break; + case incontextIdx: inContext = 1; break; + } + } + nobj = objc-idx; - if (nobj > 1) - return XOTclObjErrArgCnt(interp, objv[0], NULL, - " ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (nobj > 1) + return XOTclObjErrArgCnt(interp, objv[0], NULL, + " ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListMethods(interp, obj, nobj == 1 ? ObjStr(objv[idx]) : NULL, - noprocs, nocmds, nomixins, inContext); + return ListMethods(interp, obj, nobj == 1 ? ObjStr(objv[idx]) : NULL, + noprocs, nocmds, nomixins, inContext); } static int XOTclObjInfoNonposargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (obj->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); - if (nonposArgs) { - Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); - } + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); } - return TCL_OK; + } + return TCL_OK; } static int XOTclObjInfoProcsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - Tcl_Namespace *nsp; + XOTclObject *obj; + Tcl_Namespace *nsp; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - nsp = obj->nsPtr; - return nsp ? ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), - objc == 3 ? ObjStr(objv[2]) : NULL, - /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0 ) : TCL_OK; + nsp = obj->nsPtr; + return nsp ? ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), + objc == 3 ? ObjStr(objv[2]) : NULL, + /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0, 0) : TCL_OK; } static int XOTclObjInfoParentMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListParent(interp, obj); + return ListParent(interp, obj); } static int XOTclObjInfoPreMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt; + XOTclObject *obj; + XOTclObjectOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - opt = obj->opt; - if (opt) { - XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); - } - return TCL_OK; + opt = obj->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + } + return TCL_OK; } static int XOTclObjInfoPostMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; - XOTclObjectOpt *opt; + XOTclObject *obj; + XOTclObjectOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - opt = obj->opt; - if (opt) { - XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); - } - return TCL_OK; + opt = obj->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; } static int XOTclObjInfoPrecedenceMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListPrecedence(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); + return ListPrecedence(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL, 0); } static int XOTclObjInfoVarsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; + XOTclObject *obj; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Object"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return ListVars(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); + return ListVars(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); } static int XOTclOInfoMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - Tcl_Namespace *nsp = obj->nsPtr; - char *cmd, *pattern; - int modifiers = 0; - XOTclObjectOpt *opt; + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Namespace *nsp = obj->nsPtr; + char *cmd, *pattern; + int modifiers = 0; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], " ?args?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], " ?args?"); - opt = obj->opt; - cmd = ObjStr(objv[1]); - pattern = (objc > 2) ? ObjStr(objv[2]) : 0; + opt = obj->opt; + cmd = ObjStr(objv[1]); + pattern = (objc > 2) ? ObjStr(objv[2]) : 0; - /*fprintf(stderr, "OInfo cmd=%s, obj=%s, nsp=%p\n", cmd, ObjStr(obj->cmdName), nsp);*/ + /*fprintf(stderr, "OInfo cmd=%s, obj=%s, nsp=%p\n", cmd, ObjStr(obj->cmdName), nsp);*/ - /* - * check for "-" modifiers - */ - if (pattern && *pattern == '-') { - modifiers = countModifiers(objc, objv); - pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; - } + /* + * check for "-" modifiers + */ + if (pattern && *pattern == '-') { + modifiers = countModifiers(objc, objv); + pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; + } - switch (*cmd) { - case 'a': - if (isArgsString(cmd)) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "args "); - if (obj->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = - NonposArgsGet(obj->nonposArgsTable, pattern); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListArgsFromOrdinaryArgs(interp, nonposArgs); - } - } - if (nsp) - return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern); - else - return TCL_OK; + switch (*cmd) { + case 'a': + if (isArgsString(cmd)) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "args "); + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(obj->nonposArgsTable, pattern); + if (nonposArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); } - break; + } + if (nsp) + return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern); + else + return TCL_OK; + } + break; - case 'b': - if (!strcmp(cmd, "body")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "body "); - if (nsp) - return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern); - else - return TCL_OK; - } - break; + case 'b': + if (!strcmp(cmd, "body")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "body "); + if (nsp) + return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern); + else + return TCL_OK; + } + break; - case 'c': - if (isClassString(cmd)) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "class ?class?"); - return ListClass(interp, obj, pattern, objc, objv); - } else if (!strcmp(cmd, "commands")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "commands ?pat?"); - if (nsp) - return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); - else - return TCL_OK; - } else if (!strcmp(cmd, "children")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "children ?pat?"); - return ListChildren(interp, obj, pattern, 0); - } else if (!strcmp(cmd, "check")) { - if (objc != 2 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "check"); - return AssertionListCheckOption(interp, obj); - } - break; + case 'c': + if (isClassString(cmd)) { + if (objc > 3 || modifiers > 0 || pattern) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "class ?class?"); + return ListClass(interp, obj, objc, objv); + } else if (!strcmp(cmd, "commands")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "commands ?pattern?"); + if (nsp) + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); + else + return TCL_OK; + } else if (!strcmp(cmd, "children")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "children ?pattern?"); + return ListChildren(interp, obj, pattern, 0); + } else if (!strcmp(cmd, "check")) { + if (objc != 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "check"); + return AssertionListCheckOption(interp, obj); + } + break; - case 'd': - if (!strcmp(cmd, "default")) { - if (objc != 5 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "default "); + case 'd': + if (!strcmp(cmd, "default")) { + if (objc != 5 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "default "); - if (obj->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = - NonposArgsGet(obj->nonposArgsTable, pattern); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs, - ObjStr(objv[3]), objv[4]); - } - } - if (nsp) - return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern, - ObjStr(objv[3]), objv[4]); - else - return TCL_OK; + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(obj->nonposArgsTable, pattern); + if (nonposArgs) { + return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs, + ObjStr(objv[3]), objv[4]); } - break; + } + if (nsp) + return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern, + ObjStr(objv[3]), objv[4]); + else + return TCL_OK; + } + break; - case 'f': - if (!strcmp(cmd, "filter")) { - int withGuards = 0, withOrder = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "filter ?-guards? ?-order? ?pat?"); - if (modifiers > 0) { - withGuards = checkForModifier(objv, modifiers, "-guards"); - withOrder = checkForModifier(objv, modifiers, "-order"); + case 'f': + if (!strcmp(cmd, "filter")) { + int withGuards = 0, withOrder = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "filter ?-guards? ?-order? ?pat?"); + if (modifiers > 0) { + withGuards = checkForModifier(objv, modifiers, "-guards"); + withOrder = checkForModifier(objv, modifiers, "-order"); - if (withGuards == 0 && withOrder == 0) - return XOTclVarErrMsg(interp, "info filter: unknown modifier ", - ObjStr(objv[2]), (char *) NULL); - /* - if (withGuards && withOrder) - return XOTclVarErrMsg(interp, "info filter: cannot use -guards and -order together", - ObjStr(objv[2]), (char *) NULL); - */ - } + if (withGuards == 0 && withOrder == 0) + return XOTclVarErrMsg(interp, "info filter: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + /* + if (withGuards && withOrder) + return XOTclVarErrMsg(interp, "info filter: cannot use -guards and -order together", + ObjStr(objv[2]), (char *) NULL); + */ + } - if (withOrder) { - if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(interp, obj); - return FilterInfo(interp, obj->filterOrder, pattern, withGuards, 1); - } + if (withOrder) { + if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + return FilterInfo(interp, obj->filterOrder, pattern, withGuards, 1); + } - return opt ? FilterInfo(interp, opt->filters, pattern, withGuards, 0) : TCL_OK; + return opt ? FilterInfo(interp, opt->filters, pattern, withGuards, 0) : TCL_OK; - } else if (!strcmp(cmd, "filterguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "filterguard filter"); - return opt ? GuardList(interp, opt->filters, pattern) : TCL_OK; - } else if (!strcmp(cmd, "forward")) { - int argc = objc-modifiers; - int definition; - if (argc < 2 || argc > 3) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "forward ?-definition? ?name?"); - definition = checkForModifier(objv, modifiers, "-definition"); - if (nsp) - return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition); - else - return TCL_OK; - } + } else if (!strcmp(cmd, "filterguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "filterguard filter"); + return opt ? GuardList(interp, opt->filters, pattern) : TCL_OK; + } else if (!strcmp(cmd, "forward")) { + int argc = objc-modifiers; + int definition; + if (argc < 2 || argc > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "forward ?-definition? ?name?"); + definition = checkForModifier(objv, modifiers, "-definition"); + if (definition && argc < 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "forward ?-definition name? ?pattern?"); + if (nsp) { + return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition); + } else { + return TCL_OK; + } + } - break; + break; - case 'h': - if (!strcmp(cmd, "hasNamespace")) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL); - return TCL_OK; - } - break; + case 'h': + if (!strcmp(cmd, "hasNamespace")) { + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL); + return TCL_OK; + } + break; - case 'i': - if (!strcmp(cmd, "invar")) { - if (objc != 2 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "invar"); - if (opt && opt->assertions) - Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); - return TCL_OK; - } else if (!strcmp(cmd, "info")) { - if (objc > 2 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "info"); - return ListInfo(interp, GetXOTclClassFromObj(interp, obj->cmdName, NULL, 0) == TCL_OK); - } - break; + case 'i': + if (!strcmp(cmd, "invar")) { + if (objc != 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "invar"); + if (opt && opt->assertions) + Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); + return TCL_OK; + } else if (!strcmp(cmd, "info")) { + if (objc > 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "info"); + return ListInfo(interp, GetXOTclClassFromObj(interp, obj->cmdName, NULL, 0) == TCL_OK); + } + break; - case 'm': - if (!strcmp(cmd, "mixin")) { - int withOrder = 0, withGuards = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "mixin ?-guards? ?-order? ?class?"); - if (modifiers > 0) { - withOrder = checkForModifier(objv, modifiers, "-order"); - withGuards = checkForModifier(objv, modifiers, "-guards"); + case 'm': + if (!strcmp(cmd, "mixin")) { + int withOrder = 0, withGuards = 0, rc; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; - if (withOrder == 0 && withGuards == 0) - return XOTclVarErrMsg(interp, "info mixin: unknown modifier . ", - ObjStr(objv[2]), (char *) NULL); - } + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "mixin ?-guards? ?-order? ?class?"); + if (modifiers > 0) { + withOrder = checkForModifier(objv, modifiers, "-order"); + withGuards = checkForModifier(objv, modifiers, "-guards"); - if (withOrder) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - return MixinInfo(interp, obj->mixinOrder, pattern, withGuards); - } + if (withOrder == 0 && withGuards == 0) + return XOTclVarErrMsg(interp, "info mixin: unknown modifier . ", + ObjStr(objv[2]), (char *) NULL); + } + + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + if (withOrder) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + rc = MixinInfo(interp, obj->mixinOrder, pattern, withGuards, matchObject); + } else { + rc = opt ? MixinInfo(interp, opt->mixins, pattern, withGuards, matchObject) : TCL_OK; + } + DSTRING_FREE(dsPtr); + return rc; - return opt ? MixinInfo(interp, opt->mixins, pattern, withGuards) : TCL_OK; + } else if (!strcmp(cmd, "mixinguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "mixinguard mixin"); - } else if (!strcmp(cmd, "mixinguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "mixinguard mixin"); + return opt ? GuardList(interp, opt->mixins, pattern) : TCL_OK; - return opt ? GuardList(interp, opt->mixins, pattern) : TCL_OK; - - } else if (!strcmp(cmd, "methods")) { - int noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "methods ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pat?"); - if (modifiers > 0) { - noprocs = checkForModifier(objv, modifiers, "-noprocs"); - nocmds = checkForModifier(objv, modifiers, "-nocmds"); - nomixins = checkForModifier(objv, modifiers, "-nomixins"); - inContext = checkForModifier(objv, modifiers, "-incontext"); - } - return ListMethods(interp, obj, pattern, noprocs, nocmds, nomixins, inContext); - } + return opt ? GuardList(interp, opt->mixins, pattern) : TCL_OK; + } else if (!strcmp(cmd, "methods")) { + int noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "methods ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pattern?"); + if (modifiers > 0) { + noprocs = checkForModifier(objv, modifiers, "-noprocs"); + nocmds = checkForModifier(objv, modifiers, "-nocmds"); + nomixins = checkForModifier(objv, modifiers, "-nomixins"); + inContext = checkForModifier(objv, modifiers, "-incontext"); + } + return ListMethods(interp, obj, pattern, noprocs, nocmds, nomixins, inContext); + } #ifdef XOTCL_METADATA - else if (!strcmp(cmd, "metadata")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "metadata ?pat?"); - return ListKeys(interp, &obj->metaData, pattern); - } + else if (!strcmp(cmd, "metadata")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "metadata ?pattern?"); + return ListKeys(interp, &obj->metaData, pattern); + } #endif - break; + break; - case 'n': - if (!strcmp(cmd, "nonposargs")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "nonposargs "); - if (obj->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = - NonposArgsGet(obj->nonposArgsTable, pattern); - if (nonposArgs) { - Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); - } - } - return TCL_OK; + case 'n': + if (!strcmp(cmd, "nonposargs")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "nonposargs "); + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(obj->nonposArgsTable, pattern); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); } - break; + } + return TCL_OK; + } + break; - case 'p': - if (!strcmp(cmd, "procs")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "procs ?pat?"); - if (nsp) - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, - /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0 ); - else - return TCL_OK; - } else if (!strcmp(cmd, "parent")) { - if (objc > 2 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "parent"); - return ListParent(interp, obj); - } else if (!strcmp(cmd, "pre")) { - XOTclProcAssertion *procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "pre "); - if (opt) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); - } - return TCL_OK; - } else if (!strcmp(cmd, "post")) { - XOTclProcAssertion *procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "post "); - if (opt) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); - } - return TCL_OK; - } else if (!strcmp(cmd, "precedence")) { - return ListPrecedence(interp, obj, pattern); - } - break; + case 'p': + if (!strcmp(cmd, "procs")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "procs ?pattern?"); + if (nsp) + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, + /*noProcs*/ 0, /*noCmds*/ 1, /* noDups */ 0, + /* onlyForward */0, /* onlySetter */ 0 ); + else + return TCL_OK; + } else if (!strcmp(cmd, "parent")) { + if (objc > 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "parent"); + return ListParent(interp, obj); + } else if (!strcmp(cmd, "pre")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "pre "); + if (opt) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + } + return TCL_OK; + } else if (!strcmp(cmd, "post")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "post "); + if (opt) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; + } else if (!strcmp(cmd, "precedence")) { + int intrinsic = 0; + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "precedence ?-intrinsic? ?pattern?"); - case 'v': - if (!strcmp(cmd, "vars")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "vars ?pat?"); - return ListVars(interp, obj, pattern); - } - break; + intrinsic = checkForModifier(objv, modifiers, "-intrinsic"); + return ListPrecedence(interp, obj, pattern, intrinsic); + } else if (!strcmp(cmd, "parametercmd")) { + int argc = objc-modifiers; + if (argc < 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, + objv[0], "parametercmd ?pattern?"); + if (nsp) { + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, 1, 0, 0, 0, 1); + } else { + return TCL_OK; + } } - return XOTclErrBadVal(interp, "info", - "an info option (use 'info info' to list all info options)", cmd); + + break; + + case 'v': + if (!strcmp(cmd, "vars")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "vars ?pattern?"); + return ListVars(interp, obj, pattern); + } + break; + } + return XOTclErrBadVal(interp, "info", + "an info option (use 'info info' to list all info options)", cmd); } static int -XOTclOProcMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - char *argStr, *bdyStr, *name; - XOTclObjectOpt *opt; - int incr = 0, result = TCL_OK; +XOTclOProcMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + char *argStr, *bdyStr, *name; + XOTclObjectOpt *opt; + int incr = 0, result = TCL_OK; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 4 || objc > 7) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "name ?non-positional-args? args body ?preAssertion postAssertion?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 4 || objc > 7) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "name ?non-positional-args? args body ?preAssertion postAssertion?"); - if (objc == 5 || objc == 7) { - incr = 1; - } + if (objc == 5 || objc == 7) { + incr = 1; + } - argStr = ObjStr(objv[2 + incr]); - bdyStr = ObjStr(objv[3 + incr]); - name = ObjStr(objv[1 + incr]); + argStr = ObjStr(objv[2 + incr]); + bdyStr = ObjStr(objv[3 + incr]); + name = ObjStr(objv[1 + incr]); - if (*argStr == 0 && *bdyStr == 0) { - opt = obj->opt; - if (opt) - AssertionRemoveProc(opt->assertions, name); - if (obj->nsPtr) - NSDeleteCmd(interp, obj->nsPtr, name); - } else { - XOTclAssertionStore *aStore = NULL; - if (objc > 5) { - opt = XOTclRequireObjectOpt(obj); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; - } - result = MakeProc(requireObjNamespace(interp, obj), aStore, &(obj->nonposArgsTable), - interp, objc, (Tcl_Obj **) objv, obj, 0); + if (*argStr == 0 && *bdyStr == 0) { + opt = obj->opt; + if (opt) + AssertionRemoveProc(opt->assertions, name); + if (obj->nsPtr) + NSDeleteCmd(interp, obj->nsPtr, name); + } else { + XOTclAssertionStore *aStore = NULL; + if (objc > 5) { + opt = XOTclRequireObjectOpt(obj); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; } + requireObjNamespace(interp, obj); + result = MakeProc(obj->nsPtr, aStore, &(obj->nonposArgsTable), + interp, objc, (Tcl_Obj **) objv, obj, 0); + } - /* could be a filter => recompute filter order */ - FilterComputeDefined(interp, obj); - - return result; + /* could be a filter => recompute filter order */ + FilterComputeDefined(interp, obj); + + return result; } static int -XOTclONoinitMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; +XOTclONoinitMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - obj->flags |= XOTCL_INIT_CALLED; + obj->flags |= XOTCL_INIT_CALLED; - return TCL_OK; + return TCL_OK; } + extern int XOTclCreateObject(Tcl_Interp *interp, Tcl_Obj *name, XOTcl_Class *class) { - XOTclClass *cl = (XOTclClass*) class; - int result; - INCR_REF_COUNT(name); - result = XOTclCallMethodWithArgs((ClientData)cl, interp, - XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); - DECR_REF_COUNT(name); - return result; + XOTclClass *cl = (XOTclClass*) class; + int result; + + INCR_REF_COUNT(name); + result = XOTclCallMethodWithArgs((ClientData)cl, interp, + XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); + DECR_REF_COUNT(name); + return result; } extern int XOTclCreateClass(Tcl_Interp *interp, Tcl_Obj *name, XOTcl_Class *class) { - XOTclClass *cl = (XOTclClass*) class; - int result; - INCR_REF_COUNT(name); - result = XOTclCallMethodWithArgs((ClientData)cl, interp, - XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); - DECR_REF_COUNT(name); - return result; + XOTclClass *cl = (XOTclClass *) class; + int result; + + INCR_REF_COUNT(name); + result = XOTclCallMethodWithArgs((ClientData)cl, interp, + XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); + DECR_REF_COUNT(name); + return result; } extern int XOTclCreate(Tcl_Interp *interp, XOTcl_Class *class, Tcl_Obj *name, ClientData data, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = (XOTclClass *) class; - int result; - - INCR_REF_COUNT(name); + XOTclClass *cl = (XOTclClass *) class; + int result; - ALLOC_ON_STACK(Tcl_Obj *, objc+2, ov); - ov[0] = NULL; - ov[1] = name; - if (objc>0) { - memcpy(ov+2, objv, sizeof(Tcl_Obj *)*objc); - } - result = createMethod(interp, (XOTclClass *)cl, data, objc+2, ov); - - FREE_ON_STACK(ov); - DECR_REF_COUNT(name); - - return result; + INCR_REF_COUNT(name); + + ALLOC_ON_STACK(Tcl_Obj *, objc+2, ov); + ov[0] = NULL; + ov[1] = name; + if (objc>0) { + memcpy(ov+2, objv, sizeof(Tcl_Obj *)*objc); + } + result = createMethod(interp, (XOTclClass *)cl, data, objc+2, ov); + + FREE_ON_STACK(ov); + DECR_REF_COUNT(name); + + return result; } int XOTclDeleteObject(Tcl_Interp *interp, XOTcl_Object *obji) { - XOTclObject *obj = (XOTclObject*) obji; - return callMethod((ClientData)obj, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0); + XOTclObject *obj = (XOTclObject*) obji; + return callMethod((ClientData)obj, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0); } int XOTclDeleteClass(Tcl_Interp *interp, XOTcl_Class *cli) { - XOTclClass *cl = (XOTclClass*) cli; - return callMethod((ClientData)cl, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0); + XOTclClass *cl = (XOTclClass*) cli; + return callMethod((ClientData)cl, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0); } extern int XOTclUnsetInstVar2(XOTcl_Object *obji, Tcl_Interp *interp, char *name1, char *name2, int flgs) { - XOTclObject *obj = (XOTclObject*) obji; - int result; - XOTcl_FrameDecls; + XOTclObject *obj = (XOTclObject*) obji; + int result; + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); - if (obj->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, obj); + if (obj->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_UnsetVar2(interp, name1, name2, flgs); - XOTcl_PopFrame(interp, obj); - return result; + result = Tcl_UnsetVar2(interp, name1, name2, flgs); + XOTcl_PopFrame(interp, obj); + return result; } static int GetInstVarIntoCurrentScope(Tcl_Interp *interp, XOTclObject *obj, - Tcl_Obj *varName, Tcl_Obj *newName) { - Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; - int new; - Tcl_CallFrame *varFramePtr; - TclVarHashTable *tablePtr; - XOTcl_FrameDecls; + Tcl_Obj *varName, Tcl_Obj *newName) { + Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; + int new; + Tcl_CallFrame *varFramePtr; + TclVarHashTable *tablePtr; + XOTcl_FrameDecls; - int flgs = TCL_LEAVE_ERR_MSG | - /* PARSE_PART1 needed for 8.0.5 */ TCL_PARSE_PART1; + int flgs = TCL_LEAVE_ERR_MSG | + /* PARSE_PART1 needed for 8.0.5 */ TCL_PARSE_PART1; #if 0 - /* why do we need to deal with vars with namepaces paths? */ - if (newName && strstr(varName, "::")) { - /* the source variable name contains a namespace path. to locate it, we need a namespace */ - requireObjNamespace(interp, obj); - } - /*fprintf(stderr,"GetIntoScope obj=%s ns=%p newName=%s\n", ObjStr(obj->cmdName), obj->nsPtr, newName);*/ + /* why do we need to deal with vars with namepaces paths? */ + if (newName && strstr(varName, "::")) { + /* the source variable name contains a namespace path. to locate it, we need a namespace */ + requireObjNamespace(interp, obj); + } + /*fprintf(stderr,"GetIntoScope obj=%s ns=%p newName=%s\n", ObjStr(obj->cmdName), obj->nsPtr, newName);*/ #endif - XOTcl_PushFrame(interp, obj); - if (obj->nsPtr) { - flgs = flgs|TCL_NAMESPACE_ONLY; - } + XOTcl_PushFrame(interp, obj); + if (obj->nsPtr) { + flgs = flgs|TCL_NAMESPACE_ONLY; + } - otherPtr = XOTclObjLookupVar(interp, varName, (char *) NULL, flgs, "define", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - XOTcl_PopFrame(interp, obj); + otherPtr = XOTclObjLookupVar(interp, varName, (char *) NULL, flgs, "define", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + XOTcl_PopFrame(interp, obj); - if (otherPtr == NULL) { - return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName), - ": can't find variable on ", ObjStr(obj->cmdName), - (char *) NULL); - } + if (otherPtr == NULL) { + return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName), + ": can't find variable on ", ObjStr(obj->cmdName), + (char *) NULL); + } + /* + * if newName == NULL -> there is no alias, use varName + * as target link name + */ + if (newName == NULL) { /* - * if newName == NULL -> there is no alias, use varName - * as target link name + * Variable link into namespace cannot be an element in an array. + * see Tcl_VariableObjCmd ... */ - if (newName == NULL) { - /* - * Variable link into namespace cannot be an element in an array. - * see Tcl_VariableObjCmd ... - */ - if (arrayPtr) { - return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName), - " on ", ObjStr(obj->cmdName), - ": variable cannot be an element in an array;", - " use an alias or objeval.", (char *) NULL); - } - - newName = varName; + if (arrayPtr) { + return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName), + " on ", ObjStr(obj->cmdName), + ": variable cannot be an element in an array;", + " use an alias or objeval.", (char *) NULL); } + + newName = varName; + } #if 0 - /* fprintf(stderr,"ERRORMSG=%s newName='%s' array %p, othervar %p\n", - ObjStr(Tcl_GetObjResult(interp)), newName, arrayPtr, otherPtr); - */ - if (strstr(newName, "::")) { - return XOTclVarErrMsg(interp, "variable name \"", newName, - "\" illegal: must not contain namespace separator", - (char *) NULL); - } + varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + ObjStr(Tcl_GetObjResult(interp)), newName, arrayPtr, otherPtr); +*/ +if (strstr(newName, "::")) { + return XOTclVarErrMsg(interp, "variable name \"", newName, + "\" illegal: must not contain namespace separator", + (char *) NULL); + } #endif - varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); +varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - /* - * If we are executing inside a Tcl procedure, create a local - * variable linked to the new namespace variable "varName". - */ - if (varFramePtr != NULL && Tcl_CallFrame_isProcCallFrame(varFramePtr)) { - Proc *procPtr = Tcl_CallFrame_procPtr(varFramePtr); - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - Var *localVarPtr = Tcl_CallFrame_compiledLocals(varFramePtr); - char *newNameString = ObjStr(newName); - int i, nameLen = strlen(newNameString); +/* + * If we are executing inside a Tcl procedure, create a local + * variable linked to the new namespace variable "varName". + */ +if (varFramePtr && Tcl_CallFrame_isProcCallFrame(varFramePtr)) { + Proc *procPtr = Tcl_CallFrame_procPtr(varFramePtr); + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + Var *localVarPtr = Tcl_CallFrame_compiledLocals(varFramePtr); + char *newNameString = ObjStr(newName); + int i, nameLen = strlen(newNameString); - for (i = 0; i < localCt; i++) { /* look in compiled locals */ - /* fprintf(stderr,"%d of %d %s flags %x not isTemp %d\n", i, localCt, - localPtr->name, localPtr->flags, - !TclIsCompiledLocalTemporary(localPtr));*/ + for (i = 0; i < localCt; i++) { /* look in compiled locals */ + /* fprintf(stderr,"%d of %d %s flags %x not isTemp %d\n", i, localCt, + localPtr->name, localPtr->flags, + !TclIsCompiledLocalTemporary(localPtr));*/ - if (!TclIsCompiledLocalTemporary(localPtr)) { - char *localName = localPtr->name; - if ((newNameString[0] == localName[0]) - && (nameLen == localPtr->nameLength) - && (strcmp(newNameString, localName) == 0)) { - varPtr = getNthVar(localVarPtr, i); - new = 0; - break; - } - } - localPtr = localPtr->nextPtr; - } + if (!TclIsCompiledLocalTemporary(localPtr)) { + char *localName = localPtr->name; + if ((newNameString[0] == localName[0]) + && (nameLen == localPtr->nameLength) + && (strcmp(newNameString, localName) == 0)) { + varPtr = getNthVar(localVarPtr, i); + new = 0; + break; + } + } + localPtr = localPtr->nextPtr; + } - if (varPtr == NULL) { /* look in frame's local var hashtable */ - tablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); - if (tablePtr == NULL) { - tablePtr = (TclVarHashTable *) ckalloc(varHashTableSize); - InitVarHashTable(tablePtr, NULL); - Tcl_CallFrame_varTablePtr(varFramePtr) = tablePtr; - } - varPtr = VarHashCreateVar(tablePtr, newName, &new); - } - /* - * if we define an alias (newName != varName), be sure that - * the target does not exist already - */ - if (!new) { - /*fprintf(stderr,"GetIntoScope createalias\n");*/ - if (varPtr == otherPtr) - return XOTclVarErrMsg(interp, "can't instvar to variable itself", - (char *) NULL); + if (varPtr == NULL) { /* look in frame's local var hashtable */ + tablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); + if (tablePtr == NULL) { + tablePtr = (TclVarHashTable *) ckalloc(varHashTableSize); + InitVarHashTable(tablePtr, NULL); + Tcl_CallFrame_varTablePtr(varFramePtr) = tablePtr; + } + varPtr = VarHashCreateVar(tablePtr, newName, &new); + } + /* + * if we define an alias (newName != varName), be sure that + * the target does not exist already + */ + if (!new) { + /*fprintf(stderr,"GetIntoScope createalias\n");*/ + if (varPtr == otherPtr) + return XOTclVarErrMsg(interp, "can't instvar to variable itself", + (char *) NULL); - if (TclIsVarLink(varPtr)) { - /* we try to make the same instvar again ... this is ok */ - Var *linkPtr = valueOfVar(Var, varPtr, linkPtr); - if (linkPtr == otherPtr) { - return TCL_OK; - } + if (TclIsVarLink(varPtr)) { + /* we try to make the same instvar again ... this is ok */ + Var *linkPtr = valueOfVar(Var, varPtr, linkPtr); + if (linkPtr == otherPtr) { + return TCL_OK; + } - /*fprintf(stderr, "linkvar flags=%x\n", linkPtr->flags); - panic("new linkvar %s... When does this happen?", newNameString, NULL);*/ + /*fprintf(stderr, "linkvar flags=%x\n", linkPtr->flags); + Tcl_Panic("new linkvar %s... When does this happen?", newNameString, NULL);*/ - /* We have already a variable with the same name imported - from a different object. Get rid of this old variable - */ - VarHashRefCount(linkPtr)--; - if (TclIsVarUndefined(linkPtr)) { - CleanupVar(linkPtr, (Var *) NULL); - } + /* We have already a variable with the same name imported + from a different object. Get rid of this old variable + */ + VarHashRefCount(linkPtr)--; + if (TclIsVarUndefined(linkPtr)) { + CleanupVar(linkPtr, (Var *) NULL); + } - } else if (!TclIsVarUndefined(varPtr)) { - return XOTclVarErrMsg(interp, "variable '", ObjStr(newName), - "' exists already", (char *) NULL); - } else if (TclIsVarTraced(varPtr)) { - return XOTclVarErrMsg(interp, "variable '", ObjStr(newName), - "' has traces: can't use for instvar", (char *) NULL); - } - } + } else if (!TclIsVarUndefined(varPtr)) { + return XOTclVarErrMsg(interp, "variable '", ObjStr(newName), + "' exists already", (char *) NULL); + } else if (TclIsVarTraced(varPtr)) { + return XOTclVarErrMsg(interp, "variable '", ObjStr(newName), + "' has traces: can't use for instvar", (char *) NULL); + } + } - TclSetVarLink(varPtr); - TclClearVarUndefined(varPtr); + TclSetVarLink(varPtr); + TclClearVarUndefined(varPtr); #if FORWARD_COMPATIBLE - if (forwardCompatibleMode) { - Var85 *vPtr = (Var85 *)varPtr; - vPtr->value.linkPtr = (Var85 *)otherPtr; - } else { - varPtr->value.linkPtr = otherPtr; - } + if (forwardCompatibleMode) { + Var85 *vPtr = (Var85 *)varPtr; + vPtr->value.linkPtr = (Var85 *)otherPtr; + } else { + varPtr->value.linkPtr = otherPtr; + } #else - varPtr->value.linkPtr = otherPtr; + varPtr->value.linkPtr = otherPtr; #endif - VarHashRefCount(otherPtr)++; + VarHashRefCount(otherPtr)++; - /* - { - Var85 *p = (Var85 *)varPtr; - fprintf(stderr,"defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n", - ObjStr(newName), ObjStr(obj->cmdName), forwardCompatibleMode, - varFlags(varPtr), - TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr)); - } - */ + /* + { + Var85 *p = (Var85 *)varPtr; + fprintf(stderr,"defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n", + ObjStr(newName), ObjStr(obj->cmdName), forwardCompatibleMode, + varFlags(varPtr), + TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr)); } - return TCL_OK; + */ + } +return TCL_OK; } static int XOTclOInstVarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); extern int XOTclInstVar(XOTcl_Object *obji, Tcl_Interp *interp, char *name, char *destName) { - XOTclObject *obj = (XOTclObject*) obji; - int result; - Tcl_Obj *alias = 0; - ALLOC_ON_STACK(Tcl_Obj *, 2, objv); + XOTclObject *obj = (XOTclObject*) obji; + int result; + Tcl_Obj *alias = NULL; + ALLOC_ON_STACK(Tcl_Obj*, 2, objv); - objv[0] = XOTclGlobalObjects[XOTE_INSTVAR]; - objv[1] = Tcl_NewStringObj(name, -1); - INCR_REF_COUNT(objv[1]); + objv[0] = XOTclGlobalObjects[XOTE_INSTVAR]; + objv[1] = Tcl_NewStringObj(name, -1); + INCR_REF_COUNT(objv[1]); - if (destName != 0) { - alias = Tcl_NewStringObj(destName, -1); - INCR_REF_COUNT(alias); - Tcl_ListObjAppendElement(interp, objv[1], alias); - } + if (destName) { + alias = Tcl_NewStringObj(destName, -1); + INCR_REF_COUNT(alias); + Tcl_ListObjAppendElement(interp, objv[1], alias); + } - result = XOTclOInstVarMethod((ClientData) obj, interp, 2, objv); + result = XOTclOInstVarMethod((ClientData) obj, interp, 2, objv); - if (destName != 0) { - DECR_REF_COUNT(alias); - } - DECR_REF_COUNT(objv[1]); - FREE_ON_STACK(objv); - return result; + if (destName) { + DECR_REF_COUNT(alias); + } + DECR_REF_COUNT(objv[1]); + FREE_ON_STACK(objv); + return result; } extern void XOTclRemovePMethod(Tcl_Interp *interp, XOTcl_Object *obji, char *nm) { - XOTclObject *obj = (XOTclObject*) obji; - if (obj->nsPtr) - NSDeleteCmd(interp, obj->nsPtr, nm); + XOTclObject *obj = (XOTclObject*) obji; + if (obj->nsPtr) + NSDeleteCmd(interp, obj->nsPtr, nm); } extern void XOTclRemoveIMethod(Tcl_Interp *interp, XOTcl_Class *cli, char *nm) { - XOTclClass *cl = (XOTclClass*) cli; - NSDeleteCmd(interp, cl->nsPtr, nm); + XOTclClass *cl = (XOTclClass*) cli; + NSDeleteCmd(interp, cl->nsPtr, nm); } /* * obj/cl ClientData setter/getter */ extern void XOTclSetObjClientData(XOTcl_Object *obji, ClientData data) { - XOTclObject *obj = (XOTclObject*) obji; - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - opt->clientData = data; + XOTclObject *obj = (XOTclObject*) obji; + XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); + opt->clientData = data; } extern ClientData XOTclGetObjClientData(XOTcl_Object *obji) { - XOTclObject *obj = (XOTclObject*) obji; - return (obj && obj->opt) ? obj->opt->clientData : 0; + XOTclObject *obj = (XOTclObject*) obji; + return (obj && obj->opt) ? obj->opt->clientData : 0; } extern void XOTclSetClassClientData(XOTcl_Class *cli, ClientData data) { - XOTclClass *cl = (XOTclClass*) cli; - XOTclRequireClassOpt(cl); - cl->opt->clientData = data; + XOTclClass *cl = (XOTclClass*) cli; + XOTclRequireClassOpt(cl); + cl->opt->clientData = data; } extern ClientData XOTclGetClassClientData(XOTcl_Class *cli) { - XOTclClass *cl = (XOTclClass*) cli; - return (cl && cl->opt) ? cl->opt->clientData : 0; + XOTclClass *cl = (XOTclClass*) cli; + return (cl && cl->opt) ? cl->opt->clientData : 0; } static int setInstVar(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *value) { - Tcl_Obj *result; - int flags = (obj->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; - XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); + Tcl_Obj *result; + int flags = (obj->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); - if (value == NULL) { - result = Tcl_ObjGetVar2(interp, name, NULL, flags); - } else { - result = Tcl_ObjSetVar2(interp, name, NULL, value, flags); - } - XOTcl_PopFrame(interp, obj); + if (value == NULL) { + result = Tcl_ObjGetVar2(interp, name, NULL, flags); + } else { + result = Tcl_ObjSetVar2(interp, name, NULL, value, flags); + } + XOTcl_PopFrame(interp, obj); - if (result) { - Tcl_SetObjResult(interp, result); - return TCL_OK; - } - return TCL_ERROR; + if (result) { + Tcl_SetObjResult(interp, result); + return TCL_OK; + } + return TCL_ERROR; } static int XOTclOSetMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc > 3) XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "var ?value?"); - return setInstVar(interp, obj, objv[1], objc == 3 ? objv[2] : NULL); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc > 3 || objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "var ?value?"); + return setInstVar(interp, obj, objv[1], objc == 3 ? objv[2] : NULL); } static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?value?"); - return setInstVar(interp, obj, objv[0], objc == 2 ? objv[1] : NULL); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?value?"); + return setInstVar(interp, obj, objv[0], objc == 2 ? objv[1] : NULL); } static int -XOTclOUpvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - Tcl_Obj *frameInfoObj = NULL; - int i, result = TCL_ERROR; - char *frameInfo; - callFrameContext ctx = {0}; +XOTclOUpvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Obj *frameInfoObj = NULL; + int i, result = TCL_ERROR; + char *frameInfo; + callFrameContext ctx = {0}; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "?level? otherVar localVar ?otherVar localVar ...?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?level? otherVar localVar ?otherVar localVar ...?"); - if (objc % 2 == 0) { - frameInfo = ObjStr(objv[1]); - i = 2; - } else { - frameInfoObj = computeLevelObj(interp, CALLING_LEVEL); - INCR_REF_COUNT(frameInfoObj); - frameInfo = ObjStr(frameInfoObj); - i = 1; - } + if (objc % 2 == 0) { + frameInfo = ObjStr(objv[1]); + i = 2; + } else { + frameInfoObj = computeLevelObj(interp, CALLING_LEVEL); + INCR_REF_COUNT(frameInfoObj); + frameInfo = ObjStr(frameInfoObj); + i = 1; + } - if (obj && (obj->filterStack || obj->mixinStack)) { - CallStackUseActiveFrames(interp, &ctx); - } + if (obj && (obj->filterStack || obj->mixinStack)) { + CallStackUseActiveFrames(interp, &ctx); + } - for ( ; i < objc; i += 2) { - result = Tcl_UpVar2(interp, frameInfo, ObjStr(objv[i]), NULL, - ObjStr(objv[i+1]), 0 /*flags*/); - if (result != TCL_OK) - break; - } + for ( ; i < objc; i += 2) { + result = Tcl_UpVar2(interp, frameInfo, ObjStr(objv[i]), NULL, + ObjStr(objv[i+1]), 0 /*flags*/); + if (result != TCL_OK) + break; + } - if (frameInfoObj) { - DECR_REF_COUNT(frameInfoObj); - } - CallStackRestoreSavedFrames(interp, &ctx); - return result; + if (frameInfoObj) { + DECR_REF_COUNT(frameInfoObj); + } + CallStackRestoreSavedFrames(interp, &ctx); + return result; } static int -XOTclOUplevelMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject *)clientData; - int i, result = TCL_ERROR; - char *frameInfo = NULL; - Tcl_CallFrame *framePtr = NULL, *savedVarFramePtr; +XOTclOUplevelMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { + XOTclObject *obj = (XOTclObject *)clientData; + int i, result = TCL_ERROR; + char *frameInfo = NULL; + Tcl_CallFrame *framePtr = NULL, *savedVarFramePtr; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) { - uplevelSyntax: - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?level? command ?arg ...?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) { + uplevelSyntax: + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?level? command ?arg ...?"); + } + /* + * Find the level to use for executing the command. + */ + if (objc>2) { + CallFrame *cf; + frameInfo = ObjStr(objv[1]); + result = TclGetFrame(interp, frameInfo, &cf); + if (result == -1) { + return TCL_ERROR; } - /* - * Find the level to use for executing the command. - */ - if (objc>2) { - CallFrame *cf; - frameInfo = ObjStr(objv[1]); - result = TclGetFrame(interp, frameInfo, &cf); - if (result == -1) { - return TCL_ERROR; - } - framePtr = (Tcl_CallFrame *)cf; - i = result+1; - } else { - i = 1; - } + framePtr = (Tcl_CallFrame *)cf; + i = result+1; + } else { + i = 1; + } - objc -= i; - objv += i; - if (objc == 0) { - goto uplevelSyntax; - } + objc -= i; + objv += i; + if (objc == 0) { + goto uplevelSyntax; + } - if (!framePtr) { - XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 1); - if (csc) - framePtr = csc->currentFramePtr; - } + if (!framePtr) { + XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 1); + if (csc) + framePtr = csc->currentFramePtr; + } - savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; + savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; - /* - * Execute the residual arguments as a command. - */ + /* + * Execute the residual arguments as a command. + */ - if (objc == 1) { - result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); - } else { - /* - * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. - */ - Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); - } - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - + if (objc == 1) { + result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); + } else { /* - * Restore the variable frame, and return. + * More than one argument: concatenate them together with spaces + * between, then evaluate the result. Tcl_EvalObjEx will delete + * the object when it decrements its refcount after eval'ing it. */ + Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + } + if (result == TCL_ERROR) { + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } - Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr; - return result; + /* + * Restore the variable frame, and return. + */ + + Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr; + return result; } static int forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - Tcl_Obj *o, forwardCmdClientData *tcd, Tcl_Obj **out, - Tcl_Obj **freeList, int *interpputarg, int *mapvalue) { - char *element = ObjStr(o), *p; - int totalargs = objc + tcd->nr_args - 1; - char c = *element, c1; + Tcl_Obj *o, forwardCmdClientData *tcd, Tcl_Obj **out, + Tcl_Obj **freeList, int *inputarg, int *mapvalue) { + char *element = ObjStr(o), *p; + int totalargs = objc + tcd->nr_args - 1; + char c = *element, c1; - p = element; + p = element; - if (c == '%' && *(element+1) == '@') { - char *remainder = NULL; - long pos; - element += 2; - pos = strtol(element,&remainder, 0); - /*fprintf(stderr,"strtol('%s) returned %ld '%s'\n", element, pos, remainder);*/ - if (element == remainder && *element == 'e' && !strncmp(element,"end", 3)) { - pos = totalargs; - remainder += 3; - } - if (element == remainder || abs(pos) > totalargs) { - return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", - ObjStr(o), (char *) NULL); - } if (!remainder || *remainder != ' ') { - return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(o), - "' use: %@ ",(char *) NULL); - } - - element = ++remainder; - if (pos<0) pos = totalargs + pos; - /*fprintf(stderr,"remainder = '%s' pos = %ld\n", remainder, pos);*/ - *mapvalue = pos; - element = remainder; - c = *element; + if (c == '%' && *(element+1) == '@') { + char *remainder = NULL; + long pos; + element += 2; + pos = strtol(element,&remainder, 0); + /*fprintf(stderr,"strtol('%s) returned %ld '%s'\n", element, pos, remainder);*/ + if (element == remainder && *element == 'e' && !strncmp(element,"end", 3)) { + pos = totalargs; + remainder += 3; } - /*fprintf(stderr,"c==%c element = '%s'\n", c, element);*/ - if (c == '%') { - Tcl_Obj *list = 0, **listElements; - int nrargs = objc-1, nrElements = 0; - c = *++element; - c1 = *(element+1); + if (element == remainder || abs(pos) > totalargs) { + return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", + ObjStr(o), (char *) NULL); + } if (!remainder || *remainder != ' ') { + return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(o), + "' use: %@ ",(char *) NULL); + } - if (c == 's' && !strcmp(element,"self")) { - *out = tcd->obj->cmdName; - } else if (c == 'p' && !strcmp(element,"proc")) { - *out = objv[0]; - } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { - /*fprintf(stderr, " nrargs=%d, subcommands=%d inputarg=%d, objc=%d\n", - nrargs, tcd->nr_subcommands, inputarg, objc);*/ - if (c1 != '\0') { - if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %1 must by a valid list, given: '", - ObjStr(o), "'", (char *) NULL); - } - if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", - ObjStr(list),"'", (char *) NULL); - } - } else if (tcd->subcommands) { /* deprecated part */ - if (Tcl_ListObjGetElements(interp, tcd->subcommands,&nrElements,&listElements) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", - ObjStr(list),"'", (char *) NULL); - } - } - if (nrElements > nrargs) { - /* insert default subcommand depending on number of arguments */ - *out = listElements[nrargs]; - } else if (objc<=1) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, "option"); - } else { - *out = objv[1]; - *interpputarg = 2; - } - } else if (c == 'a' && !strncmp(element,"argcl", 4)) { - if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '", - ObjStr(o), "'", (char *) NULL); - } - if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %argclindex contains invalid list '", - ObjStr(list),"'", (char *) NULL); - } - if (nrargs >= nrElements) { - return XOTclVarErrMsg(interp, "forward: not enough elements in specified list of ARGC argument ", - ObjStr(o), (char *) NULL); - } - *out = listElements[nrargs]; - } else if (c == '%') { - Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); - *out = newarg; - goto add_to_freelist; - } else { - /* evaluating given command */ - int result; - /*fprintf(stderr,"evaluating '%s'\n", element);*/ - if ((result = Tcl_EvalEx(interp, element, -1, 0)) != TCL_OK) - return result; - *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); - /*fprintf(stderr,"result = '%s'\n", ObjStr(*out));*/ - goto add_to_freelist; + element = ++remainder; + if (pos<0) pos = totalargs + pos; + /*fprintf(stderr,"remainder = '%s' pos = %ld\n", remainder, pos);*/ + *mapvalue = pos; + element = remainder; + c = *element; + } + /*fprintf(stderr,"c==%c element = '%s'\n", c, element);*/ + if (c == '%') { + Tcl_Obj *list = NULL, **listElements; + int nrargs = objc-1, nrElements = 0; + c = *++element; + c1 = *(element+1); + + if (c == 's' && !strcmp(element,"self")) { + *out = tcd->obj->cmdName; + } else if (c == 'p' && !strcmp(element,"proc")) { + *out = objv[0]; + } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { + /*fprintf(stderr, " nrargs=%d, subcommands=%d inputarg=%d, objc=%d\n", + nrargs, tcd->nr_subcommands, inputarg, objc);*/ + if (c1 != '\0') { + if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 must by a valid list, given: '", + ObjStr(o), "'", (char *) NULL); } - } else { - if (p == element) - *out = o; - else { - Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); - *out = newarg; - goto add_to_freelist; + if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", + ObjStr(list),"'", (char *) NULL); } + } else if (tcd->subcommands) { /* deprecated part */ + if (Tcl_ListObjGetElements(interp, tcd->subcommands,&nrElements,&listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", + ObjStr(list),"'", (char *) NULL); + } + } + if (nrElements > nrargs) { + /* insert default subcommand depending on number of arguments */ + *out = listElements[nrargs]; + } else if (objc<=1) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, "option"); + } else { + *out = objv[1]; + *inputarg = 2; + } + } else if (c == 'a' && !strncmp(element,"argcl", 4)) { + if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '", + ObjStr(o), "'", (char *) NULL); + } + if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %argclindex contains invalid list '", + ObjStr(list),"'", (char *) NULL); + } + if (nrargs >= nrElements) { + return XOTclVarErrMsg(interp, "forward: not enough elements in specified list of ARGC argument ", + ObjStr(o), (char *) NULL); + } + *out = listElements[nrargs]; + } else if (c == '%') { + Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); + *out = newarg; + goto add_to_freelist; + } else { + /* evaluating given command */ + int result; + /*fprintf(stderr,"evaluating '%s'\n", element);*/ + if ((result = Tcl_EvalEx(interp, element, -1, 0)) != TCL_OK) + return result; + *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + /*fprintf(stderr,"result = '%s'\n", ObjStr(*out));*/ + goto add_to_freelist; } - return TCL_OK; + } else { + if (p == element) + *out = o; + else { + Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); + *out = newarg; + goto add_to_freelist; + } + } + return TCL_OK; add_to_freelist: - if (!*freeList) { - *freeList = Tcl_NewListObj(1, out); - INCR_REF_COUNT(*freeList); - } else - Tcl_ListObjAppendElement(interp, *freeList, *out); - return TCL_OK; + if (!*freeList) { + *freeList = Tcl_NewListObj(1, out); + INCR_REF_COUNT(*freeList); + } else + Tcl_ListObjAppendElement(interp, *freeList, *out); + return TCL_OK; } static int callForwarder(forwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - ClientData clientData; - int result; - XOTcl_FrameDecls; + ClientData clientData; + int result; + XOTcl_FrameDecls; - if (tcd->verbose) { - Tcl_Obj *cmd = Tcl_NewListObj(objc, objv); - fprintf(stderr,"calling %s\n", ObjStr(cmd)); - DECR_REF_COUNT(cmd); - } - if (tcd->objscope) { - XOTcl_PushFrame(interp, tcd->obj); - } - if (tcd->objProc) { - /*fprintf(stderr, "callForwarder: callobjproc\n");*/ - result = (tcd->objProc)(tcd->clientData, interp, objc, objv); - } else if (tcd->cmdName->typePtr == &XOTclObjectType - && XOTclObjConvertObject(interp, tcd->cmdName, (void*)&clientData) == TCL_OK) { - /*fprintf(stderr, "callForwarder: XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName), objc);*/ - result = ObjDispatch(clientData, interp, objc, objv, 0); - } else { - /*fprintf(stderr, "callForwarder: no XOTcl object %s\n", ObjStr(tcd->cmdName));*/ - result = Tcl_EvalObjv(interp, objc, objv, 0); - } + if (tcd->verbose) { + Tcl_Obj *cmd = Tcl_NewListObj(objc, objv); + fprintf(stderr,"calling %s\n", ObjStr(cmd)); + DECR_REF_COUNT(cmd); + } + if (tcd->objscope) { + XOTcl_PushFrame(interp, tcd->obj); + } + if (tcd->objProc) { + result = (tcd->objProc)(tcd->clientData, interp, objc, objv); + result = (tcd->objProc)(tcd->clientData, interp, objc, objv); + } else if (tcd->cmdName->typePtr == &XOTclObjectType + && XOTclObjConvertObject(interp, tcd->cmdName, (void*)&clientData) == TCL_OK) { + /*fprintf(stderr, "XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName), objc);*/ + result = XOTclObjDispatch(clientData, interp, objc, objv); + } else { + /*fprintf(stderr, "callForwarder: no XOTcl object %s\n", ObjStr(tcd->cmdName));*/ + result = Tcl_EvalObjv(interp, objc, objv, 0); + } - if (tcd->objscope) { - XOTcl_PopFrame(interp, tcd->obj); - } - if (result == TCL_ERROR && tcd && tcd->onerror) { - Tcl_Obj *ov[2]; - ov[0] = tcd->onerror; - ov[1] = Tcl_GetObjResult(interp); - INCR_REF_COUNT(ov[1]); - /*Tcl_EvalObjEx(interp, tcd->onerror, TCL_EVAL_DIRECT);*/ - Tcl_EvalObjv(interp, 2, ov, 0); - DECR_REF_COUNT(ov[1]); - } - return result; + if (tcd->objscope) { + XOTcl_PopFrame(interp, tcd->obj); + } + if (result == TCL_ERROR && tcd && tcd->onerror) { + Tcl_Obj *ov[2]; + ov[0] = tcd->onerror; + ov[1] = Tcl_GetObjResult(interp); + INCR_REF_COUNT(ov[1]); + /*Tcl_EvalObjEx(interp, tcd->onerror, TCL_EVAL_DIRECT);*/ + Tcl_EvalObjv(interp, 2, ov, 0); + DECR_REF_COUNT(ov[1]); + } + return result; } static int XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; - int result, j, inputarg=1, outputarg=0; - if (!tcd || !tcd->obj) return XOTclObjErrType(interp, objv[0], "Object"); + int objc, Tcl_Obj *CONST objv[]) { + forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + int result, j, inputarg = 1, outputarg = 0; - /* it is a c-method; establish a value for the currentFramePtr */ - RUNTIME_STATE(interp)->cs.top->currentFramePtr = - (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); + if (!tcd || !tcd->obj) return XOTclObjErrType(interp, objv[0], "Object"); + + /* it is a c-method; establish a value for the currentFramePtr */ + RUNTIME_STATE(interp)->cs.top->currentFramePtr = + (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); - /*fprintf(stderr,"...setting currentFramePtr %p to %p (ForwardMethod)\n", - RUNTIME_STATE(interp)->cs.top->currentFramePtr, - (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp)); */ + /*fprintf(stderr,"...setting currentFramePtr %p to %p (ForwardMethod)\n", + RUNTIME_STATE(interp)->cs.top->currentFramePtr, + (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp)); */ - if (tcd->passthrough) { /* two short cuts for simple cases */ - /* early binding, cmd* resolved, we have to care only for objscope */ - /*fprintf(stderr,"+++ forwardMethod passthrough \n");*/ - return callForwarder(tcd, interp, objc, objv); - } else if (!tcd->args && *(ObjStr(tcd->cmdName)) != '%') { - /* we have ony to replace the method name with the given cmd name */ - ALLOC_ON_STACK(Tcl_Obj *, objc, ov); - /*fprintf(stderr,"+++ forwardMethod must subst \n");*/ - memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); - ov[0] = tcd->cmdName; - result = callForwarder(tcd, interp, objc, ov); - FREE_ON_STACK(ov); - return result; - } else { - Tcl_Obj **ov, *freeList=NULL; - int totalargs = objc + tcd->nr_args + 3; - ALLOC_ON_STACK(Tcl_Obj *, totalargs, OV); - ALLOC_ON_STACK(int, totalargs, objvmap); - /*fprintf(stderr,"+++ forwardMethod standard case \n");*/ + if (tcd->passthrough) { /* two short cuts for simple cases */ + /* early binding, cmd *resolved, we have to care only for objscope */ + return callForwarder(tcd, interp, objc, objv); + return callForwarder(tcd, interp, objc, objv); + } else if (!tcd->args && *(ObjStr(tcd->cmdName)) != '%') { + /* we have ony to replace the method name with the given cmd name */ + ALLOC_ON_STACK(Tcl_Obj*, objc, ov); + /*fprintf(stderr,"+++ forwardMethod must subst \n");*/ + memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); + ov[0] = tcd->cmdName; + result = callForwarder(tcd, interp, objc, ov); + FREE_ON_STACK(ov); + return result; + } else { + Tcl_Obj **ov, *freeList=NULL; + int totalargs = objc + tcd->nr_args + 3; + ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV); + ALLOC_ON_STACK(int, totalargs, objvmap); + /*fprintf(stderr,"+++ forwardMethod standard case \n");*/ - ov = &OV[1]; - if (tcd->needobjmap) { - memset(objvmap, -1, sizeof(int)*totalargs); - } + ov = &OV[1]; + if (tcd->needobjmap) { + memset(objvmap, -1, sizeof(int)*totalargs); + } #if 0 - fprintf(stderr,"command %s (%p) objc=%d, subcommand=%d, args=%p, nrargs\n", - ObjStr(objv[0]), tcd, objc, - tcd->nr_subcommands, - tcd->args - ); + fprintf(stderr,"command %s (%p) objc=%d, subcommand=%d, args=%p, nrargs\n", + ObjStr(objv[0]), tcd, objc, + tcd->nr_subcommands, + tcd->args + ); #endif - /* the first argument is always the command, to which we forward */ + /* the first argument is always the command, to which we forward */ - if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd, + if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd, + &ov[outputarg], &freeList, &inputarg, + &objvmap[outputarg])) != TCL_OK) { + goto exitforwardmethod; + } + outputarg++; + + if (tcd->args) { + /* copy argument list from definition */ + Tcl_Obj **listElements; + int nrElements; + Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements); + + for (j=0; jnr_subcommands=%d size=%d\n", + objc, tcd->nr_subcommands, objc+ 2 );*/ - if (tcd->args) { - /* copy argument list from definition */ - Tcl_Obj **listElements; - int nrElements; - Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements); + if (objc-inputarg>0) { + /*fprintf(stderr, " copying remaining %d args starting at [%d]\n", + objc-inputarg, outputarg);*/ + memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg)); + } else { + /*fprintf(stderr, " nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/ + } + objc += outputarg - inputarg; - for (j=0; jnr_subcommands=%d size=%d\n", - objc, tcd->nr_subcommands, objc+ 2 );*/ - - if (objc-inputarg>0) { - /*fprintf(stderr, " copying remaining %d args starting at [%d]\n", - objc-inputarg, outputarg);*/ - memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg)); - } else { - /*fprintf(stderr, " nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/ - } - objc += outputarg - inputarg; - #if 0 - for(j=0; jneedobjmap) - for (j=0; jpos) { - for(i=j; i>pos; i--) { - /*fprintf(stderr,"...moving right %d to %d\n", i-1, i);*/ - ov[i] = ov[i-1]; - objvmap[i] = objvmap[i-1]; - } - } else { - for(i=j; i %s\n", pos, ObjStr(tmp)); */ - ov[pos] = tmp; - objvmap[pos] = -1; - } - - if (tcd->prefix) { - /* prepend a prefix for the subcommands to avoid name clashes */ - Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix); - Tcl_AppendObjToObj(methodName, ov[1]); - ov[1] = methodName; - INCR_REF_COUNT(ov[1]); + if (tcd->needobjmap) + for (j=0; jpos) { + for(i=j; i>pos; i--) { + /*fprintf(stderr,"...moving right %d to %d\n", i-1, i);*/ + ov[i] = ov[i-1]; + objvmap[i] = objvmap[i-1]; + } + } else { + for(i=j; i %s\n", pos, ObjStr(tmp)); */ + ov[pos] = tmp; + objvmap[pos] = -1; + } + if (tcd->prefix) { + /* prepend a prefix for the subcommands to avoid name clashes */ + Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix); + Tcl_AppendObjToObj(methodName, ov[1]); + ov[1] = methodName; + INCR_REF_COUNT(ov[1]); + } + #if 0 - for(j=0; jcmdName; - result = callForwarder(tcd, interp, objc, ov); + OV[0] = tcd->cmdName; + result = callForwarder(tcd, interp, objc, ov); - if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} - exitforwardmethod: - if (freeList) {DECR_REF_COUNT(freeList);} - FREE_ON_STACK(objvmap); - FREE_ON_STACK(OV); - } - return result; + if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} + exitforwardmethod: + if (freeList) {DECR_REF_COUNT(freeList);} + FREE_ON_STACK(objvmap); + FREE_ON_STACK(OV); + } + return result; } static int XOTclOInstVarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - Tcl_Obj **ov; - int i, oc, result = TCL_OK; - callFrameContext ctx = {0}; + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Obj **ov; + int i, oc, result = TCL_OK; + callFrameContext ctx = {0}; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?vars?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?vars?"); - if (obj && (obj->filterStack || obj->mixinStack) ) { - CallStackUseActiveFrames(interp, &ctx); - } - if (!Tcl_Interp_varFramePtr(interp)) { - CallStackRestoreSavedFrames(interp, &ctx); - return XOTclVarErrMsg(interp, "instvar used on ", ObjStr(obj->cmdName), - ", but callstack is not in procedure scope", - (char *) NULL); - } + if (obj && (obj->filterStack || obj->mixinStack) ) { + CallStackUseActiveFrames(interp, &ctx); + } + if (!Tcl_Interp_varFramePtr(interp)) { + CallStackRestoreSavedFrames(interp, &ctx); + return XOTclVarErrMsg(interp, "instvar used on ", ObjStr(obj->cmdName), + ", but callstack is not in procedure scope", + (char *) NULL); + } - for (i=1; icmdName, objv[0], "varname"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "varname"); - nameString = ObjStr(objv[1]); + nameString = ObjStr(objv[1]); - /* - * Make sure the var table exists and the varname is in there - */ - if (NSRequireVariableOnObj(interp, obj, nameString, flgs) == 0) - return XOTclVarErrMsg(interp, "Can't lookup (and create) variable ", - nameString, " on ", ObjStr(obj->cmdName), - (char *) NULL); + /* + * Make sure the var table exists and the varname is in there + */ + if (NSRequireVariableOnObj(interp, obj, nameString, flgs) == 0) + return XOTclVarErrMsg(interp, "Can't lookup (and create) variable ", + nameString, " on ", ObjStr(obj->cmdName), + (char *) NULL); - XOTcl_PushFrame(interp, obj); - /* - * much of this is copied from Tcl, since we must avoid - * access with flag TCL_GLOBAL_ONLY ... doesn't work on - * obj->varTable vars - */ - if (Tcl_TraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, - (ClientData) &done) != TCL_OK) { - return TCL_ERROR; - } - done = 0; - foundEvent = 1; - while (!done && foundEvent) { - foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); - } - Tcl_UntraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, - (ClientData) &done); - XOTcl_PopFrame(interp, obj); - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - Tcl_ResetResult(interp); + XOTcl_PushFrame(interp, obj); + /* + * much of this is copied from Tcl, since we must avoid + * access with flag TCL_GLOBAL_ONLY ... doesn't work on + * obj->varTable vars + */ + if (Tcl_TraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, + (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + done = 0; + foundEvent = 1; + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_UntraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, + (ClientData) &done); + XOTcl_PopFrame(interp, obj); + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + Tcl_ResetResult(interp); - if (!foundEvent) { - return XOTclVarErrMsg(interp, "can't wait for variable '", nameString, - "': would wait forever", (char *) NULL); - } - return TCL_OK; + if (!foundEvent) { + return XOTclVarErrMsg(interp, "can't wait for variable '", nameString, + "': would wait forever", (char *) NULL); + } + return TCL_OK; } static int XOTclOInvariantsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclObjectOpt *opt; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 2) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - opt = XOTclRequireObjectOpt(obj); + opt = XOTclRequireObjectOpt(obj); - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); + if (opt->assertions) + TclObjListFreeList(opt->assertions->invariants); + else + opt->assertions = AssertionCreateStore(); - opt->assertions->invariants = AssertionNewList(interp, objv[1]); - return TCL_OK; + opt->assertions->invariants = AssertionNewList(interp, objv[1]); + return TCL_OK; } static int XOTclOAutonameMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - int instanceOpt = 0, resetOpt = 0; - Tcl_Obj *autoname; + XOTclObject *obj = (XOTclObject*)clientData; + int instanceOpt = 0, resetOpt = 0; + Tcl_Obj *autoname; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc == 3) { - instanceOpt = (strcmp(ObjStr(objv[1]), "-instance") == 0); - resetOpt = (strcmp(ObjStr(objv[1]), "-reset") == 0); - } - if ((objc < 2 || objc > 3) || (objc == 3 && !instanceOpt && !resetOpt)) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?-instance|-reset? name"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc == 3) { + instanceOpt = (strcmp(ObjStr(objv[1]), "-instance") == 0); + resetOpt = (strcmp(ObjStr(objv[1]), "-reset") == 0); + } + if ((objc < 2 || objc > 3) || (objc == 3 && !instanceOpt && !resetOpt)) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "[-instance | -reset] name"); - autoname = AutonameIncr(interp, objv[objc-1], obj, instanceOpt, resetOpt); - if (autoname) { - Tcl_SetObjResult(interp, autoname); - DECR_REF_COUNT(autoname); - } - else - return XOTclVarErrMsg(interp, - "Autoname failed. Probably format string (with %) was not well-formed", - (char *) NULL); + autoname = AutonameIncr(interp, objv[objc-1], obj, instanceOpt, resetOpt); + if (autoname) { + Tcl_SetObjResult(interp, autoname); + DECR_REF_COUNT(autoname); + } + else + return XOTclVarErrMsg(interp, + "Autoname failed. Probably format string (with %) was not well-formed", + (char *) NULL); - return TCL_OK; + return TCL_OK; } static int XOTclOCheckMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - int ocArgs; Tcl_Obj **ovArgs; - int i; - XOTclObjectOpt *opt; + XOTclObject *obj = (XOTclObject*)clientData; + int ocArgs; Tcl_Obj **ovArgs; + int i; + XOTclObjectOpt *opt; - /*fprintf(stderr,"checkmethod\n");*/ - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 2) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "?all? ?pre? ?post? ?invar? ?instinvar?"); + /*fprintf(stderr,"checkmethod\n");*/ + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?all? ?pre? ?post? ?invar? ?instinvar?"); - opt = XOTclRequireObjectOpt(obj); - opt->checkoptions = CHECK_NONE; + opt = XOTclRequireObjectOpt(obj); + opt->checkoptions = CHECK_NONE; - if (Tcl_ListObjGetElements(interp, objv[1], &ocArgs, &ovArgs) == TCL_OK - && ocArgs > 0) { - for (i = 0; i < ocArgs; i++) { - char *option = ObjStr(ovArgs[i]); - if (option != 0) { - switch (*option) { - case 'i': - if (strcmp(option, "instinvar") == 0) { - opt->checkoptions |= CHECK_CLINVAR; - } else if (strcmp(option, "invar") == 0) { - opt->checkoptions |= CHECK_OBJINVAR; - } - break; - case 'p': - if (strcmp(option, "pre") == 0) { - opt->checkoptions |= CHECK_PRE; - } else if (strcmp(option, "post") == 0) { - opt->checkoptions |= CHECK_POST; - } - break; - case 'a': - if (strcmp(option, "all") == 0) { - opt->checkoptions |= CHECK_ALL; - } - break; - } - } + if (Tcl_ListObjGetElements(interp, objv[1], &ocArgs, &ovArgs) == TCL_OK + && ocArgs > 0) { + for (i = 0; i < ocArgs; i++) { + char *option = ObjStr(ovArgs[i]); + if (option) { + switch (*option) { + case 'i': + if (strcmp(option, "instinvar") == 0) { + opt->checkoptions |= CHECK_CLINVAR; + } else if (strcmp(option, "invar") == 0) { + opt->checkoptions |= CHECK_OBJINVAR; + } + break; + case 'p': + if (strcmp(option, "pre") == 0) { + opt->checkoptions |= CHECK_PRE; + } else if (strcmp(option, "post") == 0) { + opt->checkoptions |= CHECK_POST; + } + break; + case 'a': + if (strcmp(option, "all") == 0) { + opt->checkoptions |= CHECK_ALL; + } + break; } + } } - if (opt->checkoptions == CHECK_NONE && ocArgs>0) { - return XOTclVarErrMsg(interp, "Unknown check option in command '", - ObjStr(obj->cmdName), " ", ObjStr(objv[0]), - " ", ObjStr(objv[1]), - "', valid: all pre post invar instinvar", - (char *) NULL); - } + } + if (opt->checkoptions == CHECK_NONE && ocArgs>0) { + return XOTclVarErrMsg(interp, "Unknown check option in command '", + ObjStr(obj->cmdName), " ", ObjStr(objv[0]), + " ", ObjStr(objv[1]), + "', valid: all pre post invar instinvar", + (char *) NULL); + } - Tcl_ResetResult(interp); - return TCL_OK; + Tcl_ResetResult(interp); + return TCL_OK; } static int XOTclConfigureCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int bool, opt, result = TCL_OK; - static CONST char *opts[] = { - "filter", "softrecreate", - NULL - }; - enum subCmdIdx { - filterIdx, softrecreateIdx, - }; + int bool, opt, result = TCL_OK; + static CONST char *opts[] = { + "filter", "softrecreate", + NULL + }; + enum subCmdIdx { + filterIdx, softrecreateIdx, + }; - if (objc < 2 || objc>3) - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "filter|softrecreate ?on|off?"); + if (objc < 2 || objc>3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "filter|softrecreate ?on|off?"); - if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } - if (objc == 3) { - result = Tcl_GetBooleanFromObj(interp, objv[2], &bool); - } - if (result == TCL_OK) { - switch (opt) { - case filterIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doFilters)); - if (objc == 3) - RUNTIME_STATE(interp)->doFilters = bool; - break; + if (objc == 3) { + result = Tcl_GetBooleanFromObj(interp, objv[2], &bool); + } + if (result == TCL_OK) { + switch (opt) { + case filterIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doFilters)); + if (objc == 3) + RUNTIME_STATE(interp)->doFilters = bool; + break; - case softrecreateIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doSoftrecreate)); - if (objc == 3) - RUNTIME_STATE(interp)->doSoftrecreate = bool; - break; - } + case softrecreateIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doSoftrecreate)); + if (objc == 3) + RUNTIME_STATE(interp)->doSoftrecreate = bool; + break; } - return result; + } + return result; } static int XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - aliasCmdClientData *tcd = (aliasCmdClientData *)clientData; - XOTclObject *obj = tcd->obj; - int rc; - XOTcl_FrameDecls; - /*fprintf(stderr,"objscopedMethod obj=%p, ptr=%p\n", obj, tcd->objProc);*/ - XOTcl_PushFrame(interp, obj); - rc = (tcd->objProc)(tcd->clientData, interp, objc, objv); - XOTcl_PopFrame(interp, obj); - return rc; + aliasCmdClientData *tcd = (aliasCmdClientData *)clientData; + XOTclObject *obj = tcd->obj; + int rc; + XOTcl_FrameDecls; + /* fprintf(stderr,"objscopedMethod obj=%p, ptr=%p\n", obj, tcd->objProc); */ + + XOTcl_PushFrame(interp, obj); + rc = (tcd->objProc)(tcd->clientData, interp, objc, objv); + XOTcl_PopFrame(interp, obj); + + return rc; } static void aliasCmdDeleteProc(ClientData clientData) { - aliasCmdClientData *tcd = (aliasCmdClientData *)clientData; - if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} - /*fprintf(stderr,"aliasCmdDeleteProc\n");*/ - FREE(aliasCmdClientData, tcd); + aliasCmdClientData *tcd = (aliasCmdClientData *)clientData; + if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} + /*fprintf(stderr,"aliasCmdDeleteProc\n");*/ + FREE(aliasCmdClientData, tcd); } static int XOTclMethodPropertyCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - Tcl_Command cmd = NULL; - char allocation, *methodName, *optionName; - int protected = 0, i, opt; + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + Tcl_Command cmd = NULL; + char allocation, *methodName, *optionName; + int protected = 0, i, opt; - static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; - enum subCmdIdx {protectedIdx, publicIdx, soltobjIdx}; + static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; + enum subCmdIdx {protectedIdx, publicIdx, soltobjIdx}; - /* TODO introspection */ + /* TODO introspection */ - if (objc < 4 || objc > 6) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "| ?-per-object? ??"); - } + if (objc < 4 || objc > 6) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "| ?-per-object? ??"); + } - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (!cl) { - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) - return XOTclVarErrMsg(interp, ObjStr(objv[0]), - " should be called on Class|Object, not ", - ObjStr(objv[1]), NULL); - allocation = 'o'; - } else { - obj = &cl->object; - allocation = 'c'; - } + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (!cl) { + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + " should be called on Class|Object, not ", + ObjStr(objv[1]), NULL); + allocation = 'o'; + } else { + obj = &cl->object; + allocation = 'c'; + } - methodName = ObjStr(objv[2]); + methodName = ObjStr(objv[2]); - for (i=3; i<5 && i < objc; i++) { - optionName = ObjStr(objv[i]); - if (*optionName != '-') break; - if (!strcmp("-per-object", optionName)) { - allocation = 'o'; - if (cl) obj = &(cl->object); - } else { - return XOTclErrBadVal(interp, "::xotcl::methodproperty", - "option -per-object", optionName); - } + for (i=3; i<5 && i < objc; i++) { + optionName = ObjStr(objv[i]); + if (*optionName != '-') break; + if (!strcmp("-per-object", optionName)) { + allocation = 'o'; + if (cl) obj = &(cl->object); + } else { + return XOTclErrBadVal(interp, "::xotcl::methodproperty", + "option -per-object", optionName); } + } - if (Tcl_GetIndexFromObj(interp, objv[i], opts, "methodproperty", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(interp, objv[i], opts, "methodproperty", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } - /*fprintf(stderr, "allocation for %s = %c\n", ObjStr(objv[1]), allocation);*/ + /*fprintf(stderr, "allocation for %s = %c\n", ObjStr(objv[1]), allocation);*/ - if (allocation == 'o') { /* xxx */ - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); - if (!cmd) { - return XOTclVarErrMsg(interp, ObjStr(objv[0]), - " cannot lookup object method '", - methodName, "' for object ", ObjStr(objv[1]), - (char *) NULL); - } - } else { - if (cl->nsPtr) - cmd = FindMethod(methodName, cl->nsPtr); - if (!cmd) - return XOTclVarErrMsg(interp, ObjStr(objv[0]), " cannot lookup method '", - methodName, "' from class ", ObjStr(objv[1]), - (char *) NULL); + if (allocation == 'o') { /* xxx */ + if (obj->nsPtr) + cmd = FindMethod(methodName, obj->nsPtr); + if (!cmd) { + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + " cannot lookup object method '", + methodName, "' for object ", ObjStr(objv[1]), + (char *) NULL); } + } else { + if (cl->nsPtr) + cmd = FindMethod(methodName, cl->nsPtr); + if (!cmd) + return XOTclVarErrMsg(interp, ObjStr(objv[0]), " cannot lookup method '", + methodName, "' from class ", ObjStr(objv[1]), + (char *) NULL); + } - if (opt == protectedIdx || opt == publicIdx) { - protected = (opt == protectedIdx); + if (opt == protectedIdx || opt == publicIdx) { + protected = (opt == protectedIdx); - if (protected) { - Tcl_Command_flags(cmd) |= XOTCL_PROTECTED_METHOD; - } else { - Tcl_Command_flags(cmd) &= XOTCL_PROTECTED_METHOD; - } - } else { /* slotobj */ - Tcl_HashTable **nonposArgsTable = allocation == 'o' ? - &(obj->nonposArgsTable) : - &(cl->nonposArgsTable); - XOTclNonposArgs *nonposArgs; + if (protected) { + Tcl_Command_flags(cmd) |= XOTCL_PROTECTED_METHOD; + } else { + Tcl_Command_flags(cmd) &= XOTCL_PROTECTED_METHOD; + } + } else { /* slotobj */ + Tcl_HashTable **nonposArgsTable = allocation == 'o' ? + &(obj->nonposArgsTable) : + &(cl->nonposArgsTable); + XOTclNonposArgs *nonposArgs; - if (i + 2 != objc) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "| ?-per-object? slotobj "); - } + if (i + 2 != objc) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "| ?-per-object? slotobj "); + } - if (*nonposArgsTable == 0) { - *nonposArgsTable = NonposArgsCreateTable(); - fprintf(stderr,"this can only happen if we define a slotobj for a class/object without nonposargs\n"); - } - nonposArgs = NonposArgsGet(*nonposArgsTable, methodName); - if (nonposArgs == NULL) { - int nw; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(*nonposArgsTable, methodName, &nw); - assert(nw); + if (*nonposArgsTable == 0) { + *nonposArgsTable = NonposArgsCreateTable(); + fprintf(stderr,"this can only happen if we define a slotobj for a class/object without nonposargs\n"); + } + nonposArgs = NonposArgsGet(*nonposArgsTable, methodName); + if (nonposArgs == NULL) { + int nw; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(*nonposArgsTable, methodName, &nw); + assert(nw); - fprintf(stderr,"this can only happen if we define a slotobj for a method without nonpospargs\n slotobj = %s\n", ObjStr(objv[i+1])); + fprintf(stderr,"this can only happen if we define a slotobj for a method without nonpospargs\n slotobj = %s\n", ObjStr(objv[i+1])); - MEM_COUNT_ALLOC("nonposArg", nonposArgs); - nonposArgs = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); - nonposArgs->slotObj = NULL; - nonposArgs->nonposArgs = NULL; - nonposArgs->ordinaryArgs = NULL; - Tcl_SetHashValue(hPtr, (ClientData)nonposArgs); + MEM_COUNT_ALLOC("nonposArg", nonposArgs); + nonposArgs = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); + nonposArgs->slotObj = NULL; + nonposArgs->nonposArgs = NULL; + nonposArgs->ordinaryArgs = NULL; + Tcl_SetHashValue(hPtr, (ClientData)nonposArgs); - /* TODO check: - problem with nonposArgs->nonposArgs = NULL ? - problem with nonposArgs->ordinaryArgs = NULL ? + /* TODO check: + problem with nonposArgs->nonposArgs = NULL ? + problem with nonposArgs->ordinaryArgs = NULL ? - what happens if first method property and then method. - what happens if method then property then new method? - */ - } else { + what happens if first method property and then method. + what happens if method then property then new method? + */ + } else { - fprintf(stderr,"define slotobj for a method with nonpospargs\n slotobj = %s \n", ObjStr(objv[i+1])); - if (nonposArgs->slotObj) { - DECR_REF_COUNT(nonposArgs->slotObj); - } - } - nonposArgs->slotObj = objv[i+1]; - INCR_REF_COUNT(nonposArgs->slotObj); + fprintf(stderr,"define slotobj for a method with nonpospargs\n slotobj = %s \n", ObjStr(objv[i+1])); + if (nonposArgs->slotObj) { + DECR_REF_COUNT(nonposArgs->slotObj); + } } + nonposArgs->slotObj = objv[i+1]; + INCR_REF_COUNT(nonposArgs->slotObj); + } - return TCL_OK; + return TCL_OK; } static int XOTclDispatchCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result; - char *method; - XOTclObject *obj; - register char *n; - ClientData cp; - /* xxx */ + int result; + char *method; + XOTclObject *obj; + register char *n; + ClientData cp; + /* xxx */ - if (objc < 3) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?args?"); - } - XOTclObjConvertObject(interp, objv[2], &obj); - if (!obj) - return XOTclObjErrType(interp, objv[2], "Class|Object"); + if (objc < 3) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?args?"); + } + XOTclObjConvertObject(interp, objv[2], &obj); + if (!obj) + return XOTclObjErrType(interp, objv[2], "Class|Object"); - method = ObjStr(objv[1]); - n = method + strlen(method); + method = ObjStr(objv[1]); + n = method + strlen(method); - /*search for last '::'*/ - while ((*n != ':' || *(n-1) != ':') && n-1 > method) {n--; } - if (*n == ':' && n > method && *(n-1) == ':') {n--;} + /*search for last '::'*/ + while ((*n != ':' || *(n-1) != ':') && n-1 > method) {n--; } + if (*n == ':' && n > method && *(n-1) == ':') {n--;} - if ((n-method)>1 || *method == ':') { - Tcl_DString parentNSName, *dsp = &parentNSName; - Tcl_Namespace *ns; - Tcl_Command cmd, importedCmd; - char *parentName, *tail = n+2; - DSTRING_INIT(dsp); + if ((n-method)>1 || *method == ':') { + Tcl_DString parentNSName, *dsp = &parentNSName; + Tcl_Namespace *ns; + Tcl_Command cmd, importedCmd; + char *parentName, *tail = n+2; + DSTRING_INIT(dsp); - if (n-method != 0) { - Tcl_DStringAppend(dsp, method, (n-method)); - parentName = Tcl_DStringValue(dsp); - ns = Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); - DSTRING_FREE(dsp); - } else { - ns = Tcl_FindNamespace(interp, "::", (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); - } - if (!ns) { - return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", - method, "'", (char *) NULL); - } + if (n-method != 0) { + Tcl_DStringAppend(dsp, method, (n-method)); + parentName = Tcl_DStringValue(dsp); + ns = Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + DSTRING_FREE(dsp); + } else { + ns = Tcl_FindNamespace(interp, "::", (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + } + if (!ns) { + return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", + method, "'", (char *) NULL); + } - cmd = FindMethod(tail, ns); - if (cmd && (importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } + cmd = FindMethod(tail, ns); + if (cmd && (importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } - if (cmd == NULL) { - return XOTclVarErrMsg(interp, "cannot lookup command '", - tail, "'", (char *) NULL); - } + if (cmd == NULL) { + return XOTclVarErrMsg(interp, "cannot lookup command '", + tail, "'", (char *) NULL); + } - cp = Tcl_Command_objClientData(cmd); - result = DoCallProcCheck(cp, (ClientData)obj, interp, - objc-1, objv+1, cmd, obj, - NULL /*XOTclClass *cl*/, tail, - XOTCL_CSC_TYPE_PLAIN, 0, 1); - } else { - /* no colons, use method from dispatch order, with filters etc. - - strictly speaking unneccessary, but can be used to invoke protected methods */ - int nobjc; - Tcl_Obj *arg; - Tcl_Obj *CONST *nobjv; + cp = Tcl_Command_objClientData(cmd); + result = DoCallProcCheck((ClientData)obj, interp, + objc-1, objv+1, cmd, obj, + NULL /*XOTclClass *cl*/, tail, + XOTCL_CSC_TYPE_PLAIN); + } else { + /* no colons, use method from dispatch order, with filters etc. - + strictly speaking unneccessary, but can be used to invoke protected methods */ + int nobjc; + Tcl_Obj *arg; + Tcl_Obj *CONST *nobjv; - if (objc >= 3) { - arg = objv[3]; - nobjv = objv + 2; - } else { - arg = NULL; - nobjv = NULL; - } - nobjc = objc-3; - result = XOTclCallMethodWithArgs((ClientData)obj, interp, objv[1], arg, - nobjc, nobjv, XOTCL_CM_NO_UNKNOWN); - } - return result; + if (objc >= 3) { + arg = objv[3]; + nobjv = objv + 2; + } else { + arg = NULL; + nobjv = NULL; + } + nobjc = objc-3; + result = XOTclCallMethodWithArgs((ClientData)obj, interp, objv[1], arg, + nobjc, nobjv, XOTCL_CM_NO_UNKNOWN); + } + return result; } static int XOTclAliasCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - Tcl_Command cmd = NULL, importedCmd, newCmd; - Tcl_ObjCmdProc *objProc; - char allocation, *methodName, *optionName; - Tcl_CmdDeleteProc *dp = NULL; - aliasCmdClientData *tcd = NULL; - int objscope = 0, protected = 0, flags = 0, i; - - if (objc < 4 || objc > 6) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "| ?-objscope? ?-per-object? "); - } + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + Tcl_Command cmd = NULL, importedCmd, newCmd; + Tcl_ObjCmdProc *objProc; + char allocation, *methodName, *optionName; + Tcl_CmdDeleteProc *dp = NULL; + aliasCmdClientData *tcd = NULL; + int objscope = 0, protected = 0, flags = 0, i; + + if (objc < 4 || objc > 6) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "| ?-objscope? ?-per-object? "); + } - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (!cl) { - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) - return XOTclObjErrType(interp, objv[1], "Class|Object"); - allocation = 'o'; - } else { - allocation = 'c'; - } + GetXOTclClassFromObj(interp, objv[1], &cl, 0); /* maybe provide base? */ + if (!cl) { + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) + return XOTclObjErrType(interp, objv[1], "Class|Object"); + allocation = 'o'; + } else { + allocation = 'c'; + } - methodName = ObjStr(objv[2]); + methodName = ObjStr(objv[2]); - for (i=3; i<6 && i < objc; i++) { - optionName = ObjStr(objv[i]); - if (*optionName != '-') break; - if (!strcmp("-objscope", optionName)) { - objscope = 1; - } else if (!strcmp("-per-object", optionName)) { - allocation = 'o'; - } else if (!strcmp("-protected", optionName)) { - protected = 1; - } else { - return XOTclErrBadVal(interp, "::xotcl::alias", - "option -objscope or -per-object", optionName); - } + for (i=3; i<6 && i < objc; i++) { + optionName = ObjStr(objv[i]); + if (*optionName != '-') break; + if (!strcmp("-objscope", optionName)) { + objscope = 1; + } else if (!strcmp("-per-object", optionName)) { + allocation = 'o'; + } else if (!strcmp("-protected", optionName)) { + protected = 1; + } else { + return XOTclErrBadVal(interp, "::xotcl::alias", + "option -objscope or -per-object", optionName); } + } - cmd = Tcl_GetCommandFromObj(interp, objv[i]); - if (cmd == NULL) - return XOTclVarErrMsg(interp, "cannot lookup command '", - ObjStr(objv[i]), "'", (char *) NULL); + cmd = Tcl_GetCommandFromObj(interp, objv[i]); + if (cmd == NULL) + return XOTclVarErrMsg(interp, "cannot lookup command '", + ObjStr(objv[i]), "'", (char *) NULL); - if ((importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } - objProc = Tcl_Command_objProc(cmd); + if ((importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + objProc = Tcl_Command_objProc(cmd); - if (objc>i+1) { - return XOTclVarErrMsg(interp, "invalid argument '", - ObjStr(objv[i+1]), "'", (char *) NULL); - } + if (objc>i+1) { + return XOTclVarErrMsg(interp, "invalid argument '", + ObjStr(objv[i+1]), "'", (char *) NULL); + } - if (objscope) { - tcd = NEW(aliasCmdClientData); - tcd->cmdName = 0; - tcd->obj = allocation == 'c' ? &cl->object : obj; - tcd->objProc = objProc; - tcd->clientData = Tcl_Command_objClientData(cmd); - objProc = XOTclObjscopedMethod; - dp = aliasCmdDeleteProc; - } + if (objscope) { + tcd = NEW(aliasCmdClientData); + tcd->cmdName = NULL; + tcd->obj = allocation == 'c' ? &cl->object : obj; + tcd->objProc = objProc; + tcd->clientData = Tcl_Command_objClientData(cmd); + objProc = XOTclObjscopedMethod; + dp = aliasCmdDeleteProc; + } else { + tcd = Tcl_Command_objClientData(cmd); + } - if (protected) { - flags = XOTCL_PROTECTED_METHOD; - } + if (protected) { + flags = XOTCL_PROTECTED_METHOD; + } - if (allocation == 'c') { - /*fprintf(stderr,"alias for %s allocation %c\n", ObjStr(cl->object.cmdName), allocation);*/ - newCmd = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, - objProc, tcd, dp, flags); - } else { - /*fprintf(stderr,"alias for %s allocation %c\n", ObjStr(obj->cmdName), allocation);*/ - newCmd = XOTclAddObjectMethod(interp, (XOTcl_Object*)obj, methodName, - objProc, tcd, dp, flags); - } + if (allocation == 'c') { + newCmd = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, + objProc, tcd, dp, flags); + } else { + newCmd = XOTclAddObjectMethod(interp, (XOTcl_Object*)obj, methodName, + objProc, tcd, dp, flags); + } - return TCL_OK; + return TCL_OK; } static int XOTclSetInstvarCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; + XOTclObject *obj = NULL; - if (objc < 3 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj var ?value?"); - /*fprintf(stderr,"setinstvar obj '%s' var '%s' %d\n", ObjStr(objv[1]), ObjStr(objv[2]), objc);*/ - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 3 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj var ?value?"); + /*fprintf(stderr,"setinstvar obj '%s' var '%s' %d\n", ObjStr(objv[1]), ObjStr(objv[2]), objc);*/ + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - return setInstVar(interp, obj , objv[2], objc == 4 ? objv[3] : NULL); + return setInstVar(interp, obj , objv[2], objc == 4 ? objv[3] : NULL); } static int XOTclRelationCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int oc; Tcl_Obj **ov; - XOTclObject *obj = NULL, *nobj = NULL; - XOTclClass *cl = NULL; - XOTclObjectOpt *objopt = NULL; - XOTclClassOpt *clopt = NULL, *nclopt = NULL; - int i, opt; - static CONST char *opts[] = { - "mixin", "instmixin", "object-mixin", "class-mixin", - "filter", "instfilter", "object-filter", "class-filter", - "class", "superclass", - NULL - }; - enum subCmdIdx { - mixinIdx, instmixinIdx, pomIdx, pcmIdx, - filterIdx, instfilterIdx, pofIdx, pcfIdx, - classIdx, superclassIdx - }; + int oc; Tcl_Obj **ov; + XOTclObject *obj = NULL, *nobj = NULL; + XOTclClass *cl = NULL; + XOTclObjectOpt *objopt = NULL; + XOTclClassOpt *clopt = NULL, *nclopt = NULL; + int i, opt; + static CONST char *opts[] = { + "mixin", "instmixin", "object-mixin", "class-mixin", + "filter", "instfilter", "object-filter", "class-filter", + "class", "superclass", + NULL + }; + enum subCmdIdx { + mixinIdx, instmixinIdx, pomIdx, pcmIdx, + filterIdx, instfilterIdx, pofIdx, pcfIdx, + classIdx, superclassIdx + }; - if (objc < 3 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj reltype values"); + if (objc < 3 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj reltype values"); - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(interp, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } - switch (opt) { - case pomIdx: - case mixinIdx: - case pofIdx: - case filterIdx: - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); - if (objc == 3) { - objopt = obj->opt; - switch (opt) { - case pomIdx: - case mixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1) : TCL_OK; - case pofIdx: - case filterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; - } - } - if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) - return TCL_ERROR; - objopt = XOTclRequireObjectOpt(obj); - break; + switch (opt) { + case pomIdx: + case mixinIdx: + case pofIdx: + case filterIdx: + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); + if (objc == 3) { + objopt = obj->opt; + switch (opt) { + case pomIdx: + case mixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; + case pofIdx: + case filterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; + } + } + if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + return TCL_ERROR; + objopt = XOTclRequireObjectOpt(obj); + break; - case pcmIdx: - case instmixinIdx: - case pcfIdx: - case instfilterIdx: - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); + case pcmIdx: + case instmixinIdx: + case pcfIdx: + case instfilterIdx: + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); - if (objc == 3) { - clopt = cl->opt; - switch (opt) { - case pcmIdx: - case instmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1) : TCL_OK; - case pcfIdx: - case instfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; - } - } + if (objc == 3) { + clopt = cl->opt; + switch (opt) { + case pcmIdx: + case instmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1, NULL) : TCL_OK; + case pcfIdx: + case instfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; + } + } - if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) - return TCL_ERROR; - clopt = XOTclRequireClassOpt(cl); - break; + if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + return TCL_ERROR; + clopt = XOTclRequireClassOpt(cl); + break; - case superclassIdx: - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (objc == 3) { - return ListSuperclasses(interp, cl, NULL); - } - if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); - if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) - return TCL_ERROR; - return SuperclassAdd(interp, cl, oc, ov, objv[3], cl->object.cl); + case superclassIdx: + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (objc == 3) { + return ListSuperclasses(interp, cl, NULL, 0); + } + if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); + if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + return TCL_ERROR; + return SuperclassAdd(interp, cl, oc, ov, objv[3], cl->object.cl); - case classIdx: - XOTclObjConvertObject(interp, objv[1], &obj); - if (objc == 3) { - Tcl_SetObjResult(interp, obj->cl->object.cmdName); - return TCL_OK; - } - if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); - GetXOTclClassFromObj(interp, objv[3], &cl, obj->cl); - if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1])); - return changeClass(interp, obj, cl); + case classIdx: + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); + if (objc == 3) { + Tcl_SetObjResult(interp, obj->cl->object.cmdName); + return TCL_OK; } + GetXOTclClassFromObj(interp, objv[3], &cl, obj->cl); + if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1])); + return changeClass(interp, obj, cl); + } - switch (opt) { - case pomIdx: - case mixinIdx: + switch (opt) { + case pomIdx: + case mixinIdx: - if (objopt->mixins) { - XOTclCmdList *cmdlist, *del; - for (cmdlist = objopt->mixins; cmdlist; cmdlist = cmdlist->nextPtr) { - cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); - clopt = cl ? cl->opt : NULL; - if (clopt) { - del = CmdListFindCmdInList(obj->id, clopt->mixinofs); - if (del) { - /* fprintf(stderr,"Removing object %s from mixinofs of class %s\n", - ObjStr(obj->cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ - del = CmdListRemoveFromList(&clopt->mixinofs, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } - } - CmdListRemoveList(&objopt->mixins, GuardDel); + if (objopt->mixins) { + XOTclCmdList *cmdlist, *del; + for (cmdlist = objopt->mixins; cmdlist; cmdlist = cmdlist->nextPtr) { + cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr); + clopt = cl ? cl->opt : NULL; + if (clopt) { + del = CmdListFindCmdInList(obj->id, clopt->isObjectMixinOf); + if (del) { + /* fprintf(stderr,"Removing object %s from isObjectMixinOf of class %s\n", + ObjStr(obj->cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } } + } + CmdListRemoveList(&objopt->mixins, GuardDel); + } - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - /* - * since mixin procs may be used as filters -> we have to invalidate - */ - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + /* + * since mixin procs may be used as filters -> we have to invalidate + */ + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - /* - * now add the specified mixins - */ - for (i = 0; i < oc; i++) { - Tcl_Obj *ocl = NULL; + /* + * now add the specified mixins + */ + for (i = 0; i < oc; i++) { + Tcl_Obj *ocl = NULL; - if (MixinAdd(interp, &objopt->mixins, ov[i], obj->cl->object.cl) != TCL_OK) { - return TCL_ERROR; - } - /* fprintf(stderr,"Added to mixins of %s: %s\n", ObjStr(obj->cmdName), ObjStr(ov[i])); */ - Tcl_ListObjIndex(interp, ov[i], 0, &ocl); - XOTclObjConvertObject(interp, ocl, &nobj); - if (nobj) { - /* fprintf(stderr,"Registering object %s to mixinofs of class %s\n", - ObjStr(obj->cmdName), ObjStr(nobj->cmdName)); */ - nclopt = XOTclRequireClassOpt((XOTclClass*) nobj); - CmdListAdd(&nclopt->mixinofs, obj->id, NULL, /*noDuplicates*/ 1); - } /* else fprintf(stderr,"Problem registering %s as a mixinof of %s\n", - ObjStr(ov[i]), ObjStr(cl->object.cmdName)); */ - } + if (MixinAdd(interp, &objopt->mixins, ov[i], obj->cl->object.cl) != TCL_OK) { + return TCL_ERROR; + } + /* fprintf(stderr,"Added to mixins of %s: %s\n", ObjStr(obj->cmdName), ObjStr(ov[i])); */ + Tcl_ListObjIndex(interp, ov[i], 0, &ocl); + XOTclObjConvertObject(interp, ocl, &nobj); + if (nobj) { + /* fprintf(stderr,"Registering object %s to isObjectMixinOf of class %s\n", + ObjStr(obj->cmdName), ObjStr(nobj->cmdName)); */ + nclopt = XOTclRequireClassOpt((XOTclClass*) nobj); + CmdListAdd(&nclopt->isObjectMixinOf, obj->id, NULL, /*noDuplicates*/ 1); + } /* else fprintf(stderr,"Problem registering %s as a mixinof of %s\n", + ObjStr(ov[i]), ObjStr(cl->object.cmdName)); */ + } - MixinComputeDefined(interp, obj); - FilterComputeDefined(interp, obj); - break; + MixinComputeDefined(interp, obj); + FilterComputeDefined(interp, obj); + break; - case pofIdx: - case filterIdx: + case pofIdx: + case filterIdx: - if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); + if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - for (i = 0; i < oc; i ++) { - if (FilterAdd(interp, &objopt->filters, ov[i], obj, 0) != TCL_OK) - return TCL_ERROR; - } - /*FilterComputeDefined(interp, obj);*/ - break; + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + for (i = 0; i < oc; i ++) { + if (FilterAdd(interp, &objopt->filters, ov[i], obj, 0) != TCL_OK) + return TCL_ERROR; + } + /*FilterComputeDefined(interp, obj);*/ + break; - case pcmIdx: - case instmixinIdx: + case pcmIdx: + case instmixinIdx: - if (clopt->instmixins) { - RemoveFromInstmixinsofs(cl->object.id, clopt->instmixins); - CmdListRemoveList(&clopt->instmixins, GuardDel); - } - MixinInvalidateObjOrders(interp, cl); - /* - * since mixin procs may be used as filters, - * we have to invalidate the filters as well - */ - FilterInvalidateObjOrders(interp, cl); + if (clopt->instmixins) { + RemoveFromClassMixinsOf(cl->object.id, clopt->instmixins); + CmdListRemoveList(&clopt->instmixins, GuardDel); + } + MixinInvalidateObjOrders(interp, cl); + /* + * since mixin procs may be used as filters, + * we have to invalidate the filters as well + */ + FilterInvalidateObjOrders(interp, cl); - for (i = 0; i < oc; i++) { - Tcl_Obj *ocl = NULL; - if (MixinAdd(interp, &clopt->instmixins, ov[i], cl->object.cl) != TCL_OK) { - return TCL_ERROR; - } - /* fprintf(stderr,"Added to instmixins of %s: %s\n", - ObjStr(cl->object.cmdName), ObjStr(ov[i])); */ + for (i = 0; i < oc; i++) { + Tcl_Obj *ocl = NULL; + if (MixinAdd(interp, &clopt->instmixins, ov[i], cl->object.cl) != TCL_OK) { + return TCL_ERROR; + } + /* fprintf(stderr,"Added to instmixins of %s: %s\n", + ObjStr(cl->object.cmdName), ObjStr(ov[i])); */ - Tcl_ListObjIndex(interp, ov[i], 0, &ocl); - XOTclObjConvertObject(interp, ocl, &nobj); - if (nobj) { - /* fprintf(stderr,"Registering class %s to instmixinofs of class %s\n", - ObjStr(cl->object.cmdName), ObjStr(nobj->cmdName)); */ - nclopt = XOTclRequireClassOpt((XOTclClass*) nobj); - CmdListAdd(&nclopt->instmixinofs, cl->object.id, NULL, /*noDuplicates*/ 1); - } /* else fprintf(stderr,"Problem registering %s as a instmixinof of %s\n", - ObjStr(ov[i]), ObjStr(cl->object.cmdName)); */ - } - break; + Tcl_ListObjIndex(interp, ov[i], 0, &ocl); + XOTclObjConvertObject(interp, ocl, &nobj); + if (nobj) { + /* fprintf(stderr,"Registering class %s to isClassMixinOf of class %s\n", + ObjStr(cl->object.cmdName), ObjStr(nobj->cmdName)); */ + nclopt = XOTclRequireClassOpt((XOTclClass*) nobj); + CmdListAdd(&nclopt->isClassMixinOf, cl->object.id, NULL, /*noDuplicates*/ 1); + } /* else fprintf(stderr,"Problem registering %s as a instmixinof of %s\n", + ObjStr(ov[i]), ObjStr(cl->object.cmdName)); */ + } + break; - case pcfIdx: - case instfilterIdx: + case pcfIdx: + case instfilterIdx: - if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); + if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); - FilterInvalidateObjOrders(interp, cl); - for (i = 0; i < oc; i ++) { - if (FilterAdd(interp, &clopt->instfilters, ov[i], 0, cl) != TCL_OK) - return TCL_ERROR; - } - break; - + FilterInvalidateObjOrders(interp, cl); + for (i = 0; i < oc; i ++) { + if (FilterAdd(interp, &clopt->instfilters, ov[i], 0, cl) != TCL_OK) + return TCL_ERROR; } - return TCL_OK; + break; + + } + return TCL_OK; } static int XOTclOMixinGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclCmdList *h; - XOTclObjectOpt *opt; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclCmdList *h; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 3) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "mixin guards"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "mixin guards"); - opt = obj->opt; - if (opt && opt->mixins) { - XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); - } - if (mixinCmd) { - h = CmdListFindCmdInList(mixinCmd, opt->mixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, objv[2]); - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - return TCL_OK; - } - } + opt = obj->opt; + if (opt && opt->mixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); } + if (mixinCmd) { + h = CmdListFindCmdInList(mixinCmd, opt->mixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, objv[2]); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + return TCL_OK; + } + } + } - return XOTclVarErrMsg(interp, "Mixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Mixinguard: can't find mixin ", + ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), + (char *) NULL); } static int XOTclOFilterGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclCmdList *h; - XOTclObjectOpt *opt; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclCmdList *h; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 3) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "filtername filterGuards"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "filtername filterGuards"); - opt = obj->opt; - if (opt && opt->filters) { - h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->filters); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, objv[2]); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - return TCL_OK; - } + opt = obj->opt; + if (opt && opt->filters) { + h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->filters); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, objv[2]); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + return TCL_OK; } + } - return XOTclVarErrMsg(interp, "Filterguard: can't find filter ", - ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Filterguard: can't find filter ", + ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), + (char *) NULL); } /* @@ -10879,289 +11417,286 @@ */ static int XOTclOFilterSearchMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - char *methodName; - XOTclCmdList *cmdList; - XOTclClass *fcl; - XOTclObject *fobj; + XOTclObject *obj = (XOTclObject*)clientData; + char *methodName; + XOTclCmdList *cmdList; + XOTclClass *fcl; + XOTclObject *fobj; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - Tcl_ResetResult(interp); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "name"); + Tcl_ResetResult(interp); - if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(interp, obj); - if (!(obj->flags & XOTCL_FILTER_ORDER_DEFINED)) - return TCL_OK; + if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + if (!(obj->flags & XOTCL_FILTER_ORDER_DEFINED)) + return TCL_OK; - methodName = ObjStr(objv[1]); - cmdList = obj->filterOrder; + methodName = ObjStr(objv[1]); + + for (cmdList = obj->filterOrder; cmdList; cmdList = cmdList->nextPtr) { + CONST84 char *filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); + if (filterName[0] == methodName[0] && !strcmp(filterName, methodName)) + break; + } - while (cmdList) { - CONST84 char *filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); - if (filterName[0] == methodName[0] && !strcmp(filterName, methodName)) - break; - cmdList = cmdList->nextPtr; - } + if (!cmdList) + return TCL_OK; - if (!cmdList) - return TCL_OK; + fcl = cmdList->clorobj; + if (fcl && XOTclObjectIsClass(&fcl->object)) { + fobj = NULL; + } else { + fobj = (XOTclObject*)fcl; + fcl = NULL; + } - fcl = cmdList->clorobj; - if (fcl && XOTclObjectIsClass(&fcl->object)) { - fobj = 0; - } else { - fobj = (XOTclObject*)fcl; - fcl = 0; - } - - Tcl_SetObjResult(interp, - getFullProcQualifier(interp, methodName, fobj, fcl, - cmdList->cmdPtr)); - return TCL_OK; + Tcl_SetObjResult(interp, + getFullProcQualifier(interp, methodName, fobj, fcl, + cmdList->cmdPtr)); + return TCL_OK; } static int XOTclOProcSearchMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclClass *pcl = NULL; - Tcl_Command cmd = NULL; - char *simpleName, *methodName; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *pcl = NULL; + Tcl_Command cmd = NULL; + char *simpleName, *methodName; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "name"); - Tcl_ResetResult(interp); + Tcl_ResetResult(interp); - methodName = ObjStr(objv[1]); + methodName = ObjStr(objv[1]); - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *mixinList = obj->mixinOrder; - while (mixinList) { - XOTclClass *mcl = XOTclpGetClass(interp, (char *)Tcl_GetCommandName(interp, mixinList->cmdPtr)); - if (mcl && (pcl = SearchCMethod(mcl, methodName, &cmd))) { - break; - } - mixinList = mixinList->nextPtr; - } + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *mixinList; + for (mixinList = obj->mixinOrder; mixinList; mixinList = mixinList->nextPtr) { + XOTclClass *mcl = XOTclpGetClass(interp, (char *)Tcl_GetCommandName(interp, mixinList->cmdPtr)); + if (mcl && (pcl = SearchCMethod(mcl, methodName, &cmd))) { + break; + } } + } - if (!cmd && obj->nsPtr) { - cmd = FindMethod(methodName, obj->nsPtr); - } + if (!cmd && obj->nsPtr) { + cmd = FindMethod(methodName, obj->nsPtr); + } - if (!cmd && obj->cl) - pcl = SearchCMethod(obj->cl, methodName, &cmd); + if (!cmd && obj->cl) + pcl = SearchCMethod(obj->cl, methodName, &cmd); - if (cmd) { - XOTclObject *pobj = pcl ? NULL : obj; - simpleName = (char *)Tcl_GetCommandName(interp, cmd); - Tcl_SetObjResult(interp, getFullProcQualifier(interp, simpleName, pobj, pcl, cmd)); - } - return TCL_OK; + if (cmd) { + XOTclObject *pobj = pcl ? NULL : obj; + simpleName = (char *)Tcl_GetCommandName(interp, cmd); + Tcl_SetObjResult(interp, getFullProcQualifier(interp, simpleName, pobj, pcl, cmd)); + } + return TCL_OK; } static int XOTclORequireNamespaceMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - requireObjNamespace(interp, obj); - return TCL_OK; + requireObjNamespace(interp, obj); + return TCL_OK; } typedef enum {NO_DASH, SKALAR_DASH, LIST_DASH} dashArgType; static dashArgType isDashArg(Tcl_Interp *interp, Tcl_Obj *obj, char **methodName, int *objc, Tcl_Obj **objv[]) { - char *flag; - static Tcl_ObjType *listType = NULL; + char *flag; + static Tcl_ObjType *listType = NULL; - assert(obj); + assert(obj); - /* fetch list type, if not set already; if used on more places, this should - be moved into the interpreter state - */ - if (listType == NULL) { + /* fetch list type, if not set already; if used on more places, this should + be moved into the interpreter state + */ + if (listType == NULL) { #if defined(PRE82) - Tcl_Obj *tmp = Tcl_NewListObj(1, &obj); - listType = tmp->typePtr; - DECR_REF_COUNT(tmp); + Tcl_Obj *tmp = Tcl_NewListObj(1, &obj); + listType = tmp->typePtr; + DECR_REF_COUNT(tmp); #else - static XOTclMutex initMutex = 0; - XOTclMutexLock(&initMutex); - if (listType == NULL) { - listType = Tcl_GetObjType("list"); - /*fprintf(stderr, "fetching listType=%p\n", listType);*/ - } - XOTclMutexUnlock(&initMutex); -#endif + static XOTclMutex initMutex = 0; + XOTclMutexLock(&initMutex); + if (listType == NULL) { + listType = Tcl_GetObjType("list"); + /*fprintf(stderr, "fetching listType=%p\n", listType);*/ } + XOTclMutexUnlock(&initMutex); +#endif + } - if (obj->typePtr == listType) { - if (Tcl_ListObjGetElements(interp, obj, objc, objv) == TCL_OK && *objc>1) { - flag = ObjStr(*objv[0]); - /*fprintf(stderr, "we have a list starting with '%s'\n", flag);*/ - if (*flag == '-') { - *methodName = flag+1; - return LIST_DASH; - } - } - } - flag = ObjStr(obj); - /*fprintf(stderr, "we have a scalar '%s'\n", flag);*/ - if (*flag == '-' && isalpha((int)*((flag)+1))) { + if (obj->typePtr == listType) { + if (Tcl_ListObjGetElements(interp, obj, objc, objv) == TCL_OK && *objc>1) { + flag = ObjStr(*objv[0]); + /*fprintf(stderr, "we have a list starting with '%s'\n", flag);*/ + if (*flag == '-') { *methodName = flag+1; - *objc = 1; - return SKALAR_DASH; + return LIST_DASH; + } } - return NO_DASH; + } + flag = ObjStr(obj); + /*fprintf(stderr, "we have a scalar '%s'\n", flag);*/ + if (*flag == '-' && isalpha((int)*((flag)+1))) { + *methodName = flag+1; + *objc = 1; + return SKALAR_DASH; + } + return NO_DASH; } static int callConfigureMethod(Tcl_Interp *interp, XOTclObject *obj, - char *methodName, int argc, Tcl_Obj *CONST argv[]) { - int result; - Tcl_Obj *method = Tcl_NewStringObj(methodName,-1); + char *methodName, int argc, Tcl_Obj *CONST argv[]) { + int result; + Tcl_Obj *method = Tcl_NewStringObj(methodName,-1); - /*fprintf(stderr,"callConfigureMethod method %s->'%s' argc %d\n", - ObjStr(obj->cmdName), methodName, argc);*/ + /*fprintf(stderr,"callConfigureMethod method %s->'%s' argc %d\n", + ObjStr(obj->cmdName), methodName, argc);*/ - if (isInitString(methodName)) - obj->flags |= XOTCL_INIT_CALLED; + if (isInitString(methodName)) + obj->flags |= XOTCL_INIT_CALLED; - Tcl_ResetResult(interp); - INCR_REF_COUNT(method); - result = callMethod((ClientData)obj, interp, method, argc, argv, XOTCL_CM_NO_UNKNOWN); - DECR_REF_COUNT(method); + Tcl_ResetResult(interp); + INCR_REF_COUNT(method); + result = callMethod((ClientData)obj, interp, method, argc, argv, XOTCL_CM_NO_UNKNOWN); + DECR_REF_COUNT(method); - /*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d %d\n", - methodName, argc+1, obj, result, TCL_ERROR);*/ + /*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d %d\n", + methodName, argc+1, obj, result, TCL_ERROR);*/ - if (result != TCL_OK) { - /* XXXX TODO not sure, if we really need this; see kristoffer lawson mail */ - Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */ - INCR_REF_COUNT(res); - XOTclVarErrMsg(interp, ObjStr(res), " during '", ObjStr(obj->cmdName), " ", - methodName, "'", (char *) NULL); - DECR_REF_COUNT(res); - } + if (result != TCL_OK) { + Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */ + INCR_REF_COUNT(res); + XOTclVarErrMsg(interp, ObjStr(res), " during '", ObjStr(obj->cmdName), " ", + methodName, "'", (char *) NULL); + DECR_REF_COUNT(res); + } - return result; + return result; } static int XOTclOSetvaluesMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - Tcl_Obj **argv, **nextArgv, *resultObj; - int i, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; - char *methodName, *nextMethodName; + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Obj **argv, **nextArgv, *resultObj; + int i, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; + char *methodName, *nextMethodName; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?args?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?args?"); - /* find arguments without leading dash */ - for (i=1; i < objc; i++) { - if ((isdasharg = isDashArg(interp, objv[i], &methodName, &argc, &argv))) - break; - } - normalArgs = i-1; - Tcl_ResetResult(interp); + /* find arguments without leading dash */ + for (i=1; i < objc; i++) { + if ((isdasharg = isDashArg(interp, objv[i], &methodName, &argc, &argv))) + break; + } + normalArgs = i-1; + Tcl_ResetResult(interp); - for( ; i < objc; argc=nextArgc, argv=nextArgv, methodName=nextMethodName) { - Tcl_ResetResult(interp); - switch (isdasharg) { - case SKALAR_DASH: /* argument is a skalar with a leading dash */ - { int j; - for (j = i+1; j < objc; j++, argc++) { - if ((isdasharg = isDashArg(interp, objv[j], &nextMethodName, &nextArgc, &nextArgv))) - break; - } - result = callConfigureMethod(interp, obj, methodName, argc+1, objv+i+1); - if (result != TCL_OK) { - return result; - } - i += argc; - break; - } - case LIST_DASH: /* argument is a list with a leading dash, grouping determined by list */ - { i++; - if (icmdName), - " configure: unexpected argument '", - ObjStr(objv[i]), - "' between parameters", (char *) NULL); - } + /*fprintf(stderr, "setvalues oc=%d, i=%d\n",objc,i);*/ + + for( ; i < objc; argc=nextArgc, argv=nextArgv, methodName=nextMethodName) { + Tcl_ResetResult(interp); + switch (isdasharg) { + case SKALAR_DASH: /* Argument is a skalar with a leading dash */ + { int j; + for (j = i+1; j < objc; j++, argc++) { + if ((isdasharg = isDashArg(interp, objv[j], &nextMethodName, &nextArgc, &nextArgv))) + break; } + result = callConfigureMethod(interp, obj, methodName, argc+1, objv+i+1); + if (result != TCL_OK) { + return result; + } + i += argc; + break; + } + case LIST_DASH: /* Argument is a list with a leading dash, grouping determined by list */ + { i++; + if (icmdName), + " configure: unexpected argument '", + ObjStr(objv[i]), + "' between parameters", (char *) NULL); + } } - - resultObj = Tcl_NewListObj(normalArgs, objv+1); - /*fprintf(stderr,".... setvalues returns %s\n", ObjStr(resultObj));*/ - Tcl_SetObjResult(interp, resultObj); - - return result; + } + resultObj = Tcl_NewListObj(normalArgs, objv+1); + /*fprintf(stderr,".... setvalues returns %s\n", ObjStr(resultObj));*/ + Tcl_SetObjResult(interp, resultObj); + + return result; } static int XOTclOConfigureMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)clientData; - XOTclObjects *slotObjects, *so; - int result; - /* would be nice to do it here instead of setValue - XOTcl_FrameDecls; + XOTclObject *obj = (XOTclObject*)clientData; + XOTclObjects *slotObjects, *so; + int result; + /* would be nice to do it here instead of setValue + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); make instvars of obj accessible */ + XOTcl_PushFrame(interp, obj); make instvars of obj accessible */ - /* - * Search for default values on slots - */ - slotObjects = computeSlotObjects(interp, obj, NULL); - for (so = slotObjects; so; so = so->nextPtr) { - result = setDefaultValue(interp, obj, so->obj); - if (result != TCL_OK) { - goto configure_exit; - } + /* + * Search for default values on slots + */ + slotObjects = computeSlotObjects(interp, obj, NULL); + for (so = slotObjects; so; so = so->nextPtr) { + result = setDefaultValue(interp, obj, so->obj); + if (result != TCL_OK) { + goto configure_exit; } + } - /* - * call configure methods (starting with '-') - */ - result = callMethod((ClientData) obj, interp, - XOTclGlobalObjects[XOTE_SETVALUES], objc+1, objv+1, 0); - if (result != TCL_OK) { - goto configure_exit; - } + /* + * call configure methods (starting with '-') + */ + result = callMethod((ClientData) obj, interp, + XOTclGlobalObjects[XOTE_SETVALUES], objc+1, objv+1, 0); + if (result != TCL_OK) { + goto configure_exit; + } - /* - * Check, if we got the required values - */ - for (so = slotObjects; so; so = so->nextPtr) { - result = checkRequiredValue(interp, obj, so->obj); - if (result != TCL_OK) { - goto configure_exit; - } + /* + * Check, if we got the required values + */ + for (so = slotObjects; so; so = so->nextPtr) { + result = checkRequiredValue(interp, obj, so->obj); + if (result != TCL_OK) { + goto configure_exit; } + } configure_exit: - /*XOTcl_PopFrame(interp, obj);*/ + /*XOTcl_PopFrame(interp, obj);*/ - if (slotObjects) - XOTclObjectListFree(slotObjects); - return result; + if (slotObjects) + XOTclObjectListFree(slotObjects); + return result; } @@ -11172,1091 +11707,1377 @@ static int XOTclCInstDestroyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclObject *delobj; - int rc; + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclObject *delobj; + int rc; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], ""); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], ""); - if (XOTclObjConvertObject(interp, objv[1], &delobj) != TCL_OK) - return XOTclVarErrMsg(interp, "Can't destroy object ", - ObjStr(objv[1]), " that does not exist.", - (char *) NULL); + if (XOTclObjConvertObject(interp, objv[1], &delobj) != TCL_OK) + return XOTclVarErrMsg(interp, "Can't destroy object ", + ObjStr(objv[1]), " that does not exist.", + (char *) NULL); - /* fprintf(stderr,"instdestroy obj=%s, opt=%p\n", ObjStr(delobj->cmdName), delobj->opt);*/ - rc = freeUnsetTraceVariable(interp, delobj); - if (rc != TCL_OK) { - return rc; - } + /* fprintf(stderr,"instdestroy obj=%s, opt=%p\n", ObjStr(delobj->cmdName), delobj->opt);*/ + rc = freeUnsetTraceVariable(interp, delobj); + rc = freeUnsetTraceVariable(interp, delobj); + if (rc != TCL_OK) { + return rc; + } - /* - * latch, and call delete command if not already in progress - */ - delobj->flags |= XOTCL_DESTROY_CALLED; - RUNTIME_STATE(interp)->callIsDestroy = 1; - /*fprintf(stderr,"instDestroy %s : setting callIsDestroy = 1\n", ObjStr(objv[1]));*/ - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != - XOTCL_EXITHANDLER_ON_SOFT_DESTROY) { - CallStackDestroyObject(interp, delobj); - } + /* + * latch, and call delete command if not already in progress + */ + delobj->flags |= XOTCL_DESTROY_CALLED; + RUNTIME_STATE(interp)->callIsDestroy = 1; + /*fprintf(stderr,"instDestroy %s : setting callIsDestroy = 1\n", ObjStr(objv[1]));*/ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != + XOTCL_EXITHANDLER_ON_SOFT_DESTROY) { + CallStackDestroyObject(interp, delobj); + } - return TCL_OK; + return TCL_OK; } static Tcl_Namespace * callingNameSpace(Tcl_Interp *interp) { - Tcl_Namespace *ns = NULL; - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - XOTclCallStackContent *top = cs->top; - XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 0); + Tcl_Namespace *ns = NULL; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *top = cs->top; + XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 0); - /*fprintf(stderr," **** use last invocation csc = %p\n", csc);*/ - if (csc && csc->currentFramePtr) { - /* use the callspace from the last invocation */ - XOTclCallStackContent *called = csccurrentFramePtr) : NULL; - /*fprintf(stderr," **** csc use frame= %p\n", f);*/ + /*fprintf(stderr," **** use last invocation csc = %p\n", csc);*/ + if (csc && csc->currentFramePtr) { + /* use the callspace from the last invocation */ + XOTclCallStackContent *called = csccurrentFramePtr) : NULL; + /*fprintf(stderr," **** csc use frame= %p\n", f);*/ + if (f) { + ns = f->nsPtr; + } else { + Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(csc->currentFramePtr); + ns = Tcl_GetCurrentNamespace(interp); + /* find last incovation outside ::xotcl (for things like relmgr) */ + while (ns == RUNTIME_STATE(interp)->XOTclNS) { if (f) { - ns = f->nsPtr; + ns = f->nsPtr; + f = Tcl_CallFrame_callerPtr(f); } else { - Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(csc->currentFramePtr); - ns = Tcl_GetCurrentNamespace(interp); - /* find last incovation outside ::xotcl (for things like relmgr) */ - while (ns == RUNTIME_STATE(interp)->XOTclNS) { - if (f) { - ns = f->nsPtr; - f = Tcl_CallFrame_callerPtr(f); - } else { - ns = Tcl_GetGlobalNamespace(interp); - } - } - /*fprintf(stderr, "found ns %p '%s'\n", ns, ns?ns->fullName:"NULL");*/ + ns = Tcl_GetGlobalNamespace(interp); } + } + /*fprintf(stderr, "found ns %p '%s'\n", ns, ns?ns->fullName:"NULL");*/ } - if (!ns) { - /* calls on xotcl toplevel */ - XOTclCallStackContent *bot = cs->content + 1; - /*fprintf(stderr, " **** bot=%p diff=%d\n", bot, top-bot);*/ - if (top - bot >= 0 && bot->currentFramePtr) { - /* get calling tcl environment */ - Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(bot->currentFramePtr); - if (f) { - ns = f->nsPtr; - /*fprintf(stderr, "top=%p, bot=%p b->c=%p f=%p ns=%p\n", - top, bot, bot->currentFramePtr, f, ns);*/ - /*fprintf(stderr,"ns from calling tcl environment %p '%s'\n", - ns, ns?ns->fullName : "" );*/ - } else { - /* fprintf(stderr, "nothing found, use ::\n"); */ - ns = Tcl_GetGlobalNamespace(interp); - } - } + } + if (!ns) { + /* calls on xotcl toplevel */ + XOTclCallStackContent *bot = cs->content + 1; + /*fprintf(stderr, " **** bot=%p diff=%d\n", bot, top-bot);*/ + if (top - bot >= 0 && bot->currentFramePtr) { + /* get calling tcl environment */ + Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(bot->currentFramePtr); + if (f) { + ns = f->nsPtr; + /*fprintf(stderr, "top=%p, bot=%p b->c=%p f=%p ns=%p\n", + top, bot, bot->currentFramePtr, f, ns);*/ + /*fprintf(stderr,"ns from calling tcl environment %p '%s'\n", + ns, ns?ns->fullName : "" );*/ + } else { + /* fprintf(stderr, "nothing found, use ::\n"); */ + ns = Tcl_GetGlobalNamespace(interp); + } } + } - /*XOTclCallStackDump(interp);*/ - /*XOTclStackDump(interp);*/ + /*XOTclCallStackDump(interp);*/ + /*XOTclStackDump(interp);*/ - /*fprintf(stderr,"callingNameSpace returns %p %s\n", ns, ns?ns->fullName:"");*/ - return ns; + /*fprintf(stderr,"callingNameSpace returns %p %s\n", ns, ns?ns->fullName:"");*/ + return ns; } static int XOTclCAllocMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclClass *newcl; - XOTclObject *newobj; - int result; + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclClass *newcl; + XOTclObject *newobj; + int result; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); #if 0 - fprintf(stderr, "type(%s)=%p %s %d\n", - ObjStr(objv[1]), objv[1]->typePtr, objv[1]->typePtr? - objv[1]->typePtr->name:"NULL", - XOTclObjConvertObject(interp, objv[1], &newobj) - ); - /* - * if the lookup via GetObject for the object succeeds, - * the object exists already, - * and we do not overwrite it, but re-create it - */ - if (XOTclObjConvertObject(interp, objv[1], &newobj) == TCL_OK) { - fprintf(stderr, "lookup successful\n"); - result = doCleanup(interp, newobj, &cl->object, objc, objv); - } else + fprintf(stderr, "type(%s)=%p %s %d\n", + ObjStr(objv[1]), objv[1]->typePtr, objv[1]->typePtr? + objv[1]->typePtr->name:"NULL", + XOTclObjConvertObject(interp, objv[1], &newobj) + ); + /* + * if the lookup via GetObject for the object succeeds, + * the object exists already, + * and we do not overwrite it, but re-create it + */ + if (XOTclObjConvertObject(interp, objv[1], &newobj) == TCL_OK) { + fprintf(stderr, "lookup successful\n"); + result = doCleanup(interp, newobj, &cl->object, objc, objv); + } else #endif - { - /* - * create a new object from scratch - */ - char *objName = ObjStr(objv[1]); - Tcl_Obj *tmpName = NULL; + { + /* + * create a new object from scratch + */ + char *objName = ObjStr(objv[1]); + Tcl_Obj *tmpName = NULL; + /*fprintf(stderr, " **** 0 '%s' 1 '%s' %d\n",ObjStr(objv[0]),ObjStr(objv[1]),objc);*/ - if (!NSCheckColons(objName, 0)) { - return XOTclVarErrMsg(interp, "Cannot allocate object -- illegal name '", - objName, "'", (char *) NULL); - } + if (!NSCheckColons(objName, 0)) { + return XOTclVarErrMsg(interp, "Cannot allocate object -- illegal name '", + objName, "'", (char *) NULL); + } - if (!isAbsolutePath(objName)) { - /*fprintf(stderr, "CallocMethod\n");*/ - tmpName = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); - /*fprintf(stderr, "NoAbsoluteName for '%s' -> determined = '%s'\n", - objName, ObjStr(tmpName));*/ - objName = ObjStr(tmpName); + if (!isAbsolutePath(objName)) { + /*fprintf(stderr, "CallocMethod\n");*/ + tmpName = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); + /*fprintf(stderr, " **** NoAbsoluteName for '%s' -> determined = '%s'\n", + objName, ObjStr(tmpName));*/ + objName = ObjStr(tmpName); - /*fprintf(stderr," **** name is '%s'\n", objName);*/ - INCR_REF_COUNT(tmpName); - } + INCR_REF_COUNT(tmpName); + } + /*fprintf(stderr," **** name is '%s', isMetaClass => %d\n", objName, IsMetaClass(interp, cl));*/ - if (IsMetaClass(interp, cl)) { - /* - * if the base class is a meta-class, we create a class - */ - newcl = PrimitiveCCreate(interp, objName, cl); - if (newcl == 0) - result = XOTclVarErrMsg(interp, "Class alloc failed for '", objName, - "' (possibly parent namespace does not exist)", - (char *) NULL); - else { - Tcl_SetObjResult(interp, newcl->object.cmdName); - result = TCL_OK; - } - } else { - /* - * if the base class is an ordinary class, we create an object - */ - newobj = PrimitiveOCreate(interp, objName, cl); - if (newobj == 0) - result = XOTclVarErrMsg(interp, "Object alloc failed for '", objName, - "' (possibly parent namespace does not exist)", - (char *) NULL); - else { - result = TCL_OK; - Tcl_SetObjResult(interp, newobj->cmdName); - } - } + if (IsMetaClass(interp, cl)) { + /* + * if the base class is a meta-class, we create a class + */ + newcl = PrimitiveCCreate(interp, objName, cl); + if (newcl == 0) + result = XOTclVarErrMsg(interp, "Class alloc failed for '", objName, + "' (possibly parent namespace does not exist)", + (char *) NULL); + else { + Tcl_SetObjResult(interp, newcl->object.cmdName); + result = TCL_OK; + } + } else { + /* + * if the base class is an ordinary class, we create an object + */ + newobj = PrimitiveOCreate(interp, objName, cl); + if (newobj == 0) + result = XOTclVarErrMsg(interp, "Object alloc failed for '", objName, + "' (possibly parent namespace does not exist)", + (char *) NULL); + else { + result = TCL_OK; + Tcl_SetObjResult(interp, newobj->cmdName); + } + } - if (tmpName) { - DECR_REF_COUNT(tmpName); - } + if (tmpName) { + DECR_REF_COUNT(tmpName); + } - } + } - return result; + return result; } - static int -createMethod(Tcl_Interp *interp, XOTclClass *cl, ClientData data, - int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *newobj = NULL; - Tcl_Obj *nameObj, *tmpObj = NULL; - int result; - char *objName, *specifiedName; +createMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *obj, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *newobj = NULL; + Tcl_Obj *nameObj, *tmpObj = NULL; + int result; + char *objName, *specifiedName; - ALLOC_ON_STACK(Tcl_Obj *, objc, tov); + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); - memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); - specifiedName = objName = ObjStr(objv[1]); - /* - * complete the name if it is not absolute - */ - if (!isAbsolutePath(objName)) { - tmpObj = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); - objName = ObjStr(tmpObj); - /*fprintf(stderr," **** fixed name is '%s'\n", objName);*/ + memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); + specifiedName = objName = ObjStr(objv[1]); + /* + * complete the name if it is not absolute + */ + if (!isAbsolutePath(objName)) { + tmpObj = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); + objName = ObjStr(tmpObj); + /*fprintf(stderr," **** fixed name is '%s'\n", objName);*/ - INCR_REF_COUNT(tmpObj); - tov[1] = tmpObj; - } + INCR_REF_COUNT(tmpObj); + tov[1] = tmpObj; + } - /* - * Check whether we have to call recreate (i.e. when the - * object exists already) - */ - newobj = XOTclpGetObject(interp, objName); + /* + * Check whether we have to call recreate (i.e. when the + * object exists already) + */ + newobj = XOTclpGetObject(interp, objName); - /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p\n", - specifiedName, objName, newobj);*/ + /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p\n", + specifiedName, objName, newobj);*/ - /* don't allow an object to be recreated as a class */ - if (newobj && (!IsMetaClass(interp, cl) || IsMetaClass(interp, newobj->cl))) { - /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", - ObjStr(tov[1]), objc+1);*/ - /* call recreate --> initialization */ - result = callMethod((ClientData) cl, interp, - XOTclGlobalObjects[XOTE_RECREATE], objc+1, tov+1, 0); - if (result != TCL_OK) - goto create_method_exit; + /* don't allow to + - recreate an object as a class, and to + - recreate a class as an object + + In these clases, we use destroy + create instead of recrate. + */ - Tcl_SetObjResult(interp, newobj->cmdName); - nameObj = newobj->cmdName; - objTrace("RECREATE", newobj); + if (newobj && (IsMetaClass(interp, cl) == IsMetaClass(interp, newobj->cl))) { + /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", + ObjStr(tov[1]), objc+1);*/ + /* call recreate --> initialization */ + result = callMethod((ClientData) obj, interp, + XOTclGlobalObjects[XOTE_RECREATE], objc+1, tov+1, 0); + if (result != TCL_OK) + goto create_method_exit; - } else { + Tcl_SetObjResult(interp, newobj->cmdName); + nameObj = newobj->cmdName; + objTrace("RECREATE", newobj); - /* fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/ - result = callMethod((ClientData) cl, interp, - XOTclGlobalObjects[XOTE_ALLOC], objc+1, tov+1, 0); - if (result != TCL_OK) - goto create_method_exit; + } else { - nameObj = Tcl_GetObjResult(interp); - if (XOTclObjConvertObject(interp, nameObj, &newobj) != TCL_OK) { - result = XOTclErrMsg(interp, "couldn't find result of alloc", TCL_STATIC); - goto create_method_exit; - } + /* newobj might exist here, but will be automatically destroyed + by alloc */ + + result = XOTclVarErrMsg(interp, "Cannot create object -- illegal name '", + specifiedName, "'", (char *) NULL); + /* fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/ + result = callMethod((ClientData) obj, interp, + XOTclGlobalObjects[XOTE_ALLOC], objc+1, tov+1, 0); + if (result != TCL_OK) + goto create_method_exit; - /*(void)RemoveInstance(newobj, newobj->cl);*/ /* TODO needed? remove? */ - AddInstance(newobj, cl); - objTrace("CREATE", newobj); + nameObj = Tcl_GetObjResult(interp); + if (XOTclObjConvertObject(interp, nameObj, &newobj) != TCL_OK) { + result = XOTclErrMsg(interp, "couldn't find result of alloc", TCL_STATIC); + goto create_method_exit; + } - if (data) { - XOTclObjectOpt *objopt = XOTclRequireObjectOpt(newobj); - objopt->clientData = data; - } + /*(void)RemoveInstance(newobj, newobj->cl);*/ /* TODO needed? remove? */ + AddInstance(newobj, cl); + objTrace("CREATE", newobj); - /* in case, the object is destroyed during initialization, we incr refcount */ - INCR_REF_COUNT(nameObj); - result = doObjInitialization(interp, newobj, objc, objv); - DECR_REF_COUNT(nameObj); - } + /* in case, the object is destroyed during initialization, we incr refcount */ + INCR_REF_COUNT(nameObj); + result = doObjInitialization(interp, newobj, objc, objv); + DECR_REF_COUNT(nameObj); + } create_method_exit: - /* fprintf(stderr, "create -- end ... %s\n", ObjStr(tov[1]));*/ - if (tmpObj) {DECR_REF_COUNT(tmpObj);} - FREE_ON_STACK(tov); - return result; + /* fprintf(stderr, "create -- end ... %s\n", ObjStr(tov[1]));*/ + if (tmpObj) {DECR_REF_COUNT(tmpObj);} + FREE_ON_STACK(tov); + return result; } static int XOTclCCreateMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclClass *cl = XOTclObjectToClass(clientData); - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { - fprintf(stderr,"### Can't create object %s during shutdown\n", ObjStr(objv[1])); - return TCL_ERROR; - return TCL_OK; /* don't fail, if this happens during destroy, it might be canceled */ - } + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { + fprintf(stderr,"### Can't create object %s during shutdown\n", ObjStr(objv[1])); + return TCL_ERROR; + return TCL_OK; /* don't fail, if this happens during destroy, it might be canceled */ + } - return createMethod(interp, cl, NULL, objc, objv); + return createMethod(interp, cl, &cl->object, objc, objv); } static int XOTclCNewMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclObject *child = NULL; - Tcl_Obj *fullname; - int result, offset = 1, + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclObject *child = NULL; + Tcl_Obj *fullname; + int result, offset = 1, #if REFCOUNTED - isrefcount = 0, + isrefcount = 0, #endif - i, prefixLength; - Tcl_DString dFullname, *dsPtr = &dFullname; - XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; + i, prefixLength; + Tcl_DString dFullname, *dsPtr = &dFullname; + XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 1) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "?-childof obj? ?args?"); + if (objc < 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "[-childof obj] ?args?"); - for (i=1; icmdName), -1); - Tcl_DStringAppend(dsPtr, "::__#", 5); - } else { - Tcl_DStringAppend(dsPtr, "::xotcl::__#", 12); - } - prefixLength = dsPtr->length; + Tcl_DStringInit(dsPtr); + if (child) { + Tcl_DStringAppend(dsPtr, ObjStr(child->cmdName), -1); + Tcl_DStringAppend(dsPtr, "::__#", 5); + } else { + Tcl_DStringAppend(dsPtr, "::xotcl::__#", 12); + } + prefixLength = dsPtr->length; - while (1) { - (void)XOTclStringIncr(iss); - Tcl_DStringAppend(dsPtr, iss->start, iss->length); - if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, 0)) { - break; - } - /* in case the value existed already, reset prefix to the - original length */ - Tcl_DStringSetLength(dsPtr, prefixLength); + while (1) { + (void)XOTclStringIncr(iss); + Tcl_DStringAppend(dsPtr, iss->start, iss->length); + if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, 0)) { + break; } + /* in case the value existed already, reset prefix to the + original length */ + Tcl_DStringSetLength(dsPtr, prefixLength); + } - fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); + fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); - INCR_REF_COUNT(fullname); + INCR_REF_COUNT(fullname); - objc -= offset; - { - ALLOC_ON_STACK(Tcl_Obj *, objc+3, ov); + objc -= offset; + { + ALLOC_ON_STACK(Tcl_Obj*, objc+3, ov); - ov[0] = objv[0]; - ov[1] = XOTclGlobalObjects[XOTE_CREATE]; - ov[2] = fullname; - if (objc >= 1) - memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc); + ov[0] = objv[0]; + ov[1] = XOTclGlobalObjects[XOTE_CREATE]; + ov[2] = fullname; + if (objc >= 1) + memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc); - result = DoDispatch(clientData, interp, objc+3, ov, 0); - FREE_ON_STACK(ov); - } + result = DoDispatch(clientData, interp, objc+3, ov, 0); + FREE_ON_STACK(ov); + } #if REFCOUNTED - if (result == TCL_OK) { - if (isrefcount) { - Tcl_Obj *obj = Tcl_GetObjResult(interp); - XOTclObject *o = (XOTclObject*) obj->internalRep.otherValuePtr; - o->flags |= XOTCL_REFCOUNTED; - o->teardown = in; - DECR_REF_COUNT(obj); - } + if (result == TCL_OK) { + if (isrefcount) { + Tcl_Obj *obj = Tcl_GetObjResult(interp); + XOTclObject *o = (XOTclObject*) obj->internalRep.otherValuePtr; + o->flags |= XOTCL_REFCOUNTED; + o->teardown = in; + DECR_REF_COUNT(obj); } + } #endif - DECR_REF_COUNT(fullname); - Tcl_DStringFree(dsPtr); + DECR_REF_COUNT(fullname); + Tcl_DStringFree(dsPtr); - return result; + return result; } static int XOTclCRecreateMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclObject *newobj; - int result; + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclObject *newobj; + int result; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); - if (XOTclObjConvertObject(interp, objv[1], &newobj) != TCL_OK) - return XOTclVarErrMsg(interp, "can't recreate not existing obj ", - ObjStr(objv[1]), (char *) NULL); + if (XOTclObjConvertObject(interp, objv[1], &newobj) != TCL_OK) + return XOTclVarErrMsg(interp, "can't recreate not existing obj ", + ObjStr(objv[1]), (char *) NULL); - INCR_REF_COUNT(objv[1]); - newobj->flags |= XOTCL_RECREATE; + INCR_REF_COUNT(objv[1]); + newobj->flags |= XOTCL_RECREATE; - result = doCleanup(interp, newobj, &cl->object, objc, objv); - if (result == TCL_OK) { - result = doObjInitialization(interp, newobj, objc, objv); - if (result == TCL_OK) - Tcl_SetObjResult(interp, objv[1]); - } - DECR_REF_COUNT(objv[1]); - return result; + result = doCleanup(interp, newobj, &cl->object, objc, objv); + if (result == TCL_OK) { + result = doObjInitialization(interp, newobj, objc, objv); + if (result == TCL_OK) + Tcl_SetObjResult(interp, objv[1]); + } + DECR_REF_COUNT(objv[1]); + return result; } static int -XOTclClassInfoHeritageMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; +XOTclClassInfoHeritageMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { + XOTclClass *cl; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - return ListHeritage(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); + return ListHeritage(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); } static int +getModifiers(int objc, int offset, Tcl_Obj *CONST objv[], CONST char *options[], int *set) { + int i, j, found, count = 0; + char *to; + + *set = 0; + for (i = offset; i < objc; i++) { + to = ObjStr(objv[i]); + if (to[0] == '-') { + found = 0; + for (j=0; options[j]; j++) { + if (strcmp(to,options[j]) == 0) { + count++; + *set |= 1 << j; + found = 1; + } + } + /* if we find a modifier that was not given, stop processing */ + if (!found) break; + /* '--' stops modifiers */ + if (to[1] == '-') break; + } + } + return count; +} + +static int XOTclClassInfoInstancesMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; + XOTclClass *cl; + int modifiers, args, set, rc; + char *pattern; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; + static CONST char *options[] = {"-closure", NULL}; + int withClosure; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + /* todo: test and use getModifieres everywhere */ + modifiers = getModifiers(objc, 2, objv, options, &set); + args = objc-modifiers; + + if (args < 2 || args > 3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-closure? ?pattern?"); + + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + pattern = args == 3 ? ObjStr(objv[objc-modifiers-1]) : NULL; + if (modifiers>0) { + withClosure = 1; + } + + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } - return ListObjPtrHashTable(interp, &cl->instances, objc == 3 ? ObjStr(objv[2]) : NULL); + rc = listInstances(interp, cl, pattern, withClosure, matchObject); + + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); + return TCL_OK; } static int XOTclClassInfoInstargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - Tcl_Namespace *nsp; + XOTclClass *cl; + Tcl_Namespace *nsp; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListArgsFromOrdinaryArgs(interp, nonposArgs); - } + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); } - nsp = cl->nsPtr; - return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])); + } + nsp = cl->nsPtr; + return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])); } static int XOTclClassInfoInstbodyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - Tcl_Namespace *nsp; + XOTclClass *cl; + Tcl_Namespace *nsp; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - nsp = cl->nsPtr; - return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])); + nsp = cl->nsPtr; + return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])); } static int XOTclClassInfoInstcommandsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - Tcl_Namespace *nsp; + XOTclClass *cl; + Tcl_Namespace *nsp; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - nsp = cl->nsPtr; - return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), objc == 3 ? ObjStr(objv[2]) : NULL); + nsp = cl->nsPtr; + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), objc == 3 ? ObjStr(objv[2]) : NULL); } static int XOTclClassInfoInstdefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - Tcl_Namespace *nsp; + XOTclClass *cl; + Tcl_Namespace *nsp; - if (objc != 5) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 5) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListDefaultFromOrdinaryArgs(interp, ObjStr(objv[2]), nonposArgs, ObjStr(objv[3]), objv[4]); - } + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListDefaultFromOrdinaryArgs(interp, ObjStr(objv[2]), nonposArgs, ObjStr(objv[3]), objv[4]); } - nsp = cl->nsPtr; - return nsp ? - ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2]), ObjStr(objv[3]), objv[4]) : - TCL_OK; + } + nsp = cl->nsPtr; + return nsp ? + ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2]), ObjStr(objv[3]), objv[4]) : + TCL_OK; } static int XOTclClassInfoInstfilterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; - int idx, nobjc, withGuards = 0; - static CONST char *options[] = {"-guards", NULL}; - enum options {guardsIdx}; + XOTclClass *cl; + XOTclClassOpt *opt; + int idx, nobjc, withGuards = 0; + static CONST char *options[] = {"-guards", NULL}; + enum options {guardsIdx}; - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - for (idx = 2; idx < objc; idx++) { - char *name; - int index; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - name = Tcl_GetString(objv[idx]); - if (name[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum options) index) { - case guardsIdx: withGuards = 1; break; - } + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; } - nobjc = objc - idx; + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + } + } + nobjc = objc - idx; - if (objc < 2 || nobjc > 1 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards? ?pattern?"); + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards? ?pattern?"); - opt = cl->opt; - return opt ? FilterInfo(interp, opt->instfilters, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 0) : TCL_OK; + opt = cl->opt; + return opt ? FilterInfo(interp, opt->instfilters, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 0) : TCL_OK; } static int XOTclClassInfoInstfilterguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; + XOTclClass *cl; + XOTclClassOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " filter"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " filter"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - opt = cl->opt; - return opt ? GuardList(interp, opt->instfilters, ObjStr(objv[2])) : TCL_OK; + opt = cl->opt; + return opt ? GuardList(interp, opt->instfilters, ObjStr(objv[2])) : TCL_OK; } static int XOTclClassInfoInstforwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - Tcl_Namespace *nsp; - int withDefinition = 0; - char *name = NULL; + XOTclClass *cl; + Tcl_Namespace *nsp; + int withDefinition = 0; + char *name = NULL; - if (objc < 2 || objc > 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-definition? ?name?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc < 2 || objc > 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-definition? ?name?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - if (objc > 2) { - name = ObjStr(objv[2]); - if (*name == '-' && !strcmp("-definition", name)) { - withDefinition = 1; - name = ObjStr(objv[3]); - } + if (objc > 2) { + name = ObjStr(objv[2]); + if (*name == '-' && !strcmp("-definition", name)) { + withDefinition = 1; + name = ObjStr(objv[3]); } + } - nsp = cl->nsPtr; - return forwardList(interp, Tcl_Namespace_cmdTable(cl->nsPtr), name, withDefinition); + nsp = cl->nsPtr; + return forwardList(interp, Tcl_Namespace_cmdTable(cl->nsPtr), name, withDefinition); } static int XOTclClassInfoInstinvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; + XOTclClass *cl; + XOTclClassOpt *opt; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - opt = cl->opt; - if (opt && opt->assertions) { - Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); - } + opt = cl->opt; + if (opt && opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); + } - return TCL_OK; + return TCL_OK; } static int XOTclClassInfoInstmixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; - int idx, nobjc, withGuards = 0; - static CONST char *options[] = {"-guards", NULL}; - enum options {guardsIdx}; + XOTclClass *cl; + XOTclClassOpt *opt; + int idx, nobjc, withGuards = 0, rc; + static CONST char *options[] = {"-guards", NULL}; + enum options {guardsIdx}; + char *pattern; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - for (idx = 2; idx < objc; idx++) { - char *name; - int index; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - name = Tcl_GetString(objv[idx]); - if (name[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum options) index) { - case guardsIdx: withGuards = 1; break; - } + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; } - nobjc = objc-idx; + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + } + } + nobjc = objc-idx; - if (objc < 2 || nobjc > 1 || objc > 4) - return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards? ?pattern?"); + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards? ?pattern?"); - opt = cl->opt; - return opt ? MixinInfo(interp, opt->instmixins, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards) : TCL_OK; + opt = cl->opt; + pattern = idx < objc ? ObjStr(objv[idx]) : NULL; + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + rc = opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards, matchObject) : TCL_OK; + DSTRING_FREE(dsPtr); + return rc; } static int XOTclClassInfoInstmixinguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; + XOTclClass *cl; + XOTclClassOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " mixin"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " mixin"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - opt = cl->opt; - return opt ? GuardList(interp, opt->instmixins, ObjStr(objv[2])) : TCL_OK; + opt = cl->opt; + return opt ? GuardList(interp, opt->instmixins, ObjStr(objv[2])) : TCL_OK; } static int XOTclClassInfoInstnonposargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; + XOTclClass *cl; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); - if (nonposArgs) { - Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); - } + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); } - return TCL_OK; + } + return TCL_OK; } static int XOTclClassInfoInstprocsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; + XOTclClass *cl; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(cl->nsPtr), - objc == 3 ? ObjStr(objv[2]) : NULL, - /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0 ); + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(cl->nsPtr), + objc == 3 ? ObjStr(objv[2]) : NULL, + /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0, 0 ); } static int XOTclClassInfoInstpreMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; + XOTclClass *cl; + XOTclClassOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], ""); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - opt = cl->opt; - if (opt) { - XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); - } - return TCL_OK; + opt = cl->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + } + return TCL_OK; } static int XOTclClassInfoInstpostMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; + XOTclClass *cl; + XOTclClassOpt *opt; - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - opt = cl->opt; - if (opt) { - XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); - } - return TCL_OK; + opt = cl->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; } static int XOTclClassInfoParameterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_DString ds, *dsPtr = &ds; - XOTclClass *cl; - XOTclObject *o; + Tcl_DString ds, *dsPtr = &ds; + XOTclClass *cl; + XOTclObject *o; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { - Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); - Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, - interp, varNameObj, NULL, - TCL_LEAVE_ERR_MSG); - if (parameters) { - Tcl_SetObjResult(interp, parameters); - } - DECR_REF_COUNT(varNameObj); - } - DSTRING_FREE(dsPtr); - return TCL_OK; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); + Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, + interp, varNameObj, NULL, + TCL_LEAVE_ERR_MSG); + if (parameters) { + Tcl_SetObjResult(interp, parameters); + } + DECR_REF_COUNT(varNameObj); + } + DSTRING_FREE(dsPtr); + return TCL_OK; } static int XOTclClassInfoSuperclassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; + XOTclClass *cl; + int modifiers, args, set; + char *pattern; + static CONST char *options[] = {"-closure", NULL}; + int withClosure = 0; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + /* todo: test and use getModifieres everywhere */ + modifiers = getModifiers(objc, 2, objv, options, &set); + args = objc-modifiers; - return ListSuperclasses(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); + if (args < 2 || args > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + pattern = args == 3 ? ObjStr(objv[objc-modifiers-1]) : NULL; + if (modifiers>0) { + withClosure = 1; + } + return ListSuperclasses(interp, cl, pattern, withClosure); } + static int XOTclClassInfoSubclassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; + XOTclClass *cl; + int withClosure = 0, rc, modifiers, args, set; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; + char *pattern; + static CONST char *options[] = {"-closure", NULL}; + enum options {closureIdx}; - if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + /* todo: test and use getModifieres everywhere */ + modifiers = getModifiers(objc, 2, objv, options, &set); + args = objc-modifiers; - return ListSubclasses(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); + if (args < 2 || args > 3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-closure? ?pattern?"); + + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + /* We have only one modifier, so it must be closure; if there would + be multiple modifieres would have to check the resulting "set" */ + withClosure = modifiers > 0; + pattern = args == 3 ? ObjStr(objv[3+modifiers]) : NULL; + + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + + if (withClosure) { + XOTclClasses *saved = cl->order, *subclasses; + cl->order = NULL; + subclasses = ComputeOrder(cl, cl->order, Sub); + cl->order = saved; + if (subclasses) subclasses=subclasses->nextPtr; + rc = AppendMatchingElementsFromClasses(interp, subclasses, pattern, matchObject); + XOTclClassListFree(subclasses); + } else { + rc = AppendMatchingElementsFromClasses(interp, cl->sub, pattern, matchObject); + } + + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + + DSTRING_FREE(dsPtr); + return TCL_OK; } static int XOTclClassInfoSlotsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_DString ds, *dsPtr = &ds; - XOTclClass *cl; - XOTclObject *o; - int rc; + Tcl_DString ds, *dsPtr = &ds; + XOTclClass *cl; + XOTclObject *o; + int rc; - if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); + if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { - rc = ListChildren(interp, o, NULL, 0); - } else { - rc = TCL_OK; - } - DSTRING_FREE(dsPtr); - return rc; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + rc = ListChildren(interp, o, NULL, 0); + } else { + rc = TCL_OK; + } + DSTRING_FREE(dsPtr); + return rc; } static int XOTclCInfoMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - Tcl_Namespace *nsp; - XOTclClassOpt *opt; - char *pattern, *cmd; - int modifiers = 0; + XOTclClass *cl = XOTclObjectToClass(clientData); + Tcl_Namespace *nsp; + XOTclClassOpt *opt; + char *pattern, *cmd; + int modifiers = 0; - if (objc < 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); - if (cl) { - nsp = cl->nsPtr; - opt = cl->opt; + if (cl) { + nsp = cl->nsPtr; + opt = cl->opt; - cmd = ObjStr(objv[1]); - pattern = (objc > 2) ? ObjStr(objv[2]) : 0; + cmd = ObjStr(objv[1]); + pattern = (objc > 2) ? ObjStr(objv[2]) : NULL; - /* - * check for "-" modifiers - */ - if (pattern && *pattern == '-') { - modifiers = countModifiers(objc, objv); - pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; - } + /* + * check for "-" modifiers + */ + if (pattern && *pattern == '-') { + modifiers = countModifiers(objc, objv); + pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; + } - switch (*cmd) { - case 'c': - if (!strcmp(cmd, "classchildren")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "classchildren ?pat?"); - return ListChildren(interp, (XOTclObject*) cl, pattern, 1); - } else if (!strcmp(cmd, "classparent")) { - if (objc > 2 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "classparent"); - return ListParent(interp, &cl->object); - } - break; + switch (*cmd) { + case 'c': + if (!strcmp(cmd, "classchildren")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "classchildren ?pattern?"); + return ListChildren(interp, (XOTclObject*) cl, pattern, 1); + } else if (!strcmp(cmd, "classparent")) { + if (objc > 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "classparent"); + return ListParent(interp, &cl->object); + } + break; - case 'h': - if (!strcmp(cmd, "heritage")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "heritage ?pat?"); - return ListHeritage(interp, cl, pattern); + case 'h': + if (!strcmp(cmd, "heritage")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "heritage ?pattern?"); + return ListHeritage(interp, cl, pattern); + } + break; + + case 'i': + if (cmd[1] == 'n' && cmd[2] == 's' && cmd[3] == 't') { + char *cmdTail = cmd + 4; + switch (*cmdTail) { + case 'a': + if (!strcmp(cmdTail, "ances")) { + int withClosure = 0; + + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instances ?-closure? ?pattern?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, objv[0], "instances: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); } - break; + return ListSuperclasses(interp, cl, pattern, withClosure); - case 'i': - if (cmd[1] == 'n' && cmd[2] == 's' && cmd[3] == 't') { - char *cmdTail = cmd + 4; - switch (*cmdTail) { - case 'a': - if (!strcmp(cmdTail, "ances")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "instances ?pat?"); - return ListObjPtrHashTable(interp, &cl->instances, pattern); - } else if (!strcmp(cmdTail, "args")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instargs "); - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = - NonposArgsGet(cl->nonposArgsTable, pattern); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListArgsFromOrdinaryArgs(interp, nonposArgs); - } - } - return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern); - } - break; + } else if (!strcmp(cmdTail, "args")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instargs "); + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(cl->nonposArgsTable, pattern); + if (nonposArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); + } + } + return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern); + } + break; - case 'b': - if (!strcmp(cmdTail, "body")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instbody "); - return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern); - } - break; + case 'b': + if (!strcmp(cmdTail, "body")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instbody "); + return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern); + } + break; - case 'c': - if (!strcmp(cmdTail, "commands")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instcommands ?pat?"); - return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); - } - break; + case 'c': + if (!strcmp(cmdTail, "commands")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instcommands ?pattern?"); + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); + } + break; - case 'd': - if (!strcmp(cmdTail, "default")) { - if (objc != 5 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instdefault "); + case 'd': + if (!strcmp(cmdTail, "default")) { + if (objc != 5 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instdefault "); - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = - NonposArgsGet(cl->nonposArgsTable, pattern); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs, - ObjStr(objv[3]), objv[4]); - } - } - return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern, - ObjStr(objv[3]), objv[4]); - } - break; + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(cl->nonposArgsTable, pattern); + if (nonposArgs) { + return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs, + ObjStr(objv[3]), objv[4]); + } + } + return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern, + ObjStr(objv[3]), objv[4]); + } + break; - case 'f': - if (!strcmp(cmdTail, "filter")) { - int withGuards = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instfilter ?-guards? ?pat?"); - if (modifiers > 0) { - withGuards = checkForModifier(objv, modifiers, "-guards"); - if (withGuards == 0) - return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ", - ObjStr(objv[2]), (char *) NULL); - } - return opt ? FilterInfo(interp, opt->instfilters, pattern, withGuards, 0) : TCL_OK; + case 'f': + if (!strcmp(cmdTail, "filter")) { + int withGuards = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instfilter ?-guards? ?pattern?"); + if (modifiers > 0) { + withGuards = checkForModifier(objv, modifiers, "-guards"); + if (withGuards == 0) + return XOTclVarErrMsg(interp, objv[0], "instfilter: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + return opt ? FilterInfo(interp, opt->instfilters, pattern, withGuards, 0) : TCL_OK; - } else if (!strcmp(cmdTail, "filterguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instfilterguard filter"); - return opt ? GuardList(interp, opt->instfilters, pattern) : TCL_OK; - } else if (!strcmp(cmdTail, "forward")) { - int argc = objc-modifiers; - int definition; - if (argc < 2 || argc > 3) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instforward ?-definition? ?name?"); - definition = checkForModifier(objv, modifiers, "-definition"); - if (nsp) - return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition); - else - return TCL_OK; - } - break; + } else if (!strcmp(cmdTail, "filterguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instfilterguard filter"); + return opt ? GuardList(interp, opt->instfilters, pattern) : TCL_OK; + } else if (!strcmp(cmdTail, "forward")) { + int argc = objc-modifiers; + int definition; + if (argc < 2 || argc > 3) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instforward ?-definition? ?name?"); + definition = checkForModifier(objv, modifiers, "-definition"); + if (definition && argc < 3) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instforward ?-definition? ?name?"); + if (nsp) { + return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition); + } else { + return TCL_OK; + } + } + break; - case 'i': - if (!strcmp(cmdTail, "invar")) { - XOTclAssertionStore *assertions = opt ? opt->assertions : 0; - if (objc != 2 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instinvar"); - - if (assertions && assertions->invariants) - Tcl_SetObjResult(interp, AssertionList(interp, assertions->invariants)); - return TCL_OK; - } - break; - - case 'm': - if (!strcmp(cmdTail, "mixin")) { - int withGuards = 0; - - if (objc-modifiers > 3 || modifiers > 1) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instmixin ?-guards? ?class?"); - if (modifiers > 0) { - withGuards = checkForModifier(objv, modifiers, "-guards"); - if (withGuards == 0) - return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ", - ObjStr(objv[2]), (char *) NULL); - } - return opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards) : TCL_OK; - - } else if (!strcmp(cmdTail, "mixinof")) { - /* TODO: make a method out of me */ - if (objc-modifiers > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instmixinof ?class?"); - return opt ? MixinOfInfo(interp, opt->instmixinofs, pattern) : TCL_OK; + case 'i': + if (!strcmp(cmdTail, "invar")) { + XOTclAssertionStore *assertions = opt ? opt->assertions : 0; + if (objc != 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instinvar"); + + if (assertions && assertions->invariants) + Tcl_SetObjResult(interp, AssertionList(interp, assertions->invariants)); + return TCL_OK; + } + break; + + case 'm': + if (!strcmp(cmdTail, "mixin")) { + int withClosure = 0, withGuards = 0, rc; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; - } else if (!strcmp(cmdTail, "mixinguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instmixinguard mixin"); - return opt ? GuardList(interp, opt->instmixins, pattern) : TCL_OK; - } - break; - - case 'n': - if (!strcmp(cmdTail, "nonposargs")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instnonposargs "); - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = - NonposArgsGet(cl->nonposArgsTable, pattern); - if (nonposArgs) { - Tcl_SetObjResult(interp, NonposArgsFormat(interp, - nonposArgs->nonposArgs)); - } - } - return TCL_OK; - } - break; - - case 'p': - if (!strcmp(cmdTail, "procs")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instprocs ?pat?"); - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, - /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0); - } else if (!strcmp(cmdTail, "pre")) { - XOTclProcAssertion *procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instpre "); - if (opt && opt->assertions) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); - } - return TCL_OK; - } else if (!strcmp(cmdTail, "post")) { - XOTclProcAssertion *procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "instpost "); - if (opt && opt->assertions) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); - } - return TCL_OK; - } - break; + if (objc-modifiers > 3 || modifiers > 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instmixin ?-closure? ?-guards? ?pattern?"); + if (modifiers > 0) { + withGuards = checkForModifier(objv, modifiers, "-guards"); + withClosure = checkForModifier(objv, modifiers, "-closure"); + if ((withGuards == 0) && (withClosure == 0)) + return XOTclVarErrMsg(interp, objv[0], "instfilter: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + + if ((opt) || (withClosure)) { + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllClassMixins(interp, commandTable, cl, withGuards, pattern, matchObject); + if (matchObject && rc && !withGuards) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); } + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } else { + rc = opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards, matchObject) : TCL_OK; + } + DSTRING_FREE(dsPtr); + } + return TCL_OK; + + } else if (!strcmp(cmdTail, "mixinof")) { + int withClosure = 0, rc; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; + + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instmixinof ?-closure? ?class?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, objv[0], "instmixinof: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); } - break; - case 'm': - if (!strcmp(cmd, "mixinof")) { - /* TODO: make a method out of me */ - if (objc-modifiers > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "mixinof ?object?"); - return opt ? MixinOfInfo(interp, opt->mixinofs, pattern) : TCL_OK; + if (opt) { + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllClassMixinsOf(interp, commandTable, cl, 0, 1, pattern, matchObject); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } else { + rc = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf, + pattern, matchObject); + } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); } - break; + return TCL_OK; + } else if (!strcmp(cmdTail, "mixinguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instmixinguard mixin"); + return opt ? GuardList(interp, opt->instmixins, pattern) : TCL_OK; + } + break; + + case 'n': + if (!strcmp(cmdTail, "nonposargs")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instnonposargs "); + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(cl->nonposArgsTable, pattern); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, + nonposArgs->nonposArgs)); + } + } + return TCL_OK; + } + break; + case 'p': - if (!strcmp(cmd, "parameter")) { + if (!strcmp(cmdTail, "procs")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "instprocs ?pattern?"); + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, + /*noProcs*/ 0, /*noCmds*/ 1, /* dups */ NULL, 0, 0); + } else if (!strcmp(cmdTail, "pre")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instpre "); + if (opt && opt->assertions) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + } + return TCL_OK; + } else if (!strcmp(cmdTail, "post")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instpost "); + if (opt && opt->assertions) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; + } else if (!strcmp(cmdTail, "parametercmd")) { + int argc = objc-modifiers; + if (argc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "instparametercmd ?pattern?"); + if (nsp) { + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, 1, 0, 0, 0, 1); + } else { + return TCL_OK; + } + } + break; + } + } + break; - Tcl_DString ds, *dsPtr = &ds; - XOTclObject *o; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { - Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); - Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, - interp, varNameObj, NULL, - TCL_LEAVE_ERR_MSG); - if (parameters) { - Tcl_SetObjResult(interp, parameters); - } else { - fprintf(stderr, "info parameters: No value for %s\n", - Tcl_DStringValue(dsPtr)); - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - } - DECR_REF_COUNT(varNameObj); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - } - DSTRING_FREE(dsPtr); + case 'm': + if (!strcmp(cmd, "mixinof")) { + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; + int rc, withClosure = 0; + + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "mixinof ?-closure? ?pattern?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, objv[0], "mixinof: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + if (opt && !withClosure) { + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + + rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, pattern, matchObject); + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); + } else if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllObjectMixinsOf(interp, commandTable, cl, 0, 1, pattern, matchObject); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } + return TCL_OK; + } + break; + + case 'p': + if (!strcmp(cmd, "parameter")) { + + Tcl_DString ds, *dsPtr = &ds; + XOTclObject *o; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); + Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, + interp, varNameObj, NULL, + TCL_LEAVE_ERR_MSG); + if (parameters) { + Tcl_SetObjResult(interp, parameters); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } + DECR_REF_COUNT(varNameObj); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); #if 0 - if (cl->parameters) { - Tcl_SetObjResult(interp, cl->parameters); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - } + if (cl->parameters) { + Tcl_SetObjResult(interp, cl->parameters); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } #endif - return TCL_OK; - } - break; + return TCL_OK; + } + break; - case 's': - if (!strcmp(cmd, "superclass")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "superclass ?class?"); - return ListSuperclasses(interp, cl, pattern); - } else if (!strcmp(cmd, "subclass")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "subclass ?class?"); - return ListSubclasses(interp, cl, pattern); - } else if (!strcmp(cmd, "slots")) { - Tcl_DString ds, *dsPtr = &ds; - XOTclObject *o; - int rc; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { - rc = ListChildren(interp, o, NULL, 0); - } else { - rc = TCL_OK; - } - DSTRING_FREE(dsPtr); - return rc; - } - break; + case 's': + if (!strcmp(cmd, "superclass")) { + int withClosure = 0, rc; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; + + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "superclass ?-closure? ?pattern?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, objv[0], "superclass: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); } + + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + + if (withClosure) { + XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); + if (pl) pl=pl->nextPtr; + rc = AppendMatchingElementsFromClasses(interp, pl, pattern, matchObject); + } else { + XOTclClasses *clSuper = XOTclReverseClasses(cl->super); + rc = AppendMatchingElementsFromClasses(interp, clSuper, pattern, matchObject); + XOTclClassListFree(clSuper); + } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); + return TCL_OK; + + } else if (!strcmp(cmd, "subclass")) { + int withClosure = 0, rc; + XOTclObject *matchObject; + Tcl_DString ds, *dsPtr = &ds; + + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, + objv[0], "subclass ?-closure? ?pattern?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, objv[0], "subclass: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + + if (withClosure) { + XOTclClasses *saved = cl->order, *subclasses; + cl->order = NULL; + subclasses = ComputeOrder(cl, cl->order, Sub); + cl->order = saved; + if (subclasses) subclasses=subclasses->nextPtr; + rc = AppendMatchingElementsFromClasses(interp, subclasses, pattern, matchObject); + XOTclClassListFree(subclasses); + } else { + rc = AppendMatchingElementsFromClasses(interp, cl->sub, pattern, matchObject); + } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); + return TCL_OK; + + } else if (!strcmp(cmd, "slots")) { + Tcl_DString ds, *dsPtr = &ds; + XOTclObject *o; + int rc; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + rc = ListChildren(interp, o, NULL, 0); + } else { + rc = TCL_OK; + } + DSTRING_FREE(dsPtr); + return rc; + } + break; } + } - return XOTclOInfoMethod(clientData, interp, objc, (Tcl_Obj **)objv); + return XOTclOInfoMethod(clientData, interp, objc, (Tcl_Obj **)objv); } static int XOTclCInstParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { + int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(clientData); if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); @@ -12268,7 +13089,7 @@ static int XOTclCParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { + int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*) clientData; if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "name"); @@ -12278,1472 +13099,1503 @@ } static void forwardCmdDeleteProc(ClientData clientData) { - forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; - if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} - if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);} - if (tcd->onerror) {DECR_REF_COUNT(tcd->onerror);} - if (tcd->prefix) {DECR_REF_COUNT(tcd->prefix);} - if (tcd->args) {DECR_REF_COUNT(tcd->args);} - FREE(forwardCmdClientData, tcd); + forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} + if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);} + if (tcd->onerror) {DECR_REF_COUNT(tcd->onerror);} + if (tcd->prefix) {DECR_REF_COUNT(tcd->prefix);} + if (tcd->args) {DECR_REF_COUNT(tcd->args);} + FREE(forwardCmdClientData, tcd); } static int -forwardProcessOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - forwardCmdClientData **tcdp) { - forwardCmdClientData *tcd; - int i, rc = 0, earlybinding = 0; +forwardProcessOptions(Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[], + forwardCmdClientData **tcdp) { + forwardCmdClientData *tcd; + int i, rc = 0, earlybinding = 0; - tcd = NEW(forwardCmdClientData); - memset(tcd, 0, sizeof(forwardCmdClientData)); + tcd = NEW(forwardCmdClientData); + memset(tcd, 0, sizeof(forwardCmdClientData)); - for (i=2; isubcommands = objv[i+1]; - rc = Tcl_ListObjLength(interp, objv[i+1],&tcd->nr_subcommands); - if (rc != TCL_OK) break; - INCR_REF_COUNT(tcd->subcommands); - i++; - } else if (!strcmp(ObjStr(objv[i]),"-methodprefix")) { - if (objc <= i+1) {rc = TCL_ERROR; break;} - tcd->prefix = objv[i+1]; - INCR_REF_COUNT(tcd->prefix); - i++; - } else if (!strcmp(ObjStr(objv[i]),"-onerror")) { - if (objc <= i+1) {rc = TCL_ERROR; break;} - tcd->onerror = objv[i+1]; - INCR_REF_COUNT(tcd->onerror); - i++; - } else if (!strcmp(ObjStr(objv[i]),"-objscope")) { - tcd->objscope = 1; - } else if (!strcmp(ObjStr(objv[i]),"-earlybinding")) { - earlybinding = 1; - } else if (!strcmp(ObjStr(objv[i]),"-verbose")) { - tcd->verbose = 1; - } else { - /* todo protected */ - break; - } + for (i=2; isubcommands = objv[i+1]; + rc = Tcl_ListObjLength(interp, objv[i+1],&tcd->nr_subcommands); + if (rc != TCL_OK) break; + INCR_REF_COUNT(tcd->subcommands); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-methodprefix")) { + if (objc <= i+1) {rc = TCL_ERROR; break;} + tcd->prefix = objv[i+1]; + INCR_REF_COUNT(tcd->prefix); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-onerror")) { + if (objc <= i+1) {rc = TCL_ERROR; break;} + tcd->onerror = objv[i+1]; + INCR_REF_COUNT(tcd->onerror); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-objscope")) { + tcd->objscope = 1; + } else if (!strcmp(ObjStr(objv[i]),"-earlybinding")) { + earlybinding = 1; + } else if (!strcmp(ObjStr(objv[i]),"-verbose")) { + tcd->verbose = 1; + } else { + /* todo protected */ + break; } + } - tcd->needobjmap = 0; - for (; ineedobjmap |= (*element == '%' && *(element+1) == '@'); + tcd->needobjmap = 0; + for (; ineedobjmap |= (*element == '%' && *(element+1) == '@'); - if (tcd->cmdName == 0) { - tcd->cmdName = objv[i]; - } else if (tcd->args == 0) { - tcd->args = Tcl_NewListObj(1, &objv[i]); - tcd->nr_args++; - INCR_REF_COUNT(tcd->args); - } else { - Tcl_ListObjAppendElement(interp, tcd->args, objv[i]); - tcd->nr_args++; - } + if (tcd->cmdName == NULL) { + tcd->cmdName = objv[i]; + } else if (tcd->args == NULL) { + tcd->args = Tcl_NewListObj(1, &objv[i]); + tcd->nr_args++; + INCR_REF_COUNT(tcd->args); + } else { + Tcl_ListObjAppendElement(interp, tcd->args, objv[i]); + tcd->nr_args++; } + } - if (!tcd->cmdName) { - tcd->cmdName = objv[1]; - } + if (!tcd->cmdName) { + tcd->cmdName = objv[1]; + } - if (tcd->objscope) { - /* when we evaluating objscope, and define ... - o forward append -objscope append - a call to - o append ... - would lead to a recursive call; so we add the appropriate namespace - */ - char *name = ObjStr(tcd->cmdName); - if (!isAbsolutePath(name)) { - tcd->cmdName = NameInNamespaceObj(interp, name, callingNameSpace(interp)); - /*fprintf(stderr,"name %s not absolute, therefore qualifying %s\n", name, - ObjStr(tcd->cmdName));*/ - } + if (tcd->objscope) { + /* when we evaluating objscope, and define ... + o forward append -objscope append + a call to + o append ... + would lead to a recursive call; so we add the appropriate namespace + */ + char *name = ObjStr(tcd->cmdName); + if (!isAbsolutePath(name)) { + tcd->cmdName = NameInNamespaceObj(interp, name, callingNameSpace(interp)); + /*fprintf(stderr,"name %s not absolute, therefore qualifying %s\n", name, + ObjStr(tcd->cmdName));*/ } - INCR_REF_COUNT(tcd->cmdName); + } + INCR_REF_COUNT(tcd->cmdName); - if (earlybinding) { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName); - if (cmd == NULL) - return XOTclVarErrMsg(interp, "cannot lookup command '", ObjStr(tcd->cmdName), "'", (char *) NULL); + if (earlybinding) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName); + if (cmd == NULL) + return XOTclVarErrMsg(interp, "cannot lookup command '", ObjStr(tcd->cmdName), "'", (char *) NULL); - tcd->objProc = Tcl_Command_objProc(cmd); - if (tcd->objProc == XOTclObjDispatch /* don't do direct invoke on xotcl objects */ - || tcd->objProc == TclObjInterpProc /* don't do direct invoke on tcl procs */ - ) { - /* silently ignore earlybinding flag */ - tcd->objProc = NULL; - } else { - tcd->clientData = Tcl_Command_objClientData(cmd); - } + tcd->objProc = Tcl_Command_objProc(cmd); + if (tcd->objProc == XOTclObjDispatch /* don't do direct invoke on xotcl objects */ + || tcd->objProc == TclObjInterpProc /* don't do direct invoke on tcl procs */ + ) { + /* silently ignore earlybinding flag */ + tcd->objProc = NULL; + } else { + tcd->clientData = Tcl_Command_objClientData(cmd); } + } - tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc != NULL; + tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc; - /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/ - if (rc == TCL_OK) { - *tcdp = tcd; - } else { - forwardCmdDeleteProc((ClientData)tcd); - } - return rc; + /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/ + if (rc == TCL_OK) { + *tcdp = tcd; + } else { + forwardCmdDeleteProc((ClientData)tcd); + } + return rc; } static int XOTclCInstForwardMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - forwardCmdClientData *tcd; - int rc; + int objc, Tcl_Obj * CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + forwardCmdClientData *tcd; + int rc; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) goto forward_argc_error; - rc = forwardProcessOptions(interp, objc, objv, &tcd); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) goto forward_argc_error; + rc = forwardProcessOptions(interp, objc, objv, &tcd); - if (rc == TCL_OK) { - tcd->obj = &cl->object; - XOTclAddInstanceMethod(interp, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc, 0); - return TCL_OK; - } else { - forward_argc_error: - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "method ?target? ?-default name? ?-objscope? ?-onerror cmd? ?-methodprefix string? ?args?"); - } + if (rc == TCL_OK) { + tcd->obj = &cl->object; + XOTclAddIMethod(interp, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc); + return TCL_OK; + } else { + forward_argc_error: + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); + } } static int XOTclOForwardMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - XOTcl_Object *obj = (XOTcl_Object*) clientData; - forwardCmdClientData *tcd; - int rc; + int objc, Tcl_Obj * CONST objv[]) { + XOTcl_Object *obj = (XOTcl_Object*) clientData; + forwardCmdClientData *tcd; + int rc; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (objc < 2) goto forward_argc_error; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) goto forward_argc_error; - rc = forwardProcessOptions(interp, objc, objv, &tcd); + rc = forwardProcessOptions(interp, objc, objv, &tcd); - if (rc == TCL_OK) { - tcd->obj = (XOTclObject*)obj; - XOTclAddObjectMethod(interp, obj, NSTail(ObjStr(objv[1])), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc, 0); - return TCL_OK; - } else { - forward_argc_error: - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], - "method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); - } + if (rc == TCL_OK) { + tcd->obj = (XOTclObject*)obj; + XOTclAddPMethod(interp, obj, NSTail(ObjStr(objv[1])), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc); + return TCL_OK; + } else { + forward_argc_error: + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); + } } static int -XOTclOVolatileMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*) clientData; - Tcl_Obj *o = obj->cmdName; - int result = TCL_ERROR; - char *fullName = ObjStr(o); - char *vn; - callFrameContext ctx = {0}; +XOTclOVolatileMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { + XOTclObject *obj = (XOTclObject*) clientData; + Tcl_Obj *o = obj->cmdName; + int result = TCL_ERROR; + CONST char *fullName = ObjStr(o); + CONST char *vn; + callFrameContext ctx = {0}; - if (objc != 1) - return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + if (objc != 1) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { - fprintf(stderr,"### Can't make objects volatile during shutdown\n"); - return XOTclVarErrMsg(interp, "Can't make objects volatile during shutdown\n", NULL); - } + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { + fprintf(stderr,"### Can't make objects volatile during shutdown\n"); + return XOTclVarErrMsg(interp, "Can't make objects volatile during shutdown\n", NULL); + } - CallStackUseActiveFrames(interp, &ctx); - vn = NSTail(fullName); + CallStackUseActiveFrames(interp, &ctx); + vn = NSTail(fullName); - if (Tcl_SetVar2(interp, vn, NULL, fullName, 0) != NULL) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); + if (Tcl_SetVar2(interp, vn, NULL, fullName, 0)) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - /*fprintf(stderr,"### setting trace for %s\n", fullName);*/ - result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS, - (Tcl_VarTraceProc*)XOTclUnsetTrace, - (ClientData)o); - opt->volatileVarName = vn; - } - CallStackRestoreSavedFrames(interp, &ctx); + /*fprintf(stderr,"### setting trace for %s\n", fullName);*/ + result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS, + (Tcl_VarTraceProc*)XOTclUnsetTrace, + (ClientData)o); + opt->volatileVarName = vn; + } + CallStackRestoreSavedFrames(interp, &ctx); - if (result == TCL_OK) { - INCR_REF_COUNT(o); - } - return result; + if (result == TCL_OK) { + INCR_REF_COUNT(o); + } + return result; } static int makeMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int clsns) { - XOTclClass *cl = XOTclObjectToClass(clientData); - char *argStr, *bdyStr, *name; - XOTclClassOpt *opt; - int incr = 0, result = TCL_OK; + XOTclClass *cl = XOTclObjectToClass(clientData); + char *argStr, *bdyStr, *name; + XOTclClassOpt *opt; + int incr = 0, result = TCL_OK; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 4 || objc > 7) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "name ?non-positional-args? args body ?preAssertion postAssertion?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 4 || objc > 7) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "name ?non-positional-args? args body ?preAssertion postAssertion?"); - if (objc == 5 || objc == 7) { - incr = 1; - } + if (objc == 5 || objc == 7) { + incr = 1; + } - argStr = ObjStr(objv[2 + incr]); - bdyStr = ObjStr(objv[3 + incr]); - name = ObjStr(objv[1 + incr]); + argStr = ObjStr(objv[2 + incr]); + bdyStr = ObjStr(objv[3 + incr]); + name = ObjStr(objv[1 + incr]); - if ((cl == RUNTIME_STATE(interp)->theObject && isDestroyString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isInstDestroyString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isDeallocString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isAllocString(name)) || - (cl == RUNTIME_STATE(interp)->theClass && isCreateString(name))) - return XOTclVarErrMsg(interp, className(cl), " method '", name, "' of ", - className(cl), " can not be overwritten. Derive a ", - "sub-class", (char *) NULL); + if ((cl == RUNTIME_STATE(interp)->theObject && isDestroyString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isInstDestroyString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isDeallocString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isAllocString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isCreateString(name))) + return XOTclVarErrMsg(interp, className(cl), " method '", name, "' of ", + className(cl), " can not be overwritten. Derive a ", + "sub-class", (char *) NULL); - if (*argStr == 0 && *bdyStr == 0) { - int rc; - opt = cl->opt; - if (opt && opt->assertions) - AssertionRemoveProc(opt->assertions, name); - rc = NSDeleteCmd(interp, cl->nsPtr, name); - if (rc < 0) - return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", name, - "' of class ", className(cl), (char *) NULL); - } else { - XOTclAssertionStore *aStore = NULL; - if (objc > 5) { - opt = XOTclRequireClassOpt(cl); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; - } - result = MakeProc(cl->nsPtr, aStore, &(cl->nonposArgsTable), - interp, objc, (Tcl_Obj **) objv, &cl->object, clsns); + if (*argStr == 0 && *bdyStr == 0) { + int rc; + opt = cl->opt; + if (opt && opt->assertions) + AssertionRemoveProc(opt->assertions, name); + rc = NSDeleteCmd(interp, cl->nsPtr, name); + if (rc < 0) + return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", name, + "' of class ", className(cl), (char *) NULL); + } else { + XOTclAssertionStore *aStore = NULL; + if (objc > 5) { + opt = XOTclRequireClassOpt(cl); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; } + result = MakeProc(cl->nsPtr, aStore, &(cl->nonposArgsTable), + interp, objc, (Tcl_Obj **) objv, &cl->object, clsns); + } - /* could be a filter or filter inheritance ... update filter orders */ - FilterInvalidateObjOrders(interp, cl); + /* could be a filter or filter inheritance ... update filter orders */ + FilterInvalidateObjOrders(interp, cl); - return result; + return result; } - static int XOTclCInstProcMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - return makeMethod(clientData, interp, objc, objv, 0); + return makeMethod(clientData, interp, objc, objv, 0); } static int XOTclCInstProcMethodC(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - return makeMethod(clientData, interp, objc, objv, 1); + return makeMethod(clientData, interp, objc, objv, 1); } static int XOTclCInstFilterGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclCmdList *h; - XOTclClassOpt *opt; + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclCmdList *h; + XOTclClassOpt *opt; + + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "filtername filterGuard"); - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "filtername filterGuard"); - - opt = cl->opt; - if (opt && opt->instfilters) { - h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->instfilters); - if (h) { - if (h->clientData) - GuardDel(h); - GuardAdd(interp, h, objv[2]); - FilterInvalidateObjOrders(interp, cl); - return TCL_OK; - } + opt = cl->opt; + if (opt && opt->instfilters) { + h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->instfilters); + if (h) { + if (h->clientData) + GuardDel(h); + GuardAdd(interp, h, objv[2]); + FilterInvalidateObjOrders(interp, cl); + return TCL_OK; } + } - return XOTclVarErrMsg(interp, "Instfilterguard: can't find filter ", - ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Instfilterguard: can't find filter ", + ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), + (char *) NULL); } static int -XOTclCInstMixinGuardMethod(ClientData clientData, Tcl_Interp *interp, +XOTclCInstMixinGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclCmdList *h; - - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "mixin guard"); - - if (cl->opt && cl->opt->instmixins) { - XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); - } - if (mixinCmd) { - h = CmdListFindCmdInList(mixinCmd, cl->opt->instmixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, objv[2]); - MixinInvalidateObjOrders(interp, cl); - return TCL_OK; - } - } + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclCmdList *h; + + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "mixin guard"); + + if (cl->opt && cl->opt->instmixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); } + if (mixinCmd) { + h = CmdListFindCmdInList(mixinCmd, cl->opt->instmixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, objv[2]); + MixinInvalidateObjOrders(interp, cl); + return TCL_OK; + } + } + } - return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ", + ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), + (char *) NULL); } static int XOTclCInvariantsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclClassOpt *opt; + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclClassOpt *opt; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - ""); - opt = XOTclRequireClassOpt(cl); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + ""); + opt = XOTclRequireClassOpt(cl); - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); + if (opt->assertions) + TclObjListFreeList(opt->assertions->invariants); + else + opt->assertions = AssertionCreateStore(); - opt->assertions->invariants = AssertionNewList(interp, objv[1]); - return TCL_OK; + opt->assertions->invariants = AssertionNewList(interp, objv[1]); + return TCL_OK; } static int XOTclCUnknownMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*) clientData; - char *self = ObjStr(obj->cmdName); - int rc; - - if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "message ?args .. args?"); - if (isCreateString(self)) - return XOTclVarErrMsg(interp, "error ", self, ": unable to dispatch '", - ObjStr(objv[1]), "'", (char *) NULL); - - rc = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); - return rc; + XOTclObject *obj = (XOTclObject*) clientData; + char *self = ObjStr(obj->cmdName); + int rc; + + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "message ?args .. args?"); + if (isCreateString(self)) + return XOTclVarErrMsg(interp, "error ", self, ": unable to dispatch '", + ObjStr(objv[1]), "'", (char *) NULL); + + rc = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); + return rc; } /* * New Tcl Commands */ static int XOTcl_NSCopyCmds(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Command cmd; - Tcl_Obj *newFullCmdName, *oldFullCmdName; - char *newName, *oldName, *name; - Tcl_Namespace *ns, *newNs; - Tcl_HashTable *cmdTable; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; + Tcl_Command cmd; + Tcl_Obj *newFullCmdName, *oldFullCmdName; + char *newName, *oldName, *name; + Tcl_Namespace *ns, *newNs; + Tcl_HashTable *cmdTable, *nonposArgsTable; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + XOTclObject *obj; + XOTclClass *cl; - if (objc != 3) - return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (objc != 3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - ns = ObjFindNamespace(interp, objv[1]); - if (!ns) - return TCL_OK; + ns = ObjFindNamespace(interp, objv[1]); + if (!ns) + return TCL_OK; + + name = ObjStr(objv[1]); + /* check, if we work on an object or class namespace */ + if (isClassName(name)) { + cl = XOTclpGetClass(interp, NSCutXOTclClasses(name)); + obj = (XOTclObject *)cl; + nonposArgsTable = cl->nonposArgsTable; + } else { + cl = NULL; + obj = XOTclpGetObject(interp, name); + nonposArgsTable = obj->nonposArgsTable; + } - newNs = ObjFindNamespace(interp, objv[2]); - if (!newNs) - return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ", - ObjStr(objv[2]), " does not exist", (char *) NULL); - /* - * copy all procs & commands in the ns - */ - cmdTable = Tcl_Namespace_cmdTable(ns); - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + if (obj == NULL) { + return XOTclVarErrMsg(interp, "CopyCmds argument 1 (",ObjStr(objv[1]),") is not an object", + NULL); + } + /* obj = XOTclpGetObject(interp, ObjStr(objv[1]));*/ + newNs = ObjFindNamespace(interp, objv[2]); + if (!newNs) + return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ", + ObjStr(objv[2]), " does not exist", (char *) NULL); + /* + * copy all procs & commands in the ns + */ + cmdTable = Tcl_Namespace_cmdTable(ns); + hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + while (hPtr) { /*fprintf(stderr,"copy cmdTable = %p, first=%p\n", cmdTable, hPtr);*/ - while (hPtr != NULL) { - name = Tcl_GetHashKey(cmdTable, hPtr); + name = Tcl_GetHashKey(cmdTable, hPtr); - /* - * construct full cmd names - */ - newFullCmdName = Tcl_NewStringObj(newNs->fullName,-1); - oldFullCmdName = Tcl_NewStringObj(ns->fullName,-1); + /* + * construct full cmd names + */ + newFullCmdName = Tcl_NewStringObj(newNs->fullName,-1); + oldFullCmdName = Tcl_NewStringObj(ns->fullName,-1); - INCR_REF_COUNT(newFullCmdName); INCR_REF_COUNT(oldFullCmdName); - Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char *) NULL); - Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char *) NULL); - newName = ObjStr(newFullCmdName); - oldName = ObjStr(oldFullCmdName); + INCR_REF_COUNT(newFullCmdName); INCR_REF_COUNT(oldFullCmdName); + Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char *) NULL); + Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char *) NULL); + newName = ObjStr(newFullCmdName); + oldName = ObjStr(oldFullCmdName); - /*fprintf(stderr,"try to copy command from '%s' to '%s'\n", oldName, newName);*/ - /* - * Make sure that the destination command does not already exist. - * Otherwise: do not copy - */ - cmd = Tcl_FindCommand(interp, newName, 0, 0); + /*fprintf(stderr,"try to copy command from '%s' to '%s'\n", oldName, newName);*/ + /* + * Make sure that the destination command does not already exist. + * Otherwise: do not copy + */ + cmd = Tcl_FindCommand(interp, newName, 0, 0); + if (cmd) { + /*fprintf(stderr, "%s already exists\n", newName);*/ + if (!XOTclpGetObject(interp, newName)) { + /* command or instproc will be deleted & then copied */ + Tcl_DeleteCommandFromToken(interp, cmd); + } else { + /* don't overwrite objects -> will be recreated */ + hPtr = Tcl_NextHashEntry(&hSrch); + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + continue; + } + } - if (cmd != NULL) { - /*fprintf(stderr, "%s already exists\n", newName);*/ - if (!XOTclpGetObject(interp, newName)) { - /* command or instproc will be deleted & then copied */ - Tcl_DeleteCommandFromToken(interp, cmd); - } else { - /* don't overwrite objects -> will be recreated */ - hPtr = Tcl_NextHashEntry(&hSrch); - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - continue; - } - } + /* + * Find the existing command. An error is returned if simpleName can't + * be found + */ + cmd = Tcl_FindCommand(interp, oldName, 0, 0); + if (cmd == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't copy ", " \"", + oldName, "\": command doesn't exist", + (char *) NULL); + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + return TCL_ERROR; + } + /* + * Do not copy Objects or Classes + */ + if (!XOTclpGetObject(interp, oldName)) { + if (TclIsProc((Command*)cmd)) { + Proc *procPtr = TclFindProc((Interp *)interp, oldName); + Tcl_Obj *arglistObj = NULL; + CompiledLocal *localPtr; + XOTclNonposArgs *nonposArgs = NULL; /* - * Find the existing command. An error is returned if simpleName can't - * be found + * Build a list containing the arguments of the proc */ - cmd = Tcl_FindCommand(interp, oldName, 0, 0); - if (cmd == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't copy ", " \"", - oldName, "\": command doesn't exist", - (char *) NULL); - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - return TCL_ERROR; - } - /* - * Do not copy Objects or Classes - */ - if (!XOTclpGetObject(interp, oldName)) { - if (TclIsProc((Command*)cmd)) { - Proc *procPtr = TclFindProc((Interp *)interp, oldName); - Tcl_Obj *arglistObj; - CompiledLocal *localPtr; + if (nonposArgsTable) { + nonposArgs = NonposArgsGet(nonposArgsTable, name); + if (nonposArgs) { + arglistObj = NonposArgsFormat(interp, nonposArgs->nonposArgs); + INCR_REF_COUNT(arglistObj); + AppendOrdinaryArgsFromNonposArgs(interp, nonposArgs, 0, arglistObj); + } + } - /* - * Build a list containing the arguments of the proc - */ + if (!arglistObj) { + arglistObj = Tcl_NewListObj(0, NULL); + INCR_REF_COUNT(arglistObj); - arglistObj = Tcl_NewListObj(0, NULL); - INCR_REF_COUNT(arglistObj); + for (localPtr = procPtr->firstLocalPtr; localPtr; + localPtr = localPtr->nextPtr) { + + if (TclIsCompiledLocalArgument(localPtr)) { + Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1); + INCR_REF_COUNT(defStringObj); - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - - if (TclIsCompiledLocalArgument(localPtr)) { - Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1); - INCR_REF_COUNT(defStringObj); - /* check for default values */ - if ((GetProcDefault(interp, cmdTable, name, - localPtr->name, &defVal) == TCL_OK) && - (defVal != 0)) { - Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), - (char *) NULL); - } - Tcl_ListObjAppendElement(interp, arglistObj, defStringObj); - DECR_REF_COUNT(defStringObj); - } - } + /* check for default values */ + if ((GetProcDefault(interp, cmdTable, name, + localPtr->name, &defVal) == TCL_OK) && defVal) { + Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), + (char *) NULL); + } + Tcl_ListObjAppendElement(interp, arglistObj, defStringObj); + DECR_REF_COUNT(defStringObj); + } + } + } - if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { - Tcl_DString ds, *dsPtr = &ds; + if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { + Tcl_DString ds, *dsPtr = &ds; - if (isClassName(ns->fullName)) { - /* it started with ::xotcl::classes */ - XOTclClass *cl = XOTclpGetClass(interp, NSCutXOTclClasses(ns->fullName)); - XOTclProcAssertion *procs; + if (cl) { + /* we have a class */ + XOTclProcAssertion *procs; - if (cl) { - procs = cl->opt ? - AssertionFindProcs(cl->opt->assertions, name) : 0; - } else { - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - DECR_REF_COUNT(arglistObj); - return XOTclVarErrMsg(interp, "No class for inst - assertions", (char *) NULL); - } + if (cl) { + procs = cl->opt ? + AssertionFindProcs(cl->opt->assertions, name) : 0; + } else { + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + DECR_REF_COUNT(arglistObj); + return XOTclVarErrMsg(interp, "No class for inst - assertions", (char *) NULL); + } - /* XOTcl InstProc */ - DSTRING_INIT(dsPtr); - Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(newNs->fullName)); - Tcl_DStringAppendElement(dsPtr, "instproc"); - Tcl_DStringAppendElement(dsPtr, name); - Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); - Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); - if (procs) { - XOTclRequireClassOpt(cl); - AssertionAppendPrePost(interp, dsPtr, procs); - } - Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0); - DSTRING_FREE(dsPtr); - } else { - XOTclObject *obj = XOTclpGetObject(interp, ns->fullName); - XOTclProcAssertion *procs; - if (obj) { - procs = obj->opt ? - AssertionFindProcs(obj->opt->assertions, name) : 0; - } else { - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - DECR_REF_COUNT(arglistObj); - return XOTclVarErrMsg(interp, "No object for assertions", (char *) NULL); - } - - /* XOTcl Proc */ - DSTRING_INIT(dsPtr); - Tcl_DStringAppendElement(dsPtr, newNs->fullName); - Tcl_DStringAppendElement(dsPtr, "proc"); - Tcl_DStringAppendElement(dsPtr, name); - Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); - Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); - if (procs) { - XOTclRequireObjectOpt(obj); - AssertionAppendPrePost(interp, dsPtr, procs); - } - Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0); - DSTRING_FREE(dsPtr); - } - DECR_REF_COUNT(arglistObj); - } else { - /* Tcl Proc */ - Tcl_VarEval(interp, "proc ", newName, " {", ObjStr(arglistObj),"} {\n", - ObjStr(procPtr->bodyPtr), "}", (char *) NULL); - } + /* XOTcl InstProc */ + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(newNs->fullName)); + Tcl_DStringAppendElement(dsPtr, "instproc"); + Tcl_DStringAppendElement(dsPtr, name); + Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); + Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); + if (procs) { + XOTclRequireClassOpt(cl); + AssertionAppendPrePost(interp, dsPtr, procs); + } + Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0); + DSTRING_FREE(dsPtr); + } else { + XOTclObject *obj = XOTclpGetObject(interp, ns->fullName); + XOTclProcAssertion *procs; + if (obj) { + procs = obj->opt ? + AssertionFindProcs(obj->opt->assertions, name) : 0; } else { - /* - * Otherwise copy command - */ - Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); - Tcl_CmdDeleteProc *deleteProc = Tcl_Command_deleteProc(cmd); - ClientData clientData; - if (objProc) { - clientData = Tcl_Command_objClientData(cmd); - if (clientData == 0) { - /* if client data not null, we would have to copy - the client data; we don't know its size...., so rely - on introspection for copying */ - Tcl_CreateObjCommand(interp, newName, objProc, - Tcl_Command_objClientData(cmd), deleteProc); - } - } else { - clientData = Tcl_Command_clientData(cmd); - if (clientData == 0) { - Tcl_CreateCommand(interp, newName, Tcl_Command_proc(cmd), - Tcl_Command_clientData(cmd), deleteProc); - } - } + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + DECR_REF_COUNT(arglistObj); + return XOTclVarErrMsg(interp, "No object for assertions", (char *) NULL); } + + /* XOTcl Proc */ + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, newNs->fullName); + Tcl_DStringAppendElement(dsPtr, "proc"); + Tcl_DStringAppendElement(dsPtr, name); + Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); + Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); + if (procs) { + XOTclRequireObjectOpt(obj); + AssertionAppendPrePost(interp, dsPtr, procs); + } + Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0); + DSTRING_FREE(dsPtr); + } + DECR_REF_COUNT(arglistObj); + } else { + /* Tcl Proc */ + Tcl_VarEval(interp, "proc ", newName, " {", ObjStr(arglistObj),"} {\n", + ObjStr(procPtr->bodyPtr), "}", (char *) NULL); } - hPtr = Tcl_NextHashEntry(&hSrch); - DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); + } else { + /* + * Otherwise copy command + */ + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + Tcl_CmdDeleteProc *deleteProc = Tcl_Command_deleteProc(cmd); + ClientData clientData; + if (objProc) { + clientData = Tcl_Command_objClientData(cmd); + if (clientData == NULL || clientData == (ClientData)XOTCL_NONLEAF_METHOD) { + /* if client data not null, we would have to copy + the client data; we don't know its size...., so rely + on introspection for copying */ + Tcl_CreateObjCommand(interp, newName, objProc, + Tcl_Command_objClientData(cmd), deleteProc); + } + } else { + clientData = Tcl_Command_clientData(cmd); + if (clientData == NULL || clientData == (ClientData)XOTCL_NONLEAF_METHOD) { + Tcl_CreateCommand(interp, newName, Tcl_Command_proc(cmd), + Tcl_Command_clientData(cmd), deleteProc); + } + } + } } - return TCL_OK; + hPtr = Tcl_NextHashEntry(&hSrch); + DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); + } + return TCL_OK; } static int XOTcl_NSCopyVars(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Namespace *ns, *newNs; - Var *varPtr = NULL; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - TclVarHashTable *varTable; - int rc = TCL_OK; - XOTclObject *obj; - char *destFullName; - Tcl_Obj *destFullNameObj; - TclCallFrame frame, *framePtr = &frame; - Tcl_Obj *varNameObj = NULL; - Tcl_Obj *nobjv[4]; - int nobjc; - Tcl_Obj *setObj; + Tcl_Namespace *ns, *newNs; + Var *varPtr = NULL; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + TclVarHashTable *varTable; + int rc = TCL_OK; + XOTclObject *obj; + char *destFullName; + Tcl_Obj *destFullNameObj; + TclCallFrame frame, *framePtr = &frame; + Tcl_Obj *varNameObj = NULL; + Tcl_Obj *nobjv[4]; + int nobjc; + Tcl_Obj *setObj; + + if (objc != 3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + + ns = ObjFindNamespace(interp, objv[1]); + if (ns) { + newNs = ObjFindNamespace(interp, objv[2]); + if (!newNs) + return XOTclVarErrMsg(interp, "CopyVars: Destination namespace ", + ObjStr(objv[2]), " does not exist", (char *) NULL); - if (objc != 3) - return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - - ns = ObjFindNamespace(interp, objv[1]); - if (ns) { - newNs = ObjFindNamespace(interp, objv[2]); - if (!newNs) - return XOTclVarErrMsg(interp, "CopyVars: Destination namespace ", - ObjStr(objv[2]), " does not exist", (char *) NULL); - - obj = XOTclpGetObject(interp, ObjStr(objv[1])); - destFullName = newNs->fullName; - destFullNameObj = Tcl_NewStringObj(destFullName, -1); - INCR_REF_COUNT(destFullNameObj); - varTable = Tcl_Namespace_varTable(ns); - Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, newNs, 0); - } else { - XOTclObject *newObj; - if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) { - return XOTclVarErrMsg(interp, "CopyVars: Origin object/namespace ", - ObjStr(objv[1]), " does not exist", (char *) NULL); - } - if (XOTclObjConvertObject(interp, objv[2], &newObj) != TCL_OK) { - return XOTclVarErrMsg(interp, "CopyVars: Destination object/namespace ", - ObjStr(objv[2]), " does not exist", (char *) NULL); - } - varTable = obj->varTable; - destFullNameObj = newObj->cmdName; - destFullName = ObjStr(destFullNameObj); + obj = XOTclpGetObject(interp, ObjStr(objv[1])); + destFullName = newNs->fullName; + destFullNameObj = Tcl_NewStringObj(destFullName, -1); + INCR_REF_COUNT(destFullNameObj); + varTable = Tcl_Namespace_varTable(ns); + Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, newNs, 0); + } else { + XOTclObject *newObj; + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) { + return XOTclVarErrMsg(interp, "CopyVars: Origin object/namespace ", + ObjStr(objv[1]), " does not exist", (char *) NULL); } + if (XOTclObjConvertObject(interp, objv[2], &newObj) != TCL_OK) { + return XOTclVarErrMsg(interp, "CopyVars: Destination object/namespace ", + ObjStr(objv[2]), " does not exist", (char *) NULL); + } + varTable = obj->varTable; + destFullNameObj = newObj->cmdName; + destFullName = ObjStr(destFullNameObj); + } - setObj= Tcl_NewStringObj("set", 3); - INCR_REF_COUNT(setObj); - nobjc = 4; - nobjv[0] = destFullNameObj; - nobjv[1] = setObj; + setObj= Tcl_NewStringObj("set", 3); + INCR_REF_COUNT(setObj); + nobjc = 4; + nobjv[0] = destFullNameObj; + nobjv[1] = setObj; - /* copy all vars in the ns */ - hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : NULL; - while (hPtr != NULL) { + /* copy all vars in the ns */ + hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : NULL; + while (hPtr) { - getVarAndNameFromHash(hPtr, &varPtr, &varNameObj); - INCR_REF_COUNT(varNameObj); + getVarAndNameFromHash(hPtr, &varPtr, &varNameObj); + INCR_REF_COUNT(varNameObj); - if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) { - if (TclIsVarScalar(varPtr)) { - /* it may seem odd that we do not copy obj vars with the - * same SetVar2 as normal vars, but we want to dispatch it in order to - * be able to intercept the copying */ + if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) { + if (TclIsVarScalar(varPtr)) { + /* it may seem odd that we do not copy obj vars with the + * same SetVar2 as normal vars, but we want to dispatch it in order to + * be able to intercept the copying */ - if (obj) { + if (obj) { #if 1 - /* can't rely on "set", if there are multiple object systems */ - setInstVar(interp, obj, varNameObj, valueOfVar(Tcl_Obj, varPtr, objPtr)); + /* can't rely on "set", if there are multiple object systems */ + setInstVar(interp, obj, varNameObj, valueOfVar(Tcl_Obj, varPtr, objPtr)); #else - nobjv[2] = varNameObj; - nobjv[3] = valueOfVar(Tcl_Obj, varPtr, objPtr); - rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0); + nobjv[2] = varNameObj; + nobjv[3] = valueOfVar(Tcl_Obj, varPtr, objPtr); + rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0); #endif - } else { - Tcl_ObjSetVar2(interp, varNameObj, NULL, - valueOfVar(Tcl_Obj, varPtr, objPtr), - TCL_NAMESPACE_ONLY); - } - } else { - if (TclIsVarArray(varPtr)) { - /* //// HERE!! PRE85 Why not [array get/set] based? Let the core iterate */ - TclVarHashTable *aTable = valueOfVar(TclVarHashTable, varPtr, tablePtr); - Tcl_HashSearch ahSrch; - Tcl_HashEntry *ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) : NULL; - - for (; ahPtr != 0; ahPtr = Tcl_NextHashEntry(&ahSrch)) { - Tcl_Obj *eltNameObj; - Var *eltVar; + } else { + Tcl_ObjSetVar2(interp, varNameObj, NULL, + valueOfVar(Tcl_Obj, varPtr, objPtr), + TCL_NAMESPACE_ONLY); + } + } else { + if (TclIsVarArray(varPtr)) { + /* HERE!! PRE85 Why not [array get/set] based? Let the core iterate*/ + TclVarHashTable *aTable = valueOfVar(TclVarHashTable, varPtr, tablePtr); + Tcl_HashSearch ahSrch; + Tcl_HashEntry *ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) :0; + for (; ahPtr; ahPtr = Tcl_NextHashEntry(&ahSrch)) { + Tcl_Obj *eltNameObj; + Var *eltVar; - getVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj); - INCR_REF_COUNT(eltNameObj); + getVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj); + INCR_REF_COUNT(eltNameObj); - if (TclIsVarScalar(eltVar)) { - if (obj) { + if (TclIsVarScalar(eltVar)) { + if (obj) { #if 1 - XOTcl_ObjSetVar2((XOTcl_Object*)obj, interp, varNameObj, eltNameObj, valueOfVar(Tcl_Obj, eltVar, objPtr), 0); + XOTcl_ObjSetVar2((XOTcl_Object*)obj, interp, varNameObj, eltNameObj, valueOfVar(Tcl_Obj, eltVar, objPtr), 0); #else - Tcl_Obj *fullVarNameObj = Tcl_DuplicateObj(varNameObj); + Tcl_Obj *fullVarNameObj = Tcl_DuplicateObj(varNameObj); - INCR_REF_COUNT(fullVarNameObj); - Tcl_AppendStringsToObj(fullVarNameObj, "(", - ObjStr(eltNameObj), ")", NULL); - nobjv[2] = fullVarNameObj; - nobjv[3] = valueOfVar(Tcl_Obj, eltVar, objPtr); + INCR_REF_COUNT(fullVarNameObj); + Tcl_AppendStringsToObj(fullVarNameObj, "(", + ObjStr(eltNameObj), ")", NULL); + nobjv[2] = fullVarNameObj; + nobjv[3] = valueOfVar(Tcl_Obj, eltVar, objPtr); - rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0); - DECR_REF_COUNT(fullVarNameObj); + rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0); + DECR_REF_COUNT(fullVarNameObj); #endif - } else { - Tcl_ObjSetVar2(interp, varNameObj, eltNameObj, - valueOfVar(Tcl_Obj, eltVar, objPtr), - TCL_NAMESPACE_ONLY); - } - } - DECR_REF_COUNT(eltNameObj); - } - } + } else { + Tcl_ObjSetVar2(interp, varNameObj, eltNameObj, + valueOfVar(Tcl_Obj, eltVar, objPtr), + TCL_NAMESPACE_ONLY); + } } + DECR_REF_COUNT(eltNameObj); + } } - DECR_REF_COUNT(varNameObj); - hPtr = Tcl_NextHashEntry(&hSrch); + } } - if (ns) { - DECR_REF_COUNT(destFullNameObj); - Tcl_PopCallFrame(interp); - } - DECR_REF_COUNT(setObj); - return rc; + DECR_REF_COUNT(varNameObj); + hPtr = Tcl_NextHashEntry(&hSrch); + } + if (ns) { + DECR_REF_COUNT(destFullNameObj); + Tcl_PopCallFrame(interp); + } + DECR_REF_COUNT(setObj); + return rc; } int XOTclSelfDispatchCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *self; - int result; - if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, "?-local? method ?args?"); - if ((self = GetSelfObj(interp))) { - int i = 1; - char *arg1 = ObjStr(objv[1]); - if (*arg1 == '-' && !strcmp("-local", arg1)) { - XOTclClass *cl = GetSelfClass(interp); - Tcl_Command cmd; - ClientData cp; - char *method; - if (objc < 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "?-local? method ?args?"); - method = ObjStr(objv[2]); - i++; - cmd = FindMethod(method, cl->nsPtr); - if (cmd == 0) - return XOTclVarErrMsg(interp, ObjStr(self->cmdName), - ": unable to dispatch local method '", - method, "' in class ", ObjStr(cl->object.cmdName), - (char *) NULL); - cp = Tcl_Command_objClientData(cmd); - /*fprintf(stderr, "method %s, cmd = %p objc=%d\n", method, cmd, objc); - for (i=0; icmdName), objc, ObjStr(objv[1])); - {int i; fprintf(stderr, "MY\tCALL ");for(i=0; insPtr); + if (cmd == 0) + return XOTclVarErrMsg(interp, ObjStr(self->cmdName), + ": unable to dispatch local method '", + method, "' in class ", ObjStr(cl->object.cmdName), + (char *) NULL); + /*fprintf(stderr, "method %s, cmd = %p objc=%d\n", method, cmd, objc); + for (i=0; icmdName), objc, ObjStr(objv[1])); + {int i; fprintf(stderr, "MY\tCALL ");for(i=0; ivarFramePtr = varFramePtr;*/ + /*RUNTIME_STATE(interp)->varFramePtr = varFramePtr;*/ #if 0 - Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(RUNTIME_STATE(interp)->cs.top->cmdPtr); - fprintf(stderr,"initProcNS self=%s cmd=%p, '%s'\n", - ObjStr(RUNTIME_STATE(interp)->cs.top->self->cmdName), - nsPtr, nsPtr->fullName); - fprintf(stderr,"\tsetting currentFramePtr in %p to %p in initProcNS\n", - RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); - XOTclCallStackDump(interp); + Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(RUNTIME_STATE(interp)->cs.top->cmdPtr); + fprintf(stderr,"initProcNS self=%s cmd=%p, '%s'\n", + ObjStr(RUNTIME_STATE(interp)->cs.top->self->cmdName), + nsPtr, nsPtr->fullName); + fprintf(stderr,"\tsetting currentFramePtr in %p to %p in initProcNS\n", + RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); + XOTclCallStackDump(interp); #endif - if (RUNTIME_STATE(interp)->cs.top->currentFramePtr == 0) { - RUNTIME_STATE(interp)->cs.top->currentFramePtr = varFramePtr; - } /* else { - - fprintf(stderr,"not overwriting currentFramePtr in %p from %p to %p\n", - RUNTIME_STATE(interp)->cs.top, - RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); - } */ + if (RUNTIME_STATE(interp)->cs.top->currentFramePtr == NULL) { + RUNTIME_STATE(interp)->cs.top->currentFramePtr = varFramePtr; + } /* else { + + fprintf(stderr,"not overwriting currentFramePtr in %p from %p to %p\n", + RUNTIME_STATE(interp)->cs.top, + RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); + } */ #if !defined(NAMESPACEINSTPROCS) - if (varFramePtr) { - varFramePtr->nsPtr = GetCallerVarFrame(interp, varFramePtr); - } + if (varFramePtr) { + varFramePtr->nsPtr = GetCallerVarFrame(interp, varFramePtr); + } #endif - return TCL_OK; + return TCL_OK; } +#endif /* * Interpretation of Non-Positional Args */ int -isNonposArg(Tcl_Interp *interp, char *argStr, - int nonposArgsDefc, Tcl_Obj **nonposArgsDefv, - Tcl_Obj **var, char **type) { - int i, npac; - Tcl_Obj **npav; - char *varName; - if (argStr[0] == '-') { - for (i=0; i < nonposArgsDefc; i++) { - if (Tcl_ListObjGetElements(interp, nonposArgsDefv[i], - &npac, &npav) == TCL_OK && npac > 0) { - varName = argStr+1; - if (!strcmp(varName, ObjStr(npav[0]))) { - *var = npav[0]; - *type = ObjStr(npav[1]); - return 1; - } - } +isNonposArg(Tcl_Interp *interp, char * argStr, + int nonposArgsDefc, Tcl_Obj **nonposArgsDefv, + Tcl_Obj **var, char **type) { + int i, npac; + Tcl_Obj **npav; + char *varName; + if (argStr[0] == '-') { + for (i=0; i < nonposArgsDefc; i++) { + if (Tcl_ListObjGetElements(interp, nonposArgsDefv[i], + &npac, &npav) == TCL_OK && npac > 0) { + varName = argStr+1; + if (!strcmp(varName, ObjStr(npav[0]))) { + *var = npav[0]; + *type = ObjStr(npav[1]); + return 1; } + } } - return 0; + } + return 0; } int XOTclCheckBooleanArgs(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) { - int result, bool; - Tcl_Obj *boolean; + Tcl_Obj *CONST objv[]) { + int result, bool; + Tcl_Obj *boolean; - if (objc == 2) { - /* the variable is not yet defined (set), so we cannot check - whether it is boolean or not */ - return TCL_OK; - } else if (objc != 3) { - return XOTclObjErrArgCnt(interp, NULL, objv[0], "name ?value?"); - } - - boolean = Tcl_DuplicateObj(objv[2]); - INCR_REF_COUNT(boolean); - result = Tcl_GetBooleanFromObj(interp, boolean, &bool); - DECR_REF_COUNT(boolean); - /* - if (result != TCL_OK) - return XOTclVarErrMsg(interp, - "non-positional argument: '", ObjStr(objv[1]), "' with value '", - ObjStr(objv[2]), "' is not of type boolean", - (char *) NULL); - */ - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); + if (objc == 2) { + /* the variable is not yet defined (set), so we cannot check + whether it is boolean or not */ return TCL_OK; + } else if (objc != 3) { + return XOTclObjErrArgCnt(interp, NULL, objv[0], "name ?value?"); + } + + boolean = Tcl_DuplicateObj(objv[2]); + INCR_REF_COUNT(boolean); + result = Tcl_GetBooleanFromObj(interp, boolean, &bool); + DECR_REF_COUNT(boolean); + /* + result = TCL_OK; + if (result != TCL_OK) + return XOTclVarErrMsg(interp, + "non-positional argument: '", ObjStr(objv[1]), "' with value '", + ObjStr(objv[2]), "' is not of type boolean", + (char *) NULL); + */ + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); + return TCL_OK; } int XOTclCheckRequiredArgs(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) { - if (objc != 2 && objc != 3) - return XOTclObjErrArgCnt(interp, NULL, objv[0], " ?currentValue?"); + Tcl_Obj *CONST objv[]) { - if (objc != 3) - return XOTclVarErrMsg(interp, - "required arg '", ObjStr(objv[1]), "' missing", - (char *) NULL); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; + if (objc != 2 && objc != 3) { + return XOTclObjErrArgCnt(interp, NULL, objv[0], " ?currentValue?"); + } + + if (objc != 3) { + return XOTclVarErrMsg(interp, + "required arg: '", ObjStr(objv[1]), "' missing", + (char *) NULL); + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + return TCL_OK; } int XOTclInterpretNonpositionalArgsCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) { - Tcl_Obj **npav, **checkv, **checkArgv, **argsv, **nonposArgsDefv, - *invocation[4], **ordinaryArgsDefv, **defaultValueObjv, *list, - *checkObj, *ordinaryArg; - int npac, checkc, checkArgc, argsc, nonposArgsDefc, - ordinaryArgsDefc, defaultValueObjc, argsDefined = 0, - ordinaryArgsCounter = 0, i, j, result, ic; - char *lastDefArg = NULL, *arg, *argStr; - int endOfNonposArgsReached = 0; - Var *varPtr; + Tcl_Obj *CONST objv[]) { + Tcl_Obj **npav, **checkv, **checkArgv, **argsv, **nonposArgsDefv, + *invocation[4], **ordinaryArgsDefv, **defaultValueObjv, *list, + *checkObj, *ordinaryArg; + int npac, checkc, checkArgc, argsc, nonposArgsDefc, + ordinaryArgsDefc, defaultValueObjc, argsDefined = 0, + ordinaryArgsCounter = 0, i, j, result, ic; + char *lastDefArg = NULL, *arg, *argStr; + int endOfNonposArgsReached = 0; + Var *varPtr; - XOTclClass *selfClass = GetSelfClass(interp); - char *methodName = (char *) GetSelfProc(interp); - Tcl_HashTable *nonposArgsTable; - XOTclNonposArgs *nonposArgs; - XOTclObject *selfObj; - int r1, r2, r3, r4; + XOTclClass *selfClass = GetSelfClass(interp); + char *methodName = (char *) GetSelfProc(interp); + Tcl_HashTable *nonposArgsTable; + XOTclNonposArgs *nonposArgs; + XOTclObject *selfObj; + int r1, r2, r3, r4; - if (objc != 2) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "?args?"); + if (objc != 2) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, "?args?"); + } - if (selfClass) { - nonposArgsTable = selfClass->nonposArgsTable; - } else if ((selfObj = GetSelfObj(interp))) { - nonposArgsTable = selfObj->nonposArgsTable; - } else { - return XOTclVarErrMsg(interp, "Non-positional args: can't find self/self class", - (char *) NULL); - } + if (selfClass) { + nonposArgsTable = selfClass->nonposArgsTable; + } else if ((selfObj = GetSelfObj(interp))) { + nonposArgsTable = selfObj->nonposArgsTable; + } else { + return XOTclVarErrMsg(interp, "Non positional args: can't find self/self class", + (char *) NULL); + } - nonposArgs = NonposArgsGet(nonposArgsTable, methodName); - if (nonposArgs == 0) { - return XOTclVarErrMsg(interp, - "Non-positional args: can't find hash entry for: ", - methodName, - (char *) NULL); - } + nonposArgs = NonposArgsGet(nonposArgsTable, methodName); + if (nonposArgs == 0) { + return XOTclVarErrMsg(interp, + "Non positional args: can't find hash entry for: ", + methodName, + (char *) NULL); + } - fprintf(stderr,"interpretnonposargs nonposargs = %s, ordinaryArgs = %s\n", - ObjStr(nonposArgs->nonposArgs), ObjStr(nonposArgs->ordinaryArgs)); - - r1 = Tcl_ListObjGetElements(interp, nonposArgs->nonposArgs, - &nonposArgsDefc, &nonposArgsDefv); - r2 = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); - r3 = Tcl_ListObjGetElements(interp, objv[1], &argsc, &argsv); + r1 = Tcl_ListObjGetElements(interp, nonposArgs->nonposArgs, + &nonposArgsDefc, &nonposArgsDefv); + r2 = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + r3 = Tcl_ListObjGetElements(interp, objv[1], &argsc, &argsv); - if (r1 != TCL_OK || r2 != TCL_OK || r3 != TCL_OK) { - return XOTclVarErrMsg(interp, - "Cannot split non-positional args list: ", - methodName, - (char *) NULL); - } + if (r1 != TCL_OK || r2 != TCL_OK || r3 != TCL_OK) { + return XOTclVarErrMsg(interp, + "Cannot split non positional args list: ", + methodName, + (char *) NULL); + } - /* setting variables to default values */ - for (i=0; i < nonposArgsDefc; i++) { - r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); - if (r1 == TCL_OK) { - if (npac == 3) { - /* not sure, whether Tcl_ObjSetVar2 would be better or would - cause shimmering between list elements and vars (2 times); - however, Tcl_ObjSetVar2 seems to have a problem since - a later eval does not see the variable... - */ - Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, npav[2], 0); - } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) { - /* default for switch is "off" */ - Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, Tcl_NewBooleanObj(0), 0); - } - } + /* setting variables to default values */ + for (i=0; i < nonposArgsDefc; i++) { + r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); + if (r1 == TCL_OK) { + if (npac == 3) { + Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, npav[2], 0); + /* for unknown reasons, we can't use Tcl_ObjSetVar2 here in case the + variable is referenced via eval (sample murr6) */ + /* Tcl_ObjSetVar2(interp, npav[0], NULL, npav[2], 0); */ + } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) { + Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, Tcl_NewBooleanObj(0), 0); + } } + } - if (ordinaryArgsDefc > 0) { - lastDefArg = ObjStr(ordinaryArgsDefv[ordinaryArgsDefc-1]); - if (isArgsString(lastDefArg)) { - argsDefined = 1; - } + if (ordinaryArgsDefc > 0) { + lastDefArg = ObjStr(ordinaryArgsDefv[ordinaryArgsDefc-1]); + if (isArgsString(lastDefArg)) { + argsDefined = 1; } + } - /* setting specified variables */ - for (i=0; i < argsc; i++) { + /* setting specified variables */ + for (i=0; i < argsc; i++) { - if (!endOfNonposArgsReached) { - char *type; - Tcl_Obj *var; - argStr = ObjStr(argsv[i]); + if (!endOfNonposArgsReached) { + char *type; + Tcl_Obj *var; + argStr = ObjStr(argsv[i]); - if (isDoubleDashString(argStr)) { - endOfNonposArgsReached = 1; - i++; - } - if (isNonposArg(interp, argStr, nonposArgsDefc, nonposArgsDefv, &var,&type)) { - if (*type == 's' && !strcmp(type, "switch")) { - int bool; - Tcl_Obj *boolObj = Tcl_ObjGetVar2(interp, var, 0, 0); - if (Tcl_GetBooleanFromObj(interp, boolObj, &bool) != TCL_OK) { - return XOTclVarErrMsg(interp, "Non positional arg '", argStr, - "': no boolean value", (char *) NULL); - } - Tcl_ObjSetVar2(interp, var, NULL, Tcl_NewBooleanObj(!bool), 0); - } else { - i++; - if (i >= argsc) - return XOTclVarErrMsg(interp, "Non positional arg '", - argStr, "' missing", (char *) NULL); - Tcl_ObjSetVar2(interp, var, NULL, argsv[i], 0); - } - } else { - endOfNonposArgsReached = 1; - } + if (isDoubleDashString(argStr)) { + endOfNonposArgsReached = 1; + i++; + } + if (isNonposArg(interp, argStr, nonposArgsDefc, nonposArgsDefv, &var,&type)) { + if (*type == 's' && !strcmp(type, "switch")) { + int bool; + Tcl_Obj *boolObj = Tcl_ObjGetVar2(interp, var, 0, 0); + if (Tcl_GetBooleanFromObj(interp, boolObj, &bool) != TCL_OK) { + return XOTclVarErrMsg(interp, "Non positional arg '", argStr, + "': no boolean value", (char *) NULL); + } + Tcl_SetVar2Ex(interp, ObjStr(var), NULL, Tcl_NewBooleanObj(!bool), 0); + /*Tcl_ObjSetVar2(interp, var, NULL, Tcl_NewBooleanObj(!bool), 0); */ + } else { + i++; + if (i >= argsc) + return XOTclVarErrMsg(interp, "Non positional arg '", + argStr, "': value missing", (char *) NULL); + Tcl_SetVar2Ex(interp, ObjStr(var), NULL, argsv[i], 0); + /* Tcl_ObjSetVar2(interp, var, NULL, argsv[i], 0);*/ } + } else { + endOfNonposArgsReached = 1; + } + } - if (endOfNonposArgsReached && i < argsc) { - if (ordinaryArgsCounter >= ordinaryArgsDefc) { - Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs); - XOTclVarErrMsg(interp, "unknown argument '", - ObjStr(argsv[i]), - "' for method '", - methodName, - "': valid arguments ", - ObjStr(tmp), - " ", - ObjStr(nonposArgs->ordinaryArgs), - (char *) NULL); - DECR_REF_COUNT(tmp); - return TCL_ERROR; - } - arg = ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]); - /* this is the last arg and 'args' is defined */ - if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) { - list = Tcl_NewListObj(0, NULL); - INCR_REF_COUNT(list); - for(; i < argsc; i++) { - Tcl_ListObjAppendElement(interp, list, argsv[i]); - } - Tcl_ObjSetVar2(interp, ordinaryArgsDefv[ordinaryArgsCounter], NULL, list, 0); - DECR_REF_COUNT(list); - } else { - /* break down this argument, if it has a default value, - use only the first part */ - ordinaryArg = ordinaryArgsDefv[ordinaryArgsCounter]; - r4 = Tcl_ListObjGetElements(interp, ordinaryArg, - &defaultValueObjc, &defaultValueObjv); - if (r4 == TCL_OK && defaultValueObjc == 2) { - ordinaryArg = defaultValueObjv[0]; - } - Tcl_ObjSetVar2(interp, ordinaryArg, NULL, argsv[i], 0); - } - ordinaryArgsCounter++; + if (endOfNonposArgsReached && i < argsc) { + if (ordinaryArgsCounter >= ordinaryArgsDefc) { + Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs); + XOTclVarErrMsg(interp, "unknown argument '", + ObjStr(argsv[i]), + "' for method '", + methodName, + "': valid arguments ", + ObjStr(tmp), + " ", + ObjStr(nonposArgs->ordinaryArgs), + (char *) NULL); + DECR_REF_COUNT(tmp); + return TCL_ERROR; + } + arg = ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]); + /* this is the last arg and 'args' is defined */ + if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) { + list = Tcl_NewListObj(0, NULL); + INCR_REF_COUNT(list); + for(; i < argsc; i++) + Tcl_ListObjAppendElement(interp, list, argsv[i]); + Tcl_ObjSetVar2(interp, ordinaryArgsDefv[ordinaryArgsCounter], NULL, list, 0); + DECR_REF_COUNT(list); + } else { + /* break down this argument, if it has a default value, + use only the first part */ + ordinaryArg = ordinaryArgsDefv[ordinaryArgsCounter]; + r4 = Tcl_ListObjGetElements(interp, ordinaryArg, + &defaultValueObjc, &defaultValueObjv); + if (r4 == TCL_OK && defaultValueObjc == 2) { + ordinaryArg = defaultValueObjv[0]; } + Tcl_ObjSetVar2(interp, ordinaryArg, NULL, argsv[i], 0); + } + ordinaryArgsCounter++; } + } - /*fprintf(stderr,"... args defined %d argsc=%d oa %d oad %d\n", - argsDefined, argsc, - ordinaryArgsCounter, ordinaryArgsDefc); */ + /*fprintf(stderr,"... args defined %d argsc=%d oa %d oad %d\n", + argsDefined, argsc, + ordinaryArgsCounter, ordinaryArgsDefc); */ - if ((!argsDefined && ordinaryArgsCounter != ordinaryArgsDefc) || - (argsDefined && ordinaryArgsCounter < ordinaryArgsDefc-1)) { + if ((!argsDefined && ordinaryArgsCounter != ordinaryArgsDefc) || + (argsDefined && ordinaryArgsCounter < ordinaryArgsDefc-1)) { - /* we do not have enough arguments, maybe there are default arguments - for the missing args */ - while (ordinaryArgsCounter != ordinaryArgsDefc) { - if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) - break; - r4 = Tcl_ListObjGetElements(interp, ordinaryArgsDefv[ordinaryArgsCounter], - &defaultValueObjc, &defaultValueObjv); - /*fprintf(stderr,"... try to get default for '%s', rc %d, objc %d\n", - ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]), - r4, defaultValueObjc);*/ - if (r4 == TCL_OK && defaultValueObjc == 2) { - Tcl_ObjSetVar2(interp, defaultValueObjv[0], NULL, defaultValueObjv[1], 0); - } else { - Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs); - XOTclVarErrMsg(interp, "wrong # args for method '", - methodName, "': valid arguments ", ObjStr(tmp), " ", - ObjStr(nonposArgs->ordinaryArgs), - (char *) NULL); - DECR_REF_COUNT(tmp); - return TCL_ERROR; - } - ordinaryArgsCounter++; - } - if (argsDefined) { - Tcl_SetVar2(interp, "args", NULL, "", 0); - } - } else if (argsDefined && ordinaryArgsCounter == ordinaryArgsDefc-1) { - Tcl_SetVar2(interp, "args", NULL, "", 0); + /* we do not have enough arguments, maybe there are default arguments + for the missing args */ + while (ordinaryArgsCounter != ordinaryArgsDefc) { + if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) + break; + r4 = Tcl_ListObjGetElements(interp, ordinaryArgsDefv[ordinaryArgsCounter], + &defaultValueObjc, &defaultValueObjv); + /*fprintf(stderr,"... try to get default for '%s', rc %d, objc %d\n", + ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]), + r4, defaultValueObjc);*/ + if (r4 == TCL_OK && defaultValueObjc == 2) { + Tcl_ObjSetVar2(interp, defaultValueObjv[0], NULL, defaultValueObjv[1], 0); + } else { + Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs); + XOTclVarErrMsg(interp, "wrong # args for method '", + methodName, "': valid arguments ", ObjStr(tmp), " ", + ObjStr(nonposArgs->ordinaryArgs), + (char *) NULL); + DECR_REF_COUNT(tmp); + return TCL_ERROR; + } + ordinaryArgsCounter++; } - - if (!argsDefined) { - Tcl_UnsetVar2(interp, "args", NULL, 0); + if (argsDefined) { + Tcl_SetVar2(interp, "args", NULL, "", 0); } + } else if (argsDefined && ordinaryArgsCounter == ordinaryArgsDefc-1) { + Tcl_SetVar2(interp, "args", NULL, "", 0); + } - /* checking vars */ - for (i=0; i < nonposArgsDefc; i++) { - r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); - if (r1 == TCL_OK && npac > 1 && *(ObjStr(npav[1])) != '\0') { - r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv); - if (r1 == TCL_OK) { - int checkResult = 0; - checkObj = nonposArgs->slotObj == NULL ? - XOTclGlobalObjects[XOTE_NON_POS_ARGS_OBJ] : - nonposArgs->slotObj; - for (j=0; j < checkc; j++) { - r1 = Tcl_ListObjGetElements(interp, checkv[j], &checkArgc, &checkArgv); - if (r1 == TCL_OK && checkArgc > 1) { - if (isCheckObjString((ObjStr(checkArgv[0]))) && checkArgc == 2) { - checkObj = checkArgv[1]; - continue; - } - } - invocation[0] = checkObj; - invocation[1] = checkv[j]; - varPtr = TclVarTraceExists(interp, ObjStr(npav[0])); - invocation[2] = npav[0]; - ic = 3; - if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { - invocation[3] = Tcl_ObjGetVar2(interp, npav[0], 0, 0); - ic = 4; - } - result = Tcl_EvalObjv(interp, ic, invocation, 0); - /* - objPtr = Tcl_ConcatObj(ic, invocation); - fprintf(stderr,"eval on <%s>\n", ObjStr(objPtr)); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); - */ - if (result == TCL_OK && ic == 4) { - result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp),&checkResult); - } - if (result != TCL_OK) { - return result; - } - if (!checkResult && ic == 4) { - return XOTclVarErrMsg(interp, - "non-positional argument: '", ObjStr(invocation[2]), "' with value '", - ObjStr(invocation[3]), "' is not of ", ObjStr(invocation[1]), - (char *) NULL); - } - } + if (!argsDefined) { + Tcl_UnsetVar2(interp, "args", NULL, 0); + } + + /* checking vars */ + for (i=0; i < nonposArgsDefc; i++) { + r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); + if (r1 == TCL_OK && npac > 1 && *(ObjStr(npav[1])) != '\0') { + r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv); + if (r1 == TCL_OK) { + int checkResult = 0; + checkObj = nonposArgs->slotObj == NULL ? + XOTclGlobalObjects[XOTE_NON_POS_ARGS_OBJ] : + nonposArgs->slotObj; + + for (j=0; j < checkc; j++) { + r1 = Tcl_ListObjGetElements(interp, checkv[j], &checkArgc, &checkArgv); + if (r1 == TCL_OK && checkArgc > 1) { + if (isCheckObjString((ObjStr(checkArgv[0]))) && checkArgc == 2) { + checkObj = checkArgv[1]; + continue; } + } + invocation[0] = checkObj; + invocation[1] = checkv[j]; + varPtr = TclVarTraceExists(interp, ObjStr(npav[0])); + invocation[2] = npav[0]; + ic = 3; + if (varPtr && !TclIsVarUndefined(varPtr)) { + invocation[3] = Tcl_ObjGetVar2(interp, npav[0], 0, 0); + ic = 4; + } + result = Tcl_EvalObjv(interp, ic, invocation, 0); + /* + objPtr = Tcl_ConcatObj(ic, invocation); + fprintf(stderr,"eval on <%s>\n", ObjStr(objPtr)); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + */ + if (result == TCL_OK && ic == 4) { + result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp),&checkResult); + } + if (result != TCL_OK) { + return result; + } + if (!checkResult && ic == 4) { + return XOTclVarErrMsg(interp, + "non-positional argument: '", ObjStr(invocation[2]), "' with value '", + ObjStr(invocation[3]), "' is not of ", ObjStr(invocation[1]), + (char *) NULL); + } } + } } - return TCL_OK; + } + return TCL_OK; } /* create a slave interp that calls XOTcl Init */ static int XOTcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Interp *slave; - char *subCmd; - ALLOC_ON_STACK(Tcl_Obj *, objc, ov); + Tcl_Interp *slave; + char *subCmd; + ALLOC_ON_STACK(Tcl_Obj*, objc, ov); - memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); - if (objc < 1) { - XOTclObjErrArgCnt(interp, objv[0], NULL, "name ?args?"); - goto interp_error; - } + memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); + if (objc < 1) { + XOTclObjErrArgCnt(interp, objv[0], NULL, "name ?args?"); + goto interp_error; + } - ov[0] = XOTclGlobalObjects[XOTE_INTERP]; - if (Tcl_EvalObjv(interp, objc, ov, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) { - goto interp_error; - } + ov[0] = XOTclGlobalObjects[XOTE_INTERP]; + if (Tcl_EvalObjv(interp, objc, ov, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) { + goto interp_error; + } - subCmd = ObjStr(ov[1]); - if (isCreateString(subCmd)) { - slave = Tcl_GetSlave(interp, ObjStr(ov[2])); - if (!slave) { - XOTclVarErrMsg(interp, "Creation of slave interpreter failed", (char *) NULL); - goto interp_error; - } - if (Xotcl_Init(slave) == TCL_ERROR) { - goto interp_error; - } + subCmd = ObjStr(ov[1]); + if (isCreateString(subCmd)) { + slave = Tcl_GetSlave(interp, ObjStr(ov[2])); + if (!slave) { + XOTclVarErrMsg(interp, "Creation of slave interpreter failed", (char *) NULL); + goto interp_error; + } + if (Xotcl_Init(slave) == TCL_ERROR) { + goto interp_error; + } #ifdef XOTCL_MEM_COUNT - xotclMemCountInterpCounter++; + xotclMemCountInterpCounter++; #endif - } - FREE_ON_STACK(ov); - return TCL_OK; + } + FREE_ON_STACK(ov); + return TCL_OK; interp_error: - FREE_ON_STACK(ov); - return TCL_ERROR; + FREE_ON_STACK(ov); + return TCL_ERROR; } - - #if !defined(NDEBUG) static void checkAllInstances(Tcl_Interp *interp, XOTclClass *cl, int lvl) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - if (cl && cl->object.refCount>0) { - /*fprintf(stderr,"checkallinstances %d cl=%p '%s'\n", lvl, cl, ObjStr(cl->object.cmdName));*/ - for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *interpst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr); - assert(inst); - assert(inst->refCount>0); - assert(inst->cmdName->refCount>0); - if (XOTclObjectIsClass(inst) && (XOTclClass*)inst != RUNTIME_STATE(interp)->theClass) { - checkAllInstances(interp, (XOTclClass*) inst, lvl+1); - } - } + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + if (cl && cl->object.refCount>0) { + /*fprintf(stderr,"checkallinstances %d cl=%p '%s'\n", lvl, cl, ObjStr(cl->object.cmdName));*/ + for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *interpst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr); + assert(inst); + assert(inst->refCount>0); + assert(inst->cmdName->refCount>0); + if (XOTclObjectIsClass(inst) && (XOTclClass*)inst != RUNTIME_STATE(interp)->theClass) { + checkAllInstances(interp, (XOTclClass*) inst, lvl+1); + } } + } } #endif #ifdef DO_FULL_CLEANUP /* delete global variables and procs */ -static void deleteProcsAndVars(Tcl_Interp *interp) { - Tcl_Namespace *ns = Tcl_GetGlobalNamespace(interp); - Tcl_HashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : NULL; - Tcl_HashTable *cmdTable = ns ? Tcl_Namespace_cmdTable(ns) : NULL; - Tcl_HashSearch search; - Var *varPtr; - Tcl_Command cmd; - register Tcl_HashEntry *entryPtr; - char *varName; +static void +deleteProcsAndVars(Tcl_Interp *interp) { + Tcl_Namespace *ns = Tcl_GetGlobalNamespace(interp); + Tcl_HashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : NULL; + Tcl_HashTable *cmdTable = ns ? Tcl_Namespace_cmdTable(ns) : NULL; + Tcl_HashSearch search; + Var *varPtr; + Tcl_Command cmd; + register Tcl_HashEntry *entryPtr; + char *varName; - entryPtr = Tcl_FirstHashEntry(varTable, &search); - while (entryPtr != NULL) { - Tcl_Obj *nameObj; - getVarAndNameFromHash(entryPtr, &varPtr, &nameObj); - if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { - /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/ - Tcl_UnsetVar2(interp, ObjStr(nameObj), (char *)NULL, TCL_GLOBAL_ONLY); - } - entryPtr = Tcl_NextHashEntry(&search); + for (entryPtr = Tcl_FirstHashEntry(varTable, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) { + Tcl_Obj *nameObj; + getVarAndNameFromHash(entryPtr, &varPtr, &nameObj); + if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { + /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/ + Tcl_UnsetVar2(interp, ObjStr(nameObj), (char *)NULL, TCL_GLOBAL_ONLY); } - entryPtr = Tcl_FirstHashEntry(cmdTable, &search); - while (entryPtr) { - cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); + } + for (entryPtr = Tcl_FirstHashEntry(cmdTable, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) { + cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { - char *key = Tcl_GetHashKey(cmdTable, entryPtr); + if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { + char *key = Tcl_GetHashKey(cmdTable, entryPtr); - /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n", - key, cmd, Tcl_Command_proc(cmd), Tcl_Command_objProc(cmd), - Tcl_Command_proc(cmd)==RUNTIME_STATE(interp)->objInterpProc);*/ + /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n", + key, cmd, Tcl_Command_proc(cmd), Tcl_Command_objProc(cmd), + Tcl_Command_proc(cmd)==RUNTIME_STATE(interp)->objInterpProc);*/ - Tcl_DeleteCommandFromToken(interp, cmd); - } - entryPtr = Tcl_NextHashEntry(&search); + Tcl_DeleteCommandFromToken(interp, cmd); } + } } #endif #ifdef DO_CLEANUP static int ClassHasSubclasses(XOTclClass *cl) { - return (cl->sub != NULL); + return (cl->sub != NULL); } static int ClassHasInstances(XOTclClass *cl) { - Tcl_HashSearch hSrch; - return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL); + Tcl_HashSearch hSrch; + return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL); } static int ObjectHasChildren(Tcl_Interp *interp, XOTclObject *obj) { - Tcl_Namespace *ns = obj->nsPtr; - int result = 0; + Tcl_Namespace *ns = obj->nsPtr; + int result = 0; - if (ns) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSrch; - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - XOTcl_FrameDecls; + if (ns) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSrch; + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + XOTcl_FrameDecls; - XOTcl_PushFrame(interp, obj); - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; - hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(cmdTable, hPtr); - if (XOTclpGetObject(interp, key)) { - /*fprintf(stderr,"child = %s\n", key);*/ - result = 1; - break; - } - } - XOTcl_PopFrame(interp, obj); + XOTcl_PushFrame(interp, obj); + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(cmdTable, hPtr); + if (XOTclpGetObject(interp, key)) { + /*fprintf(stderr,"child = %s\n", key);*/ + result = 1; + break; + } } - return result; + XOTcl_PopFrame(interp, obj); + } + return result; } -static void freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandTable) { - Tcl_HashEntry *hPtr, *hDel; - Tcl_HashSearch hSrch; - XOTclObject *obj; - XOTclClass *thecls, *theobj, *cl; +static void +freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandTable) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSrch; + XOTclObject *obj; + XOTclClass *thecls, *theobj, *cl; - /* fprintf(stderr,"??? freeAllXOTclObjectsAndClasses in %p\n", interp); */ + /* fprintf(stderr,"??? freeAllXOTclObjectsAndClasses in %p\n", interp); */ - thecls = RUNTIME_STATE(interp)->theClass; - theobj = RUNTIME_STATE(interp)->theObject; - /***** PHYSICAL DESTROY *****/ - RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; - while (1) { - int deleted = 0; - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - obj = XOTclpGetObject(interp, key); - if (obj && !XOTclObjectIsClass(obj) && !ObjectHasChildren(interp, obj)) { - /*fprintf(stderr," ... delete object %s %p, class=%s\n", key, obj, - ObjStr(obj->cl->object.cmdName));*/ - freeUnsetTraceVariable(interp, obj); - Tcl_DeleteCommandFromToken(interp, obj->id); - hDel = hPtr; - deleted++; - } else { - hDel = NULL; - } - hPtr = Tcl_NextHashEntry(&hSrch); - if (hDel) - Tcl_DeleteHashEntry(hDel); - } - /*fprintf(stderr, "deleted %d Objects\n", deleted);*/ - if (deleted>0) - continue; + thecls = RUNTIME_STATE(interp)->theClass; + theobj = RUNTIME_STATE(interp)->theObject; + /***** PHYSICAL DESTROY *****/ + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; + while (1) { + int deleted = 0; + for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + obj = XOTclpGetObject(interp, key); + if (obj && !XOTclObjectIsClass(obj) && !ObjectHasChildren(interp, obj)) { + /* fprintf(stderr," ... delete object %s %p, class=%s\n", key, obj, + ObjStr(obj->cl->object.cmdName));*/ + freeUnsetTraceVariable(interp, obj); + Tcl_DeleteCommandFromToken(interp, obj->id); + Tcl_DeleteHashEntry(hPtr); + deleted++; + } + } + /* fprintf(stderr, "deleted %d Objects\n", deleted);*/ + if (deleted > 0) { + continue; + } - - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - cl = XOTclpGetClass(interp, key); - /* fprintf(stderr,"cl key = %s %p\n", key, cl); */ - if (cl - && !ObjectHasChildren(interp, (XOTclObject*)cl) - && !ClassHasInstances(cl) - && !ClassHasSubclasses(cl) - && cl != RUNTIME_STATE(interp)->theClass - && cl != RUNTIME_STATE(interp)->theObject - ) { - /* fprintf(stderr," ... delete class %s %p\n", key, cl); */ - freeUnsetTraceVariable(interp, &cl->object); - Tcl_DeleteCommandFromToken(interp, cl->object.id); - hDel = hPtr; - deleted++; - } else { - hDel = NULL; - } - hPtr = Tcl_NextHashEntry(&hSrch); - if (hDel) - Tcl_DeleteHashEntry(hDel); - } - /* fprintf(stderr, "deleted %d Classes\n", deleted);*/ - if (deleted == 0) { - break; - } + for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + cl = XOTclpGetClass(interp, key); + /* fprintf(stderr,"cl key = %s %p\n", key, cl); */ + if (cl + && !ObjectHasChildren(interp, (XOTclObject*)cl) + && !ClassHasInstances(cl) + && !ClassHasSubclasses(cl) + && cl != RUNTIME_STATE(interp)->theClass + && cl != RUNTIME_STATE(interp)->theObject + ) { + /* fprintf(stderr," ... delete class %s %p\n", key, cl); */ + freeUnsetTraceVariable(interp, &cl->object); + Tcl_DeleteCommandFromToken(interp, cl->object.id); + Tcl_DeleteHashEntry(hPtr); + deleted++; + } } + /* fprintf(stderr, "deleted %d Classes\n", deleted);*/ + if (deleted == 0) { + break; + } + } #ifdef DO_FULL_CLEANUP - deleteProcsAndVars(interp); + deleteProcsAndVars(interp); #endif - RUNTIME_STATE(interp)->callDestroy = 0; - RemoveSuper(thecls, theobj); - RemoveInstance((XOTclObject*)thecls, thecls); - RemoveInstance((XOTclObject*)theobj, thecls); + RUNTIME_STATE(interp)->callDestroy = 0; + RemoveSuper(thecls, theobj); + RemoveInstance((XOTclObject*)thecls, thecls); + RemoveInstance((XOTclObject*)theobj, thecls); - Tcl_DeleteCommandFromToken(interp, theobj->object.id); - RUNTIME_STATE(interp)->theObject = NULL; + Tcl_DeleteCommandFromToken(interp, theobj->object.id); + RUNTIME_STATE(interp)->theObject = NULL; - Tcl_DeleteCommandFromToken(interp, thecls->object.id); - RUNTIME_STATE(interp)->theClass = NULL; + Tcl_DeleteCommandFromToken(interp, thecls->object.id); + RUNTIME_STATE(interp)->theClass = NULL; - XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->fakeNS); - XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclClassesNS); - XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->fakeNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclClassesNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclNS); } #endif /* DO_CLEANUP */ - -/* - * Exit Handler +/* + * ::xotcl::finalize command */ -static void -ExitHandler(ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *) clientData; - XOTclObject *obj; - XOTclClass *cl; - int result, flags, i; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - Tcl_HashTable objTable, *commandTable = &objTable; - XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; +static int +XOTclFinalizeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclClass *cl; + int result; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + Tcl_HashTable objTable, *commandTable = &objTable; - /* - * Don't use exit handler, if the interpreted is destroyed already - * Call to exit handler comes after freeing namespaces, commands, etc. - * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed - */ + /* fprintf(stderr,"+++ call EXIT handler\n"); */ - /* - * Ahem ... - * - * Since we *must* be sure that our destroy methods will run - * we must *cheat* (I mean CHEAT) here: we flip the interp - * flag, saying, "hey boy, you're not deleted any more". - * After our handlers are done, we restore the old state... - * All this is needed so we can do an eval in the interp which - * is potentially marked for delete when we start working here. - * - * I know, I know, this is not really elegant. But... I'd need a - * standard way of invoking some code at interpreter delete time - * but JUST BEFORE the actual deletion process starts. Sadly, - * there is no such hook in Tcl as of Tcl8.3.2, that I know of. - * - * So, for the rest of procedure, assume the interp is alive ! - */ - - /*fprintf(stderr,"+++ EXIT handler\n"); */ - flags = Tcl_Interp_flags(interp); - Tcl_Interp_flags(interp) &= ~DELETED; #if defined(PROFILE) - XOTclProfilePrintData(interp); + XOTclProfilePrintData(interp); #endif - /* - * evaluate user-defined exit handler - */ - result = Tcl_Eval(interp, "::xotcl::__exitHandler"); - if (result != TCL_OK) { - fprintf(stderr,"User defined exit handler contains errors!\n" - "Error in line %d: %s\nExecution interrupted.\n", - interp->errorLine, ObjStr(Tcl_GetObjResult(interp))); - } - /* - * Pop any callstack entry that is still alive (e.g. - * if "exit" is called and we were jumping out of the - * callframe - */ - while (cs->top > cs->content) - CallStackPop(interp); + /* + * evaluate user-defined exit handler + */ + result = Tcl_Eval(interp, "::xotcl::__exitHandler"); - while (1) { - Tcl_CallFrame *f = Tcl_Interp_framePtr(interp); - if (!f) break; - if (Tcl_CallFrame_level(f) == 0) break; - Tcl_PopCallFrame(interp); - } + if (result != TCL_OK) { + fprintf(stderr,"User defined exit handler contains errors!\n" + "Error in line %d: %s\nExecution interrupted.\n", + interp->errorLine, ObjStr(Tcl_GetObjResult(interp))); + } - /* deleting in two rounds: - * (a) SOFT DESTROY: call all user-defined destroys - * (b) PHYSICAL DESTROY: delete the commands, user-defined - * destroys are not executed anymore - * - * this is to prevent user-defined destroys from overriding physical - * destroy during exit handler, but still ensure that all - * user-defined destroys are called. - */ + /* deleting in two rounds: + * (a) SOFT DESTROY: call all user-defined destroys + * (b) PHYSICAL DESTROY: delete the commands, user-defined + * destroys are not executed anymore + * + * this is to prevent user-defined destroys from overriding physical + * destroy during exit handler, but still ensure that all + * user-defined destroys are called. + */ - Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - getAllInstances(interp, commandTable, RUNTIME_STATE(interp)->theClass, 0); + Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + getAllInstances(interp, commandTable, RUNTIME_STATE(interp)->theObject); + /***** SOFT DESTROY *****/ + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; - /***** SOFT DESTROY *****/ - RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; - - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - obj = XOTclpGetObject(interp, key); - /*fprintf(stderr,"key = %s %p %d\n", - key, obj, obj && !XOTclObjectIsClass(obj));*/ - if (obj && !XOTclObjectIsClass(obj) - && !(obj->flags & XOTCL_DESTROY_CALLED)) - callDestroyMethod((ClientData)obj, interp, obj, XOTCL_CM_NO_UNKNOWN); - hPtr = Tcl_NextHashEntry(&hSrch); + for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + obj = XOTclpGetObject(interp, key); + /* fprintf(stderr,"key = %s %p %d\n", + key, obj, obj && !XOTclObjectIsClass(obj)); */ + if (obj && !XOTclObjectIsClass(obj) + && !(obj->flags & XOTCL_DESTROY_CALLED)) { + callDestroyMethod((ClientData)obj, interp, obj, 0); } + } - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - cl = XOTclpGetClass(interp, key); - if (cl - && !(cl->object.flags & XOTCL_DESTROY_CALLED)) { - /*fprintf(stderr,"call destroy key = %s, cl = %p\n", key, cl);*/ - callDestroyMethod((ClientData)cl, interp, (XOTclObject*)cl, XOTCL_CM_NO_UNKNOWN); - } - hPtr = Tcl_NextHashEntry(&hSrch); + for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + cl = XOTclpGetClass(interp, key); + if (cl && !(cl->object.flags & XOTCL_DESTROY_CALLED)) { + callDestroyMethod((ClientData)cl, interp, (XOTclObject *)cl, 0); } + } #ifdef DO_CLEANUP - freeAllXOTclObjectsAndClasses(interp, commandTable); + freeAllXOTclObjectsAndClasses(interp, commandTable); #endif - /* must be before freeing of XOTclGlobalObjects */ - XOTclShadowTclCommands(interp, SHADOW_UNLOAD); - /* free global objects */ - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - DECR_REF_COUNT(XOTclGlobalObjects[i]); - } - XOTclStringIncrFree(&RUNTIME_STATE(interp)->iss); - FREE(Tcl_Obj **, XOTclGlobalObjects); - FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + Tcl_DeleteHashTable(commandTable); - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); - Tcl_DeleteHashTable(commandTable); + return TCL_OK; +} + +/* + * Exit Handler + */ +static void +ExitHandler(ClientData clientData) { + Tcl_Interp *interp = (Tcl_Interp *)clientData; + int i, flags; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + + /* + * Don't use exit handler, if the interpreted is destroyed already + * Call to exit handler comes after freeing namespaces, commands, etc. + * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed + */ + + /* + * Ahem ... + * + * Since we *must* be sure that our destroy methods will run + * we must *cheat* (I mean CHEAT) here: we flip the interp + * flag, saying, "hey boy, you're not deleted any more". + * After our handlers are done, we restore the old state... + * All this is needed so we can do an eval in the interp which + * is potentially marked for delete when we start working here. + * + * I know, I know, this is not really elegant. But... I'd need a + * standard way of invoking some code at interpreter delete time + * but JUST BEFORE the actual deletion process starts. Sadly, + * there is no such hook in Tcl as of Tcl8.3.2, that I know of. + * + * So, for the rest of procedure, assume the interp is alive ! + */ + flags = Tcl_Interp_flags(interp); + Tcl_Interp_flags(interp) &= ~DELETED; + + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { + XOTclFinalizeObjCmd(NULL, interp, 0, NULL); + } + + /* + * Pop any callstack entry that is still alive (e.g. + * if "exit" is called and we were jumping out of the + * callframe + */ + while (cs->top > cs->content) + CallStackPop(interp); + + while (1) { + Tcl_CallFrame *f = Tcl_Interp_framePtr(interp); + if (!f) break; + if (Tcl_CallFrame_level(f) == 0) break; + Tcl_PopCallFrame(interp); + } + + /* must be before freeing of XOTclGlobalObjects */ + XOTclShadowTclCommands(interp, SHADOW_UNLOAD); + + /* free global objects */ + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + DECR_REF_COUNT(XOTclGlobalObjects[i]); + } + XOTclStringIncrFree(&RUNTIME_STATE(interp)->iss); + #if defined(TCL_MEM_DEBUG) - TclDumpMemoryInfo(stderr); - Tcl_DumpActiveMemory("./xotclActiveMem"); - /* Tcl_GlobalEval(interp, "puts {checkmem to checkmemFile}; - checkmem checkmemFile"); */ + TclDumpMemoryInfo(stderr); + Tcl_DumpActiveMemory("./xotclActiveMem"); + /* Tcl_GlobalEval(interp, "puts {checkmem to checkmemFile}; + checkmem checkmemFile"); */ #endif - MEM_COUNT_DUMP(); - - Tcl_Interp_flags(interp) = flags; - Tcl_Release((ClientData) interp); + MEM_COUNT_DUMP(); + + FREE(Tcl_Obj**, XOTclGlobalObjects); + FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); + + Tcl_Interp_flags(interp) = flags; + Tcl_Release((ClientData) interp); } @@ -13753,12 +14605,13 @@ */ static void XOTcl_ThreadExitProc(ClientData clientData) { - /*fprintf(stderr,"+++ XOTcl_ThreadExitProc\n");*/ -#if !defined(PRE83) - void XOTcl_ExitProc(ClientData clientData); - Tcl_DeleteExitHandler(XOTcl_ExitProc, clientData); -#endif - ExitHandler(clientData); + /*fprintf(stderr,"+++ XOTcl_ThreadExitProc\n");*/ + +# if !defined(PRE83) + void XOTcl_ExitProc(ClientData clientData); + Tcl_DeleteExitHandler(XOTcl_ExitProc, clientData); +# endif + ExitHandler(clientData); } #endif @@ -13767,11 +14620,11 @@ */ void XOTcl_ExitProc(ClientData clientData) { - /*fprintf(stderr,"+++ XOTcl_ExitProc\n");*/ + /*fprintf(stderr,"+++ XOTcl_ExitProc\n");*/ #if !defined(PRE83) && defined(TCL_THREADS) - Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, clientData); + Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, clientData); #endif - ExitHandler(clientData); + ExitHandler(clientData); } @@ -13780,58 +14633,58 @@ */ static void RegisterExitHandlers(ClientData clientData) { - Tcl_Preserve(clientData); + Tcl_Preserve(clientData); #if !defined(PRE83) && defined(TCL_THREADS) - Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, clientData); + Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, clientData); #endif - Tcl_CreateExitHandler(XOTcl_ExitProc, clientData); + Tcl_CreateExitHandler(XOTcl_ExitProc, clientData); } int XOTclCreateObjectSystem(Tcl_Interp *interp, char *Object, char *Class) { - XOTclClass *theobj = 0; - XOTclClass *thecls = 0; + XOTclClass *theobj = 0; + XOTclClass *thecls = 0; - /* create Object and Class, and store them in the RUNTIME STATE */ - theobj = PrimitiveCCreate(interp, Object, 0); - RUNTIME_STATE(interp)->theObject = theobj; - if (!theobj) panic("Cannot create base Object class", 0); + /* create Object and Class, and store them in the RUNTIME STATE */ + theobj = PrimitiveCCreate(interp, Object, 0); + RUNTIME_STATE(interp)->theObject = theobj; + if (!theobj) panic("Cannot create base Object class", 0); - thecls = PrimitiveCCreate(interp, Class, 0); - RUNTIME_STATE(interp)->theClass = thecls; - if (!thecls) panic("Cannot create base Class", 0); + thecls = PrimitiveCCreate(interp, Class, 0); + RUNTIME_STATE(interp)->theClass = thecls; + if (!thecls) panic("Cannot create base Class", 0); - /*theobj->parent = 0; - thecls->parent = theobj;*/ + /*theobj->parent = 0; + thecls->parent = theobj;*/ - /*Tcl_AddInterpResolvers(interp, "XOTcl", XOTclResolveCmd, 0, 0);*/ + /*Tcl_AddInterpResolvers(interp, "XOTcl", XOTclResolveCmd, 0, 0);*/ #if defined(PROFILE) - XOTclProfileInit(interp); + XOTclProfileInit(interp); #endif - /* test Object and Class creation */ - if (!theobj || !thecls) { - int i; - RUNTIME_STATE(interp)->callDestroy = 0; + /* test Object and Class creation */ + if (!theobj || !thecls) { + int i; + RUNTIME_STATE(interp)->callDestroy = 0; - if (thecls) PrimitiveCDestroy((ClientData) thecls); - if (theobj) PrimitiveCDestroy((ClientData) theobj); + if (thecls) PrimitiveCDestroy((ClientData) thecls); + if (theobj) PrimitiveCDestroy((ClientData) theobj); - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - DECR_REF_COUNT(XOTclGlobalObjects[i]); - } - FREE(Tcl_Obj **, XOTclGlobalObjects); - FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); - - return XOTclErrMsg(interp, "Object/Class failed", TCL_STATIC); + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + DECR_REF_COUNT(XOTclGlobalObjects[i]); } + FREE(Tcl_Obj **, XOTclGlobalObjects); + FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); - AddInstance((XOTclObject*)theobj, thecls); - AddInstance((XOTclObject*)thecls, thecls); - AddSuper(thecls, theobj); + return XOTclErrMsg(interp, "Object/Class failed", TCL_STATIC); + } + + AddInstance((XOTclObject*)theobj, thecls); + AddInstance((XOTclObject*)thecls, thecls); + AddSuper(thecls, theobj); - return TCL_OK; + return TCL_OK; } @@ -13842,390 +14695,420 @@ extern int Xotcl_Init(Tcl_Interp *interp) { - ClientData runtimeState; - int result, i; + ClientData runtimeState; + int result, i; #ifdef XOTCL_BYTECODE - XOTclCompEnv *interpstructions = XOTclGetCompEnv(); + XOTclCompEnv *interpstructions = XOTclGetCompEnv(); #endif #ifndef PRE81 # ifdef USE_TCL_STUBS - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { - return TCL_ERROR; - } + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } # endif #endif #if defined(TCL_MEM_DEBUG) - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo(stderr); #endif - MEM_COUNT_INIT(); + MEM_COUNT_INIT(); - /* - fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n", sizeof(XOTclObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(XOTclClass), sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable)); - */ + /* + fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n", sizeof(XOTclObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(XOTclClass), sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable)); + */ #if FORWARD_COMPATIBLE - { - int major, minor, patchlvl, type; - Tcl_GetVersion(&major, &minor, &patchlvl, &type); + { + int major, minor, patchlvl, type; + Tcl_GetVersion(&major, &minor, &patchlvl, &type); - if ((major == 8) && (minor < 5)) { - /* - * loading a version of xotcl compiled for 8.4 version - * into a 8.4 Tcl - */ - fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.4 Tcl\n"); - forwardCompatibleMode = 0; - lookupVarFromTable = LookupVarFromTable84; - tclVarHashCreateVar = VarHashCreateVar84; - tclInitVarHashTable = InitVarHashTable84; - tclCleanupVar = TclCleanupVar84; - varRefCountOffset = TclOffset(Var, refCount); - varHashTableSize = sizeof(Tcl_HashTable); - } else { - /* - * loading a version of xotcl compiled for 8.4 version - * into a 8.5 Tcl - */ - fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.5 Tcl\n"); - forwardCompatibleMode = 1; - lookupVarFromTable = LookupVarFromTable85; - tclVarHashCreateVar = VarHashCreateVar85; - tclInitVarHashTable = (Tcl_InitVarHashTableFunction*)*((&tclIntStubsPtr->reserved0)+235); - tclCleanupVar = (Tcl_CleanupVarFunction*)*((&tclIntStubsPtr->reserved0)+176); - varRefCountOffset = TclOffset(VarInHash, refCount); - varHashTableSize = sizeof(TclVarHashTable85); - } - + if ((major == 8) && (minor < 5)) { + /* + * loading a version of xotcl compiled for 8.4 version + * into a 8.4 Tcl + */ + /* + fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.4 Tcl\n"); + */ + forwardCompatibleMode = 0; + lookupVarFromTable = LookupVarFromTable84; + tclVarHashCreateVar = VarHashCreateVar84; + tclInitVarHashTable = InitVarHashTable84; + tclCleanupVar = TclCleanupVar84; + varRefCountOffset = TclOffset(Var, refCount); + varHashTableSize = sizeof(Tcl_HashTable); + } else { + /* + * loading a version of xotcl compiled for 8.4 version + * into a 8.5 Tcl + */ + /* + fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.5 Tcl\n"); + */ + forwardCompatibleMode = 1; + lookupVarFromTable = LookupVarFromTable85; + tclVarHashCreateVar = VarHashCreateVar85; + tclInitVarHashTable = (Tcl_InitVarHashTableFunction*)*((&tclIntStubsPtr->reserved0)+235); + tclCleanupVar = (Tcl_CleanupVarFunction*)*((&tclIntStubsPtr->reserved0)+176); + varRefCountOffset = TclOffset(VarInHash, refCount); + varHashTableSize = sizeof(TclVarHashTable85); } + + } #endif - /* - * Runtime State stored in the client data of the Interp's global - * Namespace in order to avoid global state information - */ - runtimeState = (ClientData) NEW(XOTclRuntimeState); + /* + * Runtime State stored in the client data of the Interp's global + * Namespace in order to avoid global state information + */ + runtimeState = (ClientData) NEW(XOTclRuntimeState); #if USE_ASSOC_DATA - Tcl_SetAssocData(interp, "XOTclRuntimeState", NULL, runtimeState); + Tcl_SetAssocData(interp, "XOTclRuntimeState", NULL, runtimeState); #else - Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState; + Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState; #endif - /* CallStack initialization */ - memset(RUNTIME_STATE(interp), 0, sizeof(XOTclRuntimeState)); - memset(RUNTIME_STATE(interp)->cs.content, 0, sizeof(XOTclCallStackContent)); + /* CallStack initialization */ + memset(RUNTIME_STATE(interp), 0, sizeof(XOTclRuntimeState)); + memset(RUNTIME_STATE(interp)->cs.content, 0, sizeof(XOTclCallStackContent)); - RUNTIME_STATE(interp)->cs.top = RUNTIME_STATE(interp)->cs.content; - RUNTIME_STATE(interp)->doFilters = 1; - RUNTIME_STATE(interp)->callDestroy = 1; + RUNTIME_STATE(interp)->cs.top = RUNTIME_STATE(interp)->cs.content; + RUNTIME_STATE(interp)->doFilters = 1; + RUNTIME_STATE(interp)->callDestroy = 1; - /* create xotcl namespace */ - RUNTIME_STATE(interp)->XOTclNS = - Tcl_CreateNamespace(interp, "::xotcl", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); + /* create xotcl namespace */ + RUNTIME_STATE(interp)->XOTclNS = + Tcl_CreateNamespace(interp, "::xotcl", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); - MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclNS); + MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclNS); - /* - * init an empty, faked proc structure in the RUNTIME state - */ - RUNTIME_STATE(interp)->fakeProc.iPtr = (Interp *)interp; - RUNTIME_STATE(interp)->fakeProc.refCount = 1; - RUNTIME_STATE(interp)->fakeProc.cmdPtr = NULL; - RUNTIME_STATE(interp)->fakeProc.bodyPtr = NULL; - RUNTIME_STATE(interp)->fakeProc.numArgs = 0; - RUNTIME_STATE(interp)->fakeProc.numCompiledLocals = 0; - RUNTIME_STATE(interp)->fakeProc.firstLocalPtr = NULL; - RUNTIME_STATE(interp)->fakeProc.lastLocalPtr = NULL; - RUNTIME_STATE(interp)->fakeNS = - Tcl_CreateNamespace(interp, "::xotcl::fakeNS", (ClientData)NULL, - (Tcl_NamespaceDeleteProc *)NULL); - MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->fakeNS); + /* + * init an empty, faked proc structure in the RUNTIME state + */ + RUNTIME_STATE(interp)->fakeProc.iPtr = (Interp *)interp; + RUNTIME_STATE(interp)->fakeProc.refCount = 1; + RUNTIME_STATE(interp)->fakeProc.cmdPtr = NULL; + RUNTIME_STATE(interp)->fakeProc.bodyPtr = NULL; + RUNTIME_STATE(interp)->fakeProc.numArgs = 0; + RUNTIME_STATE(interp)->fakeProc.numCompiledLocals = 0; + RUNTIME_STATE(interp)->fakeProc.firstLocalPtr = NULL; + RUNTIME_STATE(interp)->fakeProc.lastLocalPtr = NULL; + RUNTIME_STATE(interp)->fakeNS = + Tcl_CreateNamespace(interp, "::xotcl::fakeNS", (ClientData)NULL, + (Tcl_NamespaceDeleteProc*)NULL); + MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->fakeNS); - /* XOTclClasses in separate Namespace / Objects */ - RUNTIME_STATE(interp)->XOTclClassesNS = - Tcl_CreateNamespace(interp, "::xotcl::classes", (ClientData)NULL, - (Tcl_NamespaceDeleteProc *)NULL); - MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclClassesNS); + /* XOTclClasses in separate Namespace / Objects */ + RUNTIME_STATE(interp)->XOTclClassesNS = + Tcl_CreateNamespace(interp, "::xotcl::classes", (ClientData)NULL, + (Tcl_NamespaceDeleteProc*)NULL); + MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclClassesNS); - /* cache interpreters proc interpretation functions */ - RUNTIME_STATE(interp)->objInterpProc = TclGetObjInterpProc(); + /* cache interpreters proc interpretation functions */ + RUNTIME_STATE(interp)->objInterpProc = TclGetObjInterpProc(); #if USE_INTERP_PROC - RUNTIME_STATE(interp)->interpProc = TclGetInterpProc(); + RUNTIME_STATE(interp)->interpProc = TclGetInterpProc(); #endif - RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF; + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF; - RegisterObjTypes(); - RegisterExitHandlers((ClientData)interp); + RegisterObjTypes(); + RegisterExitHandlers((ClientData)interp); - XOTclStringIncrInit(&RUNTIME_STATE(interp)->iss); + XOTclStringIncrInit(&RUNTIME_STATE(interp)->iss); - /* initialize global Tcl_Obj */ - XOTclGlobalObjects = NEW_ARRAY(Tcl_Obj *, nr_elements(XOTclGlobalStrings)); + /* initialize global Tcl_Obj */ + XOTclGlobalObjects = NEW_ARRAY(Tcl_Obj*, nr_elements(XOTclGlobalStrings)); - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - XOTclGlobalObjects[i] = Tcl_NewStringObj(XOTclGlobalStrings[i],-1); - INCR_REF_COUNT(XOTclGlobalObjects[i]); - } + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + XOTclGlobalObjects[i] = Tcl_NewStringObj(XOTclGlobalStrings[i],-1); + INCR_REF_COUNT(XOTclGlobalObjects[i]); + } + #if defined(OO) Tcl_CreateNamespace(interp, "::oo", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); XOTclCreateObjectSystem(interp, "::oo::object", "::oo::class"); #else XOTclCreateObjectSystem(interp, "::xotcl::Object", "::xotcl::Class"); #endif - - { - typedef struct methodDefinition { - char *methodName; - Tcl_ObjCmdProc *proc; - } methodDefinition; - - char *namespace_names[] = { - "::xotcl::cmd::Object", - "::xotcl::cmd::Class", - "::xotcl::cmd::NonposArgs", - "::xotcl::cmd::ObjectInfo", - "::xotcl::cmd::ClassInfo" - }; - - methodDefinition definitions1[] = { - {"autoname", XOTclOAutonameMethod}, - {"check", XOTclOCheckMethod}, - {"cleanup", XOTclOCleanupMethod}, - {"configure", XOTclOConfigureMethod}, - {"destroy", XOTclODestroyMethod}, - {"exists", XOTclOExistsMethod}, - {"filterguard", XOTclOFilterGuardMethod}, - {"filtersearch", XOTclOFilterSearchMethod}, - {"info", XOTclOInfoMethod}, - {"instvar", XOTclOInstVarMethod}, - {"invar", XOTclOInvariantsMethod}, - {"isclass", XOTclOIsClassMethod}, - {"ismetaclass", XOTclOIsMetaClassMethod}, - {"isobject", XOTclOIsObjectMethod}, - {"istype", XOTclOIsTypeMethod}, - {"ismixin", XOTclOIsMixinMethod}, + { + typedef struct methodDefinition { + char *methodName; + Tcl_ObjCmdProc *proc; + } methodDefinition; + + char *namespace_names[] = { + "::xotcl::cmd::Object", + "::xotcl::cmd::Class", + "::xotcl::cmd::NonposArgs", + "::xotcl::cmd::ObjectInfo", + "::xotcl::cmd::ClassInfo" + }; + methodDefinition definitions1[] = { + {"autoname", XOTclOAutonameMethod}, + {"check", XOTclOCheckMethod}, + {"cleanup", XOTclOCleanupMethod}, + {"configure", XOTclOConfigureMethod}, + {"destroy", XOTclODestroyMethod}, + {"exists", XOTclOExistsMethod}, + {"filterguard", XOTclOFilterGuardMethod}, + {"filtersearch", XOTclOFilterSearchMethod}, + {"info", XOTclOInfoMethod}, + {"instvar", XOTclOInstVarMethod}, + {"invar", XOTclOInvariantsMethod}, + {"isclass", XOTclOIsClassMethod}, + {"ismetaclass", XOTclOIsMetaClassMethod}, + {"isobject", XOTclOIsObjectMethod}, + {"istype", XOTclOIsTypeMethod}, + {"ismixin", XOTclOIsMixinMethod}, #ifdef XOTCL_METADATA - {"metadata", XOTclOMetaDataMethod}, + {"metadata", XOTclOMetaDataMethod}, #endif - {"mixinguard", XOTclOMixinGuardMethod}, - {"__next", XOTclONextMethod}, - /* {"next", XOTclONextMethod2},*/ - {"noinit", XOTclONoinitMethod}, - {"parametercmd", XOTclCParameterCmdMethod}, - {"proc", XOTclOProcMethod}, - {"procsearch", XOTclOProcSearchMethod}, - {"requireNamespace", XOTclORequireNamespaceMethod}, - {"set", XOTclOSetMethod}, /***??**/ - {"setvalues", XOTclOSetvaluesMethod}, - {"forward", XOTclOForwardMethod}, - {"uplevel", XOTclOUplevelMethod}, - {"upvar", XOTclOUpvarMethod}, - {"volatile", XOTclOVolatileMethod}, - {"vwait", XOTclOVwaitMethod} - }; - methodDefinition definitions2[] = { - {"alloc", XOTclCAllocMethod}, - {"create", XOTclCCreateMethod}, - {"dealloc", XOTclCInstDestroyMethod}, - {"new", XOTclCNewMethod}, - {"info", XOTclCInfoMethod}, - {"instdestroy", XOTclCInstDestroyMethod}, - {"instfilterguard", XOTclCInstFilterGuardMethod}, - {"instinvar", XOTclCInvariantsMethod}, - {"instmixinguard", XOTclCInstMixinGuardMethod}, - {"instparametercmd", XOTclCInstParameterCmdMethod}, - {"instproc", XOTclCInstProcMethod}, - {"classscopedinstproc", XOTclCInstProcMethodC}, - {"instforward", XOTclCInstForwardMethod}, - {"recreate", XOTclCRecreateMethod}, - {"unknown", XOTclCUnknownMethod} - }; - methodDefinition definitions3[] = { - {"type=required", XOTclCheckRequiredArgs}, - {"type=switch", XOTclCheckBooleanArgs}, - {"type=boolean", XOTclCheckBooleanArgs} - }; + {"mixinguard", XOTclOMixinGuardMethod}, + {"__next", XOTclONextMethod}, + /* {"next", XOTclONextMethod2},*/ + {"noinit", XOTclONoinitMethod}, + {"parametercmd", XOTclCParameterCmdMethod}, + {"proc", XOTclOProcMethod}, + {"procsearch", XOTclOProcSearchMethod}, + {"requireNamespace", XOTclORequireNamespaceMethod}, + {"set", XOTclOSetMethod}, /***??**/ + {"setvalues", XOTclOSetvaluesMethod}, + {"forward", XOTclOForwardMethod}, + {"uplevel", XOTclOUplevelMethod}, + {"upvar", XOTclOUpvarMethod}, + {"volatile", XOTclOVolatileMethod}, + {"vwait", XOTclOVwaitMethod} + }; + + methodDefinition definitions2[] = { + {"alloc", XOTclCAllocMethod}, + {"create", XOTclCCreateMethod}, + {"dealloc", XOTclCInstDestroyMethod}, + {"new", XOTclCNewMethod}, + {"info", XOTclCInfoMethod}, + {"instdestroy", XOTclCInstDestroyMethod}, + {"instfilterguard", XOTclCInstFilterGuardMethod}, + {"instinvar", XOTclCInvariantsMethod}, + {"instmixinguard", XOTclCInstMixinGuardMethod}, + {"instparametercmd", XOTclCInstParameterCmdMethod}, + {"instproc", XOTclCInstProcMethod}, + {"classscopedinstproc", XOTclCInstProcMethodC}, + {"instforward", XOTclCInstForwardMethod}, + {"recreate", XOTclCRecreateMethod}, + {"unknown", XOTclCUnknownMethod} + }; + methodDefinition definitions3[] = { + {"type=required", XOTclCheckRequiredArgs}, + {"type=switch", XOTclCheckBooleanArgs}, + {"type=boolean", XOTclCheckBooleanArgs} + }; + methodDefinition definitions4[] = { + {"args", XOTclObjInfoArgsMethod}, + {"body", XOTclObjInfoBodyMethod}, + {"class", XOTclObjInfoClassMethod}, + {"commands", XOTclObjInfoCommandsMethod}, + {"children", XOTclObjInfoChildrenMethod}, + {"check", XOTclObjInfoCheckMethod}, + {"default", XOTclObjInfoDefaultMethod}, + {"filter", XOTclObjInfoFilterMethod}, + {"filterguard", XOTclObjInfoFilterguardMethod}, + {"forward", XOTclObjInfoForwardMethod}, + {"hasNamespace", XOTclObjInfoHasnamespaceMethod}, + /*{"info", XOTclObjInfoInfoMethod},*/ + {"invar", XOTclObjInfoInvarMethod}, + {"methods", XOTclObjInfoMethodsMethod}, + {"mixin", XOTclObjInfoMixinMethod}, + {"mixinguard", XOTclObjInfoMixinguardMethod}, + {"methods", XOTclObjInfoMethodsMethod}, + {"nonposargs", XOTclObjInfoNonposargsMethod}, + {"parent", XOTclObjInfoParentMethod}, + {"post", XOTclObjInfoPostMethod}, + {"pre", XOTclObjInfoPreMethod}, + {"procs", XOTclObjInfoProcsMethod}, + {"precedence", XOTclObjInfoPrecedenceMethod}, + {"slotobjects", XOTclObjInfoSlotObjectsMethod}, + {"vars", XOTclObjInfoVarsMethod} + }; + methodDefinition definitions5[] = { + {"heritage", XOTclClassInfoHeritageMethod}, + {"instances", XOTclClassInfoInstancesMethod}, + {"instargs", XOTclClassInfoInstargsMethod}, + {"instbody", XOTclClassInfoInstbodyMethod}, + {"instcommands", XOTclClassInfoInstcommandsMethod}, + {"instdefault", XOTclClassInfoInstdefaultMethod}, + {"instfilter", XOTclClassInfoInstfilterMethod}, + {"instfilterguard", XOTclClassInfoInstfilterguardMethod}, + {"instforward", XOTclClassInfoInstforwardMethod}, + {"instinvar", XOTclClassInfoInstinvarMethod}, + {"instmixin", XOTclClassInfoInstmixinMethod}, + {"instmixinguard", XOTclClassInfoInstmixinguardMethod}, + {"instprocs", XOTclClassInfoInstprocsMethod}, + {"instnonposargs", XOTclClassInfoInstnonposargsMethod}, + {"instpre", XOTclClassInfoInstpreMethod}, + {"instpost", XOTclClassInfoInstpostMethod}, + {"parameter", XOTclClassInfoParameterMethod}, + {"subclass", XOTclClassInfoSubclassMethod}, + {"superclass", XOTclClassInfoSuperclassMethod}, + {"slots", XOTclClassInfoSlotsMethod} + }; + + methodDefinition *definitions[] = {definitions1, definitions2, definitions3, + definitions4, definitions5}; + int nr_definitions[] = {nr_elements(definitions1), nr_elements(definitions2), + nr_elements(definitions3), nr_elements(definitions4), + nr_elements(definitions5)}; + + int namespacelength; + Tcl_DString ds, *dsPtr = &ds; - methodDefinition definitions4[] = { - {"args", XOTclObjInfoArgsMethod}, - {"body", XOTclObjInfoBodyMethod}, - {"class", XOTclObjInfoClassMethod}, - {"commands", XOTclObjInfoCommandsMethod}, - {"children", XOTclObjInfoChildrenMethod}, - {"check", XOTclObjInfoCheckMethod}, - {"default", XOTclObjInfoDefaultMethod}, - {"filter", XOTclObjInfoFilterMethod}, - {"filterguard", XOTclObjInfoFilterguardMethod}, - {"forward", XOTclObjInfoForwardMethod}, - {"hasNamespace", XOTclObjInfoHasnamespaceMethod}, - /*{"info", XOTclObjInfoInfoMethod},*/ - {"invar", XOTclObjInfoInvarMethod}, - {"methods", XOTclObjInfoMethodsMethod}, - {"mixin", XOTclObjInfoMixinMethod}, - {"mixinguard", XOTclObjInfoMixinguardMethod}, - {"methods", XOTclObjInfoMethodsMethod}, - {"nonposargs", XOTclObjInfoNonposargsMethod}, - {"parent", XOTclObjInfoParentMethod}, - {"post", XOTclObjInfoPostMethod}, - {"pre", XOTclObjInfoPreMethod}, - {"procs", XOTclObjInfoProcsMethod}, - {"precedence", XOTclObjInfoPrecedenceMethod}, - {"slotobjects", XOTclObjInfoSlotObjectsMethod}, - {"vars", XOTclObjInfoVarsMethod} - }; + Tcl_CreateNamespace(interp, "::xotcl::cmd", 0, (Tcl_NamespaceDeleteProc*)NULL); - methodDefinition definitions5[] = { - {"heritage", XOTclClassInfoHeritageMethod}, - {"instances", XOTclClassInfoInstancesMethod}, - {"instargs", XOTclClassInfoInstargsMethod}, - {"instbody", XOTclClassInfoInstbodyMethod}, - {"instcommands", XOTclClassInfoInstcommandsMethod}, - {"instdefault", XOTclClassInfoInstdefaultMethod}, - {"instfilter", XOTclClassInfoInstfilterMethod}, - {"instfilterguard", XOTclClassInfoInstfilterguardMethod}, - {"instforward", XOTclClassInfoInstforwardMethod}, - {"instinvar", XOTclClassInfoInstinvarMethod}, - {"instmixin", XOTclClassInfoInstmixinMethod}, - {"instmixinguard", XOTclClassInfoInstmixinguardMethod}, - {"instprocs", XOTclClassInfoInstprocsMethod}, - {"instnonposargs", XOTclClassInfoInstnonposargsMethod}, - {"instpre", XOTclClassInfoInstpreMethod}, - {"instpost", XOTclClassInfoInstpostMethod}, - {"parameter", XOTclClassInfoParameterMethod}, - {"subclass", XOTclClassInfoSubclassMethod}, - {"superclass", XOTclClassInfoSuperclassMethod}, - {"slots", XOTclClassInfoSlotsMethod} - }; + DSTRING_INIT(dsPtr); + for (i=0; i < nr_elements(namespace_names); i++) { + int j; + Tcl_DStringAppend(dsPtr, namespace_names[i], -1); + /*fprintf(stderr,"namespace '%s'\n", namespace_names[i]);*/ + Tcl_CreateNamespace(interp, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL); + Tcl_DStringAppend(dsPtr,"::", 2); + namespacelength = Tcl_DStringLength(dsPtr); + for (j = 0; j < nr_definitions[i]; j++) { + Tcl_DStringAppend(dsPtr, definitions[i][j].methodName, -1); + /*fprintf(stderr,"defining '%s' (%d of %d)\n", Tcl_DStringValue(dsPtr), j, nr_definitions[ + i]);*/ + Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), definitions[i][j].proc, 0, 0); + Tcl_DStringSetLength(dsPtr, namespacelength); + } + Tcl_DStringSetLength(dsPtr, 0); + } + + DSTRING_FREE(dsPtr); + } - methodDefinition *definitions[] = {definitions1, definitions2, definitions3, - definitions4, definitions5}; - int nr_definitions[] = {nr_elements(definitions1), nr_elements(definitions2), - nr_elements(definitions3), nr_elements(definitions4), - nr_elements(definitions5)}; + /* + * overwritten tcl objs + */ + result = XOTclShadowTclCommands(interp, SHADOW_LOAD); + if (result != TCL_OK) + return result; - int namespacelength; - Tcl_DString ds, *dsPtr = &ds; - - Tcl_CreateNamespace(interp, "::xotcl::cmd", 0, (Tcl_NamespaceDeleteProc*)NULL); - - DSTRING_INIT(dsPtr); - for (i=0; i < nr_elements(namespace_names); i++) { - int j; - Tcl_DStringAppend(dsPtr, namespace_names[i], -1); - /*fprintf(stderr,"namespace '%s'\n", namespace_names[i]);*/ - Tcl_CreateNamespace(interp, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL); - Tcl_DStringAppend(dsPtr,"::", 2); - namespacelength = Tcl_DStringLength(dsPtr); - for (j = 0; j < nr_definitions[i]; j++) { - Tcl_DStringAppend(dsPtr, definitions[i][j].methodName, -1); - /*fprintf(stderr,"defining '%s' (%d of %d)\n", Tcl_DStringValue(dsPtr), j, nr_definitions[i]);*/ - Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), definitions[i][j].proc, 0, 0); - Tcl_DStringSetLength(dsPtr, namespacelength); - } - Tcl_DStringSetLength(dsPtr, 0); - } - - DSTRING_FREE(dsPtr); - } - - /* - * overwritten tcl objs - */ - result = XOTclShadowTclCommands(interp, SHADOW_LOAD); - if (result != TCL_OK) - return result; - - /* - * new tcl cmds - */ + /* + * new tcl cmds + */ #ifdef XOTCL_BYTECODE - instructions[INST_SELF_DISPATCH].cmdPtr = (Command *) + instructions[INST_SELF_DISPATCH].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(interp, "::xotcl::my", XOTclSelfDispatchCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::my", XOTclSelfDispatchCmd, 0, 0); #ifdef XOTCL_BYTECODE - instructions[INST_NEXT].cmdPtr = (Command *) + instructions[INST_NEXT].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(interp, "::xotcl::next", XOTclNextObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::next", XOTclNextObjCmd, 0, 0); #ifdef XOTCL_BYTECODE - instructions[INST_SELF].cmdPtr = (Command *) + instructions[INST_SELF].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(interp, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); - - Tcl_CreateObjCommand(interp, "::xotcl::alias", XOTclAliasCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::methodproperty", XOTclMethodPropertyCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::configure", XOTclConfigureCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::deprecated", XOTcl_DeprecatedCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); + /*Tcl_CreateObjCommand(interp, "::xotcl::K", XOTclKObjCmd, 0, 0);*/ + + Tcl_CreateObjCommand(interp, "::xotcl::alias", XOTclAliasCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::methodproperty", XOTclMethodPropertyCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::configure", XOTclConfigureCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::deprecated", XOTcl_DeprecatedCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::finalize", XOTclFinalizeObjCmd, 0, 0); +#if defined(PRE85) #ifdef XOTCL_BYTECODE - instructions[INST_INITPROC].cmdPtr = (Command *) + instructions[INST_INITPROC].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(interp, "::xotcl::initProcNS", XOTclInitProcNSCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::interpretNonpositionalArgs", - XOTclInterpretNonpositionalArgsCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::interp", XOTcl_InterpObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::__qualify", XOTclQualifyObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::relation", XOTclRelationCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::setinstvar", XOTclSetInstvarCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::is", XOTclIsCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::initProcNS", XOTclInitProcNSCmd, 0, 0); +#endif + Tcl_CreateObjCommand(interp, "::xotcl::interpretNonpositionalArgs", + XOTclInterpretNonpositionalArgsCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::interp", XOTcl_InterpObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::__qualify", XOTclQualifyObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::setinstvar", XOTclSetInstvarCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::relation", XOTclRelationCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::is", XOTclIsCmd, 0, 0); - Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "self", 0); - Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "next", 0); - Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "my", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "self", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "next", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "my", 0); #ifdef XOTCL_BYTECODE - XOTclBytecodeInit(); + XOTclBytecodeInit(); #endif - /* - * set runtime version information in Tcl variable - */ - Tcl_SetVar(interp, "::xotcl::version", XOTCLVERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "::xotcl::patchlevel", XOTCLPATCHLEVEL, TCL_GLOBAL_ONLY); + /* + nonposArgsCl = PrimitiveCCreate(interp, + XOTclGlobalStrings[XOTE_NON_POS_ARGS_CL], + thecls); + XOTclAddIMethod(interp, (XOTcl_Class*) nonposArgsCl, + "required", + (Tcl_ObjCmdProc*) XOTclCheckRequiredArgs, 0, 0); + XOTclAddIMethod(interp, (XOTcl_Class*) nonposArgsCl, + "switch", + (Tcl_ObjCmdProc*) XOTclCheckBooleanArgs, 0, 0); + XOTclAddIMethod(interp, (XOTcl_Class*) nonposArgsCl, + "boolean", + (Tcl_ObjCmdProc*) XOTclCheckBooleanArgs, 0, 0); + PrimitiveOCreate(interp, XOTclGlobalStrings[XOTE_NON_POS_ARGS_OBJ], + nonposArgsCl); + paramCl = PrimitiveCCreate(interp, XOTclGlobalStrings[XOTE_PARAM_CL], thecls); + XOTclAddPMethod(interp, (XOTcl_Object*) paramObject, + XOTclGlobalStrings[XOTE_SEARCH_DEFAULTS], + (Tcl_ObjCmdProc*) ParameterSearchDefaultsMethod, 0, 0); + * set runtime version information in Tcl variable + */ + Tcl_SetVar(interp, "::xotcl::version", XOTCLVERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "::xotcl::patchlevel", XOTCLPATCHLEVEL, TCL_GLOBAL_ONLY); - /* - * with some methods and library procs in tcl - they could go in a - * xotcl.tcl file, but they're embedded here with Tcl_GlobalEval - * to avoid the need to carry around a separate file at runtime. - */ - { + /* + * with some methods and library procs in tcl - they could go in a + * xotcl.tcl file, but they're embedded here with Tcl_GlobalEval + * to avoid the need to carry around a separate file at runtime. + */ + { #include "predefined.h" - /* fprintf(stderr, "predefined=<<%s>>\n", cmd);*/ - if (Tcl_GlobalEval(interp, cmd) != TCL_OK) - return TCL_ERROR; + /* fprintf(stderr, "predefined=<<%s>>\n", cmd);*/ + if (Tcl_GlobalEval(interp, cmd) != TCL_OK) { + static char cmd[] = + "puts stderr \"Error in predefined code\n\ + $::errorInfo\""; + Tcl_EvalEx(interp, cmd, -1, 0); + return TCL_ERROR; } + } #ifndef AOL_SERVER - /* the AOL server uses a different package loading mechanism */ + /* the AOL server uses a different package loading mechanism */ # ifdef COMPILE_XOTCL_STUBS - Tcl_PkgProvideEx(interp, "XOTcl", PACKAGE_VERSION, (ClientData)&xotclStubs); + Tcl_PkgProvideEx(interp, "XOTcl", PACKAGE_VERSION, (ClientData)&xotclStubs); # else - Tcl_PkgProvide(interp, "XOTcl", PACKAGE_VERSION); + Tcl_PkgProvide(interp, "XOTcl", PACKAGE_VERSION); # endif #endif #if !defined(TCL_THREADS) && !defined(PRE81) - if ((Tcl_GetVar2(interp, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) { - /* a non threaded XOTcl version is loaded into a threaded environment */ - fprintf(stderr, "\n A non threaded XOTCL version is loaded into threaded environment\n Please reconfigure XOTcl with --enable-threads!\n\n\n"); - } + if ((Tcl_GetVar2(interp, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) { + /* a non threaded XOTcl version is loaded into a threaded environment */ + fprintf(stderr, "\n A non threaded XOTCL version is loaded into threaded environment\n Please reconfigure XOTcl with --enable-threads!\n\n\n"); + } #endif - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; + return TCL_OK; } extern int Xotcl_SafeInit(Tcl_Interp *interp) { - /*** dummy for now **/ - return Xotcl_Init(interp); + /*** dummy for now **/ + return Xotcl_Init(interp); }