Index: Makefile.in =================================================================== diff -u -N -r1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- Makefile.in (.../Makefile.in) (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ Makefile.in (.../Makefile.in) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -301,7 +301,7 @@ $(INSTALL_DATA) $(src_lib_dir)/$$i $(DESTDIR)$(pkglibdir)/$$i ; \ done; cat unix/pkgIndex.unix >> $(DESTDIR)$(pkglibdir)/pkgIndex.tcl - $(INSTALL_DATA) xotclConfig.sh $(DESTDIR)$(libdir)/ + $(INSTALL_DATA) nsfConfig.sh $(DESTDIR)$(libdir)/ install-xotcl-libraries: install-libraries $(DESTDIR)$(pkglibdir) @echo "Installing XOTcl Libraries to $(DESTDIR)$(xotcl_pkglibdir)/" @@ -503,16 +503,16 @@ $(src_generic_dir)/tclAPI.h: $(src_generic_dir)/gentclAPI.tcl $(src_generic_dir)/gentclAPI.decls $(TCLSH) $(src_generic_dir)/gentclAPI.tcl > $(src_generic_dir)/tclAPI.h -xotclStubInit.$(OBJEXT): $(PKG_HEADERS) -xotclStubLib.$(OBJEXT): $(src_generic_dir)/xotclStubLib.c $(PKG_HEADERS) -xotcl.$(OBJEXT): $(src_generic_dir)/xotcl.c $(src_generic_dir)/predefined.h $(src_generic_dir)/xotclAccessInt.h $(src_generic_dir)/tclAPI.h $(PKG_HEADERS) $(src_generic_dir)/xotclStack85.c -xotclError.$(OBJEXT): $(src_generic_dir)/xotclError.c $(PKG_HEADERS) -xotclMetaData.$(OBJEXT): $(src_generic_dir)/xotclMetaData.c $(PKG_HEADERS) -xotclObjectData.$(OBJEXT): $(src_generic_dir)/xotclObjectData.c $(PKG_HEADERS) -xotclProfile.$(OBJEXT): $(src_generic_dir)/xotclProfile.c $(PKG_HEADERS) -xotclTrace.$(OBJEXT): $(src_generic_dir)/xotclTrace.c $(PKG_HEADERS) -xotclUtil.$(OBJEXT): $(src_generic_dir)/xotclUtil.c $(PKG_HEADERS) -xotclShadow.$(OBJEXT): $(src_generic_dir)/xotclShadow.c $(PKG_HEADERS) +nsfStubInit.$(OBJEXT): $(PKG_HEADERS) +nsfStubLib.$(OBJEXT): $(src_generic_dir)/nsfStubLib.c $(PKG_HEADERS) +nsf.$(OBJEXT): $(src_generic_dir)/nsf.c $(src_generic_dir)/predefined.h $(src_generic_dir)/nsfAccessInt.h $(src_generic_dir)/tclAPI.h $(PKG_HEADERS) $(src_generic_dir)/nsfStack.c +nsfError.$(OBJEXT): $(src_generic_dir)/nsfError.c $(PKG_HEADERS) +nsfMetaData.$(OBJEXT): $(src_generic_dir)/nsfMetaData.c $(PKG_HEADERS) +nsfObjectData.$(OBJEXT): $(src_generic_dir)/nsfObjectData.c $(PKG_HEADERS) +nsfProfile.$(OBJEXT): $(src_generic_dir)/nsfProfile.c $(PKG_HEADERS) +nsfTrace.$(OBJEXT): $(src_generic_dir)/nsfTrace.c $(PKG_HEADERS) +nsfUtil.$(OBJEXT): $(src_generic_dir)/nsfUtil.c $(PKG_HEADERS) +nsfShadow.$(OBJEXT): $(src_generic_dir)/nsfShadow.c $(PKG_HEADERS) aolstub.$(OBJEXT): $(src_generic_dir)/aolstub.c $(PKG_HEADERS) # @@ -708,10 +708,10 @@ bin-tar: (cd ..; tar zcvf xotcl-$(PACKAGE_VERSION)-bin-linux-i686-glibc.tar.gz \ `find $(exec_prefix)/bin/$(NXSH) $(exec_prefix)/bin/xowish \ - $(prefix)/lib/xotcl* \ - $(prefix)/lib/libxotcl* \ - $(prefix)/include/xotcl*.h \ - $(DESTDIR)$(pkglibdir) $(prefix)/man/man1/xo* \ + $(prefix)/lib/nsf* \ + $(prefix)/lib/libnsf* \ + $(prefix)/include/nsf*.h \ + $(DESTDIR)$(pkglibdir) $(prefix)/man/man1/nsf* \ -type f -o -type l | fgrep -v CVS | fgrep -v SCCS | fgrep -v .junk| fgrep -v .db | fgrep -v "~" | fgrep -v "#" | fgrep -v /receiver/` \ ) Index: TODO =================================================================== diff -u -N -rc88fac9594630181e97e2f936891a0bdb9065cca -r0e8b567e2a1808c514f6340430920ad4d59953bc --- TODO (.../TODO) (revision c88fac9594630181e97e2f936891a0bdb9065cca) +++ TODO (.../TODO) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -1274,6 +1274,13 @@ - checked "my" vs. "nsf::dispatch" in nx.tcl and xotcl2.tcl - "child objects" are showed per default in "info methods" +- big renaming orgy (BRO): + - changed filenames starting to "xotcl" into filename starting with "nsf" + - adoped Makefile insfrastructure accordingly +- removed compile flag XOTCL_METADATA and generic/xotclMetaData.c +- changed compile flag PROFILE into NSF_PROFILE + + TODO: - check equivalence of the following two commands Index: configure =================================================================== diff -u -N -r1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- configure (.../configure) (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ configure (.../configure) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -7060,8 +7060,8 @@ - vars="xotcl.c xotclError.c xotclMetaData.c xotclObjectData.c xotclProfile.c \ - xotclTrace.c xotclUtil.c xotclShadow.c xotclCompile.c aolstub.c nsfStubInit.c" + vars="nsf.c nsfError.c nsfObjectData.c nsfProfile.c \ + nsfTrace.c nsfUtil.c nsfShadow.c nsfCompile.c aolstub.c nsfStubInit.c" for i in $vars; do case $i in \$*) @@ -7098,7 +7098,7 @@ - vars="generic/xotcl.h generic/xotclInt.h generic/nsfDecls.h generic/nsfIntDecls.h" + vars="generic/nsf.h generic/nsfInt.h generic/nsfDecls.h generic/nsfIntDecls.h" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then @@ -10633,7 +10633,7 @@ # Without the following two eval statements, NSF_SHARED_LIB_SUFFIX -# in xotclConfig.sh has $PACKAGE_VERSION unresolved. When another +# in nsfConfig.sh has $PACKAGE_VERSION unresolved. When another # app links against xotcl, the PACKAGE_VERSIONs are confused. # # Without the first eval, we get @@ -10848,7 +10848,7 @@ -# make this available, for such as xotclConfig.sh +# make this available, for such as nsfConfig.sh NSF_COMPATIBLE_TCLSH=${TCLSH_PROG} @@ -10940,9 +10940,9 @@ # target, defined in Makefile.in #-------------------------------------------------------------------- -CONFIG_CLEAN_FILES="Makefile xotclConfig.sh library/xotcl/apps/utils/xotclsh library/xotcl/apps/utils/xowish unix/xotcl.spec unix/pkgIndex.unix autom4te.cache/" +CONFIG_CLEAN_FILES="Makefile nsfConfig.sh library/xotcl/apps/utils/xotclsh library/xotcl/apps/utils/xowish unix/xotcl.spec unix/pkgIndex.unix autom4te.cache/" -ac_config_files="$ac_config_files Makefile xotclConfig.sh library/xotcl/apps/utils/xotclsh library/xotcl/apps/utils/xowish unix/xotcl.spec unix/pkgIndex.unix" +ac_config_files="$ac_config_files Makefile nsfConfig.sh library/xotcl/apps/utils/xotclsh library/xotcl/apps/utils/xowish unix/xotcl.spec unix/pkgIndex.unix" #-------------------------------------------------------------------- @@ -11525,7 +11525,7 @@ do case $ac_config_target in "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "xotclConfig.sh") CONFIG_FILES="$CONFIG_FILES xotclConfig.sh" ;; + "nsfConfig.sh") CONFIG_FILES="$CONFIG_FILES nsfConfig.sh" ;; "library/xotcl/apps/utils/xotclsh") CONFIG_FILES="$CONFIG_FILES library/xotcl/apps/utils/xotclsh" ;; "library/xotcl/apps/utils/xowish") CONFIG_FILES="$CONFIG_FILES library/xotcl/apps/utils/xowish" ;; "unix/xotcl.spec") CONFIG_FILES="$CONFIG_FILES unix/xotcl.spec" ;; Index: configure.in =================================================================== diff -u -N -r1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- configure.in (.../configure.in) (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ configure.in (.../configure.in) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -189,9 +189,9 @@ #----------------------------------------------------------------------- -TEA_ADD_SOURCES([xotcl.c xotclError.c xotclMetaData.c xotclObjectData.c xotclProfile.c \ - xotclTrace.c xotclUtil.c xotclShadow.c xotclCompile.c aolstub.c nsfStubInit.c]) -TEA_ADD_HEADERS([generic/xotcl.h generic/xotclInt.h generic/nsfDecls.h generic/nsfIntDecls.h]) +TEA_ADD_SOURCES([nsf.c nsfError.c nsfObjectData.c nsfProfile.c \ + nsfTrace.c nsfUtil.c nsfShadow.c nsfCompile.c aolstub.c nsfStubInit.c]) +TEA_ADD_HEADERS([generic/nsf.h generic/nsfInt.h generic/nsfDecls.h generic/nsfIntDecls.h]) TEA_ADD_INCLUDES([]) TEA_ADD_LIBS([]) TEA_ADD_CFLAGS([-DNSF_VERSION=\\\"$NSF_VERSION\\\" -DNSF_PATCHLEVEL=\\\"$NSF_RELEASE_LEVEL\\\" \ @@ -279,7 +279,7 @@ TEA_CONFIG_CFLAGS # Without the following two eval statements, NSF_SHARED_LIB_SUFFIX -# in xotclConfig.sh has $PACKAGE_VERSION unresolved. When another +# in nsfConfig.sh has $PACKAGE_VERSION unresolved. When another # app links against xotcl, the PACKAGE_VERSIONs are confused. # # Without the first eval, we get @@ -339,7 +339,7 @@ TEA_PROG_TCLSH -# make this available, for such as xotclConfig.sh +# make this available, for such as nsfConfig.sh NSF_COMPATIBLE_TCLSH=${TCLSH_PROG} AC_SUBST(NSF_COMPATIBLE_TCLSH) @@ -424,7 +424,7 @@ dnl Change the value of -this- macro if you want to add or remove dnl such files. -AC_DEFUN(CONFIG_OUTPUT_FILES, [[Makefile xotclConfig.sh library/xotcl/apps/utils/xotclsh library/xotcl/apps/utils/xowish unix/xotcl.spec unix/pkgIndex.unix]]) +AC_DEFUN(CONFIG_OUTPUT_FILES, [[Makefile nsfConfig.sh library/xotcl/apps/utils/xotclsh library/xotcl/apps/utils/xowish unix/xotcl.spec unix/pkgIndex.unix]]) #-------------------------------------------------------------------- # the value of this variable is set to the files which are to be Index: generic/aolstub.c =================================================================== diff -u -N -r11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b -r0e8b567e2a1808c514f6340430920ad4d59953bc --- generic/aolstub.c (.../aolstub.c) (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/aolstub.c (.../aolstub.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -12,7 +12,7 @@ #ifdef AOL_SERVER -#include "xotcl.h" +#include "nsf.h" #include int Ns_ModuleVersion = 1; Index: generic/nsf.c =================================================================== diff -u -N --- generic/nsf.c (revision 0) +++ generic/nsf.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,15202 @@ +/* + * XOTcl - Extended Object Tcl + * + * Copyright (C) 1999-2010 Gustaf Neumann (a), Uwe Zdun (a) + * + * (a) Vienna University of Economics and Business Administration + * Institute. of Information Systems and New Media + * A-1090, Augasse 2-6 + * Vienna, Austria + * + * (b) University of Essen + * Specification of Software Systems + * Altendorferstrasse 97-101 + * D-45143 Essen, Germany + * + * Permission to use, copy, modify, distribute, and sell this + * software and its documentation for any purpose is hereby granted + * without fee, provided that the above copyright notice appear in + * all copies and that both that copyright notice and this permission + * notice appear in supporting documentation. We make no + * representations about the suitability of this software for any + * purpose. It is provided "as is" without express or implied + * warranty. + * + * + * This software is based upon MIT Object Tcl by David Wetherall and + * Christopher J. Lindblad, that contains the following copyright + * message: + * + * "Copyright 1993 Massachusetts Institute of Technology + * + * Permission to use, copy, modify, distribute, and sell this + * software and its documentation for any purpose is hereby granted + * without fee, provided that the above copyright notice appear in + * all copies and that both that copyright notice and this + * permission notice appear in supporting documentation, and that + * the name of M.I.T. not be used in advertising or publicity + * pertaining to distribution of the software without specific, + * written prior permission. M.I.T. makes no representations about + * the suitability of this software for any purpose. It is + * provided "as is" without express or implied warranty." + * */ + +#define XOTCL_C 1 +#include "nsfInt.h" +#include "nsfAccessInt.h" + +#ifdef COMPILE_XOTCL_STUBS +# if defined(PRE86) +extern NxStubs nxStubs; +# else +MODULE_SCOPE const NxStubs * const nxConstStubPtr; +# endif +#endif + +#ifdef XOTCL_MEM_COUNT +int xotclMemCountInterpCounter = 0; +#endif + +/* + * Tcl_Obj Types for XOTcl Objects + */ + +#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) +#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) +#endif + +typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; + +typedef struct callFrameContext { + int framesSaved; + Tcl_CallFrame *framePtr; + Tcl_CallFrame *varFramePtr; +} callFrameContext; + +typedef struct XOTclProcContext { + ClientData oldDeleteData; + Tcl_CmdDeleteProc *oldDeleteProc; + XOTclParamDefs *paramDefs; +} XOTclProcContext; + +/* tclCmdClientdata is an incomplete type containing the common field(s) + of ForwardCmdClientData, AliasCmdClientData and SetterCmdClientData + used for filling in at runtime the actual object. */ +typedef struct TclCmdClientData { + XOTclObject *object; +} TclCmdClientData; + +typedef struct SetterCmdClientData { + XOTclObject *object; + XOTclParam *paramsPtr; +} SetterCmdClientData; + +typedef struct ForwardCmdClientData { + XOTclObject *object; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + ClientData clientData; + int passthrough; + int needobjmap; + int verbose; + int hasNonposArgs; + 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 *object; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + ClientData clientData; + XOTclClass *class; + Tcl_Interp *interp; + Tcl_Command aliasedCmd; + Tcl_Command aliasCmd; +} AliasCmdClientData; + +#define PARSE_CONTEXT_PREALLOC 20 +typedef struct { + ClientData *clientData; + Tcl_Obj **objv; + Tcl_Obj **full_objv; + int *flags; + ClientData clientData_static[PARSE_CONTEXT_PREALLOC]; + Tcl_Obj *objv_static[PARSE_CONTEXT_PREALLOC+1]; + int flags_static[PARSE_CONTEXT_PREALLOC+1]; + int lastobjc; + int objc; + int mustDecr; + int varArgs; + XOTclObject *object; +} parseContext; + +static Tcl_ObjType CONST86 *byteCodeType = NULL, *tclCmdNameType = NULL, *listType = NULL; + +int XOTclObjWrongArgs(Tcl_Interp *interp, CONST char *msg, Tcl_Obj *cmdName, Tcl_Obj *methodObj, CONST char *arglist); +static int XOTclDeprecatedCmd(Tcl_Interp *interp, CONST char *what, CONST char *oldCmd, CONST char *newCmd); + +/* methods called directly when CallDirectly() returns NULL */ +static int XOTclCAllocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj); +static int XOTclCCreateMethod(Tcl_Interp *interp, XOTclClass *cl, CONST char *name, int objc, Tcl_Obj *CONST objv[]); +static int XOTclOCleanupMethod(Tcl_Interp *interp, XOTclObject *object); +static int XOTclOConfigureMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); +static int XOTclODestroyMethod(Tcl_Interp *interp, XOTclObject *object); +static int XOTclOResidualargsMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); +static int callDestroyMethod(Tcl_Interp *interp, XOTclObject *object, int flags); + +static int XOTclNextMethod(XOTclObject *object, Tcl_Interp *interp, XOTclClass *givenCl, + CONST char *givenMethodName, int objc, Tcl_Obj *CONST objv[], + int useCSObjs, XOTclCallStackContent *cscPtr); +static int XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +static int XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc,Tcl_Obj *CONST objv[]); +XOTCLINLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int flags); +static int DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + +static int DoDealloc(Tcl_Interp *interp, XOTclObject *object); +static int RecreateObject(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); +static void XOTclCleanupObject(XOTclObject *object); +static void finalObjectDeletion(Tcl_Interp *interp, XOTclObject *object); + +static int GetObjectFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj); +static XOTclObject *XOTclpGetObject(Tcl_Interp *interp, CONST char *name); +static XOTclClass *XOTclpGetClass(Tcl_Interp *interp, CONST char *name); +#if !defined(NDEBUG) +static void checkAllInstances(Tcl_Interp *interp, XOTclClass *startCl, int lvl); +#endif + +static int ObjectSystemsCleanup(Tcl_Interp *interp); +static void ObjectSystemsCheckSystemMethod(Tcl_Interp *interp, CONST char *methodName, XOTclObjectSystem *defOsPtr); +static XOTclObjectSystem *GetObjectSystem(XOTclObject *object); + +static void getAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startClass); +static void freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable); + +static Tcl_Obj *NameInNamespaceObj(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns); +static Tcl_Namespace *callingNameSpace(Tcl_Interp *interp); +XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns); +static int setInstVar(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj); + +static void FilterComputeDefined(Tcl_Interp *interp, XOTclObject *object); +static void MixinComputeDefined(Tcl_Interp *interp, XOTclObject *object); +XOTCLINLINE static void GuardAdd(Tcl_Interp *interp, XOTclCmdList *filterCL, Tcl_Obj *guardObj); +static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObjs); +static int GuardCall(XOTclObject *object, XOTclClass *cl, Tcl_Command cmd, Tcl_Interp *interp, + Tcl_Obj *guardObj, XOTclCallStackContent *cscPtr); +static void GuardDel(XOTclCmdList *filterCL); + +static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins); +static int IsSubType(XOTclClass *subcl, XOTclClass *cl); +static int HasMixin(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl); + +static XOTclClass *DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, int isMeta); + +XOTCLINLINE static void CscInit(XOTclCallStackContent *cscPtr, XOTclObject *object, XOTclClass *cl, + Tcl_Command cmd, int frameType); +XOTCLINLINE static void CscFinish(Tcl_Interp *interp, XOTclCallStackContent *cscPtr); +static XOTclCallStackContent *CallStackGetFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr); +XOTCLINLINE static void CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *object); + +static int XOTclInvalidateObjectParameterCmd(Tcl_Interp *interp, XOTclClass *cl); +static int ProcessMethodArguments(parseContext *pcPtr, Tcl_Interp *interp, + XOTclObject *object, int pushFrame, XOTclParamDefs *paramDefs, + CONST char *methodName, int objc, Tcl_Obj *CONST objv[]); +static int ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int doCheck, + int *flags, ClientData *clientData, Tcl_Obj **outObjPtr); +static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, + const char *varNamePrefix, int doCheck, XOTclParam **paramPtrPtr); + +static CONST char* AliasIndex(Tcl_DString *dsPtr, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); +static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object, CONST char *cmd); +static int AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); +static Tcl_Obj *AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); +static int ListMethodHandle(Tcl_Interp *interp, XOTclObject *object, int withPer_object, + CONST char *methodName); + +static void +parseContextInit(parseContext *pcPtr, int objc, XOTclObject *object, Tcl_Obj *procName) { + if (objc < PARSE_CONTEXT_PREALLOC) { + /* the single larger memset below .... */ + memset(pcPtr, 0, sizeof(parseContext)); + /* ... is faster than the two smaller memsets below */ + /* memset(pcPtr->clientData_static, 0, sizeof(ClientData)*(objc)); + memset(pcPtr->objv_static, 0, sizeof(Tcl_Obj*)*(objc+1));*/ + pcPtr->full_objv = &pcPtr->objv_static[0]; + pcPtr->clientData = &pcPtr->clientData_static[0]; + pcPtr->flags = &pcPtr->flags_static[0]; + } else { + pcPtr->full_objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*(objc+1)); + pcPtr->flags = (int*)ckalloc(sizeof(int)*(objc+1)); + pcPtr->clientData = (ClientData*)ckalloc(sizeof(ClientData)*objc); + /*fprintf(stderr, "ParseContextMalloc %d objc, %p %p\n", objc, pcPtr->full_objv, pcPtr->clientData);*/ + memset(pcPtr->full_objv, 0, sizeof(Tcl_Obj*)*(objc+1)); + memset(pcPtr->flags, 0, sizeof(int)*(objc+1)); + memset(pcPtr->clientData, 0, sizeof(ClientData)*(objc)); + } + pcPtr->objv = &pcPtr->full_objv[1]; + pcPtr->full_objv[0] = procName; + pcPtr->object = object; + pcPtr->varArgs = 0; + pcPtr->mustDecr = 0; +} + +static void parseContextExtendObjv(parseContext *pcPtr, int from, int elts, Tcl_Obj *CONST source[]) { + int requiredSize = from + elts + 1; + + /*XOTclPrintObjv("BEFORE: ", pcPtr->objc, pcPtr->full_objv);*/ + + if (requiredSize >= PARSE_CONTEXT_PREALLOC) { + if (pcPtr->objv == &pcPtr->objv_static[1]) { + /* realloc from preallocated memory */ + pcPtr->full_objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * requiredSize); + memcpy(pcPtr->full_objv, &pcPtr->objv_static[0], sizeof(Tcl_Obj*) * PARSE_CONTEXT_PREALLOC); + /*fprintf(stderr, "alloc %d new objv=%p pcPtr %p\n", requiredSize, pcPtr->full_objv, pcPtr);*/ + } else { + /* realloc from mallocated memory */ + pcPtr->full_objv = (Tcl_Obj **)ckrealloc((char *)pcPtr->full_objv, sizeof(Tcl_Obj*) * requiredSize); + /*fprintf(stderr, "realloc %d new objv=%p pcPtr %p\n", requiredSize, pcPtr->full_objv, pcPtr);*/ + } + pcPtr->objv = &pcPtr->full_objv[1]; + } + + memcpy(pcPtr->objv + from, source, sizeof(Tcl_Obj *) * (elts)); + pcPtr->objc += elts; + + /*XOTclPrintObjv("AFTER: ", pcPtr->objc, pcPtr->full_objv);*/ +} + +static void parseContextRelease(parseContext *pcPtr) { + if (pcPtr->mustDecr) { + int i; + for (i = 0; i < pcPtr->lastobjc; i++) { + if (pcPtr->flags[i] & XOTCL_PC_MUST_DECR) { + DECR_REF_COUNT(pcPtr->objv[i]); + } + } + } + + /* objv can be separately extended */ + if (pcPtr->objv != &pcPtr->objv_static[1]) { + /*fprintf(stderr, "parseContextRelease %p free %p %p\n", pcPtr, pcPtr->full_objv, pcPtr->clientData);*/ + ckfree((char *)pcPtr->full_objv); + } + /* if the parameter definition was extended, both clientData and flags are extended */ + if (pcPtr->clientData != &pcPtr->clientData_static[0]) { + /*fprintf(stderr, "free clientdata and flags\n");*/ + ckfree((char *)pcPtr->clientData); + ckfree((char *)pcPtr->flags); + } +} + +/* + * Var Reform Compatibility support. + * + * Definitions for accessing Tcl variable structures after varreform + * in Tcl 8.5. + */ + +#define TclIsCompiledLocalArgument(compiledLocalPtr) ((compiledLocalPtr)->flags & VAR_ARGUMENT) +#define TclIsCompiledLocalTemporary(compiledLocalPtr) ((compiledLocalPtr)->flags & VAR_TEMPORARY) + +#define VarHashGetValue(hPtr) ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) +#define VarHashGetKey(varPtr) (((VarInHash *)(varPtr))->entry.key.objPtr) +#define VarHashTable(varTable) &(varTable)->table +#define valueOfVar(type, varPtr, field) (type *)(varPtr)->value.field + +XOTCLINLINE static Tcl_Namespace * +ObjFindNamespace(Tcl_Interp *interp, Tcl_Obj *objPtr) { + Tcl_Namespace *nsPtr; + + if (TclGetNamespaceFromObj(interp, objPtr, &nsPtr) == TCL_OK) { + return nsPtr; + } else { + return NULL; + } +} + +static XOTCLINLINE Var * +VarHashCreateVar(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; +} + +static TclVarHashTable * +VarHashTableCreate() { + TclVarHashTable *varTablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varTablePtr, NULL); + return varTablePtr; +} + +#if 0 +static int duringBootstrap(Tcl_Interp *interp) { + Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::nsf::bootstrap", NULL, TCL_GLOBAL_ONLY); + return (bootstrap != NULL); +} +#endif + +/* + * call an XOTcl method + */ +static int +callMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *methodObj, + int objc, Tcl_Obj *CONST objv[], int flags) { + XOTclObject *object = (XOTclObject*) clientData; + int result; + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); + /*fprintf(stderr, "%%%% callmethod called with method %p\n", methodObj),*/ + + tov[0] = object->cmdName; + tov[1] = methodObj; + + 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(methodObj));for(i=0; i1); + tov[0] = object->cmdName; + tov[1] = methodObj; + 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 = ObjectDispatch(clientData, interp, objc, tov, flags); + + FREE_ON_STACK(Tcl_Obj*, tov); + return result; +} + +#include "nsfStack.c" + +/* extern callable GetSelfObj */ +XOTcl_Object* +XOTclGetSelfObj(Tcl_Interp *interp) { + return (XOTcl_Object*)GetSelfObj(interp); +} + +#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); +} + +static void printCall(Tcl_Interp *interp, CONST char *string, int objc, Tcl_Obj *CONST objv[]) { + fprintf(stderr, " (%d) >%s: ", Tcl_Interp_numLevels(interp), string); + printObjv(objc, objv); + fprintf(stderr, "\n"); +} +static void printExit(Tcl_Interp *interp, CONST 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))); +} +#endif + + +/* + * XOTclObject Reference Accounting + */ +#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) +#else +# define XOTclObjectRefCountIncr(obj) \ + (obj)->refCount++; \ + MEM_COUNT_ALLOC("XOTclObject RefCount", obj) +# define XOTclObjectRefCountDecr(obj) \ + (obj)->refCount--; \ + MEM_COUNT_FREE("XOTclObject RefCount", obj) +#endif + +#if defined(XOTCLOBJ_TRACE) +void objTrace(char *string, XOTclObject *object) { + if (object) + fprintf(stderr, "--- %s tcl %p %s (%d %p) xotcl %p (%d) %s \n", string, + object->cmdName, object->cmdName->typePtr ? object->cmdName->typePtr->name : "NULL", + object->cmdName->refCount, object->cmdName->internalRep.twoPtrValue.ptr1, + object, obj->refCount, objectName(object)); + else + fprintf(stderr, "--- No object: %s\n", string); +} +#else +# define objTrace(a, b) +#endif + + +/* search for tail of name */ +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(CONST char *string) { + return (strncmp((string), "::nsf::classes", 14) == 0); +} + +/* removes preceding ::nsf::classes from a string */ +XOTCLINLINE static CONST char * +NSCutXOTclClasses(CONST char *string) { + assert(strncmp((string), "::nsf::classes", 14) == 0); + return string+14; +} + +XOTCLINLINE static XOTclObject * +GetObjectFromNsName(Tcl_Interp *interp, CONST char *string, int *fromClassNS) { + /* + * Get object or class from a fully qualified cmd name, such as + * e.g. ::nsf::classes::X + */ + if (isClassName(string)) { + *fromClassNS = 1; + return (XOTclObject *)XOTclpGetClass(interp, NSCutXOTclClasses(string)); + } else { + *fromClassNS = 0; + return XOTclpGetObject(interp, string); + } +} + +XOTCLINLINE static char * +NSCmdFullName(Tcl_Command cmd) { + Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); + return nsPtr ? nsPtr->fullName : ""; +} + +static void +XOTclCleanupObject(XOTclObject *object) { + XOTclObjectRefCountDecr(object); + + if (object->refCount <= 0) { + /*fprintf(stderr, "XOTclCleanupObject %p refcount %d\n", object, object->refCount);*/ + assert(object->refCount == 0); + assert(object->flags & XOTCL_DELETED); + + MEM_COUNT_FREE("XOTclObject/XOTclClass", object); +#if defined(XOTCLOBJ_TRACE) + fprintf(stderr, "CKFREE Object %p refcount=%d\n", object, object->refCount); +#endif +#if !defined(NDEBUG) + memset(object, 0, sizeof(XOTclObject)); +#endif + ckfree((char *) object); + } +} + + +/* + * Tcl_Obj functions for objects + */ + +static int +IsXOTclTclObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **objectPtr) { + Tcl_ObjType CONST86 *cmdType = objPtr->typePtr; + if (cmdType == tclCmdNameType) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); + if (cmd) { + XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); + if (object) { + *objectPtr = object; + return 1; + } + } + } + return 0; +} + +/* Lookup an XOTcl object from the given objPtr, preferably from an + * object of type "cmdName". objPtr might be converted in this process. + */ + +static int +GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **objectPtr) { + int result; + XOTclObject *nobject; + CONST char *string; + Tcl_Command cmd; + + /*fprintf(stderr, "GetObjectFromObj obj %p %s is of type %s\n", + objPtr, ObjStr(objPtr), objPtr->typePtr ? objPtr->typePtr->name : "(null)");*/ + + /* in case, objPtr was not of type cmdName, try to convert */ + cmd = Tcl_GetCommandFromObj(interp, objPtr); + /*fprintf(stderr, "GetObjectFromObj obj %s => cmd=%p (%d)\n", + ObjStr(objPtr), cmd, cmd ? Tcl_Command_refCount(cmd):-1);*/ + if (cmd) { + XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); + + /*fprintf(stderr, "GetObjectFromObj obj %s, o is %p objProc %p XOTclObjDispatch %p\n", ObjStr(objPtr), + object, Tcl_Command_objProc(cmd), XOTclObjDispatch);*/ + if (object) { + if (objectPtr) *objectPtr = object; + return TCL_OK; + } + } + + /*fprintf(stderr, "GetObjectFromObj convertFromAny for %s type %p %s\n", ObjStr(objPtr), + objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : "(none)");*/ + + /* In case, we have to revolve via the callingNameSpace (i.e. the + * argument is not fully qualified), we retry here. + */ + string = ObjStr(objPtr); + if (!isAbsolutePath(string)) { + Tcl_Obj *tmpName = NameInNamespaceObj(interp, string, callingNameSpace(interp)); + CONST char *nsString = ObjStr(tmpName); + + INCR_REF_COUNT(tmpName); + nobject = XOTclpGetObject(interp, nsString); + /*fprintf(stderr, " RETRY, string '%s' returned %p\n", nsString, nobj);*/ + DECR_REF_COUNT(tmpName); + } else { + nobject = NULL; + } + + if (nobject) { + if (objectPtr) *objectPtr = nobject; + result = TCL_OK; + } else { + result = TCL_ERROR; + } + return result; +} + +static int +GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, + XOTclClass **cl, XOTclClass *baseClass) { + XOTclObject *object; + XOTclClass *cls = NULL; + int result = TCL_OK; + CONST char *objName = ObjStr(objPtr); + Tcl_Command cmd; + + /*fprintf(stderr, "GetClassFromObj %s base %p\n", objName, baseClass);*/ + + cmd = Tcl_GetCommandFromObj(interp, objPtr); + + if (cmd) { + cls = XOTclGetClassFromCmdPtr(cmd); + if (cls == NULL) { + /* + * We have a cmd, but no class; namesspace-imported classes are + * already resolved, but we have to care, if a class is + * "imported" via "interp alias". + */ + Tcl_Interp *alias_interp; + const char *alias_cmd_name; + Tcl_Obj *nameObj = objPtr; + Tcl_Obj **alias_ov; + int alias_oc = 0; + + if (!isAbsolutePath(objName)) { + nameObj = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); + objName = ObjStr(nameObj); + /* adjust path for documented nx.tcl */ + } + + result = Tcl_GetAliasObj(interp, objName, + &alias_interp, &alias_cmd_name, &alias_oc, &alias_ov); + /* we only want aliases with 0 args */ + if (result == TCL_OK && alias_oc == 0) { + cmd = NSFindCommand(interp, alias_cmd_name, NULL); + /*fprintf(stderr, "..... alias arg 0 '%s' cmd %p\n", alias_cmd_name, cmd);*/ + if (cmd) { + cls = XOTclGetClassFromCmdPtr(cmd); + } + } + /*fprintf(stderr, "..... final cmd %p, cls %p\n", cmd , cls);*/ + if (nameObj != objPtr) { + DECR_REF_COUNT(nameObj); + } + } + if (cls) { + if (cl) *cl = cls; + return TCL_OK; + } + } + + result = GetObjectFromObj(interp, objPtr, &object); + if (result == TCL_OK) { + cls = XOTclObjectToClass(object); + if (cls) { + if (cl) *cl = cls; + return TCL_OK; + } else { + /* flag, that we could not convert so far */ + result = TCL_ERROR; + } + } + + /*fprintf(stderr, "try __unknown for %s, result so far is %d\n", objName, result);*/ + if (baseClass) { + Tcl_Obj *methodObj, *nameObj = isAbsolutePath(objName) ? objPtr : + NameInNamespaceObj(interp, objName, callingNameSpace(interp)); + + INCR_REF_COUNT(nameObj); + + methodObj = XOTclMethodObj(interp, &baseClass->object, XO_c_requireobject_idx); + if (methodObj) { + /*fprintf(stderr, "+++ calling __unknown for %s name=%s\n", + className(baseClass), ObjStr(nameObj));*/ + + result = callMethod((ClientData) baseClass, interp, methodObj, + 3, &nameObj, XOTCL_CM_NO_PROTECT); + if (result == TCL_OK) { + result = GetClassFromObj(interp, objPtr, cl, NULL); + } + } + DECR_REF_COUNT(nameObj); + } + + return result; +} + +static Tcl_Obj * +NameInNamespaceObj(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *nsPtr) { + Tcl_Obj *objPtr; + int len; + CONST char *objString; + + /*fprintf(stderr, "NameInNamespaceObj %s (%p, %s) ", name, nsPtr, nsPtr ? nsPtr->fullName:NULL);*/ + if (!nsPtr) + nsPtr = Tcl_GetCurrentNamespace(interp); + /* fprintf(stderr, " (resolved %p, %s) ", nsPtr, nsPtr ? nsPtr->fullName:NULL);*/ + objPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + len = Tcl_GetCharLength(objPtr); + objString = ObjStr(objPtr); + if (len == 2 && objString[0] == ':' && objString[1] == ':') { + } else { + Tcl_AppendLimitedToObj(objPtr, "::", 2, INT_MAX, NULL); + } + Tcl_AppendLimitedToObj(objPtr, name, -1, INT_MAX, NULL); + + /*fprintf(stderr, "returns %s\n", ObjStr(objPtr));*/ + return objPtr; +} + +extern void +XOTclClassListFree(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; + + 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** +XOTclObjectListAdd(XOTclObjects **cList, XOTclObject *object) { + XOTclObjects *l = *cList, *element = NEW(XOTclObjects); + element->obj = object; + element->nextPtr = NULL; + + if (l) { + while (l->nextPtr) l = l->nextPtr; + l->nextPtr = element; + } else + *cList = element; + return &(element->nextPtr); +} + + +/* + * precedence ordering functions + */ + +enum colors { WHITE, GRAY, BLACK }; + +static XOTclClasses *Super(XOTclClass *cl) { return cl->super; } +static XOTclClasses *Sub(XOTclClass *cl) { return cl->sub; } + + +static int +TopoSort(XOTclClass *cl, XOTclClass *baseClass, XOTclClasses *(*next)(XOTclClass*)) { + /*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 + */ + + 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, baseClass, next)) { + cl->color = WHITE; + if (cl == baseClass) { + 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 = baseClass->order; + baseClass->order = pl; + if (cl == baseClass) { + 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); + return cl->order = NULL; +} + +static XOTclClasses* +ComputeOrder(XOTclClass *cl, XOTclClasses *order, XOTclClasses *(*direction)(XOTclClass*)) { + if (order) + return order; + return cl->order = TopoOrder(cl, direction); +} + +extern XOTclClasses* +XOTclComputePrecedence(XOTclClass *cl) { + return ComputeOrder(cl, cl->order, Super); +} + +extern XOTclClasses* +XOTclComputeDependents(XOTclClass *cl) { + return ComputeOrder(cl, cl->order, Sub); +} + + +static void +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 + */ + + 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 *object, XOTclClass *cl) { + object->cl = cl; + if (cl) { + int nw; + (void) Tcl_CreateHashEntry(&cl->instances, (char *)object, &nw); + } +} + +static int +RemoveInstance(XOTclObject *object, XOTclClass *cl) { + if (cl) { + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&cl->instances, (char *)object, NULL); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + return 1; + } + } + return 0; +} + +/* + * superclass/subclass list maintenance + */ + +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; + } +} + +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); + } +} + +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; +} + +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); + + return sp && sb; +} + +/* + * internal type checking + */ + +extern XOTcl_Class* +XOTclIsClass(Tcl_Interp *interp, ClientData clientData) { + if (clientData && XOTclObjectIsClass((XOTclObject *)clientData)) + return (XOTcl_Class*) clientData; + return 0; +} + +/* + * methods lookup + */ +static int CmdIsProc(Tcl_Command cmd) { + /* In 8.6: TclIsProc((Command*)cmd) is not equiv to the definition below */ + return (Tcl_Command_objProc(cmd) == TclObjInterpProc); +} + +static Proc *GetTclProcFromCommand(Tcl_Command cmd) { + if (cmd) { + Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + if (proc == TclObjInterpProc) + return (Proc*) Tcl_Command_objClientData(cmd); + } + return NULL; +} + +XOTCLINLINE static Tcl_Command +FindMethod(Tcl_Namespace *nsPtr, CONST char *methodName) { + register Tcl_HashEntry *entryPtr; + if ((entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName, NULL))) { + return (Tcl_Command) Tcl_GetHashValue(entryPtr); + } + /*fprintf(stderr, "find %s in %p returns %p\n", methodName, cmdTable, cmd);*/ + return NULL; +} + +static Proc * +FindProcMethod(Tcl_Namespace *nsPtr, CONST char *methodName) { + return GetTclProcFromCommand(FindMethod(nsPtr, methodName)); +} + +static XOTclClass* +SearchPLMethod(register XOTclClasses *pl, CONST char *methodName, Tcl_Command *cmd) { + /* Search the precedence list (class hierarchy) */ +#if 1 + for (; pl; pl = pl->nextPtr) { + register Tcl_HashEntry *entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTable(pl->cl->nsPtr), methodName, NULL); + if (entryPtr) { + *cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + return pl->cl; + } + } +#else + for (; pl; pl = pl->nextPtr) { + if ((*cmd = FindMethod(pl->cl->nsPtr, methodName))) { + return pl->cl; + } + } +#endif + return NULL; +} + + +static XOTclClass* +SearchCMethod(/*@notnull@*/ XOTclClass *cl, CONST char *nm, Tcl_Command *cmd) { + assert(cl); + return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); +} + +/* + * Find a method for a given object in the precedence path + */ +static Tcl_Command +ObjectFindMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *name, XOTclClass **pcl) { + Tcl_Command cmd = NULL; + + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + + if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *mixinList; + for (mixinList = object->mixinOrder; mixinList; mixinList = mixinList->nextPtr) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(mixinList->cmdPtr); + if (mixin && (*pcl = SearchCMethod(mixin, name, &cmd))) { + if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD && !XOTclObjectIsClass(object)) { + cmd = NULL; + continue; + } + break; + } + } + } + + if (!cmd && object->nsPtr) { + cmd = FindMethod(object->nsPtr, name); + } + + if (!cmd && object->cl) + *pcl = SearchCMethod(object->cl, name, &cmd); + + return cmd; +} + +/* + *---------------------------------------------------------------------- + * ObjectSystemFree -- + * + * Free a single object system structure including its root classes. + * + * Results: + * None. + * + * Side effects: + * Free memory of structure, free the root classes. + * + *---------------------------------------------------------------------- + */ + +static void +ObjectSystemFree(Tcl_Interp *interp, XOTclObjectSystem *osPtr) { + int i; + + for (i=0; i<=XO_o_unknown_idx; i++) { + Tcl_Obj *methodObj = osPtr->methods[i]; + /*fprintf(stderr, "ObjectSystemFree [%d] %p ", i, methodObj);*/ + if (methodObj) { + /*fprintf(stderr, "%s refCount %d", ObjStr(methodObj), methodObj->refCount);*/ + DECR_REF_COUNT(methodObj); + } + /*fprintf(stderr, "\n");*/ + } + + if (osPtr->rootMetaClass && osPtr->rootClass) { + RemoveSuper(osPtr->rootMetaClass, osPtr->rootClass); + RemoveInstance((XOTclObject*)osPtr->rootMetaClass, osPtr->rootMetaClass); + RemoveInstance((XOTclObject*)osPtr->rootClass, osPtr->rootMetaClass); + + finalObjectDeletion(interp, &osPtr->rootClass->object); + finalObjectDeletion(interp, &osPtr->rootMetaClass->object); + } + + FREE(XOTclObjectSystem *, osPtr); +} + +/* + *---------------------------------------------------------------------- + * ObjectSystemAdd -- + * + * Add and entry to the list of object systems of the interpreter. + * + * Results: + * None. + * + * Side effects: + * Updating the per interp list of object systems. + * + *---------------------------------------------------------------------- + */ +static void +ObjectSystemAdd(Tcl_Interp *interp, XOTclObjectSystem *osPtr) { + osPtr->nextPtr = RUNTIME_STATE(interp)->objectSystems; + RUNTIME_STATE(interp)->objectSystems = osPtr; +} + +/* + *---------------------------------------------------------------------- + * ObjectSystemsCheckSystemMethod -- + * + * Mark in all object systems the specified method as + * (potentially) overloaded and mark it in the specified + * object system as defined. + * + * Results: + * None. + * + * Side effects: + * Updating the object system structure(s). + * + *---------------------------------------------------------------------- + */ +static void +ObjectSystemsCheckSystemMethod(Tcl_Interp *interp, CONST char *methodName, XOTclObjectSystem *defOsPtr) { + XOTclObjectSystem *osPtr; + int i; + + for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { + for (i=0; i<=XO_o_unknown_idx; i++) { + Tcl_Obj *methodObj = osPtr->methods[i]; + if (methodObj && !strcmp(methodName, ObjStr(methodObj))) { + int flag = 1<definedMethods & flag) { + osPtr->overloadedMethods |= flag; + /*fprintf(stderr, "+++ %s %.6x overloading %s\n", className(defOsPtr->rootClass), + osPtr->overloadedMethods, methodName);*/ + } + if (osPtr == defOsPtr && ((osPtr->definedMethods & flag) == 0)) { + osPtr->definedMethods |= flag; + /*fprintf(stderr, "+++ %s %.6x defining %s\n", className(defOsPtr->rootClass), + osPtr->definedMethods, methodName);*/ + } + } + } + } +} + +/* + *---------------------------------------------------------------------- + * ObjectSystemsCleanup -- + * + * Delete all objects from all defined object systems. This method + * is to be called when an XOTcl process or thread exists. + * + * Results: + * None. + * + * Side effects: + * All commands and objects are deleted, memory is freed. + * + *---------------------------------------------------------------------- + */ +static int +ObjectSystemsCleanup(Tcl_Interp *interp) { + Tcl_HashTable objTable, *commandNameTable = &objTable; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + XOTclObjectSystem *osPtr, *nPtr; + + /* Deletion is performed in two rounds: + * (a) SOFT DESTROY: invoke all user-defined destroy methods + * without destroying objects + * (b) PHYSICAL DESTROY: delete the objects and classes, + * destroy methods are not invoked anymore + * + * This is to prevent that the destroy order causes classes to be + * deleted before the methods invoked by destroy are executed. Note + * that it is necessary to iterate over all object systems + * simultaneous, since the might be dependencies between objects of + * different object systems. + */ + + Tcl_InitHashTable(commandNameTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandNameTable); + + /* collect all instances from all object systems */ + for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { + /*fprintf(stderr, "destroyObjectSystem deletes %s\n", className(osPtr->rootClass));*/ + getAllInstances(interp, commandNameTable, osPtr->rootClass); + } + + /***** SOFT DESTROY *****/ + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; + /*fprintf(stderr, "===CALL destroy on OBJECTS\n");*/ + + for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTable, hPtr); + XOTclObject *object = XOTclpGetObject(interp, key); + /* fprintf(stderr, "key = %s %p %d\n", + key, obj, obj && !XOTclObjectIsClass(object)); */ + if (object && !XOTclObjectIsClass(object) + && !(object->flags & XOTCL_DESTROY_CALLED)) { + callDestroyMethod(interp, object, 0); + } + } + + /*fprintf(stderr, "===CALL destroy on CLASSES\n");*/ + + for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTable, hPtr); + XOTclClass *cl = XOTclpGetClass(interp, key); + if (cl && !(cl->object.flags & XOTCL_DESTROY_CALLED)) { + callDestroyMethod(interp, (XOTclObject *)cl, 0); + } + } + + /* now, turn of filters, all destroy callbacks are done */ + RUNTIME_STATE(interp)->doFilters = 0; + +#ifdef DO_CLEANUP + freeAllXOTclObjectsAndClasses(interp, commandNameTable); + +# ifdef DO_FULL_CLEANUP + deleteProcsAndVars(interp); +# endif +#endif + + MEM_COUNT_FREE("Tcl_InitHashTable", commandNameTable); + Tcl_DeleteHashTable(commandNameTable); + + /* now free all objects systems with their root classes */ + for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = nPtr) { + nPtr = osPtr->nextPtr; + ObjectSystemFree(interp, osPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * GetObjectSystem -- + * + * Return the object system for which the object was defined + * + * Results: + * Object system pointer + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static XOTclObjectSystem * +GetObjectSystem(XOTclObject *object) { + if (XOTclObjectIsClass(object)) { + return ((XOTclClass *)object)->osPtr; + } + return object->cl->osPtr; +} + +/* + *---------------------------------------------------------------------- + * CallDirectly -- + * + * Determine when it is possible/necessary to call a method + * implementation directly or via method dispatch. + * + * Results: + * 1 is returned when command should be invoked directly, 0 + * otherwise. + * + * Side effects: + * methodObjPtr is set with the Tcl_Obj of the name of the method, + * if there is one defined. + * + *---------------------------------------------------------------------- + */ +static int CallDirectly(Tcl_Interp *interp, XOTclObject *object, int methodIdx, Tcl_Obj **methodObjPtr) { + /* + We can/must call a C-implemented method directly, when + a) the object system has no such appropriate method defined + + b) the script does not contain a method with the appropriate + name, and + + c) filters are not active on the object + */ + XOTclObjectSystem *osPtr = GetObjectSystem(object); + Tcl_Obj *methodObj = osPtr->methods[methodIdx]; + int callDirectly = 1; + + if (methodObj) { + + if ((osPtr->overloadedMethods & 1<definedMethods & 1<flags & XOTCL_FILTER_ORDER_VALID)) { + FilterComputeDefined(interp, object); + } + /*fprintf(stderr, "CallDirectly object %s idx %s obejct flags %.6x %.6x \n", + objectName(object), sytemMethodOpts[methodIdx]+1, + (object->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID), + XOTCL_FILTER_ORDER_DEFINED_AND_VALID + );*/ + if ((object->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == XOTCL_FILTER_ORDER_DEFINED_AND_VALID) { + /*fprintf(stderr, "CallDirectly object %s idx %s has filter \n", + objectName(object), sytemMethodOpts[methodIdx]+1);*/ + callDirectly = 0; + } + } + } + +#if 0 + fprintf(stderr, "CallDirectly object %s idx %s returns %s => %d\n", + objectName(object), sytemMethodOpts[methodIdx]+1, + methodObj ? ObjStr(methodObj) : "(null)", callDirectly); +#endif + /* return the methodObj in every case */ + *methodObjPtr = methodObj; + return callDirectly; +} + +/* + *---------------------------------------------------------------------- + * XOTclMethodObj -- + * + * Return the methodObj for a given method index. + * + * Results: + * Returns Tcl_Obj* or NULL + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * XOTclMethodObj(Tcl_Interp *interp, XOTclObject *object, int methodIdx) { + XOTclObjectSystem *osPtr = GetObjectSystem(object); + /* + fprintf(stderr, "XOTclMethodObj object %s os %p idx %d %s methodObj %p\n", + objectName(object), osPtr, methodIdx, + XOTcl_SytemMethodOpts[methodIdx]+1, + osPtr->methods[methodIdx]); + */ + return osPtr->methods[methodIdx]; +} + +static int +callDestroyMethod(Tcl_Interp *interp, XOTclObject *object, int flags) { + int result; + Tcl_Obj *methodObj; + + /* don't call destroy after exit handler started physical + destruction, or when it was called already before */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == + XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY + || (object->flags & XOTCL_DESTROY_CALLED) + ) + return TCL_OK; + + /*fprintf(stderr, " callDestroy obj %p flags %.6x active %d\n", object, object->flags, + object->activationCount);*/ + + PRINTOBJ("callDestroy", object); + + /* flag, that destroy was called and invoke the method */ + object->flags |= XOTCL_DESTROY_CALLED; + + if (CallDirectly(interp, object, XO_o_destroy_idx, &methodObj)) { + result = XOTclODestroyMethod(interp, object); + } else { + result = callMethod(object, interp, methodObj, 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) + 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", object); +#endif + return result; +} + +/* + * conditional memory allocations of optional storage + */ + +extern XOTclObjectOpt * +XOTclRequireObjectOpt(XOTclObject *object) { + if (!object->opt) { + object->opt = NEW(XOTclObjectOpt); + memset(object->opt, 0, sizeof(XOTclObjectOpt)); + } + return object->opt; +} + +extern XOTclClassOpt* +XOTclRequireClassOpt(/*@notnull@*/ XOTclClass *cl) { + 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; +} + + + + +static Tcl_Namespace* +NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, CONST char *name, int create); + +static void +makeObjNamespace(Tcl_Interp *interp, XOTclObject *object) { +#ifdef NAMESPACE_TRACE + fprintf(stderr, "+++ Make Namespace for %s\n", objectName(object)); +#endif + if (!object->nsPtr) { + Tcl_Namespace *nsPtr; + object->nsPtr = NSGetFreshNamespace(interp, (ClientData)object, + objectName(object), 1); + if (!object->nsPtr) + Tcl_Panic("makeObjNamespace: Unable to make namespace", NULL); + nsPtr = object->nsPtr; + + /* + * Copy all obj variables to the newly created namespace + */ + if (object->varTable) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); + Tcl_HashTable *varHashTable = VarHashTable(varTable); + Tcl_HashTable *objHashTable = VarHashTable(object->varTable); + + *varHashTable = *objHashTable; /* copy the table */ + + if (objHashTable->buckets == objHashTable->staticBuckets) { + varHashTable->buckets = varHashTable->staticBuckets; + } + for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + hPtr->tablePtr = varHashTable; + } + CallStackReplaceVarTableReferences(interp, object->varTable, + (TclVarHashTable *)varHashTable); + + ckfree((char *) object->varTable); + object->varTable = NULL; + } + } +} + +static Tcl_Var +CompiledLocalsLookup(CallFrame *varFramePtr, CONST char *varName) { + int i, localCt = varFramePtr->numCompiledLocals; + Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; + + /*fprintf(stderr, ".. search #local vars %d\n", localCt);*/ + for (i=0 ; icompiledLocals[i]; + } + } + } + return NULL; +} + + +static int +NsColonVarResolver(Tcl_Interp *interp, CONST char *varName, Tcl_Namespace *nsPtr, int flags, Tcl_Var *varPtr) { + Tcl_CallFrame *varFramePtr; + TclVarHashTable *varTablePtr; + XOTclObject *object; + int new, frameFlags; + char firstChar, secondChar; + Tcl_Obj *key; + Var *newVar; + +#if defined (VAR_RESOLVER_TRACE) + fprintf(stderr, "NsColonVarResolver '%s' flags %.6x\n", varName, flags); +#endif + + /* Case 1: The variable is to be resolved in global scope, proceed in + * resolver chain (i.e. return TCL_CONTINUE) + */ + if (flags & TCL_GLOBAL_ONLY) { + /*fprintf(stderr, "global-scoped lookup for var '%s' in NS '%s'\n", varName, + nsPtr->fullName);*/ + return TCL_CONTINUE; + } + + /* Case 2: The lookup happens in a proc frame (lookup in compiled + * locals and hash table vars). We are not interested to handle + * these cases here, so proceed in resolver chain. + */ + varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + assert(varFramePtr); + + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); +#if defined (VAR_RESOLVER_TRACE) + fprintf(stderr, "NsColonVarResolver '%s' frame flags %.6x\n", varName, + Tcl_CallFrame_isProcCallFrame(varFramePtr)); +#endif + + if (frameFlags & FRAME_IS_PROC) { +#if defined (VAR_RESOLVER_TRACE) + fprintf(stderr, "...... forwarding to next resolver\n"); +#endif + /*fprintf(stderr, "proc-scoped var '%s' assumed, frame %p flags %.6x\n", + name, varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr));*/ + return TCL_CONTINUE; + } + + firstChar = *varName; + secondChar = *(varName+1); + + if (frameFlags & (FRAME_IS_XOTCL_CMETHOD|FRAME_IS_XOTCL_OBJECT)) { + /* + Case 3: we are in an XOTcl frame + */ + if (firstChar == ':') { + if (secondChar != ':') { + /* + * Case 3a: The variable name starts with a single ":". Skip + * the char, but stay in the resolver. + */ + varName ++; + } else { + /* + Case 3b: Names starting with "::" are not for us + */ + return TCL_CONTINUE; + } + } else if (NSTail(varName) != varName) { + /* + Case 3c: Names containing "::" are not for us + */ + return TCL_CONTINUE; + } + + object = (frameFlags & FRAME_IS_XOTCL_CMETHOD) + ? ((XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr))->self + : (XOTclObject *)Tcl_CallFrame_clientData(varFramePtr); + + } else { + /* + * Case 4: we are not in an XOTcl frame, so proceed with a + * TCL_CONTINUE. + */ + return TCL_CONTINUE; + } + + /* We have an object and create the variable if not found */ + assert(object); + + varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + assert(varTablePtr); + + /* + * Does the variable exist in the object's namespace? + */ + + key = Tcl_NewStringObj(varName, -1); + INCR_REF_COUNT(key); + + *varPtr = (Tcl_Var)VarHashCreateVar(varTablePtr, key, NULL); + +#if defined (VAR_RESOLVER_TRACE) + fprintf(stderr, "...... lookup of '%s' for object '%s' returns %p\n", + varName, objectName(object), *varPtr); +#endif + if (*varPtr == NULL) { + /* + * We failed to find the variable so far, therefore we create it + * in this var table. Note that in several cases above, + * TCL_CONTINUE takes care for variable creation. + */ + + newVar = VarHashCreateVar(varTablePtr, key, &new); + *varPtr = (Tcl_Var)newVar; + } + DECR_REF_COUNT(key); + + return *varPtr ? TCL_OK : TCL_ERROR; +} + +/********************************************************* + * + * Begin of compiled var resolver + * + *********************************************************/ +#define FOR_COLON_RESOLVER(ptr) (*(ptr) == ':' && *(ptr+1) != ':') + +typedef struct xotclResolvedVarInfo { + Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ + XOTclObject *lastObject; + Tcl_Var var; + Tcl_Obj *nameObj; +} xotclResolvedVarInfo; + +/* + *---------------------------------------------------------------------- + * HashVarFree -- + * + * Free hashed variables based on refcount. + * + * Results: + * None. + * + * Side effects: + * Changed refCount or freed variable. + * + *---------------------------------------------------------------------- + */ +static void +HashVarFree(Tcl_Var var) { + if (VarHashRefCount(var) < 2) { + /*fprintf(stderr,"#### free %p\n", var);*/ + ckfree((char *) var); + } else { + VarHashRefCount(var)--; + } +} + +/* + *---------------------------------------------------------------------- + * CompiledColonVarFetch -- + * + * Fetch value of a a compiled XOTcl instance variable at runtime. + * + * Results: + * Tcl_Var containing value or NULL. + * + * Side effects: + * Updates of Variable structure cache in necessary. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Var +CompiledColonVarFetch(Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr) { + xotclResolvedVarInfo *resVarInfo = (xotclResolvedVarInfo *)vinfoPtr; + XOTclCallStackContent *cscPtr = CallStackGetFrame(interp, NULL); + XOTclObject *object = cscPtr ? cscPtr->self : NULL; + TclVarHashTable *varTablePtr; + Tcl_Var var = resVarInfo->var; + int new, flags = var ? ((Var*)var)->flags : 0; + +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr,"CompiledColonVarFetch var '%s' var %p flags = %.4x dead? %.4x\n", + ObjStr(resVarInfo->nameObj), var, flags, flags&VAR_DEAD_HASH); +#endif + + /* + * We cache lookups based on xotcl objects; we have to care about + * cases, where the instance variables are in some delete states. + * + */ + + if (object == resVarInfo->lastObject && ((flags & VAR_DEAD_HASH)) == 0) { + /* + * The variable is valid. + */ +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, ".... cached var '%s' var %p flags = %.4x\n", + ObjStr(resVarInfo->nameObj), var, flags); +#endif + return var; + } + + if (var) { + /* + * The variable is not valid anymore. Clean it up. + */ + HashVarFree(var); + } + + varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + assert(varTablePtr); + + resVarInfo->lastObject = object; + resVarInfo->var = var = (Tcl_Var) VarHashCreateVar(varTablePtr, resVarInfo->nameObj, &new); + /* + * Increment the reference counter to avoid ckfree() of the variable + * in Tcl's FreeVarEntry(); for cleanup, we provide our own + * HashVarFree(); + */ + VarHashRefCount(var)++; + +#if defined(VAR_RESOLVER_TRACE) + { + Var *v = (Var*)(resVarInfo->var); + fprintf(stderr, ".... looked up var %s var %p flags = %.6x\n", + ObjStr(resVarInfo->nameObj), + v, v->flags); + } +#endif + return var; +} + +/* + *---------------------------------------------------------------------- + * CompiledColonVarFree -- + * + * DeleteProc of the compiled variable handler. + * + * Results: + * None. + * + * Side effects: + * Free compiled variable structure and variable. + * + *---------------------------------------------------------------------- + */ +void CompiledColonVarFree(Tcl_ResolvedVarInfo *vinfoPtr) { + xotclResolvedVarInfo *resVarInfo = (xotclResolvedVarInfo *)vinfoPtr; + DECR_REF_COUNT(resVarInfo->nameObj); + if (resVarInfo->var) {HashVarFree(resVarInfo->var);} + ckfree((char *) vinfoPtr); +} + +/* + *---------------------------------------------------------------------- + * InterpCompiledColonVarResolver -- + * + * Register for prefixed variables our own compiled var handler. + * + * Results: + * TCL_OK or TCL_CONTINUE (based on Tcl's var resolver protocol) + * + * Side effects: + * Registered var handler or none. + * + *---------------------------------------------------------------------- + */ +int InterpCompiledColonVarResolver(Tcl_Interp *interp, + CONST84 char *name, int length, Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr) { + /* + * The variable handler is registered, when we have an active XOTcl + * object and the variable starts with the appropriate prefix. Note + * that getting the "self" object is a weak protection against + * handling of wrong vars + */ + XOTclObject *object = GetSelfObj(interp); + +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, "compiled var resolver for %s, obj %p\n", name, object); +#endif + + if (object && FOR_COLON_RESOLVER(name)) { + xotclResolvedVarInfo *vInfoPtr = (xotclResolvedVarInfo *) ckalloc(sizeof(xotclResolvedVarInfo)); + + vInfoPtr->vInfo.fetchProc = CompiledColonVarFetch; + vInfoPtr->vInfo.deleteProc = CompiledColonVarFree; /* if NULL, tcl does a ckfree on proc clean up */ + vInfoPtr->lastObject = NULL; + vInfoPtr->var = NULL; + vInfoPtr->nameObj = Tcl_NewStringObj(name+1, length-1); + INCR_REF_COUNT(vInfoPtr->nameObj); + *rPtr = (Tcl_ResolvedVarInfo *)vInfoPtr; + + return TCL_OK; + } + return TCL_CONTINUE; +} + +/* + *---------------------------------------------------------------------- + * InterpColonVarResolver -- + * + * Resolve varnames as instance variables. These might be compiled + * locals or variables to be created (e.g. during an eval) in the + * objects vartables. If the command starts with the XOTcl + * specific prefix and we are on an XOTcl stack frame, treat + * command as instance varname. + * + * Results: + * TCL_OK or TCL_CONTINUE (based on Tcl's var resolver protocol) + * + * Side effects: + * If successful, return varPtr, pointing to instance variable. + * + *---------------------------------------------------------------------- + */ +static int +InterpColonVarResolver(Tcl_Interp *interp, CONST char *varName, Tcl_Namespace *nsPtr, int flags, Tcl_Var *varPtr) { + int new, frameFlags; + CallFrame *varFramePtr; + TclVarHashTable *varTablePtr; + XOTclObject *object; + Tcl_Obj *keyObj; + Tcl_Var var; + + if (!FOR_COLON_RESOLVER(varName) || (flags & TCL_GLOBAL_ONLY)) { + /* ordinary names and global lookups are not for us */ +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, "InterpColonVarResolver '%s' flags %.6x not for us nsPtr %p\n", + varName, flags, nsPtr); +#endif + return TCL_CONTINUE; + } + + varFramePtr = Tcl_Interp_varFramePtr(interp); + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); + +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, "InterpColonVarResolver called var '%s' flags %.4x frame flags %.6x\n", + varName, flags, frameFlags); +#endif + varName ++; + + if (frameFlags & FRAME_IS_XOTCL_METHOD) { + if ((*varPtr = CompiledLocalsLookup(varFramePtr, varName))) { +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, ".... found local %s\n", varName); +#endif + return TCL_OK; + } + + object = ((XOTclCallStackContent *)varFramePtr->clientData)->self; + + } else if (frameFlags & FRAME_IS_XOTCL_CMETHOD) { + object = ((XOTclCallStackContent *)varFramePtr->clientData)->self; + + } else if (frameFlags & FRAME_IS_XOTCL_OBJECT) { + object = (XOTclObject *)(varFramePtr->clientData); + + } else { +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, ".... not found %s\n", varName); +#endif + return TCL_CONTINUE; + } + + /* We have an object and create the variable if not found */ + assert(object); + + varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + assert(varTablePtr); + + /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTable %p\n", + varName, object, object->nsPtr, varTablePtr);*/ + + keyObj = Tcl_NewStringObj(varName, -1); + INCR_REF_COUNT(keyObj); + + var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, NULL); + if (var) { +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, ".... found in hashtable %s %p\n", varName, var); +#endif + } else { + /* + We failed to find the variable, therefore we create it new + */ + var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, &new); +#if defined(VAR_RESOLVER_TRACE) + fprintf(stderr, ".... var %p %s created in hashtable %p\n", var, varName, varTablePtr); +#endif + } + *varPtr = var; + DECR_REF_COUNT(keyObj); + + return TCL_OK; +} +/********************************************************* + * + * End of var resolvers + * + *********************************************************/ + +/********************************************************* + * + * Begin of cmd resolver + * + *********************************************************/ +/* + *---------------------------------------------------------------------- + * InterpColonCmdResolver -- + * + * Resolve command names. If the command starts with the XOTcl + * specific prefix and we are on an XOTcl stack frame, treat + * command as OO method. + * + * Results: + * TCL_OK or TCL_CONTINUE (based on Tcl's command resolver protocol) + * + * Side effects: + * If successful, return cmdPtr, pointing to method. + * + *---------------------------------------------------------------------- + */ +static int +InterpColonCmdResolver(Tcl_Interp *interp, CONST char *cmdName, Tcl_Namespace *nsPtr, int flags, Tcl_Command *cmdPtr) { + CallFrame *varFramePtr; + int frameFlags; + + if (!FOR_COLON_RESOLVER(cmdName) || flags & TCL_GLOBAL_ONLY) { + /* ordinary names and global lookups are not for us */ + return TCL_CONTINUE; + } + + varFramePtr = Tcl_Interp_varFramePtr(interp); + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); + + /* skip over a nonproc frame, in case Tcl stacks it */ + if (frameFlags == 0 && Tcl_CallFrame_callerPtr(varFramePtr)) { + varFramePtr = (CallFrame *)Tcl_CallFrame_callerPtr(varFramePtr); + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); +#if defined(CMD_RESOLVER_TRACE) + fprintf(stderr, "InterpColonCmdResolver uses parent frame\n"); +#endif + } +#if defined(CMD_RESOLVER_TRACE) + fprintf(stderr, "InterpColonCmdResolver cmdName %s flags %.6x, frame flags %.6x\n",cmdName, + flags, Tcl_CallFrame_isProcCallFrame(varFramePtr)); +#endif + + if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_OBJECT|FRAME_IS_XOTCL_CMETHOD )) { +#if defined(CMD_RESOLVER_TRACE) + fprintf(stderr, " ... call colonCmd for %s\n", cmdName); +#endif + /* + * We have a cmd starting with ':', we are in an xotcl frame, so + * forward to the colonCmd. + */ + *cmdPtr = RUNTIME_STATE(interp)->colonCmd; + return TCL_OK; + } + +#if defined(CMD_RESOLVER_TRACE) + fprintf(stderr, " ... not found %s\n", cmdName); + tcl85showStack(interp); +#endif + return TCL_CONTINUE; +} +/********************************************************* + * + * End of cmd resolver + * + *********************************************************/ + +static Tcl_Namespace * +requireObjNamespace(Tcl_Interp *interp, XOTclObject *object) { + + if (!object->nsPtr) { + makeObjNamespace(interp, object); + } + /* 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(object->nsPtr, /*(Tcl_ResolveCmdProc*)NsColonCmdResolver*/ NULL, + NsColonVarResolver, + /*(Tcl_ResolveCompiledVarProc*)NsCompiledColonVarResolver*/NULL); + return object->nsPtr; +} + +extern void +XOTclRequireObjNamespace(Tcl_Interp *interp, XOTcl_Object *object) { + requireObjNamespace(interp, (XOTclObject*) object); +} + + +/* + * Namespace related commands + */ + +static int +NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST 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(nsPtr); + if ((token = FindMethod(nsPtr, name))) { + return Tcl_DeleteCommandFromToken(interp, token); + } + return -1; +} + +static void CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *object); +static void PrimitiveCDestroy(ClientData clientData); +static void PrimitiveODestroy(ClientData clientData); +static void PrimitiveDestroy(ClientData clientData); + +static void +NSDeleteChildren(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(nsPtr); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + +#ifdef OBJDELETION_TRACE + fprintf(stderr, "NSDeleteChildren %p %s\n", nsPtr, nsPtr->fullName); +#endif + + Tcl_ForgetImport(interp, nsPtr, "*"); /* don't destroy namespace imported objects */ + + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + + if (!Tcl_Command_cmdEpoch(cmd)) { + XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); + + /*fprintf(stderr, "... check %p %s\n", object, object ? objectName(object) : "(null)");*/ + + if (object) { + /*fprintf(stderr, " ... child %s %p -- %s\n", oname, object, object ? objectName(object):"(null)");*/ + /*fprintf(stderr, " ... obj=%s flags %.4x\n", objectName(object), object->flags);*/ + + /* in the exit handler physical destroy --> directly call destroy */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound + == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { + PrimitiveDestroy((ClientData) object); + } else { + if (object->teardown && !(object->flags & XOTCL_DESTROY_CALLED)) { + /*fprintf(stderr, " ... call destroy obj=%s flags %.4x\n", objectName(object), object->flags);*/ + + if (callDestroyMethod(interp, object, 0) != TCL_OK) { + /* destroy method failed, but we have to remove the command + anyway. */ + if (object->teardown) { + CallStackDestroyObject(interp, object); + } + } + } + } + } + } + } +} + +/* + * ensure that a variable exists on object varTable or nsPtr->varTable, + * if necessary create it. Return Var* if successful, otherwise 0 + */ +static Var * +NSRequireVariableOnObj(Tcl_Interp *interp, XOTclObject *object, CONST char *name, int flgs) { + Tcl_CallFrame frame, *framePtr = &frame; + Var *varPtr, *arrayPtr; + + XOTcl_PushFrameObj(interp, object, framePtr); + varPtr = TclLookupVar(interp, name, 0, flgs, "obj vwait", + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + XOTcl_PopFrameObj(interp, framePtr); + return varPtr; +} + +static int +XOTcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command cmd) { + CallStackClearCmdReferences(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; + +#ifdef OBJDELETION_TRACE + fprintf(stderr, "NSCleanupNamespace %p\n", ns); + fprintf(stderr, "NSCleanupNamespace %p %.6x varTable %p\n", ns, ((Namespace *)ns)->flags, varTable); +#endif + /* + * Delete all variables and initialize var table again + * (DeleteVars frees the vartable) + */ + TclDeleteVars((Interp *)interp, varTable); + TclInitVarHashTable(varTable, (Namespace *)ns); + + /* + * Delete all user-defined procs in the namespace + */ + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); + Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + XOTclObject *invokeObj = proc == XOTclObjDispatch ? (XOTclObject *)Tcl_Command_objClientData(cmd) : NULL; + + /* objects should not be deleted here to preseve children deletion order */ + if (invokeObj && cmd != invokeObj->id) { + /* + * cmd is an aliased object, reduce the refcount + */ + /*fprintf(stderr, "NSCleanupNamespace cleanup aliased object %p\n", invokeObj); */ + XOTclCleanupObject(invokeObj); + XOTcl_DeleteCommandFromToken(interp, cmd); + } + if (invokeObj) { + /* + * cmd is a child object + */ + continue; + } + + /* fprintf(stderr, "NSCleanupNamespace calls DeleteCommandFromToken for %p flags %.6x invokeObj %p obj %p\n", + cmd, ((Command *)cmd)->flags, invokeObj,object); + fprintf(stderr, " cmd = %s\n", Tcl_GetCommandName(interp,cmd)); + fprintf(stderr, " nsPtr = %p\n", ((Command *)cmd)->nsPtr); + fprintf(stderr, " flags %.6x\n", ((Namespace *)((Command *)cmd)->nsPtr)->flags);*/ + + XOTcl_DeleteCommandFromToken(interp, cmd); + } +} + + +static void +NSNamespaceDeleteProc(ClientData clientData) { + /* dummy for ns identification by pointer comparison */ + XOTclObject *object = (XOTclObject*) clientData; + /*fprintf(stderr, "namespacedeleteproc obj=%p ns=%p\n", + clientData,object ? object->nsPtr : NULL);*/ + if (object) { + object->nsPtr = NULL; + } +} + +void +XOTcl_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { + int activationCount = 0; + Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); + + /*fprintf(stderr, "XOTcl_DeleteNamespace %p ", nsPtr);*/ + + while (f) { + if (f->nsPtr == nsPtr) + activationCount++; + f = Tcl_CallFrame_callerPtr(f); + } + + /* todo remove debug line */ + if (Tcl_Namespace_activationCount(nsPtr) != activationCount) { + fprintf(stderr, "WE HAVE TO FIX ACTIVATIONCOUNT\n"); + Tcl_Namespace_activationCount(nsPtr) = activationCount; + } + + /*fprintf(stderr, "to %d. \n", ((Namespace *)nsPtr)->activationCount);*/ + + MEM_COUNT_FREE("TclNamespace", nsPtr); + if (Tcl_Namespace_deleteProc(nsPtr)) { + /*fprintf(stderr, "calling deteteNamespace %s\n", nsPtr->fullName);*/ + Tcl_DeleteNamespace(nsPtr); + } +} + +static Tcl_Namespace* +NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, CONST char *name, int create) { + Tcl_Namespace *nsPtr = Tcl_FindNamespace(interp, name, NULL, 0); + + if (nsPtr) { + if (nsPtr->deleteProc || nsPtr->clientData) { + Tcl_Panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace, my delete Proc %p", + name, nsPtr->deleteProc, nsPtr->clientData, NSNamespaceDeleteProc); + } + nsPtr->clientData = clientData; + nsPtr->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc; + } else if (create) { + nsPtr = Tcl_CreateNamespace(interp, name, clientData, + (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc); + } + MEM_COUNT_ALLOC("TclNamespace", nsPtr); + return nsPtr; +} + + +/* + * check colons for illegal object/class names + */ +XOTCLINLINE static int +NSCheckColons(CONST char *name, size_t l) { + register CONST 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, CONST char *name, size_t l, XOTclClass *cl) { + register CONST char *n = name+l; + int rc = 1; + + /*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); + + Tcl_DStringAppend(dsp, name, (n-name)); + parentName = Tcl_DStringValue(dsp); + + 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 { + XOTclClass *defaultSuperClass = DefaultSuperClass(interp, cl, cl->object.cl, 0); + Tcl_Obj *methodObj = XOTclMethodObj(interp, &defaultSuperClass->object, XO_c_requireobject_idx); + + if (methodObj) { + /* call requireObject and try again */ + Tcl_Obj *ov[3]; + int result; + + ov[0] = defaultSuperClass->object.cmdName; + ov[1] = methodObj; + ov[2] = Tcl_NewStringObj(parentName, -1); + INCR_REF_COUNT(ov[2]); + /*fprintf(stderr, "+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/ + result = Tcl_EvalObjv(interp, 3, ov, 0); + if (result == TCL_OK) { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + requireObjNamespace(interp, parentObj); + } + rc = (Tcl_FindNamespace(interp, parentName, + (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != NULL); + } else { + rc = 0; + } + DECR_REF_COUNT(ov[2]); + } + } + } else { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + requireObjNamespace(interp, parentObj); + } + } + DSTRING_FREE(dsp); + } + return rc; +} + +/* + * Find the "real" command belonging eg. to an XOTcl class or object. + * Do not return cmds produced by Tcl_Import, but the "real" cmd + * to which they point. + */ +XOTCLINLINE static Tcl_Command +NSFindCommand(Tcl_Interp *interp, CONST 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; +} + + + +/* + * C interface routines for manipulating objects and classes + */ + + +extern XOTcl_Object* +XOTclGetObject(Tcl_Interp *interp, CONST char *name) { + return (XOTcl_Object*) XOTclpGetObject(interp, name); +} + +/* + * Find an object using a char *name + */ +static XOTclObject* +XOTclpGetObject(Tcl_Interp *interp, CONST char *name) { + 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 OK %d\n", + name, Tcl_Command_objProc(cmd), XOTclObjDispatch, Tcl_Command_objProc(cmd) == XOTclObjDispatch); + }*/ + + 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; +} + +/* + * Find a class using a char *name + */ + +extern XOTcl_Class* +XOTclGetClass(Tcl_Interp *interp, CONST char *name) { + return (XOTcl_Class*)XOTclpGetClass(interp, name); +} + +static XOTclClass* +XOTclpGetClass(Tcl_Interp *interp, CONST char *name) { + XOTclObject *object = XOTclpGetObject(interp, name); + return (object && XOTclObjectIsClass(object)) ? (XOTclClass*)object : NULL; +} + +static int +CanRedefineCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, XOTclObject *object, CONST char *methodName) { + int result, ok; + Tcl_Command cmd = FindMethod(nsPtr, methodName); + + ok = cmd ? (Tcl_Command_flags(cmd) & XOTCL_CMD_REDEFINE_PROTECTED_METHOD) == 0 : 1; + if (ok) { + result = TCL_OK; + } else { + result = XOTclVarErrMsg(interp, "Method '", methodName, "' of ", objectName(object), + " can not be overwritten. Derive e.g. a sub-class!", + (char *) NULL); + } + ObjectSystemsCheckSystemMethod(interp, methodName, GetObjectSystem(object)); + + return result; +} + +int +XOTclAddObjectMethod(Tcl_Interp *interp, XOTcl_Object *object1, CONST char *methodName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, + int flags) { + XOTclObject *object = (XOTclObject *)object1; + Tcl_DString newCmdName, *dsPtr = &newCmdName; + Tcl_Namespace *ns = requireObjNamespace(interp, object); + Tcl_Command newCmd; + int result; + + /* Check, if we are allowed to redefine the method */ + result = CanRedefineCmd(interp, object->nsPtr, object, (char*)methodName); + if (result != TCL_OK) { + return result; + } + + /* delete an alias definition, if it exists */ + AliasDelete(interp, object->cmdName, methodName, 1); + + 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 TCL_OK; +} + +int +XOTclAddClassMethod(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; + int result; + + /* Check, if we are allowed to redefine the method */ + result = CanRedefineCmd(interp, cl->nsPtr, &cl->object, (char*)methodName); + if (result != TCL_OK) { + return result; + } + + /* delete an alias definition, if it exists */ + AliasDelete(interp, class->object.cmdName, methodName, 0); + + 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 TCL_OK; +} + +/* + * Generic Tcl_Obj List + */ + +static void +TclObjListFreeList(XOTclTclObjList *list) { + 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; +} + +/* + * Autonaming + */ + +static Tcl_Obj * +AutonameIncr(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTclObject *object, + int instanceOpt, int resetOpt) { + int valueLength, mustCopy = 1, format = 0; + char *valueString, *c; + Tcl_Obj *valueObj, *result = NULL, *savedResult = NULL; + int flgs = TCL_LEAVE_ERR_MSG; + Tcl_CallFrame frame, *framePtr = &frame; + + XOTcl_PushFrameObj(interp, object, framePtr); + if (object->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; + + valueObj = Tcl_ObjGetVar2(interp, XOTclGlobalObjs[XOTE_AUTONAMES], nameObj, flgs); + if (valueObj) { + long autoname_counter; + /* should probably do an overflow check here */ + Tcl_GetLongFromObj(interp, valueObj, &autoname_counter); + autoname_counter++; + if (Tcl_IsShared(valueObj)) { + valueObj = Tcl_DuplicateObj(valueObj); + } + Tcl_SetLongObj(valueObj, autoname_counter); + } + Tcl_ObjSetVar2(interp, XOTclGlobalObjs[XOTE_AUTONAMES], nameObj, + valueObj, flgs); + + if (resetOpt) { + if (valueObj) { /* we have an entry */ + Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(nameObj), flgs); + } + result = XOTclGlobalObjs[XOTE_EMPTY]; + INCR_REF_COUNT(result); + } else { + if (valueObj == NULL) { + valueObj = Tcl_ObjSetVar2(interp, XOTclGlobalObjs[XOTE_AUTONAMES], + nameObj, XOTclGlobalObjs[XOTE_ONE], flgs); + } + if (instanceOpt) { + char buffer[1], firstChar; + CONST char *nextChars = ObjStr(nameObj); + firstChar = *(nextChars ++); + if (isupper((int)firstChar)) { + buffer[0] = tolower((int)firstChar); + result = Tcl_NewStringObj(buffer, 1); + INCR_REF_COUNT(result); + Tcl_AppendLimitedToObj(result, nextChars, -1, INT_MAX, NULL); + mustCopy = 0; + } + } + if (mustCopy) { + result = Tcl_DuplicateObj(nameObj); + 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[1] = result; + ov[2] = valueObj; + if (XOTclCallCommand(interp, XOTE_FORMAT, 3, ov) != TCL_OK) { + XOTcl_PopFrameObj(interp, framePtr); + DECR_REF_COUNT(savedResult); + FREE_ON_STACK(Tcl_Obj*, 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(Tcl_Obj*, ov); + } else { + valueString = Tcl_GetStringFromObj(valueObj, &valueLength); + Tcl_AppendLimitedToObj(result, valueString, valueLength, INT_MAX, NULL); + /*fprintf(stderr, "+++ append to obj done\n");*/ + } + } + + XOTcl_PopFrameObj(interp, framePtr); + assert((resetOpt && result->refCount>=1) || (result->refCount == 1)); + return result; +} + +/* + * XOTcl CallStack + */ + +static void +CallStackRestoreSavedFrames(Tcl_Interp *interp, callFrameContext *ctx) { + if (ctx->framesSaved) { + Tcl_Interp_varFramePtr(interp) = (CallFrame *)ctx->varFramePtr; + /*RUNTIME_STATE(interp)->varFramePtr = ctx->varFramePtr;*/ + + } +} + +XOTCLINLINE static void +CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *object) { + Tcl_Command oid; + + PRINTOBJ("CallStackDoDestroy", object); + + /* Don't do anything, if a recursive DURING_DELETE is for some + * reason active. + */ + if (object->flags & XOTCL_DURING_DELETE) { + return; + } + /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x activation %d cmd %p \n", + object, object->flags, object->activationCount, object->id);*/ + object->flags |= XOTCL_DURING_DELETE; + oid = object->id; + /* oid might be freed already, we can't even use (((Command*)oid)->flags & CMD_IS_DELETED) */ + + if (object->teardown && oid) { + + /* PrimitiveDestroy() has to be before DeleteCommandFromToken(), + otherwise e.g. unset traces on this object cannot be executed + from Tcl. We make sure via refcounting that the object structure + is kept until after DeleteCommandFromToken(). + */ + + object->refCount ++; + + /*fprintf(stderr, "CallStackDoDestroy %p after refCount ++ %d teardown %p\n", + object, object->refCount, object->teardown);*/ + + PrimitiveDestroy((ClientData) object); +; + if (!(object->flags & XOTCL_TCL_DELETE) /*&& !(object->flags & XOTCL_CMD_NOT_FOUND)*/) { + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + INCR_REF_COUNT(savedObjResult); + /*fprintf(stderr, " before DeleteCommandFromToken %p object flags %.6x\n", oid, object->flags);*/ + /*fprintf(stderr, "cmd dealloc %p refcount %d dodestroy \n", oid, Tcl_Command_refCount(oid));*/ + Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ + /*fprintf(stderr, " after DeleteCommandFromToken %p %.6x\n", oid, ((Command*)oid)->flags);*/ + Tcl_SetObjResult(interp, savedObjResult); + DECR_REF_COUNT(savedObjResult); + } + XOTclCleanupObject(object); + } +} + +static void +CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *object) { + +#ifdef OBJDELETION_TRACE + fprintf(stderr, "CallStackDestroyObject %p %s activationcount %d flags %.6x\n", + object, objectName(object), object->activationCount, object->flags); +#endif + + if ((object->flags & XOTCL_DESTROY_CALLED) == 0) { + int activationCount = object->activationCount; + /* if the destroy method was not called yet, do it now */ +#ifdef OBJDELETION_TRACE + fprintf(stderr, " CallStackDestroyObject has to callDestroyMethod %p activationCount %d\n", + object, activationCount); +#endif + callDestroyMethod(interp, object, 0); + + if (activationCount == 0) { + /* We assume, the object is now freed. if the oobjectbj is already + freed, we cannot access activation count, and we cannot call + CallStackDoDestroy */ + /*fprintf(stderr, " CallStackDestroyObject %p done\n", obj);*/ + return; + } + } + + /* If the object is not referenced on the callstack anymore + we have to destroy it directly, because CscFinish won't + find the object destroy */ + if (object->activationCount == 0) { + CallStackDoDestroy(interp, object); + } else { + /* to prevail the deletion order call delete children now + -> children destructors are called before parent's + destructor */ + if (object->teardown && object->nsPtr) { + /*fprintf(stderr, " CallStackDestroyObject calls NSDeleteChildren\n");*/ + NSDeleteChildren(interp, object->nsPtr); + } + } + /*fprintf(stderr, " CallStackDestroyObject %p DONE\n", object);*/ +} + +/* + * cmd list handling + */ + +/* + * Cmd List Add/Remove ... returns the new element + */ +static XOTclCmdList* +CmdListAdd(XOTclCmdList **cList, Tcl_Command c, XOTclClass *clorobj, int noDuplicates) { + 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; + } + } + + /* + * 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; +} + +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); +} + +#if 0 +/** for debug purposes only */ +static void +CmdListPrint(Tcl_Interp *interp, CONST 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->next; + } +} +#endif + +/* + * physically delete an entry 'del' + */ +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); +} + +/* + * remove a command 'delCL' from a command list, but do not + * free it ... returns the removed XOTclCmdList* + */ +static XOTclCmdList* +CmdListRemoveFromList(XOTclCmdList **cmdList, XOTclCmdList *delCL) { + 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; + } + 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; + } +} + + +/* + * delete all cmds with given context class object + */ +static void +CmdListRemoveContextClassFromList(XOTclCmdList **cmdList, XOTclClass *clorobj, + XOTclFreeCmdListClientData *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) { + 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; + } +} + +/* + * 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); + } +} + +/* + * simple list search proc to search a list of cmds + * for a command ptr + */ +static XOTclCmdList* +CmdListFindCmdInList(Tcl_Command cmd, XOTclCmdList *l) { + register XOTclCmdList *h; + for (h = l; h; h = h->nextPtr) { + if (h->cmdPtr == cmd) + return h; + } + return 0; +} + +/* + * simple list search proc to search a list of cmds + * for a simple Name + */ +static XOTclCmdList* +CmdListFindNameInList(Tcl_Interp *interp, CONST char *name, XOTclCmdList *l) { + register XOTclCmdList *h; + for (h = l; h; h = h->nextPtr) { + CONST 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; + + 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; +} + +static Tcl_Obj * +AssertionList(Tcl_Interp *interp, XOTclTclObjList *alist) { + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); + for (; alist; alist = alist->nextPtr) { + Tcl_ListObjAppendElement(interp, listObj, alist->content); + } + return listObj; +} + + + +/* append a string of pre and post assertions to a method body */ +static void +AssertionAppendPrePost(Tcl_Interp *interp, Tcl_DString *dsPtr, XOTclProcAssertion *procs) { + if (procs) { + Tcl_Obj *preCondition = AssertionList(interp, procs->pre); + Tcl_Obj *postCondition = AssertionList(interp, procs->post); + INCR_REF_COUNT(preCondition); INCR_REF_COUNT(postCondition); + Tcl_DStringAppendElement(dsPtr, "-precondition"); + Tcl_DStringAppendElement(dsPtr, ObjStr(preCondition)); + Tcl_DStringAppendElement(dsPtr, "-postcondition"); + Tcl_DStringAppendElement(dsPtr, ObjStr(postCondition)); + DECR_REF_COUNT(preCondition); DECR_REF_COUNT(postCondition); + } +} + +static int +AssertionListCheckOption(Tcl_Interp *interp, XOTclObject *object) { + XOTclObjectOpt *opt = object->opt; + if (!opt) + return TCL_OK; + if (opt->checkoptions & CHECK_OBJINVAR) + Tcl_AppendElement(interp, "object-invar"); + if (opt->checkoptions & CHECK_CLINVAR) + Tcl_AppendElement(interp, "class-invar"); + 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, CONST char *name) { + Tcl_HashEntry *hPtr; + if (aStore == NULL) return NULL; + hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL); + if (hPtr == NULL) return NULL; + return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); +} + +static void +AssertionRemoveProc(XOTclAssertionStore *aStore, CONST char *name) { + Tcl_HashEntry *hPtr; + if (aStore) { + hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL); + 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, CONST char *name, XOTclAssertionStore *aStore, + 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); +} + +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; +} + +static void +AssertionRemoveStore(XOTclAssertionStore *aStore) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + + 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); + } +} + +/* + * check a given condition in the current callframe's scope + * it's the responsiblity of the caller to push the intended callframe + */ +static int +checkConditionInScope(Tcl_Interp *interp, Tcl_Obj *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_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 *object, + XOTclTclObjList *alist, CONST char *methodName) { + XOTclTclObjList *checkFailed = NULL; + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + int savedCheckoptions, acResult = TCL_OK; + + /* + * no obj->opt -> checkoption == CHECK_NONE + */ + if (!object->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 1 + /* TODO: the following check operations is xotcl1 legacy and is not + generic. it should be replaced by another methodproperty. + Most of the is*String() + definition are then obsolete and should be deleted from + nsfInt.h as well. + */ + + if (isCheckString(methodName)) { + return TCL_OK; + } +#endif + + INCR_REF_COUNT(savedObjResult); + + Tcl_ResetResult(interp); + + while (alist) { + /* Eval instead of IfObjCmd => the substitutions in the + conditions will be done by Tcl */ + CONST char *assStr = ObjStr(alist->content), *c = assStr; + int comment = 0; + + for (; c && *c != '\0'; c++) { + if (*c == '#') { + comment = 1; break; + } + } + + if (!comment) { + Tcl_CallFrame frame, *framePtr = &frame; + XOTcl_PushFrameObj(interp, object, framePtr); + + /* don't check assertion during assertion check */ + savedCheckoptions = object->opt->checkoptions; + object->opt->checkoptions = CHECK_NONE; + + /* fprintf(stderr, "Checking Assertion %s ", assStr); */ + + /* + * now check the assertion in the pushed callframe's scope + */ + acResult = checkConditionInScope(interp, alist->content); + if (acResult != TCL_OK) + checkFailed = alist; + + object->opt->checkoptions = savedCheckoptions; + /* fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok"); */ + XOTcl_PopFrameObj(interp, framePtr); + } + if (checkFailed) + break; + alist = alist->nextPtr; + } + + 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 '", + methodName, "'\n\n", ObjStr(sr), (char *) NULL); + DECR_REF_COUNT(sr); + return TCL_ERROR; + } + return XOTclVarErrMsg(interp, "Assertion failed check: {", + ObjStr(checkFailed->content), "} in proc '", + methodName, "'", (char *) NULL); + } + + Tcl_SetObjResult(interp, savedObjResult); + DECR_REF_COUNT(savedObjResult); + return TCL_OK; +} + +static int +AssertionCheckInvars(Tcl_Interp *interp, XOTclObject *object, + CONST char *methodName, + CheckOptions checkoptions) { + int result = TCL_OK; + + if (checkoptions & CHECK_OBJINVAR && object->opt->assertions) { + result = AssertionCheckList(interp, object, object->opt->assertions->invariants, + methodName); + } + + if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { + XOTclClasses *clPtr; + clPtr = ComputeOrder(object->cl, object->cl->order, Super); + while (clPtr && result != TCL_ERROR) { + XOTclAssertionStore *aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0; + if (aStore) { + result = AssertionCheckList(interp, object, aStore->invariants, methodName); + } + clPtr = clPtr->nextPtr; + } + } + return result; +} + +static int +AssertionCheck(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl, + CONST char *method, int checkOption) { + XOTclProcAssertion *procs; + int result = TCL_OK; + XOTclAssertionStore *aStore; + + if (cl) + aStore = cl->opt ? cl->opt->assertions : 0; + else + aStore = object->opt ? object->opt->assertions : 0; + + assert(object->opt); + + if (checkOption & object->opt->checkoptions) { + procs = AssertionFindProcs(aStore, method); + if (procs) { + switch (checkOption) { + case CHECK_PRE: + result = AssertionCheckList(interp, object, procs->pre, method); + break; + case CHECK_POST: + result = AssertionCheckList(interp, object, procs->post, method); + break; + } + } + if (result != TCL_ERROR) + result = AssertionCheckInvars(interp, object, method, object->opt->checkoptions); + } + return result; +} + +static int AssertionSetCheckOptions(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *arg) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); + int ocArgs, i; + Tcl_Obj **ovArgs; + opt->checkoptions = CHECK_NONE; + + if (Tcl_ListObjGetElements(interp, arg, &ocArgs, &ovArgs) == TCL_OK + && ocArgs > 0) { + for (i = 0; i < ocArgs; i++) { + CONST char *option = ObjStr(ovArgs[i]); + if (option) { + switch (*option) { + case 'c': + if (strcmp(option, "class-invar") == 0) { + opt->checkoptions |= CHECK_CLINVAR; + } + break; + case 'o': + if (strcmp(option, "object-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 '", + objectName(object), " check ", ObjStr(arg), + "', valid: all pre post object-invar class-invar", + (char *) NULL); + } + return TCL_OK; +} + +static void AssertionSetInvariants(Tcl_Interp *interp, XOTclAssertionStore **assertions, Tcl_Obj *arg) { + if (*assertions) + TclObjListFreeList((*assertions)->invariants); + else + *assertions = AssertionCreateStore(); + + (*assertions)->invariants = AssertionNewList(interp, arg); +} + + + + + +/* + * Per-Object-Mixins + */ + +/* + * push a mixin stack information on this object + */ +static int +MixinStackPush(XOTclObject *object) { + register XOTclMixinStack *h = NEW(XOTclMixinStack); + h->currentCmdPtr = NULL; + h->nextPtr = object->mixinStack; + object->mixinStack = h; + return 1; +} + +/* + * pop a mixin stack information on this object + */ +static void +MixinStackPop(XOTclObject *object) { + register XOTclMixinStack *h = object->mixinStack; + object->mixinStack = h->nextPtr; + FREE(XOTclMixinStack, h); +} + +/* + * 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; + + CmdListRemoveEpoched(mixinList, GuardDel); + + 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->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->classmixins) { + /* compute transitively the (class) mixin 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, + className(cls->cl));*/ + 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->classmixins, 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); + } + } + } + } + if (level == 0 && *checkList) { + XOTclClassListFree(*checkList); + *checkList = NULL; + } +} + +static void +MixinResetOrder(XOTclObject *object) { + /*fprintf(stderr, "removeList %s \n", objectName(object));*/ + CmdListRemoveList(&object->mixinOrder, NULL /*GuardDel*/); + object->mixinOrder = NULL; +} + +/* + * Computes a linearized order of per-object and per-class mixins. Then + * duplicates in the full list and with the class inheritance list of + * 'obj' are eliminated. + * The precendence rule is that the last occurence makes it into the + * final list. + */ +static void +MixinComputeOrder(Tcl_Interp *interp, XOTclObject *object) { + XOTclClasses *fullList, *checkList = NULL, *mixinClasses = NULL, *nextCl, *pl, + *checker, *guardChecker; + + if (object->mixinOrder) MixinResetOrder(object); + + /* append per-obj mixins */ + if (object->opt) { + MixinComputeOrderFullList(interp, &object->opt->mixins, &mixinClasses, + &checkList, 0); + } + + /* append per-class mixins */ + for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->classmixins) { + MixinComputeOrderFullList(interp, &opt->classmixins, &mixinClasses, + &checkList, 0); + } + } + 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));*/ + + while (checker) { + if (checker->cl == mixinClasses->cl) break; + checker = checker->nextPtr; + } + /* if checker is set, it is a duplicate and ignored */ + + if (checker == NULL) { + /* check obj->cl hierachy */ + for (checker = ComputeOrder(object->cl, object->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(&object->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; + } + } + } + mixinClasses = nextCl; + } + + /* ... and free the memory of the full list */ + XOTclClassListFree(fullList); + + /*CmdListPrint(interp, "mixin order\n", obj->mixinOrder);*/ + +} + +/* + * add a mixin class to 'mixinList' by appending it + */ +static int +MixinAdd(Tcl_Interp *interp, XOTclCmdList **mixinList, Tcl_Obj *nameObj, XOTclClass *baseClass) { + XOTclClass *mixin; + Tcl_Obj *guardObj = NULL; + int ocName; Tcl_Obj **ovName; + XOTclCmdList *new; + + if (Tcl_ListObjGetElements(interp, nameObj, &ocName, &ovName) == TCL_OK && ocName > 1) { + if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { + nameObj = ovName[0]; + guardObj = 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 (GetClassFromObj(interp, nameObj, &mixin, baseClass) != TCL_OK) + return XOTclErrBadVal(interp, "mixin", "a class as mixin", ObjStr(nameObj)); + + + new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1); + + if (guardObj) { + GuardAdd(interp, new, guardObj); + } else { + if (new->clientData) + GuardDel(new); + } + + return TCL_OK; +} + +/* + * call AppendElement for matching values + */ +static void +AppendMatchingElement(Tcl_Interp *interp, Tcl_Obj *nameObj, CONST char *pattern) { + CONST char *string = ObjStr(nameObj); + if (!pattern || Tcl_StringMatch(string, pattern)) { + Tcl_AppendElement(interp, string); + } +} + +/* + * apply AppendMatchingElement to CmdList + */ +static int +AppendMatchingElementsFromCmdList(Tcl_Interp *interp, XOTclCmdList *cmdl, + CONST char *pattern, XOTclObject *matchObject) { + int rc = 0; + for ( ; cmdl; cmdl = cmdl->nextPtr) { + XOTclObject *object = XOTclGetObjectFromCmdPtr(cmdl->cmdPtr); + if (object) { + if (matchObject == object) { + return 1; + } else { + AppendMatchingElement(interp, object->cmdName, pattern); + } + } + } + return rc; +} + +/* + * apply AppendMatchingElement to + */ +static int +AppendMatchingElementsFromClasses(Tcl_Interp *interp, XOTclClasses *cls, + CONST char *pattern, XOTclObject *matchObject) { + int rc = 0; + + for ( ; cls; cls = cls->nextPtr) { + XOTclObject *object = (XOTclObject *)cls->cl; + if (object) { + if (matchObject && object == 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, object->cmdName, pattern); + } + } + } + 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) { + Tcl_HashTable *table = &startCl->instances; + XOTclClasses *sc; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject *)Tcl_GetHashKey(table, hPtr); + int new; + + Tcl_CreateHashEntry(destTable, objectName(inst), &new); + /* + fprintf (stderr, " -- %s (%s)\n", objectName(inst), 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 *object, int *new, + int appendResult, CONST char *pattern, XOTclObject *matchObject) { + Tcl_CreateHashEntry(destTable, (char *)object, new); + if (*new) { + if (matchObject && matchObject == object) { + return 1; + } + if (appendResult) { + AppendMatchingElement(interp, object->cmdName, pattern); + } + } + return 0; +} + +/* + * 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, CONST char *pattern, XOTclObject *matchObject) { + Tcl_CreateHashEntry(destTable, (char *)cl, new); + if (*new) { + if (appendResult) { + if (!pattern || Tcl_StringMatch(className(cl), 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, XOTclGlobalObjs[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 int +getAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int isMixin, + int appendResult, CONST char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClasses *sc; + + /*fprintf(stderr, "startCl = %s, opt %p, isMixin %d, pattern '%s', matchObject %p\n", + className(startCl), startCl->opt, isMixin, pattern, matchObject);*/ + + /* + * 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) == 0); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + /*fprintf(stderr, "check %s mixinof %s\n", + className(cl), ObjStr(startCl->object.cmdName));*/ + rc = getAllObjectMixinsOf(interp, destTable, cl, isMixin, appendResult, pattern, matchObject); + /* fprintf(stderr, "check %s mixinof %s done\n", + className(cl), ObjStr(startCl->object.cmdName));*/ + if (rc) {return rc;} + } + } + + /* + * check, if startCl has associated per-object mixins + */ + if (startCl->opt) { + XOTclCmdList *m; + XOTclObject *object; + + for (m = startCl->opt->isObjectMixinOf; m; m = m->nextPtr) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + + object = XOTclGetObjectFromCmdPtr(m->cmdPtr); + assert(object); + + rc = addToResultSet(interp, destTable, object, &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, /*@notnull@*/ XOTclClass *startCl, + int isMixin, + int appendResult, CONST char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClass *cl; + XOTclClasses *sc; + + assert(startCl); + + /*fprintf(stderr, "startCl = %p %s, opt %p, isMixin %d\n", + startCl, className(startCl), 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) { + if (sc->cl != startCl) { + rc = getAllClassMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); + if (rc) {return rc;} + } else { + /* TODO: sanity check; it seems that we can create via + __default_superclass a class which has itself als + subclass */ + fprintf(stderr, "... STRANGE %p is subclass of %p %s, sub %p\n", sc->cl, + startCl, className(startCl), startCl->sub); + } + } + } + + /* + * 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) == 0); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + + rc = addToResultSet(interp, destTable, &cl->object, &new, appendResult, pattern, matchObject); + if (rc == 1) {return rc;} + if (new) { + /*fprintf(stderr, "... new\n");*/ + rc = getAllClassMixinsOf(interp, destTable, cl, 1, appendResult, pattern, matchObject); + if (rc) {return rc;} + } + } + } + + return rc; +} + +/* + * recursively get all classmixins 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, CONST char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClass *cl; + XOTclClasses *sc; + + /* + * check this class for classmixins + */ + if (startCl->opt) { + XOTclCmdList *m; + + for (m = startCl->opt->classmixins; m; m = m->nextPtr) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + + /* fprintf(stderr, "class mixin found: %s\n", className(cl)); */ + + if ((withGuards) && (m->clientData)) { + /* fprintf(stderr, "addToResultSetWithGuards: %s\n", className(cl)); */ + rc = addToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject); + } else { + /* fprintf(stderr, "addToResultSet: %s\n", className(cl)); */ + rc = addToResultSet(interp, destTable, &cl->object, &new, 1, pattern, matchObject); + } + if (rc == 1) {return rc;} + + if (new) { + /* fprintf(stderr, "class mixin getAllClassMixins for: %s (%s)\n", className(cl), ObjStr(startCl->object.cmdName)); */ + rc = getAllClassMixins(interp, destTable, cl, withGuards, pattern, matchObject); + if (rc) {return rc;} + } + } + } + + + /* + * check all superclasses of startCl for classmixins + */ + 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 +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", + className(cl), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + del = CmdListRemoveFromList(&nclopt->isClassMixinOf, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } + } + } +} + +static void +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", + objectName(object), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } + } /* else fprintf(stderr, "CleanupDestroyObject %s: NULL pointer in mixins!\n", objectName(object)); */ + } +} + +static void +RemoveFromClassmixins(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->classmixins); + if (del) { + /* fprintf(stderr, "Removing class %s from mixins of object %s\n", + className(cl), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */ + del = CmdListRemoveFromList(&clopt->classmixins, 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", + className(cl), 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 an object or + class mixin somewhere else and invalidate the objects of these as + well -- */ + + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *object = (XOTclObject *)Tcl_GetHashKey(&cl->instances, hPtr); + if (object + && !(object->flags & XOTCL_DURING_DELETE) + && (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + MixinResetOrder(object); + object->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", + className(cl), cl->opt);*/ + + if (cl->opt) { + XOTclCmdList *ml; + for (ml = cl->opt->isObjectMixinOf; ml; ml = ml->nextPtr) { + XOTclObject *object = XOTclGetObjectFromCmdPtr(ml->cmdPtr); + if (object) { + if (object->mixinOrder) { MixinResetOrder(object); } + object->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; + + cl->order = NULL; + + /* 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; + + /* reset mixin order for all objects having this class as per object mixin */ + ResetOrderOfClassesUsedAsMixins(clPtr->cl); + + /* fprintf(stderr, "invalidating instances of class %s\n", ObjStr(clPtr->cl->object.cmdName)); + */ + + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *object = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + if (object->mixinOrder) { MixinResetOrder(object); } + object->flags &= ~XOTCL_MIXIN_ORDER_VALID; + } + } + + XOTclClassListFree(cl->order); + cl->order = saved; + + /* Reset mixin order for all objects having this class as a per + class mixin. This means that we have to work through + the class mixin 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); + + 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); + /* this place seems to be sufficient to invalidate the computed object parameter definitions */ + /*fprintf(stderr, "MixinInvalidateObjOrders via class mixin %s calls ifd invalidate \n", className(ncl));*/ + XOTclInvalidateObjectParameterCmd(interp, ncl); + } + } + Tcl_DeleteHashTable(commandTable); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); +} + + +static int MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, CONST 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 DEFINED or NONE + */ +static void +MixinComputeDefined(Tcl_Interp *interp, XOTclObject *object) { + MixinComputeOrder(interp, object); + object->flags |= XOTCL_MIXIN_ORDER_VALID; + if (object->mixinOrder) + object->flags |= XOTCL_MIXIN_ORDER_DEFINED; + else + object->flags &= ~XOTCL_MIXIN_ORDER_DEFINED; +} + +/* + * Walk through the command list until the current command is reached. + * return the next entry. + * + */ +static XOTclCmdList * +seekCurrent(Tcl_Command currentCmd, register XOTclCmdList *cmdl) { + if (currentCmd) { + /* go forward to current class */ + for (; cmdl; cmdl = cmdl->nextPtr) { + if (cmdl->cmdPtr == currentCmd) { + return cmdl->nextPtr; + } + } + } + return cmdl; +} + +/* + * before we can perform a mixin dispatch, MixinSearchProc seeks the + * current mixin and the relevant calling information + */ +static int +MixinSearchProc(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, + XOTclClass **cl, Tcl_Command *currentCmdPtr, Tcl_Command *cmdPtr) { + Tcl_Command cmd = NULL; + XOTclCmdList *cmdList; + XOTclClass *cls; + int result = TCL_OK; + + assert(object); + assert(object->mixinStack); + + /* ensure that the mixin order is not invalid, otherwise compute order */ + assert(object->flags & XOTCL_MIXIN_ORDER_VALID); + /*MixinComputeDefined(interp, object);*/ + cmdList = seekCurrent(object->mixinStack->currentCmdPtr, object->mixinOrder); + RUNTIME_STATE(interp)->cmdPtr = cmdList ? cmdList->cmdPtr : NULL; + + /* fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName, cmdList); */ + /*CmdListPrint(interp, "MixinSearch CL = \n", cmdList);*/ + + for (; cmdList; cmdList = cmdList->nextPtr) { + + if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { + continue; + } + cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr); + assert(cls); + /* + fprintf(stderr, "+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n", + objectName(object), methodName, cmdList, + cmdList->cmdPtr, cmdList->clientData); + */ + cmd = FindMethod(cls->nsPtr, methodName); + if (cmd == NULL) { + continue; + } + + if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD) { + /*fprintf(stderr, "we found class specific method %s on class %s object %s, isclass %d\n", + methodName, className(cls), objectName(object), XOTclObjectIsClass(object));*/ + if (!XOTclObjectIsClass(object)) { + /* the command is not for us; skip it */ + cmd = NULL; + continue; + } + } + + if (cmdList->clientData) { + if (!RUNTIME_STATE(interp)->guardCount) { + result = GuardCall(object, cls, (Tcl_Command) cmd, interp, + (Tcl_Obj*)cmdList->clientData, NULL); + } + } + if (result == TCL_OK) { + /* + * on success: compute mixin call data + */ + *cl = cls; + *currentCmdPtr = cmdList->cmdPtr; + break; + } else if (result == TCL_ERROR) { + break; + } else { + if (result == XOTCL_CHECK_FAILED) result = TCL_OK; + cmd = NULL; + } + } + + *cmdPtr = cmd; + return result; +} + +/* + * info option for mixins and classmixins + */ +static int +MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, CONST char *pattern, + int withGuards, XOTclObject *matchObject) { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclClass *mixinClass; + + /*fprintf(stderr, " mixin info m=%p, pattern %s, matchObject %p\n", + m, pattern, matchObject);*/ + + 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, XOTclGlobalObjs[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, l, g); + Tcl_ListObjAppendElement(interp, list, l); + } else { + Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName); + } + if (matchObject) break; + } + m = m->nextPtr; + } + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/* + * info option for mixinofs and isClassMixinOf + */ + +static Tcl_Command +MixinSearchMethodByName(Tcl_Interp *interp, XOTclCmdList *mixinList, CONST char *name, XOTclClass **cl) { + Tcl_Command cmd; + + 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; +} + + +/* + * Filter-Commands + */ + +/* + * The search method implements filter search order for object and + * class ilter: first a given name is interpreted as fully qualified + * method name. If no method is found, a proc is searched with fully + * name. Otherwise the simple name is searched on the heritage order: + * object (only for per-object filters), class, meta-class + */ + +static Tcl_Command +FilterSearch(Tcl_Interp *interp, CONST char *name, XOTclObject *startingObject, + XOTclClass *startingClass, XOTclClass **cl) { + Tcl_Command cmd = NULL; + + if (startingObject) { + XOTclObjectOpt *opt = startingObject->opt; + /* + * the object-specific filter can also be defined on the object's + * class, its hierarchy, or the respective classmixins; thus use the + * object's class as start point for the class-specific search then ... + */ + startingClass = startingObject->cl; + + /* + * search for filters on object mixins + */ + if (opt && opt->mixins) { + if ((cmd = MixinSearchMethodByName(interp, opt->mixins, name, cl))) { + return cmd; + } + } + } + + /* + * search for classfilters on classmixins + */ + if (startingClass) { + XOTclClassOpt *opt = startingClass->opt; + if (opt && opt->classmixins) { + if ((cmd = MixinSearchMethodByName(interp, opt->classmixins, name, cl))) { + return cmd; + } + } + } + + /* + * seach for object procs that are used as filters + */ + if (startingObject && startingObject->nsPtr) { + /*fprintf(stderr, "search filter %s as proc \n", name);*/ + if ((cmd = FindMethod(startingObject->nsPtr, name))) { + *cl = (XOTclClass*)startingObject; + return cmd; + } + } + + /* + * ok, no filter on obj or mixins -> search class + */ + if (startingClass) { + *cl = SearchCMethod(startingClass, name, &cmd); + if (!*cl) { + /* + * If no filter is found yet -> search the meta-class + */ + *cl = SearchCMethod(startingClass->object.cl, name, &cmd); + } + } + return cmd; +} + +/* + * Filter Guards + */ + +/* check a filter guard, return 1 if ok */ +static int +GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObj) { + int result; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + + if (guardObj) { + /* + * 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(guardObj));*/ + + rst->guardCount++; + result = checkConditionInScope(interp, guardObj); + rst->guardCount--; + + /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", ObjStr(guardObj), rc);*/ + + if (result == TCL_OK) { + /* fprintf(stderr, " +++ OK\n"); */ + return TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_Obj *sr = Tcl_GetObjResult(interp); + INCR_REF_COUNT(sr); + + /* fprintf(stderr, " +++ ERROR\n");*/ + + XOTclVarErrMsg(interp, "Guard Error: '", ObjStr(guardObj), "'\n\n", + ObjStr(sr), (char *) NULL); + DECR_REF_COUNT(sr); + return TCL_ERROR; + } + } + /* + fprintf(stderr, " +++ FAILED\n"); + */ + return XOTCL_CHECK_FAILED; +} + +/* + static void + GuardPrint(Tcl_Interp *interp, ClientData clientData) { + Tcl_Obj *guardObj = (TclObj*) clientData; + fprintf(stderr, " +++ \n"); + if (guardObj) { + fprintf(stderr, " * %s \n", ObjStr(guardObj)); + } + fprintf(stderr, " +++ \n"); + } +*/ + +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; + } +} + +XOTCLINLINE static void +GuardAdd(Tcl_Interp *interp, XOTclCmdList *CL, Tcl_Obj *guardObj) { + if (guardObj) { + GuardDel(CL); + if (strlen(ObjStr(guardObj)) != 0) { + INCR_REF_COUNT(guardObj); + CL->clientData = (ClientData) guardObj; + /*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 *object, XOTclClass *cl, Tcl_Command cmd, + Tcl_Interp *interp, Tcl_Obj *guardObj, XOTclCallStackContent *cscPtr) { + int result = TCL_OK; + + if (guardObj) { + Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ + Tcl_CallFrame frame, *framePtr = &frame; + + INCR_REF_COUNT(res); + + /* GuardPrint(interp, cmdList->clientData); */ + /* + * For the guard push a fake callframe on the Tcl stack so that + * e.g. a "self calledproc" and other methods in the guard behave + * like in the proc. + */ + if (cscPtr) { + XOTcl_PushFrameCsc(interp, cscPtr, framePtr); + } else { + XOTcl_PushFrameObj(interp, object, framePtr); + } + result = GuardCheck(interp, guardObj); + + if (cscPtr) { + XOTcl_PopFrameCsc(interp, framePtr); + } else { + XOTcl_PopFrameObj(interp, framePtr); + } + + if (result != TCL_ERROR) { + Tcl_SetObjResult(interp, res); /* restore the result */ + } + DECR_REF_COUNT(res); + } + + return result; +} + +static int +GuardAddFromDefinitionList(Tcl_Interp *interp, XOTclCmdList *dest, + 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; +} + +static void +GuardAddInheritedGuards(Tcl_Interp *interp, XOTclCmdList *dest, + XOTclObject *object, Tcl_Command filterCmd) { + XOTclClasses *pl; + int guardAdded = 0; + XOTclObjectOpt *opt; + + /* search guards for classfilters registered on mixins */ + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml; + XOTclClass *mixin; + for (ml = object->mixinOrder; ml && !guardAdded; ml = ml->nextPtr) { + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin && mixin->opt) { + guardAdded = GuardAddFromDefinitionList(interp, dest, filterCmd, + mixin->opt->classfilters); + } + } + } + + /* search per-object filters */ + opt = object->opt; + if (!guardAdded && opt && opt->filters) { + guardAdded = GuardAddFromDefinitionList(interp, dest, filterCmd, opt->filters); + } + + if (!guardAdded) { + /* search per-class filters */ + for (pl = ComputeOrder(object->cl, object->cl->order, Super); !guardAdded && pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt) { + guardAdded = GuardAddFromDefinitionList(interp, dest, filterCmd, + opt->classfilters); + } + } + + + /* + * if this is not a registered filter, it is an inherited filter, like: + * Class create A + * A method f ... + * Class create B -superclass A + * B method {{f {}}} + * B filter f + * -> get the guard from the filter that inherits it (here B->f) + */ + if (!guardAdded) { + XOTclCmdList *registeredFilter = + CmdListFindNameInList(interp, (char *) Tcl_GetCommandName(interp, filterCmd), + object->filterOrder); + if (registeredFilter) { + GuardAdd(interp, dest, (Tcl_Obj*) registeredFilter->clientData); + } + } + } +} + +static int +GuardList(Tcl_Interp *interp, XOTclCmdList *frl, CONST 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; + } + } + 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 *nameObj, + XOTclObject *startingObject, XOTclClass *startingClass) { + Tcl_Command cmd; + int ocName; Tcl_Obj **ovName; + Tcl_Obj *guardObj = NULL; + XOTclCmdList *new; + XOTclClass *cl; + + if (Tcl_ListObjGetElements(interp, nameObj, &ocName, &ovName) == TCL_OK && ocName > 1) { + if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { + nameObj = ovName[0]; + guardObj = ovName[2]; + } + } + + if (!(cmd = FilterSearch(interp, ObjStr(nameObj), startingObject, startingClass, &cl))) { + if (startingObject) + return XOTclVarErrMsg(interp, "object filter: can't find filterproc on: ", + objectName(startingObject), " - proc: ", + ObjStr(nameObj), (char *) NULL); + else + return XOTclVarErrMsg(interp, "class filter: can't find filterproc on: ", + className(startingClass), " - proc: ", + ObjStr(nameObj), (char *) NULL); + } + + /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(nameObj), cl);*/ + + new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1); + + if (guardObj) { + GuardAdd(interp, new, guardObj); + } else { + if (new->clientData) + GuardDel(new); + } + + return TCL_OK; +} + +/* + * reset the filter order cached in obj->filterOrder + */ +static void +FilterResetOrder(XOTclObject *object) { + CmdListRemoveList(&object->filterOrder, GuardDel); + object->filterOrder = NULL; +} + +/* + * search the filter in the hierarchy again with FilterSearch, e.g. + * upon changes in the class hierarchy or mixins that carry the filter + * command, so that we can be sure it is still reachable. + */ +static void +FilterSearchAgain(Tcl_Interp *interp, XOTclCmdList **filters, + XOTclObject *startingObject, XOTclClass *startingClass) { + char *simpleName; + Tcl_Command cmd; + XOTclCmdList *cmdList, *del; + XOTclClass *cl = NULL; + + CmdListRemoveEpoched(filters, GuardDel); + for (cmdList = *filters; cmdList; ) { + simpleName = (char *) Tcl_GetCommandName(interp, cmdList->cmdPtr); + cmd = FilterSearch(interp, simpleName, startingObject, startingClass, &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); + */ +} + +/* + * if the class hierarchy or class filters have changed -> + * invalidate filter entries in all dependent instances + * + */ +static void +FilterInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) { + XOTclClasses *saved = cl->order, *clPtr, *savePtr; + + cl->order = NULL; + savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); + cl->order = saved; + + 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 class-filter registrations */ + if (clPtr->cl->opt) { + FilterSearchAgain(interp, &clPtr->cl->opt->classfilters, 0, clPtr->cl); + } + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *object = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + FilterResetOrder(object); + object->flags &= ~XOTCL_FILTER_ORDER_VALID; + + /* recalculate the commands of all object filter registrations */ + if (object->opt) { + FilterSearchAgain(interp, &object->opt->filters, object, 0); + } + } + } + XOTclClassListFree(savePtr); +} + +/* + * from cl on down the hierarchy we remove all filters + * the refer to "removeClass" namespace. E.g. used to + * remove filters defined in superclass list from dependent + * class cl + */ +static void +FilterRemoveDependentFilterCmds(XOTclClass *cl, XOTclClass *removeClass) { + XOTclClasses *saved = cl->order, *clPtr; + cl->order = NULL; + + /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n", + cl, className(cl), + 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) : NULL; + XOTclClassOpt *opt = clPtr->cl->opt; + if (opt) { + CmdListRemoveContextClassFromList(&opt->classfilters, removeClass, GuardDel); + } + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *object = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + if (object->opt) { + CmdListRemoveContextClassFromList(&object->opt->filters, removeClass, GuardDel); + } + } + } + + XOTclClassListFree(cl->order); + cl->order = saved; +} + +static Tcl_Obj * +MethodHandleObj(XOTclObject *object, int withPer_object, CONST char *methodName) { + Tcl_Obj *resultObj = Tcl_NewStringObj(withPer_object ? "" : "::nsf::classes", -1); + assert(object); + Tcl_AppendObjToObj(resultObj, object->cmdName); + Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL); + return resultObj; +} + +/* + * info option for filters and classfilters + * withGuards -> if not 0 => append guards + * withMethodHandles -> if not 0 => return method handles + */ +static int +FilterInfo(Tcl_Interp *interp, XOTclCmdList *f, CONST char *pattern, + int withGuards, int withMethodHandles) { + CONST char *simpleName; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + + /*fprintf(stderr, "FilterInfo %p %s %d %d\n", pattern, pattern, + withGuards, withMethodHandles);*/ + + /* guard lists should only have unqualified filter lists when + withGuards is activated, withMethodHandles has no effect + */ + if (withGuards) { + withMethodHandles = 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, XOTclGlobalObjs[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, innerList, g); + Tcl_ListObjAppendElement(interp, list, innerList); + } else { + if (withMethodHandles) { + XOTclClass *filterClass = f->clorobj; + Tcl_ListObjAppendElement(interp, list, + MethodHandleObj((XOTclObject *)filterClass, + !XOTclObjectIsClass(&filterClass->object), simpleName)); + } else { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1)); + } + } + } + f = f->nextPtr; + } + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/* + * 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; + + /* + * 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); + + if (fcl && !XOTclObjectIsClass(&fcl->object)) { + /* get the class from the object for per-object filter */ + fcl = ((XOTclObject *)fcl)->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(pl->cl->nsPtr, simpleName); + if (pi) { + CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0); + /* + fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName); + */ + } + } + } + } + } + /*CmdListPrint(interp, "FilterComputeOrderFullList....\n", *filterList);*/ +} + +/* + * Computes a linearized order of object and class filter. Then + * duplicates in the full list and with the class inheritance list of + * 'obj' are eliminated. The precendence rule is that the last + * occurence makes it into the final list. + */ +static void +FilterComputeOrder(Tcl_Interp *interp, XOTclObject *object) { + XOTclCmdList *filterList = NULL, *next, *checker, *newlist; + XOTclClasses *pl; + + if (object->filterOrder) FilterResetOrder(object); + /* + fprintf(stderr, " List: ", objectName(object)); + */ + + /* append classfilters registered for mixins */ + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + + if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml; + XOTclClass *mixin; + + for (ml = object->mixinOrder; ml; ml = ml->nextPtr) { + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin && mixin->opt && mixin->opt->classfilters) + FilterComputeOrderFullList(interp, &mixin->opt->classfilters, &filterList); + } + } + + /* append per-obj filters */ + if (object->opt) + FilterComputeOrderFullList(interp, &object->opt->filters, &filterList); + + /* append per-class filters */ + for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl=pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->classfilters) { + FilterComputeOrderFullList(interp, &opt->classfilters, &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 == NULL) { + newlist = CmdListAdd(&object->filterOrder, filterList->cmdPtr, filterList->clorobj, + /*noDuplicates*/ 0); + GuardAddInheritedGuards(interp, newlist, object, filterList->cmdPtr); + /* + fprintf(stderr, " Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(interp, filterList->cmdPtr)); + */ + /* + GuardPrint(interp, newlist->clientData); + */ + + } + + CmdListDeleteCmdListEntry(filterList, GuardDel); + + filterList = next; + } + /* + fprintf(stderr, "\n"); + */ +} + +/* + * the filter order is either + * DEFINED (there are filter on the instance), + * NONE (there are no filter for the instance), + * or INVALID (a class re-strucuturing has occured, thus it is not clear + * whether filters are defined or not). + * If it is INVALID FilterComputeDefined can be used to compute the order + * and set the instance to DEFINE or NONE + */ +static void +FilterComputeDefined(Tcl_Interp *interp, XOTclObject *object) { + FilterComputeOrder(interp, object); + object->flags |= XOTCL_FILTER_ORDER_VALID; + if (object->filterOrder) + object->flags |= XOTCL_FILTER_ORDER_DEFINED; + else + object->flags &= ~XOTCL_FILTER_ORDER_DEFINED; +} + +/* + * push a filter stack information on this object + */ +static int +FilterStackPush(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *calledProc) { + register XOTclFilterStack *h = NEW(XOTclFilterStack); + + h->currentCmdPtr = NULL; + h->calledProc = calledProc; + INCR_REF_COUNT(h->calledProc); + h->nextPtr = object->filterStack; + object->filterStack = h; + return 1; +} + +/* + * pop a filter stack information on this object + */ +static void +FilterStackPop(XOTclObject *object) { + register XOTclFilterStack *h = object->filterStack; + object->filterStack = h->nextPtr; + + /* free stack entry */ + DECR_REF_COUNT(h->calledProc); + FREE(XOTclFilterStack, h); +} + +/* + * search through the filter list on obj and class hierarchy + * for registration of a command ptr as filter + * + * returns a tcl obj list with the filter registration, like: + * " filter , + * " filter , + * or an empty list, if not registered + */ +static Tcl_Obj * +FilterFindReg(Tcl_Interp *interp, XOTclObject *object, Tcl_Command cmd) { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclClasses *pl; + + /* search per-object filters */ + if (object->opt && CmdListFindCmdInList(cmd, object->opt->filters)) { + Tcl_ListObjAppendElement(interp, list, object->cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_OBJECT]); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_FILTER]); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); + return list; + } + + /* search per-class filters */ + for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->classfilters) { + if (CmdListFindCmdInList(cmd, opt->classfilters)) { + Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_FILTER]); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); + 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 *object, + Tcl_Command *currentCmd, XOTclClass **cl) { + XOTclCmdList *cmdList; + + assert(object); + assert(object->filterStack); + + *currentCmd = NULL; + + /* Ensure that the filter order is not invalid, otherwise compute order + FilterComputeDefined(interp, object); + */ + assert(object->flags & XOTCL_FILTER_ORDER_VALID); + cmdList = seekCurrent(object->filterStack->currentCmdPtr, object->filterOrder); + + while (cmdList) { + if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { + cmdList = cmdList->nextPtr; + } else if (FilterActiveOnObj(interp, object, cmdList->cmdPtr)) { + /* fprintf(stderr, "Filter <%s> -- Active on: %s\n", + Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), objectName(object)); + */ + object->filterStack->currentCmdPtr = cmdList->cmdPtr; + cmdList = seekCurrent(object->filterStack->currentCmdPtr, object->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 NULL; +} + + +static int +SuperclassAdd(Tcl_Interp *interp, XOTclClass *cl, int oc, Tcl_Obj **ov, Tcl_Obj *arg, XOTclClass *baseClass) { + 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 (GetClassFromObj(interp, ov[i], &scl[i], baseClass) != 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) { + /* + * 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); + 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); + 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) { + fprintf(stderr, "SuperClassAdd super of '%s' is NULL\n", className(cl)); + /*AddSuper(cl, RUNTIME_STATE(interp)->theObject);*/ + } + + Tcl_ResetResult(interp); + return TCL_OK; +} + +extern Tcl_Obj * +XOTcl_ObjSetVar2(XOTcl_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, + Tcl_Obj *valueObj, int flgs) { + Tcl_Obj *result; + Tcl_CallFrame frame, *framePtr = &frame; + + XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); + if (((XOTclObject*)object)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; + + result = Tcl_ObjSetVar2(interp, name1, name2, valueObj, flgs); + XOTcl_PopFrameObj(interp, framePtr); + return result; +} + +extern Tcl_Obj * +XOTcl_SetVar2Ex(XOTcl_Object *object, Tcl_Interp *interp, CONST char *name1, CONST char *name2, + Tcl_Obj *valueObj, int flgs) { + Tcl_Obj *result; + Tcl_CallFrame frame, *framePtr = &frame; + + XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); + if (((XOTclObject*)object)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; + + result = Tcl_SetVar2Ex(interp, name1, name2, valueObj, flgs); + XOTcl_PopFrameObj(interp, framePtr); + return result; +} + + +Tcl_Obj * +XOTclOSetInstVar(XOTcl_Object *object, Tcl_Interp *interp, + Tcl_Obj *nameObj, Tcl_Obj *valueObj, int flgs) { + return XOTcl_ObjSetVar2(object, interp, nameObj, (Tcl_Obj *)NULL, valueObj, (flgs|TCL_PARSE_PART1)); +} + +extern Tcl_Obj * +XOTcl_ObjGetVar2(XOTcl_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, + int flgs) { + Tcl_Obj *result; + Tcl_CallFrame frame, *framePtr = &frame; + + XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); + if (((XOTclObject*)object)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; + + result = Tcl_ObjGetVar2(interp, name1, name2, flgs); + XOTcl_PopFrameObj(interp, framePtr); + + return result; +} + +extern Tcl_Obj * +XOTcl_GetVar2Ex(XOTcl_Object *object, Tcl_Interp *interp, CONST char *name1, CONST char *name2, + int flgs) { + Tcl_Obj *result; + Tcl_CallFrame frame, *framePtr = &frame; + + XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); + if (((XOTclObject*)object)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; + + result = Tcl_GetVar2Ex(interp, name1, name2, flgs); + XOTcl_PopFrameObj(interp, framePtr); + return result; +} + + +Tcl_Obj * +XOTclOGetInstVar(XOTcl_Object *object, Tcl_Interp *interp, Tcl_Obj *nameObj, int flgs) { + return XOTcl_ObjGetVar2(object, interp, nameObj, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1)); +} + +int +XOTclUnsetInstVar(XOTcl_Object *object, Tcl_Interp *interp, CONST char *name, int flgs) { + return XOTclUnsetInstVar2(object, interp, name, NULL, flgs); +} + +static int +CheckVarName(Tcl_Interp *interp, const char *varNameString) { + /* + * Check, whether the provided name is save to be used in the + * resolver. We do not want to get interferences with namespace + * resolver and such. In an first attempt, we disallowed occurances + * of "::", but we have to deal as well with e.g. arrayName(::x::y) + * + * TODO: more general and efficient solution to disallow e.g. a::b + * (check for :: until parens) + */ + /*if (strstr(varNameString, "::") || *varNameString == ':') {*/ + if (*varNameString == ':') { + return XOTclVarErrMsg(interp, "variable name \"", varNameString, + "\" must not contain namespace separator or colon prefix", + (char *) NULL); + } + return TCL_OK; +} + +static int +varExists(Tcl_Interp *interp, XOTclObject *object, CONST char *varName, CONST char *index, + int triggerTrace, int requireDefined) { + Tcl_CallFrame frame, *framePtr = &frame; + Var *varPtr, *arrayPtr; + int result; + int flags = 0; + + flags = (index == NULL) ? TCL_PARSE_PART1 : 0; + + XOTcl_PushFrameObj(interp, object, framePtr); + + if (triggerTrace) + varPtr = TclVarTraceExists(interp, varName); + else + varPtr = TclLookupVar(interp, varName, index, flags, "access", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + /* + 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_PopFrameObj(interp, framePtr); + + return result; +} + +static int +SubstValue(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj **value) { + Tcl_Obj *ov[2]; + int result; + + ov[1] = *value; + Tcl_ResetResult(interp); + + result = XOTcl_SubstObjCmd(NULL, interp, 2, ov); + + /*fprintf(stderr, "+++++ %s.%s subst returned %d OK %d\n", + objectName(object), varName, rc, TCL_OK);*/ + + if (result == TCL_OK) { + *value = Tcl_GetObjResult(interp); + } + return result; +} + +#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; + + /*fprintf(stderr, "MakeProcError %p type %p refCount %d\n", + procNameObj, procNameObj->typePtr, procNameObj->refCount);*/ + + procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + overflow = (nameLen > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (procedure \"%.*s%s\" line %d)", + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); +} + +static int +ByteCompiled(register Tcl_Interp *interp, Proc *procPtr, CONST char *body) { + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; + + if (bodyPtr->typePtr == byteCodeType) { +# if defined(HAVE_TCL_COMPILE_H) + 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 = bodyPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr) + || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { + + goto doCompilation; + } + return TCL_OK; +# endif + } else { + +# if defined(HAVE_TCL_COMPILE_H) + doCompilation: +# endif + return TclProcCompileProc(interp, procPtr, bodyPtr, + (Namespace *) nsPtr, "body of proc", + body); + } +} + +/* + PushProcCallFrame() compiles conditionally a proc and pushes a + callframe. Interesting fields: + + clientData: Record describing procedure to be interpreted. + isLambda: 1 if this is a call by ApplyObjCmd: it needs special rules for error msg + + */ + +static int +PushProcCallFrame(ClientData clientData, register Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + XOTclCallStackContent *cscPtr) { + Proc *procPtr = (Proc *) clientData; + CallFrame *framePtr; + int 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. + */ + +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "PUSH METHOD_FRAME (PushProcCallFrame) csc %p %s obj %s obj refcount %d\n", cscPtr, + cscPtr ? Tcl_GetCommandName(interp, cscPtr->cmdPtr) : NULL, + objectName(cscPtr->self), + cscPtr && cscPtr->self->id ? Tcl_Command_refCount(cscPtr->self->id) : -100 + ); +#endif + + /* TODO: we could use Tcl_PushCallFrame(), if we would allocate the tcl stack frame earlier */ + result = TclPushStackFrame(interp, (Tcl_CallFrame **)&framePtr, + (Tcl_Namespace *) procPtr->cmdPtr->nsPtr, + (FRAME_IS_PROC|FRAME_IS_XOTCL_METHOD)); + if (result != TCL_OK) { + return result; + } + + framePtr->objc = objc; + framePtr->objv = objv; + framePtr->procPtr = procPtr; +#if defined(TCL85STACK_TRACE) + fprintf(stderr, " put csc %p into frame %p flags %.4x\n", cscPtr, framePtr, framePtr->isProcCallFrame); +#endif + framePtr->clientData = (ClientData)cscPtr; + + return ByteCompiled(interp, procPtr, TclGetString(objv[0])); +} + +static void +getVarAndNameFromHash(Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) { + *val = VarHashGetValue(hPtr); + *varNameObj = VarHashGetKey(*val); +} + +static void ParamDefsFree(XOTclParamDefs *paramDefs); + +void XOTclProcDeleteProc(ClientData clientData) { + XOTclProcContext *ctxPtr = (XOTclProcContext *)clientData; + (*ctxPtr->oldDeleteProc)(ctxPtr->oldDeleteData); + if (ctxPtr->paramDefs) { + /*fprintf(stderr, "free ParamDefs %p\n", ctxPtr->paramDefs);*/ + ParamDefsFree(ctxPtr->paramDefs); + } + /*fprintf(stderr, "free %p\n", ctxPtr);*/ + FREE(XOTclProcContext, ctxPtr); +} + +static XOTclParam *ParamsNew(int nr) { + XOTclParam *paramsPtr = NEW_ARRAY(XOTclParam, nr+1); + memset(paramsPtr, 0, sizeof(XOTclParam)*(nr+1)); + return paramsPtr; +} + +static void ParamsFree(XOTclParam *paramsPtr) { + XOTclParam *paramPtr; + + /*fprintf(stderr, "ParamsFree %p\n", paramsPtr);*/ + for (paramPtr=paramsPtr; paramPtr->name; paramPtr++) { + /*fprintf(stderr, ".... paramPtr = %p, name=%s, defaultValue %p\n", paramPtr, paramPtr->name, paramPtr->defaultValue);*/ + if (paramPtr->name) ckfree(paramPtr->name); + if (paramPtr->nameObj) {DECR_REF_COUNT(paramPtr->nameObj);} + if (paramPtr->defaultValue) {DECR_REF_COUNT(paramPtr->defaultValue);} + if (paramPtr->converterName) {DECR_REF_COUNT(paramPtr->converterName);} + if (paramPtr->converterArg) {DECR_REF_COUNT(paramPtr->converterArg);} + if (paramPtr->paramObj) {DECR_REF_COUNT(paramPtr->paramObj);} + if (paramPtr->slotObj) {DECR_REF_COUNT(paramPtr->slotObj);} + } + FREE(XOTclParam*, paramsPtr); +} + +static XOTclParamDefs * +ParamDefsGet(Tcl_Command cmdPtr) { + if (Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc) { + return ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs; + } + return NULL; +} + +static int +ParamDefsStore(Tcl_Interp *interp, Tcl_Command cmd, XOTclParamDefs *paramDefs) { + Command *cmdPtr = (Command *)cmd; + + if (cmdPtr->deleteProc != XOTclProcDeleteProc) { + XOTclProcContext *ctxPtr = NEW(XOTclProcContext); + + /*fprintf(stderr, "paramDefsStore replace deleteProc %p by %p\n", + cmdPtr->deleteProc, XOTclProcDeleteProc);*/ + + ctxPtr->oldDeleteData = (Proc *)cmdPtr->deleteData; + ctxPtr->oldDeleteProc = cmdPtr->deleteProc; + cmdPtr->deleteProc = XOTclProcDeleteProc; + ctxPtr->paramDefs = paramDefs; + cmdPtr->deleteData = (ClientData)ctxPtr; + return TCL_OK; + } else { + /*fprintf(stderr, "paramDefsStore cmd %p has already XOTclProcDeleteProc deleteData %p\n", + cmd, cmdPtr->deleteData);*/ + if (cmdPtr->deleteData) { + XOTclProcContext *ctxPtr = cmdPtr->deleteData; + assert(ctxPtr->paramDefs == NULL); + ctxPtr->paramDefs = paramDefs; + } + } + return TCL_ERROR; +} + +static XOTclParamDefs * +ParamDefsNew() { + XOTclParamDefs *paramDefs; + + paramDefs = NEW(XOTclParamDefs); + memset(paramDefs, 0, sizeof(XOTclParamDefs)); + /*fprintf(stderr, "ParamDefsNew %p\n", paramDefs);*/ + + return paramDefs; +} + + +static void +ParamDefsFree(XOTclParamDefs *paramDefs) { + /*fprintf(stderr, "ParamDefsFree %p returns %p\n", paramDefs, paramDefs->returns);*/ + + if (paramDefs->paramsPtr) { + ParamsFree(paramDefs->paramsPtr); + } + if (paramDefs->slotObj) {DECR_REF_COUNT(paramDefs->slotObj);} + if (paramDefs->returns) {DECR_REF_COUNT(paramDefs->returns);} + FREE(XOTclParamDefs, paramDefs); +} + +/* + * Non Positional Parameter + */ + +static void +ParamDefsFormatOption(Tcl_Interp *interp, Tcl_Obj *nameStringObj, CONST char* option, + int *colonWritten, int *firstOption) { + if (!*colonWritten) { + Tcl_AppendLimitedToObj(nameStringObj, ":", 1, INT_MAX, NULL); + *colonWritten = 1; + } + if (*firstOption) { + *firstOption = 0; + } else { + Tcl_AppendLimitedToObj(nameStringObj, ",", 1, INT_MAX, NULL); + } + Tcl_AppendLimitedToObj(nameStringObj, option, -1, INT_MAX, NULL); +} + +static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr); + +static Tcl_Obj * +ParamDefsFormat(Tcl_Interp *interp, XOTclParam CONST *paramsPtr) { + int first, colonWritten; + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL), *innerListObj, *nameStringObj; + XOTclParam CONST *pPtr; + + for (pPtr = paramsPtr; pPtr->name; pPtr++) { + if (pPtr -> paramObj) { + innerListObj = pPtr->paramObj; + } else { + /* We need this part only for C-defined parameter definitions, + defined via genTclAPI. + + TODO: we could streamline this by defining as well C-API via + the same syntax as for accepted for tcl obj types + "xotclParam" + */ + int isNonpos = *pPtr->name == '-'; + int outputRequired = (isNonpos && (pPtr->flags & XOTCL_ARG_REQUIRED)); + int outputOptional = (!isNonpos && !(pPtr->flags & XOTCL_ARG_REQUIRED) + && !pPtr->defaultValue && + pPtr->converter != convertToNothing); + first = 1; + colonWritten = 0; + + nameStringObj = Tcl_NewStringObj(pPtr->name, -1); + if (pPtr->type) { + ParamDefsFormatOption(interp, nameStringObj, pPtr->type, &colonWritten, &first); + } + if (outputRequired) { + ParamDefsFormatOption(interp, nameStringObj, "required", &colonWritten, &first); + } else if (outputOptional) { + ParamDefsFormatOption(interp, nameStringObj, "optional", &colonWritten, &first); + } + if ((pPtr->flags & XOTCL_ARG_SUBST_DEFAULT)) { + ParamDefsFormatOption(interp, nameStringObj, "substdefault", &colonWritten, &first); + } + if ((pPtr->flags & XOTCL_ARG_ALLOW_EMPTY)) { + ParamDefsFormatOption(interp, nameStringObj, "allowempty", &colonWritten, &first); + } + if ((pPtr->flags & XOTCL_ARG_IS_CONVERTER)) { + ParamDefsFormatOption(interp, nameStringObj, "convert", &colonWritten, &first); + } + if ((pPtr->flags & XOTCL_ARG_INITCMD)) { + ParamDefsFormatOption(interp, nameStringObj, "initcmd", &colonWritten, &first); + } else if ((pPtr->flags & XOTCL_ARG_METHOD)) { + ParamDefsFormatOption(interp, nameStringObj, "method", &colonWritten, &first); + } else if ((pPtr->flags & XOTCL_ARG_NOARG)) { + ParamDefsFormatOption(interp, nameStringObj, "noarg", &colonWritten, &first); + } else if ((pPtr->flags & XOTCL_ARG_MULTIVALUED)) { + ParamDefsFormatOption(interp, nameStringObj, "multivalued", &colonWritten, &first); + } + + innerListObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, innerListObj, nameStringObj); + if (pPtr->defaultValue) { + Tcl_ListObjAppendElement(interp, innerListObj, pPtr->defaultValue); + } + } + + Tcl_ListObjAppendElement(interp, listObj, innerListObj); + } + + return listObj; +} + +static Tcl_Obj * +ParamDefsList(Tcl_Interp *interp, XOTclParam CONST *paramsPtr) { + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); + XOTclParam CONST *pPtr; + + for (pPtr = paramsPtr; pPtr->name; pPtr++) { + Tcl_ListObjAppendElement(interp, listObj, pPtr->nameObj); + } + return listObj; +} + +static Tcl_Obj* +ParamDefsSyntax(Tcl_Interp *interp, XOTclParam CONST *paramPtr) { + Tcl_Obj *argStringObj = Tcl_NewStringObj("", 0); + XOTclParam CONST *pPtr; + + for (pPtr = paramPtr; pPtr->name; pPtr++) { + if (pPtr != paramPtr) { + Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL); + } + if (pPtr->flags & XOTCL_ARG_REQUIRED) { + Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); + } else { + Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); + Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); + if (pPtr->nrArgs >0) { + Tcl_AppendLimitedToObj(argStringObj, " arg", 4, INT_MAX, NULL); + } + Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); + } + } + /* caller has to decr */ + return argStringObj; +} + +static void ParsedParamFree(XOTclParsedParam *parsedParamPtr) { + /*fprintf(stderr, "ParsedParamFree %p, npargs %p\n", parsedParamPtr, parsedParamPtr->paramDefs);*/ + if (parsedParamPtr->paramDefs) { + ParamDefsFree(parsedParamPtr->paramDefs); + } + FREE(XOTclParsedParam, parsedParamPtr); +} + + +/* + * method dispatch + */ +#if defined(NRE) +static int +FinalizeProcMethod(ClientData data[], Tcl_Interp *interp, int result) { + parseContext *pcPtr = data[0]; + XOTclCallStackContent *cscPtr = data[1]; + CONST char *methodName = data[2]; + XOTclObject *object = cscPtr->self; + XOTclObjectOpt *opt = object->opt; + XOTclParamDefs *paramDefs; + int rc; + + /*fprintf(stderr, "---- FinalizeProcMethod result %d, csc %p, pcPtr %p, obj %p\n", + result, cscPtr, pcPtr, object);*/ +# if defined(TCL85STACK_TRACE) + fprintf(stderr, "POP FRAME (implicit) csc %p obj %s obj refcount %d %d\n", + cscPtr, objectName(object), + obj->id ? Tcl_Command_refCount(object->id) : -100, + obj->refCount + ); +# endif + + paramDefs = ParamDefsGet(cscPtr->cmdPtr); + + if (result == TCL_OK && paramDefs && paramDefs->returns) { + Tcl_Obj *valueObj = Tcl_GetObjResult(interp); + /*fprintf(stderr, "***** we have returns for method '%s' check %s, value %p\n", + methodName, ObjStr(paramDefs->returns), valueObj);*/ + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", + RUNTIME_STATE(interp)->doCheckResults, + NULL); + } + + if (opt && object->teardown && (opt->checkoptions & CHECK_POST)) { + /* even, when the passed result != TCL_OK, run assertion to report + * the highest possible method from the callstack (e.g. "set" would not + * be very meaningful; however, do not flush a TCL_ERROR. + */ + rc = AssertionCheck(interp, object, cscPtr->cl, methodName, CHECK_POST); + if (result == TCL_OK) { + result = rc; + } + } + + if (pcPtr) { +# if defined(TCL_STACK_ALLOC_TRACE) + fprintf(stderr, "---- FinalizeProcMethod calls releasePc, stackFree %p\n", pcPtr); +# endif + parseContextRelease(pcPtr); + TclStackFree(interp, pcPtr); + } + +# if defined(TCL_STACK_ALLOC_TRACE) + fprintf(stderr, "---- FinalizeProcMethod calls pop, csc free %p method %s\n", cscPtr, methodName); +# endif + CscFinish(interp, cscPtr); + TclStackFree(interp, cscPtr); + + return result; +} +#endif + +/* invoke a scripted method (with assertion checking) */ +static int +ProcMethodDispatch(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + CONST char *methodName, XOTclObject *object, XOTclClass *cl, Tcl_Command cmdPtr, + XOTclCallStackContent *cscPtr) { + int result, releasePc = 0; + XOTclObjectOpt *opt = object->opt; + XOTclParamDefs *paramDefs; +#if defined(NRE) + parseContext *pcPtr = NULL; +#else + parseContext pc, *pcPtr = &pc; +#endif + + assert(object); + assert(object->teardown); + +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "+++ ProcMethodDispatch %s, cscPtr %p, frametype %d, teardown %p\n", + methodName, cscPtr, cscPtr->frameType, object->teardown); +#endif + + /* + * if this is a filter, check whether its guard applies, + * if not: just step forward to the next filter + */ + + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + XOTclCmdList *cmdList; + /* + * seek cmd in obj's filterOrder + */ + assert(object->flags & XOTCL_FILTER_ORDER_VALID); + /* otherwise: FilterComputeDefined(interp, object);*/ + + for (cmdList = object->filterOrder; cmdList && cmdList->cmdPtr != cmdPtr; cmdList = cmdList->nextPtr); + + if (cmdList) { + /* + * A filter was found, check whether it has a guard. + */ + result = GuardCall(object, cl, (Tcl_Command) cmdList->cmdPtr, interp, + cmdList->clientData, cscPtr); + + if (result != TCL_OK) { + /*fprintf(stderr, "Filter GuardCall in invokeProc returned %d\n", result);*/ + + if (result != TCL_ERROR) { + /* + * The guard failed (but no error); call "next", use the + * actual objv's, not the callstack objv, since we may not + * be in a method resulting in invalid callstackobjs. + * + * The call stack content is not jet pushed to the Tcl + * stack, so we pass it here explicitly. + */ + + /*fprintf(stderr, "... calling nextmethod cscPtr %p\n", cscPtr);*/ + result = XOTclNextMethod(object, interp, cl, methodName, + objc, objv, /*useCallStackObjs*/ 0, cscPtr); + /*fprintf(stderr, "... after nextmethod result %d\n", result);*/ + } +#if defined(NRE) +# if defined(TCL_STACK_ALLOC_TRACE) + fprintf(stderr, "---- GuardFailed calls pop, cscPtr free %p method %s\n", cscPtr, methodName); +# endif + CscFinish(interp, cscPtr); + TclStackFree(interp, cscPtr); + /* todo check mixin guards for same case? */ +#endif + return result; + } + } + } + + if (opt && (opt->checkoptions & CHECK_PRE) && + (result = AssertionCheck(interp, object, cl, methodName, CHECK_PRE)) == TCL_ERROR) { + goto finish; + } + +#ifdef DISPATCH_TRACE + printCall(interp, "ProcMethodDispatch", objc, objv); + fprintf(stderr, "\tproc=%s\n", Tcl_GetCommandName(interp, cmdPtr)); +#endif + + /* + If the method to be invoked has paramDefs, we have to call the + argument parser with the argument definitions obtained from the + proc context from the cmdPtr. + */ + paramDefs = ParamDefsGet(cmdPtr); + + /*Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc ? + ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs : NULL;*/ + + if (paramDefs && paramDefs->paramsPtr) { +#if defined(NRE) + pcPtr = (parseContext *) TclStackAlloc(interp, sizeof(parseContext)); +# if defined(TCL_STACK_ALLOC_TRACE) + fprintf(stderr, "---- parseContext alloc %p\n", pcPtr); +# endif +#endif + result = ProcessMethodArguments(pcPtr, interp, object, 1, paramDefs, methodName, objc, objv); + cscPtr->objc = objc; + cscPtr->objv = (Tcl_Obj **)objv; + if (result == TCL_OK) { + releasePc = 1; + result = PushProcCallFrame(cp, interp, pcPtr->objc, pcPtr->full_objv, cscPtr); + } + } else { + result = PushProcCallFrame(cp, interp, objc, objv, cscPtr); + } + + /* we could consider to run here ARG_METHOD or ARG_INITCMD + if (result == TCL_OK) { + + } */ + + if (result != TCL_OK) { +#if defined(NRE) + if (pcPtr) TclStackFree(interp, pcPtr); +# if defined(TCL_STACK_ALLOC_TRACE) + fprintf(stderr, "---- ProcPrep fails and calls pop, cscPtr free %p method %s\n", cscPtr, methodName); +# endif + CscFinish(interp, cscPtr); + TclStackFree(interp, cscPtr); +#endif + } + + /* + * The stack frame is pushed, we could do something here before + * running the byte code of the body. + */ + if (result == TCL_OK) { +#if !defined(NRE) + result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); + if (releasePc) { + parseContextRelease(&pc); + } +#else + { + TEOV_callback *rootPtr = TOP_CB(interp); + /*fprintf(stderr, "CALL TclNRInterpProcCore %s method '%s'\n", objectName(object), ObjStr(objv[0]));*/ + Tcl_NRAddCallback(interp, FinalizeProcMethod, + releasePc ? pcPtr : NULL, cscPtr, methodName, NULL); + result = TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); + /*fprintf(stderr, ".... run callbacks rootPtr = %p, result %d methodName %s\n", rootPtr, result, methodName);*/ + result = TclNRRunCallbacks(interp, result, rootPtr, 0); + /*fprintf(stderr, ".... run callbacks DONE result %d methodName %s\n", result, methodName);*/ + } +#endif + } +# if defined(TCL85STACK_TRACE) + fprintf(stderr, "POP OBJECT_FRAME (implicit) frame %p cscPtr %p obj %s obj refcount %d %d\n", NULL, cscPtr, + objectName(object), + object->id ? Tcl_Command_refCount(object->id) : -100, + object->refCount + ); +# endif + +#if defined(PRE86) +# ifdef DISPATCH_TRACE + printExit(interp, "ProcMethodDispatch", objc, objv, result); + /* fprintf(stderr, " returnCode %d xotcl rc %d\n", + Tcl_Interp_returnCode(interp), result);*/ +# endif + + if (result == TCL_OK && paramDefs && paramDefs->returns) { + Tcl_Obj *valueObj = Tcl_GetObjResult(interp); + /*fprintf(stderr, "***** we have returns for method '%s' check %s, value %p is shared %d\n", + methodName, ObjStr(paramDefs->returns), valueObj, Tcl_IsShared(valueObj));*/ + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", + RUNTIME_STATE(interp)->doCheckResults, + NULL); + } + + opt = object->opt; + if (opt && object->teardown && + (opt->checkoptions & CHECK_POST)) { + int rc = AssertionCheck(interp, object, cscPtr->cl, methodName, CHECK_POST); + /* don't clobber error codes */ + if (result == TCL_OK) { + result = rc; + } + } +#endif + finish: + return result; +} + +/* Invoke a method implemented as a cmd (with assertion checking) */ +static int +CmdMethodDispatch(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + CONST char *methodName, XOTclObject *object, Tcl_Command cmdPtr, + XOTclCallStackContent *cscPtr) { + CheckOptions co; + int result; + Tcl_CallFrame frame, *framePtr = &frame; + + assert(object); + assert(object->teardown); + +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "+++ CmdMethodDispatchCheck %s, obj %p %s, cscPtr %p, teardown %p\n", + methodName, object, objectName(object), cscPtr, object->teardown); +#endif + + /* fprintf(stderr, ".. calling cmd %s cscPtr %p\n", methodName, cscPtr);*/ + + if (object->opt) { + co = object->opt->checkoptions; + if ((co & CHECK_INVAR) && + ((result = AssertionCheckInvars(interp, object, methodName, co)) == TCL_ERROR)) { + goto finish; + } + } + + if (cscPtr) { + /* We have a call stack content, but the following dispatch will + * by itself not stack it; in order to get e.g. self working, we + * have to stack at least an FRAME_IS_XOTCL_OBJECT. + * TODO: maybe push should happen already before assertion checking, + * but we have to check what happens in the finish target etc. + */ + /*fprintf(stderr, "XOTcl_PushFrameCsc %s %s\n",objectName(object), methodName);*/ + XOTcl_PushFrameCsc(interp, cscPtr, framePtr); + } + +#ifdef DISPATCH_TRACE + printCall(interp, "CmdMethodDispatch cmd", objc, objv); + fprintf(stderr, "\tcmd=%s\n", Tcl_GetCommandName(interp, cmdPtr)); +#endif + + /*fprintf(stderr, "CmdDispatch obj %p %p %s\n", obj, methodName, methodName);*/ + result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmdPtr), cp, objc, objv); + +#ifdef DISPATCH_TRACE + printExit(interp, "CmdMethodDispatch cmd", objc, objv, result); +#endif + + if (cscPtr) { + XOTcl_PopFrameCsc(interp, framePtr); + } + + /* Reference counting in the calling ObjectDispatch() makes sure + that obj->opt is still accessible even after "dealloc" */ + if (object->opt) { + co = object->opt->checkoptions; + if ((co & CHECK_INVAR) && + ((result = AssertionCheckInvars(interp, object, methodName, co)) == TCL_ERROR)) { + goto finish; + } + } + + { XOTclParamDefs *paramDefs = ParamDefsGet(cmdPtr); + + if (result == TCL_OK && paramDefs && paramDefs->returns) { + Tcl_Obj *valueObj = Tcl_GetObjResult(interp); + /* fprintf(stderr, "***** CMD we have returns for method '%s' check %s, value %p\n", + methodName, ObjStr(paramDefs->returns), valueObj);*/ + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", + RUNTIME_STATE(interp)->doCheckResults, + NULL); + } + } + + finish: + return result; +} + +#if defined(NSF_PROFILE) +static int +MethodDispatch(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], Tcl_Command cmd, XOTclObject *object, XOTclClass *cl, + CONST char *methodName, int frameType) { + struct timeval trt; + long int startUsec = (gettimeofday(&trt, NULL), trt.tv_usec), startSec = trt.tv_sec; + + result = __MethodDispatch__(clientData, interp, objc, objv, cmd, object, cl, methodName, frameType); + XOTclProfileEvaluateData(interp, startSec, startUsec, object, cl, methodName); + return result; +} +# define MethodDispatch __MethodDispatch__ +#endif + +#if 0 +static Tcl_Obj* +SubcmdObj(Tcl_Interp *interp, CONST char *start, size_t len) { + Tcl_Obj *checker = Tcl_NewStringObj("sub=", 4); + Tcl_AppendLimitedToObj(checker, start, len, INT_MAX, NULL); + return checker; +} +#endif + +static int +DispatchUnknownMethod(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + Tcl_Obj *methodObj, int flags) { + int result; + XOTclObject *object = (XOTclObject*)clientData; + + Tcl_Obj *unknownObj = XOTclMethodObj(interp, object, XO_o_unknown_idx); + + if (unknownObj && methodObj != unknownObj && (flags & XOTCL_CM_NO_UNKNOWN) == 0) { + /* + * back off and try unknown; + */ + ALLOC_ON_STACK(Tcl_Obj*, objc+2, tov); + + /*fprintf(stderr, "calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s objc %d\n", + objectName(object), ObjStr(methodObj), flags, XOTCL_CM_NO_UNKNOWN, + XOTclObjectIsClass(object), object, objectName(object), objc);*/ + + tov[0] = object->cmdName; + tov[1] = unknownObj; + if (objc>0) { + memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc)); + } + /* + fprintf(stderr, "?? %s unknown %s\n", objectName(object), ObjStr(tov[2])); + */ + flags &= ~XOTCL_CM_NO_SHIFT; + result = ObjectDispatch(clientData, interp, objc+2, tov, flags | XOTCL_CM_NO_UNKNOWN); + FREE_ON_STACK(Tcl_Obj*, tov); + + } else { /* no unknown called, builtin unknown handler */ + + /*fprintf(stderr, "--- No unknown method Name %s objv[%d] %s\n", + ObjStr(methodObj), 1, ObjStr(objv[1]));*/ + result = XOTclVarErrMsg(interp, objectName(object), + ": unable to dispatch method '", + ObjStr(objv[1]), "'", (char *) NULL); + } + return result; +} + +/* + * MethodDispatch() calls an XOTcl method. It calls either a + * Tcl-implemented method (via ProcMethodDispatch()) or a C-implemented + * method (via CmdMethodDispatch()) and sets up stack and client data + * accordingly. + */ + +static int +MethodDispatch(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], + Tcl_Command cmd, XOTclObject *object, XOTclClass *cl, + CONST char *methodName, int frameType) { + ClientData cp = Tcl_Command_objClientData(cmd); + XOTclCallStackContent csc, *cscPtr; + register Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + + int result; + + assert (object->teardown); + /*fprintf(stderr, "MethodDispatch method '%s' cmd %p cp=%p objc=%d\n", methodName, cmd, cp, objc);*/ + + if (proc == TclObjInterpProc) { + /* + The cmd is a scripted method + */ +#if defined(NRE) + cscPtr = (XOTclCallStackContent *) TclStackAlloc(interp, sizeof(XOTclCallStackContent)); +# if defined(TCL_STACK_ALLOC_TRACE) + fprintf(stderr, "---- csc alloc %p method %s\n", cscPtr, methodName); +# endif +#else + cscPtr = &csc; +#endif + CscInit(cscPtr, object, cl, cmd, frameType); + result = ProcMethodDispatch(cp, interp, objc, objv, methodName, object, cl, cmd, cscPtr); +#if defined(NRE) + /* CscFinish() is performed by the callbacks or in error case base ProcMethodDispatch */ + /*fprintf(stderr, "no pop for %s\n", methodName);*/ +#else + CscFinish(interp, cscPtr); +#endif + return result; + + } else if (cp || Tcl_Command_flags(cmd) & XOTCL_CMD_NONLEAF_METHOD) { + /* + The cmd has client data or is an aliased method + */ + cscPtr = &csc; + + /*fprintf(stderr, "we could stuff obj %p %s\n", object, objectName(object));*/ + + if (proc == XOTclObjDispatch) { + /* + * invoke an aliased object via method interface + */ + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + XOTclObject *invokeObj = (XOTclObject *)cp; + + if (invokeObj->flags & XOTCL_DELETED) { + /* + * When we try to call a deleted object, the cmd (alias) is + * automatically removed. + */ + Tcl_DeleteCommandFromToken(interp, cmd); + XOTclCleanupObject(invokeObj); + return XOTclVarErrMsg(interp, "Trying to dispatch deleted object via method '", + methodName, "'", (char *) NULL); + } + + /* + * The client data cp is still the obj of the called method, + * i.e. self changes. In order to prevent this, we save the + * actual object in the runtime state, flag ObjectDispatch via + * XOTCL_CM_DELGATE to use it. + */ + /*xxxx*/ + rst->delegatee = object; + if (objc < 2) { + result = DispatchDefaultMethod(cp, interp, objc, objv); + } else { +#if 0 + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); + memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); + tov[1] = SubcmdObj(interp, ObjStr(objv[1]), -1); + INCR_REF_COUNT(tov[1]); + result = ObjectDispatch(cp, interp, objc, tov, XOTCL_CM_DELGATE); + DECR_REF_COUNT(tov[1]); +#else + XOTclObject *self = (XOTclObject *)cp; + char *methodName = ObjStr(objv[1]); + + /*fprintf(stderr, "save self %p %s (ns %p) object %p %s\n", + self, objectName(self), self->nsPtr, object, objectName(object));*/ + if (self->nsPtr) { + cmd = FindMethod(self->nsPtr, methodName); + /*fprintf(stderr, "... method %p %s\n", cmd, methodName);*/ + if (cmd) { + result = MethodDispatch(object, interp, objc-1, objv+1, + cmd, object, NULL, methodName, frameType); + goto obj_dispatch_ok; + } + } + + result = DispatchUnknownMethod(self, interp, + objc-1, objv+1, objv[1], XOTCL_CM_NO_OBJECT_METHOD); + /* + result = XOTclVarErrMsg(interp, objectName(self), + ": aaa unable to dispatch method '", + methodName, "'", (char *) NULL); + */ + obj_dispatch_ok:; + /*result = ObjectDispatch(cp, interp, objc, objv, XOTCL_CM_DELGATE);*/ +#endif + } + return result; + } else if (proc == XOTclForwardMethod || + proc == XOTclObjscopedMethod || + proc == XOTclSetterMethod + ) { + TclCmdClientData *tcd = (TclCmdClientData *)cp; + tcd->object = object; + assert((CmdIsProc(cmd) == 0)); + } else if (cp == (ClientData)XOTCL_CMD_NONLEAF_METHOD) { + cp = clientData; + assert((CmdIsProc(cmd) == 0)); + } + CscInit(cscPtr, object, cl, cmd, frameType); + + } else { + /* + The cmd has no client data + */ + /*fprintf(stderr, "cmdMethodDispatch %s %s, nothing stacked\n",objectName(object), methodName);*/ + + return CmdMethodDispatch(clientData, interp, objc, objv, methodName, object, cmd, NULL); + } + + result = CmdMethodDispatch(cp, interp, objc, objv, methodName, object, cmd, cscPtr); + /* make sure, that csc is still in the scope; therefore, csc is + currently on the top scope of this function */ + CscFinish(interp, cscPtr); + + return result; +} + +static int +DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int result; + Tcl_Obj *methodObj = XOTclMethodObj(interp, (XOTclObject *)clientData, XO_o_defaultmethod_idx); + + if (methodObj) { + Tcl_Obj *tov[2]; + tov[0] = objv[0]; + tov[1] = methodObj; + result = ObjectDispatch(clientData, interp, 2, tov, XOTCL_CM_NO_UNKNOWN); + } else { + result = TCL_OK; + } + return result; +} + + +XOTCLINLINE static int +ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int flags) { + register XOTclObject *object = (XOTclObject*)clientData; + int result = TCL_OK, mixinStackPushed = 0, + filterStackPushed = 0, unknown = 0, objflags, shift, + frameType = XOTCL_CSC_TYPE_PLAIN; + CONST char *methodName; + XOTclClass *cl = NULL; + Tcl_Command cmd = NULL; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + Tcl_Obj *cmdName = object->cmdName, *methodObj, *cmdObj; + + assert(objc>0); + + if (flags & XOTCL_CM_NO_SHIFT) { + shift = 0; + cmdObj = object->cmdName; + methodObj = objv[0]; + } else { + assert(objc>1); + shift = 1; + cmdObj = objv[0]; + methodObj = objv[1]; + } + + methodName = ObjStr(methodObj); + if (FOR_COLON_RESOLVER(methodName)) { + methodName ++; + } + + /*fprintf(stderr, "ObjectDispatch obj = %s objc = %d 0=%s methodName=%s\n", + objectName(object), objc, ObjStr(cmdObj), methodName);*/ + +#ifdef DISPATCH_TRACE + printCall(interp, "DISPATCH", objc, objv); +#endif + + objflags = object->flags; /* avoid stalling */ + + /* make sure, cmdName and obj survive this method until the end */ + INCR_REF_COUNT(cmdName); + object->refCount ++; + + if (!(objflags & XOTCL_FILTER_ORDER_VALID)) { + FilterComputeDefined(interp, object); + objflags = object->flags; + } + + if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) { + MixinComputeDefined(interp, object); + objflags = object->flags; + } + + /* Only start new filter chain, if + (a) filters are defined and + (b) the toplevel csc entry is not an filter on self + */ + + /*fprintf(stderr, "call %s, objflags %.6x, defined and valid %.6x doFilters %d guard count %d\n", + methodName, objflags, XOTCL_FILTER_ORDER_DEFINED_AND_VALID, + rst->doFilters, rst->guardCount);*/ + + if (((objflags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == XOTCL_FILTER_ORDER_DEFINED_AND_VALID) + && rst->doFilters + && !rst->guardCount) { + XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); + + /*fprintf(stderr, "... check ok, cscPtr = %p\n", cscPtr); + if (!cscPtr) { + tcl85showStack(interp); + }*/ + if (!cscPtr || (object != cscPtr->self || + cscPtr->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER)) { + filterStackPushed = FilterStackPush(interp, object, methodObj); + cmd = FilterSearchProc(interp, object, &object->filterStack->currentCmdPtr, &cl); + if (cmd) { + /*fprintf(stderr, "filterSearchProc returned cmd %p\n", cmd);*/ + frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + methodName = (char *)Tcl_GetCommandName(interp, cmd); + } else { + /*fprintf(stderr, "filterSearchProc returned no cmd\n");*/ + FilterStackPop(object); + 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 ((objflags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + + mixinStackPushed = MixinStackPush(object); + + if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { + result = MixinSearchProc(interp, object, methodName, &cl, + &object->mixinStack->currentCmdPtr, &cmd); + if (result != TCL_OK) { + goto exit_dispatch; + } + if (cmd) { + frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + } else { /* the else branch could be deleted */ + MixinStackPop(object); + mixinStackPushed = 0; + } + } + } + + /* check if an absolute method name was provided */ + if (*methodName == ':') { + cmd = Tcl_GetCommandFromObj(interp, methodObj); + if (cmd) { + CONST char *mn = Tcl_GetCommandName(interp, cmd); + if (isClassName(methodName)) { + CONST char *className = NSCutXOTclClasses(methodName); + Tcl_DString ds, *dsPtr = &ds; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className, strlen(className)-strlen(mn)-2); + cl = (XOTclClass *)XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + DSTRING_FREE(dsPtr); + } + } + } + + /* if no filter/mixin is found => do ordinary method lookup */ + if (cmd == NULL) { + + /* do we have a object-specific proc? */ + if (object->nsPtr && (flags & XOTCL_CM_NO_OBJECT_METHOD) == 0) { + cmd = FindMethod(object->nsPtr, methodName); + /* fprintf(stderr, "lookup for proc in obj %p method %s nsPtr %p => %p\n", + object, methodName, object->nsPtr, cmd);*/ + } + /*fprintf(stderr, "findMethod for proc '%s' in %p returned %p\n", methodName, object->nsPtr, cmd);*/ + + if (cmd == NULL) { + /* check for a method */ + XOTclClass *currentClass = object->cl; + if (currentClass->order == NULL) currentClass->order = TopoOrder(currentClass, Super); + cl = SearchPLMethod(currentClass->order, methodName, &cmd); + } + } + + if (cmd) { + result = TCL_OK; + + /*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 */ + + if ((Tcl_Command_flags(cmd) & XOTCL_CMD_PROTECTED_METHOD) && + (flags & (XOTCL_CM_NO_UNKNOWN|XOTCL_CM_NO_PROTECT)) == 0) { + XOTclObject *o, *lastSelf = GetSelfObj(interp); + + /* we do not want to rely on clientData, so get obj from cmdObj */ + GetObjectFromObj(interp, cmdObj, &o); + if (o != lastSelf) { + /*fprintf(stderr, "+++ protected method %s is not invoked\n", methodName);*/ + /* allow unknown-handler to handle this case */ + unknown = 1; + fprintf(stderr, "+++ %s is protected, therefore maybe unknown %p %s lastself=%p o=%p cd %p flags = %.6x\n", + methodName, cmdObj, ObjStr(cmdObj), lastSelf, o, clientData, flags); + /*tcl85showStack(interp);*/ + } + } + + if (!unknown) { + /* xxxx */ + /*fprintf(stderr, "ObjectDispatch calls MethodDispatch with obj = %s frameType %d method %s flags %.6x\n", + objectName(object), frameType, methodName, flags);*/ + if (flags & XOTCL_CM_DELGATE && rst->delegatee) { + /* + * We want to execute the method on the delegatee, so we have + * to flip the object. + * + * Note: there is a object->refCount ++; at the begin of this + * function and a XOTclCleanupObject(object) at the end. So, + * we have to keep track of the refcounts here. Either mangle + * refcounts, or save originator. + * + */ + result = MethodDispatch(rst->delegatee, interp, objc-shift, objv+shift, + cmd, rst->delegatee, cl, + methodName, frameType); + } else { + result = MethodDispatch(clientData, interp, objc-shift, objv+shift, cmd, object, cl, + methodName, frameType); + } + + /*fprintf(stderr, "MethodDispatch %s returns %d unknown %d\n", + methodName, result, rst->unknown);*/ + + if (result == TCL_ERROR) { + /*fprintf(stderr, "Call ErrInProc cl = %p, cmd %p, flags %.6x\n", + cl, cl ? cl->object.id : 0, cl ? cl->object.flags : 0);*/ + result = XOTclErrInProc(interp, cmdName, + cl && cl->object.teardown ? cl->object.cmdName : NULL, + methodName); + } + + if (rst->unknown && (frameType & XOTCL_CSC_TYPE_ACTIVE_FILTER)) { + /*fprintf(stderr, "use saved unknown %d frameType %.6x\n", + RUNTIME_STATE(interp)->unknown, frameType);*/ + unknown = 1; + } else { + unknown = 0; + } + + } + } else { + unknown = 1; + } + + /* fprintf(stderr, "cmd %p unknown %d result %d\n", cmd, unknown, result);*/ + + if (result == TCL_OK) { + /*fprintf(stderr, "after doCallProcCheck unknown == %d\n", unknown);*/ + if (unknown) { + result = DispatchUnknownMethod(clientData, interp, + objc-shift, objv+shift, methodObj, flags); + } + } + /* be sure to reset unknown flag */ + if (unknown && (frameType & XOTCL_CSC_TYPE_ACTIVE_FILTER) == 0) { + /*fprintf(stderr, "**** rst->unknown set to 0 flags %.6x frameType %.6x\n",flags,frameType);*/ + rst->unknown = 0; + } + + exit_dispatch: +#ifdef DISPATCH_TRACE + printExit(interp, "DISPATCH", objc, objv, result); +#endif + + if (mixinStackPushed && object->mixinStack) + MixinStackPop(object); + + if (filterStackPushed && object->filterStack) + FilterStackPop(object); + + XOTclCleanupObject(object); + /*fprintf(stderr, "ObjectDispatch call XOTclCleanupObject %p DONE\n", object);*/ + DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */ + return result; +} + + +int +XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int result; +#ifdef STACK_TRACE + XOTclStackDump(interp); +#endif + +#ifdef CALLSTACK_TRACE + XOTclCallStackDump(interp); +#endif + + if (objc > 1) { + /* normal dispatch */ + result = ObjectDispatch(clientData, interp, objc, objv, 0); + } else { + result = DispatchDefaultMethod(clientData, interp, objc, objv); + } + return result; +} + +/* + * Proc-Creation + */ + +static Tcl_Obj *addPrefixToBody(Tcl_Obj *body, int paramDefs, XOTclParsedParam *paramPtr) { + Tcl_Obj *resultBody = Tcl_NewStringObj("", 0); + + INCR_REF_COUNT(resultBody); + + if (paramDefs && paramPtr->possibleUnknowns > 0) + Tcl_AppendStringsToObj(resultBody, "::nsf::unsetUnknownArgs\n", (char *) NULL); + + Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); + return resultBody; +} + +#define NEW_STRING(target, p, l) target = ckalloc(l+1); strncpy(target, p, l); *((target)+l) = '\0' + +XOTCLINLINE static int +noMetaChars(CONST char *pattern) { + register char c; + CONST char *p = pattern; + + assert(pattern); + for (c=*p; c; c = *++p) { + if (c == '*' || c == '?' || c == '[') { + return 0; + } + } + return 1; +} + +/* + * type converter + */ +/* we could define parameterTypes with a converter, setter, canCheck, name */ +static int convertToString(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + *clientData = (char *)ObjStr(objPtr); + *outObjPtr = objPtr; + return TCL_OK; +} + +enum stringTypeIdx {StringTypeAlnum, StringTypeAlpha, StringTypeAscii, StringTypeBoolean, StringTypeControl, + StringTypeDigit, StringTypeDouble, StringTypeFalse,StringTypeGraph, StringTypeInteger, + StringTypeLower, StringTypePrint, StringTypePunct, StringTypeSpace, StringTypeTrue, + StringTypeUpper, StringTypeWordchar, StringTypeXdigit }; +static CONST char *stringTypeOpts[] = {"alnum", "alpha", "ascii", "boolean", "control", + "digit", "double", "false", "graph", "integer", + "lower", "print", "punct", "space", "true", + "upper", "wordchar", "xdigit", NULL}; + +static int convertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + Tcl_Obj *objv[3]; + int result; + + if (pPtr->converterArg) { + /*fprintf(stderr, "convertToStringType %s (must be %s)\n", ObjStr(objPtr), ObjStr(pPtr->converterArg));*/ + + objv[1] = pPtr->converterArg; + objv[2] = objPtr; + + result = XOTclCallCommand(interp, XOTE_IS, 3, objv); + if (result == TCL_OK) { + int success; + Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &success); + if (success == 1) { + *clientData = (ClientData)objPtr; + } else { + result = XOTclVarErrMsg(interp, "expected ", ObjStr(pPtr->converterArg), + " but got \"", ObjStr(objPtr), + "\" for parameter ", pPtr->name, NULL); + } + } + } else { + *clientData = (ClientData)objPtr; + result = TCL_OK; + } + *outObjPtr = objPtr; + return result; +} + +static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + *outObjPtr = objPtr; + return TCL_OK; +} + +static int convertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + int result, bool; + result = Tcl_GetBooleanFromObj(interp, objPtr, &bool); + + if (result == TCL_OK) { + *clientData = (ClientData)INT2PTR(bool); + } else { + XOTclVarErrMsg(interp, "expected boolean value but got \"", ObjStr(objPtr), + "\" for parameter ", pPtr->name, NULL); + } + *outObjPtr = objPtr; + return result; +} + +static int convertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + int result, i; + + result = Tcl_GetIntFromObj(interp, objPtr, &i); + + if (result == TCL_OK) { + *clientData = (ClientData)INT2PTR(i); + *outObjPtr = objPtr; + } else { + XOTclVarErrMsg(interp, "expected integer but got \"", ObjStr(objPtr), + "\" for parameter ", pPtr->name, NULL); + } + return result; +} + +static int convertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + return convertToBoolean(interp, objPtr, pPtr, clientData, outObjPtr); +} + +static int objectOfType(Tcl_Interp *interp, XOTclObject *object, CONST char *what, Tcl_Obj *objPtr, + XOTclParam CONST *pPtr) { + XOTclClass *cl; + Tcl_DString ds, *dsPtr = &ds; + + if (pPtr->converterArg == NULL) + return TCL_OK; + + if ((GetClassFromObj(interp, pPtr->converterArg, &cl, NULL) == TCL_OK) + && IsSubType(object->cl, cl)) { + return TCL_OK; + } + + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, what, -1); + Tcl_DStringAppend(dsPtr, " of type ", -1); + Tcl_DStringAppend(dsPtr, ObjStr(pPtr->converterArg), -1); + XOTclObjErrType(interp, objPtr, Tcl_DStringValue(dsPtr), pPtr->name); + DSTRING_FREE(dsPtr); + + return TCL_ERROR; +} + +static int convertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + *outObjPtr = objPtr; + if (GetObjectFromObj(interp, objPtr, (XOTclObject **)clientData) == TCL_OK) { + return objectOfType(interp, (XOTclObject *)*clientData, "object", objPtr, pPtr); + } + return XOTclObjErrType(interp, objPtr, "object", pPtr->name); +} + +static int convertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + *outObjPtr = objPtr; + if (GetClassFromObj(interp, objPtr, (XOTclClass **)clientData, NULL) == TCL_OK) { + return objectOfType(interp, (XOTclObject *)*clientData, "class", objPtr, pPtr); + } + return XOTclObjErrType(interp, objPtr, "class", pPtr->name); +} + +static int convertToRelation(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + /* XOTclRelationCmd is the real setter, which checks the values + according to the relation type (Class, List of Class, list of + filters; we treat it here just like a tclobj */ + *clientData = (ClientData)objPtr; + *outObjPtr = objPtr; + return TCL_OK; +} + +static int convertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + Tcl_Obj *ov[5]; + Tcl_Obj *savedResult; + int result, oc; + + /* + * In general, when the converter is used e.g. for result checking, + * we do not want to alter the result just when the converter sets a + * result. So, for non-converter, we save the old result and restore + * it before the return in case of success. Strictly speaking, + * result-overwritng just harms for result-converters, but saving is + * always semantic correct. + */ + if ((pPtr->flags & XOTCL_ARG_IS_CONVERTER) == 0) { + savedResult = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(savedResult); + } else { + savedResult = NULL; + } + + ov[0] = pPtr->slotObj ? pPtr->slotObj : XOTclGlobalObjs[XOTE_METHOD_PARAMETER_SLOT_OBJ]; + ov[1] = pPtr->converterName; + ov[2] = pPtr->nameObj; + ov[3] = objPtr; + + /*fprintf(stderr, "convertViaCmd call converter %s (refCount %d) on %s paramPtr %p\n", + ObjStr(pPtr->converterName), pPtr->converterName->refCount, ObjStr(ov[0]), pPtr);*/ + oc = 4; + if (pPtr->converterArg) { + ov[4] = pPtr->converterArg; + oc++; + } + + + INCR_REF_COUNT(ov[1]); + INCR_REF_COUNT(ov[2]); + result = Tcl_EvalObjv(interp, oc, ov, 0); + DECR_REF_COUNT(ov[1]); + DECR_REF_COUNT(ov[2]); + + /* per default, the input arg is the output arg */ + *outObjPtr = objPtr; + + if (result == TCL_OK) { + /*fprintf(stderr, "convertViaCmd could convert %s to '%s' paramPtr %p, is_converter %d\n", + ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)),pPtr, + pPtr->flags & XOTCL_ARG_IS_CONVERTER);*/ + if (pPtr->flags & XOTCL_ARG_IS_CONVERTER) { + /* + * If we want to convert, the resulting obj is the result of the + * converter. incr refCount is necessary e.g. for e.g. + * return [expr {$value + 1}] + */ + *outObjPtr = Tcl_GetObjResult(interp); + INCR_REF_COUNT(*outObjPtr); + } + *clientData = (ClientData) *outObjPtr; + + if (savedResult) { + /*fprintf(stderr, "restore savedResult %p\n", savedResult);*/ + Tcl_SetObjResult(interp, savedResult); /* restore the result */ + } + } + + if (savedResult) { + DECR_REF_COUNT(savedResult); + } + + return result; +} + +static int convertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, + ClientData *clientData, Tcl_Obj **outObjPtr) { + Tcl_Obj *patternObj = objPtr; + CONST char *pattern = ObjStr(objPtr); + + if (noMetaChars(pattern)) { + /* we have no meta characters, we try to check for an existing object */ + XOTclObject *object = NULL; + GetObjectFromObj(interp, objPtr, &object); + if (object) { + patternObj = object->cmdName; + } + } else { + /* + * 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+1 != ':') { + patternObj = Tcl_NewStringObj("::", 2); + Tcl_AppendLimitedToObj(patternObj, pattern, -1, INT_MAX, NULL); + } + } + if (patternObj) { + INCR_REF_COUNT(patternObj); + } + *clientData = (ClientData)patternObj; + *outObjPtr = objPtr; + return TCL_OK; +} + +static Tcl_Obj* +ParamCheckObj(Tcl_Interp *interp, CONST char *start, size_t len) { + Tcl_Obj *checker = Tcl_NewStringObj("type=", 5); + Tcl_AppendLimitedToObj(checker, start, len, INT_MAX, NULL); + return checker; +} + +static int +ParamOptionSetConverter(Tcl_Interp *interp, XOTclParam *paramPtr, + CONST char *typeName, XOTclTypeConverter *converter) { + if (paramPtr->converter) { + return XOTclVarErrMsg(interp, "Refuse to redefine parameter converter to use ", + typeName, (char *) NULL); + } + paramPtr->converter = converter; + paramPtr->nrArgs = 1; + paramPtr->type = typeName; + return TCL_OK; +} + +static int +ParamOptionParse(Tcl_Interp *interp, CONST char *option, size_t length, int disallowedOptions, XOTclParam *paramPtr) { + int result = TCL_OK; + /*fprintf(stderr, "ParamOptionParse name %s, option '%s' (%d) disallowed %.6x\n", + paramPtr->name, option, length, disallowedOptions);*/ + if (strncmp(option, "required", MAX(3,length)) == 0) { + paramPtr->flags |= XOTCL_ARG_REQUIRED; + } else if (strncmp(option, "optional", MAX(3,length)) == 0) { + paramPtr->flags &= ~XOTCL_ARG_REQUIRED; + } else if (strncmp(option, "substdefault", 12) == 0) { + paramPtr->flags |= XOTCL_ARG_SUBST_DEFAULT; + } else if (strncmp(option, "allowempty", 10) == 0) { + paramPtr->flags |= XOTCL_ARG_ALLOW_EMPTY; + } else if (strncmp(option, "convert", 7) == 0) { + paramPtr->flags |= XOTCL_ARG_IS_CONVERTER; + } else if (strncmp(option, "initcmd", 7) == 0) { + paramPtr->flags |= XOTCL_ARG_INITCMD; + } else if (strncmp(option, "method", 6) == 0) { + paramPtr->flags |= XOTCL_ARG_METHOD; + } else if (strncmp(option, "multivalued", 11) == 0) { + if ((paramPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_METHOD|XOTCL_ARG_SWITCH)) != 0) + return XOTclVarErrMsg(interp, + "option multivalued not allowed for \"initcmd\", \"method\", \"relation\" or \"switch\"\n", + (char *) NULL); + paramPtr->flags |= XOTCL_ARG_MULTIVALUED; + } else if (strncmp(option, "noarg", 5) == 0) { + if ((paramPtr->flags & XOTCL_ARG_METHOD) == 0) { + return XOTclVarErrMsg(interp, "option noarg only allowed for parameter type \"method\"", + (char *) NULL); + } + paramPtr->flags |= XOTCL_ARG_NOARG; + paramPtr->nrArgs = 0; + } else if (length >= 4 && strncmp(option, "arg=", 4) == 0) { + if ((paramPtr->flags & (XOTCL_ARG_METHOD|XOTCL_ARG_RELATION)) == 0 + && paramPtr->converter != convertViaCmd) + return XOTclVarErrMsg(interp, + "option arg= only allowed for \"method\", \"relation\" or \"user-defined converter\"", + (char *) NULL); + paramPtr->converterArg = Tcl_NewStringObj(option+4, length-4); + INCR_REF_COUNT(paramPtr->converterArg); + } else if (strncmp(option, "switch", 6) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "switch", convertToSwitch); + paramPtr->flags |= XOTCL_ARG_SWITCH; + paramPtr->nrArgs = 0; + assert(paramPtr->defaultValue == NULL); + paramPtr->defaultValue = Tcl_NewBooleanObj(0); + INCR_REF_COUNT(paramPtr->defaultValue); + } else if (strncmp(option, "integer", MAX(3,length)) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "integer", convertToInteger); + } else if (strncmp(option, "boolean", 7) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "boolean", convertToBoolean); + } else if (strncmp(option, "object", 6) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "object", convertToObject); + } else if (strncmp(option, "class", 5) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "class", convertToClass); + } else if (strncmp(option, "relation", 8) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "relation", convertToRelation); + paramPtr->flags |= XOTCL_ARG_RELATION; + /*paramPtr->type = "tclobj";*/ + } else if (length >= 6 && strncmp(option, "type=", 5) == 0) { + if (paramPtr->converter != convertToObject && + paramPtr->converter != convertToClass) + return XOTclVarErrMsg(interp, "option type= only allowed for object or class", (char *) NULL); + paramPtr->converterArg = Tcl_NewStringObj(option+5, length-5); + INCR_REF_COUNT(paramPtr->converterArg); + } else if (length >= 6 && strncmp(option, "slot=", 5) == 0) { + paramPtr->slotObj = Tcl_NewStringObj(option+5, length-5); + INCR_REF_COUNT(paramPtr->slotObj); + } else { + int i, found = -1; + + for (i=0; stringTypeOpts[i]; i++) { + /* Do not allow abbreviations, so the additional strlen checks + for a full match */ + if (strncmp(option, stringTypeOpts[i], length) == 0 && strlen(stringTypeOpts[i]) == length) { + found = i; + break; + } + } + if (found > -1) { + /* converter is stringType */ + result = ParamOptionSetConverter(interp, paramPtr, "stringtype", convertToTclobj); + paramPtr->converterArg = Tcl_NewStringObj(stringTypeOpts[i], -1); + INCR_REF_COUNT(paramPtr->converterArg); + } else { + /* must be a converter defined via method */ + paramPtr->converterName = ParamCheckObj(interp, option, length); + INCR_REF_COUNT(paramPtr->converterName); + result = ParamOptionSetConverter(interp, paramPtr, ObjStr(paramPtr->converterName), convertViaCmd); + } + } + + if ((paramPtr->flags & disallowedOptions)) { + return XOTclVarErrMsg(interp, "Parameter option '", option, "' not allowed", (char *) NULL); + } + + return result; +} + +static int +ParamParse(Tcl_Interp *interp, CONST char *procName, Tcl_Obj *arg, int disallowedFlags, + XOTclParam *paramPtr, int *possibleUnknowns, int *plainParams) { + int result, npac, isNonposArgument; + size_t nameLength, length, j; + CONST char *argString, *argName; + Tcl_Obj **npav; + + paramPtr->paramObj = arg; + INCR_REF_COUNT(paramPtr->paramObj); + + result = Tcl_ListObjGetElements(interp, arg, &npac, &npav); + if (result != TCL_OK || npac < 1 || npac > 2) { + return XOTclVarErrMsg(interp, "wrong # of elements in parameter definition for method ", + procName, " (should be 1 or 2 list elements): ", + ObjStr(arg), (char *) NULL); + } + + argString = ObjStr(npav[0]); + length = strlen(argString); + + isNonposArgument = *argString == '-'; + + if (isNonposArgument) { + argName = argString+1; + nameLength = length-1; + paramPtr->nrArgs = 1; /* per default 1 argument, switches set their arg numbers */ + } else { + argName = argString; + nameLength = length; + paramPtr->flags |= XOTCL_ARG_REQUIRED; /* positional arguments are required unless we have a default */ + } + + /* fprintf(stderr, "... parsing '%s', name '%s' \n", ObjStr(arg), argName);*/ + + /* find the first ':' */ + for (j=0; jname, argString, j); + paramPtr->nameObj = Tcl_NewStringObj(argName, isNonposArgument ? j-1 : j); + INCR_REF_COUNT(paramPtr->nameObj); + + /* skip space at begin */ + for (start = j+1; start0 && isspace((int)argString[end-1]); end--); + result = ParamOptionParse(interp, argString+start, end-start, disallowedFlags, paramPtr); + if (result != TCL_OK) { + goto param_error; + } + l++; + /* skip space from begin */ + for (start = l; start0 && isspace((int)argString[end-1]); end--); + /* process last option */ + result = ParamOptionParse(interp, argString+start, end-start, disallowedFlags, paramPtr); + if (result != TCL_OK) { + goto param_error; + } + } else { + /* no ':', the whole arg is the name, we have not options */ + NEW_STRING(paramPtr->name, argString, length); + if (isNonposArgument) { + paramPtr->nameObj = Tcl_NewStringObj(argName, length-1); + } else { + (*plainParams) ++; + paramPtr->nameObj = Tcl_NewStringObj(argName, length); + } + INCR_REF_COUNT(paramPtr->nameObj); + } + + /* if we have two arguments in the list, the second one is a default value */ + if (npac == 2) { + + if (disallowedFlags & XOTCL_ARG_HAS_DEFAULT) { + XOTclVarErrMsg(interp, "parameter \"", argString, + "\" is not allowed to have default \"", + ObjStr(npav[1]), "\"", (char *) NULL); + goto param_error; + } + + /* if we have for some reason already a default value, free it */ + if (paramPtr->defaultValue) { + DECR_REF_COUNT(paramPtr->defaultValue); + } + paramPtr->defaultValue = Tcl_DuplicateObj(npav[1]); + INCR_REF_COUNT(paramPtr->defaultValue); + /* + * The argument will be not required for an invocation, since we + * have a default. + */ + paramPtr->flags &= ~XOTCL_ARG_REQUIRED; + } else if (paramPtr->flags & XOTCL_ARG_SUBST_DEFAULT) { + XOTclVarErrMsg(interp, "parameter option substdefault specified for parameter \"", + paramPtr->name, "\" without default value", (char *) NULL); + goto param_error; + } + + /* postprocessing the parameter options */ + + if (paramPtr->converter == NULL) { + /* convertToTclobj() is the default converter */ + paramPtr->converter = convertToTclobj; + } /*else if (paramPtr->converter == convertViaCmd) {*/ + + if ((paramPtr->slotObj || paramPtr->converter == convertViaCmd) && paramPtr->type) { + Tcl_Obj *converterNameObj; + CONST char *converterNameString; + XOTclObject *paramObj; + XOTclClass *pcl; + Tcl_Command cmd; + + result = GetObjectFromObj(interp, paramPtr->slotObj ? paramPtr->slotObj : + XOTclGlobalObjs[XOTE_METHOD_PARAMETER_SLOT_OBJ], + ¶mObj); + if (result != TCL_OK) + return result; + + if (paramPtr->converterName == NULL) { + converterNameObj = ParamCheckObj(interp, paramPtr->type, strlen(paramPtr->type)); + INCR_REF_COUNT(converterNameObj); + } else { + converterNameObj = paramPtr->converterName; + } + converterNameString = ObjStr(converterNameObj); + + cmd = ObjectFindMethod(interp, paramObj, converterNameString, &pcl); + if (cmd == NULL) { + if (paramPtr->converter == convertViaCmd) { + fprintf(stderr, "**** could not find checker method %s defined on %s\n", + converterNameString, objectName(paramObj)); + paramPtr->flags |= XOTCL_ARG_CURRENTLY_UNKNOWN; + /* TODO: for the time being, we do not return an error here */ + } + } else if (paramPtr->converter != convertViaCmd && + strcmp(ObjStr(paramPtr->slotObj), + XOTclGlobalStrings[XOTE_METHOD_PARAMETER_SLOT_OBJ]) != 0) { + /* todo remove me */ + fprintf(stderr, "**** checker method %s defined on %s shadows built-in converter\n", + converterNameString, objectName(paramObj)); + if (paramPtr->converterName == NULL) { + paramPtr->converterName = converterNameObj; + paramPtr->converter = NULL; + result = ParamOptionSetConverter(interp, paramPtr, converterNameString, convertViaCmd); + } + } + if ((paramPtr->flags & XOTCL_ARG_IS_CONVERTER) && paramPtr->converter != convertViaCmd) { + return XOTclVarErrMsg(interp, + "option 'convert' only allowed for application-defined converters", + (char *) NULL); + } + if (converterNameObj != paramPtr->converterName) { + DECR_REF_COUNT(converterNameObj); + } + } + + /* + * If the argument is not required and no default value is + * specified, we have to handle in the client code (eg. in the + * canonical arg handlers for scripted methods) the unknown value + * (e.g. don't set/unset a variable) + */ + if (!(paramPtr->flags & XOTCL_ARG_REQUIRED) && paramPtr->defaultValue == NULL) { + (*possibleUnknowns)++; + } + return TCL_OK; + + param_error: + ckfree((char *)paramPtr->name); + paramPtr->name = NULL + DECR_REF_COUNT(paramPtr->nameObj); + return TCL_ERROR; +} + +static int +ParamDefsParse(Tcl_Interp *interp, CONST char *procName, Tcl_Obj *args, + int allowedOptinons, XOTclParsedParam *parsedParamPtr) { + Tcl_Obj **argsv; + int result, argsc; + + parsedParamPtr->paramDefs = NULL; + parsedParamPtr->possibleUnknowns = 0; + + result = Tcl_ListObjGetElements(interp, args, &argsc, &argsv); + if (result != TCL_OK) { + return XOTclVarErrMsg(interp, "cannot break down non-positional args: ", + ObjStr(args), (char *) NULL); + } + + if (argsc > 0) { + XOTclParam *paramsPtr, *paramPtr, *lastParamPtr; + int i, possibleUnknowns = 0, plainParams = 0; + XOTclParamDefs *paramDefs; + + paramPtr = paramsPtr = ParamsNew(argsc); + + for (i=0; i < argsc; i++, paramPtr++) { + result = ParamParse(interp, procName, argsv[i], allowedOptinons, + paramPtr, &possibleUnknowns, &plainParams); + if (result != TCL_OK) { + ParamsFree(paramsPtr); + return result; + } + } + + /* + * If all arguments are good old Tcl arguments, there is no need + * to use the parameter definition structure. + */ + if (plainParams == argsc) { + ParamsFree(paramsPtr); + return TCL_OK; + } + /* + fprintf(stderr, "we need param definition structure for {%s}, argsc %d plain %d\n", + ObjStr(args), argsc, plainParams); + */ + /* + * Check the last argument. If the last argument is named 'args', + * force converter and make it non-required. + */ + lastParamPtr = paramPtr - 1; + if (isArgsString(lastParamPtr->name)) { + lastParamPtr->converter = convertToNothing; + lastParamPtr->flags &= ~XOTCL_ARG_REQUIRED; + } + + paramDefs = ParamDefsNew(); + paramDefs->paramsPtr = paramsPtr; + paramDefs->nrParams = paramPtr-paramsPtr; + /*fprintf(stderr, "method %s ifsize %d, possible unknowns = %d,\n", + procName, paramPtr-paramDefsPtr, possibleUnknowns);*/ + parsedParamPtr->paramDefs = paramDefs; + parsedParamPtr->possibleUnknowns = possibleUnknowns; + } + return TCL_OK; +} + +static int +MakeProc(Tcl_Namespace *nsPtr, XOTclAssertionStore *aStore, Tcl_Interp *interp, + Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, + Tcl_Obj *postcondition, XOTclObject *object, + int withPublic, int withPer_object, int clsns) { + Tcl_CallFrame frame, *framePtr = &frame; + CONST char *methodName = ObjStr(nameObj); + XOTclParsedParam parsedParam; + Tcl_Obj *ov[4]; + int result; + + /* Check, if we are allowed to redefine the method */ + result = CanRedefineCmd(interp, nsPtr, object, methodName); + if (result == TCL_OK) { + /* Yes, so obtain an method parameter definitions */ + result = ParamDefsParse(interp, methodName, args, XOTCL_DISALLOWED_ARG_METHOD_PARAMETER, &parsedParam); + } + if (result != TCL_OK) { + return result; + } + + ov[0] = NULL; /*objv[0];*/ + ov[1] = nameObj; + + if (parsedParam.paramDefs) { + XOTclParam *pPtr; + Tcl_Obj *argList = Tcl_NewListObj(0, NULL); + + for (pPtr = parsedParam.paramDefs->paramsPtr; pPtr->name; pPtr++) { + if (*pPtr->name == '-') { + Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name+1, -1)); + } else { + Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name, -1)); + } + } + ov[2] = argList; + INCR_REF_COUNT(ov[2]); + /*fprintf(stderr, "final arglist = <%s>\n", ObjStr(argList)); */ + ov[3] = addPrefixToBody(body, 1, &parsedParam); + } else { /* no nonpos arguments */ + ov[2] = args; + ov[3] = addPrefixToBody(body, 0, &parsedParam); + } + + Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, nsPtr, 0); + /* create the method in the provided namespace */ + result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; + if (result == TCL_OK) { + /* retrieve the defined proc */ + Proc *procPtr = FindProcMethod(nsPtr, methodName); + if (procPtr) { + /* modify the cmd of the proc to set the current namespace for the body */ + if (clsns) { + /* + * Set the namespace of the method as inside of the class + */ + if (!object->nsPtr) { + makeObjNamespace(interp, object); + } + /*fprintf(stderr, "obj %s\n", objectName(object)); + fprintf(stderr, "ns %p object->ns %p\n", ns, object->nsPtr); + fprintf(stderr, "ns %s object->ns %s\n", ns->fullName, object->nsPtr->fullName);*/ + procPtr->cmdPtr->nsPtr = (Namespace*) object->nsPtr; + } else { + /* + * Set the namespace of the method to the same namespace the class has + */ + procPtr->cmdPtr->nsPtr = ((Command *)object->id)->nsPtr; + } + + ParamDefsStore(interp, (Tcl_Command)procPtr->cmdPtr, parsedParam.paramDefs); +#if 0 + if (!withPublic) { + Tcl_Command_flags((Tcl_Command)procPtr->cmdPtr) |= XOTCL_CMD_PROTECTED_METHOD; + } +#endif + result = ListMethodHandle(interp, object, withPer_object, methodName); + } + } + Tcl_PopCallFrame(interp); + + if (result == TCL_OK && (precondition || postcondition)) { + AssertionAddProc(interp, methodName, aStore, precondition, postcondition); + } + + if (parsedParam.paramDefs) { + DECR_REF_COUNT(ov[2]); + } + DECR_REF_COUNT(ov[3]); + + return result; +} + +static int +MakeMethod(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl, Tcl_Obj *nameObj, + Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition, + int withPublic, int clsns) { + CONST char *argsStr = ObjStr(args), *bodyStr = ObjStr(body), *nameStr = ObjStr(nameObj); + int result; + + if (precondition && !postcondition) { + return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, + "'; when specifying a precondition (", ObjStr(precondition), + ") a postcondition must be specified as well", + (char *) NULL); + } + + /* if both, args and body are empty strings, we delete the method */ + if (*argsStr == 0 && *bodyStr == 0) { + result = cl ? + XOTclRemoveClassMethod(interp, (XOTcl_Class *)cl, nameStr) : + XOTclRemoveObjectMethod(interp, (XOTcl_Object *)object, nameStr); + } else { + XOTclAssertionStore *aStore = NULL; + if (precondition || postcondition) { + if (cl) { + XOTclClassOpt *opt = XOTclRequireClassOpt(cl); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } else { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } + } + result = MakeProc(cl ? cl->nsPtr : object->nsPtr, aStore, + interp, nameObj, args, body, precondition, postcondition, + object, withPublic, cl == NULL, clsns); + } + + if (cl) { + /* could be a filter or filter inheritance ... update filter orders */ + FilterInvalidateObjOrders(interp, cl); + } else { + /* could be a filter => recompute filter order */ + FilterComputeDefined(interp, object); + } + + return result; +} + +static int +getMatchObject(Tcl_Interp *interp, Tcl_Obj *patternObj, Tcl_Obj *origObj, + XOTclObject **matchObject, CONST char **pattern) { + if (patternObj) { + *pattern = ObjStr(patternObj); + if (IsXOTclTclObj(interp, patternObj, matchObject)) { + } else if (patternObj == origObj && **pattern != ':') { + /* no meta chars, but no appropriate xotcl object found, so + return empty; we could check above with noMetaChars(pattern) + as well, but the only remaining case are leading colons and + metachars. */ + return 1; + } + } + return 0; +} + +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); +} + +static int +forwardProcessOptions(Tcl_Interp *interp, Tcl_Obj *nameObj, + Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, + int withObjscope, Tcl_Obj *withOnerror, int withVerbose, + Tcl_Obj *target, int objc, Tcl_Obj * CONST objv[], + ForwardCmdClientData **tcdp) { + ForwardCmdClientData *tcd; + int i, result = 0; + + tcd = NEW(ForwardCmdClientData); + memset(tcd, 0, sizeof(ForwardCmdClientData)); + + if (withDefault) { + Tcl_DString ds, *dsPtr = &ds; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, "%1 {", 4); + Tcl_DStringAppend(dsPtr, ObjStr(withDefault), -1); + Tcl_DStringAppend(dsPtr, "}", 1); + XOTclDeprecatedCmd(interp, "forward option","-default ...", Tcl_DStringValue(dsPtr)); + DSTRING_FREE(dsPtr); + + tcd->subcommands = withDefault; + result = Tcl_ListObjLength(interp, withDefault, &tcd->nr_subcommands); + INCR_REF_COUNT(tcd->subcommands); + } + if (withMethodprefix) { + tcd->prefix = withMethodprefix; + INCR_REF_COUNT(tcd->prefix); + } + if (withOnerror) { + tcd->onerror = withOnerror; + INCR_REF_COUNT(tcd->onerror); + } + tcd->objscope = withObjscope; + tcd->verbose = withVerbose; + tcd->needobjmap = 0; + tcd->cmdName = target; + /*fprintf(stderr, "...forwardprocess objc %d\n", objc);*/ + + for (i=0; ineedobjmap |= (*element == '%' && *(element+1) == '@'); + tcd->hasNonposArgs |= (*element == '%' && *(element+1) == '-'); + 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 = nameObj; + } + + /*fprintf(stderr, "cmdName = %s, args = %s, # = %d\n", + ObjStr(tcd->cmdName), tcd->args?ObjStr(tcd->args):"NULL", tcd->nr_args);*/ + + 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 + */ + CONST char *nameString = ObjStr(tcd->cmdName); + if (!isAbsolutePath(nameString)) { + tcd->cmdName = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); + /*fprintf(stderr, "name %s not absolute, therefore qualifying %s\n", nameObj, + ObjStr(tcd->cmdName));*/ + } + } + INCR_REF_COUNT(tcd->cmdName); + + if (withEarlybinding) { + 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->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc; + + /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/ + if (result == TCL_OK) { + *tcdp = tcd; + } else { + forwardCmdDeleteProc((ClientData)tcd); + } + return result; +} + +static XOTclClasses * +ComputePrecedenceList(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, + int withMixins, int withRootClass) { + XOTclClasses *precedenceList = NULL, *pcl, **npl = &precedenceList; + + if (withMixins) { + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + + if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml = object->mixinOrder; + + while (ml) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (pattern) { + if (!Tcl_StringMatch(className(mixin), pattern)) continue; + } + npl = XOTclClassListAdd(npl, mixin, NULL); + ml = ml->nextPtr; + } + } + } + + pcl = ComputeOrder(object->cl, object->cl->order, Super); + for (; pcl; pcl = pcl->nextPtr) { + if (withRootClass == 0 && pcl->cl->object.flags & XOTCL_IS_ROOT_CLASS) + continue; + + if (pattern) { + if (!Tcl_StringMatch(className(pcl->cl), pattern)) continue; + } + npl = XOTclClassListAdd(npl, pcl->cl, NULL); + } + return precedenceList; +} + +static CONST char * +StripBodyPrefix(CONST char *body) { + if (strncmp(body, "::nsf::unsetUnknownArgs\n", 24) == 0) + body += 24; + return body; +} + + +static XOTclObjects * +computeSlotObjects(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, int withRootClass) { + XOTclObjects *slotObjects = NULL, **npl = &slotObjects; + XOTclClasses *pl, *fullPrecendenceList; + XOTclObject *childObject, *tmpObject; + Tcl_HashTable slotTable; + + assert(object); + + Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", slotTable); + + fullPrecendenceList = ComputePrecedenceList(interp, object, NULL /* pattern*/, 1, withRootClass); + for (pl=fullPrecendenceList; pl; pl = pl->nextPtr) { + Tcl_DString ds, *dsPtr = &ds; + + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(pl->cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + tmpObject = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (tmpObject) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr, *slotEntry; + Tcl_HashTable *cmdTable; + Tcl_Command cmd; + int new; + + if (!tmpObject->nsPtr) continue; + cmdTable = Tcl_Namespace_cmdTable(tmpObject->nsPtr); + + hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + for (; hPtr; 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); + childObject = XOTclGetObjectFromCmdPtr(cmd); + /*fprintf(stderr, "we have true child obj %s\n", objectName(childObject));*/ + npl = XOTclObjectListAdd(npl, childObject); + } + } + DSTRING_FREE(dsPtr); + } + + Tcl_DeleteHashTable(&slotTable); + MEM_COUNT_FREE("Tcl_InitHashTable", slotTable); + + XOTclClassListFree(fullPrecendenceList); + + return slotObjects; +} + +static XOTclClass* +FindCalledClass(Tcl_Interp *interp, XOTclObject *object) { + XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); + CONST char *methodName; + Tcl_Command cmd; + + if (cscPtr->frameType == XOTCL_CSC_TYPE_PLAIN) + return cscPtr->cl; + + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) + methodName = ObjStr(cscPtr->filterStackEntry->calledProc); + else if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && object->mixinStack) + methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); + else + return NULL; + + if (object->nsPtr) { + cmd = FindMethod(object->nsPtr, methodName); + if (cmd) { + /* we called an object specific method */ + return NULL; + } + } + + return SearchCMethod(object->cl, methodName, &cmd); +} + +/* + * Next Primitive Handling + */ +XOTCLINLINE static int +NextSearchMethod(XOTclObject *object, Tcl_Interp *interp, XOTclCallStackContent *cscPtr, + XOTclClass **cl, CONST char **methodName, Tcl_Command *cmd, + int *isMixinEntry, int *isFilterEntry, + int *endOfFilterChain, Tcl_Command *currentCmd) { + int endOfChain = 0, objflags; + + /* + * Next in filters + */ + + objflags = object->flags; /* avoid stalling */ + if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) { + MixinComputeDefined(interp, object); + objflags = object->flags; /* avoid stalling */ + } + + if ((objflags & XOTCL_FILTER_ORDER_VALID) && + object->filterStack && + object->filterStack->currentCmdPtr) { + *cmd = FilterSearchProc(interp, object, currentCmd, cl); + /*fprintf(stderr, "EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ + /* XOTclCallStackDump(interp); XOTclStackDump(interp);*/ + + if (*cmd == 0) { + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /* reset the information to the values of method, cl + to the values they had before calling the filters */ + *methodName = ObjStr(object->filterStack->calledProc); + endOfChain = 1; + *endOfFilterChain = 1; + *cl = 0; + /*fprintf(stderr, "EndOfChain resetting cl\n");*/ + } + } else { + *methodName = (char *) Tcl_GetCommandName(interp, *cmd); + *endOfFilterChain = 0; + *isFilterEntry = 1; + return TCL_OK; + } + } + + /* + * Next in Mixins + */ + assert(objflags & XOTCL_MIXIN_ORDER_VALID); + /* otherwise: MixinComputeDefined(interp, object); */ + + /*fprintf(stderr, "nextsearch: mixinorder valid %d stack=%p\n", + obj->flags & XOTCL_MIXIN_ORDER_VALID, obj->mixinStack);*/ + + if ((objflags & XOTCL_MIXIN_ORDER_VALID) && object->mixinStack) { + int result = MixinSearchProc(interp, object, *methodName, cl, currentCmd, cmd); + if (result != TCL_OK) { + return result; + } + /*fprintf(stderr, "nextsearch: mixinsearch cmd %p, currentCmd %p\n",*cmd, *currentCmd);*/ + if (*cmd == 0) { + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) { + endOfChain = 1; + *cl = 0; + } + } else { + *isMixinEntry = 1; + return TCL_OK; + } + } + + /* + * 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 a mixin or filter chain has ended -> we have to search + the obj-specific methods as well */ + + if (object->nsPtr && endOfChain) { + *cmd = FindMethod(object->nsPtr, *methodName); + } else { + *cmd = NULL; + } + + + if (!*cmd) { + XOTclClasses *pl; +#if 0 + /* a more explicit version, but slower */ + pl = ComputeOrder(object->cl, object->cl->order, Super); + /* if we have a class, skip to the next class in the precedence order */ + if (*cl) { + for (; pl; pl = pl->nextPtr) { + if (pl->cl == *cl) { + pl = pl->nextPtr; + break; + } + } + } +#else + for (pl = ComputeOrder(object->cl, object->cl->order, Super); *cl && pl; pl = pl->nextPtr) { + if (pl->cl == *cl) { + *cl = NULL; + } + } +#endif + + /* + * search for a further class method + */ + *cl = SearchPLMethod(pl, *methodName, cmd); + /*fprintf(stderr, "no cmd, cl = %p %s\n",*cl, className((*cl)));*/ + } else { + *cl = 0; + } + + return TCL_OK; +} + +static int +XOTclNextMethod(XOTclObject *object, Tcl_Interp *interp, XOTclClass *givenCl, + CONST char *givenMethodName, int objc, Tcl_Obj *CONST objv[], + int useCallstackObjs, XOTclCallStackContent *cscPtr) { + Tcl_Command cmd, currentCmd = NULL; + int result, frameType = XOTCL_CSC_TYPE_PLAIN, + isMixinEntry = 0, isFilterEntry = 0, + endOfFilterChain = 0, decrObjv0 = 0; + int nobjc; Tcl_Obj **nobjv; + XOTclClass **cl = &givenCl; + CONST char **methodName = &givenMethodName; + Tcl_CallFrame *framePtr; + + if (!cscPtr) { + cscPtr = CallStackGetTopFrame(interp, &framePtr); + } else { + /* + * cscPtr was given (i.e. it is not yet on the stack. So we cannot + * get objc from the associated stack frame + */ + framePtr = NULL; + assert(useCallstackObjs == 0); + /* fprintf(stderr, "XOTclNextMethod csc given, use %d, framePtr %p\n", useCallstackObjs, framePtr); */ + } + + /*fprintf(stderr, "XOTclNextMethod givenMethod = %s, csc = %p, useCallstackObj %d, objc %d cfp %p\n", + givenMethodName, cscPtr, useCallstackObjs, objc, framePtr);*/ + + /* if no args are given => use args from stack */ + if (objc < 2 && useCallstackObjs && framePtr) { + if (cscPtr->objv) { + nobjv = cscPtr->objv; + nobjc = cscPtr->objc; + } else { + nobjc = Tcl_CallFrame_objc(framePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(framePtr); + } + } 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 && framePtr) { + nobjv[0] = Tcl_CallFrame_objv(framePtr)[0]; + INCR_REF_COUNT(nobjv[0]); /* we seem to need this here */ + decrObjv0 = 1; + } + } + + /* + * Search the next method & compute its method data + */ + result = NextSearchMethod(object, interp, cscPtr, cl, methodName, &cmd, + &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); + if (result != TCL_OK) { + return result; + } + + /* + fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", + *methodName, endOfFilterChain); + + if (obj) + fprintf(stderr, " obj=%s,", objectName(object)); + if ((*cl)) + fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName); + fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n", + isMixinEntry, isFilterEntry, proc); + */ +#if 0 + Tcl_ResetResult(interp); /* needed for bytecode support */ +#endif + if (cmd) { + /* + * change mixin state + */ + if (object->mixinStack) { + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) + cscPtr->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN; + + /* otherwise move the command pointer forward */ + if (isMixinEntry) { + frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + object->mixinStack->currentCmdPtr = currentCmd; + } + } + /* + * change filter state + */ + if (object->filterStack) { + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /*fprintf(stderr, "next changes filter state\n");*/ + cscPtr->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; + object->filterStack->currentCmdPtr = currentCmd; + } + } + + /* + * now actually call the "next" method + */ + + /* cut the flag, that no stdargs should be used, if it is there */ + if (nobjc > 1) { + CONST char *nobjv1 = ObjStr(nobjv[1]); + if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs")) + nobjc = 1; + } + cscPtr->callType |= XOTCL_CSC_CALL_IS_NEXT; + RUNTIME_STATE(interp)->unknown = 0; + /*fprintf(stderr, "setting unknown to 0\n");*/ + result = MethodDispatch((ClientData)object, interp, nobjc, nobjv, cmd, + object, *cl, *methodName, frameType); + cscPtr->callType &= ~XOTCL_CSC_CALL_IS_NEXT; + + if (cscPtr->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER) + cscPtr->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + else if (cscPtr->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN) + cscPtr->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; +} + +int +XOTclNextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); + + if (!cscPtr) + return XOTclVarErrMsg(interp, "next: can't find self", (char *) NULL); + + if (!cscPtr->cmdPtr) + return XOTclErrMsg(interp, "next: no executing proc", TCL_STATIC); + + return XOTclNextMethod(cscPtr->self, interp, cscPtr->cl, + (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr), + objc, objv, 1, NULL); +} + + +/* + * "self" object command + */ + +static int +FindSelfNext(Tcl_Interp *interp) { + XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); + Tcl_Command cmd, currentCmd = 0; + int result, isMixinEntry = 0, + isFilterEntry = 0, + endOfFilterChain = 0; + XOTclClass *cl = cscPtr->cl; + XOTclObject *object = cscPtr->self; + CONST char *methodName; + + Tcl_ResetResult(interp); + + methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); + if (!methodName) { + return TCL_OK; + } + + result = NextSearchMethod(object, interp, cscPtr, &cl, &methodName, &cmd, + &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); + if (cmd) { + Tcl_SetObjResult(interp, MethodHandleObj(cl ? (XOTclObject*)cl : object, + cl == NULL, methodName)); + } + return result; +} + +static Tcl_Obj * +computeLevelObj(Tcl_Interp *interp, CallStackLevel level) { + Tcl_CallFrame *framePtr; + Tcl_Obj *resultObj; + + switch (level) { + case CALLING_LEVEL: XOTclCallStackFindLastInvocation(interp, 1, &framePtr); break; + case ACTIVE_LEVEL: XOTclCallStackFindActiveFrame(interp, 1, &framePtr); break; + default: framePtr = NULL; + } + + if (framePtr) { + /* the call was from an xotcl frame, return absolute frame number */ + char buffer[LONG_AS_STRING]; + int l; + + buffer[0] = '#'; + XOTcl_ltoa(buffer+1, (long)Tcl_CallFrame_level(framePtr), &l); + /*fprintf(stderr, "*** framePtr=%p buffer %s\n", framePtr, buffer);*/ + resultObj = Tcl_NewStringObj(buffer, l+1); + } else { + /* If not called from an xotcl frame, return 1 as default */ + resultObj = Tcl_NewIntObj(1); + } + + return resultObj; +} + +/* + int + 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); + + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +*/ + +/* + * object creation & destruction + */ + +static int +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(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); + } + + 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 *interp, XOTclObject *object) { + int result = TCL_OK; + if (object->opt && object->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);*/ + + result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, 0); + if (result != TCL_OK) { + int result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY); + if (result != TCL_OK) { + Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (unsetInAllNamespaces(interp, nsPtr, object->opt->volatileVarName) == 0) { + fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n", + object->opt->volatileVarName); + } + } + } + if (result == TCL_OK) { + /*fprintf(stderr, "### success unset\n");*/ + } + } + return result; +} + +static char * +XOTclUnsetTrace(ClientData clientData, Tcl_Interp *interp, CONST char *name, CONST char *name2, int flags) +{ + Tcl_Obj *obj = (Tcl_Obj *)clientData; + XOTclObject *object; + char *resultMsg = NULL; + + /*fprintf(stderr, "XOTclUnsetTrace %s flags %.4x %.4x\n", name, flags, + flags & TCL_INTERP_DESTROYED); */ + + if ((flags & TCL_INTERP_DESTROYED) == 0) { + if (GetObjectFromObj(interp, obj, &object) == TCL_OK) { + Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(res); + + /* clear variable, destroy is called from trace */ + if (object->opt && object->opt->volatileVarName) { + object->opt->volatileVarName = NULL; + } + + if (callDestroyMethod(interp, object, 0) != TCL_OK) { + resultMsg = "Destroy for volatile object failed"; + } else + resultMsg = "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);*/ + } + return resultMsg; +} + +/* + * bring an object into a state, as after initialization + */ +static void +CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *object, int softrecreate) { + /*fprintf(stderr, "CleanupDestroyObject obj %p softrecreate %d nsPtr %p\n", + object, softrecreate, object->nsPtr);*/ + + /* remove the instance, but not for ::Class/::Object */ + if ((object->flags & XOTCL_IS_ROOT_CLASS) == 0 && + (object->flags & XOTCL_IS_ROOT_META_CLASS) == 0 ) { + + if (!softrecreate) { + (void)RemoveInstance(object, object->cl); + } + } + + if (object->nsPtr) { + NSCleanupNamespace(interp, object->nsPtr); + NSDeleteChildren(interp, object->nsPtr); + } + + if (object->varTable) { + TclDeleteVars(((Interp *)interp), object->varTable); + + ckfree((char *)object->varTable); + /*FREE(obj->varTable, obj->varTable);*/ + object->varTable = 0; + } + + if (object->opt) { + XOTclObjectOpt *opt = object->opt; + AssertionRemoveStore(opt->assertions); + opt->assertions = NULL; + + if (!softrecreate) { + /* + * Remove this object from all per object mixin lists and clear the mixin list + */ + removeFromObjectMixinsOf(object->id, opt->mixins); + + CmdListRemoveList(&opt->mixins, GuardDel); + CmdListRemoveList(&opt->filters, GuardDel); + FREE(XOTclObjectOpt, opt); + opt = object->opt = 0; + } + } + + object->flags &= ~XOTCL_MIXIN_ORDER_VALID; + if (object->mixinOrder) MixinResetOrder(object); + object->flags &= ~XOTCL_FILTER_ORDER_VALID; + if (object->filterOrder) FilterResetOrder(object); +} + +/* + * do obj initialization & namespace creation + */ +static void +CleanupInitObject(Tcl_Interp *interp, XOTclObject *object, + XOTclClass *cl, Tcl_Namespace *nsPtr, int softrecreate) { + +#ifdef OBJDELETION_TRACE + fprintf(stderr, "+++ CleanupInitObject\n"); +#endif + object->teardown = interp; + object->nsPtr = nsPtr; + if (!softrecreate) { + AddInstance(object, cl); + } + if (object->flags & XOTCL_RECREATE) { + object->opt = 0; + object->varTable = 0; + object->mixinOrder = 0; + object->filterOrder = 0; + object->flags = 0; + } + /* + fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", + obj->cmdName ? objectName(object) : "", object, object->cl);*/ +} + +static void +PrimitiveDestroy(ClientData clientData) { + XOTclObject *object = (XOTclObject*)clientData; + + if (XOTclObjectIsClass(object)) + PrimitiveCDestroy((ClientData) object); + else + PrimitiveODestroy((ClientData) object); +} + +static void +tclDeletesObject(ClientData clientData) { + XOTclObject *object = (XOTclObject*)clientData; + Tcl_Interp *interp; + + object->flags |= XOTCL_TCL_DELETE; + /*fprintf(stderr, "cmd dealloc %p tclDeletesObject (2d)\n", object->id, Tcl_Command_refCount(object->id)); + */ + +#ifdef OBJDELETION_TRACE + fprintf(stderr, "tclDeletesObject %p obj->id %p flags %.6x\n", object, object->id, object->flags); +#endif + if ((object->flags & XOTCL_DURING_DELETE) || !object->teardown) return; + interp = object->teardown; +# ifdef OBJDELETION_TRACE + fprintf(stderr, "... %p %s\n", object, objectName(object)); +# endif + CallStackDestroyObject(interp, object); + /*fprintf(stderr, "tclDeletesObject %p DONE\n", object);*/ +} + +/* + * physical object destroy + */ +static void +PrimitiveODestroy(ClientData clientData) { + XOTclObject *object = (XOTclObject*)clientData; + Tcl_Interp *interp; + + if (!object || !object->teardown) return; + + /*fprintf(stderr, "****** PrimitiveODestroy %p flags %.6x\n", object, object->flags);*/ + assert(!(object->flags & XOTCL_DELETED)); + + /* destroy must have been called already */ + assert(object->flags & XOTCL_DESTROY_CALLED); + + /* + * check and latch against recurrent calls with object->teardown + */ + PRINTOBJ("PrimitiveODestroy", object); + interp = object->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; + +#ifdef OBJDELETION_TRACE + fprintf(stderr, " physical delete of %p id=%p destroyCalled=%d '%s'\n", + object, object->id, (object->flags & XOTCL_DESTROY_CALLED), objectName(object)); +#endif + CleanupDestroyObject(interp, object, 0); + + while (object->mixinStack) + MixinStackPop(object); + + while (object->filterStack) + FilterStackPop(object); + + object->teardown = NULL; + if (object->nsPtr) { + /*fprintf(stderr, "PrimitiveODestroy calls deleteNamespace for object %p nsPtr %p\n", object, object->nsPtr);*/ + XOTcl_DeleteNamespace(interp, object->nsPtr); + object->nsPtr = NULL; + } + + /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", objectName(object));*/ + + object->flags |= XOTCL_DELETED; + objTrace("ODestroy", object); + + DECR_REF_COUNT(object->cmdName); + XOTclCleanupObject(object); + +} + +/* + * reset the object to a fresh, undestroyed state + */ +static void +MarkUndestroyed(XOTclObject *object) { + object->flags &= ~XOTCL_DESTROY_CALLED; +} + +static void +PrimitiveOInit(void *mem, Tcl_Interp *interp, CONST char *name, XOTclClass *cl) { + XOTclObject *object = (XOTclObject*)mem; + Tcl_Namespace *nsPtr; + +#ifdef OBJDELETION_TRACE + fprintf(stderr, "+++ PrimitiveOInit\n"); +#endif + +#ifdef XOTCLOBJ_TRACE + fprintf(stderr, "OINIT %s = %p\n", name, object); +#endif + XOTclObjectRefCountIncr(object); + MarkUndestroyed(object); + + /* + * There might be already a namespace with name name; if this is the + * case, use this namepsace as object namespace. The preexisting + * namespace might contain XOTcl objects. If we would not use the + * namespace as child namespace, we would not recognize the objects + * as child objects, deletions of the object might lead to a crash. + */ + + nsPtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + /*fprintf(stderr, "PrimitiveOInit %p %s, ns %p\n", object, name, nsPtr); */ + + CleanupInitObject(interp, object, cl, nsPtr, 0); + + /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/ + object->mixinStack = NULL; + object->filterStack = NULL; +} + +/* + * Object creation: create object name (full name) and Tcl command + */ +static XOTclObject* +PrimitiveOCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTclClass *cl) { + XOTclObject *object = (XOTclObject*)ckalloc(sizeof(XOTclObject)); + CONST char *nameString = ObjStr(nameObj); + size_t length; + +#if defined(XOTCLOBJ_TRACE) + fprintf(stderr, "CKALLOC Object %p %s\n", object, nameString); +#endif +#ifdef OBJDELETION_TRACE + fprintf(stderr, "+++ PrimitiveOCreate\n"); +#endif + + memset(object, 0, sizeof(XOTclObject)); + MEM_COUNT_ALLOC("XOTclObject/XOTclClass", object); + assert(object); /* ckalloc panics, if malloc fails */ + assert(isAbsolutePath(nameString)); + length = strlen(nameString); + if (!NSCheckForParent(interp, nameString, length, cl)) { + ckfree((char *) object); + return NULL; + } + + object->id = Tcl_CreateObjCommand(interp, nameString, XOTclObjDispatch, + (ClientData)object, tclDeletesObject); + /*fprintf(stderr, "cmd alloc %p %d (%s)\n", object->id, Tcl_Command_refCount(object->id), nameString);*/ + + PrimitiveOInit(object, interp, nameString, cl); + object->cmdName = nameObj; + /* convert cmdName to Tcl Obj of type cmdName */ + /*Tcl_GetCommandFromObj(interp, obj->cmdName);*/ + + INCR_REF_COUNT(object->cmdName); + objTrace("PrimitiveOCreate", object); + + return object; +} + +static XOTclClass * +DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, int isMeta) { + XOTclClass *defaultClass = NULL; + + /*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s, isMeta %d\n", + className(cl), className(mcl), isMeta );*/ + + if (mcl) { + int result; + result = setInstVar(interp, (XOTclObject *)mcl, isMeta ? + XOTclGlobalObjs[XOTE_DEFAULTMETACLASS] : + XOTclGlobalObjs[XOTE_DEFAULTSUPERCLASS], NULL); + + if (result == TCL_OK) { + Tcl_Obj *nameObj = Tcl_GetObjResult(interp); + if (GetClassFromObj(interp, nameObj, &defaultClass, NULL) != TCL_OK) { + XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); + } + /*fprintf(stderr, "DefaultSuperClass for %s got from var %s\n", className(cl), ObjStr(nameObj));*/ + + } else { + XOTclClass *result; + XOTclClasses *sc; + + /*fprintf(stderr, "DefaultSuperClass for %s: search in superclasses starting with %p meta %d\n", + className(cl), cl->super, isMeta);*/ + + /* + * check superclasses of metaclass + */ + if (isMeta) { + /*fprintf(stderr, " ... is %s already root meta %d\n", + className(mcl->object.cl), + mcl->object.cl->object.flags & XOTCL_IS_ROOT_META_CLASS);*/ + if (mcl->object.cl->object.flags & XOTCL_IS_ROOT_META_CLASS) { + return mcl->object.cl; + } + } + for (sc = mcl->super; sc && sc->cl != cl; sc = sc->nextPtr) { + /*fprintf(stderr, " ... check ismeta %d %s root mcl %d root cl %d\n", + isMeta, className(sc->cl), + sc->cl->object.flags & XOTCL_IS_ROOT_META_CLASS, + sc->cl->object.flags & XOTCL_IS_ROOT_CLASS);*/ + if (isMeta) { + if (sc->cl->object.flags & XOTCL_IS_ROOT_META_CLASS) { + return sc->cl; + } + } else { + if (sc->cl->object.flags & XOTCL_IS_ROOT_CLASS) { + /*fprintf(stderr, "found root class %p\n", sc->cl);*/ + return sc->cl; + } + } + result = DefaultSuperClass(interp, cl, sc->cl, isMeta); + if (result) { + return result; + } + } + } + } else { + /* during bootstrapping, there might be no meta class defined yet */ + /*fprintf(stderr, "no meta class ismeta %d %s root mcl %d root cl %d\n", + isMeta, className(cl), + cl->object.flags & XOTCL_IS_ROOT_META_CLASS, + cl->object.flags & XOTCL_IS_ROOT_CLASS + );*/ + return NULL; + } + 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, int recreate) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + XOTclClassOpt *clopt = cl->opt; + XOTclClass *baseClass = NULL; + + PRINTOBJ("CleanupDestroyClass", (XOTclObject *)cl); + assert(softrecreate ? recreate == 1 : 1); + + /* fprintf(stderr, "CleanupDestroyClass %p %s (ismeta=%d) softrecreate=%d, recreate=%d, %p\n", cl,className(cl),IsMetaClass(interp, cl, 1), + softrecreate, recreate, clopt);*/ + + /* + * Perform the next steps even with clopt == NULL, since the class + * might be used as a superclass of a per object mixin, so it might + * have no clopt... + */ + MixinInvalidateObjOrders(interp, cl); + FilterInvalidateObjOrders(interp, cl); + + if (clopt) { + /* + * Remove this class from all isClassMixinOf lists and clear the + * class mixin list + */ + RemoveFromClassMixinsOf(clopt->id, clopt->classmixins); + + CmdListRemoveList(&clopt->classmixins, GuardDel); + /*MixinInvalidateObjOrders(interp, cl);*/ + + CmdListRemoveList(&clopt->classfilters, GuardDel); + /*FilterInvalidateObjOrders(interp, cl);*/ + + 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 class mixin lists and clear the + * isClassMixinOf list + */ + RemoveFromClassmixins(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 NSF_OBJECTDATA + XOTclFreeObjectData(cl); +#endif + } + + NSCleanupNamespace(interp, cl->nsPtr); + NSDeleteChildren(interp, cl->nsPtr); + + /*fprintf(stderr, " CleanupDestroyClass softrecreate %d\n", softrecreate);*/ + + if (!softrecreate) { + + /* + * Reclass all instances of the current class the the appropriate + * most general class ("baseClass"). The most general class of a + * metaclass is the root meta class, the most general class of an + * object is the root class. Instances of metaclasses can be only + * reset to the root meta class (and not to to the root base + * class). + */ + + baseClass = DefaultSuperClass(interp, cl, cl->object.cl, + IsMetaClass(interp, cl, 1)); + /* + * We do not have to reclassing in case, cl is a root class + */ + if ((cl->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { + + hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); + /*fprintf(stderr, " inst %p %s flags %.6x id %p baseClass %p %s\n", + inst, objectName(inst), inst->flags, inst->id,baseClass,className(baseClass));*/ + if (inst && inst != (XOTclObject*)cl && !(inst->flags & XOTCL_DURING_DELETE) /*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); + } + + if ((clopt) && (!recreate)) { + FREE(XOTclClassOpt, clopt); + clopt = cl->opt = 0; + } + + /* + * 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->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { + /* fprintf(stderr,"subClass %p %s baseClass %p %s\n", + cl,className(cl),baseClass,className(baseClass)); */ + AddSuper(subClass, baseClass); + } + } + /*(void)RemoveSuper(cl, cl->super->cl);*/ + } + +} + +/* + * do class initialization & namespace creation + */ +static void +CleanupInitClass(Tcl_Interp *interp, XOTclClass *cl, Tcl_Namespace *nsPtr, + int softrecreate, int recreate) { + XOTclClass *defaultSuperclass; + + assert(softrecreate ? recreate == 1 : 1); + +#ifdef OBJDELETION_TRACE + 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((XOTclObject*)cl); + + cl->nsPtr = nsPtr; + + 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, 0); + if (cl != defaultSuperclass) { + AddSuper(cl, defaultSuperclass); + } + + cl->color = WHITE; + cl->order = NULL; + + if (!softrecreate) { + Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", &cl->instances); + } + + if (!recreate) { + cl->opt = NULL; + } +} + +/* + * class physical destruction + */ +static void +PrimitiveCDestroy(ClientData clientData) { + XOTclClass *cl = (XOTclClass*)clientData; + XOTclObject *object = (XOTclObject*)clientData; + Tcl_Interp *interp; + Tcl_Namespace *saved; + + PRINTOBJ("PrimitiveCDestroy", object); + + /* + * check and latch against recurrent calls with obj->teardown + */ + if (!object || !object->teardown) return; + interp = object->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; + + /* + * call and latch user destroy with object->id if we haven't + */ + /*fprintf(stderr, "PrimitiveCDestroy %s flags %.6x\n", objectName(object), object->flags);*/ + + object->teardown = NULL; + CleanupDestroyClass(interp, cl, 0, 0); + + /* + * handoff the primitive teardown + */ + + saved = cl->nsPtr; + object->teardown = interp; + + /* + * class object destroy + physical destroy + */ + /*fprintf(stderr, "primitive cdestroy %p %.6x calls primitive odestroy\n", cl, flags);*/ + PrimitiveODestroy(clientData); + + /*fprintf(stderr, "primitive cdestroy calls deletenamespace for obj %p, nsPtr %p flags %.6x\n", + cl, saved, ((Namespace *)saved)->flags);*/ + saved->clientData = NULL; + XOTcl_DeleteNamespace(interp, saved); + /*fprintf(stderr, "primitive cdestroy %p DONE\n",cl);*/ + return; +} + +/* + * class init + */ +static void +PrimitiveCInit(XOTclClass *cl, Tcl_Interp *interp, CONST char *name) { + Tcl_CallFrame frame, *framePtr = &frame; + Tcl_Namespace *nsPtr; + + /* + * 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; + } + nsPtr = NSGetFreshNamespace(interp, (ClientData)cl, name, 1); + Tcl_PopCallFrame(interp); + + CleanupInitClass(interp, cl, nsPtr, 0, 0); + return; +} + +/* + * class create: creation of namespace + class full name + * calls class object creation + */ +static XOTclClass* +PrimitiveCCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTclClass *class) { + XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass)); + CONST char *nameString = ObjStr(nameObj); + size_t length; + XOTclObject *object = (XOTclObject*)cl; + + /*fprintf(stderr, "CKALLOC Class %p %s\n", cl, nameString);*/ + + memset(cl, 0, sizeof(XOTclClass)); + MEM_COUNT_ALLOC("XOTclObject/XOTclClass", cl); + + /* pass object system from meta class */ + if (class) { + cl->osPtr = class->osPtr; + } + + assert(isAbsolutePath(nameString)); + length = strlen(nameString); + /* + fprintf(stderr, "Class alloc %p '%s'\n", cl, nameString); + */ + /* check whether Object parent NS already exists, + otherwise: error */ + if (!NSCheckForParent(interp, nameString, length, class)) { + ckfree((char *) cl); + return 0; + } + object->id = Tcl_CreateObjCommand(interp, nameString, XOTclObjDispatch, + (ClientData)cl, tclDeletesObject); + /*fprintf(stderr, "cmd alloc %p %d (%s) cl\n", object->id, Tcl_Command_refCount(object->id), nameString);*/ + + PrimitiveOInit(object, interp, nameString, class); + object->cmdName = nameObj; + + /* convert cmdName to Tcl Obj of type cmdName */ + /* Tcl_GetCommandFromObj(interp, obj->cmdName);*/ + + INCR_REF_COUNT(object->cmdName); + PrimitiveCInit(cl, interp, nameString+2); + + objTrace("PrimitiveCCreate", object); + return cl; +} + +/* change XOTcl class conditionally; obj must not be NULL */ + +XOTCLINLINE static int +changeClass(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl) { + assert(object); + + /*fprintf(stderr, "changing %s to class %s ismeta %d\n", + objectName(object), + className(cl), + IsMetaClass(interp, cl, 1));*/ + + if (cl != object->cl) { + if (IsMetaClass(interp, cl, 1)) { + /* 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, object->cl, 1)) { + 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 */ + + /*fprintf(stderr, "target class %s not a meta class, am i a class %d\n", + className(cl), + XOTclObjectIsClass(object) );*/ + + if (XOTclObjectIsClass(object)) { + return XOTclVarErrMsg(interp, "cannot turn class into an object ", + (char *) NULL); + } + } + (void)RemoveInstance(object, object->cl); + AddInstance(object, cl); + + MixinComputeDefined(interp, object); + FilterComputeDefined(interp, object); + } + return TCL_OK; +} + + +/* + * Std object initialization: + * call parameter default values + * apply "-" methods (call "configure" with given arguments) + * call constructor "init", if it was not called before + */ +static int +doObjInitialization(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Obj *methodObj, *savedObjResult = Tcl_GetObjResult(interp); /* save the result */ + int result; + + INCR_REF_COUNT(savedObjResult); + /* + * clear INIT_CALLED flag + */ + object->flags &= ~XOTCL_INIT_CALLED; + + /* + * call configure methods (starting with '-') + */ + if (CallDirectly(interp, object, XO_o_configure_idx, &methodObj)) { + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); + memcpy(tov+1, objv+2, sizeof(Tcl_Obj *)*(objc-2)); + /* the provided name of the method is just for error reporting */ + tov[0] = methodObj ? methodObj : XOTclGlobalObjs[XOTE_CONFIGURE]; + result = XOTclOConfigureMethod(interp, object, objc-1, tov); + FREE_ON_STACK(Tcl_Obj*, tov); + } else { + result = callMethod((ClientData) object, interp, methodObj, objc, objv+2, 0); + } + + if (result != TCL_OK) { + goto objinitexit; + } + + /* + * check, whether init was called already + */ + if (!(object->flags & XOTCL_INIT_CALLED)) { + int nobjc = 0; + Tcl_Obj **nobjv, *resultObj = Tcl_GetObjResult(interp); + + /* + * Call the scripted constructor and pass the result of + * configure to it as arguments + */ + INCR_REF_COUNT(resultObj); + Tcl_ListObjGetElements(interp, resultObj, &nobjc, &nobjv); + /* CallDirectly does not make much sense, since init is already + defined in predefined */ + methodObj = XOTclMethodObj(interp, object, XO_o_init_idx); + if (methodObj) { + result = callMethod((ClientData) object, interp, methodObj, + nobjc+2, nobjv, XOTCL_CM_NO_PROTECT); + } + object->flags |= XOTCL_INIT_CALLED; + DECR_REF_COUNT(resultObj); + } + + if (result == TCL_OK) { + Tcl_SetObjResult(interp, savedObjResult); + } + objinitexit: + DECR_REF_COUNT(savedObjResult); + return result; +} + + +static int +hasMetaProperty(Tcl_Interp *interp, XOTclClass *cl) { + return cl->object.flags & XOTCL_IS_ROOT_META_CLASS; +} + +static int +IsBaseClass(XOTclClass *cl) { + return cl->object.flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS); +} + + +static int +IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins) { + /* check if class is a meta-class */ + XOTclClasses *pl, *checkList = NULL, *mixinClasses = NULL, *mc; + int hasMCM = 0; + + /* is the class the most general meta-class? */ + if (hasMetaProperty(interp, cl)) + return 1; + + /* is the class a subclass of a meta-class? */ + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + if (hasMetaProperty(interp, pl->cl)) + return 1; + } + + if (withMixins) { + /* has the class metaclass mixed in? */ + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *clopt = pl->cl->opt; + if (clopt && clopt->classmixins) { + MixinComputeOrderFullList(interp, + &clopt->classmixins, + &mixinClasses, + &checkList, 0); + } + } + + for (mc=mixinClasses; mc; mc = mc->nextPtr) { + if (IsMetaClass(interp, mc->cl, 0)) { + hasMCM = 1; + break; + } + } + XOTclClassListFree(mixinClasses); + XOTclClassListFree(checkList); + /*fprintf(stderr, "has MC returns %d, mixinClasses = %p\n", + hasMCM, mixinClasses);*/ + } + + return hasMCM; +} + +static int +IsSubType(XOTclClass *subcl, XOTclClass *cl) { + 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; + } + } + } + return success; +} + +static int +HasMixin(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl) { + + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + + if ((object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + XOTclCmdList *ml; + for (ml = object->mixinOrder; ml; ml = ml->nextPtr) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin == cl) { + return 1; + } + } + } + return 0; +} + +extern int +XOTclCreateObject(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTcl_Class *class) { + XOTclClass *cl = (XOTclClass*) class; + Tcl_Obj *methodObj; + int result; + + INCR_REF_COUNT(nameObj); + + if (CallDirectly(interp, &cl->object, XO_c_create_idx, &methodObj)) { + result = XOTclCCreateMethod(interp, cl, ObjStr(nameObj), 1, &nameObj); + } else { + result = XOTclCallMethodWithArgs((ClientData)cl, interp, methodObj, + nameObj, 1, 0, 0); + } + DECR_REF_COUNT(nameObj); + return result; +} + +extern int +XOTclCreate(Tcl_Interp *interp, XOTcl_Class *class, Tcl_Obj *nameObj, ClientData clientData, + int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = (XOTclClass *) class; + int result; + ALLOC_ON_STACK(Tcl_Obj *, objc+2, ov); + + INCR_REF_COUNT(nameObj); + + ov[0] = NULL; + ov[1] = nameObj; + if (objc>0) { + memcpy(ov+2, objv, sizeof(Tcl_Obj *)*objc); + } + result = XOTclCCreateMethod(interp, cl, ObjStr(nameObj), objc+2, ov); + + FREE_ON_STACK(Tcl_Obj*, ov); + DECR_REF_COUNT(nameObj); + + return result; +} + +int +XOTclDeleteObject(Tcl_Interp *interp, XOTcl_Object *object1) { + XOTclObject *object = (XOTclObject *) object1; + return callDestroyMethod(interp, object, 0); +} + +extern int +XOTclUnsetInstVar2(XOTcl_Object *object1, Tcl_Interp *interp, + CONST char *name1, CONST char *name2, + int flgs) { + XOTclObject *object = (XOTclObject *) object1; + int result; + Tcl_CallFrame frame, *framePtr = &frame; + + XOTcl_PushFrameObj(interp, object, framePtr); + if (object->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; + + result = Tcl_UnsetVar2(interp, name1, name2, flgs); + XOTcl_PopFrameObj(interp, framePtr); + return result; +} + +static int +GetInstVarIntoCurrentScope(Tcl_Interp *interp, const char *cmdName, XOTclObject *object, + Tcl_Obj *varName, Tcl_Obj *newName) { + Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; + int new = 0, flgs = TCL_LEAVE_ERR_MSG; + Tcl_CallFrame *varFramePtr; + Tcl_CallFrame frame, *framePtr = &frame; + char *varNameString; + + if (CheckVarName(interp, ObjStr(varName)) != TCL_OK) { + return TCL_ERROR; + } + + XOTcl_PushFrameObj(interp, object, framePtr); + if (object->nsPtr) { + flgs = flgs|TCL_NAMESPACE_ONLY; + } + + otherPtr = TclObjLookupVar(interp, varName, NULL, flgs, "define", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + XOTcl_PopFrameObj(interp, framePtr); + + if (otherPtr == NULL) { + return XOTclVarErrMsg(interp, "can't import variable ", ObjStr(varName), + " into method scope: can't find variable on ", objectName(object), + (char *) NULL); + } + + /* + * if newName == NULL -> there is no alias, use varName + * as target link name + */ + 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 instance variable ", ObjStr(varName), + " on ", objectName(object), + ": Variable cannot be an element in an array;", + " use e.g. an alias.", (char *) NULL); + } + + newName = varName; + } + varNameString = ObjStr(newName); + + + + 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 && (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_PROC)) { + varPtr = (Var *)CompiledLocalsLookup((CallFrame *)varFramePtr, varNameString); + + if (varPtr == NULL) { + /* look in frame's local var hashtable */ + TclVarHashTable *varTablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); + + if (varTablePtr == NULL) { + /* + * The variable table does not exist. This seems to be is the + * first access to a variable on this frame. We create the and + * initialize the variable hash table and update the object + */ + /*fprintf(stderr, "+++ create varTable in GetInstVarIntoCurrentScope\n");*/ + Tcl_CallFrame_varTablePtr(varFramePtr) = varTablePtr = VarHashTableCreate(); + } + varPtr = VarHashCreateVar(varTablePtr, 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; + } + + /*fprintf(stderr, "linkvar flags=%x\n", linkPtr->flags); + Tcl_Panic("new linkvar %s... When does this happen?", ObjStr(newName), 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)) { + TclCleanupVar(linkPtr, (Var *) NULL); + } + + } else if (!TclIsVarUndefined(varPtr)) { + return XOTclVarErrMsg(interp, "variable '", varNameString, + "' exists already", (char *) NULL); + } else if (TclIsVarTraced(varPtr)) { + return XOTclVarErrMsg(interp, "variable '", varNameString, + "' has traces: can't use for instvar", (char *) NULL); + } + } + + TclSetVarLink(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.linkPtr = otherPtr; + VarHashRefCount(otherPtr)++; + + /* fprintf(stderr, "defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n", + ObjStr(newName), objectName(object), + 0, + varPtr->flags, + TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr)); + */ + } else { + return XOTclVarErrMsg(interp, cmdName, + " cannot import variable '", varNameString, + "' into method scope; not called from a method frame", (char *) NULL); + } + return TCL_OK; +} + +extern int +XOTclRemoveObjectMethod(Tcl_Interp *interp, XOTcl_Object *object1, CONST char *methodName) { + XOTclObject *object = (XOTclObject*) object1; + + AliasDelete(interp, object->cmdName, methodName, 1); + + if (object->opt) + AssertionRemoveProc(object->opt->assertions, methodName); + + if (object->nsPtr) { + int rc = NSDeleteCmd(interp, object->nsPtr, methodName); + if (rc < 0) + return XOTclVarErrMsg(interp, objectName(object), " cannot delete method '", methodName, + "' of object ", objectName(object), (char *) NULL); + } + return TCL_OK; +} + +extern int +XOTclRemoveClassMethod(Tcl_Interp *interp, XOTcl_Class *class, CONST char *methodName) { + XOTclClass *cl = (XOTclClass*) class; + XOTclClassOpt *opt = cl->opt; + int rc; + + AliasDelete(interp, class->object.cmdName, methodName, 0); + + if (opt && opt->assertions) + AssertionRemoveProc(opt->assertions, methodName); + + rc = NSDeleteCmd(interp, cl->nsPtr, methodName); + if (rc < 0) + return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", methodName, + "' of class ", className(cl), (char *) NULL); + return TCL_OK; +} + +/* + * obj/cl ClientData setter/getter + */ +extern void +XOTclSetObjClientData(XOTcl_Object *object1, ClientData data) { + XOTclObject *object = (XOTclObject*) object1; + XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); + opt->clientData = data; +} +extern ClientData +XOTclGetObjClientData(XOTcl_Object *object1) { + XOTclObject *object = (XOTclObject*) object1; + return (object && object->opt) ? object->opt->clientData : 0; +} +extern void +XOTclSetClassClientData(XOTcl_Class *cli, 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; +} + +static int +setInstVar(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj) { + Tcl_Obj *result; + int flags = (object->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; + Tcl_CallFrame frame, *framePtr = &frame; + XOTcl_PushFrameObj(interp, object, framePtr); + + if (valueObj == NULL) { + result = Tcl_ObjGetVar2(interp, nameObj, NULL, flags); + } else { + /*fprintf(stderr, "setvar in obj %s: name %s = %s\n", objectName(object), ObjStr(nameObj), ObjStr(value));*/ + result = Tcl_ObjSetVar2(interp, nameObj, NULL, valueObj, flags); + } + XOTcl_PopFrameObj(interp, framePtr); + + if (result) { + Tcl_SetObjResult(interp, result); + return TCL_OK; + } + return TCL_ERROR; +} + +static int +XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + SetterCmdClientData *cd = (SetterCmdClientData*)clientData; + XOTclObject *object = cd->object; + + if (!object) return XOTclObjErrType(interp, objv[0], "object", ObjStr(objv[0])); + if (objc > 2) return XOTclObjErrArgCnt(interp, object->cmdName, objv[0], "?value?"); + + if (cd->paramsPtr && objc == 2) { + Tcl_Obj *outObjPtr; + int result, flags = 0; + ClientData checkedData; + + result = ArgumentCheck(interp, objv[1], cd->paramsPtr, + RUNTIME_STATE(interp)->doCheckArguments, + &flags, &checkedData, &outObjPtr); + + if (result == TCL_OK) { + result = setInstVar(interp, object, objv[0], outObjPtr); + + if (flags & XOTCL_PC_MUST_DECR) { + DECR_REF_COUNT(outObjPtr); + } + } + return result; + + } else { + return setInstVar(interp, object, objv[0], objc == 2 ? objv[1] : NULL); + } +} + +static int +forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + Tcl_Obj *forwardArgObj, ForwardCmdClientData *tcd, Tcl_Obj **out, + Tcl_Obj **freeList, int *inputArg, int *mapvalue, + int firstPosArg, int *outputincr) { + CONST char *forwardArgString = ObjStr(forwardArgObj), *p; + int totalargs = objc + tcd->nr_args - 1; + char c = *forwardArgString, c1; + + /* per default every forwardArgString from the processed list corresponds to exactly + one forwardArgString in the computed final list */ + *outputincr = 1; + p = forwardArgString; + + /*fprintf(stderr, "ForwardArg: processing '%s'\n", forwardArgString);*/ + + if (c == '%' && *(forwardArgString+1) == '@') { + char *remainder = NULL; + long pos; + forwardArgString += 2; + pos = strtol(forwardArgString, &remainder, 0); + /*fprintf(stderr, "strtol('%s) returned %ld '%s'\n", forwardArgString, pos, remainder);*/ + if (forwardArgString == remainder && *forwardArgString == 'e' + && !strncmp(forwardArgString, "end", 3)) { + pos = -1; + remainder += 3; + } else if (pos < 0) { + pos --; + } + if (forwardArgString == remainder || abs(pos) > totalargs) { + return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", + ObjStr(forwardArgObj), (char *) NULL); + } if (!remainder || *remainder != ' ') { + return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(forwardArgObj), + "' use: %@ ", (char *) NULL); + } + + forwardArgString = ++remainder; + /* in case we address from the end, we reduct further to distinguish from -1 (void) */ + if (pos<0) pos--; + /*fprintf(stderr, "remainder = '%s' pos = %ld\n", remainder, pos);*/ + *mapvalue = pos; + forwardArgString = remainder; + c = *forwardArgString; + } + + if (c == '%') { + Tcl_Obj *list = NULL, **listElements; + int nrArgs = objc-1, nrPosArgs = objc-firstPosArg, nrElements = 0; + char *firstActualArgument = nrArgs>0 ? ObjStr(objv[1]) : NULL; + c = *++forwardArgString; + c1 = *(forwardArgString+1); + + if (c == 's' && !strcmp(forwardArgString, "self")) { + *out = tcd->object->cmdName; + } else if (c == 'p' && !strcmp(forwardArgString, "proc")) { + CONST char *methodName = ObjStr(objv[0]); + /* if we dispatch a method via ".", we do not want to see the + "." in the %proc, e.g. for the interceptor slots (such as + .mixin, ... */ + if (FOR_COLON_RESOLVER(methodName)) { + *out = Tcl_NewStringObj(methodName + 1, -1); + } else { + *out = objv[0]; + } + } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { + + if (c1 != '\0') { + if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 must be followed by a valid list, given: '", + ObjStr(forwardArgObj), "'", (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); + } + } + /*fprintf(stderr, "nrElements=%d, nra=%d firstPos %d objc %d\n", + nrElements, nrArgs, firstPosArg, objc);*/ + + if (nrElements > nrPosArgs) { + /* insert default subcommand depending on number of arguments */ + /*fprintf(stderr, "inserting listElements[%d] '%s'\n", nrPosArgs, + ObjStr(listElements[nrPosArgs]));*/ + *out = listElements[nrPosArgs]; + } else if (objc<=1) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, "option"); + } else { + /*fprintf(stderr, "copying %%1: '%s'\n", ObjStr(objv[firstPosArg]));*/ + *out = objv[firstPosArg]; + *inputArg = firstPosArg+1; + } + } else if (c == '-') { + CONST char *firstElementString; + int i, insertRequired, done = 0; + + /*fprintf(stderr, "process flag '%s'\n", firstActualArgument);*/ + if (Tcl_ListObjGetElements(interp, forwardArgObj, &nrElements, &listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: '", forwardArgString, "' is not a valid list", + (char *) NULL); + } + if (nrElements < 1 || nrElements > 2) { + return XOTclVarErrMsg(interp, "forward: '", forwardArgString, + "' must contain 1 or 2 arguments", + (char *) NULL); + } + firstElementString = ObjStr(listElements[0]); + firstElementString++; /* we skip the dash */ + + if (firstActualArgument && *firstActualArgument == '-') { + /*fprintf(stderr, "we have a flag in first argument '%s'\n", firstActualArgument);*/ + + for (i = 1; i < firstPosArg; i++) { + if (strcmp(firstElementString, ObjStr(objv[i])) == 0) { + /*fprintf(stderr, "We have a MATCH for '%s' oldInputArg %d\n", forwardArgString, *inputArg);*/ + *out = objv[i]; + /* %1 will start at a different place. Proceed if necessary to firstPosArg */ + if (*inputArg < firstPosArg) { + *inputArg = firstPosArg; + } + done = 1; + break; + } + } + } + + if (!done) { + /* We have a flag in the actual arguments that does not match. + * We proceed to the actual arguments without dashes. + */ + if (*inputArg < firstPosArg) { + *inputArg = firstPosArg; + } + /* + * If the user requested we output the argument also when not + * given in the argument list. + */ + if (nrElements == 2 + && Tcl_GetIntFromObj(interp, listElements[1], &insertRequired) == TCL_OK + && insertRequired) { + /* no match, but insert of flag is required */ + /*fprintf(stderr, "no match, but insert of %s required\n", firstElementString);*/ + *out = Tcl_NewStringObj(firstElementString, -1); + *outputincr = 1; + goto add_to_freelist; + } else { + /* no match, no insert of flag required, we skip the + * forwarder option and output nothing + */ + /*fprintf(stderr, "no match, nrElements %d insert req %d\n", nrElements, insertRequired);*/ + *outputincr = 0; + } + } + + } else if (c == 'a' && !strncmp(forwardArgString, "argcl", 4)) { + if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '", + forwardArgString, "'", (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 ", + forwardArgString, (char *) NULL); + } + *out = listElements[nrArgs]; + } else if (c == '%') { + Tcl_Obj *newarg = Tcl_NewStringObj(forwardArgString, -1); + *out = newarg; + goto add_to_freelist; + } else { + /* evaluating given command */ + int result; + /*fprintf(stderr, "evaluating '%s'\n", forwardArgString);*/ + if ((result = Tcl_EvalEx(interp, forwardArgString, -1, 0)) != TCL_OK) + return result; + *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + /*fprintf(stderr, "result = '%s'\n", ObjStr(*out));*/ + goto add_to_freelist; + } + } else { + if (p == forwardArgString) + *out = forwardArgObj; + else { + Tcl_Obj *newarg = Tcl_NewStringObj(forwardArgString, -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; +} + + +static int +callForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + ClientData clientData; + int result; + XOTclObject *object = tcd->object; + Tcl_CallFrame frame, *framePtr = &frame; + + if (tcd->verbose) { + Tcl_Obj *cmd = Tcl_NewListObj(objc, objv); + fprintf(stderr, "forwarder calls '%s'\n", ObjStr(cmd)); + DECR_REF_COUNT(cmd); + } + if (tcd->objscope) { + XOTcl_PushFrameObj(interp, object, framePtr); + } + if (tcd->objProc) { +#if 1 || !defined(NRE) + result = (*tcd->objProc)(tcd->clientData, interp, objc, objv); +#else + result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv); +#endif + } else if (IsXOTclTclObj(interp, tcd->cmdName, (XOTclObject**)&clientData)) { + /*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_PopFrameObj(interp, framePtr); + } + 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->object) return XOTclObjErrType(interp, objv[0], "object", ""); + + 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); + } 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(Tcl_Obj *, ov); + return result; + } else { + Tcl_Obj **ov, *freeList=NULL; + int outputincr, firstPosArg=1, totalargs = objc + tcd->nr_args + 3; + ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV); + ALLOC_ON_STACK(int, totalargs, objvmap); + /*fprintf(stderr, "+++ forwardMethod standard case, allocated %d args\n", totalargs);*/ + + ov = &OV[1]; + if (tcd->needobjmap) { + memset(objvmap, -1, sizeof(int)*totalargs); + } + + /* the first argument is always the command, to which we forward */ + if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd, + &ov[outputArg], &freeList, &inputArg, + &objvmap[outputArg], + firstPosArg, &outputincr)) != TCL_OK) { + goto exitforwardmethod; + } + outputArg += outputincr; + + /* if we have nonpos args, determine the first pos arg position for %1 */ + if (tcd->hasNonposArgs) { + firstPosArg = objc; + for (j=outputArg; jargs) { + /* 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 (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);*/ + } + if (tcd->needobjmap) { + /* we have to set the adressing relative from the end; -2 means + last, -3 element before last, etc. */ + int max = objc + tcd->nr_args - inputArg; + 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 0 + for(j=0; jcmdName; + result = callForwarder(tcd, interp, objc, ov); + + if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} + exitforwardmethod: + if (freeList) {DECR_REF_COUNT(freeList);} + FREE_ON_STACK(int,objvmap); + FREE_ON_STACK(Tcl_Obj*,OV); + } + return result; +} + +/* + * copied from Tcl, since not exported + */ +static char * +VwaitVarProc( + ClientData clientData, /* Pointer to integer to set to 1. */ + Tcl_Interp *interp, /* Interpreter containing variable. */ + char *name1, /* Name of variable. */ + char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +static int +XOTclProcAliasMethod(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]) { + AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; + XOTclObject *self = GetSelfObj(interp); + CONST char *methodName = ObjStr(objv[0]); + + if (self == NULL) { + return XOTclVarErrMsg(interp, "no object active for alias '", + Tcl_GetCommandName(interp, tcd->aliasCmd), + "'; don't call aliased methods via namespace paths", + (char *) NULL); + } + return MethodDispatch((ClientData)self, interp, objc, objv, tcd->aliasedCmd, self, tcd->class, + methodName, 0); +} + +static int +XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; + XOTclObject *object = tcd->object; + Tcl_CallFrame frame, *framePtr = &frame; + int result; + + /*fprintf(stderr, "objscopedMethod obj=%p %s, ptr=%p\n", object, objectName(object), tcd->objProc);*/ + + XOTcl_PushFrameObj(interp, object, framePtr); + +#if !defined(NRE) + result = (*tcd->objProc)(tcd->clientData, interp, objc, objv); +#else + result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv); +#endif + + XOTcl_PopFrameObj(interp, framePtr); + return result; +} + +static void setterCmdDeleteProc(ClientData clientData) { + SetterCmdClientData *setterClientData = (SetterCmdClientData *)clientData; + + if (setterClientData->paramsPtr) { + ParamsFree(setterClientData->paramsPtr); + } + FREE(SetterCmdClientData, setterClientData); +} + +static void aliasCmdDeleteProc(ClientData clientData) { + AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; + ImportRef *refPtr, *prevPtr = NULL; + + /* + * Since we just get the clientData, we have to obtain interp, + * object, methodName and per-object from tcd; the obj might be + * deleted already. We need as well at least still the global + * namespace. + */ + if (tcd->interp && + ((Interp *)(tcd->interp))->globalNsPtr && + RUNTIME_STATE(tcd->interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { + CONST char *methodName = Tcl_GetCommandName(tcd->interp, tcd->aliasCmd); + AliasDelete(tcd->interp, tcd->cmdName, methodName, tcd->class == NULL); + } + + /*fprintf(stderr, "aliasCmdDeleteProc\n");*/ + if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} + if (tcd->aliasedCmd) { + Command *aliasedCmd = (Command *)(tcd->aliasedCmd); + /* + * Clear the aliasCmd from the imported-ref chain of the aliased + * (or real) cmd. This widely resembles what happens in the + * DeleteImportedCmd() (see tclNamesp.c), however, as we do not + * provide for ImportedCmdData client data etc., we cannot + * directly use it. + */ + for (refPtr = aliasedCmd->importRefPtr; refPtr; refPtr = refPtr->nextPtr) { + if (refPtr->importedCmdPtr == (Command *) tcd->aliasCmd) { + if (prevPtr == NULL) { + aliasedCmd->importRefPtr = refPtr->nextPtr; + } else { + prevPtr->nextPtr = refPtr->nextPtr; + } + ckfree((char *) refPtr); + break; + } + prevPtr = refPtr; + } + } + + FREE(AliasCmdClientData, tcd); +} + + +typedef enum {NO_DASH, SKALAR_DASH, LIST_DASH} dashArgType; + +static dashArgType +isDashArg(Tcl_Interp *interp, Tcl_Obj *obj, int firstArg, CONST char **methodName, int *objc, Tcl_Obj **objv[]) { + CONST char *flag; + assert(obj); + + 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(*((flag)+1))) { + if (firstArg) { + /* if the argument contains a space, try to split */ + CONST char *p= flag+1; + while (*p && *p != ' ') p++; + if (*p == ' ') { + if (Tcl_ListObjGetElements(interp, obj, objc, objv) == TCL_OK) { + *methodName = ObjStr(*objv[0]); + if (**methodName == '-') {(*methodName)++ ;} + return LIST_DASH; + } + } + } + *methodName = flag+1; + *objc = 1; + return SKALAR_DASH; + } + return NO_DASH; +} + +static int +callConfigureMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, + int argc, Tcl_Obj *CONST argv[]) { + int result; + Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1); + + /* fprintf(stderr, "callConfigureMethod method %s->'%s' level %d, argc %d\n", + objectName(object), methodName, level, argc);*/ + + if (isInitString(methodName)) { + object->flags |= XOTCL_INIT_CALLED; + } + + Tcl_ResetResult(interp); + INCR_REF_COUNT(methodObj); + result = callMethod((ClientData)object, interp, methodObj, argc, argv, XOTCL_CM_NO_UNKNOWN); + DECR_REF_COUNT(methodObj); + + /*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d %d\n", + methodName, argc+1, obj, result, TCL_ERROR);*/ + + if (result != TCL_OK) { + Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */ + INCR_REF_COUNT(res); + XOTclVarErrMsg(interp, ObjStr(res), " during '", objectName(object), " ", + methodName, "'", (char *) NULL); + DECR_REF_COUNT(res); + } + + return result; +} + + +/* + * class method implementations + */ + +static int isRootNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { + XOTclObjectSystem *osPtr; + + for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { + Tcl_Command cmd = osPtr->rootClass->object.id; + if ((Tcl_Namespace *)((Command *)cmd)->nsPtr == nsPtr) { + return 1; + } + } + return 0; +} + +static Tcl_Namespace * +callingNameSpace(Tcl_Interp *interp) { + Tcl_CallFrame *framePtr; + Tcl_Namespace *nsPtr; + + /*tcl85showStack(interp);*/ + + /* + * Find last incovation outside the XOTcl system namespaces. For + * example, the pre defined slot handlers for relations (defined in + * the too namespace) handle mixin and class registration. etc. If we + * would use this namespace, we would resolve non-fully-qualified + * names against the root namespace). + */ + for (framePtr = activeProcFrame((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)); + framePtr; + framePtr = Tcl_CallFrame_callerVarPtr(framePtr)) { + nsPtr = Tcl_CallFrame_nsPtr(framePtr); + if (isRootNamespace(interp, nsPtr)) { + /*fprintf(stderr, "... %p skip %s\n", framePtr, nsPtr->fullName);*/ + continue; + } + /*fprintf(stderr, "... %p take %s\n", framePtr, nsPtr->fullName); */ + break; + } + + if (!framePtr) { + nsPtr = Tcl_GetGlobalNamespace(interp); + } + + /*fprintf(stderr, " **** callingNameSpace: returns %p %s framePtr %p\n", + nsPtr, nsPtr ? nsPtr->fullName:"(null)", framePtr);*/ + return nsPtr; +} + +/*********************************** + * argument parser + ***********************************/ + +#include "tclAPI.h" + +static int +ArgumentError(Tcl_Interp *interp, CONST char *errorMsg, XOTclParam CONST *paramPtr, + Tcl_Obj *cmdNameObj, Tcl_Obj *methodObj) { + Tcl_Obj *argStringObj = ParamDefsSyntax(interp, paramPtr); + + XOTclObjWrongArgs(interp, errorMsg, cmdNameObj, methodObj, ObjStr(argStringObj)); + DECR_REF_COUNT(argStringObj); + + return TCL_ERROR; +} + +static int +ArgumentCheckHelper(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int *flags, + ClientData *clientData, Tcl_Obj **outObjPtr) { + int objc, i, result; + Tcl_Obj **ov; + + /*fprintf(stderr, "ArgumentCheckHelper\n");*/ + assert(pPtr->flags & XOTCL_ARG_MULTIVALUED); + + result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov); + if (result != TCL_OK) { + return result; + } + + *outObjPtr = Tcl_NewListObj(0, NULL); + INCR_REF_COUNT(*outObjPtr); + + for (i=0; iflags & XOTCL_ARG_ALLOW_EMPTY && *valueString == '\0') { + result = convertToString(interp, ov[i], pPtr, clientData, &elementObjPtr); + } else { + result = (*pPtr->converter)(interp, ov[i], pPtr, clientData, &elementObjPtr); + } + + /*fprintf(stderr, "ArgumentCheckHelper convert %s result %d (%s)\n", + valueString, result, ObjStr(elementObjPtr));*/ + + if (result == TCL_OK) { + Tcl_ListObjAppendElement(interp, *outObjPtr, elementObjPtr); + } else { + Tcl_Obj *resultObj = Tcl_GetObjResult(interp); + INCR_REF_COUNT(resultObj); + XOTclVarErrMsg(interp, "invalid value in \"", ObjStr(objPtr), "\": ", + ObjStr(resultObj), (char *) NULL); + DECR_REF_COUNT(resultObj); + DECR_REF_COUNT(*outObjPtr); + *flags &= ~XOTCL_PC_MUST_DECR; + *outObjPtr = objPtr; + break; + } + } + return result; +} + +static int +ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int doCheck, + int *flags, ClientData *clientData, Tcl_Obj **outObjPtr) { + int result; + + if (doCheck == 0 && (pPtr->flags & (XOTCL_ARG_IS_CONVERTER|XOTCL_ARG_INITCMD)) == 0) { + /*fprintf(stderr, "*** omit argument check for arg %s flags %.6x\n",pPtr->name, pPtr->flags);*/ + *outObjPtr = objPtr; + *clientData = ObjStr(objPtr); + *flags = 0; + return TCL_OK; + } + + if (pPtr->flags & XOTCL_ARG_MULTIVALUED) { + int objc, i; + Tcl_Obj **ov; + + /* + * In the multivalued case, we have either to check a list of + * values or to build a new list of values (in case, the converter + * normalizes the values). + */ + result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov); + if (result != TCL_OK) { + return result; + } + + /* + * Default assumption: outObjPtr is not modified, in cases where + * necessary, we switch to the helper function + */ + *outObjPtr = objPtr; + + for (i=0; iflags & XOTCL_ARG_ALLOW_EMPTY && *valueString == '\0') { + result = convertToString(interp, ov[i], pPtr, clientData, &elementObjPtr); + } else { + result = (*pPtr->converter)(interp, ov[i], pPtr, clientData, &elementObjPtr); + } + + if (result == TCL_OK) { + if (ov[i] != elementObjPtr) { + /* + The elementObjPtr differs from the input tcl_obj, we + switch to the version of this handler building an output + list + */ + /*fprintf(stderr, "switch to output list construction for value %s\n", + ObjStr(elementObjPtr));*/ + *flags |= XOTCL_PC_MUST_DECR; + result = ArgumentCheckHelper(interp, objPtr, pPtr, flags, clientData, outObjPtr); + break; + } + } else { + Tcl_Obj *resultObj = Tcl_GetObjResult(interp); + INCR_REF_COUNT(resultObj); + XOTclVarErrMsg(interp, "invalid value in \"", ObjStr(objPtr), "\": ", + ObjStr(resultObj), (char *) NULL); + DECR_REF_COUNT(resultObj); + break; + } + } + } else { + const char *valueString = ObjStr(objPtr); + if (pPtr->flags & XOTCL_ARG_ALLOW_EMPTY && *valueString == '\0') { + result = convertToString(interp, objPtr, pPtr, clientData, outObjPtr); + } else { + result = (*pPtr->converter)(interp, objPtr, pPtr, clientData, outObjPtr); + } + } + return result; +} + +static int +ArgumentDefaults(parseContext *pcPtr, Tcl_Interp *interp, + XOTclParam CONST *ifd, int nrParams) { + XOTclParam CONST *pPtr; + int i; + + for (pPtr = ifd, i=0; i %p %p, default %s\n", + pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr, + pcPtr->clientData[i], pcPtr->objv[i], + pPtr->defaultValue ? ObjStr(pPtr->defaultValue) : "NONE");*/ + + if (pcPtr->objv[i]) { + /* we got an actual value, which was already checked by objv parser */ + /*fprintf(stderr, "setting passed value for %s to '%s'\n", pPtr->name, ObjStr(pcPtr->objv[i]));*/ + if (pPtr->converter == convertToSwitch) { + int bool; + Tcl_GetBooleanFromObj(interp, pPtr->defaultValue, &bool); + pcPtr->objv[i] = Tcl_NewBooleanObj(!bool); + } + } else { + /* no valued passed, check if default is available */ + + if (pPtr->defaultValue) { + int mustDecrNewValue; + Tcl_Obj *newValue = pPtr->defaultValue; + ClientData checkedData; + + /* we have a default, do we have to subst it? */ + if (pPtr->flags & XOTCL_ARG_SUBST_DEFAULT) { + int result = SubstValue(interp, pcPtr->object, &newValue); + if (result != TCL_OK) { + return result; + } + /*fprintf(stderr, "attribute %s default %p %s => %p '%s'\n", pPtr->name, + pPtr->defaultValue, ObjStr(pPtr->defaultValue), + newValue, ObjStr(newValue));*/ + + /* the according DECR is performed by parseContextRelease() */ + INCR_REF_COUNT(newValue); + mustDecrNewValue = 1; + pcPtr->flags[i] |= XOTCL_PC_MUST_DECR; + pcPtr->mustDecr = 1; + } else { + mustDecrNewValue = 0; + } + + pcPtr->objv[i] = newValue; + /*fprintf(stderr, "==> setting default value '%s' for var '%s' flag %d type %s conv %p\n", + ObjStr(newValue), pPtr->name, pPtr->flags & XOTCL_ARG_INITCMD, + pPtr->type, pPtr->converter);*/ + + /* Check the default value, unless we have an INITCMD or METHOD */ + if ((pPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_METHOD)) == 0) { + int mustDecrList = 0; + if (ArgumentCheck(interp, newValue, pPtr, + RUNTIME_STATE(interp)->doCheckArguments, + &mustDecrList, &checkedData, &pcPtr->objv[i]) != TCL_OK) { + return TCL_ERROR; + } + + if (pcPtr->objv[i] != newValue) { + /* The output tcl_obj differs from the input, so the tcl_obj + was converted; in case we have set prevously must_decr + on newValue, we decr the refcount on newValue here and + clear the flag */ + if (mustDecrNewValue) { + DECR_REF_COUNT(newValue); + pcPtr->flags[i] &= ~XOTCL_PC_MUST_DECR; + } + /* the new output value itself might require a decr, so + set the flag here if required; this is just necessary + for multivalued converted output */ + if (mustDecrList) { + pcPtr->flags[i] |= XOTCL_PC_MUST_DECR; + pcPtr->mustDecr = 1; + } + } + } + } else if (pPtr->flags & XOTCL_ARG_REQUIRED) { + return XOTclVarErrMsg(interp, + pcPtr->object ? objectName(pcPtr->object) : "", + pcPtr->object ? " " : "", + ObjStr(pcPtr->full_objv[0]), ": required argument '", + pPtr->nameObj ? ObjStr(pPtr->nameObj) : pPtr->name, + "' is missing", (char *) NULL); + } else { + /* Use as dummy default value an arbitrary symbol, which must not be + * returned to the Tcl level level; this value is + * unset later by unsetUnknownArgs + */ + pcPtr->objv[i] = XOTclGlobalObjs[XOTE___UNKNOWN__]; + } + } + } + return TCL_OK; +} + +static int +ArgumentParse(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + XOTclObject *object, Tcl_Obj *procNameObj, + XOTclParam CONST *paramPtr, int nrParams, int doCheck, + parseContext *pcPtr) { + int i, o, flagCount, nrReq = 0, nrOpt = 0, dashdash = 0, nrDashdash = 0; + XOTclParam CONST *pPtr; + + parseContextInit(pcPtr, nrParams, object, procNameObj); + +#if defined(PARSE_TRACE) + fprintf(stderr, "BEGIN (%d) [0]%s ", objc, ObjStr(procNameObj)); + for (o=1; oname && o < objc;) { +#if defined(PARSE_TRACE_FULL) + fprintf(stderr, "... (%d) processing [%d]: '%s' %s\n", i, o, + pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req"); +#endif + flagCount = 0; + if (*pPtr->name == '-') { + int p, found; + CONST char *objStr; + /* + * We expect now a non-positional (named) parameter, starting + * with a "-"; such arguments can be given in an arbitrary order + */ + for (p = o; pname && *nppPtr->name == '-'; nppPtr ++) { + if (strcmp(objStr, nppPtr->name) == 0) { + int j = nppPtr-paramPtr; + /*fprintf(stderr, "... flag '%s' o=%d p=%d, objc=%d nrArgs %d\n", objStr, o, p, objc, nppPtr->nrArgs);*/ + if (nppPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; + if (nppPtr->nrArgs == 0) { + pcPtr->clientData[j] = (ClientData)1; /* the flag was given */ + pcPtr->objv[j] = XOTclGlobalObjs[XOTE_ONE]; + } else { + /* we assume for now, nrArgs is at most 1 */ + o++; p++; + if (nppPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; + + if (o < objc) { +#if defined(PARSE_TRACE_FULL) + fprintf(stderr, "... setting cd[%d] '%s' = %s (%d) %s converter %p\n", + i, nppPtr->name, ObjStr(objv[p]), nppPtr->nrArgs, + nppPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req", nppPtr->converter); +#endif + if (ArgumentCheck(interp, objv[p], nppPtr, doCheck, + &pcPtr->flags[j], &pcPtr->clientData[j], &pcPtr->objv[j]) != TCL_OK) { + return TCL_ERROR; + } + + if (pcPtr->flags[j] & XOTCL_PC_MUST_DECR) + pcPtr->mustDecr = 1; + + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Argument for parameter '", objStr, "' expected", (char *) NULL); + return TCL_ERROR; + } + } + flagCount++; + found = 1; + break; + } + } + if (!found) { + /* we did not find the specified flag, the thing starting + with a '-' must be an argument */ + break; + } + } + } + /*fprintf(stderr, "... we found %d flags\n", flagCount);*/ + /* skip in parameter definition until the end of the switches */ + while (pPtr->name && *pPtr->name == '-') {pPtr++, i++;}; + /* under the assumption, flags have no arguments */ + o += flagCount; + /* + * check double dash -- + */ + if (oflags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; + /*fprintf(stderr, "... arg %s req %d converter %p try to set on %d: '%s' convertViaCmd %p\n", + pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr->converter, i, ObjStr(objv[o]), + convertViaCmd);*/ + + if (ArgumentCheck(interp, objv[o], pPtr, doCheck, + &pcPtr->flags[i], &pcPtr->clientData[i], &pcPtr->objv[i]) != TCL_OK) { + return TCL_ERROR; + } + if (pcPtr->flags[i] & XOTCL_PC_MUST_DECR) + pcPtr->mustDecr = 1; + + /* + * objv is always passed via pcPtr->objv + */ +#if defined(PARSE_TRACE_FULL) + fprintf(stderr, "... setting %s pPtr->objv[%d] to [%d]'%s' converter %p\n", + pPtr->name, i, o, ObjStr(objv[o]), pPtr->converter); +#endif + o++; i++; pPtr++; + } + } + pcPtr->lastobjc = pPtr->name ? o : o-1; + pcPtr->objc = i + 1; + + /* Process all args until end of parameter definitions to get correct counters */ + while (pPtr->name) { + if (pPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; + pPtr++; + } + + /* is last argument a vararg? */ + pPtr--; + if (pPtr->converter == convertToNothing) { + pcPtr->varArgs = 1; + /*fprintf(stderr, "last arg of proc '%s' is varargs\n", ObjStr(procNameObj));*/ + } + + /* handle missing or unexpected arguments */ + if (pcPtr->lastobjc < nrReq) { + return ArgumentError(interp, "not enough arguments:", paramPtr, NULL, procNameObj); /* for methods and cmds */ + } + if (!pcPtr->varArgs && objc-nrDashdash-1 > nrReq + nrOpt) { + return ArgumentError(interp, "too many arguments:", paramPtr, NULL, procNameObj); /* for methods and cmds */ + } + + return ArgumentDefaults(pcPtr, interp, paramPtr, nrParams); +} + + +/*********************************** + * Begin result setting commands + * (essentially List*() and support + ***********************************/ +static int +ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, CONST char *pattern) { + Tcl_HashEntry *hPtr; + + if (pattern && noMetaChars(pattern)) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + INCR_REF_COUNT(patternObj); + + hPtr = tablePtr ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : NULL; + if (hPtr) { + Var *val = VarHashGetValue(hPtr); + Tcl_SetObjResult(interp, VarHashGetKey(val)); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); + } + 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; +} + +static Tcl_Command +GetOriginalCommand(Tcl_Command cmd) /* The imported command for which the original + * command should be returned. */ +{ + Tcl_Command importedCmd; + + while (1) { + /* dereference the namespace import reference chain */ + if ((importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + /* dereference the XOtcl alias chain */ + if (Tcl_Command_deleteProc(cmd) == aliasCmdDeleteProc) { + AliasCmdClientData *tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd); + cmd = tcd->aliasedCmd; + continue; + } + break; + } + return cmd; +} + +static int +ListProcBody(Tcl_Interp *interp, Proc *procPtr, CONST char *methodName) { + if (procPtr) { + CONST char *body = ObjStr(procPtr->bodyPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); + return TCL_OK; + } + return XOTclErrBadVal(interp, "info body", "a tcl method name", methodName); +} + +static Tcl_Obj* +ListParamDefs(Tcl_Interp *interp, XOTclParam CONST *paramsPtr, int style) { + Tcl_Obj *listObj; + + switch (style) { + case 0: listObj = ParamDefsFormat(interp, paramsPtr); break; + case 1: listObj = ParamDefsList(interp, paramsPtr); break; + case 2: listObj = ParamDefsSyntax(interp, paramsPtr); break; + } + + return listObj; +} + +static int +ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, CONST char *methodName, int withVarnames) { + Proc *procPtr = GetTclProcFromCommand(cmd); + if (procPtr) { + XOTclParamDefs *paramDefs = procPtr ? ParamDefsGet((Tcl_Command)procPtr->cmdPtr) : NULL; + Tcl_Obj *list; + + if (paramDefs) { + /* + * Obtain parameter info from paramDefs + */ + list = ListParamDefs(interp, paramDefs->paramsPtr, withVarnames); + + } else { + /* + * Obtain parameter info from compiled locals + */ + CompiledLocal *args = procPtr->firstLocalPtr; + + list = Tcl_NewListObj(0, NULL); + for ( ; args; args = args->nextPtr) { + Tcl_Obj *innerlist; + + if (!TclIsCompiledLocalArgument(args)) { + continue; + } + + innerlist = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, innerlist, Tcl_NewStringObj(args->name, -1)); + if (!withVarnames && args->defValuePtr) { + Tcl_ListObjAppendElement(interp, innerlist, args->defValuePtr); + } + Tcl_ListObjAppendElement(interp, list, innerlist); + } + } + + Tcl_SetObjResult(interp, list); + return TCL_OK; + + } else if (cmd) { + /* + * If a command is found for the object|class, check whether we + * find the parameter definitions for the C-defined method. + */ + methodDefinition *mdPtr = &method_definitions[0]; + + for (; mdPtr->methodName; mdPtr ++) { + + /*fprintf(stderr, "... comparing %p with %p => %s\n", ((Command *)cmd)->objProc, mdPtr->proc, + mdPtr->methodName);*/ + + if (((Command *)cmd)->objProc == mdPtr->proc) { + XOTclParamDefs paramDefs = {mdPtr->paramDefs, mdPtr->nrParameters}; + Tcl_Obj *list = ListParamDefs(interp, paramDefs.paramsPtr, withVarnames); + + Tcl_SetObjResult(interp, list); + return TCL_OK; + } + } + + if (((Command *)cmd)->objProc == XOTclSetterMethod) { + SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd); + if (cd->paramsPtr) { + Tcl_Obj *list; + XOTclParamDefs paramDefs; + paramDefs.paramsPtr = cd->paramsPtr; + paramDefs.nrParams = 1; + paramDefs.slotObj = NULL; + list = ListParamDefs(interp, paramDefs.paramsPtr, withVarnames); + Tcl_SetObjResult(interp, list); + return TCL_OK; + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj(methodName, -1)); + return TCL_OK; + } + } else if (((Command *)cmd)->objProc == XOTclForwardMethod) { + return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for forwarder '", + methodName, "'", (char *) NULL); + } else { + return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for method '", + methodName, "'", (char *) NULL); + } + } + return XOTclErrBadVal(interp, "info params", "a method name", methodName); +} + +static void +AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd) { + if (tcd->prefix) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-methodprefix", -1)); + Tcl_ListObjAppendElement(interp, listObj, tcd->prefix); + } + if (tcd->subcommands) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-default", -1)); + Tcl_ListObjAppendElement(interp, listObj, tcd->subcommands); + } + if (tcd->objscope) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-objscope", -1)); + } + Tcl_ListObjAppendElement(interp, listObj, tcd->cmdName); + if (tcd->args) { + Tcl_Obj **args; + int nrArgs, i; + Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); + for (i=0; icmdName); + if (withPer_object) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6)); + } + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(registerCmdName, -1)); + if (withObjscope) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-objscope", 9)); + } + if (Tcl_Command_flags(cmd) & XOTCL_CMD_NONLEAF_METHOD) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-nonleaf", 8)); + } + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(methodName, -1)); +} + +static int +ListMethodHandle(Tcl_Interp *interp, XOTclObject *object, int withPer_object, CONST char *methodName) { + Tcl_SetObjResult(interp, MethodHandleObj(object, withPer_object, methodName)); + return TCL_OK; +} + +static int +ListMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, Tcl_Command cmd, + int subcmd, int withPer_object) { + + /*fprintf(stderr, "ListMethodtype %s %s %p subcmd %d per-object %d\n", + objectName(object), methodName, cmd, subcmd, withPer_object);*/ + + if (!cmd) { + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); + } else { + Tcl_ObjCmdProc *procPtr = Tcl_Command_objProc(cmd); + int outputPerObject = 0; + Tcl_Obj *resultObj; + + if (*methodName == ':') { + /* + * We have a fully qualified method name, maybe an object handle + */ + CONST char *procName = Tcl_GetCommandName(interp, cmd); + size_t objNameLength = strlen(methodName) - strlen(procName) - 2; + Tcl_DString ds, *dsPtr = &ds; + + if (objNameLength > 0) { + XOTclObject *object1; + int fromClassNS; + + Tcl_DStringInit(dsPtr); + Tcl_DStringAppend(dsPtr, methodName, objNameLength); + object1 = GetObjectFromNsName(interp, Tcl_DStringValue(dsPtr), &fromClassNS); + if (object1) { + /* + * The command was from an object, return therefore this + * object as reference. + */ + /*fprintf(stderr, "We are flipping the object to %s, method %s to %s !fromClassNS %d\n", + objectName(object1), methodName, procName, !fromClassNS);*/ + object = object1; + methodName = procName; + withPer_object = fromClassNS ? 0 : 1; + } + Tcl_DStringFree(dsPtr); + } + } + + if (!XOTclObjectIsClass(object)) { + withPer_object = 1; + /* don't output "object" modifier, if object is not a class */ + outputPerObject = 0; + } else { + outputPerObject = withPer_object; + } + + switch (subcmd) { + case InfomethodsubcmdHandleIdx: + { + return ListMethodHandle(interp, object, withPer_object, methodName); + } + case InfomethodsubcmdArgsIdx: + { + Tcl_Command importedCmd = GetOriginalCommand(cmd); + return ListCmdParams(interp, importedCmd, methodName, 1); + } + case InfomethodsubcmdParameterIdx: + { + Tcl_Command importedCmd = GetOriginalCommand(cmd); + return ListCmdParams(interp, importedCmd, methodName, 0); + } + case InfomethodsubcmdParametersyntaxIdx: + { + Tcl_Command importedCmd = GetOriginalCommand(cmd); + return ListCmdParams(interp, importedCmd, methodName, 2); + } + case InfomethodsubcmdPreconditionIdx: + { + XOTclProcAssertion *procs; + if (withPer_object) { + procs = object->opt ? AssertionFindProcs(object->opt->assertions, methodName) : NULL; + } else { + XOTclClass *class = (XOTclClass *)object; + procs = class->opt ? AssertionFindProcs(class->opt->assertions, methodName) : NULL; + } + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + return TCL_OK; + } + case InfomethodsubcmdPostconditionIdx: + { + XOTclProcAssertion *procs; + if (withPer_object) { + procs = object->opt ? AssertionFindProcs(object->opt->assertions, methodName) : NULL; + } else { + XOTclClass *class = (XOTclClass *)object; + procs = class->opt ? AssertionFindProcs(class->opt->assertions, methodName) : NULL; + } + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + return TCL_OK; + } + + } + + /* + * Subcommands different per type of method. The Converter in + * InfoMethods defines the types: + * + * "all|scripted|system|alias|forwarder|object|setter" + */ + if (GetTclProcFromCommand(cmd)) { + /* a scripted method */ + switch (subcmd) { + + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("scripted", -1)); + break; + + case InfomethodsubcmdBodyIdx: + ListProcBody(interp, GetTclProcFromCommand(cmd), methodName); + break; + + case InfomethodsubcmdDefinitionIdx: + { + XOTclAssertionStore *assertions; + + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "method" / XOTE_METHOD */ + AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_METHOD], + object, methodName, cmd, 0, outputPerObject); + ListCmdParams(interp, cmd, methodName, 0); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp)); + ListProcBody(interp, GetTclProcFromCommand(cmd), methodName); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp)); + + if (withPer_object) { + assertions = object->opt ? object->opt->assertions : NULL; + } else { + XOTclClass *class = (XOTclClass *)object; + assertions = class->opt ? class->opt->assertions : NULL; + } + if (assertions) { + XOTclProcAssertion *procs = AssertionFindProcs(assertions, methodName); + if (procs) { + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-precondition", -1)); + Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->pre)); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-postcondition", -1)); + Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->post)); + } + } + Tcl_SetObjResult(interp, resultObj); + break; + } + } + + } else if (procPtr == XOTclForwardMethod) { + /* forwarder */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_FORWARD]); + break; + case InfomethodsubcmdDefinitionIdx: + { + ClientData clientData = cmd ? Tcl_Command_objClientData(cmd) : NULL; + + if (clientData) { + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "forward" / XOTE_FORWARD*/ + AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_FORWARD], + object, methodName, cmd, 0, outputPerObject); + AppendForwardDefinition(interp, resultObj, clientData); + Tcl_SetObjResult(interp, resultObj); + break; + } + } + } + + } else if (procPtr == XOTclSetterMethod) { + /* setter methods */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_SETTER]); + break; + case InfomethodsubcmdDefinitionIdx: { + SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd); + + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "setter" / XOTE_SETTER */ + + AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_SETTER], object, + cd->paramsPtr ? ObjStr(cd->paramsPtr->paramObj) : methodName, + cmd, 0, outputPerObject); + Tcl_SetObjResult(interp, resultObj); + break; + } + } +#if 0 + } else if (procPtr == XOTclObjDispatch) { + /* + Also some aliases come with procPtr == XOTclObjDispatch. In + order to dinstinguish between "object" and alias, we would + have to do the lookup for the entryObj in advance and alter + e.g. the procPtr. + */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("object", -1)); + break; + case InfomethodsubcmdDefinitionIdx: + { + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); + break; + } + } +#endif + } else { + /* + * The cmd must be an alias or object. + * + * Note that some aliases come with procPtr == XOTclObjDispatch. + * In order to dinstinguish between "object" and alias, we have + * to do the lookup for the entryObj to determine wether it is + * really an alias. + */ + + Tcl_Obj *entryObj = AliasGet(interp, object->cmdName, methodName, withPer_object); + /*fprintf(stderr, "aliasGet %s -> %s (%d) returned %p\n", + objectName(object), methodName, withPer_object, entryObj);*/ + + if (entryObj) { + /* is an alias */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_ALIAS]); + break; + case InfomethodsubcmdDefinitionIdx: + { + int nrElements; + Tcl_Obj **listElements; + resultObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements); + /* todo: don't hard-code registering command name "alias" / XOTE_ALIAS */ + AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_ALIAS], + object, methodName, cmd, nrElements!=1, outputPerObject); + Tcl_ListObjAppendElement(interp, resultObj, listElements[nrElements-1]); + Tcl_SetObjResult(interp, resultObj); + break; + } + } + } else { + /* check, to be on the safe side */ + if (procPtr == XOTclObjDispatch) { + /* is an object */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("object", -1)); + break; + case InfomethodsubcmdDefinitionIdx: + { + /* yyyy */ + XOTclObject *subObject = XOTclGetObjectFromCmdPtr(cmd); + assert(subObject); + resultObj = Tcl_NewListObj(0, NULL); + /* we can make + create + or something similar to the other definition cmds + createChild + */ + AppendMethodRegistration(interp, resultObj, "create", + &(subObject->cl)->object, + ObjStr(subObject->cmdName), cmd, 0, 0); + /* + AppendMethodRegistration(interp, resultObj, "subobject", + object, methodName, cmd, 0, 0); + Tcl_ListObjAppendElement(interp, resultObj, subObject->cmdName);*/ + + Tcl_SetObjResult(interp, resultObj); + break; + } + } + } else { + /* should never happen */ + fprintf(stderr, "should never happen, maybe someone deleted the alias %s for object %s\n", + methodName, objectName(object)); + Tcl_ResetResult(interp); + } + } + } + } + return TCL_OK; +} + +static int +ProtectionMatches(Tcl_Interp *interp, int withCallprotection, Tcl_Command cmd) { + int result, isProtected = Tcl_Command_flags(cmd) & XOTCL_CMD_PROTECTED_METHOD; + if (withCallprotection == CallprotectionNULL) { + withCallprotection = CallprotectionPublicIdx; + } + switch (withCallprotection) { + case CallprotectionAllIdx: result = 1; break; + case CallprotectionPublicIdx: result = (isProtected == 0); break; + case CallprotectionProtectedIdx: result = (isProtected == 1); break; + default: result = 1; + } + return result; +} + +static int +MethodTypeMatches(Tcl_Interp *interp, int methodType, Tcl_Command cmd, + XOTclObject *object, CONST char *key, int withPer_object) { + Tcl_Command importedCmd; + Tcl_ObjCmdProc *proc, *resolvedProc; + + proc = Tcl_Command_objProc(cmd); + importedCmd = GetOriginalCommand(cmd); + resolvedProc = Tcl_Command_objProc(importedCmd); + + if (methodType == XOTCL_METHODTYPE_ALIAS) { + if (!(proc == XOTclProcAliasMethod || AliasGet(interp, object->cmdName, key, withPer_object))) { + return 0; + } + } else { + if (proc == XOTclProcAliasMethod) { + if ((methodType & XOTCL_METHODTYPE_ALIAS) == 0) return 0; + } + /* the following cases are disjoint */ + if (CmdIsProc(importedCmd)) { + /*fprintf(stderr,"%s scripted %d\n", key, methodType & XOTCL_METHODTYPE_SCRIPTED);*/ + if ((methodType & XOTCL_METHODTYPE_SCRIPTED) == 0) return 0; + } else if (resolvedProc == XOTclForwardMethod) { + if ((methodType & XOTCL_METHODTYPE_FORWARDER) == 0) return 0; + } else if (resolvedProc == XOTclSetterMethod) { + if ((methodType & XOTCL_METHODTYPE_SETTER) == 0) return 0; + } else if (resolvedProc == XOTclObjDispatch) { + if ((methodType & XOTCL_METHODTYPE_OBJECT) == 0) return 0; + } else if ((methodType & XOTCL_METHODTYPE_OTHER) == 0) { + /* fprintf(stderr,"OTHER %s not wanted %.4x\n", key, methodType);*/ + return 0; + } + /* XOTclObjscopedMethod ??? */ + } + return 1; +} + +static int +ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, CONST char *pattern, + int methodType, int withCallprotection, + Tcl_HashTable *dups, XOTclObject *object, int withPer_object) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr, *duphPtr; + Tcl_Command cmd; + char *key; + int new; + + if (pattern && noMetaChars(pattern)) { + /* We have a pattern that can be used for direct lookup; + * no need to iterate + */ + hPtr = table ? Tcl_CreateHashEntry(table, pattern, NULL) : NULL; + if (hPtr) { + key = Tcl_GetHashKey(table, hPtr); + cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + + if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD && !XOTclObjectIsClass(object)) { + return TCL_OK; + } + + if (ProtectionMatches(interp, withCallprotection, cmd) + && MethodTypeMatches(interp, methodType, cmd, object, key, withPer_object)) { + if (dups) { + duphPtr = Tcl_CreateHashEntry(dups, key, &new); + if (new) { + Tcl_AppendElement(interp, key); + } + } else { + Tcl_AppendElement(interp, key); + } + } + } + return TCL_OK; + + } else { + hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + key = Tcl_GetHashKey(table, hPtr); + cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + + if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD && !XOTclObjectIsClass(object)) continue; + if (pattern && !Tcl_StringMatch(key, pattern)) continue; + if (!ProtectionMatches(interp, withCallprotection, cmd) + || !MethodTypeMatches(interp, methodType, cmd, object, key, withPer_object) + ) continue; + + if (dups) { + duphPtr = Tcl_CreateHashEntry(dups, key, &new); + if (!new) continue; + } + Tcl_AppendElement(interp, key); + } + } + /*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/ + return TCL_OK; +} + +static int +ListChildren(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, int classesOnly) { + XOTclObject *childObject; + Tcl_HashTable *cmdTable; + + if (!object->nsPtr) return TCL_OK; + + cmdTable = Tcl_Namespace_cmdTable(object->nsPtr); + if (pattern && noMetaChars(pattern)) { + + if ((childObject = XOTclpGetObject(interp, pattern)) && + (!classesOnly || XOTclObjectIsClass(childObject)) && + (Tcl_Command_nsPtr(childObject->id) == object->nsPtr) /* true children */ + ) { + Tcl_SetObjResult(interp, childObject->cmdName); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); + } + + } else { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + char *key; + + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + key = Tcl_GetHashKey(cmdTable, hPtr); + if (!pattern || Tcl_StringMatch(key, pattern)) { + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + + /*fprintf(stderr, "... check %s child key %s child object %p %p\n", + objectName(object),key,XOTclpGetObject(interp, key), + XOTclGetObjectFromCmdPtr(cmd));*/ + + if ((childObject = XOTclGetObjectFromCmdPtr(cmd)) && + (!classesOnly || XOTclObjectIsClass(childObject)) && + (Tcl_Command_nsPtr(childObject->id) == object->nsPtr) /* true children */ + ) { + Tcl_ListObjAppendElement(interp, list, childObject->cmdName); + } + } + } + Tcl_SetObjResult(interp, list); + } + + return TCL_OK; +} + +static int +ListForward(Tcl_Interp *interp, Tcl_HashTable *table, CONST char *pattern, int withDefinition) { + if (withDefinition) { + Tcl_HashEntry *hPtr = table && pattern ? Tcl_CreateHashEntry(table, pattern, NULL) : NULL; + /* notice: we don't use pattern for wildcard matching here; + pattern can only contain wildcards when used without + "-definition" */ + 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_Command_objProc(cmd) == XOTclForwardMethod) { + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); + AppendForwardDefinition(interp, listObj, tcd); + Tcl_SetObjResult(interp, listObj); + return TCL_OK; + } + } + return XOTclVarErrMsg(interp, "'", pattern, "' is not a forwarder", (char *) NULL); + } + return ListMethodKeys(interp, table, pattern, XOTCL_METHODTYPE_FORWARDER, CallprotectionAllIdx, NULL, NULL, 0); +} + +static int +ListDefinedMethods(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, + int withPer_object, int methodType, int withCallproctection, + int noMixins, int inContext) { + Tcl_HashTable *cmdTable; + + if (XOTclObjectIsClass(object) && !withPer_object) { + cmdTable = Tcl_Namespace_cmdTable(((XOTclClass *)object)->nsPtr); + } else { + cmdTable = object->nsPtr ? Tcl_Namespace_cmdTable(object->nsPtr) : NULL; + } + ListMethodKeys(interp, cmdTable, pattern, methodType, withCallproctection, + NULL, object, withPer_object); + return TCL_OK; +} + +static int +ListCallableMethods(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, + int methodType, int withCallprotection, + int withApplication, int noMixins, int inContext) { + XOTclClasses *pl; + int withPer_object = 1; + Tcl_HashTable *cmdTable, dupsTable, *dups = &dupsTable; + + /* + * TODO: we could make this faster for patterns without metachars + * by letting ListMethodKeys() to signal us when an entry was found. + * we wait, until the we decided about "info methods defined" + * vs. "info method search" vs. "info defined" etc. + */ + if (withCallprotection == CallprotectionNULL) { + withCallprotection = CallprotectionPublicIdx; + } + + if (withApplication && object->flags & IsBaseClass((XOTclClass*)object)) { + return TCL_OK; + } + + Tcl_InitHashTable(dups, TCL_STRING_KEYS); + if (object->nsPtr) { + cmdTable = Tcl_Namespace_cmdTable(object->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, + dups, object, withPer_object); + } + + if (!noMixins) { + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml; + XOTclClass *mixin; + for (ml = object->mixinOrder; ml; ml = ml->nextPtr) { + int guardOk = TCL_OK; + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + assert(mixin); + + if (inContext) { + if (!RUNTIME_STATE(interp)->guardCount) { + guardOk = GuardCall(object, 0, 0, interp, ml->clientData, NULL); + } + } + if (mixin && guardOk == TCL_OK) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, + dups, object, withPer_object); + } + } + } + } + + /* append method keys from inheritance order */ + for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); + if (withApplication && IsBaseClass(pl->cl)) { + break; + } + ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, + dups, object, withPer_object); + } + Tcl_DeleteHashTable(dups); + return TCL_OK; +} + +static int +ListSuperclasses(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *pattern, int withClosure) { + XOTclObject *matchObject = NULL; + Tcl_Obj *patternObj = NULL, *outObjPtr; + CONST char *patternString = NULL; + int rc; + + if (pattern && + convertToObjpattern(interp, pattern, NULL, (ClientData *)&patternObj, &outObjPtr) == TCL_OK) { + if (getMatchObject(interp, patternObj, pattern, &matchObject, &patternString) == -1) { + if (patternObj) { + DECR_REF_COUNT(patternObj); + } + return TCL_OK; + } + } + + if (withClosure) { + XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); + if (pl) pl=pl->nextPtr; + rc = AppendMatchingElementsFromClasses(interp, pl, patternString, matchObject); + } else { + XOTclClasses *clSuper = XOTclReverseClasses(cl->super); + rc = AppendMatchingElementsFromClasses(interp, clSuper, patternString, matchObject); + XOTclClassListFree(clSuper); + } + + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + } + + if (patternObj) { + DECR_REF_COUNT(patternObj); + } + return TCL_OK; +} + + +/******************************** + * End result setting commands + ********************************/ + +static CONST char* AliasIndex(Tcl_DString *dsPtr, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object) { + Tcl_DStringInit(dsPtr); + Tcl_DStringAppend(dsPtr, ObjStr(cmdName), -1); + Tcl_DStringAppend(dsPtr, ",", 1); + Tcl_DStringAppend(dsPtr, methodName, -11); + if (withPer_object) { + Tcl_DStringAppend(dsPtr, ",1", 2); + } else { + Tcl_DStringAppend(dsPtr, ",0", 2); + } + /*fprintf(stderr, "AI %s\n", Tcl_DStringValue(dsPtr));*/ + return Tcl_DStringValue(dsPtr); +} + +static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object, + CONST char *cmd) { + Tcl_DString ds, *dsPtr = &ds; + Tcl_SetVar2Ex(interp, XOTclGlobalStrings[XOTE_ALIAS_ARRAY], + AliasIndex(dsPtr, cmdName, methodName, withPer_object), + Tcl_NewStringObj(cmd, -1), + TCL_GLOBAL_ONLY); + /*fprintf(stderr, "aliasAdd ::nsf::alias(%s) '%s' returned %p\n", + AliasIndex(dsPtr, cmdName, methodName, withPer_object), cmd, 1);*/ + Tcl_DStringFree(dsPtr); + return TCL_OK; +} + +static int AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object) { + Tcl_DString ds, *dsPtr = &ds; + int result = Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_ALIAS_ARRAY], + AliasIndex(dsPtr, cmdName, methodName, withPer_object), + TCL_GLOBAL_ONLY); + /*fprintf(stderr, "aliasDelete ::nsf::alias(%s) returned %d (%d)\n", + AliasIndex(dsPtr, cmdName, methodName, withPer_object), result);*/ + Tcl_DStringFree(dsPtr); + return result; +} + +static Tcl_Obj *AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object) { + Tcl_DString ds, *dsPtr = &ds; + Tcl_Obj *obj = Tcl_GetVar2Ex(interp, XOTclGlobalStrings[XOTE_ALIAS_ARRAY], + AliasIndex(dsPtr, cmdName, methodName, withPer_object), + TCL_GLOBAL_ONLY); + /*fprintf(stderr, "aliasGet returns %p\n", object);*/ + Tcl_DStringFree(dsPtr); + return obj; +} + + +/********************************* + * Begin generated XOTcl commands + *********************************/ +/* +xotclCmd alias XOTclAliasCmd { + {-argName "object" -type object} + {-argName "-per-object"} + {-argName "methodName"} + {-argName "-nonleaf"} + {-argName "-objscope"} + {-argName "cmdName" -required 1 -type tclobj} +} +*/ +static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, + CONST char *methodName, int withNonleaf, int withObjscope, + Tcl_Obj *cmdName) { + Tcl_ObjCmdProc *objProc, *newObjProc = NULL; + Tcl_CmdDeleteProc *deleteProc = NULL; + AliasCmdClientData *tcd = NULL; /* make compiler happy */ + Tcl_Command cmd, newCmd = NULL; + Tcl_Namespace *nsPtr; + int flags, result; + XOTclClass *cl = (withPer_object || ! XOTclObjectIsClass(object)) ? NULL : (XOTclClass *)object; + + cmd = Tcl_GetCommandFromObj(interp, cmdName); + if (cmd == NULL) { + return XOTclVarErrMsg(interp, "cannot lookup command '", + ObjStr(cmdName), "'", (char *) NULL); + } + + cmd = GetOriginalCommand(cmd); + objProc = Tcl_Command_objProc(cmd); + + /* objProc is either ... + + 1. XOTclObjDispatch: a command representing an XOTcl object + + 2. TclObjInterpProc: a cmd standing for a + Tcl proc (including XOTcl methods), verified through + CmdIsProc() -> to be wrapped by XOTclProcAliasMethod() + + 3. XOTclForwardMethod: an XOTcl forwarder + + 4. XOTclSetterMethod: an XOTcl setter + + 5. arbitrary Tcl commands (e.g. set, ..., ::nsf::relation, ...) + + TODO GN: i think, we should use XOTclProcAliasMethod, whenever the clientData + is not 0. These are the cases, where the clientData will be freed, + when the original command is deleted. + */ + + if (withObjscope) { + newObjProc = XOTclObjscopedMethod; + } + + if (objProc == XOTclObjDispatch) { + /* + * if we register an alias for an object, we have to take care to + * handle cases, where the aliased object is destroyed and the + * alias points to nowhere. We realize this via using the object + * refcount. + */ + /*fprintf(stderr, "registering an object %p\n", tcd);*/ + + XOTclObjectRefCountIncr((XOTclObject *)Tcl_Command_objClientData(cmd)); + + /*newObjProc = XOTclProcAliasMethod;*/ + + } else if (CmdIsProc(cmd)) { + /* + * if we have a tcl proc|xotcl-method as alias, then use the + * wrapper, which will be deleted automatically when the original + * proc/method is deleted. + */ + newObjProc = XOTclProcAliasMethod; + + if (withObjscope) { + return XOTclVarErrMsg(interp, "cannot use -objscope for tcl implemented command '", + ObjStr(cmdName), "'", (char *) NULL); + } + } + + if (newObjProc) { + /* add a wrapper */ + tcd = NEW(AliasCmdClientData); + tcd->cmdName = object->cmdName; + tcd->interp = interp; /* just for deleting the associated variable */ + tcd->object = object; + tcd->class = cl ? (XOTclClass *) object : NULL; + tcd->objProc = objProc; + tcd->aliasedCmd = cmd; + tcd->clientData = Tcl_Command_objClientData(cmd); + objProc = newObjProc; + deleteProc = aliasCmdDeleteProc; + if (tcd->cmdName) {INCR_REF_COUNT(tcd->cmdName);} + } else { + /* call the command directly (must be a c-implemented command not + * depending on a volatile client data) + */ + tcd = Tcl_Command_objClientData(cmd); + } + + flags = 0; + + if (cl) { + result = XOTclAddClassMethod(interp, (XOTcl_Class *)cl, methodName, + objProc, tcd, deleteProc, flags); + nsPtr = cl->nsPtr; + } else { + result = XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, + objProc, tcd, deleteProc, flags); + nsPtr = object->nsPtr; + } + + if (result == TCL_OK) { + newCmd = FindMethod(nsPtr, methodName); + } + + if (newObjProc) { + /* + * Define the reference chain like for 'namespace import' to + * obtain automatic deletes when the original command is deleted. + */ + ImportRef *refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr->importedCmdPtr = (Command *) newCmd; + refPtr->nextPtr = ((Command *) tcd->aliasedCmd)->importRefPtr; + ((Command *) tcd->aliasedCmd)->importRefPtr = refPtr; + tcd->aliasCmd = newCmd; + } + + if (newCmd) { + Tcl_DString ds, *dsPtr = &ds; + Tcl_DStringInit(dsPtr); + /*if (withPer_object) {Tcl_DStringAppend(dsPtr, "-per-object ", -1);}*/ + if (withObjscope) {Tcl_DStringAppend(dsPtr, "-objscope ", -1);} + Tcl_DStringAppend(dsPtr, ObjStr(cmdName), -1); + AliasAdd(interp, object->cmdName, methodName, cl == NULL, Tcl_DStringValue(dsPtr)); + Tcl_DStringFree(dsPtr); + + if (!withObjscope && withNonleaf) { + Tcl_Command_flags(newCmd) |= XOTCL_CMD_NONLEAF_METHOD; + /*fprintf(stderr, "setting aliased for cmd %p %s flags %.6x, tcd = %p\n", + newCmd,methodName,Tcl_Command_flags(newCmd), tcd);*/ + } + + result = ListMethodHandle(interp, object, cl == NULL, methodName); + } + + return result; +} + +/* +xotclCmd assertion XOTclAssertionCmd { + {-argName "object" -type object} + {-argName "assertionsubcmd" -required 1 -type "check|object-invar|class-invar"} + {-argName "arg" -required 0 -type tclobj} +} + + Make "::nsf::assertion" a cmd rather than a method, otherwise we + cannot define e.g. a "method check options {...}" to reset the check + options in case of a failed option, since assertion checking would + be applied on the sketched method already. +*/ + +static int XOTclAssertionCmd(Tcl_Interp *interp, XOTclObject *object, int subcmd, Tcl_Obj *arg) { + XOTclClass *class; + + switch (subcmd) { + case AssertionsubcmdCheckIdx: + if (arg) { + return AssertionSetCheckOptions(interp, object, arg); + } else { + return AssertionListCheckOption(interp, object); + } + break; + + case AssertionsubcmdObject_invarIdx: + if (arg) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); + AssertionSetInvariants(interp, &opt->assertions, arg); + } else { + if (object->opt && object->opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, object->opt->assertions->invariants)); + } + } + break; + + case AssertionsubcmdClass_invarIdx: + class = (XOTclClass *)object; + if (arg) { + XOTclClassOpt *opt = XOTclRequireClassOpt(class); + AssertionSetInvariants(interp, &opt->assertions, arg); + } else { + if (class->opt && class->opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, class->opt->assertions->invariants)); + } + } + } + return TCL_OK; +} + +/* +xotclCmd configure XOTclConfigureCmd { + {-argName "configureoption" -required 1 -type "filter|softrecreate|objectsystems|keepinitcmd|checkresult"} + {-argName "value" -required 0 -type tclobj} +} +*/ +static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *valueObj) { + int bool; + + if (configureoption == ConfigureoptionObjectsystemsIdx) { + XOTclObjectSystem *osPtr; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + + for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { + Tcl_Obj *osObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, osObj, osPtr->rootClass->object.cmdName); + Tcl_ListObjAppendElement(interp, osObj, osPtr->rootMetaClass->object.cmdName); + Tcl_ListObjAppendElement(interp, list, osObj); + } + Tcl_SetObjResult(interp, list); + return TCL_OK; + } + + if (valueObj) { + int result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); + if (result != TCL_OK) + return result; + } + + switch (configureoption) { + case ConfigureoptionFilterIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doFilters)); + if (valueObj) + RUNTIME_STATE(interp)->doFilters = bool; + break; + + case ConfigureoptionSoftrecreateIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doSoftrecreate)); + if (valueObj) + RUNTIME_STATE(interp)->doSoftrecreate = bool; + break; + + case ConfigureoptionKeepinitcmdIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doKeepinitcmd)); + if (valueObj) + RUNTIME_STATE(interp)->doKeepinitcmd = bool; + break; + + case ConfigureoptionCheckresultsIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doCheckResults)); + if (valueObj) + RUNTIME_STATE(interp)->doCheckResults = bool; + break; + + case ConfigureoptionCheckargumentsIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doCheckArguments)); + if (valueObj) + RUNTIME_STATE(interp)->doCheckArguments = bool; + break; + } + return TCL_OK; +} + + +/* +xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { + {-argName "rootClass" -required 1 -type tclobj} + {-argName "rootMetaClass" -required 1 -type tclobj} + {-argName "systemMethods" -required 0 -type tclobj} +} +*/ +static int +XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *Object, Tcl_Obj *Class, Tcl_Obj *systemMethodsObj) { + XOTclClass *theobj; + XOTclClass *thecls; + XOTclObjectSystem *osPtr = NEW(XOTclObjectSystem); + + memset(osPtr, 0, sizeof(XOTclObjectSystem)); + + if (systemMethodsObj) { + int oc, i, idx, result; + Tcl_Obj **ov; + + if ((result = Tcl_ListObjGetElements(interp, systemMethodsObj, &oc, &ov)) == TCL_OK) { + if (oc % 2) { + ObjectSystemFree(interp, osPtr); + return XOTclErrMsg(interp, "System methods must be provided as pairs", TCL_STATIC); + } + for (i=0; imethods[idx] = ov[i+1]; + INCR_REF_COUNT(osPtr->methods[idx]); + } + } else { + ObjectSystemFree(interp, osPtr); + return XOTclErrMsg(interp, "Provided system methods are not a proper list", TCL_STATIC); + } + } + /* + Create a basic object system with the basic root class Object and + the basic metaclass Class, and store them in the RUNTIME STATE if + successful + */ + theobj = PrimitiveCCreate(interp, Object, NULL); + thecls = PrimitiveCCreate(interp, Class, NULL); + /* fprintf(stderr, "CreateObjectSystem created base classes \n"); */ + +#if defined(NSF_PROFILE) + XOTclProfileInit(interp); +#endif + + /* check whether Object and Class creation was successful */ + if (!theobj || !thecls) { + int i; + + if (thecls) PrimitiveCDestroy((ClientData) thecls); + if (theobj) PrimitiveCDestroy((ClientData) theobj); + + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + DECR_REF_COUNT(XOTclGlobalObjs[i]); + } + FREE(Tcl_Obj **, XOTclGlobalObjs); + FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); + ObjectSystemFree(interp, osPtr); + + return XOTclErrMsg(interp, "Creation of object system failed", TCL_STATIC); + } + + theobj->osPtr = osPtr; + thecls->osPtr = osPtr; + osPtr->rootClass = theobj; + osPtr->rootMetaClass = thecls; + + theobj->object.flags |= XOTCL_IS_ROOT_CLASS; + thecls->object.flags |= XOTCL_IS_ROOT_META_CLASS; + + ObjectSystemAdd(interp, osPtr); + + AddInstance((XOTclObject*)theobj, thecls); + AddInstance((XOTclObject*)thecls, thecls); + AddSuper(thecls, theobj); + + return TCL_OK; +} + +/* +xotclCmd deprecated XOTclDeprecatedCmd { + {-argName "what" -required 1} + {-argName "oldCmd" -required 1} + {-argName "newCmd" -required 0} +} +*/ +/* + * Prints a msg to the screen that oldCmd is deprecated + * optinal: give a new cmd + */ +static int +XOTclDeprecatedCmd(Tcl_Interp *interp, CONST char *what, CONST char *oldCmd, CONST char *newCmd) { + fprintf(stderr, "**\n**\n** The %s <%s> is deprecated.\n", what, oldCmd); + if (newCmd) + fprintf(stderr, "** Use <%s> instead.\n", newCmd); + fprintf(stderr, "**\n"); + return TCL_OK; +} + +/* +xotclCmd dispatch XOTclDispatchCmd { + {-argName "object" -required 1 -type object} + {-argName "-objscope"} + {-argName "command" -required 1 -type tclobj} + {-argName "args" -type args} +} +*/ +static int +XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, + Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]) { + int result; + CONST char *methodName = ObjStr(command); + register CONST char *n = methodName + strlen(methodName); + + /* fprintf(stderr, "Dispatch obj=%s, o=%p cmd m='%s'\n", objectName(object), object, methodName);*/ + + /* + * If the specified method is a fully qualified cmd name like + * e.g. ::nsf::cmd::Class::alloc, this method is called on the + * specified , no matter whether it was registered on + * it. + */ + + /*search for last '::'*/ + while ((*n != ':' || *(n-1) != ':') && n-1 > methodName) {n--; } + if (*n == ':' && n > methodName && *(n-1) == ':') {n--;} + + if ((n-methodName)>1 || *methodName == ':') { + Tcl_DString parentNSName, *dsp = &parentNSName; + Tcl_Namespace *nsPtr; + Tcl_Command cmd, importedCmd; + CONST char *parentName, *tail = n+2; + DSTRING_INIT(dsp); + + /* + * We have an absolute name. We assume, the name is the name of a + * tcl command, that will be dispatched. If "withObjscope is + * specified, a callstack frame is pushed to make instvars + * accessible for the command. + */ + + /*fprintf(stderr, "colon name %s\n", tail);*/ + if (n-methodName != 0) { + Tcl_DStringAppend(dsp, methodName, (n-methodName)); + parentName = Tcl_DStringValue(dsp); + nsPtr = Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + DSTRING_FREE(dsp); + } else { + nsPtr = Tcl_FindNamespace(interp, "::", (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + } + if (!nsPtr) { + return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", + methodName, "'", (char *) NULL); + } + cmd = FindMethod(nsPtr, tail); + if (cmd && (importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + /*fprintf(stderr, " .... findmethod '%s' in %s returns %p\n", tail, nsPtr->fullName, cmd);*/ + + if (cmd == NULL) { + return XOTclVarErrMsg(interp, "cannot lookup command '", + tail, "'", (char *) NULL); + } + { Tcl_CallFrame frame, *framePtr = &frame; + + if (withObjscope) { + XOTcl_PushFrameObj(interp, object, framePtr); + } + /* + * Since we know, that we are always called with a full argument + * vector, we can include the cmd name in the objv by using + * nobjv-1; this way, we avoid a memcpy() + */ + + result = MethodDispatch((ClientData)object, interp, + nobjc+1, nobjv-1, cmd, object, + NULL /*XOTclClass *cl*/, tail, + XOTCL_CSC_TYPE_PLAIN); + if (withObjscope) { + XOTcl_PopFrameObj(interp, framePtr); + } + } + } else { + /* + * No colons in command name, use method from the precedence + * order, with filters etc. -- strictly speaking unneccessary, + * since we could dispatch the method also without + * XOTclDispatchCmd(), but it can be used to invoke protected + * methods. 'withObjscope' is here a no-op. + */ + Tcl_Obj *arg; + Tcl_Obj *CONST *objv; + + if (nobjc >= 1) { + arg = nobjv[0]; + objv = nobjv+1; + } else { + arg = NULL; + objv = NULL; + } + result = XOTclCallMethodWithArgs((ClientData)object, interp, command, arg, + nobjc, objv, XOTCL_CM_NO_UNKNOWN); + } + + return result; +} + +/* +xotclCmd colon XOTclColonCmd { + {-argName "args" -type allargs} +} +*/ +static int XOTclColonCmd(Tcl_Interp *interp, int nobjc, Tcl_Obj *CONST nobjv[]) { + XOTclObject *self = GetSelfObj(interp); + if (!self) { + return XOTclVarErrMsg(interp, "Cannot resolve 'self', probably called outside the context of an XOTcl Object", + (char *) NULL); + } + /*fprintf(stderr, "Colon dispatch %s on %s\n", ObjStr(nobjv[0]), objectName(self));*/ + + return ObjectDispatch(self, interp, nobjc, nobjv, XOTCL_CM_NO_SHIFT); +} + +/* +xotclCmd existsvar XOTclExistsVarCmd { + {-argName "object" -required 1 -type object} + {-argName "var" -required 1} +} +*/ +static int XOTclExistsVarCmd(Tcl_Interp *interp, XOTclObject *object, CONST char *varName) { + if (CheckVarName(interp, varName) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), varExists(interp, object, varName, NULL, 1, 1)); + return TCL_OK; +} + + +/* +xotclCmd finalize XOTclFinalizeObjCmd { +} +*/ +/* + * ::nsf::finalize command + */ +static int +XOTclFinalizeObjCmd(Tcl_Interp *interp) { + int result; + + /*fprintf(stderr, "+++ call tcl-defined exit handler\n"); */ + +#if defined(NSF_PROFILE) + XOTclProfilePrintData(interp); +#endif + /* + * evaluate user-defined exit handler + */ + result = Tcl_Eval(interp, "::nsf::__exitHandler"); + + if (result != TCL_OK) { + fprintf(stderr, "User defined exit handler contains errors!\n" + "Error in line %d: %s\nExecution interrupted.\n", + Tcl_GetErrorLine(interp), ObjStr(Tcl_GetObjResult(interp))); + } + + ObjectSystemsCleanup(interp); + +#ifdef DO_CLEANUP + /*fprintf(stderr, "CLEANUP TOP NS\n");*/ + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "", 1); + Tcl_DeleteNamespace(RUNTIME_STATE(interp)->XOTclClassesNS); + Tcl_DeleteNamespace(RUNTIME_STATE(interp)->XOTclNS); +#endif + + return TCL_OK; +} + +/* +xotclCmd forward XOTclForwardCmd { + {-argName "object" -required 1 -type object} + {-argName "-per-object"} + {-argName "method" -required 1 -type tclobj} + {-argName "-default" -nrargs 1 -type tclobj} + {-argName "-earlybinding"} + {-argName "-methodprefix" -nrargs 1 -type tclobj} + {-argName "-objscope"} + {-argName "-onerror" -nrargs 1 -type tclobj} + {-argName "-verbose"} + {-argName "target" -type tclobj} + {-argName "args" -type args} +} +*/ +static int XOTclForwardCmd(Tcl_Interp *interp, + XOTclObject *object, int withPer_object, + Tcl_Obj *methodObj, + Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, + int withObjscope, Tcl_Obj *withOnerror, int withVerbose, + Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]) { + ForwardCmdClientData *tcd = NULL; + int result; + + result = forwardProcessOptions(interp, methodObj, + withDefault, withEarlybinding, withMethodprefix, + withObjscope, withOnerror, withVerbose, + target, nobjc, nobjv, &tcd); + if (result == TCL_OK) { + CONST char *methodName = NSTail(ObjStr(methodObj)); + XOTclClass *cl = + (withPer_object || ! XOTclObjectIsClass(object)) ? + NULL : (XOTclClass *)object; + + tcd->object = object; + if (cl == NULL) { + result = XOTclAddObjectMethod(interp, (XOTcl_Object *)object, methodName, + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); + } else { + result = XOTclAddClassMethod(interp, (XOTcl_Class*)cl, methodName, + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); + } + if (result == TCL_OK) { + result = ListMethodHandle(interp, object, cl == NULL, methodName); + } + } + + if (result != TCL_OK) { + forwardCmdDeleteProc((ClientData)tcd); + } + return result; +} + +/* +xotclCmd importvar XOTclImportvarCmd { + {-argName "object" -type object} + {-argName "args" -type args} +} +*/ +static int +XOTclImportvar(Tcl_Interp *interp, XOTclObject *object, const char *cmdName, int objc, Tcl_Obj *CONST objv[]) { + int i, result = TCL_OK; + + for (i=0; iparsedParamPtr) { + /*fprintf(stderr, " %s invalidate %p\n", className(cl), cl->parsedParamPtr);*/ + ParsedParamFree(cl->parsedParamPtr); + cl->parsedParamPtr = NULL; + } + return TCL_OK; +} + +/* +xotclCmd is XOTclIsCmd { + {-argName "-complain"} + {-argName "constraint" -required 1 -type tclobj} + {-argName "value" -required 1 -type tclobj} +} +*/ +static int XOTclIsCmd(Tcl_Interp *interp, int withComplain, Tcl_Obj *constraintObj, Tcl_Obj *valueObj) { + XOTclParam *paramPtr = NULL; + int result; + + result = Parametercheck(interp, constraintObj, valueObj, "value:", 1, ¶mPtr); + + if (paramPtr == NULL) { + /* + * We could not convert the arguments. Even with noComplain, we + * report the invalid converter spec as exception + */ + return TCL_ERROR; + } + + if (paramPtr->converter == convertViaCmd + && (withComplain == 0 || result == TCL_OK)) { + Tcl_ResetResult(interp); + } + + if (withComplain == 0) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); + result = TCL_OK; + } else if (result == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } + + return result; +} + +/* +xotclCmd isobject XOTclIsObjectCmd { + {-argName "object" -required 1 -type tclobj} +} +*/ +static int XOTclIsObjectCmd(Tcl_Interp *interp, Tcl_Obj *valueObj) { + XOTclObject *object; + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), GetObjectFromObj(interp, valueObj, &object) == TCL_OK); + return TCL_OK; +} + + +/* +xotclCmd method XOTclMethodCmd { + {-argName "object" -required 1 -type object} + {-argName "-inner-namespace"} + {-argName "-per-object"} + {-argName "-public"} + {-argName "name" -required 1 -type tclobj} + {-argName "args" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} + {-argName "-precondition" -nrargs 1 -type tclobj} + {-argName "-postcondition" -nrargs 1 -type tclobj} +} +*/ +static int XOTclMethodCmd(Tcl_Interp *interp, XOTclObject *object, + int withInner_namespace, int withPer_object, int withPublic, + Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { + XOTclClass *cl = + (withPer_object || ! XOTclObjectIsClass(object)) ? + NULL : (XOTclClass *)object; + + if (cl == 0) { + requireObjNamespace(interp, object); + } + return MakeMethod(interp, object, cl, nameObj, args, body, + withPrecondition, withPostcondition, + withPublic, withInner_namespace); +} + +/* +xotclCmd methodproperty XOTclMethodPropertyCmd { + {-argName "object" -required 1 -type object} + {-argName "-per-object"} + {-argName "methodName" -required 1 -type tclobj} + {-argName "methodproperty" -required 1 -type "class-only|protected|redefine-protected|returns|slotobj"} + {-argName "value" -type tclobj} +} +*/ +static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, + Tcl_Obj *methodObj, int methodproperty, Tcl_Obj *valueObj) { + CONST char *methodName = ObjStr(methodObj); + Tcl_Command cmd = NULL; + + /*fprintf(stderr, "methodProperty for method '%s' prop %d value %s\n", + methodName, methodproperty, valueObj ? ObjStr(valueObj) : "NULL");*/ + + if (*methodName == ':') { + cmd = Tcl_GetCommandFromObj(interp, methodObj); + if (!cmd) { + return XOTclVarErrMsg(interp, "Cannot lookup object method '", + methodName, "' for object ", objectName(object), + (char *) NULL); + } + } else { + XOTclClass *cl; + + if (withPer_object) { + cl = NULL; + } else { + cl = XOTclObjectIsClass(object) ? (XOTclClass *)object : NULL; + } + + if (cl == NULL) { + if (object->nsPtr) + cmd = FindMethod(object->nsPtr, methodName); + if (!cmd) { + return XOTclVarErrMsg(interp, "Cannot lookup object method '", + methodName, "' for object ", objectName(object), + (char *) NULL); + } + } else { + if (cl->nsPtr) + cmd = FindMethod(cl->nsPtr, methodName); + if (!cmd) + return XOTclVarErrMsg(interp, "Cannot lookup method '", + methodName, "' from class ", objectName(object), + (char *) NULL); + } + } + + switch (methodproperty) { + case MethodpropertyClass_onlyIdx: /* fall through */ + case MethodpropertyProtectedIdx: /* fall through */ + case MethodpropertyRedefine_protectedIdx: + { + int flag = methodproperty == MethodpropertyProtectedIdx ? + XOTCL_CMD_PROTECTED_METHOD : + methodproperty == MethodpropertyRedefine_protectedIdx ? + XOTCL_CMD_REDEFINE_PROTECTED_METHOD + :XOTCL_CMD_CLASS_ONLY_METHOD; + + if (valueObj) { + int bool, result; + result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); + if (result != TCL_OK) { + return result; + } + if (bool) { + Tcl_Command_flags(cmd) |= flag; + } else { + Tcl_Command_flags(cmd) &= ~flag; + } + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), (Tcl_Command_flags(cmd) & flag) != 0); + break; + } + case MethodpropertySlotobjIdx: + case MethodpropertyReturnsIdx: + { + XOTclParamDefs *paramDefs; + Tcl_Obj **objPtr; + + if (valueObj == NULL && methodproperty == MethodpropertySlotobjIdx) { + return XOTclVarErrMsg(interp, "Option 'slotobj' of method ", methodName, + " requires argument '", (char *) NULL); + } + + paramDefs = ParamDefsGet(cmd); + /*fprintf(stderr, "MethodProperty, ParamDefsGet cmd %p paramDefs %p returns %p\n", + cmd, paramDefs, paramDefs?paramDefs->returns:NULL);*/ + + if (paramDefs == NULL) { + paramDefs = ParamDefsNew(); + ParamDefsStore(interp, cmd, paramDefs); + /*fprintf(stderr, "new param defs %p for cmd %p %s\n", paramDefs, cmd, methodName);*/ + } + objPtr = methodproperty == MethodpropertySlotobjIdx ? ¶mDefs->slotObj : ¶mDefs->returns; + if (valueObj == NULL) { + /* must be a returns query */ + Tcl_SetObjResult(interp, *objPtr ? *objPtr : XOTclGlobalObjs[XOTE_EMPTY]); + } else { + const char *valueString = ObjStr(valueObj); + /* Set a new value; if there is already a value, free it */ + if (*objPtr) { + DECR_REF_COUNT(*objPtr); + } + if (*valueString == '\0') { + /* set the value to NULL */ + *objPtr = NULL; + } else { + *objPtr = valueObj; + INCR_REF_COUNT(*objPtr); + } + } + break; + } + } + + return TCL_OK; +} + +/* +xotclCmd my XOTclMyCmd { + {-argName "-local"} + {-argName "method" -required 1 -type tclobj} + {-argName "args" -type args} +} +*/ +static int XOTclMyCmd(Tcl_Interp *interp, int withLocal, Tcl_Obj *methodObj, int nobjc, Tcl_Obj *CONST nobjv[]) { + XOTclObject *self = GetSelfObj(interp); + int result; + + if (!self) { + return XOTclVarErrMsg(interp, "Cannot resolve 'self', probably called outside the context of an XOTcl Object", + (char *) NULL); + } + + if (withLocal) { + XOTclClass *cl = self->cl; + CONST char *methodName = ObjStr(methodObj); + Tcl_Command cmd = FindMethod(cl->nsPtr, methodName); + if (cmd == NULL) { + return XOTclVarErrMsg(interp, objectName(self), + ": unable to dispatch local method '", + methodName, "' in class ", className(cl), + (char *) NULL); + } + result = MethodDispatch((ClientData)self, interp, nobjc+2, nobjv, cmd, self, cl, + methodName, 0); + } else { + result = callMethod((ClientData)self, interp, methodObj, nobjc+2, nobjv, 0); + } + return result; +} + +/* +xotclCmd namespace_copycmds XOTclNSCopyCmds { + {-argName "fromNs" -required 1 -type tclobj} + {-argName "toNs" -required 1 -type tclobj} +} +*/ +static int XOTclNSCopyCmds(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs) { + Tcl_Command cmd; + Tcl_Obj *newFullCmdName, *oldFullCmdName; + CONST char *newName, *oldName, *name; + Tcl_Namespace *fromNsPtr, *toNsPtr; + Tcl_HashTable *cmdTable; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + XOTclObject *object; + XOTclClass *cl; + int fromClassNS; + + fromNsPtr = ObjFindNamespace(interp, fromNs); + if (!fromNsPtr) + return TCL_OK; + + name = ObjStr(fromNs); + + /* check, if we work on an object or class namespace */ + object = GetObjectFromNsName(interp, name, &fromClassNS); + + if (object == NULL) { + return XOTclVarErrMsg(interp, "argument 1 '", ObjStr(fromNs), "' is not an object", + NULL); + } + + cl = fromClassNS ? (XOTclClass *)object : NULL; + + /* object = XOTclpGetObject(interp, ObjStr(fromNs));*/ + + toNsPtr = ObjFindNamespace(interp, toNs); + if (!toNsPtr) + return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ", + ObjStr(toNs), " does not exist", (char *) NULL); + /* + * copy all procs & commands in the ns + */ + cmdTable = Tcl_Namespace_cmdTable(fromNsPtr); + hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + while (hPtr) { + /*fprintf(stderr, "copy cmdTable = %p, first=%p\n", cmdTable, hPtr);*/ + name = Tcl_GetHashKey(cmdTable, hPtr); + + /* + * construct full cmd names + */ + newFullCmdName = Tcl_NewStringObj(toNsPtr->fullName, -1); + oldFullCmdName = Tcl_NewStringObj(fromNsPtr->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); + + /*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 scripted method 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 (CmdIsProc(cmd)) { + Proc *procPtr = (Proc*) Tcl_Command_objClientData(cmd); + Tcl_Obj *arglistObj; + int result; + + /* + * Build a list containing the arguments of the proc + */ + result = ListCmdParams(interp, cmd, oldName, 0); + if (result != TCL_OK) { + return result; + } + + arglistObj = Tcl_GetObjResult(interp); + INCR_REF_COUNT(arglistObj); + + if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { + Tcl_DString ds, *dsPtr = &ds; + + if (cl) { + /* XOTcl class-methods */ + XOTclProcAssertion *procs; + procs = cl->opt ? AssertionFindProcs(cl->opt->assertions, name) : 0; + + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, "::nsf::method"); + Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(toNsPtr->fullName)); + 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 { + /* XOTcl object-methods */ + XOTclObject *object = XOTclpGetObject(interp, fromNsPtr->fullName); + XOTclProcAssertion *procs; + + if (object) { + procs = object->opt ? AssertionFindProcs(object->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); + } + + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, "::nsf::method"); + Tcl_DStringAppendElement(dsPtr, toNsPtr->fullName); + Tcl_DStringAppendElement(dsPtr, "-per-object"); + Tcl_DStringAppendElement(dsPtr, name); + Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); + Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); + if (procs) { + XOTclRequireObjectOpt(object); + 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); + } + } 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_CMD_NONLEAF_METHOD) { + /* if client data is 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_CMD_NONLEAF_METHOD) { + Tcl_CreateCommand(interp, newName, Tcl_Command_proc(cmd), + Tcl_Command_clientData(cmd), deleteProc); + } + } + } + } + hPtr = Tcl_NextHashEntry(&hSrch); + DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); + } + return TCL_OK; +} + +/* +xotclCmd namespace_copyvars XOTclNSCopyVars { + {-argName "fromNs" -required 1 -type tclobj} + {-argName "toNs" -required 1 -type tclobj} +} +*/ +static int +XOTclNSCopyVars(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs) { + Tcl_Namespace *fromNsPtr, *toNsPtr; + Var *varPtr = NULL; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + TclVarHashTable *varTable; + XOTclObject *object, *destObject; + CONST char *destFullName; + Tcl_Obj *destFullNameObj; + Tcl_CallFrame frame, *framePtr = &frame; + Tcl_Obj *varNameObj = NULL; + + fromNsPtr = ObjFindNamespace(interp, fromNs); + /*fprintf(stderr, "copyvars from %s to %s, ns=%p\n", ObjStr(objv[1]), ObjStr(objv[2]), ns);*/ + + if (fromNsPtr) { + toNsPtr = ObjFindNamespace(interp, toNs); + if (!toNsPtr) + return XOTclVarErrMsg(interp, "CopyVars: Destination namespace ", + ObjStr(toNs), " does not exist", (char *) NULL); + + object = XOTclpGetObject(interp, ObjStr(fromNs)); + destFullName = toNsPtr->fullName; + destFullNameObj = Tcl_NewStringObj(destFullName, -1); + INCR_REF_COUNT(destFullNameObj); + varTable = Tcl_Namespace_varTable(fromNsPtr); + Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, toNsPtr, 0); + } else { + XOTclObject *newObject; + if (GetObjectFromObj(interp, fromNs, &object) != TCL_OK) { + return XOTclVarErrMsg(interp, "CopyVars: Origin object/namespace ", + ObjStr(fromNs), " does not exist", (char *) NULL); + } + if (GetObjectFromObj(interp, toNs, &newObject) != TCL_OK) { + return XOTclVarErrMsg(interp, "CopyVars: Destination object/namespace ", + ObjStr(toNs), " does not exist", (char *) NULL); + } + varTable = object->varTable; + destFullNameObj = newObject->cmdName; + destFullName = ObjStr(destFullNameObj); + } + + destObject = XOTclpGetObject(interp, destFullName); + + /* copy all vars in the ns */ + hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : NULL; + while (hPtr) { + + 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 (object) { + /* fprintf(stderr, "copy in obj %s var %s val '%s'\n", objectName(object), ObjStr(varNameObj), + ObjStr(valueOfVar(Tcl_Obj, varPtr, objPtr)));*/ + + /* can't rely on "set", if there are multiple object systems */ + setInstVar(interp, destObject, varNameObj, valueOfVar(Tcl_Obj, varPtr, objPtr)); + } 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); + + if (TclIsVarScalar(eltVar)) { + if (object) { + XOTcl_ObjSetVar2((XOTcl_Object*)destObject, interp, varNameObj, eltNameObj, + valueOfVar(Tcl_Obj, eltVar, objPtr), 0); + } 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 (fromNsPtr) { + DECR_REF_COUNT(destFullNameObj); + Tcl_PopCallFrame(interp); + } + return TCL_OK; +} + +/* +xotclCmd __qualify XOTclQualifyObjCmd { + {-argName "name" -required 1 -type tclobj} +} +*/ +static int XOTclQualifyObjCmd(Tcl_Interp *interp, Tcl_Obj *nameObj) { + CONST char *nameString = ObjStr(nameObj); + + if (isAbsolutePath(nameString)) { + Tcl_SetObjResult(interp, nameObj); + } else { + Tcl_SetObjResult(interp, NameInNamespaceObj(interp, nameString, callingNameSpace(interp))); + } + return TCL_OK; +} + +/* +xotclCmd relation XOTclRelationCmd { + {-argName "object" -type object} + {-argName "relationtype" -required 1 -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"} + {-argName "value" -required 0 -type tclobj} +} +*/ +static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, + int relationtype, Tcl_Obj *valueObj) { + int oc; Tcl_Obj **ov; + XOTclObject *nObject = NULL; + XOTclClass *cl = NULL; + XOTclObjectOpt *objopt = NULL; + XOTclClassOpt *clopt = NULL, *nclopt = NULL; + int i; + + /* fprintf(stderr, "XOTclRelationCmd %s rel=%d val='%s'\n", + objectName(object), relationtype, valueObj ? ObjStr(valueObj) : "NULL");*/ + + if (relationtype == RelationtypeClass_mixinIdx || + relationtype == RelationtypeClass_filterIdx) { + if (XOTclObjectIsClass(object)) { + cl = (XOTclClass *)object; + } else { + /* fall back to per-object case */ + relationtype = (relationtype == RelationtypeClass_mixinIdx) ? + RelationtypeObject_mixinIdx : + RelationtypeObject_filterIdx ; + } + } + + switch (relationtype) { + case RelationtypeObject_filterIdx: + case RelationtypeObject_mixinIdx: + if (valueObj == NULL) { + objopt = object->opt; + switch (relationtype) { + case RelationtypeObject_mixinIdx: + return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; + case RelationtypeObject_filterIdx: + return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; + } + } + if (Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK) + return TCL_ERROR; + objopt = XOTclRequireObjectOpt(object); + break; + + case RelationtypeClass_mixinIdx: + case RelationtypeClass_filterIdx: + + if (valueObj == NULL) { + clopt = cl->opt; + switch (relationtype) { + case RelationtypeClass_mixinIdx: + return clopt ? MixinInfo(interp, clopt->classmixins, NULL, 1, NULL) : TCL_OK; + case RelationtypeClass_filterIdx: + return objopt ? FilterInfo(interp, clopt->classfilters, NULL, 1, 0) : TCL_OK; + } + } + + if (Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK) + return TCL_ERROR; + clopt = XOTclRequireClassOpt(cl); + break; + + case RelationtypeSuperclassIdx: + if (!XOTclObjectIsClass(object)) + return XOTclObjErrType(interp, object->cmdName, "class", "relationtype"); + cl = (XOTclClass *)object; + if (valueObj == NULL) { + return ListSuperclasses(interp, cl, NULL, 0); + } + if (Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK) + return TCL_ERROR; + return SuperclassAdd(interp, cl, oc, ov, valueObj, cl->object.cl); + + case RelationtypeClassIdx: + if (valueObj == NULL) { + Tcl_SetObjResult(interp, object->cl->object.cmdName); + return TCL_OK; + } + GetClassFromObj(interp, valueObj, &cl, object->cl); + if (!cl) return XOTclErrBadVal(interp, "class", "a class", objectName(object)); + return changeClass(interp, object, cl); + + case RelationtypeRootclassIdx: + { + XOTclClass *metaClass; + + if (!XOTclObjectIsClass(object)) + return XOTclObjErrType(interp, object->cmdName, "class", "relationtype"); + cl = (XOTclClass *)object; + + if (valueObj == NULL) { + return XOTclVarErrMsg(interp, "metaclass must be specified as third argument", + (char *) NULL); + } + GetClassFromObj(interp, valueObj, &metaClass, NULL); + if (!metaClass) return XOTclObjErrType(interp, valueObj, "class", ""); + + cl->object.flags |= XOTCL_IS_ROOT_CLASS; + metaClass->object.flags |= XOTCL_IS_ROOT_META_CLASS; + + return TCL_OK; + + /* todo: + need to remove these properties? + allow to delete a classystem at runtime? + */ + } + } + + switch (relationtype) { + case RelationtypeObject_mixinIdx: + { + XOTclCmdList *newMixinCmdList = NULL; + + for (i = 0; i < oc; i++) { + if (MixinAdd(interp, &newMixinCmdList, ov[i], object->cl->object.cl) != TCL_OK) { + CmdListRemoveList(&newMixinCmdList, GuardDel); + return TCL_ERROR; + } + } + + 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(object->id, clopt->isObjectMixinOf); + if (del) { + /* fprintf(stderr, "Removing object %s from isObjectMixinOf of class %s\n", + objectName(object), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ + del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } + } + } + CmdListRemoveList(&objopt->mixins, GuardDel); + } + + object->flags &= ~XOTCL_MIXIN_ORDER_VALID; + /* + * since mixin procs may be used as filters -> we have to invalidate + */ + object->flags &= ~XOTCL_FILTER_ORDER_VALID; + + /* + * now add the specified mixins + */ + objopt->mixins = newMixinCmdList; + for (i = 0; i < oc; i++) { + Tcl_Obj *ocl = NULL; + + /* fprintf(stderr, "Added to mixins of %s: %s\n", objectName(object), ObjStr(ov[i])); */ + Tcl_ListObjIndex(interp, ov[i], 0, &ocl); + GetObjectFromObj(interp, ocl, &nObject); + if (nObject) { + /* fprintf(stderr, "Registering object %s to isObjectMixinOf of class %s\n", + objectName(object), objectName(nObject)); */ + nclopt = XOTclRequireClassOpt((XOTclClass*)nObject); + CmdListAdd(&nclopt->isObjectMixinOf, object->id, NULL, /*noDuplicates*/ 1); + } /* else fprintf(stderr, "Problem registering %s as a mixinof of %s\n", + ObjStr(ov[i]), className(cl)); */ + } + + MixinComputeDefined(interp, object); + FilterComputeDefined(interp, object); + break; + } + + case RelationtypeObject_filterIdx: + + if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); + + object->flags &= ~XOTCL_FILTER_ORDER_VALID; + for (i = 0; i < oc; i ++) { + if (FilterAdd(interp, &objopt->filters, ov[i], object, 0) != TCL_OK) + return TCL_ERROR; + } + /*FilterComputeDefined(interp, object);*/ + break; + + case RelationtypeClass_mixinIdx: + { + XOTclCmdList *newMixinCmdList = NULL; + + for (i = 0; i < oc; i++) { + if (MixinAdd(interp, &newMixinCmdList, ov[i], cl->object.cl) != TCL_OK) { + CmdListRemoveList(&newMixinCmdList, GuardDel); + return TCL_ERROR; + } + } + if (clopt->classmixins) { + RemoveFromClassMixinsOf(cl->object.id, clopt->classmixins); + CmdListRemoveList(&clopt->classmixins, GuardDel); + } + + MixinInvalidateObjOrders(interp, cl); + /* + * since mixin procs may be used as filters, + * we have to invalidate the filters as well + */ + FilterInvalidateObjOrders(interp, cl); + clopt->classmixins = newMixinCmdList; + for (i = 0; i < oc; i++) { + Tcl_Obj *ocl = NULL; + /* fprintf(stderr, "Added to classmixins of %s: %s\n", + className(cl), ObjStr(ov[i])); */ + + Tcl_ListObjIndex(interp, ov[i], 0, &ocl); + GetObjectFromObj(interp, ocl, &nObject); + if (nObject) { + /* fprintf(stderr, "Registering class %s to isClassMixinOf of class %s\n", + className(cl), objectName(nObject)); */ + nclopt = XOTclRequireClassOpt((XOTclClass*) nObject); + CmdListAdd(&nclopt->isClassMixinOf, cl->object.id, NULL, /*noDuplicates*/ 1); + } /* else fprintf(stderr, "Problem registering %s as a class-mixin of %s\n", + ObjStr(ov[i]), className(cl)); */ + } + break; + } + + case RelationtypeClass_filterIdx: + + if (clopt->classfilters) CmdListRemoveList(&clopt->classfilters, GuardDel); + + FilterInvalidateObjOrders(interp, cl); + for (i = 0; i < oc; i ++) { + if (FilterAdd(interp, &clopt->classfilters, ov[i], 0, cl) != TCL_OK) + return TCL_ERROR; + } + break; + + } + return TCL_OK; +} + +/* +xotclCmd current XOTclCurrentCmd { + {-argName "currentoption" -required 0 -type "proc|method|object|class|activelevel|args|activemixin|calledproc|calledmethod|calledclass|callingproc|callingmethod|callingclass|callinglevel|callingobject|filterreg|isnextcall|next"} +} +*/ +static int XOTclCurrentCmd(Tcl_Interp *interp, int selfoption) { + XOTclObject *object = GetSelfObj(interp); + XOTclCallStackContent *cscPtr; + int result = TCL_OK; + + /*fprintf(stderr, "getSelfObj returns %p\n", object); tcl85showStack(interp);*/ + + if (selfoption == 0 || selfoption == CurrentoptionObjectIdx) { + if (object) { + Tcl_SetObjResult(interp, object->cmdName); + return TCL_OK; + } else { + return XOTclVarErrMsg(interp, "No current object", (char *) NULL); + } + } + + if (!object && selfoption != CurrentoptionCallinglevelIdx) { + return XOTclVarErrMsg(interp, "No current object", (char *) NULL); + } + + switch (selfoption) { + case CurrentoptionMethodIdx: /* fall through */ + case CurrentoptionProcIdx: + cscPtr = CallStackGetTopFrame(interp, NULL); + if (cscPtr) { + CONST char *procName = Tcl_GetCommandName(interp, cscPtr->cmdPtr); + Tcl_SetResult(interp, (char *)procName, TCL_VOLATILE); + } else { + return XOTclVarErrMsg(interp, "Can't find proc", (char *) NULL); + } + break; + + case CurrentoptionClassIdx: /* class subcommand */ + cscPtr = CallStackGetTopFrame(interp, NULL); + Tcl_SetObjResult(interp, cscPtr->cl ? cscPtr->cl->object.cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + break; + + case CurrentoptionActivelevelIdx: + Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); + break; + + case CurrentoptionArgsIdx: { + int nobjc; + Tcl_Obj **nobjv; + Tcl_CallFrame *topFramePtr; + + cscPtr = CallStackGetTopFrame(interp, &topFramePtr); + if (cscPtr->objv) { + nobjc = cscPtr->objc; + nobjv = cscPtr->objv; + } else { + nobjc = Tcl_CallFrame_objc(topFramePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(topFramePtr); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1)); + break; + } + + case CurrentoptionActivemixinIdx: { + XOTclObject *object = NULL; + if (RUNTIME_STATE(interp)->cmdPtr) { + object = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); + } + Tcl_SetObjResult(interp, object ? object->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + break; + } + + case CurrentoptionCalledprocIdx: + case CurrentoptionCalledmethodIdx: + cscPtr = CallStackFindActiveFilter(interp); + if (cscPtr) { + Tcl_SetObjResult(interp, cscPtr->filterStackEntry->calledProc); + } else { + result = XOTclVarErrMsg(interp, "called from outside of a filter", + (char *) NULL); + } + break; + + case CurrentoptionCalledclassIdx: + Tcl_SetResult(interp, className(FindCalledClass(interp, object)), TCL_VOLATILE); + break; + + case CurrentoptionCallingmethodIdx: + case CurrentoptionCallingprocIdx: + cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); + Tcl_SetResult(interp, cscPtr ? (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr) : "", + TCL_VOLATILE); + break; + + case CurrentoptionCallingclassIdx: + cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); + Tcl_SetObjResult(interp, cscPtr && cscPtr->cl ? cscPtr->cl->object.cmdName : + XOTclGlobalObjs[XOTE_EMPTY]); + break; + + case CurrentoptionCallinglevelIdx: + if (!object) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); + } + break; + + case CurrentoptionCallingobjectIdx: + cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); + Tcl_SetObjResult(interp, cscPtr ? cscPtr->self->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + break; + + case CurrentoptionFilterregIdx: + cscPtr = CallStackFindActiveFilter(interp); + if (cscPtr) { + Tcl_SetObjResult(interp, FilterFindReg(interp, object, cscPtr->cmdPtr)); + } else { + result = XOTclVarErrMsg(interp, + "called from outside of a filter", + (char *) NULL); + } + break; + + case CurrentoptionIsnextcallIdx: { + Tcl_CallFrame *framePtr; + cscPtr = CallStackGetTopFrame(interp, &framePtr); + framePtr = nextFrameOfType(Tcl_CallFrame_callerPtr(framePtr), FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD); + cscPtr = framePtr ? Tcl_CallFrame_clientData(framePtr) : NULL; + + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (cscPtr && (cscPtr->callType & XOTCL_CSC_CALL_IS_NEXT))); + break; + } + + case CurrentoptionNextIdx: + result = FindSelfNext(interp); + break; + } + + return result; +} + +/* +xotclCmd setvar XOTclSetVarCmd { + {-argName "object" -required 1 -type object} + {-argName "variable" -required 1 -type tclobj} + {-argName "value" -required 0 -type tclobj} +} +*/ +static int XOTclSetVarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *valueObj) { + if (CheckVarName(interp, ObjStr(variable)) != TCL_OK) { + return TCL_ERROR; + } + return setInstVar(interp, object, variable, valueObj); +} + +/* +xotclCmd setter XOTclSetterCmd { + {-argName "object" -required 1 -type object} + {-argName "-per-object"} + {-argName "parameter" -type tclobj} + } +*/ +static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, Tcl_Obj *parameter) { + XOTclClass *cl = (withPer_object || ! XOTclObjectIsClass(object)) ? NULL : (XOTclClass *)object; + CONST char *methodName = ObjStr(parameter); + SetterCmdClientData *setterClientData; + size_t j, length; + int result; + + if (*methodName == '-') { + return XOTclVarErrMsg(interp, + "method name \"", methodName, "\" must not start with a dash", + (char *) NULL); + + } + + setterClientData = NEW(SetterCmdClientData); + setterClientData->paramsPtr = NULL; + length = strlen(methodName); + + for (j=0; jparamsPtr = ParamsNew(1); + result = ParamParse(interp, "setter", parameter, + XOTCL_DISALLOWED_ARG_SETTER|XOTCL_ARG_HAS_DEFAULT, + setterClientData->paramsPtr, &possibleUnknowns, &plainParams); + + if (result != TCL_OK) { + setterCmdDeleteProc((ClientData)setterClientData); + return result; + } + methodName = setterClientData->paramsPtr->name; + } else { + setterClientData->paramsPtr = NULL; + } + + if (cl) { + result = XOTclAddClassMethod(interp, (XOTcl_Class *)cl, methodName, + (Tcl_ObjCmdProc*)XOTclSetterMethod, + (ClientData)setterClientData, setterCmdDeleteProc, 0); + } else { + result = XOTclAddObjectMethod(interp, (XOTcl_Object *)object, methodName, + (Tcl_ObjCmdProc*)XOTclSetterMethod, + (ClientData)setterClientData, setterCmdDeleteProc, 0); + } + if (result == TCL_OK) { + result = ListMethodHandle(interp, object, cl == NULL, methodName); + } else { + setterCmdDeleteProc((ClientData)setterClientData); + } + return result; +} + +typedef struct XOTclParamWrapper { + XOTclParam *paramPtr; + int refCount; + int canFree; +} XOTclParamWrapper; + +static Tcl_DupInternalRepProc ParamDupInteralRep; +static Tcl_FreeInternalRepProc ParamFreeInternalRep; +static Tcl_UpdateStringProc ParamUpdateString; + +static void ParamUpdateString(Tcl_Obj *objPtr) { + Tcl_Panic("%s of type %s should not be called", "updateStringProc", + objPtr->typePtr->name); +} + +static void ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { + Tcl_Panic("%s of type %s should not be called", "dupStringProc", + srcPtr->typePtr->name); +} + +static int ParamSetFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr); +static Tcl_ObjType paramObjType = { + "xotclParam", /* name */ + ParamFreeInternalRep, /* freeIntRepProc */ + ParamDupInteralRep, /* dupIntRepProc */ + ParamUpdateString, /* updateStringProc */ + ParamSetFromAny /* setFromAnyProc */ +}; + +static void +ParamFreeInternalRep( + register Tcl_Obj *objPtr) /* Param structure object with internal + * representation to free. */ +{ + XOTclParamWrapper *paramWrapperPtr = (XOTclParamWrapper *)objPtr->internalRep.twoPtrValue.ptr1; + + if (paramWrapperPtr != NULL) { + /* fprintf(stderr, "ParamFreeInternalRep freeing wrapper %p paramPtr %p refCount %dcanFree %d\n", + paramWrapperPtr, paramWrapperPtr->paramPtr, paramWrapperPtr->refCount, + paramWrapperPtr->canFree);*/ + + if (paramWrapperPtr->canFree) { + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); + } else { + paramWrapperPtr->refCount--; + } + } +} + +static int +ParamSetFromAny2( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + const char *varNamePrefix, /* shows up as varname in error message */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + XOTclParamWrapper *paramWrapperPtr = NEW(XOTclParamWrapper); + Tcl_Obj *fullParamObj = Tcl_NewStringObj(varNamePrefix, -1); + int result, possibleUnknowns = 0, plainParams = 0; + + paramWrapperPtr->paramPtr = ParamsNew(1); + paramWrapperPtr->refCount = 1; + paramWrapperPtr->canFree = 0; + /*fprintf(stderr, "allocating %p\n",paramWrapperPtr->paramPtr);*/ + + Tcl_AppendLimitedToObj(fullParamObj, ObjStr(objPtr), -1, INT_MAX, NULL); + INCR_REF_COUNT(fullParamObj); + result = ParamParse(interp, "valuecheck", fullParamObj, + XOTCL_DISALLOWED_ARG_VALUEECHECK /* disallowed options */, + paramWrapperPtr->paramPtr, &possibleUnknowns, &plainParams); + /* Here, we want to treat currently unknown user level converters as + error. + */ + if (paramWrapperPtr->paramPtr->flags & XOTCL_ARG_CURRENTLY_UNKNOWN) { + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); + result = TCL_ERROR; + } else if (result == TCL_OK) { + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (void *)paramWrapperPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = ¶mObjType; + } + + DECR_REF_COUNT(fullParamObj); + return result; +} + +static int +ParamSetFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + return ParamSetFromAny2(interp, "value:", objPtr); +} + +static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, + const char *varNamePrefix, int doCheck, XOTclParam **paramPtrPtr) { + XOTclParamWrapper *paramWrapperPtr; + Tcl_Obj *outObjPtr = NULL; + XOTclParam *paramPtr; + ClientData checkedData; + int result, flags = 0; + + /*fprintf(stderr, "ParamSetFromAny %s value %p %s\n", + ObjStr(objPtr), valueObj, ObjStr(valueObj));*/ + + if (objPtr->typePtr == ¶mObjType) { + paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; + } else { + result = ParamSetFromAny2(interp, varNamePrefix, objPtr); + if (result == TCL_OK) { + paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; + } else { + return XOTclVarErrMsg(interp, + "invalid value constraints \"", ObjStr(objPtr), "\"", + (char *) NULL); + } + } + paramPtr = paramWrapperPtr->paramPtr; + if (paramPtrPtr) *paramPtrPtr = paramPtr; + + /* if (!doCheck) { + outObjPtr = valueObj; + checkedData = ObjStr(valueObj); + return TCL_OK; + }*/ + + result = ArgumentCheck(interp, valueObj, paramPtr, doCheck, &flags, &checkedData, &outObjPtr); + + /*fprintf(stderr, "ParamSetFromAny paramPtr %p final refcount of wrapper %d can free %d\n", + paramPtr, paramWrapperPtr->refCount, paramWrapperPtr->canFree);*/ + + if (paramWrapperPtr->refCount == 0) { + /* fprintf(stderr, "ParamSetFromAny paramPtr %p manual free\n",paramPtr);*/ + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); + } else { + paramWrapperPtr->canFree = 1; + } + + if (flags & XOTCL_PC_MUST_DECR) { + DECR_REF_COUNT(outObjPtr); + } + + return result; +} + +/*************************** + * End generated XOTcl commands + ***************************/ + +/*************************** + * Begin Object Methods + ***************************/ +static int XOTclOAutonameMethod(Tcl_Interp *interp, XOTclObject *object, int withInstance, int withReset, + Tcl_Obj *nameObj) { + Tcl_Obj *autoname = AutonameIncr(interp, nameObj, object, withInstance, withReset); + 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; +} + +static int XOTclOCleanupMethod(Tcl_Interp *interp, XOTclObject *object) { + XOTclClass *cl = XOTclObjectToClass(object); + int softrecreate; + Tcl_Obj *savedNameObj; + +#if defined(OBJDELETION_TRACE) + fprintf(stderr, "+++ XOTclOCleanupMethod\n"); +#endif + PRINTOBJ("XOTclOCleanupMethod", object); + + savedNameObj = object->cmdName; + INCR_REF_COUNT(savedNameObj); + + /* save and pass around softrecreate*/ + softrecreate = object->flags & XOTCL_RECREATE && RUNTIME_STATE(interp)->doSoftrecreate; + + CleanupDestroyObject(interp, object, softrecreate); + CleanupInitObject(interp, object, object->cl, object->nsPtr, softrecreate); + + if (cl) { + CleanupDestroyClass(interp, cl, softrecreate, 1); + CleanupInitClass(interp, cl, cl->nsPtr, softrecreate, 1); + } + + DECR_REF_COUNT(savedNameObj); + return TCL_OK; +} + +static int +GetObjectParameterDefinition(Tcl_Interp *interp, CONST char *methodName, XOTclObject *object, + XOTclParsedParam *parsedParamPtr) { + int result; + Tcl_Obj *rawConfArgs; + + /* + * Parameter definitions are cached in the class, for which + * instances are created. The parameter definitions are flushed in + * the following situations: + * + * a) on class cleanup: ParsedParamFree(cl->parsedParamPtr) + * b) on class structure changes, + * c) when classmixins are added, + * d) when new slots are defined, + * e) when slots are removed + * + * When slot defaults or types are changed, the slots have to + * perform a manual "::nsf::invalidateobjectparameter $domain" + */ + + /* + * Check, if there is already a parameter definition available for + * creating objects of this class. + */ + if (object->cl->parsedParamPtr) { + parsedParamPtr->paramDefs = object->cl->parsedParamPtr->paramDefs; + parsedParamPtr->possibleUnknowns = object->cl->parsedParamPtr->possibleUnknowns; + result = TCL_OK; + } else { + /* + * There is no parameter definition available, get a new one in + * the the string representation. + */ + /*fprintf(stderr, "calling %s objectparameter\n", objectName(object));*/ + Tcl_Obj *methodObj = XOTclMethodObj(interp, object, XO_o_objectparameter_idx); + + if (methodObj) { + result = callMethod((ClientData) object, interp, methodObj, + 2, 0, XOTCL_CM_NO_PROTECT); + + if (result == TCL_OK) { + rawConfArgs = Tcl_GetObjResult(interp); + /*fprintf(stderr, ".... rawConfArgs for %s => %s\n", objectName(object), ObjStr(rawConfArgs));*/ + INCR_REF_COUNT(rawConfArgs); + + /* Parse the string representation to obtain the internal representation */ + result = ParamDefsParse(interp, methodName, rawConfArgs, XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER, parsedParamPtr); + if (result == TCL_OK) { + XOTclParsedParam *ppDefPtr = NEW(XOTclParsedParam); + ppDefPtr->paramDefs = parsedParamPtr->paramDefs; + ppDefPtr->possibleUnknowns = parsedParamPtr->possibleUnknowns; + object->cl->parsedParamPtr = ppDefPtr; + } + DECR_REF_COUNT(rawConfArgs); + } + } else { + parsedParamPtr->paramDefs = NULL; + parsedParamPtr->possibleUnknowns = 0; + result = TCL_OK; + } + } + return result; +} + +static int +XOTclOConfigureMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { + int result, i, remainingArgsc; + XOTclParsedParam parsedParam; + XOTclParam *paramPtr; + XOTclParamDefs *paramDefs; + Tcl_Obj *newValue; + parseContext pc; + Tcl_CallFrame frame, *framePtr = &frame; + +#if 0 + fprintf(stderr, "XOTclOConfigureMethod %s %d ",objectName(object), objc); + + for(i=0; iparamsPtr; paramPtr->name; paramPtr++, i++) { + + newValue = pc.full_objv[i]; + /*fprintf(stderr, "new Value of %s = %p '%s', type %s", + ObjStr(paramPtr->nameObj), + newValue, newValue ? ObjStr(newValue) : "(null)", paramPtr->type); */ + + if (newValue == XOTclGlobalObjs[XOTE___UNKNOWN__]) { + /* nothing to do here */ + continue; + } + + /* special setter due to relation handling */ + if (paramPtr->converter == convertToRelation) { + ClientData relIdx; + Tcl_Obj *relationObj = paramPtr->converterArg ? paramPtr->converterArg : paramPtr->nameObj, + *outObjPtr; + + result = convertToRelationtype(interp, relationObj, paramPtr, &relIdx, &outObjPtr); + + if (result == TCL_OK) { + result = XOTclRelationCmd(interp, object, PTR2INT(relIdx), newValue); + } + + if (result != TCL_OK) { + XOTcl_PopFrameObj(interp, framePtr); + parseContextRelease(&pc); + goto configure_exit; + } + /* done with relation handling */ + continue; + } + + /* special setter for init commands */ + if (paramPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_METHOD)) { + CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); + XOTclCallStackContent csc, *cscPtr = &csc; + Tcl_CallFrame frame2, *framePtr2 = &frame2; + + /* The current callframe of configure uses an objscope, such + that setvar etc. are able to access variables like "a" as a + local variable. However, in the init block, we do not like + that behavior, since this should look like like a proc body. + So we push yet another callframe without providing the + varframe. + + The new frame will have the namespace of the caller to avoid + the current objscope. XOTcl_PushFrameCsc() will establish + a CMETHOD frame. + */ + + Tcl_Interp_varFramePtr(interp) = varFramePtr->callerPtr; + CscInit(cscPtr, object, NULL /*cl*/, NULL/*cmd*/, XOTCL_CSC_TYPE_PLAIN); + XOTcl_PushFrameCsc(interp, cscPtr, framePtr2); + + if (paramPtr->flags & XOTCL_ARG_INITCMD) { + result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT); + + } else /* must be XOTCL_ARG_METHOD */ { + Tcl_Obj *ov[3]; + int oc = 0; + if (paramPtr->converterArg) { + /* if arg= was given, pass it as first argument */ + ov[0] = paramPtr->converterArg; + oc = 1; + } + if (paramPtr->nrArgs == 1) { + ov[oc] = newValue; + oc ++; + } + result = XOTclCallMethodWithArgs((ClientData) object, interp, paramPtr->nameObj, + ov[0], oc, &ov[1], 0); + } + /* + Pop previously stacked frame for eval context and set the + varFramePtr to the previous value. + */ + XOTcl_PopFrameCsc(interp, framePtr2); + CscFinish(interp, cscPtr); + Tcl_Interp_varFramePtr(interp) = varFramePtr; + + /*fprintf(stderr, "XOTclOConfigureMethod_ attribute %s evaluated %s => (%d)\n", + ObjStr(paramPtr->nameObj), ObjStr(newValue), result);*/ + + if (result != TCL_OK) { + XOTcl_PopFrameObj(interp, framePtr); + parseContextRelease(&pc); + goto configure_exit; + } + + if (paramPtr->flags & XOTCL_ARG_INITCMD && RUNTIME_STATE(interp)->doKeepinitcmd) { + Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, newValue, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + } + + /* done with init command handling */ + continue; + } + + /* set the variables unless the last argument of the definition is varArgs */ + if (i < paramDefs->nrParams || !pc.varArgs) { + /* standard setter */ +#if defined(CONFIGURE_ARGS_TRACE) + fprintf(stderr, "*** %s SET %s '%s'\n", objectName(object), ObjStr(paramPtr->nameObj), ObjStr(newValue)); +#endif + Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, newValue, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + } + } + + XOTcl_PopFrameObj(interp, framePtr); + + remainingArgsc = pc.objc - paramDefs->nrParams; + + /* + Call residualargs when we have varargs and left over arguments + */ + if (pc.varArgs && remainingArgsc > 0) { + Tcl_Obj *methodObj; + + if (CallDirectly(interp, object, XO_o_residualargs_idx, &methodObj)) { + i -= 2; + if (methodObj) {pc.full_objv[i] = methodObj;} + result = XOTclOResidualargsMethod(interp, object, remainingArgsc+1, pc.full_objv + i); + } else { + result = callMethod((ClientData) object, interp, + methodObj, remainingArgsc+2, pc.full_objv + i-1, 0); + } + if (result != TCL_OK) { + parseContextRelease(&pc); + goto configure_exit; + } + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); + } + + parseContextRelease(&pc); + + configure_exit: + return result; +} + +static int XOTclODestroyMethod(Tcl_Interp *interp, XOTclObject *object) { + PRINTOBJ("XOTclODestroyMethod", object); + + /*fprintf(stderr,"XOTclODestroyMethod %p %s flags %.6x activation %d cmd %p cmd->flags %.6x\n", + object, ((Command*)object->id)->flags == 0 ? objectName(object) : "(deleted)", + object->flags, object->activationCount, object->id, ((Command*)object->id)->flags);*/ + + /* + * XOTCL_DESTROY_CALLED might be set already be callDestroyMethod(), + * the implicit destroy calls. It is necessary to set it here for + * the explicit destroy calls in the script, which reach the + * Object->destroy. + */ + + if ((object->flags & XOTCL_DESTROY_CALLED) == 0) { + object->flags |= XOTCL_DESTROY_CALLED; + } + + if ((object->flags & XOTCL_DURING_DELETE) == 0) { + int result; + Tcl_Obj *methodObj; + + /*fprintf(stderr, " call dealloc on %p %s\n", object, + ((Command*)object->id)->flags == 0 ? objectName(object) : "(deleted)");*/ + + if (CallDirectly(interp, &object->cl->object, XO_c_dealloc_idx, &methodObj)) { + result = DoDealloc(interp, object); + } else { + /*fprintf(stderr, "call dealloc\n");*/ + result = XOTclCallMethodWithArgs((ClientData)object->cl, interp, methodObj, + object->cmdName, 1, NULL, 0); + if (result != TCL_OK) { + /* + * In case, the call of the dealloc method has failed above (e.g. NS_DYING), + * we have to call dealloc manually, otherwise we have a memory leak + */ + /*object->flags |= XOTCL_CMD_NOT_FOUND;*/ + /*fprintf(stderr, "*** dealloc failed for %p %s flags %.6x, retry\n", + object, objectName(object), object->flags);*/ + result = DoDealloc(interp, object); + } + } + return result; + } else { +#if defined(OBJDELETION_TRACE) + fprintf(stderr, " Object->destroy already during delete, don't call dealloc %p\n", object); +#endif + } + return TCL_OK; +} + +static int XOTclOExistsMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *var) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), varExists(interp, object, var, NULL, 1, 1)); + return TCL_OK; +} + +static int XOTclOFilterGuardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter, Tcl_Obj *guardObj) { + XOTclObjectOpt *opt = object->opt; + + if (opt && opt->filters) { + XOTclCmdList *h = CmdListFindNameInList(interp, filter, opt->filters); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, guardObj); + object->flags &= ~XOTCL_FILTER_ORDER_VALID; + return TCL_OK; + } + } + + return XOTclVarErrMsg(interp, "Filterguard: can't find filter ", + filter, " on ", objectName(object), (char *) NULL); +} + +/* + * Searches for filter on [self] and returns fully qualified name + * if it is not found it returns an empty string + */ +static int FilterSearchMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter) { + CONST char *filterName; + XOTclCmdList *cmdList; + XOTclClass *fcl; + + Tcl_ResetResult(interp); + + if (!(object->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, object); + if (!(object->flags & XOTCL_FILTER_ORDER_DEFINED)) + return TCL_OK; + + for (cmdList = object->filterOrder; cmdList; cmdList = cmdList->nextPtr) { + filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); + if (filterName[0] == filter[0] && !strcmp(filterName, filter)) + break; + } + + if (!cmdList) + return TCL_OK; + + fcl = cmdList->clorobj; + return ListMethodHandle(interp, (XOTclObject*)fcl, !XOTclObjectIsClass(&fcl->object), filterName); +} + +static int XOTclOInstVarMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { + callFrameContext ctx = {0}; + int result; + + if (object && (object->filterStack || object->mixinStack) ) { + CallStackUseActiveFrames(interp, &ctx); + } + if (!Tcl_Interp_varFramePtr(interp)) { + CallStackRestoreSavedFrames(interp, &ctx); + return XOTclVarErrMsg(interp, "instvar used on ", objectName(object), + ", but callstack is not in procedure scope", + (char *) NULL); + } + + result = XOTclImportvar(interp, object, ObjStr(objv[0]), objc-1, objv+1); + CallStackRestoreSavedFrames(interp, &ctx); + return result; +} + +static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *mixin, Tcl_Obj *guardObj) { + XOTclObjectOpt *opt = object->opt; + + if (opt && opt->mixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, mixin); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); + } + if (mixinCmd) { + XOTclCmdList *h = CmdListFindCmdInList(mixinCmd, opt->mixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, guardObj); + object->flags &= ~XOTCL_MIXIN_ORDER_VALID; + return TCL_OK; + } + } + } + + return XOTclVarErrMsg(interp, "Mixinguard: can't find mixin ", + mixin, " on ", objectName(object), (char *) NULL); +} + +#if 0 +/* method for calling e.g. $obj __next */ +static int XOTclONextMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { + XOTclCallStackContent *cscPtr = CallStackGetObjectFrame(interp, object); + CONST char *methodName; + + if (!cscPtr) + return XOTclVarErrMsg(interp, "__next: can't find object", + objectName(object), (char *) NULL); + methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); + /* fprintf(stderr, "methodName %s\n", methodName);*/ + return XOTclNextMethod(object, interp, cscPtr->cl, methodName, objc-1, &objv[1], 0, NULL); +} +#endif + +static int XOTclONoinitMethod(Tcl_Interp *interp, XOTclObject *object) { + object->flags |= XOTCL_INIT_CALLED; + return TCL_OK; +} + + +static int XOTclORequireNamespaceMethod(Tcl_Interp *interp, XOTclObject *object) { + requireObjNamespace(interp, object); + return TCL_OK; +} + +static int XOTclOResidualargsMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Obj **argv, **nextArgv, *resultObj; + int i, start = 1, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; + CONST char *methodName, *nextMethodName; + + /* find arguments without leading dash */ + for (i=start; i < objc; i++) { + if ((isdasharg = isDashArg(interp, objv[i], 1, &methodName, &argc, &argv))) { + break; + } + } + normalArgs = i-1; + + 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], j==i+1, &nextMethodName, &nextArgc, &nextArgv))) { + break; + } + } + result = callConfigureMethod(interp, object, 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 (i2) { + 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; + } + + objc -= i; + objv += i; + + if (!framePtr) { + XOTclCallStackFindLastInvocation(interp, 1, &framePtr); + if (!framePtr) { + framePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)->callerVarPtr; + if (!framePtr) { + framePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + } + } + } + + savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; + + /* + * 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)", Tcl_GetErrorLine(interp)); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + + /* + * Restore the variable frame, and return. + */ + + Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr; + return result; +} + +static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Obj *frameInfoObj = NULL; + int i, result = TCL_ERROR; + CONST char *frameInfo; + callFrameContext ctx = {0}; + + 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 (object && (object->filterStack || object->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; + } + + if (frameInfoObj) { + DECR_REF_COUNT(frameInfoObj); + } + CallStackRestoreSavedFrames(interp, &ctx); + return result; +} + +static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *object) { + Tcl_Obj *objPtr = object->cmdName; + int result = TCL_ERROR; + CONST char *fullName = ObjStr(objPtr); + CONST char *vn; + callFrameContext ctx = {0}; + + 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); + + if (Tcl_SetVar2(interp, vn, NULL, fullName, 0)) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); + + /*fprintf(stderr, "### setting trace for %s on frame %p\n", fullName, + Tcl_Interp_varFramePtr(interp)); + tcl85showStack(interp);*/ + result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS, + (Tcl_VarTraceProc*)XOTclUnsetTrace, + (ClientData)objPtr); + opt->volatileVarName = vn; + } + CallStackRestoreSavedFrames(interp, &ctx); + + if (result == TCL_OK) { + INCR_REF_COUNT(objPtr); + } + return result; +} + +static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *varname) { + int done, foundEvent; + int flgs = TCL_TRACE_WRITES|TCL_TRACE_UNSETS; + Tcl_CallFrame frame, *framePtr = &frame; + + /* + * Make sure the var table exists and the varname is in there + */ + if (NSRequireVariableOnObj(interp, object, varname, flgs) == 0) + return XOTclVarErrMsg(interp, "Can't lookup (and create) variable ", + varname, " on ", objectName(object), (char *) NULL); + + XOTcl_PushFrameObj(interp, object, framePtr); + /* + * 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, varname, 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, varname, flgs, (Tcl_VarTraceProc *)VwaitVarProc, + (ClientData) &done); + XOTcl_PopFrameObj(interp, framePtr); + /* + * 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 '", varname, + "': would wait forever", (char *) NULL); + } + return TCL_OK; +} + +/*************************** + * End Object Methods + ***************************/ + + +/*************************** + * Begin Class Methods + ***************************/ + +static int XOTclCAllocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj) { + Tcl_Obj *tmpName = NULL; + CONST char *nameString = ObjStr(nameObj); + int result; + + /* + * create a new object from scratch + */ + + /*fprintf(stderr, " **** 0 class '%s' wants to alloc '%s'\n", className(cl), nameString);*/ + if (!NSCheckColons(nameString, 0)) { + return XOTclVarErrMsg(interp, "Cannot allocate object -- illegal name '", + nameString, "'", (char *) NULL); + } + + /* + * If the path is not absolute, we add the appropriate namespace + */ + if (!isAbsolutePath(nameString)) { + nameObj = tmpName = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); + INCR_REF_COUNT(tmpName); + /*fprintf(stderr, " **** NoAbsoluteName for '%s' -> determined = '%s'\n", + name, ObjStr(tmpName));*/ + nameString = ObjStr(tmpName); + } + + if (IsMetaClass(interp, cl, 1)) { + /* + * if the base class is a meta-class, we create a class + */ + XOTclClass *newcl = PrimitiveCCreate(interp, nameObj, cl); + if (newcl == 0) { + result = XOTclVarErrMsg(interp, "Class alloc failed for '", nameString, + "' (possibly parent namespace does not exist)", + (char *) NULL); + } else { + Tcl_SetObjResult(interp, nameObj); + result = TCL_OK; + } + } else { + /* + * if the base class is an ordinary class, we create an object + */ + XOTclObject *newObj = PrimitiveOCreate(interp, nameObj, cl); + if (newObj == 0) + result = XOTclVarErrMsg(interp, "Object alloc failed for '", nameString, + "' (possibly parent namespace does not exist)", + (char *) NULL); + else { + Tcl_SetObjResult(interp, nameObj); + result = TCL_OK; + } + } + + if (tmpName) { + DECR_REF_COUNT(tmpName); + } + + return result; +} + +static int +XOTclCCreateMethod(Tcl_Interp *interp, XOTclClass *cl, CONST char *specifiedName, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *newObject = NULL; + Tcl_Obj *nameObj, *methodObj, *tmpObj = NULL; + Tcl_Obj **nobjv; + int result; + CONST char *nameString = specifiedName; + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); + + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { + fprintf(stderr, "### Can't create object %s during shutdown\n", ObjStr(objv[1])); + return TCL_OK; /* don't fail, if this happens during destroy, it might be canceled */ + } + + /* + * complete the name if it is not absolute + */ + if (!isAbsolutePath(nameString)) { + tmpObj = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); + nameString = ObjStr(tmpObj); + /*fprintf(stderr, " **** fixed name is '%s'\n", nameString);*/ + INCR_REF_COUNT(tmpObj); + memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); + tov[1] = tmpObj; + nameObj = tmpObj; + nobjv = tov; + } else { + nameObj = objv[1]; + nobjv = (Tcl_Obj **)objv; + } + + /* + * Check whether we have to call recreate (i.e. when the + * object exists already) + */ + newObject = XOTclpGetObject(interp, nameString); + + /*fprintf(stderr, "+++ createspecifiedName '%s', nameString '%s', newObject=%p ismeta(%s) %d, ismeta(%s) %d\n", + specifiedName, nameString, newObject, + className(cl), IsMetaClass(interp, cl, 1), + newObject ? ObjStr(newObject->cl->object.cmdName) : "NULL", + newObject ? IsMetaClass(interp, newObject->cl, 1) : 0 + );*/ + + /* don't allow to + - recreate an object as a class, + - recreate a class as an object, and to + - recreate an object in a different obejct system + + In these clases, we use destroy + create instead of recrate. + */ + + if (newObject + && (IsMetaClass(interp, cl, 1) == IsMetaClass(interp, newObject->cl, 1)) + && GetObjectSystem(newObject) == cl->osPtr) { + + /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d oldOs %p != newOs %p EQ %d\n", + ObjStr(nameObj), objc+1, + GetObjectSystem(newObject), cl->osPtr, + GetObjectSystem(newObject) != cl->osPtr + ); + */ + + /* call recreate --> initialization */ + if (CallDirectly(interp, &cl->object, XO_c_recreate_idx, &methodObj)) { + result = RecreateObject(interp, cl, newObject, objc, nobjv); + } else { + result = callMethod((ClientData) cl, interp, methodObj, + objc+1, nobjv+1, XOTCL_CM_NO_PROTECT); + } + + if (result != TCL_OK) + goto create_method_exit; + + Tcl_SetObjResult(interp, newObject->cmdName); + nameObj = newObject->cmdName; + objTrace("RECREATE", newObject); + + } else { + /* + * newObject might exist here, but will be automatically destroyed by + * alloc + */ + + /*fprintf(stderr, "alloc ... %s\n", ObjStr(nameObj));*/ + if (CallDirectly(interp, &cl->object, XO_c_alloc_idx, &methodObj)) { + result = XOTclCAllocMethod(interp, cl, nameObj); + } else { + result = callMethod((ClientData) cl, interp, methodObj, + 3, &nameObj, 0); + } + if (result != TCL_OK) + goto create_method_exit; + + nameObj = Tcl_GetObjResult(interp); + + if (GetObjectFromObj(interp, nameObj, &newObject) != TCL_OK) { + result = XOTclErrMsg(interp, "couldn't find result of alloc", TCL_STATIC); + goto create_method_exit; + } + + /*(void)RemoveInstance(newObject, newObject->cl);*/ /* TODO needed? remove? */ + AddInstance(newObject, cl); + + objTrace("CREATE", newObject); + + /* in case, the object is destroyed during initialization, we incr refcount */ + INCR_REF_COUNT(nameObj); + result = doObjInitialization(interp, newObject, objc, objv); + DECR_REF_COUNT(nameObj); + } + create_method_exit: + + /*fprintf(stderr, "create -- end ... %s => %d\n", ObjStr(nameObj), result);*/ + if (tmpObj) {DECR_REF_COUNT(tmpObj);} + FREE_ON_STACK(Tcl_Obj *, tov); + return result; +} + +static int DoDealloc(Tcl_Interp *interp, XOTclObject *object) { + int result; + + /*fprintf(stderr, "DoDealloc obj= %s %p flags %.6x activation %d cmd %p opt=%p\n", + objectName(object), object, object->flags, object->activationCount, + object->id, object->opt);*/ + + result = freeUnsetTraceVariable(interp, object); + if (result != TCL_OK) { + return result; + } + + /* + * latch, and call delete command if not already in progress + */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != + XOTCL_EXITHANDLER_ON_SOFT_DESTROY) { + CallStackDestroyObject(interp, object); + } + + return TCL_OK; +} + + +static int XOTclCDeallocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *obj) { + XOTclObject *object; + + /* fprintf(stderr, "XOTclCDeallocMethod obj %p %s\n",obj, ObjStr(obj));*/ + + if (GetObjectFromObj(interp, obj, &object) != TCL_OK) { + fprintf(stderr, "XOTcl object %s does not exist\n", ObjStr(obj)); + return XOTclVarErrMsg(interp, "Can't destroy object ", + ObjStr(obj), " that does not exist.", (char *) NULL); + } + + return DoDealloc(interp, object); +} + +static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, + int objc, Tcl_Obj *CONST objv[]) { + Tcl_Obj *fullnameObj; + int result, prefixLength; + Tcl_DString dFullname, *dsPtr = &dFullname; + XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; + + Tcl_DStringInit(dsPtr); + if (withChildof) { + Tcl_DStringAppend(dsPtr, objectName(withChildof), -1); + Tcl_DStringAppend(dsPtr, "::__#", 5); + } else { + Tcl_DStringAppend(dsPtr, "::nsf::__#", 10); + } + 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); + } + + fullnameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); + + INCR_REF_COUNT(fullnameObj); + + { + Tcl_Obj *methodObj; + int callDirectly; + ALLOC_ON_STACK(Tcl_Obj*, objc+3, ov); + + callDirectly = CallDirectly(interp, &cl->object, XO_c_create_idx, &methodObj); + + ov[0] = objv[0]; + ov[1] = methodObj; + ov[2] = fullnameObj; + if (objc >= 1) + memcpy(ov+3, objv, sizeof(Tcl_Obj *)*objc); + + if (callDirectly) { + result = XOTclCCreateMethod(interp, cl, ObjStr(fullnameObj), objc+2, ov+1); + } else { + result = ObjectDispatch((ClientData)cl, interp, objc+3, ov, 0); + } + + FREE_ON_STACK(Tcl_Obj *, ov); + } + + DECR_REF_COUNT(fullnameObj); + Tcl_DStringFree(dsPtr); + + return result; +} + +static int XOTclCFilterGuardMethod(Tcl_Interp *interp, XOTclClass *cl, + CONST char *filter, Tcl_Obj *guardObj) { + XOTclClassOpt *opt = cl->opt; + + if (opt && opt->classfilters) { + XOTclCmdList *h = CmdListFindNameInList(interp, filter, opt->classfilters); + if (h) { + if (h->clientData) + GuardDel(h); + GuardAdd(interp, h, guardObj); + FilterInvalidateObjOrders(interp, cl); + return TCL_OK; + } + } + + return XOTclVarErrMsg(interp, "filterguard: can't find filter ", + filter, " on ", className(cl), (char *) NULL); +} + +static int XOTclCMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, CONST char *mixin, Tcl_Obj *guardObj) { + XOTclClassOpt *opt = cl->opt; + + if (opt && opt->classmixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, mixin); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); + } + if (mixinCmd) { + XOTclCmdList *h = CmdListFindCmdInList(mixinCmd, opt->classmixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, guardObj); + MixinInvalidateObjOrders(interp, cl); + return TCL_OK; + } + } + } + + return XOTclVarErrMsg(interp, "mixinguard: can't find mixin ", + mixin, " on ", className(cl), (char *) NULL); +} + +static int RecreateObject(Tcl_Interp *interp, XOTclClass *class, XOTclObject *object, + int objc, Tcl_Obj *CONST objv[]) { + int result; + + object->flags |= XOTCL_RECREATE; + + /* + * First, cleanup the data from the object. + * + * Check whether we have a pending destroy on the object; if yes, + * clear it, such that the recreated object and won't be destroyed + * on a POP + */ + MarkUndestroyed(object); + + /* + * ensure correct class for object + */ + result = changeClass(interp, object, class); + + if (result == TCL_OK) { + Tcl_Obj *methodObj; + /* + * dispatch "cleanup" method + */ + if (CallDirectly(interp, object, XO_o_cleanup_idx, &methodObj)) { + result = XOTclOCleanupMethod(interp, object); + } else { + result = callMethod((ClientData) object, interp, methodObj, + 2, 0, XOTCL_CM_NO_PROTECT); + } + } + + /* + * Second: if cleanup was successful, initialize the object as usual + */ + if (result == TCL_OK) { + result = doObjInitialization(interp, object, objc, objv); + if (result == TCL_OK) { + Tcl_SetObjResult(interp, object->cmdName); + } + } + return result; +} + +static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *object; + + if (GetObjectFromObj(interp, nameObj, &object) != TCL_OK) + return XOTclVarErrMsg(interp, "can't recreate non existing object ", + ObjStr(nameObj), (char *) NULL); + + return RecreateObject(interp, cl, object, objc, objv); +} + +/*************************** + * End Class Methods + ***************************/ + +#if 0 +/*************************** + * Begin check Methods + ***************************/ +static int XOTclCheckBooleanArgs(Tcl_Interp *interp, CONST char *name, Tcl_Obj *valueObj) { + int result, bool; + Tcl_Obj *boolean; + + if (value == NULL) { + /* the variable is not yet defined (set), so we cannot check + whether it is boolean or not */ + return TCL_OK; + } + + boolean = Tcl_DuplicateObj(valueObj); + INCR_REF_COUNT(boolean); + result = Tcl_GetBooleanFromObj(interp, boolean, &bool); + DECR_REF_COUNT(boolean); + + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); + return TCL_OK; +} + +static int XOTclCheckRequiredArgs(Tcl_Interp *interp, CONST char *name, Tcl_Obj *valueObj) { + if (value == NULL) { + return XOTclVarErrMsg(interp, "required arg: '", name, "' missing", + (char *) NULL); + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + return TCL_OK; +} +/*************************** + * End check Methods + ***************************/ +#endif + +static int AggregatedMethodType(int methodType) { + switch (methodType) { + case MethodtypeNULL: /* default */ + /* TODO remove comment when settled. + methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN; + break;*/ + case MethodtypeAllIdx: + methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN|XOTCL_METHODTYPE_OBJECT; + break; + case MethodtypeScriptedIdx: + /*methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_ALIAS;*/ + methodType = XOTCL_METHODTYPE_SCRIPTED; + break; + case MethodtypeBuiltinIdx: + methodType = XOTCL_METHODTYPE_BUILTIN|XOTCL_METHODTYPE_OBJECT; + break; + case MethodtypeForwarderIdx: + methodType = XOTCL_METHODTYPE_FORWARDER; + break; + case MethodtypeAliasIdx: + methodType = XOTCL_METHODTYPE_ALIAS; + break; + case MethodtypeSetterIdx: + methodType = XOTCL_METHODTYPE_SETTER; + break; + case MethodtypeObjectIdx: + methodType = XOTCL_METHODTYPE_OBJECT; + break; + default: + methodType = 0; + } + + return methodType; +} + +/*************************** + * Begin Object Info Methods + ***************************/ +/* +objectInfoMethod callable XOTclObjInfoCallableMethod { + {-argName "infocallablesubcmd" -nrargs 1 -type "filter|method|methods" -required 1} + {-argName "-methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"} + {-argName "-callprotection" -nrargs 1 -type "all|protected|public" -default all} + {-argName "-application"} + {-argName "-nomixins"} + {-argName "-incontext"} + {-argName "pattern" -required 0} +} +*/ +static int XOTclObjInfoCallableMethod(Tcl_Interp *interp, XOTclObject *object, + int subcmd, + int withMethodtype, int withCallprotection, + int withApplication, + int withNomixins, int withIncontext, CONST char *pattern) { + + if (subcmd != InfocallablesubcmdMethodsIdx) { + if (withMethodtype || withCallprotection || withApplication || withNomixins || withIncontext) { + return XOTclVarErrMsg(interp, "options -methodtype, -callprotection, -application, ", + "-nomixins, -incontext are only valued for subcommand 'methods'", + (char *) NULL); + } + if (pattern == NULL) { + return XOTclVarErrMsg(interp, "methodname must be provided as last argument", + (char *) NULL); + } + } + switch (subcmd) { + case InfocallablesubcmdMethodIdx: + { + XOTclClass *pcl = NULL; + Tcl_Command cmd = ObjectFindMethod(interp, object, pattern, &pcl); + + if (cmd) { + XOTclObject *pobj = pcl ? &pcl->object : object; + int perObject = (pcl == NULL); + ListMethod(interp, pobj, pattern, cmd, InfomethodsubcmdHandleIdx, perObject); + } + return TCL_OK; + } + case InfocallablesubcmdMethodsIdx: + { + return ListCallableMethods(interp, object, pattern, + AggregatedMethodType(withMethodtype), withCallprotection, + withApplication, withNomixins, withIncontext); + } + case InfocallablesubcmdFilterIdx: + { + return FilterSearchMethod(interp, object, pattern); + } + default: + fprintf(stderr, "should never happen, subcmd %d pattern '%s'\n", subcmd, pattern); + + assert(0); /* should never happen */ + } +} + +/* +objectInfoMethod children XOTclObjInfoChildrenMethod { + {-argName "pattern" -required 0} +} +*/ +static int XOTclObjInfoChildrenMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern) { + return ListChildren(interp, object, pattern, 0); +} + +/* +objectInfoMethod class XOTclObjInfoClassMethod { +} +*/ +static int XOTclObjInfoClassMethod(Tcl_Interp *interp, XOTclObject *object) { + Tcl_SetObjResult(interp, object->cl->object.cmdName); + return TCL_OK; +} + +/* +objectInfoMethod filterguard XOTclObjInfoFilterguardMethod { + {-argName "filter" -required 1} +} +*/ +static int XOTclObjInfoFilterguardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter) { + return object->opt ? GuardList(interp, object->opt->filters, filter) : TCL_OK; +} + +/* +objectInfoMethod filtermethods XOTclObjInfoFiltermethodsMethod { + {-argName "-guards"} + {-argName "-order"} + {-argName "pattern"} +} +*/ +static int XOTclObjInfoFiltermethodsMethod(Tcl_Interp *interp, XOTclObject *object, + int withGuards, int withOrder, + CONST char *pattern) { + XOTclObjectOpt *opt = object->opt; + + if (withOrder) { + if (!(object->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, object); + return FilterInfo(interp, object->filterOrder, pattern, withGuards, 1); + } + return opt ? FilterInfo(interp, opt->filters, pattern, withGuards, 0) : TCL_OK; +} + +/* +objectInfoMethod forward XOTclObjInfoForwardMethod { + {-argName "-definition"} + {-argName "name"} +} +*/ +static int XOTclObjInfoForwardMethod(Tcl_Interp *interp, XOTclObject *object, int withDefinition, CONST char *pattern) { + return object->nsPtr ? + ListForward(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern, withDefinition) : + TCL_OK; +} + +/* +objectInfoMethod hasmixin XOTclObjInfoHasMixinMethod { + {-argName "class" -type class} +} +*/ +static int +XOTclObjInfoHasMixinMethod(Tcl_Interp *interp, XOTclObject *object, XOTclClass *mixinClass) { + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), HasMixin(interp, object, mixinClass)); + return TCL_OK; +} + +/* +objectInfoMethod hasnamespace XOTclObjInfoHasnamespaceMethod { +} +*/ +static int XOTclObjInfoHasnamespaceMethod(Tcl_Interp *interp, XOTclObject *object) { + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), object->nsPtr != NULL); + return TCL_OK; +} + +/* +objectInfoMethod hastype XOTclObjInfoHasTypeMethod { + {-argName "class" -type class} +} +*/ +static int +XOTclObjInfoHasTypeMethod(Tcl_Interp *interp, XOTclObject *object, XOTclClass *typeClass) { + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), IsSubType(object->cl, typeClass)); + return TCL_OK; +} + +/* +objectInfoMethod is XOTclObjInfoIsMethod { + {-argName "objectkind" -type "class|baseclass|metaclass"} +} +*/ +static int XOTclObjInfoIsMethod(Tcl_Interp *interp, XOTclObject *object, int objectkind) { + int success = 0; + + switch (objectkind) { + case ObjectkindClassIdx: + success = (XOTclObjectIsClass(object) > 0); + break; + + case ObjectkindMetaclassIdx: + success = XOTclObjectIsClass(object) + && IsMetaClass(interp, (XOTclClass*)object, 1); + break; + + case ObjectkindBaseclassIdx: + success = XOTclObjectIsClass(object) + && IsBaseClass((XOTclClass*)object); + break; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; +} + +/* +objectInfoMethod method XOTclObjInfoMethodMethod { + {-argName "infomethodsubcmd" -type "args|body|definition|handle|parameter|parametersyntax|type|precondition|postcondition"} + {-argName "name"} +} +*/ +static int XOTclObjInfoMethodMethod(Tcl_Interp *interp, XOTclObject *object, + int subcmd, CONST char *methodName) { + Tcl_Namespace *nsPtr = object->nsPtr; + Tcl_Command cmd; + + if (*methodName == ':') { + Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1); + cmd = Tcl_GetCommandFromObj(interp, methodObj); + } else { + cmd = nsPtr ? FindMethod(nsPtr, methodName) : NULL; + } + return ListMethod(interp, object, methodName, cmd, subcmd, 1); +} + +/* +objectInfoMethod methods XOTclObjInfoMethodsMethod { + {-argName "-methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"} + {-argName "-callprotection" -nrargs 1 -type "all|protected|public" -default public} + {-argName "-nomixins"} + {-argName "-incontext"} + {-argName "pattern"} +} +*/ +static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, + int withMethodtype, int withCallproctection, + int withNomixins, int withIncontext, CONST char *pattern) { + return ListDefinedMethods(interp, object, pattern, 1 /* per-object */, + AggregatedMethodType(withMethodtype), withCallproctection, + withNomixins, withIncontext); +} + +/* +objectInfoMethod mixinclasses XOTclObjInfoMixinclassesMethod { + {-argName "-guards"} + {-argName "-order"} + {-argName "pattern" -type objpattern} +} +*/ +static int XOTclObjInfoMixinclassesMethod(Tcl_Interp *interp, XOTclObject *object, + int withGuards, int withOrder, + CONST char *patternString, XOTclObject *patternObj) { + + if (withOrder) { + if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, object); + return MixinInfo(interp, object->mixinOrder, patternString, + withGuards, patternObj); + } + return object->opt ? MixinInfo(interp, object->opt->mixins, patternString, withGuards, patternObj) : TCL_OK; +} + +/* +objectInfoMethod mixinguard XOTclObjInfoMixinguardMethod { + {-argName "mixin" -required 1} +} +*/ +static int XOTclObjInfoMixinguardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *mixin) { + return object->opt ? GuardList(interp, object->opt->mixins, mixin) : TCL_OK; +} + +/* +objectInfoMethod parent XOTclObjInfoParentMethod { +} +*/ +static int XOTclObjInfoParentMethod(Tcl_Interp *interp, XOTclObject *object) { + if (object->id) { + Tcl_SetResult(interp, NSCmdFullName(object->id), TCL_VOLATILE); + } + return TCL_OK; +} + +/* +objectInfoMethod precedence XOTclObjInfoPrecedenceMethod { + {-argName "-intrinsic"} + {-argName "pattern" -required 0} +} +*/ +static int XOTclObjInfoPrecedenceMethod(Tcl_Interp *interp, XOTclObject *object, + int withIntrinsicOnly, CONST char *pattern) { + XOTclClasses *precedenceList = NULL, *pl; + + precedenceList = ComputePrecedenceList(interp, object, pattern, !withIntrinsicOnly, 1); + for (pl = precedenceList; pl; pl = pl->nextPtr) { + Tcl_AppendElement(interp, className(pl->cl)); + } + XOTclClassListFree(precedenceList); + return TCL_OK; +} + +/* +objectInfoMethod slotobjects XOTclObjInfoSlotObjectsMethod { + {-argName "pattern" -required 0} +} +*/ +static int XOTclObjInfoSlotObjectsMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern) { + XOTclObjects *pl, *slotObjects; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + /*XOTclClass *slotClass = XOTclpGetClass(interp, "::nx::Slot");*/ + + slotObjects = computeSlotObjects(interp, object, pattern /* not used */, 1); + + for (pl=slotObjects; pl; pl = pl->nextPtr) { + /*if (slotClass && !IsSubType(pl->obj->cl, slotClass)) continue;*/ + Tcl_ListObjAppendElement(interp, list, pl->obj->cmdName); + } + + XOTclObjectListFree(slotObjects); + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/* +objectInfoMethod vars XOTclObjInfoVarsMethod { + {-argName "pattern" -required 0} +} +*/ +static int XOTclObjInfoVarsMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern) { + Tcl_Obj *varlist, *okList, *element; + int i, length; + TclVarHashTable *varTable = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; + + ListVarKeys(interp, VarHashTable(varTable), pattern); + varlist = Tcl_GetObjResult(interp); + + Tcl_ListObjLength(interp, varlist, &length); + okList = Tcl_NewListObj(0, NULL); + for (i=0; iopt ? GuardList(interp, class->opt->classfilters, filter) : TCL_OK; +} + +/* +classInfoMethod filtermethods XOTclClassInfoFiltermethodsMethod { + {-argName "-guards"} + {-argName "pattern"} +} +*/ +static int XOTclClassInfoFiltermethodsMethod(Tcl_Interp *interp, XOTclClass *class, + int withGuards, CONST char *pattern) { + return class->opt ? FilterInfo(interp, class->opt->classfilters, pattern, withGuards, 0) : TCL_OK; +} + +/* +classInfoMethod forward XOTclClassInfoForwardMethod { + {-argName "-definition"} + {-argName "name"} +} +*/ +static int XOTclClassInfoForwardMethod(Tcl_Interp *interp, XOTclClass *class, + int withDefinition, CONST char *pattern) { + return ListForward(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, withDefinition); +} + +/* +classInfoMethod heritage XOTclClassInfoHeritageMethod { + {-argName "pattern"} +} +*/ +static int XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *cl, CONST 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; +} + +/* + * get all instances of a class recursively into an initialized + * String key hashtable + */ +static int XOTclClassInfoInstancesMethod1(Tcl_Interp *interp, XOTclClass *startCl, + int withClosure, CONST char *pattern, XOTclObject *matchObject) { + Tcl_HashTable *table = &startCl->instances; + XOTclClasses *sc; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + int rc = 0; + + /*fprintf(stderr, "XOTclClassInfoInstancesMethod: clo %d pattern %s match %p\n", + withClosure, pattern, matchObject);*/ + + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); + /*fprintf(stderr, "match '%s' %p %p '%s'\n", + matchObject ? objectName(matchObject) : "NULL", matchObject, inst, objectName(inst));*/ + if (matchObject && inst == matchObject) { + Tcl_SetObjResult(interp, matchObject->cmdName); + return 1; + } + AppendMatchingElement(interp, inst->cmdName, pattern); + } + if (withClosure) { + for (sc = startCl->sub; sc; sc = sc->nextPtr) { + rc = XOTclClassInfoInstancesMethod1(interp, sc->cl, withClosure, pattern, matchObject); + if (rc) break; + } + } + return rc; +} + +/* +classInfoMethod instances XOTclClassInfoInstancesMethod { + {-argName "-closure"} + {-argName "pattern" -type objpattern} +} +*/ +static int XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *startCl, + int withClosure, CONST char *pattern, XOTclObject *matchObject) { + XOTclClassInfoInstancesMethod1(interp, startCl, withClosure, pattern, matchObject); + return TCL_OK; +} + +/* +classInfoMethod method XOTclClassInfoMethodMethod { + {-argName "infomethodsubcmd" -type "args|body|definition|handle|parameter|parametersyntax|type|precondition|postcondition"} + {-argName "name"} +} +*/ +static int XOTclClassInfoMethodMethod(Tcl_Interp *interp, XOTclClass *class, + int subcmd, CONST char *methodName) { + Tcl_Namespace *nsPtr = class->nsPtr; + Tcl_Command cmd; + + if (*methodName == ':') { + Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1); + cmd = Tcl_GetCommandFromObj(interp, methodObj); + } else { + cmd = nsPtr ? FindMethod(nsPtr, methodName) : NULL; + } + return ListMethod(interp, &class->object, methodName, cmd, subcmd, 0); +} + +/* +classInfoMethod methods XOTclClassInfoMethodsMethod { + {-argName "-methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"} + {-argName "-callprotection" -nrargs 1 -type "all|protected|public" -default public} + {-argName "-nomixins"} + {-argName "-incontext"} + {-argName "pattern"} +} +*/ +static int XOTclClassInfoMethodsMethod(Tcl_Interp *interp, XOTclClass *class, + int withMethodtype, int withCallproctection, + int withNomixins, int withIncontext, CONST char *pattern) { + return ListDefinedMethods(interp, &class->object, pattern, 0 /* per-object */, + AggregatedMethodType(withMethodtype), withCallproctection, + withNomixins, withIncontext); +} + +/* +classInfoMethod mixinclasses XOTclClassInfoMixinclassesMethod { + {-argName "-closure"} + {-argName "-guards"} + {-argName "pattern" -type objpattern} +} +*/ +static int XOTclClassInfoMixinclassesMethod(Tcl_Interp *interp, XOTclClass *class, + int withClosure, int withGuards, + CONST char *patternString, XOTclObject *patternObj) { + XOTclClassOpt *opt = class->opt; + int rc; + + if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllClassMixins(interp, commandTable, class, withGuards, patternString, patternObj); + if (patternObj && rc && !withGuards) { + Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + } + Tcl_DeleteHashTable(commandTable); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } else { + rc = opt ? MixinInfo(interp, opt->classmixins, patternString, withGuards, patternObj) : TCL_OK; + } + + return TCL_OK; +} + +/* +classInfoMethod mixinguard XOTclClassInfoMixinguardMethod { + {-argName "mixin" -required 1} +} +*/ +static int XOTclClassInfoMixinguardMethod(Tcl_Interp *interp, XOTclClass *class, CONST char *mixin) { + return class->opt ? GuardList(interp, class->opt->classmixins, mixin) : TCL_OK; +} + +/* +classInfoMethod mixinof XOTclClassInfoMixinOfMethod { + {-argName "-closure"} + {-argName "-scope" -required 0 -nrargs 1 -type "all|class|object"} + {-argName "pattern" -type objpattern} +} +*/ +static int XOTclClassInfoMixinOfMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, int withScope, + CONST char *patternString, XOTclObject *patternObj) { + XOTclClassOpt *opt = class->opt; + int perClass, perObject; + int rc; + + if (withScope == ScopeNULL || withScope == ScopeAllIdx) { + perClass = 1; + perObject = 1; + } else if (withScope == ScopeClassIdx) { + perClass = 1; + perObject = 0; + } else { + perClass = 0; + perObject = 1; + } + + if (opt && !withClosure) { + if (perClass) { + rc = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf, patternString, patternObj); + if (rc && patternObj) {goto finished;} + } + if (perObject) { + rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, patternString, patternObj); + } + } else if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + if (perClass) { + rc = getAllClassMixinsOf(interp, commandTable, class, 0, 1, patternString, patternObj); + if (rc && patternObj) {goto finished;} + } + if (perObject) { + rc = getAllObjectMixinsOf(interp, commandTable, class, 0, 1, patternString, patternObj); + } + Tcl_DeleteHashTable(commandTable); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } + + finished: + if (patternObj) { + Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + } + return TCL_OK; +} + +/* +classInfoMethod slots XOTclClassInfoSlotsMethod { +} +*/ +static int XOTclClassInfoSlotsMethod(Tcl_Interp *interp, XOTclClass *class) { + Tcl_DString ds, *dsPtr = &ds; + XOTclObject *object; + int result; + + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(class), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + object = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (object) { + result = ListChildren(interp, object, NULL, 0); + } else { + result = TCL_OK; + } + DSTRING_FREE(dsPtr); + return result; +} + +/* +classInfoMethod subclass XOTclClassInfoSubclassMethod { + {-argName "-closure"} + {-argName "pattern" -type objpattern} +} +*/ +static int XOTclClassInfoSubclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, + CONST char *patternString, XOTclObject *patternObj) { + int rc; + if (withClosure) { + XOTclClasses *saved = class->order, *subclasses; + class->order = NULL; + subclasses = ComputeOrder(class, class->order, Sub); + class->order = saved; + rc = AppendMatchingElementsFromClasses(interp, subclasses ? subclasses->nextPtr:NULL, + patternString, patternObj); + XOTclClassListFree(subclasses); + } else { + rc = AppendMatchingElementsFromClasses(interp, class->sub, patternString, patternObj); + } + + if (patternObj) { + Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + } + + return TCL_OK; +} + +/* +classInfoMethod superclass XOTclClassInfoSuperclassMethod { + {-argName "-closure"} + {-argName "pattern" -type tclobj} +} +*/ +static int XOTclClassInfoSuperclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, Tcl_Obj *pattern) { + return ListSuperclasses(interp, class, pattern, withClosure); +} + +/*************************** + * End Class Info methods + ***************************/ + +/* + * New Tcl Commands + */ + +static int +ProcessMethodArguments(parseContext *pcPtr, Tcl_Interp *interp, + XOTclObject *object, int pushFrame, + XOTclParamDefs *paramDefs, + CONST char *methodName, int objc, Tcl_Obj *CONST objv[]) { + int result; + Tcl_CallFrame frame, *framePtr = &frame; + + if (object && pushFrame) { + XOTcl_PushFrameObj(interp, object, framePtr); + } + + result = ArgumentParse(interp, objc, objv, object, objv[0], + paramDefs->paramsPtr, paramDefs->nrParams, + RUNTIME_STATE(interp)->doCheckArguments, + pcPtr); + if (object && pushFrame) { + XOTcl_PopFrameObj(interp, framePtr); + } + if (result != TCL_OK) { + return result; + } + + /* + * Set objc of the parse context to the number of defined parameters. + * pcPtr->objc and paramDefs->nrParams will be equivalent in cases + * where argument values are passed to the call in absence of var + * args ('args'). Treating "args is more involved (see below). + */ + pcPtr->objc = paramDefs->nrParams + 1; + + if (pcPtr->varArgs) { + /* + * The last argument was "args". + */ + int elts = objc - pcPtr->lastobjc; + + if (elts == 0) { + /* + * No arguments were passed to "args". We simply decrement objc. + */ + pcPtr->objc--; + } else if (elts > 1) { + /* + * Multiple arguments were passed to "args". pcPtr->objv is + * pointing to the first of the var args. We have to copy the + * remaining actual argument vector objv to the parse context. + */ + + /*XOTclPrintObjv("actual: ", objc, objv);*/ + parseContextExtendObjv(pcPtr, paramDefs->nrParams, elts-1, objv + 1 + pcPtr->lastobjc); + } else { + /* + * A single argument was passed to "args". There is no need to + * mutate the pcPtr->objv, because this has been achieved in + * ArgumentParse (i.e., pcPtr->objv[i] contains this element). + */ + } + } + + return TCL_OK; +} + +/* XOTclUnsetUnknownArgsCmd was developed and tested for Tcl 8.5 and + * needs probably modifications for earlier versions of Tcl. However, + * since CANONICAL_ARGS requires Tcl 8.5 this is not an issue. + */ +int +XOTclUnsetUnknownArgsCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]) { + CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); + Proc *proc = Tcl_CallFrame_procPtr(varFramePtr); + int i; + + if (proc) { + CompiledLocal *ap; + Var *varPtr; + for (ap = proc->firstLocalPtr, i=0; ap; ap = ap->nextPtr, i++) { + if (!TclIsCompiledLocalArgument(ap)) continue; + varPtr = &Tcl_CallFrame_compiledLocals(varFramePtr)[i]; + /*fprintf(stderr, "XOTclUnsetUnknownArgsCmd var '%s' i %d fi %d var %p flags %.8x obj %p unk %p\n", + ap->name, i, ap->frameIndex, varPtr, varPtr->flags, varPtr->value.objPtr, + XOTclGlobalObjs[XOTE___UNKNOWN__]);*/ + if (varPtr->value.objPtr != XOTclGlobalObjs[XOTE___UNKNOWN__]) continue; + /*fprintf(stderr, "XOTclUnsetUnknownArgsCmd must unset %s\n", ap->name);*/ + Tcl_UnsetVar2(interp, ap->name, NULL, 0); + } + } + + return TCL_OK; +} + +#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, className(cl));*/ + for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr); + assert(inst); + assert(inst->refCount>0); + assert(inst->cmdName->refCount>0); + if (XOTclObjectIsClass(inst)) { + checkAllInstances(interp, (XOTclClass*) inst, lvl+1); + } + } + } +} +#endif + +#ifdef DO_FULL_CLEANUP +/* delete global variables and procs */ +static void +deleteProcsAndVars(Tcl_Interp *interp) { + Tcl_Namespace *nsPtr = Tcl_GetGlobalNamespace(interp); + Tcl_HashTable *varTable = nsPtr ? Tcl_Namespace_varTable(ns) : NULL; + Tcl_HashTable *cmdTable = nsPtr ? Tcl_Namespace_cmdTable(ns) : NULL; + Tcl_HashSearch search; + Var *varPtr; + Tcl_Command cmd; + register Tcl_HashEntry *entryPtr; + char *varName; + + 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); + } + } + 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); + + /*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); + } + } +} +#endif + + +#ifdef DO_CLEANUP +static int +ClassHasSubclasses(XOTclClass *cl) { + return (cl->sub != NULL); +} + +static int +ClassHasInstances(XOTclClass *cl) { + Tcl_HashSearch hSrch; + return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL); +} + +static int +ObjectHasChildren(Tcl_Interp *interp, XOTclObject *object) { + Tcl_Namespace *ns = object->nsPtr; + int result = 0; + + if (ns) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSrch; + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + Tcl_Command cmd = Tcl_GetHashValue(hPtr); + XOTclObject *childObject = XOTclGetObjectFromCmdPtr(cmd); + + if (childObject) { + result = 1; + break; + } + } + } + return result; +} + +static void +finalObjectDeletion(Tcl_Interp *interp, XOTclObject *object) { + /* If a call to exit happens from a higher stack frame, the + obejct refcount might not be decremented corectly. If we are + in the phyical destroy round, we can set the counter to an + appropriate value to ensure deletion. + + todo: remove debug line + */ + if (object->refCount != 1) { + fprintf(stderr, "*** have to fix refcount for obj %p refcount %d",object, object->refCount); + if (object->refCount > 1) { + fprintf(stderr, " (name %s)",objectName(object)); + } + fprintf(stderr, "\n"); + object->refCount = 1; + } + assert(object->activationCount == 0); + /*fprintf(stderr, "finalObjectDeletion obj %p activationcount %d\n", object, object->activationCount);*/ + if (object->id) { + /*fprintf(stderr, "cmd dealloc %p final delete refCount %d\n", object->id, Tcl_Command_refCount(object->id));*/ + Tcl_DeleteCommandFromToken(interp, object->id); + } +} + +static void +freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable) { + Tcl_HashEntry *hPtr, *hPtr2; + Tcl_HashSearch hSrch, hSrch2; + XOTclObject *object; + int deleted = 0; + + /*fprintf(stderr, "freeAllXOTclObjectsAndClasses in %p\n", interp);*/ + + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; + + /* + * First delete all child commands of all objects, which are not + * objects themselves. This will for example delete namespace + * imported commands and objects and will resolve potential loops in + * the dependency graph. The result is a plain object/class tree. + */ + for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTable, hPtr); + object = XOTclpGetObject(interp, key); + + /* delete per-object methods */ + if (object && object->nsPtr) { + for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(object->nsPtr), &hSrch2); hPtr2; + hPtr2 = Tcl_NextHashEntry(&hSrch2)) { + Tcl_Command cmd = Tcl_GetHashValue(hPtr2); + if (cmd && Tcl_Command_objProc(cmd) != XOTclObjDispatch) { + Tcl_DeleteCommandFromToken(interp, cmd); + deleted ++; + } + } + } + + /* + * Delete class methods; these methods might have aliases (dependencies) to + * objects, which will resolved this way. + */ + if (XOTclObjectIsClass(object)) { + for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(((XOTclClass *)object)->nsPtr), &hSrch2); hPtr2; + hPtr2 = Tcl_NextHashEntry(&hSrch2)) { + Tcl_Command cmd = Tcl_GetHashValue(hPtr2); + if (cmd) { + Tcl_DeleteCommandFromToken(interp, cmd); + deleted ++; + } + } + } + } + /*fprintf(stderr, "deleted %d cmds\n", deleted);*/ + + /* + * Finally delete the object/class tree in a bottom up manner, + * deleteing all objects without dependencies first. Finally, only + * the root classes of the object system will remain, which are + * deleted separately. + */ + + while (1) { + /* + * Delete all plain objects without dependencies + */ + deleted = 0; + for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTable, hPtr); + + object = XOTclpGetObject(interp, key); + if (object && !XOTclObjectIsClass(object) && !ObjectHasChildren(interp, object)) { + /*fprintf(stderr, " ... delete object %s %p, class=%s id %p\n", key, object, + className(object->cl), object->id);*/ + + freeUnsetTraceVariable(interp, object); + if (object->id) finalObjectDeletion(interp, object); + Tcl_DeleteHashEntry(hPtr); + deleted++; + } + } + /* fprintf(stderr, "deleted %d Objects without dependencies\n", deleted);*/ + if (deleted > 0) { + continue; + } + + /* + * Delete all classes without dependencies + */ + for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(commandNameTable, hPtr); + XOTclClass *cl = XOTclpGetClass(interp, key); + + /*fprintf(stderr, "cl key = %s %p\n", key, cl);*/ + if (cl + && !ObjectHasChildren(interp, (XOTclObject*)cl) + && !ClassHasInstances(cl) + && !ClassHasSubclasses(cl) + && !IsBaseClass(cl) + ) { + /*fprintf(stderr, " ... delete class %s %p\n", key, cl); */ + freeUnsetTraceVariable(interp, &cl->object); + if (cl->object.id) finalObjectDeletion(interp, &cl->object); + + Tcl_DeleteHashEntry(hPtr); + deleted++; + } + } + /*fprintf(stderr, "deleted %d Classes\n", deleted);*/ + if (deleted == 0) { + break; + } + } +} + +#endif /* DO_CLEANUP */ + +/* + * Exit Handler + */ +static void +ExitHandler(ClientData clientData) { + Tcl_Interp *interp = (Tcl_Interp *)clientData; + int i, flags; + + /*fprintf(stderr, "ExitHandler\n");*/ + + /* + * Don't use exit handler, if the interpreter is alread destroyed. + * 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.4.*, 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; + + CallStackPopAll(interp); + + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { + XOTclFinalizeObjCmd(interp); + } + + /* must be before freeing of XOTclGlobalObjs */ + XOTclShadowTclCommands(interp, SHADOW_UNLOAD); + + /* free global objects */ + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + DECR_REF_COUNT(XOTclGlobalObjs[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"); */ +#endif + MEM_COUNT_DUMP(); + + FREE(Tcl_Obj**, XOTclGlobalObjs); + FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); + + Tcl_Interp_flags(interp) = flags; + Tcl_Release((ClientData) interp); +} + + +#if defined(TCL_THREADS) +/* + * Gets activated at thread-exit + */ +static void +XOTcl_ThreadExitProc(ClientData clientData) { + /*fprintf(stderr, "+++ XOTcl_ThreadExitProc\n");*/ + + void XOTcl_ExitProc(ClientData clientData); + Tcl_DeleteExitHandler(XOTcl_ExitProc, clientData); + ExitHandler(clientData); +} +#endif + +/* + * Gets activated at application-exit + */ +void +XOTcl_ExitProc(ClientData clientData) { + /*fprintf(stderr, "+++ XOTcl_ExitProc\n");*/ +#if defined(TCL_THREADS) + Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, clientData); +#endif + ExitHandler(clientData); +} + + +/* + * Registers thread/appl exit handlers. + */ +static void +RegisterExitHandlers(ClientData clientData) { + Tcl_Preserve(clientData); +#if defined(TCL_THREADS) + Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, clientData); +#endif + Tcl_CreateExitHandler(XOTcl_ExitProc, clientData); +} + +/* + * Tcl extension initialization routine + */ + +extern int +Nsf_Init(Tcl_Interp *interp) { + ClientData runtimeState; + int result, i; +#ifdef NSF_BYTECODE + XOTclCompEnv *interpstructions = XOTclGetCompEnv(); +#endif + static XOTclMutex initMutex = 0; + +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + +#if defined(TCL_MEM_DEBUG) + TclDumpMemoryInfo(stderr); +#endif + + MEM_COUNT_INIT(); + + /* init global variables for tcl types */ + XOTclMutexLock(&initMutex); + byteCodeType = Tcl_GetObjType("bytecode"); + tclCmdNameType = Tcl_GetObjType("cmdName"); + listType = Tcl_GetObjType("list"); + XOTclMutexUnlock(&initMutex); + + /* + 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)); + */ + + /* + * Runtime State stored in the client data of the Interp's global + * Namespace in order to avoid global state information + */ + runtimeState = (ClientData) NEW(XOTclRuntimeState); + memset(runtimeState, 0, sizeof(XOTclRuntimeState)); + +#if USE_ASSOC_DATA + Tcl_SetAssocData(interp, "XOTclRuntimeState", NULL, runtimeState); +#else + Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState; +#endif + + RUNTIME_STATE(interp)->doFilters = 1; + RUNTIME_STATE(interp)->doCheckResults = 1; + RUNTIME_STATE(interp)->doCheckArguments = 1; + + /* create xotcl namespace */ + RUNTIME_STATE(interp)->XOTclNS = + Tcl_CreateNamespace(interp, "::nsf", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); + + 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; + + /* XOTclClasses in separate Namespace / Objects */ + RUNTIME_STATE(interp)->XOTclClassesNS = + Tcl_CreateNamespace(interp, "::nsf::classes", (ClientData)NULL, + (Tcl_NamespaceDeleteProc*)NULL); + MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclClassesNS); + + + /* cache interpreters proc interpretation functions */ + RUNTIME_STATE(interp)->objInterpProc = TclGetObjInterpProc(); + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF; + + RegisterExitHandlers((ClientData)interp); + XOTclStringIncrInit(&RUNTIME_STATE(interp)->iss); + /* initialize global Tcl_Obj */ + XOTclGlobalObjs = NEW_ARRAY(Tcl_Obj*, nr_elements(XOTclGlobalStrings)); + + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + XOTclGlobalObjs[i] = Tcl_NewStringObj(XOTclGlobalStrings[i], -1); + INCR_REF_COUNT(XOTclGlobalObjs[i]); + } + + /* create namespaces for the different command types */ + Tcl_CreateNamespace(interp, "::nsf::cmd", 0, (Tcl_NamespaceDeleteProc*)NULL); + for (i=0; i < nr_elements(method_command_namespace_names); i++) { + Tcl_CreateNamespace(interp, method_command_namespace_names[i], 0, (Tcl_NamespaceDeleteProc*)NULL); + } + + /* create all method commands (will use the namespaces above) */ + for (i=0; i < nr_elements(method_definitions)-1; i++) { + Tcl_CreateObjCommand(interp, method_definitions[i].methodName, method_definitions[i].proc, 0, 0); + } + + /* + * overwritten tcl objs + */ + result = XOTclShadowTclCommands(interp, SHADOW_LOAD); + if (result != TCL_OK) + return result; + + /* + * new tcl cmds + */ +#ifdef NSF_BYTECODE + instructions[INST_NEXT].cmdPtr = (Command *) +#endif + Tcl_CreateObjCommand(interp, "::nsf::next", XOTclNextObjCmd, 0, 0); +#ifdef NSF_BYTECODE + instructions[INST_SELF].cmdPtr = (Command *)Tcl_FindCommand(interp, "::nsf::current", 0, 0); +#endif + /*Tcl_CreateObjCommand(interp, "::nsf::K", XOTclKObjCmd, 0, 0);*/ + + Tcl_CreateObjCommand(interp, "::nsf::unsetUnknownArgs", XOTclUnsetUnknownArgsCmd, 0, 0); + +#ifdef NSF_BYTECODE + XOTclBytecodeInit(); +#endif + + Tcl_SetVar(interp, "::nsf::version", NSF_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "::nsf::patchlevel", NSF_PATCHLEVEL, TCL_GLOBAL_ONLY); + + Tcl_AddInterpResolvers(interp,"nxt", + (Tcl_ResolveCmdProc*)InterpColonCmdResolver, + InterpColonVarResolver, + (Tcl_ResolveCompiledVarProc*)InterpCompiledColonVarResolver); + RUNTIME_STATE(interp)->colonCmd = Tcl_FindCommand(interp, "::nsf::colon", 0, 0); + + /* + * 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) { + 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 */ +# ifdef COMPILE_XOTCL_STUBS +# if defined(PRE86) + Tcl_PkgProvideEx(interp, "nsf", PACKAGE_VERSION, (ClientData)&xotclStubs); +# else + Tcl_PkgProvideEx(interp, "nsf", PACKAGE_VERSION, (ClientData)&xotclConstStubPtr); +# endif +# else + Tcl_PkgProvide(interp, "nsf", PACKAGE_VERSION); +# endif +#endif + +#if !defined(TCL_THREADS) + 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); + + return TCL_OK; +} + + +extern int +Next_SafeInit(Tcl_Interp *interp) { + /*** dummy for now **/ + return Nsf_Init(interp); +} + Index: generic/nsf.h =================================================================== diff -u -N --- generic/nsf.h (revision 0) +++ generic/nsf.h (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,179 @@ +/* -*- Mode: c++ -*- + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * This software is based upon MIT Object Tcl by David Wetherall and + * Christopher J. Lindblad, that contains the following copyright + * message: + * + * Copyright 1993 Massachusetts Institute of Technology + * + * Permission to use, copy, modify, distribute, and sell this + * software and its documentation for any purpose is hereby granted + * without fee, provided that the above copyright notice appear in + * all copies and that both that copyright notice and this permission + * notice appear in supporting documentation, and that the name of + * M.I.T. not be used in advertising or publicity pertaining to + * distribution of the software without specific, written prior + * permission. M.I.T. makes no representations about the suitability + * of this software for any purpose. It is provided "as is" without + * express or implied warranty. + * */ + +#ifndef _xotcl_h_ +#define _xotcl_h_ + +#include "tcl.h" + +#undef TCL_STORAGE_CLASS +#ifdef BUILD_xotcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_NSF_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + +/* + * prevent old TCL-versions + */ + +#if TCL_MAJOR_VERSION < 8 +# error Tcl distribution is TOO OLD, we require at least tcl8.5 +#endif + +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<5 +# error Tcl distribution is TOO OLD, we require at least tcl8.5 +#endif + +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<6 +# define PRE86 +#endif + +#if defined(PRE86) +# define CONST86 +# define Tcl_GetErrorLine(interp) (interp)->errorLine +#else +# define NRE +#endif + +/* + * Feature activation/deactivation + */ + +/* activate bytecode support +#define NSF_BYTECODE +*/ + +/* activate/deacticate profiling information at the end + of running the program +#define NSF_PROFILE +*/ + +/* activate/deacticate assert +#define NDEBUG 1 +*/ + +/* activate/deacticate memory tracing +#define XOTCL_MEM_TRACE 1 +#define XOTCL_MEM_COUNT 1 +*/ + +/* turn tracing output on/off +#define XOTCLOBJ_TRACE 1 + +#define CALLSTACK_TRACE 1 +#define DISPATCH_TRACE 1 +#define NAMESPACE_TRACE 1 +#define OBJDELETION_TRACE 1 +#define STACK_TRACE 1 +#define TCL85STACK_TRACE 1 +#define PARSE_TRACE 1 +#define PARSE_TRACE_FULL 1 +#define CONFIGURE_ARGS_TRACE 1 +#define TCL_STACK_ALLOC_TRACE 1 +#define VAR_RESOLVER_TRACE 1 +#define CMD_RESOLVER_TRACE 1 +*/ + +#if defined(PARSE_TRACE_FULL) +# define PARSE_TRACE 1 +#endif + +#ifdef XOTCL_MEM_COUNT +# define DO_FULL_CLEANUP 1 +#endif + +#ifdef AOL_SERVER +# ifndef TCL_THREADS +# define TCL_THREADS +# endif +#endif + +#ifdef TCL_THREADS +# define DO_CLEANUP +#endif + +#ifdef DO_FULL_CLEANUP +# define DO_CLEANUP +#endif + +/* + * A special definition used to allow this header file to be included + * in resource files so that they can get obtain version information from + * this file. Resource compilers don't like all the C stuff, like typedefs + * and procedure declarations, that occur below. + */ + +#ifndef RC_INVOKED + +/* + * The structures XOTcl_Object and XOTcl_Class define mostly opaque + * data structures for the internal use strucures XOTclObject and + * XOTclClass (both defined in XOTclInt.h). Modification of elements + * visible elements must be mirrored in both incarnations. + */ + +typedef struct XOTcl_Object { + Tcl_Obj *cmdName; +} XOTcl_Object; + +typedef struct XOTcl_Class { + struct XOTcl_Object object; +} XOTcl_Class; + + +/* + * Include the public function declarations that are accessible via + * the stubs table. + */ +#include "nsfDecls.h" + +/* + * Nsf_InitStubs is used by extensions that can be linked + * against the xotcl stubs library. If we are not using stubs + * then this reduces to package require. + */ + +#ifdef USE_NSF_STUBS + +# ifdef __cplusplus +extern "C" +# endif +CONST char * +Nsf_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, CONST char *version, int exact)); +#else +# define Nsf_InitStubs(interp, version, exact) \ + Tcl_PkgRequire(interp, "nx", version, exact) +#endif + +#endif /* RC_INVOKED */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* _xotcl_h_ */ Index: generic/nsfAccessInt.h =================================================================== diff -u -N --- generic/nsfAccessInt.h (revision 0) +++ generic/nsfAccessInt.h (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,79 @@ +#define Tcl_Interp_numLevels(interp) ((Interp *)interp)->numLevels +#define Tcl_Interp_framePtr(interp) ((Tcl_CallFrame *)((Interp *)interp)->framePtr) +#define Tcl_Interp_varFramePtr(interp) (((Interp *)interp)->varFramePtr) +#define Tcl_Interp_cmdFramePtr(interp) (((Interp *)interp)->cmdFramePtr) +#define Tcl_Interp_globalNsPtr(interp) ((Tcl_Namespace *)((Interp *)interp)->globalNsPtr) +#define Tcl_Interp_flags(interp) ((Interp *)interp)->flags +#if DISPATCH_TRACE +#define Tcl_Interp_returnCode(interp) ((Interp *)interp)->returnCode +#endif +#define Tcl_Interp_threadId(interp) ((Interp *)interp)->threadId + +#define Tcl_CallFrame_callerPtr(cf) ((Tcl_CallFrame*)((CallFrame *)cf)->callerPtr) +#define Tcl_CallFrame_procPtr(cf) ((CallFrame *)cf)->procPtr +#define Tcl_CallFrame_varTablePtr(cf) ((CallFrame *)cf)->varTablePtr +#define Tcl_CallFrame_level(cf) ((CallFrame *)cf)->level +#define Tcl_CallFrame_isProcCallFrame(cf) ((CallFrame *)cf)->isProcCallFrame +#define Tcl_CallFrame_compiledLocals(cf) ((CallFrame *)cf)->compiledLocals +#define Tcl_CallFrame_numCompiledLocals(cf) ((CallFrame *)cf)->numCompiledLocals +#define Tcl_CallFrame_callerVarPtr(cf) ((Tcl_CallFrame*)((CallFrame *)cf)->callerVarPtr) +#define Tcl_CallFrame_objc(cf) ((CallFrame *)cf)->objc +#define Tcl_CallFrame_objv(cf) ((CallFrame *)cf)->objv +#define Tcl_CallFrame_clientData(cf) ((CallFrame *)cf)->clientData +#define Tcl_CallFrame_nsPtr(cf) ((Tcl_Namespace *)((CallFrame *)cf)->nsPtr) + +#define Tcl_Namespace_cmdTable(nsPtr) &((Namespace *)nsPtr)->cmdTable +#define Tcl_Namespace_varTable(nsPtr) &((Namespace *)nsPtr)->varTable +#define Tcl_Namespace_childTable(nsPtr) &((Namespace *)nsPtr)->childTable +#define Tcl_Namespace_activationCount(nsPtr) ((Namespace *)nsPtr)->activationCount +#define Tcl_Namespace_deleteProc(nsPtr) ((Namespace *)nsPtr)->deleteProc + +#define Tcl_Command_refCount(cmd) ((Command *)cmd)->refCount +#define Tcl_Command_cmdEpoch(cmd) ((Command *)cmd)->cmdEpoch +#define Tcl_Command_flags(cmd) ((Command *)cmd)->flags +/* the following items could be obtained from + Tcl_GetCommandInfoFromToken(cmd, infoPtr) */ +#define Tcl_Command_nsPtr(cmd) ((Tcl_Namespace*)(((Command *)cmd)->nsPtr)) +#define Tcl_Command_objProc(cmd) ((Command *)cmd)->objProc +#define Tcl_Command_objClientData(cmd) ((Command *)cmd)->objClientData +#define Tcl_Command_proc(cmd) ((Command *)cmd)->proc +#define Tcl_Command_clientData(cmd) ((Command *)cmd)->clientData +#define Tcl_Command_deleteProc(cmd) ((Command *)cmd)->deleteProc +#define Tcl_Command_deleteData(cmd) ((Command *)cmd)->deleteData + +/* + * Conversion from CmdPtr to Class / Object + */ + +static XOTCLINLINE ClientData +XOTclGetClientDataFromCmdPtr(Tcl_Command cmd) { + assert(cmd); + /*fprintf(stderr, "objProc=%p %p\n",Tcl_Command_objProc(cmd),XOTclObjDispatch);*/ + if (Tcl_Command_objProc(cmd) == XOTclObjDispatch /* && !Tcl_Command_cmdEpoch(cmd)*/) + return Tcl_Command_objClientData(cmd); + else { + cmd = TclGetOriginalCommand(cmd); + if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) { + /*fprintf(stderr, "???? got cmd right in 2nd round\n");*/ + return Tcl_Command_objClientData(cmd); + } + return NULL; + } +} + +static XOTCLINLINE XOTclClass* +XOTclGetClassFromCmdPtr(Tcl_Command cmd) { + ClientData cd = XOTclGetClientDataFromCmdPtr(cmd); + /*fprintf(stderr, "cd=%p\n",cd);*/ + if (cd) + return XOTclObjectToClass(cd); + else + return 0; +} + +static XOTCLINLINE XOTclObject* +XOTclGetObjectFromCmdPtr(Tcl_Command cmd) { + return (XOTclObject*) XOTclGetClientDataFromCmdPtr(cmd); +} + + Index: generic/nsfCompile.c =================================================================== diff -u -N --- generic/nsfCompile.c (revision 0) +++ generic/nsfCompile.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,144 @@ +#include "nsfInt.h" + +#ifdef NSF_BYTECODE +#include + +static CompileProc + initProcNsCompile, nextCompile, + selfCompile, selfDispatchCompile; + +static InstructionDesc instructionTable[] = { + {"initProc", 1, 0, {OPERAND_NONE}}, + {"next", 1, 0, {OPERAND_NONE}}, + {"self", 1, 0, {OPERAND_NONE}}, + {"dispatch", 2, 1, {OPERAND_UINT1}}, +}; + +static XOTclCompEnv instructions[] = { + {0, 0, initProcNsCompile, XOTclInitProcNSCmd}, + {0, 0, nextCompile, XOTclNextObjCmd}, + {0, 0, selfCompile, XOTclGetSelfObjCmd}, + {0, 0, selfDispatchCompile, /*XOTclSelfDispatchCmd*/XOTclDirectSelfDispatch}, + 0 +}; + +XOTclCompEnv * +XOTclGetCompEnv() { + return &instructions[0]; +} + + +static int +initProcNsCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, + CompileEnv *envPtr) { + + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be '::xotcl::initProcNS'", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + TclEmitOpcode(instructions[INST_INITPROC].bytecode, envPtr); + envPtr->maxStackDepth = 0; + + return TCL_OK; +} + +static int +nextCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, + CompileEnv *envPtr) { + + if (parsePtr->numWords != 1) + return TCL_OUT_LINE_COMPILE; + + TclEmitOpcode(instructions[INST_NEXT].bytecode, envPtr); + envPtr->maxStackDepth = 0; + + return TCL_OK; +} +static int +selfCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, + CompileEnv *envPtr) { + + if (parsePtr->numWords != 1) + return TCL_OUT_LINE_COMPILE; + + TclEmitOpcode(instructions[INST_SELF].bytecode, envPtr); + envPtr->maxStackDepth = 0; + + return TCL_OK; +} +static int +selfDispatchCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, + CompileEnv *envPtr) { + + Tcl_Token *tokenPtr; + int code, wordIdx; + /* + fprintf(stderr, "****** selfDispatchCompile words=%d tokens=%d, avail=%d\n", + parsePtr->numWords,parsePtr->numTokens,parsePtr->tokensAvailable); + */ + + if (parsePtr->numWords > 255) + return TCL_OUT_LINE_COMPILE; + + /*TclEmitOpcode(instructions[INST_SELF].bytecode, envPtr);*/ + + for (wordIdx=0, tokenPtr = parsePtr->tokenPtr + 0; + wordIdx < parsePtr->numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + + /* + fprintf(stderr," %d: %p token type=%d size=%d\n", + wordIdx,tokenPtr,tokenPtr->type,tokenPtr->size ); + */ + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, tokenPtr->start, + tokenPtr->size, 0), envPtr); + envPtr->maxStackDepth = 1; + /* + fprintf(stderr," %d: simple '%s' components=%d\n", + wordIdx,tokenPtr->start, tokenPtr->numComponents); + */ + } else { + /* + fprintf(stderr," %d NOT simple '%s' components=%d\n", + wordIdx,tokenPtr->start, tokenPtr->numComponents); + */ + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + } + + /*fprintf(stderr, "maxdepth=%d, onStack=%d\n",envPtr->maxStackDepth,wordIdx); + */ + TclEmitInstInt1(instructions[INST_SELF_DISPATCH].bytecode, wordIdx, envPtr); + envPtr->maxStackDepth = 0; + + return TCL_OK; +} + + + +void +XOTclBytecodeInit() { + int i; + for(i=0; iobjClientData))) { + instructions[i].cmdPtr->compileProc = instructions[i].compileProc; + } + + } + /*tclTraceCompile = 2;*/ + +} + +#endif Index: generic/nsfError.c =================================================================== diff -u -N --- generic/nsfError.c (revision 0) +++ generic/nsfError.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,117 @@ +/* -*- Mode: c++ -*- + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * + * xotclError.c -- + * + * error return functions for XOTcl + * + */ + +#include "nsfInt.h" + +int +XOTclErrMsg(Tcl_Interp *interp, char *msg, Tcl_FreeProc* type) { + Tcl_SetResult(interp, msg, type); + return TCL_ERROR; +} + +int +XOTclVarErrMsg TCL_VARARGS_DEF (Tcl_Interp *, arg1) { + va_list argList; + char *string; + Tcl_Interp *interp; + + interp = TCL_VARARGS_START(Tcl_Interp *, arg1, argList); + Tcl_ResetResult(interp); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_AppendResult(interp, string, (char *) NULL); + } + va_end(argList); + return TCL_ERROR; +} + + +int +XOTclErrInProc(Tcl_Interp *interp, Tcl_Obj *objName, + Tcl_Obj *clName, CONST char *procName) { + Tcl_DString errMsg; + char *cName, *space; + ALLOC_DSTRING(&errMsg, "\n "); + if (clName) { + cName = ObjStr(clName); + space = " "; + } else { + cName = ""; + space =""; + } + Tcl_DStringAppend(&errMsg, ObjStr(objName),-1); + Tcl_DStringAppend(&errMsg, space, -1); + Tcl_DStringAppend(&errMsg, cName, -1); + Tcl_DStringAppend(&errMsg, "->", 2); + Tcl_DStringAppend(&errMsg, procName, -1); + Tcl_AddErrorInfo (interp, Tcl_DStringValue(&errMsg)); + DSTRING_FREE(&errMsg); + return TCL_ERROR; +} + +int +XOTclObjWrongArgs(Tcl_Interp *interp, char *msg, Tcl_Obj *cmdName, Tcl_Obj *methodName, char *arglist) { + int need_space = 0; + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, msg, " should be \"", (char *) NULL); + if (cmdName) { + Tcl_AppendResult(interp, ObjStr(cmdName), (char *) NULL); + need_space = 1; + } + if (methodName) { + if (need_space) Tcl_AppendResult(interp, " ", (char *) NULL); + Tcl_AppendResult(interp, ObjStr(methodName), (char *) NULL); + need_space = 1; + } + if (arglist != NULL) { + if (need_space) Tcl_AppendResult(interp, " ", (char *) NULL); + Tcl_AppendResult(interp, arglist, (char *) NULL); + } + Tcl_AppendResult(interp, "\"", (char *) NULL); + return TCL_ERROR; +} + +int +XOTclObjErrArgCnt(Tcl_Interp *interp, Tcl_Obj *cmdName, Tcl_Obj *methodName, char *arglist) { + return XOTclObjWrongArgs(interp, "wrong # args:", cmdName, methodName, arglist); +} + +int +XOTclErrBadVal(Tcl_Interp *interp, char *context, char *expected, CONST char *value) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, context, ": expected ", expected, " but got '", + value, "'", (char *) NULL); + return TCL_ERROR; +} + +int +XOTclErrBadVal_(Tcl_Interp *interp, char *expected, char *value) { + fprintf(stderr, "Deprecated call, recompile your program with xotcl 1.5 or newer\n"); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, ": expected ", expected, " but got '", + value, "'", (char *) NULL); + return TCL_ERROR; +} + +extern int +XOTclObjErrType(Tcl_Interp *interp, Tcl_Obj *value, char *type, char *parameterName) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp,"expected ", type, " but got \"", ObjStr(value), "\"", + parameterName ? " for parameter " : "", + parameterName ? parameterName : "", + (char *) NULL); + return TCL_ERROR; +} Index: generic/nsfInt.h =================================================================== diff -u -N --- generic/nsfInt.h (revision 0) +++ generic/nsfInt.h (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,788 @@ +/* -*- Mode: c++ -*- + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * nsfInt.h -- + * + * Mostly internally used API Functions + */ + +#ifndef _xotcl_int_h_ +#define _xotcl_int_h_ + +#if defined(HAVE_STDINT_H) +# define HAVE_INTPTR_T +# define HAVE_UINTPTR_T +#endif + +#include +#include "nsf.h" + +#include +#include +#include + +#if defined(HAVE_TCL_COMPILE_H) +# include +#endif + +#if defined(NSF_PROFILE) +# include +#endif + +#ifdef DMALLOC +# include "dmalloc.h" +#endif + +#ifdef BUILD_xotcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * Makros + */ + +#if defined(PRE86) +# define Tcl_NRCallObjProc(interp, proc, cd, objc, objv) \ + (*(proc))((cd), (interp), (objc), (objv)) +#endif + +#ifdef XOTCL_MEM_COUNT +Tcl_HashTable xotclMemCount; +extern int xotclMemCountInterpCounter; +typedef struct XOTclMemCounter { + int peak; + int count; +} XOTclMemCounter; +# define MEM_COUNT_ALLOC(id,p) XOTclMemCountAlloc(id,p) +# define MEM_COUNT_FREE(id,p) XOTclMemCountFree(id,p) +# define MEM_COUNT_INIT() \ + if (xotclMemCountInterpCounter == 0) { \ + Tcl_InitHashTable(&xotclMemCount, TCL_STRING_KEYS); \ + xotclMemCountInterpCounter = 1; \ + } +# define MEM_COUNT_DUMP() XOTclMemCountDump(interp) +# define MEM_COUNT_OPEN_FRAME() +/*if (obj->varTable) noTableBefore = 0*/ +# define MEM_COUNT_CLOSE_FRAME() +/* if (obj->varTable && noTableBefore) \ + XOTclMemCountAlloc("obj->varTable",NULL)*/ +#else +# define MEM_COUNT_ALLOC(id,p) +# define MEM_COUNT_FREE(id,p) +# define MEM_COUNT_INIT() +# define MEM_COUNT_DUMP() +# define MEM_COUNT_OPEN_FRAME() +# define MEM_COUNT_CLOSE_FRAME() +#endif + +#define DSTRING_INIT(dsPtr) Tcl_DStringInit(dsPtr); MEM_COUNT_ALLOC("DString",dsPtr) +#define DSTRING_FREE(dsPtr) Tcl_DStringFree(dsPtr); MEM_COUNT_FREE("DString",dsPtr) + +#if USE_ASSOC_DATA +# define RUNTIME_STATE(interp) ((XOTclRuntimeState*)Tcl_GetAssocData((interp), "XOTclRuntimeState", NULL)) +#else +# define RUNTIME_STATE(interp) ((XOTclRuntimeState*)((Interp*)(interp))->globalNsPtr->clientData) +#endif + + +#define ALLOC_NAME_NS(DSP, NS, NAME) \ + DSTRING_INIT(DSP);\ + Tcl_DStringAppend(DSP, NS, -1),\ + Tcl_DStringAppend(DSP, "::", 2),\ + Tcl_DStringAppend(DSP, NAME, -1) +#define ALLOC_TOP_NS(DSP, NAME) \ + DSTRING_INIT(DSP);\ + Tcl_DStringAppend(DSP, "::", 2),\ + Tcl_DStringAppend(DSP, NAME, -1) +#define ALLOC_DSTRING(DSP,ENTRY) \ + DSTRING_INIT(DSP);\ + Tcl_DStringAppend(DSP, ENTRY, -1) + +#define nr_elements(arr) ((int) (sizeof(arr) / sizeof(arr[0]))) + +# define NEW(type) \ + (type *)ckalloc(sizeof(type)); MEM_COUNT_ALLOC(#type, NULL) +# define NEW_ARRAY(type,n) \ + (type *)ckalloc(sizeof(type)*(n)); MEM_COUNT_ALLOC(#type "*", NULL) +# define FREE(type, var) \ + ckfree((char*) var); MEM_COUNT_FREE(#type,var) + +#define isAbsolutePath(m) (*m == ':' && m[1] == ':') +#define isArgsString(m) (\ + *m == 'a' && m[1] == 'r' && m[2] == 'g' && m[3] == 's' && \ + m[4] == '\0') +#define isBodyString(m) (\ + *m == 'b' && m[1] == 'o' && m[2] == 'd' && m[3] == 'y' && \ + m[4] == '\0') +#define isCheckString(m) (\ + *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ + m[4] == 'k' && m[5] == '\0') +#define isCheckObjString(m) (\ + *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ + m[4] == 'k' && m[5] == 'o' && m[6] == 'b' && m[7] == 'j' && \ + m[8] == '\0') +#define isCreateString(m) (\ + *m == 'c' && m[1] == 'r' && m[2] == 'e' && m[3] == 'a' && \ + m[4] == 't' && m[5] == 'e' && m[6] == '\0') +#define isInitString(m) (\ + *m == 'i' && m[1] == 'n' && m[2] == 'i' && m[3] == 't' && \ + m[4] == '\0') +#define isTypeString(m) (\ + *m == 't' && m[1] == 'y' && m[2] == 'p' && m[3] == 'e' && \ + m[4] == '\0') +#define isObjectString(m) (\ + *m == 'o' && m[1] == 'b' && m[2] == 'j' && m[3] == 'e' && \ + m[4] == 'c' && m[5] == 't' && m[6] == '\0') +#define isClassString(m) (\ + *m == 'c' && m[1] == 'l' && m[2] == 'a' && m[3] == 's' && \ + m[4] == 's' && m[5] == '\0') + +#if (defined(sun) || defined(__hpux)) && !defined(__GNUC__) +# define USE_ALLOCA +#endif + +#if defined(__IBMC__) && !defined(__GNUC__) +# if __IBMC__ >= 0x0306 +# define USE_ALLOCA +# else +# define USE_MALLOC +# endif +#endif + +#if defined(VISUAL_CC) +# define USE_MALLOC +#endif + +#if defined(__GNUC__) && !defined(USE_ALLOCA) && !defined(USE_MALLOC) +# if !defined(NDEBUG) +# define ALLOC_ON_STACK(type,n,var) \ + int __##var##_count = (n); type __##var[n+2]; \ + type *var = __##var + 1; var[-1] = var[__##var##_count] = (type)0xdeadbeaf +# define FREE_ON_STACK(type,var) \ + assert(var[-1] == var[__##var##_count] && var[-1] == (type)0xdeadbeaf) +# else +# define ALLOC_ON_STACK(type,n,var) type var[(n)] +# define FREE_ON_STACK(type,var) +# endif +#elif defined(USE_ALLOCA) +# define ALLOC_ON_STACK(type,n,var) type *var = (type *)alloca((n)*sizeof(type)) +# define FREE_ON_STACK(type,var) +#else +# define ALLOC_ON_STACK(type,n,var) type *var = (type *)ckalloc((n)*sizeof(type)) +# define FREE_ON_STACK(type,var) ckfree((char*)var) +#endif + +#ifdef USE_ALLOCA +# include +#endif + +#ifdef __WIN32__ +# define XOTCLINLINE +# define XOTclNewObj(A) A=Tcl_NewObj() +# define DECR_REF_COUNT(A) \ + MEM_COUNT_FREE("INCR_REF_COUNT",A); Tcl_DecrRefCount(A) +#else +/* + * This was defined to be inline for anything !sun or __IBMC__ >= 0x0306, + * but __hpux should also be checked - switched to only allow in gcc - JH + */ +# if defined(__GNUC__) +# define XOTCLINLINE inline +# else +# define XOTCLINLINE +# endif +# ifdef USE_TCL_STUBS +# define XOTclNewObj(A) A=Tcl_NewObj() +# define DECR_REF_COUNT(A) \ + MEM_COUNT_FREE("INCR_REF_COUNT",A); assert((A)->refCount > -1); \ + Tcl_DecrRefCount(A) +# else +# define XOTclNewObj(A) TclNewObj(A) +# define DECR_REF_COUNT(A) \ + MEM_COUNT_FREE("INCR_REF_COUNT",A); TclDecrRefCount(A) +# endif +#endif + +#if defined(TCL_THREADS) +# define XOTclMutex Tcl_Mutex +# define XOTclMutexLock(a) Tcl_MutexLock(a) +# define XOTclMutexUnlock(a) Tcl_MutexUnlock(a) +#else +# define XOTclMutex int +# define XOTclMutexLock(a) (*(a))++ +# define XOTclMutexUnlock(a) (*(a))-- +#endif + +#define ObjStr(obj) (obj)->bytes ? (obj)->bytes : Tcl_GetString(obj) + +#define INCR_REF_COUNT(A) MEM_COUNT_ALLOC("INCR_REF_COUNT",A); Tcl_IncrRefCount(A) + +#ifdef OBJDELETION_TRACE +# define PRINTOBJ(ctx,obj) \ + fprintf(stderr, " %s %p %s oid=%p teardown=%p destroyCalled=%d\n", \ + ctx,obj,(obj)->teardown?ObjStr((obj)->cmdName):"(deleted)", \ + (obj)->id, (obj)->teardown, \ + ((obj)->flags & XOTCL_DESTROY_CALLED)) +#else +# define PRINTOBJ(ctx,obj) +#endif + +#define className(cl) (cl ? ObjStr(cl->object.cmdName) : "") +#define objectName(obj) (ObjStr(obj->cmdName)) + + +#define LONG_AS_STRING 32 + +/* TCL_CONTINUE is defined as 4, from 5 on we can + use app-specific return codes */ +#define XOTCL_CHECK_FAILED 6 + +/* flags for call method */ +#define XOTCL_CM_NO_UNKNOWN 1 +#define XOTCL_CM_NO_SHIFT 2 +#define XOTCL_CM_NO_PROTECT 4 +#define XOTCL_CM_NO_OBJECT_METHOD 8 +#define XOTCL_CM_DELGATE 0x10 + +/* + * + * XOTcl Structures + * + */ + +/* + * Filter structures + */ +typedef struct XOTclFilterStack { + Tcl_Command currentCmdPtr; + Tcl_Obj *calledProc; + struct XOTclFilterStack *nextPtr; +} XOTclFilterStack; + +typedef struct XOTclTclObjList { + Tcl_Obj *content; + struct XOTclTclObjList *nextPtr; +} XOTclTclObjList; + +/* + * Assertion structures + */ + +typedef struct XOTclProcAssertion { + XOTclTclObjList *pre; + XOTclTclObjList *post; +} XOTclProcAssertion; + +typedef struct XOTclAssertionStore { + XOTclTclObjList *invariants; + Tcl_HashTable procs; +} XOTclAssertionStore; + +typedef enum { /* powers of 2; add to ALL, if default; */ + CHECK_NONE = 0, CHECK_CLINVAR = 1, CHECK_OBJINVAR = 2, + CHECK_PRE = 4, CHECK_POST = 8, + CHECK_INVAR = CHECK_CLINVAR + CHECK_OBJINVAR, + CHECK_ALL = CHECK_INVAR + CHECK_PRE + CHECK_POST +} CheckOptions; + +void XOTclAssertionRename(Tcl_Interp *interp, Tcl_Command cmd, + XOTclAssertionStore *as, + char *oldSimpleCmdName, char *newName); +/* + * mixins + */ +typedef struct XOTclMixinStack { + Tcl_Command currentCmdPtr; + struct XOTclMixinStack *nextPtr; +} XOTclMixinStack; + +/* + * Generic command pointer list + */ +typedef struct XOTclCmdList { + Tcl_Command cmdPtr; + ClientData clientData; + struct XOTclClass *clorobj; + struct XOTclCmdList *nextPtr; +} XOTclCmdList; + +typedef void (XOTclFreeCmdListClientData) _ANSI_ARGS_((XOTclCmdList*)); + +/* for incr string */ +typedef struct XOTclStringIncrStruct { + char *buffer; + char *start; + size_t bufSize; + int length; +} XOTclStringIncrStruct; + +/* + * cmd flags + */ + +#define XOTCL_CMD_PROTECTED_METHOD 0x00010000 +#define XOTCL_CMD_REDEFINE_PROTECTED_METHOD 0x00020000 +/* XOTCL_CMD_NONLEAF_METHOD is used to flag, if a Method implemented via cmd calls "next" */ +#define XOTCL_CMD_NONLEAF_METHOD 0x00040000 +#define XOTCL_CMD_CLASS_ONLY_METHOD 0x00080000 +/* + * object flags ... + */ + +/* DESTROY_CALLED indicates that destroy was called on obj */ +#define XOTCL_DESTROY_CALLED 0x0001 +/* INIT_CALLED indicates that init was called on obj */ +#define XOTCL_INIT_CALLED 0x0002 +/* MIXIN_ORDER_VALID set when mixin order is valid */ +#define XOTCL_MIXIN_ORDER_VALID 0x0004 +/* MIXIN_ORDER_DEFINED set, when mixins are defined for obj */ +#define XOTCL_MIXIN_ORDER_DEFINED 0x0008 +#define XOTCL_MIXIN_ORDER_DEFINED_AND_VALID 0x000c +/* FILTER_ORDER_VALID set, when filter order is valid */ +#define XOTCL_FILTER_ORDER_VALID 0x0010 +/* FILTER_ORDER_DEFINED set, when filters are defined for obj */ +#define XOTCL_FILTER_ORDER_DEFINED 0x0020 +#define XOTCL_FILTER_ORDER_DEFINED_AND_VALID 0x0030 +/* CLASS properties for objects */ +#define XOTCL_IS_CLASS 0x0040 +#define XOTCL_IS_ROOT_META_CLASS 0x0080 +#define XOTCL_IS_ROOT_CLASS 0x0100 +#define XOTCL_TCL_DELETE 0x0200 +/* DESTROYED set, when object is physically destroyed with PrimitiveODestroy */ +/*#define XOTCL_CMD_NOT_FOUND 0x1000*/ +#define XOTCL_DURING_DELETE 0x2000 +#define XOTCL_DELETED 0x4000 +#define XOTCL_RECREATE 0x8000 + +/* flags for XOTclParams */ + +#define XOTCL_ARG_REQUIRED 0x0001 +#define XOTCL_ARG_MULTIVALUED 0x0002 +#define XOTCL_ARG_NOARG 0x0004 +#define XOTCL_ARG_CURRENTLY_UNKNOWN 0x0008 +#define XOTCL_ARG_SUBST_DEFAULT 0x0010 +#define XOTCL_ARG_ALLOW_EMPTY 0x0020 +#define XOTCL_ARG_INITCMD 0x0040 +#define XOTCL_ARG_METHOD 0x0080 +#define XOTCL_ARG_RELATION 0x0100 +#define XOTCL_ARG_SWITCH 0x0200 +#define XOTCL_ARG_HAS_DEFAULT 0x1000 +#define XOTCL_ARG_IS_CONVERTER 0x2000 + +/* disallowed options */ +#define XOTCL_DISALLOWED_ARG_METHOD_PARAMETER (XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION) +#define XOTCL_DISALLOWED_ARG_SETTER (XOTCL_ARG_SUBST_DEFAULT|XOTCL_DISALLOWED_ARG_METHOD_PARAMETER) +#define XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER 0 +#define XOTCL_DISALLOWED_ARG_VALUEECHECK (XOTCL_ARG_SUBST_DEFAULT|XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_SWITCH|XOTCL_ARG_CURRENTLY_UNKNOWN) + + +/* method types */ +#define XOTCL_METHODTYPE_ALIAS 0x0001 +#define XOTCL_METHODTYPE_SCRIPTED 0x0002 +#define XOTCL_METHODTYPE_SETTER 0x0004 +#define XOTCL_METHODTYPE_FORWARDER 0x0008 +#define XOTCL_METHODTYPE_OBJECT 0x0010 +#define XOTCL_METHODTYPE_OTHER 0x0100 +#define XOTCL_METHODTYPE_BUILTIN XOTCL_METHODTYPE_ALIAS|XOTCL_METHODTYPE_SETTER|XOTCL_METHODTYPE_FORWARDER|XOTCL_METHODTYPE_OTHER + + +/* flags for parseContext */ +#define XOTCL_PC_MUST_DECR 0x0001 + +#define XOTclObjectSetClass(obj) \ + (obj)->flags |= XOTCL_IS_CLASS +#define XOTclObjectClearClass(obj) \ + (obj)->flags &= ~XOTCL_IS_CLASS +#define XOTclObjectIsClass(obj) \ + ((obj)->flags & XOTCL_IS_CLASS) +#define XOTclObjectToClass(obj) \ + (XOTclClass*)((((XOTclObject*)obj)->flags & XOTCL_IS_CLASS)?obj:0) + + +/* + * object and class internals + */ +struct XOTclParam; +typedef int (XOTclTypeConverter)(Tcl_Interp *interp, + Tcl_Obj *obj, + struct XOTclParam CONST *pPtr, + ClientData *clientData, + Tcl_Obj **outObjPtr); + +typedef struct XOTclParam { + char *name; + int flags; + int nrArgs; + XOTclTypeConverter *converter; + Tcl_Obj *converterArg; + Tcl_Obj *defaultValue; + CONST char *type; + Tcl_Obj *nameObj; + Tcl_Obj *converterName; + Tcl_Obj *paramObj; + Tcl_Obj *slotObj; +} XOTclParam; + +typedef struct XOTclParamDefs { + XOTclParam *paramsPtr; + int nrParams; + Tcl_Obj *slotObj; + Tcl_Obj *returns; +} XOTclParamDefs; + +typedef struct XOTclParsedParam { + XOTclParamDefs *paramDefs; + int possibleUnknowns; +} XOTclParsedParam; + +typedef struct XOTclObjectOpt { + XOTclAssertionStore *assertions; + XOTclCmdList *filters; + XOTclCmdList *mixins; + ClientData clientData; + CONST char *volatileVarName; + short checkoptions; +} XOTclObjectOpt; + +typedef struct XOTclObject { + Tcl_Obj *cmdName; + Tcl_Command id; + Tcl_Interp *teardown; + struct XOTclClass *cl; + TclVarHashTable *varTable; + Tcl_Namespace *nsPtr; + XOTclObjectOpt *opt; + struct XOTclCmdList *filterOrder; + struct XOTclCmdList *mixinOrder; + XOTclFilterStack *filterStack; + XOTclMixinStack *mixinStack; + int refCount; + short flags; + short activationCount; +} XOTclObject; + +typedef struct XOTclObjects { + struct XOTclObject *obj; + struct XOTclObjects *nextPtr; +} XOTclObjects; + +typedef struct XOTclClassOpt { + XOTclCmdList *classfilters; + XOTclCmdList *classmixins; + XOTclCmdList *isObjectMixinOf; + XOTclCmdList *isClassMixinOf; + XOTclAssertionStore *assertions; +#ifdef NSF_OBJECTDATA + Tcl_HashTable *objectdata; +#endif + Tcl_Command id; + ClientData clientData; +} XOTclClassOpt; + +typedef struct XOTclClass { + struct XOTclObject object; + struct XOTclClasses *super; + struct XOTclClasses *sub; + struct XOTclObjectSystem *osPtr; + struct XOTclClasses *order; + Tcl_HashTable instances; + Tcl_Namespace *nsPtr; + XOTclParsedParam *parsedParamPtr; + XOTclClassOpt *opt; + short color; +} XOTclClass; + +typedef struct XOTclClasses { + struct XOTclClass *cl; + ClientData clientData; + struct XOTclClasses *nextPtr; +} XOTclClasses; + +typedef enum SystemMethodsIdx { + XO_c_alloc_idx, + XO_c_create_idx, + XO_c_dealloc_idx, + XO_c_recreate_idx, + XO_c_requireobject_idx, + XO_o_cleanup_idx, + XO_o_configure_idx, + XO_o_defaultmethod_idx, + XO_o_destroy_idx, + XO_o_init_idx, + XO_o_move_idx, + XO_o_objectparameter_idx, + XO_o_residualargs_idx, + XO_o_unknown_idx +} SystemMethodsIdx; + +#if !defined(XOTCL_C) +extern CONST char *XOTcl_SytemMethodOpts[]; +#else +CONST char *XOTcl_SytemMethodOpts[] = { + "-class.alloc", + "-class.create", + "-class.dealloc", + "-class.recreate", + "-class.requireobject", + "-object.cleanup", + "-object.configure", + "-object.defaultmethod", + "-object.destroy", + "-object.init", + "-object.move", + "-object.objectparameter", + "-object.residualargs", + "-object.unknown", + NULL +}; +#endif + +typedef struct XOTclObjectSystem { + XOTclClass *rootClass; + XOTclClass *rootMetaClass; + int overloadedMethods; + int definedMethods; + Tcl_Obj *methods[XO_o_unknown_idx+1]; + struct XOTclObjectSystem *nextPtr; +} XOTclObjectSystem; + + + + +/* XOTcl global names and strings */ +/* these are names and contents for global (corresponding) Tcl_Objs + and Strings - otherwise these "constants" would have to be built + every time they are used; now they are built once in XOTcl_Init */ +typedef enum { + XOTE_EMPTY, XOTE_ONE, + /* methods called internally */ + XOTE_CONFIGURE, + /* var names */ + XOTE_AUTONAMES, XOTE_DEFAULTMETACLASS, XOTE_DEFAULTSUPERCLASS, + XOTE_ALIAS_ARRAY, + /* object/class names */ + XOTE_METHOD_PARAMETER_SLOT_OBJ, + /* constants */ + XOTE_ALIAS, XOTE_ARGS, XOTE_CMD, XOTE_FILTER, XOTE_FORWARD, + XOTE_METHOD, XOTE_OBJECT, XOTE_SETTER, + XOTE_GUARD_OPTION, XOTE___UNKNOWN__, + /* Patly redefined Tcl commands; leave them together at the end */ + XOTE_EXPR, XOTE_FORMAT, XOTE_INFO, XOTE_INFO_FRAME, XOTE_INTERP, XOTE_IS, XOTE_RENAME, XOTE_SUBST +} XOTclGlobalNames; +#if !defined(XOTCL_C) +extern char *XOTclGlobalStrings[]; +#else +char *XOTclGlobalStrings[] = { + "", "1", + /* methods called internally */ + "configure", + /* var names */ + "__autonames", "__default_metaclass", "__default_superclass", + "::nsf::alias", + /* object/class names */ + "::nx::methodParameterSlot", + /* constants */ + "alias", "args", "cmd", "filter", "forward", + "method", "object", "setter", + "-guard", "__unknown__", + /* tcl commands */ + "expr", "format", "info", "::tcl::info::frame", "interp", "::tcl::string::is", "rename", "subst", +}; +#endif + +#define XOTclGlobalObjs RUNTIME_STATE(interp)->methodObjNames + +/* XOTcl ShadowTclCommands */ +typedef struct XOTclShadowTclCommandInfo { + TclObjCmdProcType proc; + ClientData clientData; +} XOTclShadowTclCommandInfo; +typedef enum {SHADOW_LOAD=1, SHADOW_UNLOAD=0, SHADOW_REFETCH=2} XOTclShadowOperations; + +int XOTclCallCommand(Tcl_Interp *interp, XOTclGlobalNames name, + int objc, Tcl_Obj *CONST objv[]); +int XOTclShadowTclCommands(Tcl_Interp *interp, XOTclShadowOperations load); +Tcl_Obj * XOTclMethodObj(Tcl_Interp *interp, XOTclObject *object, int methodIdx); + + +/* + * XOTcl CallStack + */ +typedef struct XOTclCallStackContent { + XOTclObject *self; + XOTclClass *cl; + Tcl_Command cmdPtr; + XOTclFilterStack *filterStackEntry; + Tcl_Obj ** objv; + int objc; + unsigned short frameType; + unsigned short callType; +} XOTclCallStackContent; + +#define XOTCL_CSC_TYPE_PLAIN 0 +#define XOTCL_CSC_TYPE_ACTIVE_MIXIN 1 +#define XOTCL_CSC_TYPE_ACTIVE_FILTER 2 +#define XOTCL_CSC_TYPE_INACTIVE 4 +#define XOTCL_CSC_TYPE_INACTIVE_MIXIN 5 +#define XOTCL_CSC_TYPE_INACTIVE_FILTER 6 +#define XOTCL_CSC_TYPE_GUARD 16 + +#define XOTCL_CSC_CALL_IS_NEXT 1 +#define XOTCL_CSC_CALL_IS_GUARD 2 + +#if defined(NSF_PROFILE) +typedef struct XOTclProfile { + long int overallTime; + Tcl_HashTable objectData; + Tcl_HashTable methodData; +} XOTclProfile; +#endif + +typedef struct XOTclRuntimeState { + Tcl_Namespace *XOTclClassesNS; + Tcl_Namespace *XOTclNS; + /* + * definitions of the main xotcl objects + */ + struct XOTclObjectSystem *objectSystems; + Tcl_ObjCmdProc *objInterpProc; + Tcl_Obj **methodObjNames; + struct XOTclShadowTclCommandInfo *tclCommands; + int errorCount; + /* these flags could move into a bitarray, but are used only once per interp*/ + int unknown; + int doFilters; + int doSoftrecreate; + int doKeepinitcmd; + int doCheckResults; + int doCheckArguments; + int exitHandlerDestroyRound; + int returnCode; + int overloadedMethods; + long newCounter; + XOTclStringIncrStruct iss; + XOTclObject *delegatee; + Proc fakeProc; + Tcl_Namespace *fakeNS; + NsfStubs *nsfStubs; + Tcl_CallFrame *varFramePtr; + Tcl_Command cmdPtr; /* used for ACTIVE_MIXIN */ + Tcl_Command colonCmd; +#if defined(NSF_PROFILE) + XOTclProfile profile; +#endif + short guardCount; + ClientData clientData; +} XOTclRuntimeState; + +#define XOTCL_EXITHANDLER_OFF 0 +#define XOTCL_EXITHANDLER_ON_SOFT_DESTROY 1 +#define XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY 2 + + +#ifdef NSF_OBJECTDATA +extern void +XOTclSetObjectData(struct XOTclObject *obj, struct XOTclClass *cl, + ClientData data); +extern int +XOTclGetObjectData(struct XOTclObject *obj, struct XOTclClass *cl, + ClientData *data); +extern int +XOTclUnsetObjectData(struct XOTclObject *obj, struct XOTclClass *cl); +extern void +XOTclFreeObjectData(XOTclClass *cl); +#endif + +/* + * + * internally used API functions + * + */ + +#include "nsfIntDecls.h" + +/* + * Profiling functions + */ + +#if defined(NSF_PROFILE) +extern void +XOTclProfileFillTable(Tcl_HashTable *table, Tcl_DString *key, + double totalMicroSec); +extern void +XOTclProfileEvaluateData(Tcl_Interp *interp, long int startSec, long int startUsec, + XOTclObject *obj, XOTclClass *cl, char *methodName); +extern void +XOTclProfilePrintTable(Tcl_HashTable *table); + +extern void +XOTclProfilePrintData(Tcl_Interp *interp); + +extern void +XOTclProfileInit(Tcl_Interp *interp); +#endif + +/* + * MEM Counting + */ +#ifdef XOTCL_MEM_COUNT +void XOTclMemCountAlloc(char *id, void *); +void XOTclMemCountFree(char *id, void *); +void XOTclMemCountDump(); +#endif /* XOTCL_MEM_COUNT */ + +/* + * bytecode support + */ +#ifdef NSF_BYTECODE +typedef struct XOTclCompEnv { + int bytecode; + Command *cmdPtr; + CompileProc *compileProc; + Tcl_ObjCmdProc *callProc; +} XOTclCompEnv; + +typedef enum {INST_INITPROC, INST_NEXT, INST_SELF, INST_SELF_DISPATCH, + LAST_INSTRUCTION} XOTclByteCodeInstructions; + + +extern XOTclCompEnv *XOTclGetCompEnv(); + +Tcl_ObjCmdProc XOTclInitProcNSCmd, XOTclSelfDispatchCmd, + XOTclNextObjCmd, XOTclGetSelfObjCmd; + +int XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +#endif + +int +XOTclObjDispatch(ClientData cd, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); + +/* functions from xotclUtil.c */ +char *XOTcl_ltoa(char *buf, long i, int *len); +char *XOTclStringIncr(XOTclStringIncrStruct *iss); +void XOTclStringIncrInit(XOTclStringIncrStruct *iss); +void XOTclStringIncrFree(XOTclStringIncrStruct *iss); + + +/* + Tcl uses 01 and 02, TclOO uses 04 and 08, so leave some space free + for further extensions of tcl and tcloo... +*/ +#define FRAME_IS_XOTCL_OBJECT 0x10000 +#define FRAME_IS_XOTCL_METHOD 0x20000 +#define FRAME_IS_XOTCL_CMETHOD 0x40000 + +#if !defined(NDEBUG) +/*# define XOTCLINLINE*/ +#endif + +/*** common win sermon ***/ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* _xotcl_int_h_ */ Index: generic/nsfIntDecls.h =================================================================== diff -u -N -r1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- generic/nsfIntDecls.h (.../nsfIntDecls.h) (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ generic/nsfIntDecls.h (.../nsfIntDecls.h) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -1,5 +1,5 @@ /* - * xotclIntDecls.h -- + * nsfIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These @@ -19,7 +19,7 @@ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made - * in the xotclInt.decls script. + * in the nsfInt.decls script. */ /* !BEGIN!: Do not edit below this line. */ Index: generic/nsfObjectData.c =================================================================== diff -u -N --- generic/nsfObjectData.c (revision 0) +++ generic/nsfObjectData.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,61 @@ +/* -*- Mode: c++ -*- + * nsfObjectData.c + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2008 Gustaf Neumann, Uwe Zdun + * + * + * nsfObjectData.c -- + * + * XOTcl Object Data, needs NSF_OBJECTDATA to be compiled in + * + */ + +#include "nsfInt.h" + +#ifdef NSF_OBJECTDATA +extern void +XOTclFreeObjectData(XOTclClass* cl) { + if (cl->opt && cl->opt->objectdata) { + Tcl_DeleteHashTable(cl->opt->objectdata); + ckfree((char*)cl->opt->objectdata); + cl->opt->objectdata = 0; + } +} +extern void +XOTclSetObjectData(XOTclObject* obj, XOTclClass* cl, ClientData data) { + Tcl_HashEntry *hPtr; + int nw; + + XOTclRequireClassOpt(cl); + + if (!cl->opt->objectdata) { + cl->opt->objectdata = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(cl->opt->objectdata, TCL_ONE_WORD_KEYS); + } + hPtr = Tcl_CreateHashEntry(cl->opt->objectdata, (char*)obj, &nw); + Tcl_SetHashValue(hPtr, data); +} + +extern int +XOTclGetObjectData(XOTclObject* obj, XOTclClass* cl, ClientData* data) { + Tcl_HashEntry *hPtr; + if (!cl->opt || !cl->opt->objectdata) + return 0; + hPtr = Tcl_FindHashEntry(cl->opt->objectdata, (char*)obj); + if (data) *data = hPtr ? Tcl_GetHashValue(hPtr) : 0; + return hPtr != 0; +} + +extern int +XOTclUnsetObjectData(XOTclObject* obj, XOTclClass* cl) { + Tcl_HashEntry *hPtr; + + if (!cl->opt || !cl->opt->objectdata) + return 0; + hPtr = Tcl_FindHashEntry(cl->opt->objectdata, (char*)obj); + if (hPtr) Tcl_DeleteHashEntry(hPtr); + return hPtr != 0; +} +#endif Index: generic/nsfProfile.c =================================================================== diff -u -N --- generic/nsfProfile.c (revision 0) +++ generic/nsfProfile.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,144 @@ +/* -*- Mode: c++ -*- + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * + * nsfProfile.c -- + * + * Profiling information printout for XOTcl + * + * For profiling infos NSF_PROFILE (nsf.h) flag must be activated + * + */ + +#include "nsfInt.h" + +#if defined(NSF_PROFILE) +void +XOTclProfileFillTable(Tcl_HashTable* table, Tcl_DString* key, + double totalMicroSec) { + Tcl_HashEntry* hPtr; + char* keyStr = Tcl_DStringValue(key); + long int* value; + + hPtr = Tcl_FindHashEntry(table, keyStr); + if (!hPtr) { + int nw; + hPtr = Tcl_CreateHashEntry(table, keyStr, &nw); + if (!nw) + return; + value = (long int*) ckalloc (sizeof(long int)); + *value = 0; + Tcl_SetHashValue(hPtr, (ClientData) value); + } else + value = (long int*) Tcl_GetHashValue (hPtr); + + *value += totalMicroSec; + + + /* { + long int* d = (long int*) Tcl_GetHashValue (hPtr); + fprintf(stderr, "Entered %s ... %ld\n", Tcl_GetHashKey(table, hPtr), *d); + }*/ + +} + +void +XOTclProfileEvaluateData(Tcl_Interp* interp, long int startSec, long int startUsec, + XOTclObject* obj, XOTclClass *cl, char *methodName) { + double totalMicroSec; + struct timeval trt; + Tcl_DString objectKey, methodKey; + + XOTclProfile* profile = &RUNTIME_STATE(interp)->profile; + + gettimeofday(&trt, NULL); + + totalMicroSec = (trt.tv_sec - startSec) * 1000000 + + (trt.tv_usec - startUsec); + + profile->overallTime += totalMicroSec; + + if (obj->teardown == 0 || !obj->id || obj->destroyCalled) + return; + + ALLOC_DSTRING(&objectKey, ObjStr(obj->cmdName)); + + if (cl) + ALLOC_DSTRING(&methodKey, ObjStr(cl->object.cmdName)); + else + ALLOC_DSTRING(&methodKey, ObjStr(obj->cmdName)); + Tcl_DStringAppend(&methodKey, "->", 2); + Tcl_DStringAppend(&methodKey, methodName, -1); + if (cl) + Tcl_DStringAppend(&methodKey, " (instproc)", 11); + else + Tcl_DStringAppend(&methodKey, " (proc)", 7); + + XOTclProfileFillTable(&profile->objectData, &objectKey, totalMicroSec); + XOTclProfileFillTable(&profile->methodData, &methodKey, totalMicroSec); + DSTRING_FREE(&objectKey); + DSTRING_FREE(&methodKey); +} + +void +XOTclProfilePrintTable(Tcl_HashTable* table) { + Tcl_HashEntry* topValueHPtr; + long int* topValue; + + do { + Tcl_HashSearch hSrch; + Tcl_HashEntry* hPtr = table ? + Tcl_FirstHashEntry(table, &hSrch) : 0; + char* topKey = 0; + + topValueHPtr = 0; + topValue = 0; + + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + long int *val = (long int*) Tcl_GetHashValue(hPtr); + if (val && (!topValue || (topValue && *val >= *topValue))) { + topValue = val; + topValueHPtr = hPtr; + topKey = Tcl_GetHashKey(table, hPtr); + } + } + + if (topValueHPtr) { + fprintf(stderr, " %15ld %s\n", *topValue, topKey); + ckfree((char*) topValue); + Tcl_DeleteHashEntry(topValueHPtr); + } + } while (topValueHPtr); +} + +void +XOTclProfilePrintData(Tcl_Interp *interp) { + XOTclProfile* profile = &RUNTIME_STATE(interp)->profile; + + fprintf(stderr, "------------------------------------------------------------------\n"); + fprintf(stderr, "\nXOTcl Profile Information\n\n"); + fprintf(stderr, "------------------------------------------------------------------\n"); + fprintf(stderr, "Overall Elapsed Time %ld\n", + profile->overallTime); + fprintf(stderr, "------------------------------------------------------------------\n"); + fprintf(stderr, " MICROSECONDS OBJECT-NAME\n"); + XOTclProfilePrintTable(&profile->objectData); + fprintf(stderr, "------------------------------------------------------------------\n"); + fprintf(stderr, " MICROSECONDS (CL/OBJ)->METHOD-NAME\n"); + XOTclProfilePrintTable(&profile->methodData); + fprintf(stderr, "------------------------------------------------------------------\n"); +} + +void +XOTclProfileInit(Tcl_Interp *interp) { + RUNTIME_STATE(interp)->profile.overallTime = 0; + Tcl_InitHashTable(&RUNTIME_STATE(interp)->profile.objectData, + TCL_STRING_KEYS); + Tcl_InitHashTable(&RUNTIME_STATE(interp)->profile.methodData, + TCL_STRING_KEYS); +} + +#endif Index: generic/nsfShadow.c =================================================================== diff -u -N --- generic/nsfShadow.c (revision 0) +++ generic/nsfShadow.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,231 @@ +/* -*- Mode: c++ -*- + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * + * xotclShadow.c -- + * + * Shadowing (overloading) and accessing global tcl obj commands + * + */ + +#include "nsfInt.h" +#include "nsfAccessInt.h" + +static int +XOTclReplaceCommandCleanup(Tcl_Interp *interp, XOTclGlobalNames name) { + Tcl_Command cmd; + int result = TCL_OK; + XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; + + /*fprintf(stderr," cleanup for %s ti=%p in %p\n", XOTclGlobalStrings[name], ti, interp);*/ + cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjs[name]); + if (cmd != NULL) { + Tcl_Command_objProc(cmd) = ti->proc; + ti->proc = NULL; + } else { + result = TCL_ERROR; + } + + return result; +} + +static void +XOTclReplaceCommandCheck(Tcl_Interp *interp, XOTclGlobalNames name, Tcl_ObjCmdProc *proc) { + Tcl_Command cmd; + XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; + cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjs[name]); + + if (cmd != NULL && ti->proc && Tcl_Command_objProc(cmd) != proc) { + /* + fprintf(stderr, "we have to do something about %s %p %p\n", + XOTclGlobalStrings[name], Tcl_Command_objProc(cmd), proc); + */ + ti->proc = Tcl_Command_objProc(cmd); + ti->clientData = Tcl_Command_objClientData(cmd); + Tcl_Command_objProc(cmd) = proc; + } +} + +static int +XOTclReplaceCommand(Tcl_Interp *interp, XOTclGlobalNames name, + Tcl_ObjCmdProc *xotclReplacementProc, int pass) { + Tcl_Command cmd; + XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; + int result = TCL_OK; + + /*fprintf(stderr,"XOTclReplaceCommand %d\n",name);*/ + cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjs[name]); + + if (cmd == NULL) { + result = TCL_ERROR; + } else { + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + if (xotclReplacementProc != objProc) { + if (pass == 0) { /* setting values on first pass (must be locked here) */ + ti->proc = objProc; + ti->clientData = Tcl_Command_objClientData(cmd); + } else if (ti->proc != objProc) { + /*fprintf(stderr, "we have to refetch command for %s\n",XOTclGlobalStrings[name]);*/ + ti->proc = objProc; + ti->clientData = Tcl_Command_objClientData(cmd); + } + if (xotclReplacementProc) { + Tcl_Command_objProc(cmd) = xotclReplacementProc; + /*Tcl_CreateObjCommand(interp, XOTclGlobalStrings[name], xotclReplacementProc, 0, 0);*/ + } + } + } + return result; +} + +static int +XOTcl_RenameObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + /* this call the Tcl_RenameObjCmd, but it ensures before that + the renamed obj, functions, etc. are not part of XOTcl */ + Tcl_Command cmd; + + /* wrong # args => normal Tcl ErrMsg*/ + if (objc != 3) { + return XOTclCallCommand(interp, XOTE_RENAME, objc, objv); + } + + /* if an obj/cl should be renamed => call the XOTcl move method */ + cmd = Tcl_FindCommand(interp, ObjStr(objv[1]), (Tcl_Namespace *)NULL,0); + if (cmd) { + XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); + Tcl_Obj *methodObj = object ? XOTclMethodObj(interp, object, XO_o_move_idx) : NULL; + if (object && methodObj) { + return XOTclCallMethodWithArgs((ClientData)object, interp, + methodObj, objv[2], 1, 0, 0); + } + } + + /* Actually rename the cmd using Tcl's rename*/ + return XOTclCallCommand(interp, XOTE_RENAME, objc, objv); +} + +static int +XOTcl_InfoFrameObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int result; + + result = XOTclCallCommand(interp, XOTE_INFO_FRAME, objc, objv); + + if (result == TCL_OK && objc == 2) { + int level, topLevel, frameFlags; + CONST char *frameType; + CmdFrame *framePtr = Tcl_Interp_cmdFramePtr(interp); + CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); + Tcl_Obj *resultObj = Tcl_GetObjResult(interp); + + /* level must be ok, otherwise we weould not have a TCL_OK */ + Tcl_GetIntFromObj(interp, objv[1], &level); + + /* todo: coroutine level messing is missing */ + topLevel = framePtr == NULL ? 0 : framePtr->level; + + if (level > 0) { + level -= topLevel; + } + /*fprintf(stderr, "topLevel %d level %d\n",topLevel, level);*/ + while (++level <= 0) { + framePtr = framePtr->nextPtr; + varFramePtr = varFramePtr->callerPtr; + } + frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); + /*fprintf(stderr, " ... frame %p varFramePtr %p frameFlags %.6x\n", framePtr, varFramePtr, frameFlags); + tcl85showStack(interp);*/ + if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + XOTclCallStackContent *cscPtr = + ((XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr)); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("object",6)); + Tcl_ListObjAppendElement(interp, resultObj, cscPtr->self->cmdName); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("class",5)); + Tcl_ListObjAppendElement(interp, resultObj, + cscPtr->cl ? cscPtr->cl->object.cmdName : XOTclGlobalObjs[XOTE_EMPTY]); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("frametype",9)); + if (cscPtr->frameType == XOTCL_CSC_TYPE_PLAIN) { + frameType = "intrinsic"; + } else if (cscPtr->frameType & XOTCL_CSC_TYPE_ACTIVE_MIXIN) { + frameType = "mixin"; + } else if (cscPtr->frameType & XOTCL_CSC_TYPE_ACTIVE_FILTER) { + frameType = "filter"; + } else if (cscPtr->frameType & XOTCL_CSC_TYPE_GUARD) { + frameType = "guard"; + } else { + frameType = "unknown"; + } + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(frameType,-1)); + } + } + + return result; +} + +/* + * Obtain the names of the tcl commands + * not available through the stub interface and overload some global commands + */ +int +XOTclShadowTclCommands(Tcl_Interp *interp, XOTclShadowOperations load) { + int rc = TCL_OK; + if (load == SHADOW_LOAD) { + int initialized = (RUNTIME_STATE(interp)->tclCommands != NULL); + assert(initialized == 0); + RUNTIME_STATE(interp)->tclCommands = + NEW_ARRAY(XOTclShadowTclCommandInfo, XOTE_SUBST - XOTE_EXPR + 1); + + /*fprintf(stderr, "+++ load tcl commands %d %d\n", load, initialized);*/ + +#ifdef USE_TCL_STUBS + /* no commands are overloaded, these are only used for calling + e.g. Tcl_ExprObjCmd(), Tcl_IncrObjCmd() and Tcl_SubstObjCmd(), + which are not available in though the stub table */ + rc |= XOTclReplaceCommand(interp, XOTE_EXPR, NULL, initialized); + rc |= XOTclReplaceCommand(interp, XOTE_SUBST, NULL, initialized); +#endif + rc |= XOTclReplaceCommand(interp, XOTE_FORMAT, NULL, initialized); + rc |= XOTclReplaceCommand(interp, XOTE_INTERP, NULL, initialized); + rc |= XOTclReplaceCommand(interp, XOTE_IS, NULL, initialized); + + /* for the following commands, we have to add our own semantics */ + rc |= XOTclReplaceCommand(interp, XOTE_INFO_FRAME, XOTcl_InfoFrameObjCmd, initialized); + rc |= XOTclReplaceCommand(interp, XOTE_RENAME, XOTcl_RenameObjCmd, initialized); + + } else if (load == SHADOW_REFETCH) { + XOTclReplaceCommandCheck(interp, XOTE_RENAME, XOTcl_RenameObjCmd); + } else { + XOTclReplaceCommandCleanup(interp, XOTE_RENAME); + XOTclReplaceCommandCleanup(interp, XOTE_INFO_FRAME); + FREE(XOTclShadowTclCommandInfo*, RUNTIME_STATE(interp)->tclCommands); + RUNTIME_STATE(interp)->tclCommands = NULL; + } + return rc; +} + +/* + * call a Tcl command with given objv's ... replace objv[0] + * with the given command name + */ +int XOTclCallCommand(Tcl_Interp *interp, XOTclGlobalNames name, + int objc, Tcl_Obj *CONST objv[]) { + int result; + XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; + ALLOC_ON_STACK(Tcl_Obj*,objc, ov); + /* + {int i; + fprintf(stderr,"calling %s (%p %p) in %p, objc=%d ", + XOTclGlobalStrings[name],ti,ti->proc, interp, objc); + for(i=0;i 1) + memcpy(ov+1, objv+1, sizeof(Tcl_Obj *)*(objc-1)); + result = Tcl_NRCallObjProc(interp, ti->proc, ti->clientData, objc, objv); + FREE_ON_STACK(Tcl_Obj *, ov); + return result; +} Index: generic/nsfStack.c =================================================================== diff -u -N --- generic/nsfStack.c (revision 0) +++ generic/nsfStack.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,532 @@ + +static TclVarHashTable *VarHashTableCreate(); +static void XOTclCleanupObject(XOTclObject *object); + +void tcl85showStack(Tcl_Interp *interp) { + Tcl_CallFrame *framePtr; + + fprintf(stderr, "tcl85showStack framePtr %p varFramePtr %p\n", + Tcl_Interp_framePtr(interp), Tcl_Interp_varFramePtr(interp)); + /* framePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { + fprintf(stderr, "... frame %p flags %.6x cd %p objv[0] %s\n", + framePtr, Tcl_CallFrame_isProcCallFrame(framePtr), + Tcl_CallFrame_clientData(framePtr), + Tcl_CallFrame_objc(framePtr) ? ObjStr(Tcl_CallFrame_objv(framePtr)[0]) : "(null)"); + }*/ + framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); + for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { + int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); + XOTclCallStackContent *cscPtr = + (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) ? + ((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr)) : NULL; + + fprintf(stderr, "... var frame %p flags %.6x cd %p lvl %d ns %p %s ov %s %d", + framePtr, frameFlags, + Tcl_CallFrame_clientData(framePtr), + Tcl_CallFrame_level(framePtr), + Tcl_CallFrame_nsPtr(framePtr), Tcl_CallFrame_nsPtr(framePtr)->fullName, + Tcl_CallFrame_objc(framePtr) ? ObjStr(Tcl_CallFrame_objv(framePtr)[0]) : "(null)", + Tcl_CallFrame_objc(framePtr) ? Tcl_CallFrame_objc(framePtr) : -1); + if (cscPtr) { + fprintf(stderr, " frameType %d callType %d (%p %s)\n", + cscPtr ? cscPtr->frameType : -1, + cscPtr ? cscPtr->callType : -1, + cscPtr ? cscPtr->self : NULL, + cscPtr ? objectName(cscPtr->self) : ""); + } else { + fprintf(stderr, " no csc"); + if (frameFlags & FRAME_IS_XOTCL_OBJECT) { + XOTclObject *object = (XOTclObject *)Tcl_CallFrame_clientData(framePtr); + fprintf(stderr, " obj %p %s", object, objectName(object)); + } + fprintf(stderr, "\n"); + } + } +} + +/* + * Push and pop operations. + * + * Note that it is possible that between push and pop + * a object->nsPtr can be created (e.g. during a read trace) + */ + +static void XOTcl_PushFrameObj(Tcl_Interp *interp, XOTclObject *object, Tcl_CallFrame *framePtr) { + /*fprintf(stderr,"PUSH OBJECT_FRAME (XOTcl_PushFrame) frame %p\n",framePtr);*/ + if (object->nsPtr) { + /*fprintf(stderr,"XOTcl_PushFrame frame %p with object->nsPtr %p\n", framePtr, object->nsPtr);*/ + Tcl_PushCallFrame(interp, framePtr, object->nsPtr, + 0|FRAME_IS_XOTCL_OBJECT); + } else { + /*fprintf(stderr,"XOTcl_PushFrame frame %p (with fakeProc)\n",framePtr);*/ + Tcl_PushCallFrame(interp, framePtr, Tcl_CallFrame_nsPtr(Tcl_Interp_varFramePtr(interp)), + 1|FRAME_IS_XOTCL_OBJECT); + + Tcl_CallFrame_procPtr(framePtr) = &RUNTIME_STATE(interp)->fakeProc; + if (object->varTable == NULL) { + object->varTable = VarHashTableCreate(); + /*fprintf(stderr, "+++ create varTable %p in PushFrameObj obj %p framePtr %p\n", + object->varTable, object, framePtr);*/ + } + Tcl_CallFrame_varTablePtr(framePtr) = object->varTable; + /*fprintf(stderr,"+++ setting varTable %p in varFrame %p\n",object->varTable,framePtr);*/ + } + Tcl_CallFrame_clientData(framePtr) = (ClientData)object; +} + +static void XOTcl_PopFrameObj(Tcl_Interp *interp, Tcl_CallFrame *framePtr) { + /*fprintf(stderr,"POP OBJECT_FRAME (XOTcl_PopFrame) frame %p, vartable %p set to NULL, already %d\n", + framePtr, Tcl_CallFrame_varTablePtr(framePtr), Tcl_CallFrame_varTablePtr(framePtr) == NULL);*/ + Tcl_CallFrame_varTablePtr(framePtr) = NULL; + Tcl_PopCallFrame(interp); +} + +static void XOTcl_PushFrameCsc(Tcl_Interp *interp, XOTclCallStackContent *cscPtr, Tcl_CallFrame *framePtr) { + CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); + + /*fprintf(stderr,"PUSH CMETHOD_FRAME (XOTcl_PushFrame) frame %p object->nsPtr %p interp ns %p\n", + framePtr,object->nsPtr, + Tcl_CallFrame_nsPtr(varFramePtr));*/ + + Tcl_PushCallFrame(interp, framePtr, Tcl_CallFrame_nsPtr(varFramePtr), + 1|FRAME_IS_XOTCL_CMETHOD); + Tcl_CallFrame_clientData(framePtr) = (ClientData)cscPtr; + Tcl_CallFrame_procPtr(framePtr) = &RUNTIME_STATE(interp)->fakeProc; +} + +static void XOTcl_PopFrameCsc(Tcl_Interp *interp, Tcl_CallFrame *framePtr) { + /*fprintf(stderr,"POP CMETHOD_FRAME (XOTcl_PopFrame) frame %p, varTable = %p\n", + framePtr, Tcl_CallFrame_varTablePtr(framePtr));*/ + Tcl_PopCallFrame(interp); +} + +/* + * stack query operations + */ + +static Tcl_CallFrame * +activeProcFrame(Tcl_CallFrame *framePtr) { + for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { + register int flag = Tcl_CallFrame_isProcCallFrame(framePtr); + + if (flag & FRAME_IS_XOTCL_METHOD) { + /* never return an inactive method frame */ + if (!(((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr))->frameType + & XOTCL_CSC_TYPE_INACTIVE)) break; + } else { + if (flag & (FRAME_IS_XOTCL_CMETHOD|FRAME_IS_XOTCL_OBJECT)) continue; + if (flag == 0 || flag & FRAME_IS_PROC) break; + } + } + return framePtr; +} + +static Tcl_CallFrame * +nextFrameOfType(Tcl_CallFrame *framePtr, int flags) { + for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { + if (Tcl_CallFrame_isProcCallFrame(framePtr) & flags) + return framePtr; + } + return framePtr; +} + +XOTCLINLINE static XOTclObject* +GetSelfObj(Tcl_Interp *interp) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + /*fprintf(stderr, "GetSelfObj interp has frame %p and varframe %p\n", + Tcl_Interp_framePtr(interp),Tcl_Interp_varFramePtr(interp));*/ + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + register int flag = Tcl_CallFrame_isProcCallFrame(varFramePtr); +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "GetSelfObj check frame %p flags %.6x cd %p objv[0] %s\n", + varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr), + Tcl_CallFrame_clientData(varFramePtr), + Tcl_CallFrame_objc(varFramePtr) ? ObjStr(Tcl_CallFrame_objv(varFramePtr)[0]) : "(null)"); +#endif + if (flag & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "... self returns %p %.6x %s\n", cscPtr->self, + cscPtr->self->flags, objectName(cscPtr->self)); +#endif + return cscPtr->self; + } else if (flag & FRAME_IS_XOTCL_OBJECT) { +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "... self returns %s\n", + objectName(((XOTclObject*)Tcl_CallFrame_clientData(varFramePtr)))); +#endif + return (XOTclObject *)Tcl_CallFrame_clientData(varFramePtr); + } + } + return NULL; +} + +static XOTclCallStackContent* +CallStackGetFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { +# if defined(TCL85STACK_TRACE) + fprintf(stderr, "... check frame %p flags %.6x cd %p objv[0] %s\n", + varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr), + Tcl_CallFrame_clientData(varFramePtr), + Tcl_CallFrame_objc(varFramePtr) ? ObjStr(Tcl_CallFrame_objv(varFramePtr)[0]) : "(null)"); +# endif + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + if (framePtrPtr) *framePtrPtr = varFramePtr; + return (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + } + } + if (framePtrPtr) *framePtrPtr = NULL; + return NULL; +} + +XOTCLINLINE static XOTclCallStackContent* +CallStackGetTopFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr) { + return CallStackGetFrame(interp, framePtrPtr); +} + +/* find last invocation of a scripted method */ +static XOTclCallStackContent * +XOTclCallStackFindLastInvocation(Tcl_Interp *interp, int offset, Tcl_CallFrame **framePtrPtr) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + int lvl = Tcl_CallFrame_level(varFramePtr); + + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_XOTCL_METHOD) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + if ((cscPtr->callType & XOTCL_CSC_CALL_IS_NEXT) || (cscPtr->frameType & XOTCL_CSC_TYPE_INACTIVE)) { + continue; + } + if (offset) { + offset--; + } else { + if (Tcl_CallFrame_level(varFramePtr) < lvl) { + if (framePtrPtr) *framePtrPtr = varFramePtr; + return cscPtr; + } + } + } + } + if (framePtrPtr) *framePtrPtr = NULL; + return NULL; +} + +static XOTclCallStackContent * +XOTclCallStackFindActiveFrame(Tcl_Interp *interp, int offset, Tcl_CallFrame **framePtrPtr) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + /* skip #offset frames */ + for (; offset>0 && varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr), offset--); + + /* search for first active frame and set tcl frame pointers */ + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_XOTCL_METHOD/*(FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)*/) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + if (!(cscPtr->frameType & XOTCL_CSC_TYPE_INACTIVE)) { + /* we found the highest active frame */ + if (framePtrPtr) *framePtrPtr = varFramePtr; + return cscPtr; + } + } + } + /* we could not find an active frame; called from toplevel? */ + if (framePtrPtr) *framePtrPtr = NULL; + return NULL; +} + +static void +CallStackUseActiveFrames(Tcl_Interp *interp, callFrameContext *ctx) { + Tcl_CallFrame + *inFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp), + *framePtr; + + /*XOTclCallStackFindActiveFrame(interp, 0, &activeFramePtr);*/ +# if defined(TCL85STACK_TRACE) + tcl85showStack(interp); +# endif + /* Get the first active non object frame */ + framePtr = activeProcFrame(inFramePtr); + + /*fprintf(stderr,"... use frameptr %p \n", framePtr);*/ + + if (inFramePtr == framePtr) { + /* call frame pointers are fine */ + ctx->framesSaved = 0; + } else { + ctx->varFramePtr = inFramePtr; + Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; + ctx->framesSaved = 1; + } +} + + +static XOTclCallStackContent * +CallStackFindActiveFilter(Tcl_Interp *interp) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + return cscPtr; + } + } + } + /* for some reasons, we could not find invocation (topLevel, destroy) */ + return NULL; +} + +/* + * check, if there is an active filters on "obj" using cmd + */ +XOTCLINLINE static int +FilterActiveOnObj(Tcl_Interp *interp, XOTclObject *object, Tcl_Command cmd) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + if (cmd == cscPtr->cmdPtr && object == cscPtr->self && + cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + return 1; + } + } + } + return 0; +} + +static void +CallStackReplaceVarTableReferences(Tcl_Interp *interp, TclVarHashTable *oldVarTablePtr, TclVarHashTable *newVarTablePtr) { + Tcl_CallFrame *framePtr; + + for (framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); framePtr; + framePtr = Tcl_CallFrame_callerPtr(framePtr)) { + int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); + + if (!(frameFlags & FRAME_IS_XOTCL_OBJECT)) continue; + if (!(Tcl_CallFrame_varTablePtr(framePtr) == oldVarTablePtr)) continue; + + /*fprintf(stderr, "+++ makeObjNamespace replacing vartable %p with %p in frame %p\n", + oldVarTablePtr, newVarTablePtr, framePtr);*/ + Tcl_CallFrame_varTablePtr(framePtr) = newVarTablePtr; + } +} + +static void +CallStackClearCmdReferences(Tcl_Interp *interp, Tcl_Command cmd) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + if (cscPtr->cmdPtr == cmd) { + cscPtr->cmdPtr = NULL; + } + } + } +} + + +#if 0 +/* just used by XOTclONextMethod() */ +static XOTclCallStackContent* +CallStackGetObjectFrame(Tcl_Interp *interp, XOTclObject *object) { + register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + + for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { + if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); + if (cscPtr->self == object) { + return cscPtr; + } + } + } + return NULL; +} +#endif + +/* + * Pop any callstack entry that is still alive (e.g. + * if "exit" is called and we were jumping out of the + * callframe + */ +static void CallStackPopAll(Tcl_Interp *interp) { + /*tcl85showStack(interp);*/ + + while (1) { + Tcl_CallFrame *framePtr = Tcl_Interp_framePtr(interp); + int frameFlags; + + if (!framePtr) break; + if (Tcl_CallFrame_level(framePtr) == 0) break; + + frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); + /*fprintf(stderr, "--- popping %p frameflags %.6x\n", framePtr, frameFlags);*/ + + if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { + /* free the call stack content; we need this just for decr activation count */ + XOTclCallStackContent *cscPtr = ((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr)); + CscFinish(interp, cscPtr); + } else if (frameFlags & FRAME_IS_XOTCL_OBJECT) { + Tcl_CallFrame_varTablePtr(framePtr) = NULL; + } + + /* pop the Tcl frame */ + Tcl_PopCallFrame(interp); + } +} + +/* + *---------------------------------------------------------------------- + * CscInit -- + * + * Initialize call stack content and track activation counts + * of involved objects and classes + * + * Results: + * None. + * + * Side effects: + * Initialized Csc, updated activation counts + * + *---------------------------------------------------------------------- + */ + +XOTCLINLINE static void +CscInit(/*@notnull@*/ XOTclCallStackContent *cscPtr, XOTclObject *object, XOTclClass *cl, Tcl_Command cmd, int frameType) { + + assert(cscPtr); + + /* + * track object activations + */ + object->activationCount ++; + + /* + * track class activations + */ + if (cl) { + Namespace *nsPtr = ((Command *)cmd)->nsPtr; + cl->object.activationCount ++; + /*fprintf(stderr, "... %s cmd %s cmd ns %p (%s, refCount %d ++) obj ns %p parent %p\n", + className(cl), + Tcl_GetCommandName(object->teardown, cmd), + nsPtr, nsPtr->fullName, nsPtr->refCount, + cl->object.nsPtr,cl->object.nsPtr ? ((Namespace*)cl->object.nsPtr)->parentPtr : NULL);*/ + + /* incremement the namespace ptr in case tcl tries to delete this namespace + during the invocation */ + nsPtr->refCount ++; + } + + /* fprintf(stderr, "incr activationCount for %s to %d\n", objectName(object), object->activationCount); */ + cscPtr->self = object; + cscPtr->cl = cl; + cscPtr->cmdPtr = cmd; + cscPtr->frameType = frameType; + cscPtr->callType = 0; + cscPtr->filterStackEntry = frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER ? object->filterStack : NULL; + cscPtr->objv = NULL; + +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "PUSH csc %p type %d obj %s, self=%p cmd=%p (%s) id=%p (%s) obj refcount %d name refcount %d\n", + cscPtr, frameType, objectName(object), object, + cmd, (char *) Tcl_GetCommandName(object->teardown, cmd), + object->id, object->id ? Tcl_GetCommandName(object->teardown, object->id) : "(deleted)", + object->id ? Tcl_Command_refCount(object->id) : -100, object->cmdName->refCount + ); +#endif +} + +/* + *---------------------------------------------------------------------- + * CscFinish -- + * + * Counterpart of CscInit(). Decrement activation counts + * and delete objects/classes if necessary. + * + * Results: + * None. + * + * Side effects: + * potentially deletes objects, classes or namespaces. + * + *---------------------------------------------------------------------- + */ +XOTCLINLINE static void +CscFinish(Tcl_Interp *interp, XOTclCallStackContent *cscPtr) { + XOTclObject *object = cscPtr->self; + int allowDestroy = RUNTIME_STATE(interp)->exitHandlerDestroyRound != + XOTCL_EXITHANDLER_ON_SOFT_DESTROY; + +#if defined(TCL85STACK_TRACE) + fprintf(stderr, "POP csc=%p, obj %s method %s\n", cscPtr, objectName(object), + Tcl_GetCommandName(interp, cscPtr->cmdPtr)); +#endif + /* + tracking activations of objects + */ + object->activationCount --; + + /*fprintf(stderr, "decr activationCount for %s to %d cscPtr->cl %p\n", objectName(cscPtr->self), + cscPtr->self->activationCount, cscPtr->cl);*/ + + if (object->activationCount < 1 && object->flags & XOTCL_DESTROY_CALLED && allowDestroy) { + CallStackDoDestroy(interp, object); + } +#if defined(OBJDELETION_TRACE) + else if (!allowDestroy) { + fprintf(stderr,"checkFree %p %s\n",object, objectName(object)); + } +#endif + + /* + tracking activations of classes + */ + if (cscPtr->cl) { + Namespace *nsPtr = cscPtr->cmdPtr ? ((Command *)(cscPtr->cmdPtr))->nsPtr : NULL; + + object = &cscPtr->cl->object; + object->activationCount --; + /* fprintf(stderr, "CscFinish cl=%p %s (%d) flags %.6x cl ns=%p cmd %p cmd ns %p\n", + object, objectName(object), object->activationCount, object->flags, cscPtr->cl->nsPtr, + cscPtr->cmdPtr, ((Command *)cscPtr->cmdPtr)->nsPtr); */ + + /*fprintf(stderr, "CscFinish check ac %d flags %.6x\n", + object->activationCount, object->flags & XOTCL_DESTROY_CALLED);*/ + + if (object->activationCount < 1 && object->flags & XOTCL_DESTROY_CALLED && allowDestroy) { + CallStackDoDestroy(interp, object); + } +#if defined(OBJDELETION_TRACE) + else if (!allowDestroy) { + fprintf(stderr,"checkFree %p %s\n",object, objectName(object)); + } +#endif + + if (nsPtr) { + nsPtr->refCount--; + /*fprintf(stderr, "CscFinish parent %s activationCount %d flags %.4x refCount %d\n", + nsPtr->fullName, nsPtr->activationCount, nsPtr->flags, nsPtr->refCount);*/ + + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + /* the namspace refcound has reached 0, we have to free + it. unfortunately, NamespaceFree() is not exported */ + /* TODO: remove me finally */ + fprintf(stderr, "HAVE TO FREE %p\n",nsPtr); + /*NamespaceFree(nsPtr);*/ + ckfree(nsPtr->fullName); + ckfree(nsPtr->name); + ckfree((char*)nsPtr); + } + } + + } + /*fprintf(stderr, "CscFinish done\n");*/ + +} + + Index: generic/nsfStubInit.c =================================================================== diff -u -N -r1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- generic/nsfStubInit.c (.../nsfStubInit.c) (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ generic/nsfStubInit.c (.../nsfStubInit.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -10,7 +10,7 @@ * */ -#include "xotclInt.h" +#include "nsfInt.h" /* * Remove macros that will interfere with the definitions below. Index: generic/nsfStubLib.c =================================================================== diff -u -N -r1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- generic/nsfStubLib.c (.../nsfStubLib.c) (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ generic/nsfStubLib.c (.../nsfStubLib.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -1,102 +1,102 @@ -/* - * nsfStubLib.c -- - * - * Stub object that will be statically linked into extensions of XOTcl - * - * Copyright (c) 2001-2008 Gustaf Neumann, Uwe Zdun - * Copyright (c) 1998 Paul Duffin. - * - * See the file "tcl-license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - */ - -/* - * We need to ensure that we use the stub macros so that this file contains - * no references to any of the stub functions. This will make it possible - * to build an extension that references Tcl_InitStubs but doesn't end up - * including the rest of the stub functions. - */ - -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif -#undef USE_TCL_STUB_PROCS - -/* - * This ensures that the Nsf_InitStubs has a prototype in - * xotcl.h and is not the macro that turns it into Tcl_PkgRequire - */ - -#ifndef USE_XOTCL_STUBS -# define USE_XOTCL_STUBS -#endif - -#include "xotclInt.h" - -#if defined(PRE86) -extern NsfStubs *nsfStubsPtr; -#else -MODULE_SCOPE const NsfStubs *nsfStubsPtr; -MODULE_SCOPE const NsfIntStubs *nsfIntStubsPtr; -#endif -CONST86 NsfStubs *nsfStubsPtr = NULL; -CONST86 NsfIntStubs *nsfIntStubsPtr = NULL; - - -/* - *---------------------------------------------------------------------- - * - * Xotcl_InitStubs -- - * - * Tries to initialise the stub table pointers and ensures that - * the correct version of XOTcl is loaded. - * - * Results: - * The actual version of XOTcl that satisfies the request, or - * NULL to indicate that an error occurred. - * - * Side effects: - * Sets the stub table pointers. - * - *---------------------------------------------------------------------- - */ - -CONST char * -Xotcl_InitStubs (Tcl_Interp *interp, CONST char *version, int exact) { - CONST char *actualVersion; - const char *packageName = "XOTcl"; - ClientData clientData = NULL; - - actualVersion = Tcl_PkgRequireEx(interp, "XOTcl", version, exact, - &clientData); - - if (clientData == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", - "package not present or incomplete", NULL); - return NULL; - } else { - CONST86 NsfStubs * const stubsPtr = clientData; - CONST86 NsfIntStubs * const intStubsPtr = stubsPtr->hooks ? - stubsPtr->hooks->nsfIntStubs : NULL; - - if (actualVersion == NULL) { - return NULL; - } - - if (!stubsPtr || !intStubsPtr) { - static char *errMsg = "missing stub table pointer"; - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Error loading ", packageName, " package", - " (requested version '", version, "', loaded version '", - actualVersion, "'): ", errMsg, NULL); - return NULL; - } - - nsfStubsPtr = stubsPtr; - nsfIntStubsPtr = intStubsPtr; - - return actualVersion; - } -} +/* + * nsfStubLib.c -- + * + * Stub object that will be statically linked into extensions of XOTcl + * + * Copyright (c) 2001-2008 Gustaf Neumann, Uwe Zdun + * Copyright (c) 1998 Paul Duffin. + * + * See the file "tcl-license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + */ + +/* + * We need to ensure that we use the stub macros so that this file contains + * no references to any of the stub functions. This will make it possible + * to build an extension that references Tcl_InitStubs but doesn't end up + * including the rest of the stub functions. + */ + +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#undef USE_TCL_STUB_PROCS + +/* + * This ensures that the Nsf_InitStubs has a prototype in + * nsf.h and is not the macro that turns it into Tcl_PkgRequire + */ + +#ifndef USE_NSF_STUBS +# define USE_NSF_STUBS +#endif + +#include "nsfInt.h" + +#if defined(PRE86) +extern NsfStubs *nsfStubsPtr; +#else +MODULE_SCOPE const NsfStubs *nsfStubsPtr; +MODULE_SCOPE const NsfIntStubs *nsfIntStubsPtr; +#endif +CONST86 NsfStubs *nsfStubsPtr = NULL; +CONST86 NsfIntStubs *nsfIntStubsPtr = NULL; + + +/* + *---------------------------------------------------------------------- + * + * Nsf_InitStubs -- + * + * Tries to initialise the stub table pointers and ensures that + * the correct version of nsf is loaded. + * + * Results: + * The actual version of nsf that satisfies the request, or + * NULL to indicate that an error occurred. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ + +CONST char * +Nsf_InitStubs (Tcl_Interp *interp, CONST char *version, int exact) { + CONST char *actualVersion; + const char *packageName = "XOTcl"; + ClientData clientData = NULL; + + actualVersion = Tcl_PkgRequireEx(interp, "nsf", version, exact, + &clientData); + + if (clientData == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", + "package not present or incomplete", NULL); + return NULL; + } else { + CONST86 NsfStubs * const stubsPtr = clientData; + CONST86 NsfIntStubs * const intStubsPtr = stubsPtr->hooks ? + stubsPtr->hooks->nsfIntStubs : NULL; + + if (actualVersion == NULL) { + return NULL; + } + + if (!stubsPtr || !intStubsPtr) { + static char *errMsg = "missing stub table pointer"; + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package", + " (requested version '", version, "', loaded version '", + actualVersion, "'): ", errMsg, NULL); + return NULL; + } + + nsfStubsPtr = stubsPtr; + nsfIntStubsPtr = intStubsPtr; + + return actualVersion; + } +} Index: generic/nsfTrace.c =================================================================== diff -u -N --- generic/nsfTrace.c (revision 0) +++ generic/nsfTrace.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,144 @@ +/* -*- Mode: c++ -*- + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * + * xotclTrace.c -- + * + * Tracing facilities for XOTcl + * + */ + +#include "nsfInt.h" +#include "nsfAccessInt.h" + +void +XOTclStackDump(Tcl_Interp *interp) { + Interp *iPtr = (Interp *)interp; + CallFrame *f = iPtr->framePtr, *v = iPtr->varFramePtr; + Tcl_Obj *varCmdObj; + + XOTclNewObj(varCmdObj); + fprintf (stderr, " TCL STACK:\n"); + if (f == 0) fprintf(stderr, "- "); + while (f) { + Tcl_Obj *cmdObj; + XOTclNewObj(cmdObj); + fprintf(stderr, "\tFrame=%p ", f); + if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) { + fprintf(stderr,"caller %p ",Tcl_CallFrame_callerPtr(f)); + fprintf(stderr,"callerV %p ",Tcl_CallFrame_callerVarPtr(f)); + Tcl_GetCommandFullName(interp, (Tcl_Command) f->procPtr->cmdPtr, cmdObj); + fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level); + DECR_REF_COUNT(cmdObj); + } else { + if (f && f->varTablePtr) { + fprintf(stderr, "var_table = %p ",f->varTablePtr); + } + fprintf(stderr, "- \n"); + } + + f = f->callerPtr; + } + + fprintf (stderr, " VARFRAME:\n"); + fprintf(stderr, "\tFrame=%p ", v); + if (v) { + fprintf(stderr, "caller %p var_table %p ", v->callerPtr, v->varTablePtr); + /* if (v->varTablePtr) + panic(0, "testing");*/ + } + if (v && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) { + Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj); + if (varCmdObj) { + fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level); + } + } else fprintf(stderr, "- \n"); + DECR_REF_COUNT(varCmdObj); +} + +void +XOTclPrintObjv(char *string, int objc, Tcl_Obj *CONST objv[]) { + int j; + fprintf(stderr, "%s", string); + for (j = 0; j < objc; j++) { + /*fprintf(stderr, " objv[%d]=%s, ",j, objv[j] ? ObjStr(objv[j]) : "NULL");*/ + fprintf(stderr, " objv[%d]=%s %p, ",j, objv[j] ? ObjStr(objv[j]) : "NULL", objv[j]); + } + fprintf(stderr, "\n"); +} + +#ifdef XOTCL_MEM_COUNT +void +XOTclMemCountAlloc(char *id, void *p) { + int new; + XOTclMemCounter *entry; + Tcl_HashTable *table = &xotclMemCount; + Tcl_HashEntry *hPtr; + hPtr = Tcl_CreateHashEntry(table, id, &new); +#ifdef XOTCL_MEM_TRACE + fprintf(stderr, "+++ alloc %s %p\n",id,p); +#endif + /*fprintf(stderr,"+++alloc '%s'\n",id);*/ + if (new) { + entry = (XOTclMemCounter*)ckalloc(sizeof(XOTclMemCounter)); + entry->count = 1; + entry->peak = 1; + Tcl_SetHashValue(hPtr, entry); + } else { + entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); + entry->count++; + if (entry->count > entry->peak) + entry->peak = entry->count; + } +} + +void +XOTclMemCountFree(char *id, void *p) { + XOTclMemCounter *entry; + Tcl_HashTable *table = &xotclMemCount; + Tcl_HashEntry *hPtr; +#ifdef XOTCL_MEM_TRACE + fprintf(stderr, "+++ free %s %p\n",id,p); +#endif + + hPtr = Tcl_FindHashEntry(table, id); + if (!hPtr) { + fprintf(stderr, "******** MEM COUNT ALERT: Trying to free <%s>, but was not allocated\n", id); + return; + } + entry = (XOTclMemCounter *)Tcl_GetHashValue(hPtr); + entry->count--; +} + +void +XOTclMemCountDump() { + Tcl_HashTable *table = &xotclMemCount; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + int count = 0; + + xotclMemCountInterpCounter--; + if (xotclMemCountInterpCounter != 0) { + return; + } + + fprintf(stderr, "******** XOTcl MEM Count *********\n* count peak\n"); + + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + char *id = Tcl_GetHashKey(table, hPtr); + XOTclMemCounter *entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); + count += entry->count; + fprintf(stderr, "* %4d %6d %s\n", entry->count, entry->peak, id); + ckfree ((char*) entry); + } + + Tcl_DeleteHashTable(table); + + fprintf(stderr, "******** Count Overall = %d\n", count); +} + +#endif Index: generic/nsfUtil.c =================================================================== diff -u -N --- generic/nsfUtil.c (revision 0) +++ generic/nsfUtil.c (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,124 @@ +/* -*- Mode: c++ -*- + * + * Extended Object Tcl (XOTcl) + * + * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun + * + * + * xotclUtil.c -- + * + * Utility functions + * + */ + +#include "nsfInt.h" + +char * +XOTcl_ltoa(char *buf, long i, int *len) /* fast version of sprintf(buf,"%ld",l); */ { + int nr_written, negative; + char tmp[LONG_AS_STRING], *pointer = &tmp[1], *string, *p; + *tmp = 0; + + if (i<0) { + i = -i; + negative = nr_written = 1; + } else + nr_written = negative = 0; + + do { + nr_written++; + *pointer++ = i%10 + '0'; + i/=10; + } while (i); + + p = string = buf; + if (negative) + *p++ = '-'; + + while ((*p++ = *--pointer)); /* copy number (reversed) from tmp to buf */ + if (len) *len = nr_written; + return string; +} + + +static char *alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; +static int blockIncrement = 8; +/* +static char *alphabet = "ab"; +static int blockIncrement = 2; +*/ +static unsigned char chartable[255] = {0}; + + +char * +XOTclStringIncr(XOTclStringIncrStruct *iss) { + char newch, *currentChar; + + currentChar = iss->buffer + iss->bufSize - 2; + newch = *(alphabet + chartable[(unsigned)*currentChar]); + + while (1) { + if (newch) { /* no overflow */ + *currentChar = newch; + break; + } else { /* overflow */ + *currentChar = *alphabet; /* use first char from alphabet */ + currentChar--; + assert(currentChar >= iss->buffer); + + newch = *(alphabet + chartable[(unsigned)*currentChar]); + if (currentChar < iss->start) { + iss->length++; + if (currentChar == iss->buffer) { + size_t newBufSize = iss->bufSize + blockIncrement; + char *newBuffer = ckalloc(newBufSize); + currentChar = newBuffer+blockIncrement; + /*memset(newBuffer, 0, blockIncrement);*/ + memcpy(currentChar, iss->buffer, iss->bufSize); + *currentChar = newch; + iss->start = currentChar; + ckfree(iss->buffer); + iss->buffer = newBuffer; + iss->bufSize = newBufSize; + } else { + iss->start = currentChar; + } + } + } + } + assert(iss->buffer[iss->bufSize-1] == 0); + assert(iss->buffer[iss->bufSize-2] != 0); + assert(iss->length < iss->bufSize); + assert(iss->start + iss->length + 1 == iss->buffer + iss->bufSize); + + return iss->start; +} + + +void +XOTclStringIncrInit(XOTclStringIncrStruct *iss) { + char *p; + int i = 0; + const size_t bufSize = blockIncrement>2 ? blockIncrement : 2; + + for (p=alphabet; *p; p++) { + chartable[(int)*p] = ++i; + } + + iss->buffer = ckalloc(bufSize); + memset(iss->buffer, 0, bufSize); + iss->start = iss->buffer + bufSize-2; + iss->bufSize = bufSize; + iss->length = 1; + /* + for (i=1; i<50; i++) { + XOTclStringIncr(iss); + fprintf(stderr, "string '%s' (%d)\n", iss->start, iss->length); + } + */ +} + +void +XOTclStringIncrFree(XOTclStringIncrStruct *iss) { + ckfree(iss->buffer); +} Index: generic/xotcl.c =================================================================== diff -u -N --- generic/xotcl.c (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ generic/xotcl.c (revision 0) @@ -1,15206 +0,0 @@ -/* - * XOTcl - Extended Object Tcl - * - * Copyright (C) 1999-2010 Gustaf Neumann (a), Uwe Zdun (a) - * - * (a) Vienna University of Economics and Business Administration - * Institute. of Information Systems and New Media - * A-1090, Augasse 2-6 - * Vienna, Austria - * - * (b) University of Essen - * Specification of Software Systems - * Altendorferstrasse 97-101 - * D-45143 Essen, Germany - * - * Permission to use, copy, modify, distribute, and sell this - * software and its documentation for any purpose is hereby granted - * without fee, provided that the above copyright notice appear in - * all copies and that both that copyright notice and this permission - * notice appear in supporting documentation. We make no - * representations about the suitability of this software for any - * purpose. It is provided "as is" without express or implied - * warranty. - * - * - * This software is based upon MIT Object Tcl by David Wetherall and - * Christopher J. Lindblad, that contains the following copyright - * message: - * - * "Copyright 1993 Massachusetts Institute of Technology - * - * Permission to use, copy, modify, distribute, and sell this - * software and its documentation for any purpose is hereby granted - * without fee, provided that the above copyright notice appear in - * all copies and that both that copyright notice and this - * permission notice appear in supporting documentation, and that - * the name of M.I.T. not be used in advertising or publicity - * pertaining to distribution of the software without specific, - * written prior permission. M.I.T. makes no representations about - * the suitability of this software for any purpose. It is - * provided "as is" without express or implied warranty." - * */ - -#define XOTCL_C 1 -#include "xotclInt.h" -#include "xotclAccessInt.h" - -#ifdef COMPILE_XOTCL_STUBS -# if defined(PRE86) -extern NxStubs nxStubs; -# else -MODULE_SCOPE const NxStubs * const nxConstStubPtr; -# endif -#endif - -#ifdef XOTCL_MEM_COUNT -int xotclMemCountInterpCounter = 0; -#endif - -/* - * Tcl_Obj Types for XOTcl Objects - */ - -#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) -#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) -#endif - -typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; - -typedef struct callFrameContext { - int framesSaved; - Tcl_CallFrame *framePtr; - Tcl_CallFrame *varFramePtr; -} callFrameContext; - -typedef struct XOTclProcContext { - ClientData oldDeleteData; - Tcl_CmdDeleteProc *oldDeleteProc; - XOTclParamDefs *paramDefs; -} XOTclProcContext; - -/* tclCmdClientdata is an incomplete type containing the common field(s) - of ForwardCmdClientData, AliasCmdClientData and SetterCmdClientData - used for filling in at runtime the actual object. */ -typedef struct TclCmdClientData { - XOTclObject *object; -} TclCmdClientData; - -typedef struct SetterCmdClientData { - XOTclObject *object; - XOTclParam *paramsPtr; -} SetterCmdClientData; - -typedef struct ForwardCmdClientData { - XOTclObject *object; - Tcl_Obj *cmdName; - Tcl_ObjCmdProc *objProc; - ClientData clientData; - int passthrough; - int needobjmap; - int verbose; - int hasNonposArgs; - 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 *object; - Tcl_Obj *cmdName; - Tcl_ObjCmdProc *objProc; - ClientData clientData; - XOTclClass *class; - Tcl_Interp *interp; - Tcl_Command aliasedCmd; - Tcl_Command aliasCmd; -} AliasCmdClientData; - -#define PARSE_CONTEXT_PREALLOC 20 -typedef struct { - ClientData *clientData; - Tcl_Obj **objv; - Tcl_Obj **full_objv; - int *flags; - ClientData clientData_static[PARSE_CONTEXT_PREALLOC]; - Tcl_Obj *objv_static[PARSE_CONTEXT_PREALLOC+1]; - int flags_static[PARSE_CONTEXT_PREALLOC+1]; - int lastobjc; - int objc; - int mustDecr; - int varArgs; - XOTclObject *object; -} parseContext; - -static Tcl_ObjType CONST86 *byteCodeType = NULL, *tclCmdNameType = NULL, *listType = NULL; - -int XOTclObjWrongArgs(Tcl_Interp *interp, CONST char *msg, Tcl_Obj *cmdName, Tcl_Obj *methodObj, CONST char *arglist); -static int XOTclDeprecatedCmd(Tcl_Interp *interp, CONST char *what, CONST char *oldCmd, CONST char *newCmd); - -/* methods called directly when CallDirectly() returns NULL */ -static int XOTclCAllocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj); -static int XOTclCCreateMethod(Tcl_Interp *interp, XOTclClass *cl, CONST char *name, int objc, Tcl_Obj *CONST objv[]); -static int XOTclOCleanupMethod(Tcl_Interp *interp, XOTclObject *object); -static int XOTclOConfigureMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); -static int XOTclODestroyMethod(Tcl_Interp *interp, XOTclObject *object); -static int XOTclOResidualargsMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); -static int callDestroyMethod(Tcl_Interp *interp, XOTclObject *object, int flags); - -static int XOTclNextMethod(XOTclObject *object, Tcl_Interp *interp, XOTclClass *givenCl, - CONST char *givenMethodName, int objc, Tcl_Obj *CONST objv[], - int useCSObjs, XOTclCallStackContent *cscPtr); -static int XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc,Tcl_Obj *CONST objv[]); -XOTCLINLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], int flags); -static int DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int DoDealloc(Tcl_Interp *interp, XOTclObject *object); -static int RecreateObject(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); -static void XOTclCleanupObject(XOTclObject *object); -static void finalObjectDeletion(Tcl_Interp *interp, XOTclObject *object); - -static int GetObjectFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj); -static XOTclObject *XOTclpGetObject(Tcl_Interp *interp, CONST char *name); -static XOTclClass *XOTclpGetClass(Tcl_Interp *interp, CONST char *name); -#if !defined(NDEBUG) -static void checkAllInstances(Tcl_Interp *interp, XOTclClass *startCl, int lvl); -#endif - -static int ObjectSystemsCleanup(Tcl_Interp *interp); -static void ObjectSystemsCheckSystemMethod(Tcl_Interp *interp, CONST char *methodName, XOTclObjectSystem *defOsPtr); -static XOTclObjectSystem *GetObjectSystem(XOTclObject *object); - -static void getAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startClass); -static void freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable); - -static Tcl_Obj *NameInNamespaceObj(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns); -static Tcl_Namespace *callingNameSpace(Tcl_Interp *interp); -XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns); -static int setInstVar(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj); - -static void FilterComputeDefined(Tcl_Interp *interp, XOTclObject *object); -static void MixinComputeDefined(Tcl_Interp *interp, XOTclObject *object); -XOTCLINLINE static void GuardAdd(Tcl_Interp *interp, XOTclCmdList *filterCL, Tcl_Obj *guardObj); -static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObjs); -static int GuardCall(XOTclObject *object, XOTclClass *cl, Tcl_Command cmd, Tcl_Interp *interp, - Tcl_Obj *guardObj, XOTclCallStackContent *cscPtr); -static void GuardDel(XOTclCmdList *filterCL); - -static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins); -static int IsSubType(XOTclClass *subcl, XOTclClass *cl); -static int HasMixin(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl); - -static XOTclClass *DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, int isMeta); - -XOTCLINLINE static void CscInit(XOTclCallStackContent *cscPtr, XOTclObject *object, XOTclClass *cl, - Tcl_Command cmd, int frameType); -XOTCLINLINE static void CscFinish(Tcl_Interp *interp, XOTclCallStackContent *cscPtr); -static XOTclCallStackContent *CallStackGetFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr); -XOTCLINLINE static void CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *object); - -static int XOTclInvalidateObjectParameterCmd(Tcl_Interp *interp, XOTclClass *cl); -static int ProcessMethodArguments(parseContext *pcPtr, Tcl_Interp *interp, - XOTclObject *object, int pushFrame, XOTclParamDefs *paramDefs, - CONST char *methodName, int objc, Tcl_Obj *CONST objv[]); -static int ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int doCheck, - int *flags, ClientData *clientData, Tcl_Obj **outObjPtr); -static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, - const char *varNamePrefix, int doCheck, XOTclParam **paramPtrPtr); - -static CONST char* AliasIndex(Tcl_DString *dsPtr, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); -static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object, CONST char *cmd); -static int AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); -static Tcl_Obj *AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); -static int ListMethodHandle(Tcl_Interp *interp, XOTclObject *object, int withPer_object, - CONST char *methodName); - -static void -parseContextInit(parseContext *pcPtr, int objc, XOTclObject *object, Tcl_Obj *procName) { - if (objc < PARSE_CONTEXT_PREALLOC) { - /* the single larger memset below .... */ - memset(pcPtr, 0, sizeof(parseContext)); - /* ... is faster than the two smaller memsets below */ - /* memset(pcPtr->clientData_static, 0, sizeof(ClientData)*(objc)); - memset(pcPtr->objv_static, 0, sizeof(Tcl_Obj*)*(objc+1));*/ - pcPtr->full_objv = &pcPtr->objv_static[0]; - pcPtr->clientData = &pcPtr->clientData_static[0]; - pcPtr->flags = &pcPtr->flags_static[0]; - } else { - pcPtr->full_objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*(objc+1)); - pcPtr->flags = (int*)ckalloc(sizeof(int)*(objc+1)); - pcPtr->clientData = (ClientData*)ckalloc(sizeof(ClientData)*objc); - /*fprintf(stderr, "ParseContextMalloc %d objc, %p %p\n", objc, pcPtr->full_objv, pcPtr->clientData);*/ - memset(pcPtr->full_objv, 0, sizeof(Tcl_Obj*)*(objc+1)); - memset(pcPtr->flags, 0, sizeof(int)*(objc+1)); - memset(pcPtr->clientData, 0, sizeof(ClientData)*(objc)); - } - pcPtr->objv = &pcPtr->full_objv[1]; - pcPtr->full_objv[0] = procName; - pcPtr->object = object; - pcPtr->varArgs = 0; - pcPtr->mustDecr = 0; -} - -static void parseContextExtendObjv(parseContext *pcPtr, int from, int elts, Tcl_Obj *CONST source[]) { - int requiredSize = from + elts + 1; - - /*XOTclPrintObjv("BEFORE: ", pcPtr->objc, pcPtr->full_objv);*/ - - if (requiredSize >= PARSE_CONTEXT_PREALLOC) { - if (pcPtr->objv == &pcPtr->objv_static[1]) { - /* realloc from preallocated memory */ - pcPtr->full_objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * requiredSize); - memcpy(pcPtr->full_objv, &pcPtr->objv_static[0], sizeof(Tcl_Obj*) * PARSE_CONTEXT_PREALLOC); - /*fprintf(stderr, "alloc %d new objv=%p pcPtr %p\n", requiredSize, pcPtr->full_objv, pcPtr);*/ - } else { - /* realloc from mallocated memory */ - pcPtr->full_objv = (Tcl_Obj **)ckrealloc((char *)pcPtr->full_objv, sizeof(Tcl_Obj*) * requiredSize); - /*fprintf(stderr, "realloc %d new objv=%p pcPtr %p\n", requiredSize, pcPtr->full_objv, pcPtr);*/ - } - pcPtr->objv = &pcPtr->full_objv[1]; - } - - memcpy(pcPtr->objv + from, source, sizeof(Tcl_Obj *) * (elts)); - pcPtr->objc += elts; - - /*XOTclPrintObjv("AFTER: ", pcPtr->objc, pcPtr->full_objv);*/ -} - -static void parseContextRelease(parseContext *pcPtr) { - if (pcPtr->mustDecr) { - int i; - for (i = 0; i < pcPtr->lastobjc; i++) { - if (pcPtr->flags[i] & XOTCL_PC_MUST_DECR) { - DECR_REF_COUNT(pcPtr->objv[i]); - } - } - } - - /* objv can be separately extended */ - if (pcPtr->objv != &pcPtr->objv_static[1]) { - /*fprintf(stderr, "parseContextRelease %p free %p %p\n", pcPtr, pcPtr->full_objv, pcPtr->clientData);*/ - ckfree((char *)pcPtr->full_objv); - } - /* if the parameter definition was extended, both clientData and flags are extended */ - if (pcPtr->clientData != &pcPtr->clientData_static[0]) { - /*fprintf(stderr, "free clientdata and flags\n");*/ - ckfree((char *)pcPtr->clientData); - ckfree((char *)pcPtr->flags); - } -} - -/* - * Var Reform Compatibility support. - * - * Definitions for accessing Tcl variable structures after varreform - * in Tcl 8.5. - */ - -#define TclIsCompiledLocalArgument(compiledLocalPtr) ((compiledLocalPtr)->flags & VAR_ARGUMENT) -#define TclIsCompiledLocalTemporary(compiledLocalPtr) ((compiledLocalPtr)->flags & VAR_TEMPORARY) - -#define VarHashGetValue(hPtr) ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) -#define VarHashGetKey(varPtr) (((VarInHash *)(varPtr))->entry.key.objPtr) -#define VarHashTable(varTable) &(varTable)->table -#define valueOfVar(type, varPtr, field) (type *)(varPtr)->value.field - -XOTCLINLINE static Tcl_Namespace * -ObjFindNamespace(Tcl_Interp *interp, Tcl_Obj *objPtr) { - Tcl_Namespace *nsPtr; - - if (TclGetNamespaceFromObj(interp, objPtr, &nsPtr) == TCL_OK) { - return nsPtr; - } else { - return NULL; - } -} - -static XOTCLINLINE Var * -VarHashCreateVar(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; -} - -static TclVarHashTable * -VarHashTableCreate() { - TclVarHashTable *varTablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varTablePtr, NULL); - return varTablePtr; -} - -#if 0 -static int duringBootstrap(Tcl_Interp *interp) { - Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::nsf::bootstrap", NULL, TCL_GLOBAL_ONLY); - return (bootstrap != NULL); -} -#endif - -/* - * call an XOTcl method - */ -static int -callMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *methodObj, - int objc, Tcl_Obj *CONST objv[], int flags) { - XOTclObject *object = (XOTclObject*) clientData; - int result; - ALLOC_ON_STACK(Tcl_Obj*, objc, tov); - /*fprintf(stderr, "%%%% callmethod called with method %p\n", methodObj),*/ - - tov[0] = object->cmdName; - tov[1] = methodObj; - - 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(methodObj));for(i=0; i1); - tov[0] = object->cmdName; - tov[1] = methodObj; - 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 = ObjectDispatch(clientData, interp, objc, tov, flags); - - FREE_ON_STACK(Tcl_Obj*, tov); - return result; -} - -#include "xotclStack85.c" - -/* extern callable GetSelfObj */ -XOTcl_Object* -XOTclGetSelfObj(Tcl_Interp *interp) { - return (XOTcl_Object*)GetSelfObj(interp); -} - -#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); -} - -static void printCall(Tcl_Interp *interp, CONST char *string, int objc, Tcl_Obj *CONST objv[]) { - fprintf(stderr, " (%d) >%s: ", Tcl_Interp_numLevels(interp), string); - printObjv(objc, objv); - fprintf(stderr, "\n"); -} -static void printExit(Tcl_Interp *interp, CONST 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))); -} -#endif - - -/* - * XOTclObject Reference Accounting - */ -#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) -#else -# define XOTclObjectRefCountIncr(obj) \ - (obj)->refCount++; \ - MEM_COUNT_ALLOC("XOTclObject RefCount", obj) -# define XOTclObjectRefCountDecr(obj) \ - (obj)->refCount--; \ - MEM_COUNT_FREE("XOTclObject RefCount", obj) -#endif - -#if defined(XOTCLOBJ_TRACE) -void objTrace(char *string, XOTclObject *object) { - if (object) - fprintf(stderr, "--- %s tcl %p %s (%d %p) xotcl %p (%d) %s \n", string, - object->cmdName, object->cmdName->typePtr ? object->cmdName->typePtr->name : "NULL", - object->cmdName->refCount, object->cmdName->internalRep.twoPtrValue.ptr1, - object, obj->refCount, objectName(object)); - else - fprintf(stderr, "--- No object: %s\n", string); -} -#else -# define objTrace(a, b) -#endif - - -/* search for tail of name */ -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(CONST char *string) { - return (strncmp((string), "::nsf::classes", 14) == 0); -} - -/* removes preceding ::nsf::classes from a string */ -XOTCLINLINE static CONST char * -NSCutXOTclClasses(CONST char *string) { - assert(strncmp((string), "::nsf::classes", 14) == 0); - return string+14; -} - -XOTCLINLINE static XOTclObject * -GetObjectFromNsName(Tcl_Interp *interp, CONST char *string, int *fromClassNS) { - /* - * Get object or class from a fully qualified cmd name, such as - * e.g. ::nsf::classes::X - */ - if (isClassName(string)) { - *fromClassNS = 1; - return (XOTclObject *)XOTclpGetClass(interp, NSCutXOTclClasses(string)); - } else { - *fromClassNS = 0; - return XOTclpGetObject(interp, string); - } -} - -XOTCLINLINE static char * -NSCmdFullName(Tcl_Command cmd) { - Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); - return nsPtr ? nsPtr->fullName : ""; -} - -static void -XOTclCleanupObject(XOTclObject *object) { - XOTclObjectRefCountDecr(object); - - if (object->refCount <= 0) { - /*fprintf(stderr, "XOTclCleanupObject %p refcount %d\n", object, object->refCount);*/ - assert(object->refCount == 0); - assert(object->flags & XOTCL_DELETED); - - MEM_COUNT_FREE("XOTclObject/XOTclClass", object); -#if defined(XOTCLOBJ_TRACE) - fprintf(stderr, "CKFREE Object %p refcount=%d\n", object, object->refCount); -#endif -#if !defined(NDEBUG) - memset(object, 0, sizeof(XOTclObject)); -#endif - ckfree((char *) object); - } -} - - -/* - * Tcl_Obj functions for objects - */ - -static int -IsXOTclTclObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **objectPtr) { - Tcl_ObjType CONST86 *cmdType = objPtr->typePtr; - if (cmdType == tclCmdNameType) { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); - if (cmd) { - XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); - if (object) { - *objectPtr = object; - return 1; - } - } - } - return 0; -} - -/* Lookup an XOTcl object from the given objPtr, preferably from an - * object of type "cmdName". objPtr might be converted in this process. - */ - -static int -GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **objectPtr) { - int result; - XOTclObject *nobject; - CONST char *string; - Tcl_Command cmd; - - /*fprintf(stderr, "GetObjectFromObj obj %p %s is of type %s\n", - objPtr, ObjStr(objPtr), objPtr->typePtr ? objPtr->typePtr->name : "(null)");*/ - - /* in case, objPtr was not of type cmdName, try to convert */ - cmd = Tcl_GetCommandFromObj(interp, objPtr); - /*fprintf(stderr, "GetObjectFromObj obj %s => cmd=%p (%d)\n", - ObjStr(objPtr), cmd, cmd ? Tcl_Command_refCount(cmd):-1);*/ - if (cmd) { - XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); - - /*fprintf(stderr, "GetObjectFromObj obj %s, o is %p objProc %p XOTclObjDispatch %p\n", ObjStr(objPtr), - object, Tcl_Command_objProc(cmd), XOTclObjDispatch);*/ - if (object) { - if (objectPtr) *objectPtr = object; - return TCL_OK; - } - } - - /*fprintf(stderr, "GetObjectFromObj convertFromAny for %s type %p %s\n", ObjStr(objPtr), - objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : "(none)");*/ - - /* In case, we have to revolve via the callingNameSpace (i.e. the - * argument is not fully qualified), we retry here. - */ - string = ObjStr(objPtr); - if (!isAbsolutePath(string)) { - Tcl_Obj *tmpName = NameInNamespaceObj(interp, string, callingNameSpace(interp)); - CONST char *nsString = ObjStr(tmpName); - - INCR_REF_COUNT(tmpName); - nobject = XOTclpGetObject(interp, nsString); - /*fprintf(stderr, " RETRY, string '%s' returned %p\n", nsString, nobj);*/ - DECR_REF_COUNT(tmpName); - } else { - nobject = NULL; - } - - if (nobject) { - if (objectPtr) *objectPtr = nobject; - result = TCL_OK; - } else { - result = TCL_ERROR; - } - return result; -} - -static int -GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, - XOTclClass **cl, XOTclClass *baseClass) { - XOTclObject *object; - XOTclClass *cls = NULL; - int result = TCL_OK; - CONST char *objName = ObjStr(objPtr); - Tcl_Command cmd; - - /*fprintf(stderr, "GetClassFromObj %s base %p\n", objName, baseClass);*/ - - cmd = Tcl_GetCommandFromObj(interp, objPtr); - - if (cmd) { - cls = XOTclGetClassFromCmdPtr(cmd); - if (cls == NULL) { - /* - * We have a cmd, but no class; namesspace-imported classes are - * already resolved, but we have to care, if a class is - * "imported" via "interp alias". - */ - Tcl_Interp *alias_interp; - const char *alias_cmd_name; - Tcl_Obj *nameObj = objPtr; - Tcl_Obj **alias_ov; - int alias_oc = 0; - - if (!isAbsolutePath(objName)) { - nameObj = NameInNamespaceObj(interp, objName, callingNameSpace(interp)); - objName = ObjStr(nameObj); - /* adjust path for documented nx.tcl */ - } - - result = Tcl_GetAliasObj(interp, objName, - &alias_interp, &alias_cmd_name, &alias_oc, &alias_ov); - /* we only want aliases with 0 args */ - if (result == TCL_OK && alias_oc == 0) { - cmd = NSFindCommand(interp, alias_cmd_name, NULL); - /*fprintf(stderr, "..... alias arg 0 '%s' cmd %p\n", alias_cmd_name, cmd);*/ - if (cmd) { - cls = XOTclGetClassFromCmdPtr(cmd); - } - } - /*fprintf(stderr, "..... final cmd %p, cls %p\n", cmd , cls);*/ - if (nameObj != objPtr) { - DECR_REF_COUNT(nameObj); - } - } - if (cls) { - if (cl) *cl = cls; - return TCL_OK; - } - } - - result = GetObjectFromObj(interp, objPtr, &object); - if (result == TCL_OK) { - cls = XOTclObjectToClass(object); - if (cls) { - if (cl) *cl = cls; - return TCL_OK; - } else { - /* flag, that we could not convert so far */ - result = TCL_ERROR; - } - } - - /*fprintf(stderr, "try __unknown for %s, result so far is %d\n", objName, result);*/ - if (baseClass) { - Tcl_Obj *methodObj, *nameObj = isAbsolutePath(objName) ? objPtr : - NameInNamespaceObj(interp, objName, callingNameSpace(interp)); - - INCR_REF_COUNT(nameObj); - - methodObj = XOTclMethodObj(interp, &baseClass->object, XO_c_requireobject_idx); - if (methodObj) { - /*fprintf(stderr, "+++ calling __unknown for %s name=%s\n", - className(baseClass), ObjStr(nameObj));*/ - - result = callMethod((ClientData) baseClass, interp, methodObj, - 3, &nameObj, XOTCL_CM_NO_PROTECT); - if (result == TCL_OK) { - result = GetClassFromObj(interp, objPtr, cl, NULL); - } - } - DECR_REF_COUNT(nameObj); - } - - return result; -} - -static Tcl_Obj * -NameInNamespaceObj(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *nsPtr) { - Tcl_Obj *objPtr; - int len; - CONST char *objString; - - /*fprintf(stderr, "NameInNamespaceObj %s (%p, %s) ", name, nsPtr, nsPtr ? nsPtr->fullName:NULL);*/ - if (!nsPtr) - nsPtr = Tcl_GetCurrentNamespace(interp); - /* fprintf(stderr, " (resolved %p, %s) ", nsPtr, nsPtr ? nsPtr->fullName:NULL);*/ - objPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - len = Tcl_GetCharLength(objPtr); - objString = ObjStr(objPtr); - if (len == 2 && objString[0] == ':' && objString[1] == ':') { - } else { - Tcl_AppendLimitedToObj(objPtr, "::", 2, INT_MAX, NULL); - } - Tcl_AppendLimitedToObj(objPtr, name, -1, INT_MAX, NULL); - - /*fprintf(stderr, "returns %s\n", ObjStr(objPtr));*/ - return objPtr; -} - -extern void -XOTclClassListFree(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; - - 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** -XOTclObjectListAdd(XOTclObjects **cList, XOTclObject *object) { - XOTclObjects *l = *cList, *element = NEW(XOTclObjects); - element->obj = object; - element->nextPtr = NULL; - - if (l) { - while (l->nextPtr) l = l->nextPtr; - l->nextPtr = element; - } else - *cList = element; - return &(element->nextPtr); -} - - -/* - * precedence ordering functions - */ - -enum colors { WHITE, GRAY, BLACK }; - -static XOTclClasses *Super(XOTclClass *cl) { return cl->super; } -static XOTclClasses *Sub(XOTclClass *cl) { return cl->sub; } - - -static int -TopoSort(XOTclClass *cl, XOTclClass *baseClass, XOTclClasses *(*next)(XOTclClass*)) { - /*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 - */ - - 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, baseClass, next)) { - cl->color = WHITE; - if (cl == baseClass) { - 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 = baseClass->order; - baseClass->order = pl; - if (cl == baseClass) { - 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); - return cl->order = NULL; -} - -static XOTclClasses* -ComputeOrder(XOTclClass *cl, XOTclClasses *order, XOTclClasses *(*direction)(XOTclClass*)) { - if (order) - return order; - return cl->order = TopoOrder(cl, direction); -} - -extern XOTclClasses* -XOTclComputePrecedence(XOTclClass *cl) { - return ComputeOrder(cl, cl->order, Super); -} - -extern XOTclClasses* -XOTclComputeDependents(XOTclClass *cl) { - return ComputeOrder(cl, cl->order, Sub); -} - - -static void -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 - */ - - 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 *object, XOTclClass *cl) { - object->cl = cl; - if (cl) { - int nw; - (void) Tcl_CreateHashEntry(&cl->instances, (char *)object, &nw); - } -} - -static int -RemoveInstance(XOTclObject *object, XOTclClass *cl) { - if (cl) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&cl->instances, (char *)object, NULL); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - return 1; - } - } - return 0; -} - -/* - * superclass/subclass list maintenance - */ - -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; - } -} - -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); - } -} - -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; -} - -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); - - return sp && sb; -} - -/* - * internal type checking - */ - -extern XOTcl_Class* -XOTclIsClass(Tcl_Interp *interp, ClientData clientData) { - if (clientData && XOTclObjectIsClass((XOTclObject *)clientData)) - return (XOTcl_Class*) clientData; - return 0; -} - -/* - * methods lookup - */ -static int CmdIsProc(Tcl_Command cmd) { - /* In 8.6: TclIsProc((Command*)cmd) is not equiv to the definition below */ - return (Tcl_Command_objProc(cmd) == TclObjInterpProc); -} - -static Proc *GetTclProcFromCommand(Tcl_Command cmd) { - if (cmd) { - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (proc == TclObjInterpProc) - return (Proc*) Tcl_Command_objClientData(cmd); - } - return NULL; -} - -XOTCLINLINE static Tcl_Command -FindMethod(Tcl_Namespace *nsPtr, CONST char *methodName) { - register Tcl_HashEntry *entryPtr; - if ((entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName, NULL))) { - return (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - /*fprintf(stderr, "find %s in %p returns %p\n", methodName, cmdTable, cmd);*/ - return NULL; -} - -static Proc * -FindProcMethod(Tcl_Namespace *nsPtr, CONST char *methodName) { - return GetTclProcFromCommand(FindMethod(nsPtr, methodName)); -} - -static XOTclClass* -SearchPLMethod(register XOTclClasses *pl, CONST char *methodName, Tcl_Command *cmd) { - /* Search the precedence list (class hierarchy) */ -#if 1 - for (; pl; pl = pl->nextPtr) { - register Tcl_HashEntry *entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTable(pl->cl->nsPtr), methodName, NULL); - if (entryPtr) { - *cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - return pl->cl; - } - } -#else - for (; pl; pl = pl->nextPtr) { - if ((*cmd = FindMethod(pl->cl->nsPtr, methodName))) { - return pl->cl; - } - } -#endif - return NULL; -} - - -static XOTclClass* -SearchCMethod(/*@notnull@*/ XOTclClass *cl, CONST char *nm, Tcl_Command *cmd) { - assert(cl); - return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); -} - -/* - * Find a method for a given object in the precedence path - */ -static Tcl_Command -ObjectFindMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *name, XOTclClass **pcl) { - Tcl_Command cmd = NULL; - - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - - if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *mixinList; - for (mixinList = object->mixinOrder; mixinList; mixinList = mixinList->nextPtr) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(mixinList->cmdPtr); - if (mixin && (*pcl = SearchCMethod(mixin, name, &cmd))) { - if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD && !XOTclObjectIsClass(object)) { - cmd = NULL; - continue; - } - break; - } - } - } - - if (!cmd && object->nsPtr) { - cmd = FindMethod(object->nsPtr, name); - } - - if (!cmd && object->cl) - *pcl = SearchCMethod(object->cl, name, &cmd); - - return cmd; -} - -/* - *---------------------------------------------------------------------- - * ObjectSystemFree -- - * - * Free a single object system structure including its root classes. - * - * Results: - * None. - * - * Side effects: - * Free memory of structure, free the root classes. - * - *---------------------------------------------------------------------- - */ - -static void -ObjectSystemFree(Tcl_Interp *interp, XOTclObjectSystem *osPtr) { - int i; - - for (i=0; i<=XO_o_unknown_idx; i++) { - Tcl_Obj *methodObj = osPtr->methods[i]; - /*fprintf(stderr, "ObjectSystemFree [%d] %p ", i, methodObj);*/ - if (methodObj) { - /*fprintf(stderr, "%s refCount %d", ObjStr(methodObj), methodObj->refCount);*/ - DECR_REF_COUNT(methodObj); - } - /*fprintf(stderr, "\n");*/ - } - - if (osPtr->rootMetaClass && osPtr->rootClass) { - RemoveSuper(osPtr->rootMetaClass, osPtr->rootClass); - RemoveInstance((XOTclObject*)osPtr->rootMetaClass, osPtr->rootMetaClass); - RemoveInstance((XOTclObject*)osPtr->rootClass, osPtr->rootMetaClass); - - finalObjectDeletion(interp, &osPtr->rootClass->object); - finalObjectDeletion(interp, &osPtr->rootMetaClass->object); - } - - FREE(XOTclObjectSystem *, osPtr); -} - -/* - *---------------------------------------------------------------------- - * ObjectSystemAdd -- - * - * Add and entry to the list of object systems of the interpreter. - * - * Results: - * None. - * - * Side effects: - * Updating the per interp list of object systems. - * - *---------------------------------------------------------------------- - */ -static void -ObjectSystemAdd(Tcl_Interp *interp, XOTclObjectSystem *osPtr) { - osPtr->nextPtr = RUNTIME_STATE(interp)->objectSystems; - RUNTIME_STATE(interp)->objectSystems = osPtr; -} - -/* - *---------------------------------------------------------------------- - * ObjectSystemsCheckSystemMethod -- - * - * Mark in all object systems the specified method as - * (potentially) overloaded and mark it in the specified - * object system as defined. - * - * Results: - * None. - * - * Side effects: - * Updating the object system structure(s). - * - *---------------------------------------------------------------------- - */ -static void -ObjectSystemsCheckSystemMethod(Tcl_Interp *interp, CONST char *methodName, XOTclObjectSystem *defOsPtr) { - XOTclObjectSystem *osPtr; - int i; - - for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { - for (i=0; i<=XO_o_unknown_idx; i++) { - Tcl_Obj *methodObj = osPtr->methods[i]; - if (methodObj && !strcmp(methodName, ObjStr(methodObj))) { - int flag = 1<definedMethods & flag) { - osPtr->overloadedMethods |= flag; - /*fprintf(stderr, "+++ %s %.6x overloading %s\n", className(defOsPtr->rootClass), - osPtr->overloadedMethods, methodName);*/ - } - if (osPtr == defOsPtr && ((osPtr->definedMethods & flag) == 0)) { - osPtr->definedMethods |= flag; - /*fprintf(stderr, "+++ %s %.6x defining %s\n", className(defOsPtr->rootClass), - osPtr->definedMethods, methodName);*/ - } - } - } - } -} - -/* - *---------------------------------------------------------------------- - * ObjectSystemsCleanup -- - * - * Delete all objects from all defined object systems. This method - * is to be called when an XOTcl process or thread exists. - * - * Results: - * None. - * - * Side effects: - * All commands and objects are deleted, memory is freed. - * - *---------------------------------------------------------------------- - */ -static int -ObjectSystemsCleanup(Tcl_Interp *interp) { - Tcl_HashTable objTable, *commandNameTable = &objTable; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - XOTclObjectSystem *osPtr, *nPtr; - - /* Deletion is performed in two rounds: - * (a) SOFT DESTROY: invoke all user-defined destroy methods - * without destroying objects - * (b) PHYSICAL DESTROY: delete the objects and classes, - * destroy methods are not invoked anymore - * - * This is to prevent that the destroy order causes classes to be - * deleted before the methods invoked by destroy are executed. Note - * that it is necessary to iterate over all object systems - * simultaneous, since the might be dependencies between objects of - * different object systems. - */ - - Tcl_InitHashTable(commandNameTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandNameTable); - - /* collect all instances from all object systems */ - for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { - /*fprintf(stderr, "destroyObjectSystem deletes %s\n", className(osPtr->rootClass));*/ - getAllInstances(interp, commandNameTable, osPtr->rootClass); - } - - /***** SOFT DESTROY *****/ - RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; - /*fprintf(stderr, "===CALL destroy on OBJECTS\n");*/ - - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); - XOTclObject *object = XOTclpGetObject(interp, key); - /* fprintf(stderr, "key = %s %p %d\n", - key, obj, obj && !XOTclObjectIsClass(object)); */ - if (object && !XOTclObjectIsClass(object) - && !(object->flags & XOTCL_DESTROY_CALLED)) { - callDestroyMethod(interp, object, 0); - } - } - - /*fprintf(stderr, "===CALL destroy on CLASSES\n");*/ - - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); - XOTclClass *cl = XOTclpGetClass(interp, key); - if (cl && !(cl->object.flags & XOTCL_DESTROY_CALLED)) { - callDestroyMethod(interp, (XOTclObject *)cl, 0); - } - } - - /* now, turn of filters, all destroy callbacks are done */ - RUNTIME_STATE(interp)->doFilters = 0; - -#ifdef DO_CLEANUP - freeAllXOTclObjectsAndClasses(interp, commandNameTable); - -# ifdef DO_FULL_CLEANUP - deleteProcsAndVars(interp); -# endif -#endif - - MEM_COUNT_FREE("Tcl_InitHashTable", commandNameTable); - Tcl_DeleteHashTable(commandNameTable); - - /* now free all objects systems with their root classes */ - for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = nPtr) { - nPtr = osPtr->nextPtr; - ObjectSystemFree(interp, osPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * GetObjectSystem -- - * - * Return the object system for which the object was defined - * - * Results: - * Object system pointer - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -static XOTclObjectSystem * -GetObjectSystem(XOTclObject *object) { - if (XOTclObjectIsClass(object)) { - return ((XOTclClass *)object)->osPtr; - } - return object->cl->osPtr; -} - -/* - *---------------------------------------------------------------------- - * CallDirectly -- - * - * Determine when it is possible/necessary to call a method - * implementation directly or via method dispatch. - * - * Results: - * 1 is returned when command should be invoked directly, 0 - * otherwise. - * - * Side effects: - * methodObjPtr is set with the Tcl_Obj of the name of the method, - * if there is one defined. - * - *---------------------------------------------------------------------- - */ -static int CallDirectly(Tcl_Interp *interp, XOTclObject *object, int methodIdx, Tcl_Obj **methodObjPtr) { - /* - We can/must call a C-implemented method directly, when - a) the object system has no such appropriate method defined - - b) the script does not contain a method with the appropriate - name, and - - c) filters are not active on the object - */ - XOTclObjectSystem *osPtr = GetObjectSystem(object); - Tcl_Obj *methodObj = osPtr->methods[methodIdx]; - int callDirectly = 1; - - if (methodObj) { - - if ((osPtr->overloadedMethods & 1<definedMethods & 1<flags & XOTCL_FILTER_ORDER_VALID)) { - FilterComputeDefined(interp, object); - } - /*fprintf(stderr, "CallDirectly object %s idx %s obejct flags %.6x %.6x \n", - objectName(object), sytemMethodOpts[methodIdx]+1, - (object->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID), - XOTCL_FILTER_ORDER_DEFINED_AND_VALID - );*/ - if ((object->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == XOTCL_FILTER_ORDER_DEFINED_AND_VALID) { - /*fprintf(stderr, "CallDirectly object %s idx %s has filter \n", - objectName(object), sytemMethodOpts[methodIdx]+1);*/ - callDirectly = 0; - } - } - } - -#if 0 - fprintf(stderr, "CallDirectly object %s idx %s returns %s => %d\n", - objectName(object), sytemMethodOpts[methodIdx]+1, - methodObj ? ObjStr(methodObj) : "(null)", callDirectly); -#endif - /* return the methodObj in every case */ - *methodObjPtr = methodObj; - return callDirectly; -} - -/* - *---------------------------------------------------------------------- - * XOTclMethodObj -- - * - * Return the methodObj for a given method index. - * - * Results: - * Returns Tcl_Obj* or NULL - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -Tcl_Obj * XOTclMethodObj(Tcl_Interp *interp, XOTclObject *object, int methodIdx) { - XOTclObjectSystem *osPtr = GetObjectSystem(object); - /* - fprintf(stderr, "XOTclMethodObj object %s os %p idx %d %s methodObj %p\n", - objectName(object), osPtr, methodIdx, - XOTcl_SytemMethodOpts[methodIdx]+1, - osPtr->methods[methodIdx]); - */ - return osPtr->methods[methodIdx]; -} - -static int -callDestroyMethod(Tcl_Interp *interp, XOTclObject *object, int flags) { - int result; - Tcl_Obj *methodObj; - - /* don't call destroy after exit handler started physical - destruction, or when it was called already before */ - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == - XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY - || (object->flags & XOTCL_DESTROY_CALLED) - ) - return TCL_OK; - - /*fprintf(stderr, " callDestroy obj %p flags %.6x active %d\n", object, object->flags, - object->activationCount);*/ - - PRINTOBJ("callDestroy", object); - - /* flag, that destroy was called and invoke the method */ - object->flags |= XOTCL_DESTROY_CALLED; - - if (CallDirectly(interp, object, XO_o_destroy_idx, &methodObj)) { - result = XOTclODestroyMethod(interp, object); - } else { - result = callMethod(object, interp, methodObj, 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) - 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", object); -#endif - return result; -} - -/* - * conditional memory allocations of optional storage - */ - -extern XOTclObjectOpt * -XOTclRequireObjectOpt(XOTclObject *object) { - if (!object->opt) { - object->opt = NEW(XOTclObjectOpt); - memset(object->opt, 0, sizeof(XOTclObjectOpt)); - } - return object->opt; -} - -extern XOTclClassOpt* -XOTclRequireClassOpt(/*@notnull@*/ XOTclClass *cl) { - 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; -} - - - - -static Tcl_Namespace* -NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, CONST char *name, int create); - -static void -makeObjNamespace(Tcl_Interp *interp, XOTclObject *object) { -#ifdef NAMESPACE_TRACE - fprintf(stderr, "+++ Make Namespace for %s\n", objectName(object)); -#endif - if (!object->nsPtr) { - Tcl_Namespace *nsPtr; - object->nsPtr = NSGetFreshNamespace(interp, (ClientData)object, - objectName(object), 1); - if (!object->nsPtr) - Tcl_Panic("makeObjNamespace: Unable to make namespace", NULL); - nsPtr = object->nsPtr; - - /* - * Copy all obj variables to the newly created namespace - */ - if (object->varTable) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); - Tcl_HashTable *varHashTable = VarHashTable(varTable); - Tcl_HashTable *objHashTable = VarHashTable(object->varTable); - - *varHashTable = *objHashTable; /* copy the table */ - - if (objHashTable->buckets == objHashTable->staticBuckets) { - varHashTable->buckets = varHashTable->staticBuckets; - } - for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - hPtr->tablePtr = varHashTable; - } - CallStackReplaceVarTableReferences(interp, object->varTable, - (TclVarHashTable *)varHashTable); - - ckfree((char *) object->varTable); - object->varTable = NULL; - } - } -} - -static Tcl_Var -CompiledLocalsLookup(CallFrame *varFramePtr, CONST char *varName) { - int i, localCt = varFramePtr->numCompiledLocals; - Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; - - /*fprintf(stderr, ".. search #local vars %d\n", localCt);*/ - for (i=0 ; icompiledLocals[i]; - } - } - } - return NULL; -} - - -static int -NsColonVarResolver(Tcl_Interp *interp, CONST char *varName, Tcl_Namespace *nsPtr, int flags, Tcl_Var *varPtr) { - Tcl_CallFrame *varFramePtr; - TclVarHashTable *varTablePtr; - XOTclObject *object; - int new, frameFlags; - char firstChar, secondChar; - Tcl_Obj *key; - Var *newVar; - -#if defined (VAR_RESOLVER_TRACE) - fprintf(stderr, "NsColonVarResolver '%s' flags %.6x\n", varName, flags); -#endif - - /* Case 1: The variable is to be resolved in global scope, proceed in - * resolver chain (i.e. return TCL_CONTINUE) - */ - if (flags & TCL_GLOBAL_ONLY) { - /*fprintf(stderr, "global-scoped lookup for var '%s' in NS '%s'\n", varName, - nsPtr->fullName);*/ - return TCL_CONTINUE; - } - - /* Case 2: The lookup happens in a proc frame (lookup in compiled - * locals and hash table vars). We are not interested to handle - * these cases here, so proceed in resolver chain. - */ - varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - assert(varFramePtr); - - frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); -#if defined (VAR_RESOLVER_TRACE) - fprintf(stderr, "NsColonVarResolver '%s' frame flags %.6x\n", varName, - Tcl_CallFrame_isProcCallFrame(varFramePtr)); -#endif - - if (frameFlags & FRAME_IS_PROC) { -#if defined (VAR_RESOLVER_TRACE) - fprintf(stderr, "...... forwarding to next resolver\n"); -#endif - /*fprintf(stderr, "proc-scoped var '%s' assumed, frame %p flags %.6x\n", - name, varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr));*/ - return TCL_CONTINUE; - } - - firstChar = *varName; - secondChar = *(varName+1); - - if (frameFlags & (FRAME_IS_XOTCL_CMETHOD|FRAME_IS_XOTCL_OBJECT)) { - /* - Case 3: we are in an XOTcl frame - */ - if (firstChar == ':') { - if (secondChar != ':') { - /* - * Case 3a: The variable name starts with a single ":". Skip - * the char, but stay in the resolver. - */ - varName ++; - } else { - /* - Case 3b: Names starting with "::" are not for us - */ - return TCL_CONTINUE; - } - } else if (NSTail(varName) != varName) { - /* - Case 3c: Names containing "::" are not for us - */ - return TCL_CONTINUE; - } - - object = (frameFlags & FRAME_IS_XOTCL_CMETHOD) - ? ((XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr))->self - : (XOTclObject *)Tcl_CallFrame_clientData(varFramePtr); - - } else { - /* - * Case 4: we are not in an XOTcl frame, so proceed with a - * TCL_CONTINUE. - */ - return TCL_CONTINUE; - } - - /* We have an object and create the variable if not found */ - assert(object); - - varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; - assert(varTablePtr); - - /* - * Does the variable exist in the object's namespace? - */ - - key = Tcl_NewStringObj(varName, -1); - INCR_REF_COUNT(key); - - *varPtr = (Tcl_Var)VarHashCreateVar(varTablePtr, key, NULL); - -#if defined (VAR_RESOLVER_TRACE) - fprintf(stderr, "...... lookup of '%s' for object '%s' returns %p\n", - varName, objectName(object), *varPtr); -#endif - if (*varPtr == NULL) { - /* - * We failed to find the variable so far, therefore we create it - * in this var table. Note that in several cases above, - * TCL_CONTINUE takes care for variable creation. - */ - - newVar = VarHashCreateVar(varTablePtr, key, &new); - *varPtr = (Tcl_Var)newVar; - } - DECR_REF_COUNT(key); - - return *varPtr ? TCL_OK : TCL_ERROR; -} - -/********************************************************* - * - * Begin of compiled var resolver - * - *********************************************************/ -#define FOR_COLON_RESOLVER(ptr) (*(ptr) == ':' && *(ptr+1) != ':') - -typedef struct xotclResolvedVarInfo { - Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ - XOTclObject *lastObject; - Tcl_Var var; - Tcl_Obj *nameObj; -} xotclResolvedVarInfo; - -/* - *---------------------------------------------------------------------- - * HashVarFree -- - * - * Free hashed variables based on refcount. - * - * Results: - * None. - * - * Side effects: - * Changed refCount or freed variable. - * - *---------------------------------------------------------------------- - */ -static void -HashVarFree(Tcl_Var var) { - if (VarHashRefCount(var) < 2) { - /*fprintf(stderr,"#### free %p\n", var);*/ - ckfree((char *) var); - } else { - VarHashRefCount(var)--; - } -} - -/* - *---------------------------------------------------------------------- - * CompiledColonVarFetch -- - * - * Fetch value of a a compiled XOTcl instance variable at runtime. - * - * Results: - * Tcl_Var containing value or NULL. - * - * Side effects: - * Updates of Variable structure cache in necessary. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Var -CompiledColonVarFetch(Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr) { - xotclResolvedVarInfo *resVarInfo = (xotclResolvedVarInfo *)vinfoPtr; - XOTclCallStackContent *cscPtr = CallStackGetFrame(interp, NULL); - XOTclObject *object = cscPtr ? cscPtr->self : NULL; - TclVarHashTable *varTablePtr; - Tcl_Var var = resVarInfo->var; - int new, flags = var ? ((Var*)var)->flags : 0; - -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr,"CompiledColonVarFetch var '%s' var %p flags = %.4x dead? %.4x\n", - ObjStr(resVarInfo->nameObj), var, flags, flags&VAR_DEAD_HASH); -#endif - - /* - * We cache lookups based on xotcl objects; we have to care about - * cases, where the instance variables are in some delete states. - * - */ - - if (object == resVarInfo->lastObject && ((flags & VAR_DEAD_HASH)) == 0) { - /* - * The variable is valid. - */ -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... cached var '%s' var %p flags = %.4x\n", - ObjStr(resVarInfo->nameObj), var, flags); -#endif - return var; - } - - if (var) { - /* - * The variable is not valid anymore. Clean it up. - */ - HashVarFree(var); - } - - varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; - assert(varTablePtr); - - resVarInfo->lastObject = object; - resVarInfo->var = var = (Tcl_Var) VarHashCreateVar(varTablePtr, resVarInfo->nameObj, &new); - /* - * Increment the reference counter to avoid ckfree() of the variable - * in Tcl's FreeVarEntry(); for cleanup, we provide our own - * HashVarFree(); - */ - VarHashRefCount(var)++; - -#if defined(VAR_RESOLVER_TRACE) - { - Var *v = (Var*)(resVarInfo->var); - fprintf(stderr, ".... looked up var %s var %p flags = %.6x\n", - ObjStr(resVarInfo->nameObj), - v, v->flags); - } -#endif - return var; -} - -/* - *---------------------------------------------------------------------- - * CompiledColonVarFree -- - * - * DeleteProc of the compiled variable handler. - * - * Results: - * None. - * - * Side effects: - * Free compiled variable structure and variable. - * - *---------------------------------------------------------------------- - */ -void CompiledColonVarFree(Tcl_ResolvedVarInfo *vinfoPtr) { - xotclResolvedVarInfo *resVarInfo = (xotclResolvedVarInfo *)vinfoPtr; - DECR_REF_COUNT(resVarInfo->nameObj); - if (resVarInfo->var) {HashVarFree(resVarInfo->var);} - ckfree((char *) vinfoPtr); -} - -/* - *---------------------------------------------------------------------- - * InterpCompiledColonVarResolver -- - * - * Register for prefixed variables our own compiled var handler. - * - * Results: - * TCL_OK or TCL_CONTINUE (based on Tcl's var resolver protocol) - * - * Side effects: - * Registered var handler or none. - * - *---------------------------------------------------------------------- - */ -int InterpCompiledColonVarResolver(Tcl_Interp *interp, - CONST84 char *name, int length, Tcl_Namespace *context, - Tcl_ResolvedVarInfo **rPtr) { - /* - * The variable handler is registered, when we have an active XOTcl - * object and the variable starts with the appropriate prefix. Note - * that getting the "self" object is a weak protection against - * handling of wrong vars - */ - XOTclObject *object = GetSelfObj(interp); - -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, "compiled var resolver for %s, obj %p\n", name, object); -#endif - - if (object && FOR_COLON_RESOLVER(name)) { - xotclResolvedVarInfo *vInfoPtr = (xotclResolvedVarInfo *) ckalloc(sizeof(xotclResolvedVarInfo)); - - vInfoPtr->vInfo.fetchProc = CompiledColonVarFetch; - vInfoPtr->vInfo.deleteProc = CompiledColonVarFree; /* if NULL, tcl does a ckfree on proc clean up */ - vInfoPtr->lastObject = NULL; - vInfoPtr->var = NULL; - vInfoPtr->nameObj = Tcl_NewStringObj(name+1, length-1); - INCR_REF_COUNT(vInfoPtr->nameObj); - *rPtr = (Tcl_ResolvedVarInfo *)vInfoPtr; - - return TCL_OK; - } - return TCL_CONTINUE; -} - -/* - *---------------------------------------------------------------------- - * InterpColonVarResolver -- - * - * Resolve varnames as instance variables. These might be compiled - * locals or variables to be created (e.g. during an eval) in the - * objects vartables. If the command starts with the XOTcl - * specific prefix and we are on an XOTcl stack frame, treat - * command as instance varname. - * - * Results: - * TCL_OK or TCL_CONTINUE (based on Tcl's var resolver protocol) - * - * Side effects: - * If successful, return varPtr, pointing to instance variable. - * - *---------------------------------------------------------------------- - */ -static int -InterpColonVarResolver(Tcl_Interp *interp, CONST char *varName, Tcl_Namespace *nsPtr, int flags, Tcl_Var *varPtr) { - int new, frameFlags; - CallFrame *varFramePtr; - TclVarHashTable *varTablePtr; - XOTclObject *object; - Tcl_Obj *keyObj; - Tcl_Var var; - - if (!FOR_COLON_RESOLVER(varName) || (flags & TCL_GLOBAL_ONLY)) { - /* ordinary names and global lookups are not for us */ -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, "InterpColonVarResolver '%s' flags %.6x not for us nsPtr %p\n", - varName, flags, nsPtr); -#endif - return TCL_CONTINUE; - } - - varFramePtr = Tcl_Interp_varFramePtr(interp); - frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); - -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, "InterpColonVarResolver called var '%s' flags %.4x frame flags %.6x\n", - varName, flags, frameFlags); -#endif - varName ++; - - if (frameFlags & FRAME_IS_XOTCL_METHOD) { - if ((*varPtr = CompiledLocalsLookup(varFramePtr, varName))) { -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... found local %s\n", varName); -#endif - return TCL_OK; - } - - object = ((XOTclCallStackContent *)varFramePtr->clientData)->self; - - } else if (frameFlags & FRAME_IS_XOTCL_CMETHOD) { - object = ((XOTclCallStackContent *)varFramePtr->clientData)->self; - - } else if (frameFlags & FRAME_IS_XOTCL_OBJECT) { - object = (XOTclObject *)(varFramePtr->clientData); - - } else { -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... not found %s\n", varName); -#endif - return TCL_CONTINUE; - } - - /* We have an object and create the variable if not found */ - assert(object); - - varTablePtr = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; - assert(varTablePtr); - - /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTable %p\n", - varName, object, object->nsPtr, varTablePtr);*/ - - keyObj = Tcl_NewStringObj(varName, -1); - INCR_REF_COUNT(keyObj); - - var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, NULL); - if (var) { -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... found in hashtable %s %p\n", varName, var); -#endif - } else { - /* - We failed to find the variable, therefore we create it new - */ - var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, &new); -#if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... var %p %s created in hashtable %p\n", var, varName, varTablePtr); -#endif - } - *varPtr = var; - DECR_REF_COUNT(keyObj); - - return TCL_OK; -} -/********************************************************* - * - * End of var resolvers - * - *********************************************************/ - -/********************************************************* - * - * Begin of cmd resolver - * - *********************************************************/ -/* - *---------------------------------------------------------------------- - * InterpColonCmdResolver -- - * - * Resolve command names. If the command starts with the XOTcl - * specific prefix and we are on an XOTcl stack frame, treat - * command as OO method. - * - * Results: - * TCL_OK or TCL_CONTINUE (based on Tcl's command resolver protocol) - * - * Side effects: - * If successful, return cmdPtr, pointing to method. - * - *---------------------------------------------------------------------- - */ -static int -InterpColonCmdResolver(Tcl_Interp *interp, CONST char *cmdName, Tcl_Namespace *nsPtr, int flags, Tcl_Command *cmdPtr) { - CallFrame *varFramePtr; - int frameFlags; - - if (!FOR_COLON_RESOLVER(cmdName) || flags & TCL_GLOBAL_ONLY) { - /* ordinary names and global lookups are not for us */ - return TCL_CONTINUE; - } - - varFramePtr = Tcl_Interp_varFramePtr(interp); - frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); - - /* skip over a nonproc frame, in case Tcl stacks it */ - if (frameFlags == 0 && Tcl_CallFrame_callerPtr(varFramePtr)) { - varFramePtr = (CallFrame *)Tcl_CallFrame_callerPtr(varFramePtr); - frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); -#if defined(CMD_RESOLVER_TRACE) - fprintf(stderr, "InterpColonCmdResolver uses parent frame\n"); -#endif - } -#if defined(CMD_RESOLVER_TRACE) - fprintf(stderr, "InterpColonCmdResolver cmdName %s flags %.6x, frame flags %.6x\n",cmdName, - flags, Tcl_CallFrame_isProcCallFrame(varFramePtr)); -#endif - - if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_OBJECT|FRAME_IS_XOTCL_CMETHOD )) { -#if defined(CMD_RESOLVER_TRACE) - fprintf(stderr, " ... call colonCmd for %s\n", cmdName); -#endif - /* - * We have a cmd starting with ':', we are in an xotcl frame, so - * forward to the colonCmd. - */ - *cmdPtr = RUNTIME_STATE(interp)->colonCmd; - return TCL_OK; - } - -#if defined(CMD_RESOLVER_TRACE) - fprintf(stderr, " ... not found %s\n", cmdName); - tcl85showStack(interp); -#endif - return TCL_CONTINUE; -} -/********************************************************* - * - * End of cmd resolver - * - *********************************************************/ - -static Tcl_Namespace * -requireObjNamespace(Tcl_Interp *interp, XOTclObject *object) { - - if (!object->nsPtr) { - makeObjNamespace(interp, object); - } - /* 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(object->nsPtr, /*(Tcl_ResolveCmdProc*)NsColonCmdResolver*/ NULL, - NsColonVarResolver, - /*(Tcl_ResolveCompiledVarProc*)NsCompiledColonVarResolver*/NULL); - return object->nsPtr; -} - -extern void -XOTclRequireObjNamespace(Tcl_Interp *interp, XOTcl_Object *object) { - requireObjNamespace(interp, (XOTclObject*) object); -} - - -/* - * Namespace related commands - */ - -static int -NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST 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(nsPtr); - if ((token = FindMethod(nsPtr, name))) { - return Tcl_DeleteCommandFromToken(interp, token); - } - return -1; -} - -static void CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *object); -static void PrimitiveCDestroy(ClientData clientData); -static void PrimitiveODestroy(ClientData clientData); -static void PrimitiveDestroy(ClientData clientData); - -static void -NSDeleteChildren(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(nsPtr); - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - -#ifdef OBJDELETION_TRACE - fprintf(stderr, "NSDeleteChildren %p %s\n", nsPtr, nsPtr->fullName); -#endif - - Tcl_ForgetImport(interp, nsPtr, "*"); /* don't destroy namespace imported objects */ - - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - - if (!Tcl_Command_cmdEpoch(cmd)) { - XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); - - /*fprintf(stderr, "... check %p %s\n", object, object ? objectName(object) : "(null)");*/ - - if (object) { - /*fprintf(stderr, " ... child %s %p -- %s\n", oname, object, object ? objectName(object):"(null)");*/ - /*fprintf(stderr, " ... obj=%s flags %.4x\n", objectName(object), object->flags);*/ - - /* in the exit handler physical destroy --> directly call destroy */ - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound - == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { - PrimitiveDestroy((ClientData) object); - } else { - if (object->teardown && !(object->flags & XOTCL_DESTROY_CALLED)) { - /*fprintf(stderr, " ... call destroy obj=%s flags %.4x\n", objectName(object), object->flags);*/ - - if (callDestroyMethod(interp, object, 0) != TCL_OK) { - /* destroy method failed, but we have to remove the command - anyway. */ - if (object->teardown) { - CallStackDestroyObject(interp, object); - } - } - } - } - } - } - } -} - -/* - * ensure that a variable exists on object varTable or nsPtr->varTable, - * if necessary create it. Return Var* if successful, otherwise 0 - */ -static Var * -NSRequireVariableOnObj(Tcl_Interp *interp, XOTclObject *object, CONST char *name, int flgs) { - Tcl_CallFrame frame, *framePtr = &frame; - Var *varPtr, *arrayPtr; - - XOTcl_PushFrameObj(interp, object, framePtr); - varPtr = TclLookupVar(interp, name, 0, flgs, "obj vwait", - /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); - XOTcl_PopFrameObj(interp, framePtr); - return varPtr; -} - -static int -XOTcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command cmd) { - CallStackClearCmdReferences(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; - -#ifdef OBJDELETION_TRACE - fprintf(stderr, "NSCleanupNamespace %p\n", ns); - fprintf(stderr, "NSCleanupNamespace %p %.6x varTable %p\n", ns, ((Namespace *)ns)->flags, varTable); -#endif - /* - * Delete all variables and initialize var table again - * (DeleteVars frees the vartable) - */ - TclDeleteVars((Interp *)interp, varTable); - TclInitVarHashTable(varTable, (Namespace *)ns); - - /* - * Delete all user-defined procs in the namespace - */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - XOTclObject *invokeObj = proc == XOTclObjDispatch ? (XOTclObject *)Tcl_Command_objClientData(cmd) : NULL; - - /* objects should not be deleted here to preseve children deletion order */ - if (invokeObj && cmd != invokeObj->id) { - /* - * cmd is an aliased object, reduce the refcount - */ - /*fprintf(stderr, "NSCleanupNamespace cleanup aliased object %p\n", invokeObj); */ - XOTclCleanupObject(invokeObj); - XOTcl_DeleteCommandFromToken(interp, cmd); - } - if (invokeObj) { - /* - * cmd is a child object - */ - continue; - } - - /* fprintf(stderr, "NSCleanupNamespace calls DeleteCommandFromToken for %p flags %.6x invokeObj %p obj %p\n", - cmd, ((Command *)cmd)->flags, invokeObj,object); - fprintf(stderr, " cmd = %s\n", Tcl_GetCommandName(interp,cmd)); - fprintf(stderr, " nsPtr = %p\n", ((Command *)cmd)->nsPtr); - fprintf(stderr, " flags %.6x\n", ((Namespace *)((Command *)cmd)->nsPtr)->flags);*/ - - XOTcl_DeleteCommandFromToken(interp, cmd); - } -} - - -static void -NSNamespaceDeleteProc(ClientData clientData) { - /* dummy for ns identification by pointer comparison */ - XOTclObject *object = (XOTclObject*) clientData; - /*fprintf(stderr, "namespacedeleteproc obj=%p ns=%p\n", - clientData,object ? object->nsPtr : NULL);*/ - if (object) { - object->nsPtr = NULL; - } -} - -void -XOTcl_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { - int activationCount = 0; - Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); - - /*fprintf(stderr, "XOTcl_DeleteNamespace %p ", nsPtr);*/ - - while (f) { - if (f->nsPtr == nsPtr) - activationCount++; - f = Tcl_CallFrame_callerPtr(f); - } - - /* todo remove debug line */ - if (Tcl_Namespace_activationCount(nsPtr) != activationCount) { - fprintf(stderr, "WE HAVE TO FIX ACTIVATIONCOUNT\n"); - Tcl_Namespace_activationCount(nsPtr) = activationCount; - } - - /*fprintf(stderr, "to %d. \n", ((Namespace *)nsPtr)->activationCount);*/ - - MEM_COUNT_FREE("TclNamespace", nsPtr); - if (Tcl_Namespace_deleteProc(nsPtr)) { - /*fprintf(stderr, "calling deteteNamespace %s\n", nsPtr->fullName);*/ - Tcl_DeleteNamespace(nsPtr); - } -} - -static Tcl_Namespace* -NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, CONST char *name, int create) { - Tcl_Namespace *nsPtr = Tcl_FindNamespace(interp, name, NULL, 0); - - if (nsPtr) { - if (nsPtr->deleteProc || nsPtr->clientData) { - Tcl_Panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace, my delete Proc %p", - name, nsPtr->deleteProc, nsPtr->clientData, NSNamespaceDeleteProc); - } - nsPtr->clientData = clientData; - nsPtr->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc; - } else if (create) { - nsPtr = Tcl_CreateNamespace(interp, name, clientData, - (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc); - } - MEM_COUNT_ALLOC("TclNamespace", nsPtr); - return nsPtr; -} - - -/* - * check colons for illegal object/class names - */ -XOTCLINLINE static int -NSCheckColons(CONST char *name, size_t l) { - register CONST 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, CONST char *name, size_t l, XOTclClass *cl) { - register CONST char *n = name+l; - int rc = 1; - - /*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); - - Tcl_DStringAppend(dsp, name, (n-name)); - parentName = Tcl_DStringValue(dsp); - - 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 { - XOTclClass *defaultSuperClass = DefaultSuperClass(interp, cl, cl->object.cl, 0); - Tcl_Obj *methodObj = XOTclMethodObj(interp, &defaultSuperClass->object, XO_c_requireobject_idx); - - if (methodObj) { - /* call requireObject and try again */ - Tcl_Obj *ov[3]; - int result; - - ov[0] = defaultSuperClass->object.cmdName; - ov[1] = methodObj; - ov[2] = Tcl_NewStringObj(parentName, -1); - INCR_REF_COUNT(ov[2]); - /*fprintf(stderr, "+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/ - result = Tcl_EvalObjv(interp, 3, ov, 0); - if (result == TCL_OK) { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); - if (parentObj) { - requireObjNamespace(interp, parentObj); - } - rc = (Tcl_FindNamespace(interp, parentName, - (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != NULL); - } else { - rc = 0; - } - DECR_REF_COUNT(ov[2]); - } - } - } else { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); - if (parentObj) { - requireObjNamespace(interp, parentObj); - } - } - DSTRING_FREE(dsp); - } - return rc; -} - -/* - * Find the "real" command belonging eg. to an XOTcl class or object. - * Do not return cmds produced by Tcl_Import, but the "real" cmd - * to which they point. - */ -XOTCLINLINE static Tcl_Command -NSFindCommand(Tcl_Interp *interp, CONST 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; -} - - - -/* - * C interface routines for manipulating objects and classes - */ - - -extern XOTcl_Object* -XOTclGetObject(Tcl_Interp *interp, CONST char *name) { - return (XOTcl_Object*) XOTclpGetObject(interp, name); -} - -/* - * Find an object using a char *name - */ -static XOTclObject* -XOTclpGetObject(Tcl_Interp *interp, CONST char *name) { - 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 OK %d\n", - name, Tcl_Command_objProc(cmd), XOTclObjDispatch, Tcl_Command_objProc(cmd) == XOTclObjDispatch); - }*/ - - 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; -} - -/* - * Find a class using a char *name - */ - -extern XOTcl_Class* -XOTclGetClass(Tcl_Interp *interp, CONST char *name) { - return (XOTcl_Class*)XOTclpGetClass(interp, name); -} - -static XOTclClass* -XOTclpGetClass(Tcl_Interp *interp, CONST char *name) { - XOTclObject *object = XOTclpGetObject(interp, name); - return (object && XOTclObjectIsClass(object)) ? (XOTclClass*)object : NULL; -} - -static int -CanRedefineCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, XOTclObject *object, CONST char *methodName) { - int result, ok; - Tcl_Command cmd = FindMethod(nsPtr, methodName); - - ok = cmd ? (Tcl_Command_flags(cmd) & XOTCL_CMD_REDEFINE_PROTECTED_METHOD) == 0 : 1; - if (ok) { - result = TCL_OK; - } else { - result = XOTclVarErrMsg(interp, "Method '", methodName, "' of ", objectName(object), - " can not be overwritten. Derive e.g. a sub-class!", - (char *) NULL); - } - ObjectSystemsCheckSystemMethod(interp, methodName, GetObjectSystem(object)); - - return result; -} - -int -XOTclAddObjectMethod(Tcl_Interp *interp, XOTcl_Object *object1, CONST char *methodName, - Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, - int flags) { - XOTclObject *object = (XOTclObject *)object1; - Tcl_DString newCmdName, *dsPtr = &newCmdName; - Tcl_Namespace *ns = requireObjNamespace(interp, object); - Tcl_Command newCmd; - int result; - - /* Check, if we are allowed to redefine the method */ - result = CanRedefineCmd(interp, object->nsPtr, object, (char*)methodName); - if (result != TCL_OK) { - return result; - } - - /* delete an alias definition, if it exists */ - AliasDelete(interp, object->cmdName, methodName, 1); - - 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 TCL_OK; -} - -int -XOTclAddClassMethod(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; - int result; - - /* Check, if we are allowed to redefine the method */ - result = CanRedefineCmd(interp, cl->nsPtr, &cl->object, (char*)methodName); - if (result != TCL_OK) { - return result; - } - - /* delete an alias definition, if it exists */ - AliasDelete(interp, class->object.cmdName, methodName, 0); - - 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 TCL_OK; -} - -/* - * Generic Tcl_Obj List - */ - -static void -TclObjListFreeList(XOTclTclObjList *list) { - 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; -} - -/* - * Autonaming - */ - -static Tcl_Obj * -AutonameIncr(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTclObject *object, - int instanceOpt, int resetOpt) { - int valueLength, mustCopy = 1, format = 0; - char *valueString, *c; - Tcl_Obj *valueObj, *result = NULL, *savedResult = NULL; - int flgs = TCL_LEAVE_ERR_MSG; - Tcl_CallFrame frame, *framePtr = &frame; - - XOTcl_PushFrameObj(interp, object, framePtr); - if (object->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - valueObj = Tcl_ObjGetVar2(interp, XOTclGlobalObjs[XOTE_AUTONAMES], nameObj, flgs); - if (valueObj) { - long autoname_counter; - /* should probably do an overflow check here */ - Tcl_GetLongFromObj(interp, valueObj, &autoname_counter); - autoname_counter++; - if (Tcl_IsShared(valueObj)) { - valueObj = Tcl_DuplicateObj(valueObj); - } - Tcl_SetLongObj(valueObj, autoname_counter); - } - Tcl_ObjSetVar2(interp, XOTclGlobalObjs[XOTE_AUTONAMES], nameObj, - valueObj, flgs); - - if (resetOpt) { - if (valueObj) { /* we have an entry */ - Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(nameObj), flgs); - } - result = XOTclGlobalObjs[XOTE_EMPTY]; - INCR_REF_COUNT(result); - } else { - if (valueObj == NULL) { - valueObj = Tcl_ObjSetVar2(interp, XOTclGlobalObjs[XOTE_AUTONAMES], - nameObj, XOTclGlobalObjs[XOTE_ONE], flgs); - } - if (instanceOpt) { - char buffer[1], firstChar; - CONST char *nextChars = ObjStr(nameObj); - firstChar = *(nextChars ++); - if (isupper((int)firstChar)) { - buffer[0] = tolower((int)firstChar); - result = Tcl_NewStringObj(buffer, 1); - INCR_REF_COUNT(result); - Tcl_AppendLimitedToObj(result, nextChars, -1, INT_MAX, NULL); - mustCopy = 0; - } - } - if (mustCopy) { - result = Tcl_DuplicateObj(nameObj); - 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[1] = result; - ov[2] = valueObj; - if (XOTclCallCommand(interp, XOTE_FORMAT, 3, ov) != TCL_OK) { - XOTcl_PopFrameObj(interp, framePtr); - DECR_REF_COUNT(savedResult); - FREE_ON_STACK(Tcl_Obj*, 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(Tcl_Obj*, ov); - } else { - valueString = Tcl_GetStringFromObj(valueObj, &valueLength); - Tcl_AppendLimitedToObj(result, valueString, valueLength, INT_MAX, NULL); - /*fprintf(stderr, "+++ append to obj done\n");*/ - } - } - - XOTcl_PopFrameObj(interp, framePtr); - assert((resetOpt && result->refCount>=1) || (result->refCount == 1)); - return result; -} - -/* - * XOTcl CallStack - */ - -static void -CallStackRestoreSavedFrames(Tcl_Interp *interp, callFrameContext *ctx) { - if (ctx->framesSaved) { - Tcl_Interp_varFramePtr(interp) = (CallFrame *)ctx->varFramePtr; - /*RUNTIME_STATE(interp)->varFramePtr = ctx->varFramePtr;*/ - - } -} - -XOTCLINLINE static void -CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *object) { - Tcl_Command oid; - - PRINTOBJ("CallStackDoDestroy", object); - - /* Don't do anything, if a recursive DURING_DELETE is for some - * reason active. - */ - if (object->flags & XOTCL_DURING_DELETE) { - return; - } - /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x activation %d cmd %p \n", - object, object->flags, object->activationCount, object->id);*/ - object->flags |= XOTCL_DURING_DELETE; - oid = object->id; - /* oid might be freed already, we can't even use (((Command*)oid)->flags & CMD_IS_DELETED) */ - - if (object->teardown && oid) { - - /* PrimitiveDestroy() has to be before DeleteCommandFromToken(), - otherwise e.g. unset traces on this object cannot be executed - from Tcl. We make sure via refcounting that the object structure - is kept until after DeleteCommandFromToken(). - */ - - object->refCount ++; - - /*fprintf(stderr, "CallStackDoDestroy %p after refCount ++ %d teardown %p\n", - object, object->refCount, object->teardown);*/ - - PrimitiveDestroy((ClientData) object); -; - if (!(object->flags & XOTCL_TCL_DELETE) /*&& !(object->flags & XOTCL_CMD_NOT_FOUND)*/) { - Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); - INCR_REF_COUNT(savedObjResult); - /*fprintf(stderr, " before DeleteCommandFromToken %p object flags %.6x\n", oid, object->flags);*/ - /*fprintf(stderr, "cmd dealloc %p refcount %d dodestroy \n", oid, Tcl_Command_refCount(oid));*/ - Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ - /*fprintf(stderr, " after DeleteCommandFromToken %p %.6x\n", oid, ((Command*)oid)->flags);*/ - Tcl_SetObjResult(interp, savedObjResult); - DECR_REF_COUNT(savedObjResult); - } - XOTclCleanupObject(object); - } -} - -static void -CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *object) { - -#ifdef OBJDELETION_TRACE - fprintf(stderr, "CallStackDestroyObject %p %s activationcount %d flags %.6x\n", - object, objectName(object), object->activationCount, object->flags); -#endif - - if ((object->flags & XOTCL_DESTROY_CALLED) == 0) { - int activationCount = object->activationCount; - /* if the destroy method was not called yet, do it now */ -#ifdef OBJDELETION_TRACE - fprintf(stderr, " CallStackDestroyObject has to callDestroyMethod %p activationCount %d\n", - object, activationCount); -#endif - callDestroyMethod(interp, object, 0); - - if (activationCount == 0) { - /* We assume, the object is now freed. if the oobjectbj is already - freed, we cannot access activation count, and we cannot call - CallStackDoDestroy */ - /*fprintf(stderr, " CallStackDestroyObject %p done\n", obj);*/ - return; - } - } - - /* If the object is not referenced on the callstack anymore - we have to destroy it directly, because CscFinish won't - find the object destroy */ - if (object->activationCount == 0) { - CallStackDoDestroy(interp, object); - } else { - /* to prevail the deletion order call delete children now - -> children destructors are called before parent's - destructor */ - if (object->teardown && object->nsPtr) { - /*fprintf(stderr, " CallStackDestroyObject calls NSDeleteChildren\n");*/ - NSDeleteChildren(interp, object->nsPtr); - } - } - /*fprintf(stderr, " CallStackDestroyObject %p DONE\n", object);*/ -} - -/* - * cmd list handling - */ - -/* - * Cmd List Add/Remove ... returns the new element - */ -static XOTclCmdList* -CmdListAdd(XOTclCmdList **cList, Tcl_Command c, XOTclClass *clorobj, int noDuplicates) { - 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; - } - } - - /* - * 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; -} - -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); -} - -#if 0 -/** for debug purposes only */ -static void -CmdListPrint(Tcl_Interp *interp, CONST 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->next; - } -} -#endif - -/* - * physically delete an entry 'del' - */ -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); -} - -/* - * remove a command 'delCL' from a command list, but do not - * free it ... returns the removed XOTclCmdList* - */ -static XOTclCmdList* -CmdListRemoveFromList(XOTclCmdList **cmdList, XOTclCmdList *delCL) { - 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; - } - 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; - } -} - - -/* - * delete all cmds with given context class object - */ -static void -CmdListRemoveContextClassFromList(XOTclCmdList **cmdList, XOTclClass *clorobj, - XOTclFreeCmdListClientData *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) { - 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; - } -} - -/* - * 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); - } -} - -/* - * simple list search proc to search a list of cmds - * for a command ptr - */ -static XOTclCmdList* -CmdListFindCmdInList(Tcl_Command cmd, XOTclCmdList *l) { - register XOTclCmdList *h; - for (h = l; h; h = h->nextPtr) { - if (h->cmdPtr == cmd) - return h; - } - return 0; -} - -/* - * simple list search proc to search a list of cmds - * for a simple Name - */ -static XOTclCmdList* -CmdListFindNameInList(Tcl_Interp *interp, CONST char *name, XOTclCmdList *l) { - register XOTclCmdList *h; - for (h = l; h; h = h->nextPtr) { - CONST 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; - - 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; -} - -static Tcl_Obj * -AssertionList(Tcl_Interp *interp, XOTclTclObjList *alist) { - Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); - for (; alist; alist = alist->nextPtr) { - Tcl_ListObjAppendElement(interp, listObj, alist->content); - } - return listObj; -} - - - -/* append a string of pre and post assertions to a method body */ -static void -AssertionAppendPrePost(Tcl_Interp *interp, Tcl_DString *dsPtr, XOTclProcAssertion *procs) { - if (procs) { - Tcl_Obj *preCondition = AssertionList(interp, procs->pre); - Tcl_Obj *postCondition = AssertionList(interp, procs->post); - INCR_REF_COUNT(preCondition); INCR_REF_COUNT(postCondition); - Tcl_DStringAppendElement(dsPtr, "-precondition"); - Tcl_DStringAppendElement(dsPtr, ObjStr(preCondition)); - Tcl_DStringAppendElement(dsPtr, "-postcondition"); - Tcl_DStringAppendElement(dsPtr, ObjStr(postCondition)); - DECR_REF_COUNT(preCondition); DECR_REF_COUNT(postCondition); - } -} - -static int -AssertionListCheckOption(Tcl_Interp *interp, XOTclObject *object) { - XOTclObjectOpt *opt = object->opt; - if (!opt) - return TCL_OK; - if (opt->checkoptions & CHECK_OBJINVAR) - Tcl_AppendElement(interp, "object-invar"); - if (opt->checkoptions & CHECK_CLINVAR) - Tcl_AppendElement(interp, "class-invar"); - 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, CONST char *name) { - Tcl_HashEntry *hPtr; - if (aStore == NULL) return NULL; - hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL); - if (hPtr == NULL) return NULL; - return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); -} - -static void -AssertionRemoveProc(XOTclAssertionStore *aStore, CONST char *name) { - Tcl_HashEntry *hPtr; - if (aStore) { - hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL); - 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, CONST char *name, XOTclAssertionStore *aStore, - 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); -} - -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; -} - -static void -AssertionRemoveStore(XOTclAssertionStore *aStore) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - - 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); - } -} - -/* - * check a given condition in the current callframe's scope - * it's the responsiblity of the caller to push the intended callframe - */ -static int -checkConditionInScope(Tcl_Interp *interp, Tcl_Obj *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_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 *object, - XOTclTclObjList *alist, CONST char *methodName) { - XOTclTclObjList *checkFailed = NULL; - Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); - int savedCheckoptions, acResult = TCL_OK; - - /* - * no obj->opt -> checkoption == CHECK_NONE - */ - if (!object->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 1 - /* TODO: the following check operations is xotcl1 legacy and is not - generic. it should be replaced by another methodproperty. - Most of the is*String() - definition are then obsolete and should be deleted from - xotclInt.h as well. - */ - - if (isCheckString(methodName)) { - return TCL_OK; - } -#endif - - INCR_REF_COUNT(savedObjResult); - - Tcl_ResetResult(interp); - - while (alist) { - /* Eval instead of IfObjCmd => the substitutions in the - conditions will be done by Tcl */ - CONST char *assStr = ObjStr(alist->content), *c = assStr; - int comment = 0; - - for (; c && *c != '\0'; c++) { - if (*c == '#') { - comment = 1; break; - } - } - - if (!comment) { - Tcl_CallFrame frame, *framePtr = &frame; - XOTcl_PushFrameObj(interp, object, framePtr); - - /* don't check assertion during assertion check */ - savedCheckoptions = object->opt->checkoptions; - object->opt->checkoptions = CHECK_NONE; - - /* fprintf(stderr, "Checking Assertion %s ", assStr); */ - - /* - * now check the assertion in the pushed callframe's scope - */ - acResult = checkConditionInScope(interp, alist->content); - if (acResult != TCL_OK) - checkFailed = alist; - - object->opt->checkoptions = savedCheckoptions; - /* fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok"); */ - XOTcl_PopFrameObj(interp, framePtr); - } - if (checkFailed) - break; - alist = alist->nextPtr; - } - - 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 '", - methodName, "'\n\n", ObjStr(sr), (char *) NULL); - DECR_REF_COUNT(sr); - return TCL_ERROR; - } - return XOTclVarErrMsg(interp, "Assertion failed check: {", - ObjStr(checkFailed->content), "} in proc '", - methodName, "'", (char *) NULL); - } - - Tcl_SetObjResult(interp, savedObjResult); - DECR_REF_COUNT(savedObjResult); - return TCL_OK; -} - -static int -AssertionCheckInvars(Tcl_Interp *interp, XOTclObject *object, - CONST char *methodName, - CheckOptions checkoptions) { - int result = TCL_OK; - - if (checkoptions & CHECK_OBJINVAR && object->opt->assertions) { - result = AssertionCheckList(interp, object, object->opt->assertions->invariants, - methodName); - } - - if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { - XOTclClasses *clPtr; - clPtr = ComputeOrder(object->cl, object->cl->order, Super); - while (clPtr && result != TCL_ERROR) { - XOTclAssertionStore *aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0; - if (aStore) { - result = AssertionCheckList(interp, object, aStore->invariants, methodName); - } - clPtr = clPtr->nextPtr; - } - } - return result; -} - -static int -AssertionCheck(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl, - CONST char *method, int checkOption) { - XOTclProcAssertion *procs; - int result = TCL_OK; - XOTclAssertionStore *aStore; - - if (cl) - aStore = cl->opt ? cl->opt->assertions : 0; - else - aStore = object->opt ? object->opt->assertions : 0; - - assert(object->opt); - - if (checkOption & object->opt->checkoptions) { - procs = AssertionFindProcs(aStore, method); - if (procs) { - switch (checkOption) { - case CHECK_PRE: - result = AssertionCheckList(interp, object, procs->pre, method); - break; - case CHECK_POST: - result = AssertionCheckList(interp, object, procs->post, method); - break; - } - } - if (result != TCL_ERROR) - result = AssertionCheckInvars(interp, object, method, object->opt->checkoptions); - } - return result; -} - -static int AssertionSetCheckOptions(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *arg) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); - int ocArgs, i; - Tcl_Obj **ovArgs; - opt->checkoptions = CHECK_NONE; - - if (Tcl_ListObjGetElements(interp, arg, &ocArgs, &ovArgs) == TCL_OK - && ocArgs > 0) { - for (i = 0; i < ocArgs; i++) { - CONST char *option = ObjStr(ovArgs[i]); - if (option) { - switch (*option) { - case 'c': - if (strcmp(option, "class-invar") == 0) { - opt->checkoptions |= CHECK_CLINVAR; - } - break; - case 'o': - if (strcmp(option, "object-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 '", - objectName(object), " check ", ObjStr(arg), - "', valid: all pre post object-invar class-invar", - (char *) NULL); - } - return TCL_OK; -} - -static void AssertionSetInvariants(Tcl_Interp *interp, XOTclAssertionStore **assertions, Tcl_Obj *arg) { - if (*assertions) - TclObjListFreeList((*assertions)->invariants); - else - *assertions = AssertionCreateStore(); - - (*assertions)->invariants = AssertionNewList(interp, arg); -} - - - - - -/* - * Per-Object-Mixins - */ - -/* - * push a mixin stack information on this object - */ -static int -MixinStackPush(XOTclObject *object) { - register XOTclMixinStack *h = NEW(XOTclMixinStack); - h->currentCmdPtr = NULL; - h->nextPtr = object->mixinStack; - object->mixinStack = h; - return 1; -} - -/* - * pop a mixin stack information on this object - */ -static void -MixinStackPop(XOTclObject *object) { - register XOTclMixinStack *h = object->mixinStack; - object->mixinStack = h->nextPtr; - FREE(XOTclMixinStack, h); -} - -/* - * 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; - - CmdListRemoveEpoched(mixinList, GuardDel); - - 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->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->classmixins) { - /* compute transitively the (class) mixin 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, - className(cls->cl));*/ - 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->classmixins, 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); - } - } - } - } - if (level == 0 && *checkList) { - XOTclClassListFree(*checkList); - *checkList = NULL; - } -} - -static void -MixinResetOrder(XOTclObject *object) { - /*fprintf(stderr, "removeList %s \n", objectName(object));*/ - CmdListRemoveList(&object->mixinOrder, NULL /*GuardDel*/); - object->mixinOrder = NULL; -} - -/* - * Computes a linearized order of per-object and per-class mixins. Then - * duplicates in the full list and with the class inheritance list of - * 'obj' are eliminated. - * The precendence rule is that the last occurence makes it into the - * final list. - */ -static void -MixinComputeOrder(Tcl_Interp *interp, XOTclObject *object) { - XOTclClasses *fullList, *checkList = NULL, *mixinClasses = NULL, *nextCl, *pl, - *checker, *guardChecker; - - if (object->mixinOrder) MixinResetOrder(object); - - /* append per-obj mixins */ - if (object->opt) { - MixinComputeOrderFullList(interp, &object->opt->mixins, &mixinClasses, - &checkList, 0); - } - - /* append per-class mixins */ - for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->classmixins) { - MixinComputeOrderFullList(interp, &opt->classmixins, &mixinClasses, - &checkList, 0); - } - } - 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));*/ - - while (checker) { - if (checker->cl == mixinClasses->cl) break; - checker = checker->nextPtr; - } - /* if checker is set, it is a duplicate and ignored */ - - if (checker == NULL) { - /* check obj->cl hierachy */ - for (checker = ComputeOrder(object->cl, object->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(&object->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; - } - } - } - mixinClasses = nextCl; - } - - /* ... and free the memory of the full list */ - XOTclClassListFree(fullList); - - /*CmdListPrint(interp, "mixin order\n", obj->mixinOrder);*/ - -} - -/* - * add a mixin class to 'mixinList' by appending it - */ -static int -MixinAdd(Tcl_Interp *interp, XOTclCmdList **mixinList, Tcl_Obj *nameObj, XOTclClass *baseClass) { - XOTclClass *mixin; - Tcl_Obj *guardObj = NULL; - int ocName; Tcl_Obj **ovName; - XOTclCmdList *new; - - if (Tcl_ListObjGetElements(interp, nameObj, &ocName, &ovName) == TCL_OK && ocName > 1) { - if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { - nameObj = ovName[0]; - guardObj = 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 (GetClassFromObj(interp, nameObj, &mixin, baseClass) != TCL_OK) - return XOTclErrBadVal(interp, "mixin", "a class as mixin", ObjStr(nameObj)); - - - new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1); - - if (guardObj) { - GuardAdd(interp, new, guardObj); - } else { - if (new->clientData) - GuardDel(new); - } - - return TCL_OK; -} - -/* - * call AppendElement for matching values - */ -static void -AppendMatchingElement(Tcl_Interp *interp, Tcl_Obj *nameObj, CONST char *pattern) { - CONST char *string = ObjStr(nameObj); - if (!pattern || Tcl_StringMatch(string, pattern)) { - Tcl_AppendElement(interp, string); - } -} - -/* - * apply AppendMatchingElement to CmdList - */ -static int -AppendMatchingElementsFromCmdList(Tcl_Interp *interp, XOTclCmdList *cmdl, - CONST char *pattern, XOTclObject *matchObject) { - int rc = 0; - for ( ; cmdl; cmdl = cmdl->nextPtr) { - XOTclObject *object = XOTclGetObjectFromCmdPtr(cmdl->cmdPtr); - if (object) { - if (matchObject == object) { - return 1; - } else { - AppendMatchingElement(interp, object->cmdName, pattern); - } - } - } - return rc; -} - -/* - * apply AppendMatchingElement to - */ -static int -AppendMatchingElementsFromClasses(Tcl_Interp *interp, XOTclClasses *cls, - CONST char *pattern, XOTclObject *matchObject) { - int rc = 0; - - for ( ; cls; cls = cls->nextPtr) { - XOTclObject *object = (XOTclObject *)cls->cl; - if (object) { - if (matchObject && object == 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, object->cmdName, pattern); - } - } - } - 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) { - Tcl_HashTable *table = &startCl->instances; - XOTclClasses *sc; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - - for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject *)Tcl_GetHashKey(table, hPtr); - int new; - - Tcl_CreateHashEntry(destTable, objectName(inst), &new); - /* - fprintf (stderr, " -- %s (%s)\n", objectName(inst), 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 *object, int *new, - int appendResult, CONST char *pattern, XOTclObject *matchObject) { - Tcl_CreateHashEntry(destTable, (char *)object, new); - if (*new) { - if (matchObject && matchObject == object) { - return 1; - } - if (appendResult) { - AppendMatchingElement(interp, object->cmdName, pattern); - } - } - return 0; -} - -/* - * 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, CONST char *pattern, XOTclObject *matchObject) { - Tcl_CreateHashEntry(destTable, (char *)cl, new); - if (*new) { - if (appendResult) { - if (!pattern || Tcl_StringMatch(className(cl), 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, XOTclGlobalObjs[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 int -getAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, - int isMixin, - int appendResult, CONST char *pattern, XOTclObject *matchObject) { - int rc = 0, new = 0; - XOTclClasses *sc; - - /*fprintf(stderr, "startCl = %s, opt %p, isMixin %d, pattern '%s', matchObject %p\n", - className(startCl), startCl->opt, isMixin, pattern, matchObject);*/ - - /* - * 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) == 0); - - cl = XOTclGetClassFromCmdPtr(m->cmdPtr); - assert(cl); - /*fprintf(stderr, "check %s mixinof %s\n", - className(cl), ObjStr(startCl->object.cmdName));*/ - rc = getAllObjectMixinsOf(interp, destTable, cl, isMixin, appendResult, pattern, matchObject); - /* fprintf(stderr, "check %s mixinof %s done\n", - className(cl), ObjStr(startCl->object.cmdName));*/ - if (rc) {return rc;} - } - } - - /* - * check, if startCl has associated per-object mixins - */ - if (startCl->opt) { - XOTclCmdList *m; - XOTclObject *object; - - for (m = startCl->opt->isObjectMixinOf; m; m = m->nextPtr) { - - /* we should have no deleted commands in the list */ - assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); - - object = XOTclGetObjectFromCmdPtr(m->cmdPtr); - assert(object); - - rc = addToResultSet(interp, destTable, object, &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, /*@notnull@*/ XOTclClass *startCl, - int isMixin, - int appendResult, CONST char *pattern, XOTclObject *matchObject) { - int rc = 0, new = 0; - XOTclClass *cl; - XOTclClasses *sc; - - assert(startCl); - - /*fprintf(stderr, "startCl = %p %s, opt %p, isMixin %d\n", - startCl, className(startCl), 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) { - if (sc->cl != startCl) { - rc = getAllClassMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); - if (rc) {return rc;} - } else { - /* TODO: sanity check; it seems that we can create via - __default_superclass a class which has itself als - subclass */ - fprintf(stderr, "... STRANGE %p is subclass of %p %s, sub %p\n", sc->cl, - startCl, className(startCl), startCl->sub); - } - } - } - - /* - * 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) == 0); - - cl = XOTclGetClassFromCmdPtr(m->cmdPtr); - assert(cl); - - rc = addToResultSet(interp, destTable, &cl->object, &new, appendResult, pattern, matchObject); - if (rc == 1) {return rc;} - if (new) { - /*fprintf(stderr, "... new\n");*/ - rc = getAllClassMixinsOf(interp, destTable, cl, 1, appendResult, pattern, matchObject); - if (rc) {return rc;} - } - } - } - - return rc; -} - -/* - * recursively get all classmixins 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, CONST char *pattern, XOTclObject *matchObject) { - int rc = 0, new = 0; - XOTclClass *cl; - XOTclClasses *sc; - - /* - * check this class for classmixins - */ - if (startCl->opt) { - XOTclCmdList *m; - - for (m = startCl->opt->classmixins; m; m = m->nextPtr) { - - /* we should have no deleted commands in the list */ - assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); - - cl = XOTclGetClassFromCmdPtr(m->cmdPtr); - assert(cl); - - /* fprintf(stderr, "class mixin found: %s\n", className(cl)); */ - - if ((withGuards) && (m->clientData)) { - /* fprintf(stderr, "addToResultSetWithGuards: %s\n", className(cl)); */ - rc = addToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject); - } else { - /* fprintf(stderr, "addToResultSet: %s\n", className(cl)); */ - rc = addToResultSet(interp, destTable, &cl->object, &new, 1, pattern, matchObject); - } - if (rc == 1) {return rc;} - - if (new) { - /* fprintf(stderr, "class mixin getAllClassMixins for: %s (%s)\n", className(cl), ObjStr(startCl->object.cmdName)); */ - rc = getAllClassMixins(interp, destTable, cl, withGuards, pattern, matchObject); - if (rc) {return rc;} - } - } - } - - - /* - * check all superclasses of startCl for classmixins - */ - 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 -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", - className(cl), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ - del = CmdListRemoveFromList(&nclopt->isClassMixinOf, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } - } -} - -static void -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", - objectName(object), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ - del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } /* else fprintf(stderr, "CleanupDestroyObject %s: NULL pointer in mixins!\n", objectName(object)); */ - } -} - -static void -RemoveFromClassmixins(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->classmixins); - if (del) { - /* fprintf(stderr, "Removing class %s from mixins of object %s\n", - className(cl), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */ - del = CmdListRemoveFromList(&clopt->classmixins, 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", - className(cl), 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 an object or - class mixin somewhere else and invalidate the objects of these as - well -- */ - - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *object = (XOTclObject *)Tcl_GetHashKey(&cl->instances, hPtr); - if (object - && !(object->flags & XOTCL_DURING_DELETE) - && (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - MixinResetOrder(object); - object->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", - className(cl), cl->opt);*/ - - if (cl->opt) { - XOTclCmdList *ml; - for (ml = cl->opt->isObjectMixinOf; ml; ml = ml->nextPtr) { - XOTclObject *object = XOTclGetObjectFromCmdPtr(ml->cmdPtr); - if (object) { - if (object->mixinOrder) { MixinResetOrder(object); } - object->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; - - cl->order = NULL; - - /* 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; - - /* reset mixin order for all objects having this class as per object mixin */ - ResetOrderOfClassesUsedAsMixins(clPtr->cl); - - /* fprintf(stderr, "invalidating instances of class %s\n", ObjStr(clPtr->cl->object.cmdName)); - */ - - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *object = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - if (object->mixinOrder) { MixinResetOrder(object); } - object->flags &= ~XOTCL_MIXIN_ORDER_VALID; - } - } - - XOTclClassListFree(cl->order); - cl->order = saved; - - /* Reset mixin order for all objects having this class as a per - class mixin. This means that we have to work through - the class mixin 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); - - 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); - /* this place seems to be sufficient to invalidate the computed object parameter definitions */ - /*fprintf(stderr, "MixinInvalidateObjOrders via class mixin %s calls ifd invalidate \n", className(ncl));*/ - XOTclInvalidateObjectParameterCmd(interp, ncl); - } - } - Tcl_DeleteHashTable(commandTable); - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); -} - - -static int MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, CONST 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 DEFINED or NONE - */ -static void -MixinComputeDefined(Tcl_Interp *interp, XOTclObject *object) { - MixinComputeOrder(interp, object); - object->flags |= XOTCL_MIXIN_ORDER_VALID; - if (object->mixinOrder) - object->flags |= XOTCL_MIXIN_ORDER_DEFINED; - else - object->flags &= ~XOTCL_MIXIN_ORDER_DEFINED; -} - -/* - * Walk through the command list until the current command is reached. - * return the next entry. - * - */ -static XOTclCmdList * -seekCurrent(Tcl_Command currentCmd, register XOTclCmdList *cmdl) { - if (currentCmd) { - /* go forward to current class */ - for (; cmdl; cmdl = cmdl->nextPtr) { - if (cmdl->cmdPtr == currentCmd) { - return cmdl->nextPtr; - } - } - } - return cmdl; -} - -/* - * before we can perform a mixin dispatch, MixinSearchProc seeks the - * current mixin and the relevant calling information - */ -static int -MixinSearchProc(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, - XOTclClass **cl, Tcl_Command *currentCmdPtr, Tcl_Command *cmdPtr) { - Tcl_Command cmd = NULL; - XOTclCmdList *cmdList; - XOTclClass *cls; - int result = TCL_OK; - - assert(object); - assert(object->mixinStack); - - /* ensure that the mixin order is not invalid, otherwise compute order */ - assert(object->flags & XOTCL_MIXIN_ORDER_VALID); - /*MixinComputeDefined(interp, object);*/ - cmdList = seekCurrent(object->mixinStack->currentCmdPtr, object->mixinOrder); - RUNTIME_STATE(interp)->cmdPtr = cmdList ? cmdList->cmdPtr : NULL; - - /* fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName, cmdList); */ - /*CmdListPrint(interp, "MixinSearch CL = \n", cmdList);*/ - - for (; cmdList; cmdList = cmdList->nextPtr) { - - if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { - continue; - } - cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr); - assert(cls); - /* - fprintf(stderr, "+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n", - objectName(object), methodName, cmdList, - cmdList->cmdPtr, cmdList->clientData); - */ - cmd = FindMethod(cls->nsPtr, methodName); - if (cmd == NULL) { - continue; - } - - if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD) { - /*fprintf(stderr, "we found class specific method %s on class %s object %s, isclass %d\n", - methodName, className(cls), objectName(object), XOTclObjectIsClass(object));*/ - if (!XOTclObjectIsClass(object)) { - /* the command is not for us; skip it */ - cmd = NULL; - continue; - } - } - - if (cmdList->clientData) { - if (!RUNTIME_STATE(interp)->guardCount) { - result = GuardCall(object, cls, (Tcl_Command) cmd, interp, - (Tcl_Obj*)cmdList->clientData, NULL); - } - } - if (result == TCL_OK) { - /* - * on success: compute mixin call data - */ - *cl = cls; - *currentCmdPtr = cmdList->cmdPtr; - break; - } else if (result == TCL_ERROR) { - break; - } else { - if (result == XOTCL_CHECK_FAILED) result = TCL_OK; - cmd = NULL; - } - } - - *cmdPtr = cmd; - return result; -} - -/* - * info option for mixins and classmixins - */ -static int -MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, CONST char *pattern, - int withGuards, XOTclObject *matchObject) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclClass *mixinClass; - - /*fprintf(stderr, " mixin info m=%p, pattern %s, matchObject %p\n", - m, pattern, matchObject);*/ - - 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, XOTclGlobalObjs[XOTE_GUARD_OPTION]); - Tcl_ListObjAppendElement(interp, l, g); - Tcl_ListObjAppendElement(interp, list, l); - } else { - Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName); - } - if (matchObject) break; - } - m = m->nextPtr; - } - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - -/* - * info option for mixinofs and isClassMixinOf - */ - -static Tcl_Command -MixinSearchMethodByName(Tcl_Interp *interp, XOTclCmdList *mixinList, CONST char *name, XOTclClass **cl) { - Tcl_Command cmd; - - 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; -} - - -/* - * Filter-Commands - */ - -/* - * The search method implements filter search order for object and - * class ilter: first a given name is interpreted as fully qualified - * method name. If no method is found, a proc is searched with fully - * name. Otherwise the simple name is searched on the heritage order: - * object (only for per-object filters), class, meta-class - */ - -static Tcl_Command -FilterSearch(Tcl_Interp *interp, CONST char *name, XOTclObject *startingObject, - XOTclClass *startingClass, XOTclClass **cl) { - Tcl_Command cmd = NULL; - - if (startingObject) { - XOTclObjectOpt *opt = startingObject->opt; - /* - * the object-specific filter can also be defined on the object's - * class, its hierarchy, or the respective classmixins; thus use the - * object's class as start point for the class-specific search then ... - */ - startingClass = startingObject->cl; - - /* - * search for filters on object mixins - */ - if (opt && opt->mixins) { - if ((cmd = MixinSearchMethodByName(interp, opt->mixins, name, cl))) { - return cmd; - } - } - } - - /* - * search for classfilters on classmixins - */ - if (startingClass) { - XOTclClassOpt *opt = startingClass->opt; - if (opt && opt->classmixins) { - if ((cmd = MixinSearchMethodByName(interp, opt->classmixins, name, cl))) { - return cmd; - } - } - } - - /* - * seach for object procs that are used as filters - */ - if (startingObject && startingObject->nsPtr) { - /*fprintf(stderr, "search filter %s as proc \n", name);*/ - if ((cmd = FindMethod(startingObject->nsPtr, name))) { - *cl = (XOTclClass*)startingObject; - return cmd; - } - } - - /* - * ok, no filter on obj or mixins -> search class - */ - if (startingClass) { - *cl = SearchCMethod(startingClass, name, &cmd); - if (!*cl) { - /* - * If no filter is found yet -> search the meta-class - */ - *cl = SearchCMethod(startingClass->object.cl, name, &cmd); - } - } - return cmd; -} - -/* - * Filter Guards - */ - -/* check a filter guard, return 1 if ok */ -static int -GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObj) { - int result; - XOTclRuntimeState *rst = RUNTIME_STATE(interp); - - if (guardObj) { - /* - * 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(guardObj));*/ - - rst->guardCount++; - result = checkConditionInScope(interp, guardObj); - rst->guardCount--; - - /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", ObjStr(guardObj), rc);*/ - - if (result == TCL_OK) { - /* fprintf(stderr, " +++ OK\n"); */ - return TCL_OK; - } else if (result == TCL_ERROR) { - Tcl_Obj *sr = Tcl_GetObjResult(interp); - INCR_REF_COUNT(sr); - - /* fprintf(stderr, " +++ ERROR\n");*/ - - XOTclVarErrMsg(interp, "Guard Error: '", ObjStr(guardObj), "'\n\n", - ObjStr(sr), (char *) NULL); - DECR_REF_COUNT(sr); - return TCL_ERROR; - } - } - /* - fprintf(stderr, " +++ FAILED\n"); - */ - return XOTCL_CHECK_FAILED; -} - -/* - static void - GuardPrint(Tcl_Interp *interp, ClientData clientData) { - Tcl_Obj *guardObj = (TclObj*) clientData; - fprintf(stderr, " +++ \n"); - if (guardObj) { - fprintf(stderr, " * %s \n", ObjStr(guardObj)); - } - fprintf(stderr, " +++ \n"); - } -*/ - -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; - } -} - -XOTCLINLINE static void -GuardAdd(Tcl_Interp *interp, XOTclCmdList *CL, Tcl_Obj *guardObj) { - if (guardObj) { - GuardDel(CL); - if (strlen(ObjStr(guardObj)) != 0) { - INCR_REF_COUNT(guardObj); - CL->clientData = (ClientData) guardObj; - /*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 *object, XOTclClass *cl, Tcl_Command cmd, - Tcl_Interp *interp, Tcl_Obj *guardObj, XOTclCallStackContent *cscPtr) { - int result = TCL_OK; - - if (guardObj) { - Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ - Tcl_CallFrame frame, *framePtr = &frame; - - INCR_REF_COUNT(res); - - /* GuardPrint(interp, cmdList->clientData); */ - /* - * For the guard push a fake callframe on the Tcl stack so that - * e.g. a "self calledproc" and other methods in the guard behave - * like in the proc. - */ - if (cscPtr) { - XOTcl_PushFrameCsc(interp, cscPtr, framePtr); - } else { - XOTcl_PushFrameObj(interp, object, framePtr); - } - result = GuardCheck(interp, guardObj); - - if (cscPtr) { - XOTcl_PopFrameCsc(interp, framePtr); - } else { - XOTcl_PopFrameObj(interp, framePtr); - } - - if (result != TCL_ERROR) { - Tcl_SetObjResult(interp, res); /* restore the result */ - } - DECR_REF_COUNT(res); - } - - return result; -} - -static int -GuardAddFromDefinitionList(Tcl_Interp *interp, XOTclCmdList *dest, - 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; -} - -static void -GuardAddInheritedGuards(Tcl_Interp *interp, XOTclCmdList *dest, - XOTclObject *object, Tcl_Command filterCmd) { - XOTclClasses *pl; - int guardAdded = 0; - XOTclObjectOpt *opt; - - /* search guards for classfilters registered on mixins */ - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml; - XOTclClass *mixin; - for (ml = object->mixinOrder; ml && !guardAdded; ml = ml->nextPtr) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin && mixin->opt) { - guardAdded = GuardAddFromDefinitionList(interp, dest, filterCmd, - mixin->opt->classfilters); - } - } - } - - /* search per-object filters */ - opt = object->opt; - if (!guardAdded && opt && opt->filters) { - guardAdded = GuardAddFromDefinitionList(interp, dest, filterCmd, opt->filters); - } - - if (!guardAdded) { - /* search per-class filters */ - for (pl = ComputeOrder(object->cl, object->cl->order, Super); !guardAdded && pl; pl = pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt) { - guardAdded = GuardAddFromDefinitionList(interp, dest, filterCmd, - opt->classfilters); - } - } - - - /* - * if this is not a registered filter, it is an inherited filter, like: - * Class create A - * A method f ... - * Class create B -superclass A - * B method {{f {}}} - * B filter f - * -> get the guard from the filter that inherits it (here B->f) - */ - if (!guardAdded) { - XOTclCmdList *registeredFilter = - CmdListFindNameInList(interp, (char *) Tcl_GetCommandName(interp, filterCmd), - object->filterOrder); - if (registeredFilter) { - GuardAdd(interp, dest, (Tcl_Obj*) registeredFilter->clientData); - } - } - } -} - -static int -GuardList(Tcl_Interp *interp, XOTclCmdList *frl, CONST 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; - } - } - 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 *nameObj, - XOTclObject *startingObject, XOTclClass *startingClass) { - Tcl_Command cmd; - int ocName; Tcl_Obj **ovName; - Tcl_Obj *guardObj = NULL; - XOTclCmdList *new; - XOTclClass *cl; - - if (Tcl_ListObjGetElements(interp, nameObj, &ocName, &ovName) == TCL_OK && ocName > 1) { - if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { - nameObj = ovName[0]; - guardObj = ovName[2]; - } - } - - if (!(cmd = FilterSearch(interp, ObjStr(nameObj), startingObject, startingClass, &cl))) { - if (startingObject) - return XOTclVarErrMsg(interp, "object filter: can't find filterproc on: ", - objectName(startingObject), " - proc: ", - ObjStr(nameObj), (char *) NULL); - else - return XOTclVarErrMsg(interp, "class filter: can't find filterproc on: ", - className(startingClass), " - proc: ", - ObjStr(nameObj), (char *) NULL); - } - - /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(nameObj), cl);*/ - - new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1); - - if (guardObj) { - GuardAdd(interp, new, guardObj); - } else { - if (new->clientData) - GuardDel(new); - } - - return TCL_OK; -} - -/* - * reset the filter order cached in obj->filterOrder - */ -static void -FilterResetOrder(XOTclObject *object) { - CmdListRemoveList(&object->filterOrder, GuardDel); - object->filterOrder = NULL; -} - -/* - * search the filter in the hierarchy again with FilterSearch, e.g. - * upon changes in the class hierarchy or mixins that carry the filter - * command, so that we can be sure it is still reachable. - */ -static void -FilterSearchAgain(Tcl_Interp *interp, XOTclCmdList **filters, - XOTclObject *startingObject, XOTclClass *startingClass) { - char *simpleName; - Tcl_Command cmd; - XOTclCmdList *cmdList, *del; - XOTclClass *cl = NULL; - - CmdListRemoveEpoched(filters, GuardDel); - for (cmdList = *filters; cmdList; ) { - simpleName = (char *) Tcl_GetCommandName(interp, cmdList->cmdPtr); - cmd = FilterSearch(interp, simpleName, startingObject, startingClass, &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); - */ -} - -/* - * if the class hierarchy or class filters have changed -> - * invalidate filter entries in all dependent instances - * - */ -static void -FilterInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) { - XOTclClasses *saved = cl->order, *clPtr, *savePtr; - - cl->order = NULL; - savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); - cl->order = saved; - - 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 class-filter registrations */ - if (clPtr->cl->opt) { - FilterSearchAgain(interp, &clPtr->cl->opt->classfilters, 0, clPtr->cl); - } - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *object = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - FilterResetOrder(object); - object->flags &= ~XOTCL_FILTER_ORDER_VALID; - - /* recalculate the commands of all object filter registrations */ - if (object->opt) { - FilterSearchAgain(interp, &object->opt->filters, object, 0); - } - } - } - XOTclClassListFree(savePtr); -} - -/* - * from cl on down the hierarchy we remove all filters - * the refer to "removeClass" namespace. E.g. used to - * remove filters defined in superclass list from dependent - * class cl - */ -static void -FilterRemoveDependentFilterCmds(XOTclClass *cl, XOTclClass *removeClass) { - XOTclClasses *saved = cl->order, *clPtr; - cl->order = NULL; - - /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n", - cl, className(cl), - 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) : NULL; - XOTclClassOpt *opt = clPtr->cl->opt; - if (opt) { - CmdListRemoveContextClassFromList(&opt->classfilters, removeClass, GuardDel); - } - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *object = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - if (object->opt) { - CmdListRemoveContextClassFromList(&object->opt->filters, removeClass, GuardDel); - } - } - } - - XOTclClassListFree(cl->order); - cl->order = saved; -} - -static Tcl_Obj * -MethodHandleObj(XOTclObject *object, int withPer_object, CONST char *methodName) { - Tcl_Obj *resultObj = Tcl_NewStringObj(withPer_object ? "" : "::nsf::classes", -1); - assert(object); - Tcl_AppendObjToObj(resultObj, object->cmdName); - Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL); - return resultObj; -} - -/* - * info option for filters and classfilters - * withGuards -> if not 0 => append guards - * withMethodHandles -> if not 0 => return method handles - */ -static int -FilterInfo(Tcl_Interp *interp, XOTclCmdList *f, CONST char *pattern, - int withGuards, int withMethodHandles) { - CONST char *simpleName; - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - - /*fprintf(stderr, "FilterInfo %p %s %d %d\n", pattern, pattern, - withGuards, withMethodHandles);*/ - - /* guard lists should only have unqualified filter lists when - withGuards is activated, withMethodHandles has no effect - */ - if (withGuards) { - withMethodHandles = 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, XOTclGlobalObjs[XOTE_GUARD_OPTION]); - Tcl_ListObjAppendElement(interp, innerList, g); - Tcl_ListObjAppendElement(interp, list, innerList); - } else { - if (withMethodHandles) { - XOTclClass *filterClass = f->clorobj; - Tcl_ListObjAppendElement(interp, list, - MethodHandleObj((XOTclObject *)filterClass, - !XOTclObjectIsClass(&filterClass->object), simpleName)); - } else { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1)); - } - } - } - f = f->nextPtr; - } - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - -/* - * 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; - - /* - * 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); - - if (fcl && !XOTclObjectIsClass(&fcl->object)) { - /* get the class from the object for per-object filter */ - fcl = ((XOTclObject *)fcl)->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(pl->cl->nsPtr, simpleName); - if (pi) { - CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0); - /* - fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName); - */ - } - } - } - } - } - /*CmdListPrint(interp, "FilterComputeOrderFullList....\n", *filterList);*/ -} - -/* - * Computes a linearized order of object and class filter. Then - * duplicates in the full list and with the class inheritance list of - * 'obj' are eliminated. The precendence rule is that the last - * occurence makes it into the final list. - */ -static void -FilterComputeOrder(Tcl_Interp *interp, XOTclObject *object) { - XOTclCmdList *filterList = NULL, *next, *checker, *newlist; - XOTclClasses *pl; - - if (object->filterOrder) FilterResetOrder(object); - /* - fprintf(stderr, " List: ", objectName(object)); - */ - - /* append classfilters registered for mixins */ - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - - if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml; - XOTclClass *mixin; - - for (ml = object->mixinOrder; ml; ml = ml->nextPtr) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin && mixin->opt && mixin->opt->classfilters) - FilterComputeOrderFullList(interp, &mixin->opt->classfilters, &filterList); - } - } - - /* append per-obj filters */ - if (object->opt) - FilterComputeOrderFullList(interp, &object->opt->filters, &filterList); - - /* append per-class filters */ - for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl=pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->classfilters) { - FilterComputeOrderFullList(interp, &opt->classfilters, &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 == NULL) { - newlist = CmdListAdd(&object->filterOrder, filterList->cmdPtr, filterList->clorobj, - /*noDuplicates*/ 0); - GuardAddInheritedGuards(interp, newlist, object, filterList->cmdPtr); - /* - fprintf(stderr, " Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(interp, filterList->cmdPtr)); - */ - /* - GuardPrint(interp, newlist->clientData); - */ - - } - - CmdListDeleteCmdListEntry(filterList, GuardDel); - - filterList = next; - } - /* - fprintf(stderr, "\n"); - */ -} - -/* - * the filter order is either - * DEFINED (there are filter on the instance), - * NONE (there are no filter for the instance), - * or INVALID (a class re-strucuturing has occured, thus it is not clear - * whether filters are defined or not). - * If it is INVALID FilterComputeDefined can be used to compute the order - * and set the instance to DEFINE or NONE - */ -static void -FilterComputeDefined(Tcl_Interp *interp, XOTclObject *object) { - FilterComputeOrder(interp, object); - object->flags |= XOTCL_FILTER_ORDER_VALID; - if (object->filterOrder) - object->flags |= XOTCL_FILTER_ORDER_DEFINED; - else - object->flags &= ~XOTCL_FILTER_ORDER_DEFINED; -} - -/* - * push a filter stack information on this object - */ -static int -FilterStackPush(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *calledProc) { - register XOTclFilterStack *h = NEW(XOTclFilterStack); - - h->currentCmdPtr = NULL; - h->calledProc = calledProc; - INCR_REF_COUNT(h->calledProc); - h->nextPtr = object->filterStack; - object->filterStack = h; - return 1; -} - -/* - * pop a filter stack information on this object - */ -static void -FilterStackPop(XOTclObject *object) { - register XOTclFilterStack *h = object->filterStack; - object->filterStack = h->nextPtr; - - /* free stack entry */ - DECR_REF_COUNT(h->calledProc); - FREE(XOTclFilterStack, h); -} - -/* - * search through the filter list on obj and class hierarchy - * for registration of a command ptr as filter - * - * returns a tcl obj list with the filter registration, like: - * " filter , - * " filter , - * or an empty list, if not registered - */ -static Tcl_Obj * -FilterFindReg(Tcl_Interp *interp, XOTclObject *object, Tcl_Command cmd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclClasses *pl; - - /* search per-object filters */ - if (object->opt && CmdListFindCmdInList(cmd, object->opt->filters)) { - Tcl_ListObjAppendElement(interp, list, object->cmdName); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_OBJECT]); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_FILTER]); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); - return list; - } - - /* search per-class filters */ - for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *opt = pl->cl->opt; - if (opt && opt->classfilters) { - if (CmdListFindCmdInList(cmd, opt->classfilters)) { - Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName); - Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjs[XOTE_FILTER]); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); - 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 *object, - Tcl_Command *currentCmd, XOTclClass **cl) { - XOTclCmdList *cmdList; - - assert(object); - assert(object->filterStack); - - *currentCmd = NULL; - - /* Ensure that the filter order is not invalid, otherwise compute order - FilterComputeDefined(interp, object); - */ - assert(object->flags & XOTCL_FILTER_ORDER_VALID); - cmdList = seekCurrent(object->filterStack->currentCmdPtr, object->filterOrder); - - while (cmdList) { - if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { - cmdList = cmdList->nextPtr; - } else if (FilterActiveOnObj(interp, object, cmdList->cmdPtr)) { - /* fprintf(stderr, "Filter <%s> -- Active on: %s\n", - Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), objectName(object)); - */ - object->filterStack->currentCmdPtr = cmdList->cmdPtr; - cmdList = seekCurrent(object->filterStack->currentCmdPtr, object->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 NULL; -} - - -static int -SuperclassAdd(Tcl_Interp *interp, XOTclClass *cl, int oc, Tcl_Obj **ov, Tcl_Obj *arg, XOTclClass *baseClass) { - 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 (GetClassFromObj(interp, ov[i], &scl[i], baseClass) != 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) { - /* - * 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); - 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); - 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) { - fprintf(stderr, "SuperClassAdd super of '%s' is NULL\n", className(cl)); - /*AddSuper(cl, RUNTIME_STATE(interp)->theObject);*/ - } - - Tcl_ResetResult(interp); - return TCL_OK; -} - -extern Tcl_Obj * -XOTcl_ObjSetVar2(XOTcl_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, - Tcl_Obj *valueObj, int flgs) { - Tcl_Obj *result; - Tcl_CallFrame frame, *framePtr = &frame; - - XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); - if (((XOTclObject*)object)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - result = Tcl_ObjSetVar2(interp, name1, name2, valueObj, flgs); - XOTcl_PopFrameObj(interp, framePtr); - return result; -} - -extern Tcl_Obj * -XOTcl_SetVar2Ex(XOTcl_Object *object, Tcl_Interp *interp, CONST char *name1, CONST char *name2, - Tcl_Obj *valueObj, int flgs) { - Tcl_Obj *result; - Tcl_CallFrame frame, *framePtr = &frame; - - XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); - if (((XOTclObject*)object)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - result = Tcl_SetVar2Ex(interp, name1, name2, valueObj, flgs); - XOTcl_PopFrameObj(interp, framePtr); - return result; -} - - -Tcl_Obj * -XOTclOSetInstVar(XOTcl_Object *object, Tcl_Interp *interp, - Tcl_Obj *nameObj, Tcl_Obj *valueObj, int flgs) { - return XOTcl_ObjSetVar2(object, interp, nameObj, (Tcl_Obj *)NULL, valueObj, (flgs|TCL_PARSE_PART1)); -} - -extern Tcl_Obj * -XOTcl_ObjGetVar2(XOTcl_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, - int flgs) { - Tcl_Obj *result; - Tcl_CallFrame frame, *framePtr = &frame; - - XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); - if (((XOTclObject*)object)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - result = Tcl_ObjGetVar2(interp, name1, name2, flgs); - XOTcl_PopFrameObj(interp, framePtr); - - return result; -} - -extern Tcl_Obj * -XOTcl_GetVar2Ex(XOTcl_Object *object, Tcl_Interp *interp, CONST char *name1, CONST char *name2, - int flgs) { - Tcl_Obj *result; - Tcl_CallFrame frame, *framePtr = &frame; - - XOTcl_PushFrameObj(interp, (XOTclObject*)object, framePtr); - if (((XOTclObject*)object)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - result = Tcl_GetVar2Ex(interp, name1, name2, flgs); - XOTcl_PopFrameObj(interp, framePtr); - return result; -} - - -Tcl_Obj * -XOTclOGetInstVar(XOTcl_Object *object, Tcl_Interp *interp, Tcl_Obj *nameObj, int flgs) { - return XOTcl_ObjGetVar2(object, interp, nameObj, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1)); -} - -int -XOTclUnsetInstVar(XOTcl_Object *object, Tcl_Interp *interp, CONST char *name, int flgs) { - return XOTclUnsetInstVar2(object, interp, name, NULL, flgs); -} - -static int -CheckVarName(Tcl_Interp *interp, const char *varNameString) { - /* - * Check, whether the provided name is save to be used in the - * resolver. We do not want to get interferences with namespace - * resolver and such. In an first attempt, we disallowed occurances - * of "::", but we have to deal as well with e.g. arrayName(::x::y) - * - * TODO: more general and efficient solution to disallow e.g. a::b - * (check for :: until parens) - */ - /*if (strstr(varNameString, "::") || *varNameString == ':') {*/ - if (*varNameString == ':') { - return XOTclVarErrMsg(interp, "variable name \"", varNameString, - "\" must not contain namespace separator or colon prefix", - (char *) NULL); - } - return TCL_OK; -} - -static int -varExists(Tcl_Interp *interp, XOTclObject *object, CONST char *varName, CONST char *index, - int triggerTrace, int requireDefined) { - Tcl_CallFrame frame, *framePtr = &frame; - Var *varPtr, *arrayPtr; - int result; - int flags = 0; - - flags = (index == NULL) ? TCL_PARSE_PART1 : 0; - - XOTcl_PushFrameObj(interp, object, framePtr); - - if (triggerTrace) - varPtr = TclVarTraceExists(interp, varName); - else - varPtr = TclLookupVar(interp, varName, index, flags, "access", - /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - 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_PopFrameObj(interp, framePtr); - - return result; -} - -static int -SubstValue(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj **value) { - Tcl_Obj *ov[2]; - int result; - - ov[1] = *value; - Tcl_ResetResult(interp); - - result = XOTcl_SubstObjCmd(NULL, interp, 2, ov); - - /*fprintf(stderr, "+++++ %s.%s subst returned %d OK %d\n", - objectName(object), varName, rc, TCL_OK);*/ - - if (result == TCL_OK) { - *value = Tcl_GetObjResult(interp); - } - return result; -} - -#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; - - /*fprintf(stderr, "MakeProcError %p type %p refCount %d\n", - procNameObj, procNameObj->typePtr, procNameObj->refCount);*/ - - procName = Tcl_GetStringFromObj(procNameObj, &nameLen); - overflow = (nameLen > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (procedure \"%.*s%s\" line %d)", - (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); -} - -static int -ByteCompiled(register Tcl_Interp *interp, Proc *procPtr, CONST char *body) { - Tcl_Obj *bodyPtr = procPtr->bodyPtr; - Namespace *nsPtr = procPtr->cmdPtr->nsPtr; - - if (bodyPtr->typePtr == byteCodeType) { -# if defined(HAVE_TCL_COMPILE_H) - 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 = bodyPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { - - goto doCompilation; - } - return TCL_OK; -# endif - } else { - -# if defined(HAVE_TCL_COMPILE_H) - doCompilation: -# endif - return TclProcCompileProc(interp, procPtr, bodyPtr, - (Namespace *) nsPtr, "body of proc", - body); - } -} - -/* - PushProcCallFrame() compiles conditionally a proc and pushes a - callframe. Interesting fields: - - clientData: Record describing procedure to be interpreted. - isLambda: 1 if this is a call by ApplyObjCmd: it needs special rules for error msg - - */ - -static int -PushProcCallFrame(ClientData clientData, register Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - XOTclCallStackContent *cscPtr) { - Proc *procPtr = (Proc *) clientData; - CallFrame *framePtr; - int 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. - */ - -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "PUSH METHOD_FRAME (PushProcCallFrame) csc %p %s obj %s obj refcount %d\n", cscPtr, - cscPtr ? Tcl_GetCommandName(interp, cscPtr->cmdPtr) : NULL, - objectName(cscPtr->self), - cscPtr && cscPtr->self->id ? Tcl_Command_refCount(cscPtr->self->id) : -100 - ); -#endif - - /* TODO: we could use Tcl_PushCallFrame(), if we would allocate the tcl stack frame earlier */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **)&framePtr, - (Tcl_Namespace *) procPtr->cmdPtr->nsPtr, - (FRAME_IS_PROC|FRAME_IS_XOTCL_METHOD)); - if (result != TCL_OK) { - return result; - } - - framePtr->objc = objc; - framePtr->objv = objv; - framePtr->procPtr = procPtr; -#if defined(TCL85STACK_TRACE) - fprintf(stderr, " put csc %p into frame %p flags %.4x\n", cscPtr, framePtr, framePtr->isProcCallFrame); -#endif - framePtr->clientData = (ClientData)cscPtr; - - return ByteCompiled(interp, procPtr, TclGetString(objv[0])); -} - -static void -getVarAndNameFromHash(Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) { - *val = VarHashGetValue(hPtr); - *varNameObj = VarHashGetKey(*val); -} - -static void ParamDefsFree(XOTclParamDefs *paramDefs); - -void XOTclProcDeleteProc(ClientData clientData) { - XOTclProcContext *ctxPtr = (XOTclProcContext *)clientData; - (*ctxPtr->oldDeleteProc)(ctxPtr->oldDeleteData); - if (ctxPtr->paramDefs) { - /*fprintf(stderr, "free ParamDefs %p\n", ctxPtr->paramDefs);*/ - ParamDefsFree(ctxPtr->paramDefs); - } - /*fprintf(stderr, "free %p\n", ctxPtr);*/ - FREE(XOTclProcContext, ctxPtr); -} - -static XOTclParam *ParamsNew(int nr) { - XOTclParam *paramsPtr = NEW_ARRAY(XOTclParam, nr+1); - memset(paramsPtr, 0, sizeof(XOTclParam)*(nr+1)); - return paramsPtr; -} - -static void ParamsFree(XOTclParam *paramsPtr) { - XOTclParam *paramPtr; - - /*fprintf(stderr, "ParamsFree %p\n", paramsPtr);*/ - for (paramPtr=paramsPtr; paramPtr->name; paramPtr++) { - /*fprintf(stderr, ".... paramPtr = %p, name=%s, defaultValue %p\n", paramPtr, paramPtr->name, paramPtr->defaultValue);*/ - if (paramPtr->name) ckfree(paramPtr->name); - if (paramPtr->nameObj) {DECR_REF_COUNT(paramPtr->nameObj);} - if (paramPtr->defaultValue) {DECR_REF_COUNT(paramPtr->defaultValue);} - if (paramPtr->converterName) {DECR_REF_COUNT(paramPtr->converterName);} - if (paramPtr->converterArg) {DECR_REF_COUNT(paramPtr->converterArg);} - if (paramPtr->paramObj) {DECR_REF_COUNT(paramPtr->paramObj);} - if (paramPtr->slotObj) {DECR_REF_COUNT(paramPtr->slotObj);} - } - FREE(XOTclParam*, paramsPtr); -} - -static XOTclParamDefs * -ParamDefsGet(Tcl_Command cmdPtr) { - if (Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc) { - return ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs; - } - return NULL; -} - -static int -ParamDefsStore(Tcl_Interp *interp, Tcl_Command cmd, XOTclParamDefs *paramDefs) { - Command *cmdPtr = (Command *)cmd; - - if (cmdPtr->deleteProc != XOTclProcDeleteProc) { - XOTclProcContext *ctxPtr = NEW(XOTclProcContext); - - /*fprintf(stderr, "paramDefsStore replace deleteProc %p by %p\n", - cmdPtr->deleteProc, XOTclProcDeleteProc);*/ - - ctxPtr->oldDeleteData = (Proc *)cmdPtr->deleteData; - ctxPtr->oldDeleteProc = cmdPtr->deleteProc; - cmdPtr->deleteProc = XOTclProcDeleteProc; - ctxPtr->paramDefs = paramDefs; - cmdPtr->deleteData = (ClientData)ctxPtr; - return TCL_OK; - } else { - /*fprintf(stderr, "paramDefsStore cmd %p has already XOTclProcDeleteProc deleteData %p\n", - cmd, cmdPtr->deleteData);*/ - if (cmdPtr->deleteData) { - XOTclProcContext *ctxPtr = cmdPtr->deleteData; - assert(ctxPtr->paramDefs == NULL); - ctxPtr->paramDefs = paramDefs; - } - } - return TCL_ERROR; -} - -static XOTclParamDefs * -ParamDefsNew() { - XOTclParamDefs *paramDefs; - - paramDefs = NEW(XOTclParamDefs); - memset(paramDefs, 0, sizeof(XOTclParamDefs)); - /*fprintf(stderr, "ParamDefsNew %p\n", paramDefs);*/ - - return paramDefs; -} - - -static void -ParamDefsFree(XOTclParamDefs *paramDefs) { - /*fprintf(stderr, "ParamDefsFree %p returns %p\n", paramDefs, paramDefs->returns);*/ - - if (paramDefs->paramsPtr) { - ParamsFree(paramDefs->paramsPtr); - } - if (paramDefs->slotObj) {DECR_REF_COUNT(paramDefs->slotObj);} - if (paramDefs->returns) {DECR_REF_COUNT(paramDefs->returns);} - FREE(XOTclParamDefs, paramDefs); -} - -/* - * Non Positional Parameter - */ - -static void -ParamDefsFormatOption(Tcl_Interp *interp, Tcl_Obj *nameStringObj, CONST char* option, - int *colonWritten, int *firstOption) { - if (!*colonWritten) { - Tcl_AppendLimitedToObj(nameStringObj, ":", 1, INT_MAX, NULL); - *colonWritten = 1; - } - if (*firstOption) { - *firstOption = 0; - } else { - Tcl_AppendLimitedToObj(nameStringObj, ",", 1, INT_MAX, NULL); - } - Tcl_AppendLimitedToObj(nameStringObj, option, -1, INT_MAX, NULL); -} - -static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr); - -static Tcl_Obj * -ParamDefsFormat(Tcl_Interp *interp, XOTclParam CONST *paramsPtr) { - int first, colonWritten; - Tcl_Obj *listObj = Tcl_NewListObj(0, NULL), *innerListObj, *nameStringObj; - XOTclParam CONST *pPtr; - - for (pPtr = paramsPtr; pPtr->name; pPtr++) { - if (pPtr -> paramObj) { - innerListObj = pPtr->paramObj; - } else { - /* We need this part only for C-defined parameter definitions, - defined via genTclAPI. - - TODO: we could streamline this by defining as well C-API via - the same syntax as for accepted for tcl obj types - "xotclParam" - */ - int isNonpos = *pPtr->name == '-'; - int outputRequired = (isNonpos && (pPtr->flags & XOTCL_ARG_REQUIRED)); - int outputOptional = (!isNonpos && !(pPtr->flags & XOTCL_ARG_REQUIRED) - && !pPtr->defaultValue && - pPtr->converter != convertToNothing); - first = 1; - colonWritten = 0; - - nameStringObj = Tcl_NewStringObj(pPtr->name, -1); - if (pPtr->type) { - ParamDefsFormatOption(interp, nameStringObj, pPtr->type, &colonWritten, &first); - } - if (outputRequired) { - ParamDefsFormatOption(interp, nameStringObj, "required", &colonWritten, &first); - } else if (outputOptional) { - ParamDefsFormatOption(interp, nameStringObj, "optional", &colonWritten, &first); - } - if ((pPtr->flags & XOTCL_ARG_SUBST_DEFAULT)) { - ParamDefsFormatOption(interp, nameStringObj, "substdefault", &colonWritten, &first); - } - if ((pPtr->flags & XOTCL_ARG_ALLOW_EMPTY)) { - ParamDefsFormatOption(interp, nameStringObj, "allowempty", &colonWritten, &first); - } - if ((pPtr->flags & XOTCL_ARG_IS_CONVERTER)) { - ParamDefsFormatOption(interp, nameStringObj, "convert", &colonWritten, &first); - } - if ((pPtr->flags & XOTCL_ARG_INITCMD)) { - ParamDefsFormatOption(interp, nameStringObj, "initcmd", &colonWritten, &first); - } else if ((pPtr->flags & XOTCL_ARG_METHOD)) { - ParamDefsFormatOption(interp, nameStringObj, "method", &colonWritten, &first); - } else if ((pPtr->flags & XOTCL_ARG_NOARG)) { - ParamDefsFormatOption(interp, nameStringObj, "noarg", &colonWritten, &first); - } else if ((pPtr->flags & XOTCL_ARG_MULTIVALUED)) { - ParamDefsFormatOption(interp, nameStringObj, "multivalued", &colonWritten, &first); - } - - innerListObj = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, innerListObj, nameStringObj); - if (pPtr->defaultValue) { - Tcl_ListObjAppendElement(interp, innerListObj, pPtr->defaultValue); - } - } - - Tcl_ListObjAppendElement(interp, listObj, innerListObj); - } - - return listObj; -} - -static Tcl_Obj * -ParamDefsList(Tcl_Interp *interp, XOTclParam CONST *paramsPtr) { - Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); - XOTclParam CONST *pPtr; - - for (pPtr = paramsPtr; pPtr->name; pPtr++) { - Tcl_ListObjAppendElement(interp, listObj, pPtr->nameObj); - } - return listObj; -} - -static Tcl_Obj* -ParamDefsSyntax(Tcl_Interp *interp, XOTclParam CONST *paramPtr) { - Tcl_Obj *argStringObj = Tcl_NewStringObj("", 0); - XOTclParam CONST *pPtr; - - for (pPtr = paramPtr; pPtr->name; pPtr++) { - if (pPtr != paramPtr) { - Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL); - } - if (pPtr->flags & XOTCL_ARG_REQUIRED) { - Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); - } else { - Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); - Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); - if (pPtr->nrArgs >0) { - Tcl_AppendLimitedToObj(argStringObj, " arg", 4, INT_MAX, NULL); - } - Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); - } - } - /* caller has to decr */ - return argStringObj; -} - -static void ParsedParamFree(XOTclParsedParam *parsedParamPtr) { - /*fprintf(stderr, "ParsedParamFree %p, npargs %p\n", parsedParamPtr, parsedParamPtr->paramDefs);*/ - if (parsedParamPtr->paramDefs) { - ParamDefsFree(parsedParamPtr->paramDefs); - } - FREE(XOTclParsedParam, parsedParamPtr); -} - - -/* - * method dispatch - */ -#if defined(NRE) -static int -FinalizeProcMethod(ClientData data[], Tcl_Interp *interp, int result) { - parseContext *pcPtr = data[0]; - XOTclCallStackContent *cscPtr = data[1]; - CONST char *methodName = data[2]; - XOTclObject *object = cscPtr->self; - XOTclObjectOpt *opt = object->opt; - XOTclParamDefs *paramDefs; - int rc; - - /*fprintf(stderr, "---- FinalizeProcMethod result %d, csc %p, pcPtr %p, obj %p\n", - result, cscPtr, pcPtr, object);*/ -# if defined(TCL85STACK_TRACE) - fprintf(stderr, "POP FRAME (implicit) csc %p obj %s obj refcount %d %d\n", - cscPtr, objectName(object), - obj->id ? Tcl_Command_refCount(object->id) : -100, - obj->refCount - ); -# endif - - paramDefs = ParamDefsGet(cscPtr->cmdPtr); - - if (result == TCL_OK && paramDefs && paramDefs->returns) { - Tcl_Obj *valueObj = Tcl_GetObjResult(interp); - /*fprintf(stderr, "***** we have returns for method '%s' check %s, value %p\n", - methodName, ObjStr(paramDefs->returns), valueObj);*/ - result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", - RUNTIME_STATE(interp)->doCheckResults, - NULL); - } - - if (opt && object->teardown && (opt->checkoptions & CHECK_POST)) { - /* even, when the passed result != TCL_OK, run assertion to report - * the highest possible method from the callstack (e.g. "set" would not - * be very meaningful; however, do not flush a TCL_ERROR. - */ - rc = AssertionCheck(interp, object, cscPtr->cl, methodName, CHECK_POST); - if (result == TCL_OK) { - result = rc; - } - } - - if (pcPtr) { -# if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- FinalizeProcMethod calls releasePc, stackFree %p\n", pcPtr); -# endif - parseContextRelease(pcPtr); - TclStackFree(interp, pcPtr); - } - -# if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- FinalizeProcMethod calls pop, csc free %p method %s\n", cscPtr, methodName); -# endif - CscFinish(interp, cscPtr); - TclStackFree(interp, cscPtr); - - return result; -} -#endif - -/* invoke a scripted method (with assertion checking) */ -static int -ProcMethodDispatch(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - CONST char *methodName, XOTclObject *object, XOTclClass *cl, Tcl_Command cmdPtr, - XOTclCallStackContent *cscPtr) { - int result, releasePc = 0; - XOTclObjectOpt *opt = object->opt; - XOTclParamDefs *paramDefs; -#if defined(NRE) - parseContext *pcPtr = NULL; -#else - parseContext pc, *pcPtr = &pc; -#endif - - assert(object); - assert(object->teardown); - -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "+++ ProcMethodDispatch %s, cscPtr %p, frametype %d, teardown %p\n", - methodName, cscPtr, cscPtr->frameType, object->teardown); -#endif - - /* - * if this is a filter, check whether its guard applies, - * if not: just step forward to the next filter - */ - - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - XOTclCmdList *cmdList; - /* - * seek cmd in obj's filterOrder - */ - assert(object->flags & XOTCL_FILTER_ORDER_VALID); - /* otherwise: FilterComputeDefined(interp, object);*/ - - for (cmdList = object->filterOrder; cmdList && cmdList->cmdPtr != cmdPtr; cmdList = cmdList->nextPtr); - - if (cmdList) { - /* - * A filter was found, check whether it has a guard. - */ - result = GuardCall(object, cl, (Tcl_Command) cmdList->cmdPtr, interp, - cmdList->clientData, cscPtr); - - if (result != TCL_OK) { - /*fprintf(stderr, "Filter GuardCall in invokeProc returned %d\n", result);*/ - - if (result != TCL_ERROR) { - /* - * The guard failed (but no error); call "next", use the - * actual objv's, not the callstack objv, since we may not - * be in a method resulting in invalid callstackobjs. - * - * The call stack content is not jet pushed to the Tcl - * stack, so we pass it here explicitly. - */ - - /*fprintf(stderr, "... calling nextmethod cscPtr %p\n", cscPtr);*/ - result = XOTclNextMethod(object, interp, cl, methodName, - objc, objv, /*useCallStackObjs*/ 0, cscPtr); - /*fprintf(stderr, "... after nextmethod result %d\n", result);*/ - } -#if defined(NRE) -# if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- GuardFailed calls pop, cscPtr free %p method %s\n", cscPtr, methodName); -# endif - CscFinish(interp, cscPtr); - TclStackFree(interp, cscPtr); - /* todo check mixin guards for same case? */ -#endif - return result; - } - } - } - - if (opt && (opt->checkoptions & CHECK_PRE) && - (result = AssertionCheck(interp, object, cl, methodName, CHECK_PRE)) == TCL_ERROR) { - goto finish; - } - -#ifdef DISPATCH_TRACE - printCall(interp, "ProcMethodDispatch", objc, objv); - fprintf(stderr, "\tproc=%s\n", Tcl_GetCommandName(interp, cmdPtr)); -#endif - - /* - If the method to be invoked has paramDefs, we have to call the - argument parser with the argument definitions obtained from the - proc context from the cmdPtr. - */ - paramDefs = ParamDefsGet(cmdPtr); - - /*Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc ? - ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs : NULL;*/ - - if (paramDefs && paramDefs->paramsPtr) { -#if defined(NRE) - pcPtr = (parseContext *) TclStackAlloc(interp, sizeof(parseContext)); -# if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- parseContext alloc %p\n", pcPtr); -# endif -#endif - result = ProcessMethodArguments(pcPtr, interp, object, 1, paramDefs, methodName, objc, objv); - cscPtr->objc = objc; - cscPtr->objv = (Tcl_Obj **)objv; - if (result == TCL_OK) { - releasePc = 1; - result = PushProcCallFrame(cp, interp, pcPtr->objc, pcPtr->full_objv, cscPtr); - } - } else { - result = PushProcCallFrame(cp, interp, objc, objv, cscPtr); - } - - /* we could consider to run here ARG_METHOD or ARG_INITCMD - if (result == TCL_OK) { - - } */ - - if (result != TCL_OK) { -#if defined(NRE) - if (pcPtr) TclStackFree(interp, pcPtr); -# if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- ProcPrep fails and calls pop, cscPtr free %p method %s\n", cscPtr, methodName); -# endif - CscFinish(interp, cscPtr); - TclStackFree(interp, cscPtr); -#endif - } - - /* - * The stack frame is pushed, we could do something here before - * running the byte code of the body. - */ - if (result == TCL_OK) { -#if !defined(NRE) - result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); - if (releasePc) { - parseContextRelease(&pc); - } -#else - { - TEOV_callback *rootPtr = TOP_CB(interp); - /*fprintf(stderr, "CALL TclNRInterpProcCore %s method '%s'\n", objectName(object), ObjStr(objv[0]));*/ - Tcl_NRAddCallback(interp, FinalizeProcMethod, - releasePc ? pcPtr : NULL, cscPtr, methodName, NULL); - result = TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); - /*fprintf(stderr, ".... run callbacks rootPtr = %p, result %d methodName %s\n", rootPtr, result, methodName);*/ - result = TclNRRunCallbacks(interp, result, rootPtr, 0); - /*fprintf(stderr, ".... run callbacks DONE result %d methodName %s\n", result, methodName);*/ - } -#endif - } -# if defined(TCL85STACK_TRACE) - fprintf(stderr, "POP OBJECT_FRAME (implicit) frame %p cscPtr %p obj %s obj refcount %d %d\n", NULL, cscPtr, - objectName(object), - object->id ? Tcl_Command_refCount(object->id) : -100, - object->refCount - ); -# endif - -#if defined(PRE86) -# ifdef DISPATCH_TRACE - printExit(interp, "ProcMethodDispatch", objc, objv, result); - /* fprintf(stderr, " returnCode %d xotcl rc %d\n", - Tcl_Interp_returnCode(interp), result);*/ -# endif - - if (result == TCL_OK && paramDefs && paramDefs->returns) { - Tcl_Obj *valueObj = Tcl_GetObjResult(interp); - /*fprintf(stderr, "***** we have returns for method '%s' check %s, value %p is shared %d\n", - methodName, ObjStr(paramDefs->returns), valueObj, Tcl_IsShared(valueObj));*/ - result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", - RUNTIME_STATE(interp)->doCheckResults, - NULL); - } - - opt = object->opt; - if (opt && object->teardown && - (opt->checkoptions & CHECK_POST)) { - int rc = AssertionCheck(interp, object, cscPtr->cl, methodName, CHECK_POST); - /* don't clobber error codes */ - if (result == TCL_OK) { - result = rc; - } - } -#endif - finish: - return result; -} - -/* Invoke a method implemented as a cmd (with assertion checking) */ -static int -CmdMethodDispatch(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - CONST char *methodName, XOTclObject *object, Tcl_Command cmdPtr, - XOTclCallStackContent *cscPtr) { - CheckOptions co; - int result; - Tcl_CallFrame frame, *framePtr = &frame; - - assert(object); - assert(object->teardown); - -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "+++ CmdMethodDispatchCheck %s, obj %p %s, cscPtr %p, teardown %p\n", - methodName, object, objectName(object), cscPtr, object->teardown); -#endif - - /* fprintf(stderr, ".. calling cmd %s cscPtr %p\n", methodName, cscPtr);*/ - - if (object->opt) { - co = object->opt->checkoptions; - if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(interp, object, methodName, co)) == TCL_ERROR)) { - goto finish; - } - } - - if (cscPtr) { - /* We have a call stack content, but the following dispatch will - * by itself not stack it; in order to get e.g. self working, we - * have to stack at least an FRAME_IS_XOTCL_OBJECT. - * TODO: maybe push should happen already before assertion checking, - * but we have to check what happens in the finish target etc. - */ - /*fprintf(stderr, "XOTcl_PushFrameCsc %s %s\n",objectName(object), methodName);*/ - XOTcl_PushFrameCsc(interp, cscPtr, framePtr); - } - -#ifdef DISPATCH_TRACE - printCall(interp, "CmdMethodDispatch cmd", objc, objv); - fprintf(stderr, "\tcmd=%s\n", Tcl_GetCommandName(interp, cmdPtr)); -#endif - - /*fprintf(stderr, "CmdDispatch obj %p %p %s\n", obj, methodName, methodName);*/ - result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmdPtr), cp, objc, objv); - -#ifdef DISPATCH_TRACE - printExit(interp, "CmdMethodDispatch cmd", objc, objv, result); -#endif - - if (cscPtr) { - XOTcl_PopFrameCsc(interp, framePtr); - } - - /* Reference counting in the calling ObjectDispatch() makes sure - that obj->opt is still accessible even after "dealloc" */ - if (object->opt) { - co = object->opt->checkoptions; - if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(interp, object, methodName, co)) == TCL_ERROR)) { - goto finish; - } - } - - { XOTclParamDefs *paramDefs = ParamDefsGet(cmdPtr); - - if (result == TCL_OK && paramDefs && paramDefs->returns) { - Tcl_Obj *valueObj = Tcl_GetObjResult(interp); - /* fprintf(stderr, "***** CMD we have returns for method '%s' check %s, value %p\n", - methodName, ObjStr(paramDefs->returns), valueObj);*/ - result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", - RUNTIME_STATE(interp)->doCheckResults, - NULL); - } - } - - finish: - return result; -} - -#if defined(PROFILE) -static int -MethodDispatch(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], Tcl_Command cmd, XOTclObject *object, XOTclClass *cl, - CONST char *methodName, int frameType) { - struct timeval trt; - long int startUsec = (gettimeofday(&trt, NULL), trt.tv_usec), startSec = trt.tv_sec; - - result = __MethodDispatch__(clientData, interp, objc, objv, cmd, object, cl, methodName, frameType); - XOTclProfileEvaluateData(interp, startSec, startUsec, object, cl, methodName); - return result; -} -# define MethodDispatch __MethodDispatch__ -#endif - -#if 0 -static Tcl_Obj* -SubcmdObj(Tcl_Interp *interp, CONST char *start, size_t len) { - Tcl_Obj *checker = Tcl_NewStringObj("sub=", 4); - Tcl_AppendLimitedToObj(checker, start, len, INT_MAX, NULL); - return checker; -} -#endif - -static int -DispatchUnknownMethod(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - Tcl_Obj *methodObj, int flags) { - int result; - XOTclObject *object = (XOTclObject*)clientData; - - Tcl_Obj *unknownObj = XOTclMethodObj(interp, object, XO_o_unknown_idx); - - if (unknownObj && methodObj != unknownObj && (flags & XOTCL_CM_NO_UNKNOWN) == 0) { - /* - * back off and try unknown; - */ - ALLOC_ON_STACK(Tcl_Obj*, objc+2, tov); - - /*fprintf(stderr, "calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s objc %d\n", - objectName(object), ObjStr(methodObj), flags, XOTCL_CM_NO_UNKNOWN, - XOTclObjectIsClass(object), object, objectName(object), objc);*/ - - tov[0] = object->cmdName; - tov[1] = unknownObj; - if (objc>0) { - memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc)); - } - /* - fprintf(stderr, "?? %s unknown %s\n", objectName(object), ObjStr(tov[2])); - */ - flags &= ~XOTCL_CM_NO_SHIFT; - result = ObjectDispatch(clientData, interp, objc+2, tov, flags | XOTCL_CM_NO_UNKNOWN); - FREE_ON_STACK(Tcl_Obj*, tov); - - } else { /* no unknown called, builtin unknown handler */ - - /*fprintf(stderr, "--- No unknown method Name %s objv[%d] %s\n", - ObjStr(methodObj), 1, ObjStr(objv[1]));*/ - result = XOTclVarErrMsg(interp, objectName(object), - ": unable to dispatch method '", - ObjStr(objv[1]), "'", (char *) NULL); - } - return result; -} - -/* - * MethodDispatch() calls an XOTcl method. It calls either a - * Tcl-implemented method (via ProcMethodDispatch()) or a C-implemented - * method (via CmdMethodDispatch()) and sets up stack and client data - * accordingly. - */ - -static int -MethodDispatch(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], - Tcl_Command cmd, XOTclObject *object, XOTclClass *cl, - CONST char *methodName, int frameType) { - ClientData cp = Tcl_Command_objClientData(cmd); - XOTclCallStackContent csc, *cscPtr; - register Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - - int result; - - assert (object->teardown); - /*fprintf(stderr, "MethodDispatch method '%s' cmd %p cp=%p objc=%d\n", methodName, cmd, cp, objc);*/ - - if (proc == TclObjInterpProc) { - /* - The cmd is a scripted method - */ -#if defined(NRE) - cscPtr = (XOTclCallStackContent *) TclStackAlloc(interp, sizeof(XOTclCallStackContent)); -# if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- csc alloc %p method %s\n", cscPtr, methodName); -# endif -#else - cscPtr = &csc; -#endif - CscInit(cscPtr, object, cl, cmd, frameType); - result = ProcMethodDispatch(cp, interp, objc, objv, methodName, object, cl, cmd, cscPtr); -#if defined(NRE) - /* CscFinish() is performed by the callbacks or in error case base ProcMethodDispatch */ - /*fprintf(stderr, "no pop for %s\n", methodName);*/ -#else - CscFinish(interp, cscPtr); -#endif - return result; - - } else if (cp || Tcl_Command_flags(cmd) & XOTCL_CMD_NONLEAF_METHOD) { - /* - The cmd has client data or is an aliased method - */ - cscPtr = &csc; - - /*fprintf(stderr, "we could stuff obj %p %s\n", object, objectName(object));*/ - - if (proc == XOTclObjDispatch) { - /* - * invoke an aliased object via method interface - */ - XOTclRuntimeState *rst = RUNTIME_STATE(interp); - XOTclObject *invokeObj = (XOTclObject *)cp; - - if (invokeObj->flags & XOTCL_DELETED) { - /* - * When we try to call a deleted object, the cmd (alias) is - * automatically removed. - */ - Tcl_DeleteCommandFromToken(interp, cmd); - XOTclCleanupObject(invokeObj); - return XOTclVarErrMsg(interp, "Trying to dispatch deleted object via method '", - methodName, "'", (char *) NULL); - } - - /* - * The client data cp is still the obj of the called method, - * i.e. self changes. In order to prevent this, we save the - * actual object in the runtime state, flag ObjectDispatch via - * XOTCL_CM_DELGATE to use it. - */ - /*xxxx*/ - rst->delegatee = object; - if (objc < 2) { - result = DispatchDefaultMethod(cp, interp, objc, objv); - } else { -#if 0 - ALLOC_ON_STACK(Tcl_Obj*, objc, tov); - memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); - tov[1] = SubcmdObj(interp, ObjStr(objv[1]), -1); - INCR_REF_COUNT(tov[1]); - result = ObjectDispatch(cp, interp, objc, tov, XOTCL_CM_DELGATE); - DECR_REF_COUNT(tov[1]); -#else - XOTclObject *self = (XOTclObject *)cp; - char *methodName = ObjStr(objv[1]); - - /*fprintf(stderr, "save self %p %s (ns %p) object %p %s\n", - self, objectName(self), self->nsPtr, object, objectName(object));*/ - if (self->nsPtr) { - cmd = FindMethod(self->nsPtr, methodName); - /*fprintf(stderr, "... method %p %s\n", cmd, methodName);*/ - if (cmd) { - result = MethodDispatch(object, interp, objc-1, objv+1, - cmd, object, NULL, methodName, frameType); - goto obj_dispatch_ok; - } - } - - result = DispatchUnknownMethod(self, interp, - objc-1, objv+1, objv[1], XOTCL_CM_NO_OBJECT_METHOD); - /* - result = XOTclVarErrMsg(interp, objectName(self), - ": aaa unable to dispatch method '", - methodName, "'", (char *) NULL); - */ - obj_dispatch_ok:; - /*result = ObjectDispatch(cp, interp, objc, objv, XOTCL_CM_DELGATE);*/ -#endif - } - return result; - } else if (proc == XOTclForwardMethod || - proc == XOTclObjscopedMethod || - proc == XOTclSetterMethod - ) { - TclCmdClientData *tcd = (TclCmdClientData *)cp; - tcd->object = object; - assert((CmdIsProc(cmd) == 0)); - } else if (cp == (ClientData)XOTCL_CMD_NONLEAF_METHOD) { - cp = clientData; - assert((CmdIsProc(cmd) == 0)); - } - CscInit(cscPtr, object, cl, cmd, frameType); - - } else { - /* - The cmd has no client data - */ - /*fprintf(stderr, "cmdMethodDispatch %s %s, nothing stacked\n",objectName(object), methodName);*/ - - return CmdMethodDispatch(clientData, interp, objc, objv, methodName, object, cmd, NULL); - } - - result = CmdMethodDispatch(cp, interp, objc, objv, methodName, object, cmd, cscPtr); - /* make sure, that csc is still in the scope; therefore, csc is - currently on the top scope of this function */ - CscFinish(interp, cscPtr); - - return result; -} - -static int -DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result; - Tcl_Obj *methodObj = XOTclMethodObj(interp, (XOTclObject *)clientData, XO_o_defaultmethod_idx); - - if (methodObj) { - Tcl_Obj *tov[2]; - tov[0] = objv[0]; - tov[1] = methodObj; - result = ObjectDispatch(clientData, interp, 2, tov, XOTCL_CM_NO_UNKNOWN); - } else { - result = TCL_OK; - } - return result; -} - - -XOTCLINLINE static int -ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], int flags) { - register XOTclObject *object = (XOTclObject*)clientData; - int result = TCL_OK, mixinStackPushed = 0, - filterStackPushed = 0, unknown = 0, objflags, shift, - frameType = XOTCL_CSC_TYPE_PLAIN; - CONST char *methodName; - XOTclClass *cl = NULL; - Tcl_Command cmd = NULL; - XOTclRuntimeState *rst = RUNTIME_STATE(interp); - Tcl_Obj *cmdName = object->cmdName, *methodObj, *cmdObj; - - assert(objc>0); - - if (flags & XOTCL_CM_NO_SHIFT) { - shift = 0; - cmdObj = object->cmdName; - methodObj = objv[0]; - } else { - assert(objc>1); - shift = 1; - cmdObj = objv[0]; - methodObj = objv[1]; - } - - methodName = ObjStr(methodObj); - if (FOR_COLON_RESOLVER(methodName)) { - methodName ++; - } - - /*fprintf(stderr, "ObjectDispatch obj = %s objc = %d 0=%s methodName=%s\n", - objectName(object), objc, ObjStr(cmdObj), methodName);*/ - -#ifdef DISPATCH_TRACE - printCall(interp, "DISPATCH", objc, objv); -#endif - - objflags = object->flags; /* avoid stalling */ - - /* make sure, cmdName and obj survive this method until the end */ - INCR_REF_COUNT(cmdName); - object->refCount ++; - - if (!(objflags & XOTCL_FILTER_ORDER_VALID)) { - FilterComputeDefined(interp, object); - objflags = object->flags; - } - - if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) { - MixinComputeDefined(interp, object); - objflags = object->flags; - } - - /* Only start new filter chain, if - (a) filters are defined and - (b) the toplevel csc entry is not an filter on self - */ - - /*fprintf(stderr, "call %s, objflags %.6x, defined and valid %.6x doFilters %d guard count %d\n", - methodName, objflags, XOTCL_FILTER_ORDER_DEFINED_AND_VALID, - rst->doFilters, rst->guardCount);*/ - - if (((objflags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == XOTCL_FILTER_ORDER_DEFINED_AND_VALID) - && rst->doFilters - && !rst->guardCount) { - XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); - - /*fprintf(stderr, "... check ok, cscPtr = %p\n", cscPtr); - if (!cscPtr) { - tcl85showStack(interp); - }*/ - if (!cscPtr || (object != cscPtr->self || - cscPtr->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER)) { - filterStackPushed = FilterStackPush(interp, object, methodObj); - cmd = FilterSearchProc(interp, object, &object->filterStack->currentCmdPtr, &cl); - if (cmd) { - /*fprintf(stderr, "filterSearchProc returned cmd %p\n", cmd);*/ - frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - methodName = (char *)Tcl_GetCommandName(interp, cmd); - } else { - /*fprintf(stderr, "filterSearchProc returned no cmd\n");*/ - FilterStackPop(object); - 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 ((objflags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - - mixinStackPushed = MixinStackPush(object); - - if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { - result = MixinSearchProc(interp, object, methodName, &cl, - &object->mixinStack->currentCmdPtr, &cmd); - if (result != TCL_OK) { - goto exit_dispatch; - } - if (cmd) { - frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - } else { /* the else branch could be deleted */ - MixinStackPop(object); - mixinStackPushed = 0; - } - } - } - - /* check if an absolute method name was provided */ - if (*methodName == ':') { - cmd = Tcl_GetCommandFromObj(interp, methodObj); - if (cmd) { - CONST char *mn = Tcl_GetCommandName(interp, cmd); - if (isClassName(methodName)) { - CONST char *className = NSCutXOTclClasses(methodName); - Tcl_DString ds, *dsPtr = &ds; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className, strlen(className)-strlen(mn)-2); - cl = (XOTclClass *)XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - DSTRING_FREE(dsPtr); - } - } - } - - /* if no filter/mixin is found => do ordinary method lookup */ - if (cmd == NULL) { - - /* do we have a object-specific proc? */ - if (object->nsPtr && (flags & XOTCL_CM_NO_OBJECT_METHOD) == 0) { - cmd = FindMethod(object->nsPtr, methodName); - /* fprintf(stderr, "lookup for proc in obj %p method %s nsPtr %p => %p\n", - object, methodName, object->nsPtr, cmd);*/ - } - /*fprintf(stderr, "findMethod for proc '%s' in %p returned %p\n", methodName, object->nsPtr, cmd);*/ - - if (cmd == NULL) { - /* check for a method */ - XOTclClass *currentClass = object->cl; - if (currentClass->order == NULL) currentClass->order = TopoOrder(currentClass, Super); - cl = SearchPLMethod(currentClass->order, methodName, &cmd); - } - } - - if (cmd) { - result = TCL_OK; - - /*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 */ - - if ((Tcl_Command_flags(cmd) & XOTCL_CMD_PROTECTED_METHOD) && - (flags & (XOTCL_CM_NO_UNKNOWN|XOTCL_CM_NO_PROTECT)) == 0) { - XOTclObject *o, *lastSelf = GetSelfObj(interp); - - /* we do not want to rely on clientData, so get obj from cmdObj */ - GetObjectFromObj(interp, cmdObj, &o); - if (o != lastSelf) { - /*fprintf(stderr, "+++ protected method %s is not invoked\n", methodName);*/ - /* allow unknown-handler to handle this case */ - unknown = 1; - fprintf(stderr, "+++ %s is protected, therefore maybe unknown %p %s lastself=%p o=%p cd %p flags = %.6x\n", - methodName, cmdObj, ObjStr(cmdObj), lastSelf, o, clientData, flags); - /*tcl85showStack(interp);*/ - } - } - - if (!unknown) { - /* xxxx */ - /*fprintf(stderr, "ObjectDispatch calls MethodDispatch with obj = %s frameType %d method %s flags %.6x\n", - objectName(object), frameType, methodName, flags);*/ - if (flags & XOTCL_CM_DELGATE && rst->delegatee) { - /* - * We want to execute the method on the delegatee, so we have - * to flip the object. - * - * Note: there is a object->refCount ++; at the begin of this - * function and a XOTclCleanupObject(object) at the end. So, - * we have to keep track of the refcounts here. Either mangle - * refcounts, or save originator. - * - */ - result = MethodDispatch(rst->delegatee, interp, objc-shift, objv+shift, - cmd, rst->delegatee, cl, - methodName, frameType); - } else { - result = MethodDispatch(clientData, interp, objc-shift, objv+shift, cmd, object, cl, - methodName, frameType); - } - - /*fprintf(stderr, "MethodDispatch %s returns %d unknown %d\n", - methodName, result, rst->unknown);*/ - - if (result == TCL_ERROR) { - /*fprintf(stderr, "Call ErrInProc cl = %p, cmd %p, flags %.6x\n", - cl, cl ? cl->object.id : 0, cl ? cl->object.flags : 0);*/ - result = XOTclErrInProc(interp, cmdName, - cl && cl->object.teardown ? cl->object.cmdName : NULL, - methodName); - } - - if (rst->unknown && (frameType & XOTCL_CSC_TYPE_ACTIVE_FILTER)) { - /*fprintf(stderr, "use saved unknown %d frameType %.6x\n", - RUNTIME_STATE(interp)->unknown, frameType);*/ - unknown = 1; - } else { - unknown = 0; - } - - } - } else { - unknown = 1; - } - - /* fprintf(stderr, "cmd %p unknown %d result %d\n", cmd, unknown, result);*/ - - if (result == TCL_OK) { - /*fprintf(stderr, "after doCallProcCheck unknown == %d\n", unknown);*/ - if (unknown) { - result = DispatchUnknownMethod(clientData, interp, - objc-shift, objv+shift, methodObj, flags); - } - } - /* be sure to reset unknown flag */ - if (unknown && (frameType & XOTCL_CSC_TYPE_ACTIVE_FILTER) == 0) { - /*fprintf(stderr, "**** rst->unknown set to 0 flags %.6x frameType %.6x\n",flags,frameType);*/ - rst->unknown = 0; - } - - exit_dispatch: -#ifdef DISPATCH_TRACE - printExit(interp, "DISPATCH", objc, objv, result); -#endif - - if (mixinStackPushed && object->mixinStack) - MixinStackPop(object); - - if (filterStackPushed && object->filterStack) - FilterStackPop(object); - - XOTclCleanupObject(object); - /*fprintf(stderr, "ObjectDispatch call XOTclCleanupObject %p DONE\n", object);*/ - DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */ - return result; -} - - -int -XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result; -#ifdef STACK_TRACE - XOTclStackDump(interp); -#endif - -#ifdef CALLSTACK_TRACE - XOTclCallStackDump(interp); -#endif - - if (objc > 1) { - /* normal dispatch */ - result = ObjectDispatch(clientData, interp, objc, objv, 0); - } else { - result = DispatchDefaultMethod(clientData, interp, objc, objv); - } - return result; -} - -/* - * Proc-Creation - */ - -static Tcl_Obj *addPrefixToBody(Tcl_Obj *body, int paramDefs, XOTclParsedParam *paramPtr) { - Tcl_Obj *resultBody = Tcl_NewStringObj("", 0); - - INCR_REF_COUNT(resultBody); - - if (paramDefs && paramPtr->possibleUnknowns > 0) - Tcl_AppendStringsToObj(resultBody, "::nsf::unsetUnknownArgs\n", (char *) NULL); - - Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); - return resultBody; -} - -#define NEW_STRING(target, p, l) target = ckalloc(l+1); strncpy(target, p, l); *((target)+l) = '\0' - -XOTCLINLINE static int -noMetaChars(CONST char *pattern) { - register char c; - CONST char *p = pattern; - - assert(pattern); - for (c=*p; c; c = *++p) { - if (c == '*' || c == '?' || c == '[') { - return 0; - } - } - return 1; -} - -/* - * type converter - */ -/* we could define parameterTypes with a converter, setter, canCheck, name */ -static int convertToString(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - *clientData = (char *)ObjStr(objPtr); - *outObjPtr = objPtr; - return TCL_OK; -} - -enum stringTypeIdx {StringTypeAlnum, StringTypeAlpha, StringTypeAscii, StringTypeBoolean, StringTypeControl, - StringTypeDigit, StringTypeDouble, StringTypeFalse,StringTypeGraph, StringTypeInteger, - StringTypeLower, StringTypePrint, StringTypePunct, StringTypeSpace, StringTypeTrue, - StringTypeUpper, StringTypeWordchar, StringTypeXdigit }; -static CONST char *stringTypeOpts[] = {"alnum", "alpha", "ascii", "boolean", "control", - "digit", "double", "false", "graph", "integer", - "lower", "print", "punct", "space", "true", - "upper", "wordchar", "xdigit", NULL}; - -static int convertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - Tcl_Obj *objv[3]; - int result; - - if (pPtr->converterArg) { - /*fprintf(stderr, "convertToStringType %s (must be %s)\n", ObjStr(objPtr), ObjStr(pPtr->converterArg));*/ - - objv[1] = pPtr->converterArg; - objv[2] = objPtr; - - result = XOTclCallCommand(interp, XOTE_IS, 3, objv); - if (result == TCL_OK) { - int success; - Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &success); - if (success == 1) { - *clientData = (ClientData)objPtr; - } else { - result = XOTclVarErrMsg(interp, "expected ", ObjStr(pPtr->converterArg), - " but got \"", ObjStr(objPtr), - "\" for parameter ", pPtr->name, NULL); - } - } - } else { - *clientData = (ClientData)objPtr; - result = TCL_OK; - } - *outObjPtr = objPtr; - return result; -} - -static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - *outObjPtr = objPtr; - return TCL_OK; -} - -static int convertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - int result, bool; - result = Tcl_GetBooleanFromObj(interp, objPtr, &bool); - - if (result == TCL_OK) { - *clientData = (ClientData)INT2PTR(bool); - } else { - XOTclVarErrMsg(interp, "expected boolean value but got \"", ObjStr(objPtr), - "\" for parameter ", pPtr->name, NULL); - } - *outObjPtr = objPtr; - return result; -} - -static int convertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - int result, i; - - result = Tcl_GetIntFromObj(interp, objPtr, &i); - - if (result == TCL_OK) { - *clientData = (ClientData)INT2PTR(i); - *outObjPtr = objPtr; - } else { - XOTclVarErrMsg(interp, "expected integer but got \"", ObjStr(objPtr), - "\" for parameter ", pPtr->name, NULL); - } - return result; -} - -static int convertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - return convertToBoolean(interp, objPtr, pPtr, clientData, outObjPtr); -} - -static int objectOfType(Tcl_Interp *interp, XOTclObject *object, CONST char *what, Tcl_Obj *objPtr, - XOTclParam CONST *pPtr) { - XOTclClass *cl; - Tcl_DString ds, *dsPtr = &ds; - - if (pPtr->converterArg == NULL) - return TCL_OK; - - if ((GetClassFromObj(interp, pPtr->converterArg, &cl, NULL) == TCL_OK) - && IsSubType(object->cl, cl)) { - return TCL_OK; - } - - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, what, -1); - Tcl_DStringAppend(dsPtr, " of type ", -1); - Tcl_DStringAppend(dsPtr, ObjStr(pPtr->converterArg), -1); - XOTclObjErrType(interp, objPtr, Tcl_DStringValue(dsPtr), pPtr->name); - DSTRING_FREE(dsPtr); - - return TCL_ERROR; -} - -static int convertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - *outObjPtr = objPtr; - if (GetObjectFromObj(interp, objPtr, (XOTclObject **)clientData) == TCL_OK) { - return objectOfType(interp, (XOTclObject *)*clientData, "object", objPtr, pPtr); - } - return XOTclObjErrType(interp, objPtr, "object", pPtr->name); -} - -static int convertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - *outObjPtr = objPtr; - if (GetClassFromObj(interp, objPtr, (XOTclClass **)clientData, NULL) == TCL_OK) { - return objectOfType(interp, (XOTclObject *)*clientData, "class", objPtr, pPtr); - } - return XOTclObjErrType(interp, objPtr, "class", pPtr->name); -} - -static int convertToRelation(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - /* XOTclRelationCmd is the real setter, which checks the values - according to the relation type (Class, List of Class, list of - filters; we treat it here just like a tclobj */ - *clientData = (ClientData)objPtr; - *outObjPtr = objPtr; - return TCL_OK; -} - -static int convertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - Tcl_Obj *ov[5]; - Tcl_Obj *savedResult; - int result, oc; - - /* - * In general, when the converter is used e.g. for result checking, - * we do not want to alter the result just when the converter sets a - * result. So, for non-converter, we save the old result and restore - * it before the return in case of success. Strictly speaking, - * result-overwritng just harms for result-converters, but saving is - * always semantic correct. - */ - if ((pPtr->flags & XOTCL_ARG_IS_CONVERTER) == 0) { - savedResult = Tcl_GetObjResult(interp); /* save the result */ - INCR_REF_COUNT(savedResult); - } else { - savedResult = NULL; - } - - ov[0] = pPtr->slotObj ? pPtr->slotObj : XOTclGlobalObjs[XOTE_METHOD_PARAMETER_SLOT_OBJ]; - ov[1] = pPtr->converterName; - ov[2] = pPtr->nameObj; - ov[3] = objPtr; - - /*fprintf(stderr, "convertViaCmd call converter %s (refCount %d) on %s paramPtr %p\n", - ObjStr(pPtr->converterName), pPtr->converterName->refCount, ObjStr(ov[0]), pPtr);*/ - oc = 4; - if (pPtr->converterArg) { - ov[4] = pPtr->converterArg; - oc++; - } - - - INCR_REF_COUNT(ov[1]); - INCR_REF_COUNT(ov[2]); - result = Tcl_EvalObjv(interp, oc, ov, 0); - DECR_REF_COUNT(ov[1]); - DECR_REF_COUNT(ov[2]); - - /* per default, the input arg is the output arg */ - *outObjPtr = objPtr; - - if (result == TCL_OK) { - /*fprintf(stderr, "convertViaCmd could convert %s to '%s' paramPtr %p, is_converter %d\n", - ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)),pPtr, - pPtr->flags & XOTCL_ARG_IS_CONVERTER);*/ - if (pPtr->flags & XOTCL_ARG_IS_CONVERTER) { - /* - * If we want to convert, the resulting obj is the result of the - * converter. incr refCount is necessary e.g. for e.g. - * return [expr {$value + 1}] - */ - *outObjPtr = Tcl_GetObjResult(interp); - INCR_REF_COUNT(*outObjPtr); - } - *clientData = (ClientData) *outObjPtr; - - if (savedResult) { - /*fprintf(stderr, "restore savedResult %p\n", savedResult);*/ - Tcl_SetObjResult(interp, savedResult); /* restore the result */ - } - } - - if (savedResult) { - DECR_REF_COUNT(savedResult); - } - - return result; -} - -static int convertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, - ClientData *clientData, Tcl_Obj **outObjPtr) { - Tcl_Obj *patternObj = objPtr; - CONST char *pattern = ObjStr(objPtr); - - if (noMetaChars(pattern)) { - /* we have no meta characters, we try to check for an existing object */ - XOTclObject *object = NULL; - GetObjectFromObj(interp, objPtr, &object); - if (object) { - patternObj = object->cmdName; - } - } else { - /* - * 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+1 != ':') { - patternObj = Tcl_NewStringObj("::", 2); - Tcl_AppendLimitedToObj(patternObj, pattern, -1, INT_MAX, NULL); - } - } - if (patternObj) { - INCR_REF_COUNT(patternObj); - } - *clientData = (ClientData)patternObj; - *outObjPtr = objPtr; - return TCL_OK; -} - -static Tcl_Obj* -ParamCheckObj(Tcl_Interp *interp, CONST char *start, size_t len) { - Tcl_Obj *checker = Tcl_NewStringObj("type=", 5); - Tcl_AppendLimitedToObj(checker, start, len, INT_MAX, NULL); - return checker; -} - -static int -ParamOptionSetConverter(Tcl_Interp *interp, XOTclParam *paramPtr, - CONST char *typeName, XOTclTypeConverter *converter) { - if (paramPtr->converter) { - return XOTclVarErrMsg(interp, "Refuse to redefine parameter converter to use ", - typeName, (char *) NULL); - } - paramPtr->converter = converter; - paramPtr->nrArgs = 1; - paramPtr->type = typeName; - return TCL_OK; -} - -static int -ParamOptionParse(Tcl_Interp *interp, CONST char *option, size_t length, int disallowedOptions, XOTclParam *paramPtr) { - int result = TCL_OK; - /*fprintf(stderr, "ParamOptionParse name %s, option '%s' (%d) disallowed %.6x\n", - paramPtr->name, option, length, disallowedOptions);*/ - if (strncmp(option, "required", MAX(3,length)) == 0) { - paramPtr->flags |= XOTCL_ARG_REQUIRED; - } else if (strncmp(option, "optional", MAX(3,length)) == 0) { - paramPtr->flags &= ~XOTCL_ARG_REQUIRED; - } else if (strncmp(option, "substdefault", 12) == 0) { - paramPtr->flags |= XOTCL_ARG_SUBST_DEFAULT; - } else if (strncmp(option, "allowempty", 10) == 0) { - paramPtr->flags |= XOTCL_ARG_ALLOW_EMPTY; - } else if (strncmp(option, "convert", 7) == 0) { - paramPtr->flags |= XOTCL_ARG_IS_CONVERTER; - } else if (strncmp(option, "initcmd", 7) == 0) { - paramPtr->flags |= XOTCL_ARG_INITCMD; - } else if (strncmp(option, "method", 6) == 0) { - paramPtr->flags |= XOTCL_ARG_METHOD; - } else if (strncmp(option, "multivalued", 11) == 0) { - if ((paramPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_METHOD|XOTCL_ARG_SWITCH)) != 0) - return XOTclVarErrMsg(interp, - "option multivalued not allowed for \"initcmd\", \"method\", \"relation\" or \"switch\"\n", - (char *) NULL); - paramPtr->flags |= XOTCL_ARG_MULTIVALUED; - } else if (strncmp(option, "noarg", 5) == 0) { - if ((paramPtr->flags & XOTCL_ARG_METHOD) == 0) { - return XOTclVarErrMsg(interp, "option noarg only allowed for parameter type \"method\"", - (char *) NULL); - } - paramPtr->flags |= XOTCL_ARG_NOARG; - paramPtr->nrArgs = 0; - } else if (length >= 4 && strncmp(option, "arg=", 4) == 0) { - if ((paramPtr->flags & (XOTCL_ARG_METHOD|XOTCL_ARG_RELATION)) == 0 - && paramPtr->converter != convertViaCmd) - return XOTclVarErrMsg(interp, - "option arg= only allowed for \"method\", \"relation\" or \"user-defined converter\"", - (char *) NULL); - paramPtr->converterArg = Tcl_NewStringObj(option+4, length-4); - INCR_REF_COUNT(paramPtr->converterArg); - } else if (strncmp(option, "switch", 6) == 0) { - result = ParamOptionSetConverter(interp, paramPtr, "switch", convertToSwitch); - paramPtr->flags |= XOTCL_ARG_SWITCH; - paramPtr->nrArgs = 0; - assert(paramPtr->defaultValue == NULL); - paramPtr->defaultValue = Tcl_NewBooleanObj(0); - INCR_REF_COUNT(paramPtr->defaultValue); - } else if (strncmp(option, "integer", MAX(3,length)) == 0) { - result = ParamOptionSetConverter(interp, paramPtr, "integer", convertToInteger); - } else if (strncmp(option, "boolean", 7) == 0) { - result = ParamOptionSetConverter(interp, paramPtr, "boolean", convertToBoolean); - } else if (strncmp(option, "object", 6) == 0) { - result = ParamOptionSetConverter(interp, paramPtr, "object", convertToObject); - } else if (strncmp(option, "class", 5) == 0) { - result = ParamOptionSetConverter(interp, paramPtr, "class", convertToClass); - } else if (strncmp(option, "relation", 8) == 0) { - result = ParamOptionSetConverter(interp, paramPtr, "relation", convertToRelation); - paramPtr->flags |= XOTCL_ARG_RELATION; - /*paramPtr->type = "tclobj";*/ - } else if (length >= 6 && strncmp(option, "type=", 5) == 0) { - if (paramPtr->converter != convertToObject && - paramPtr->converter != convertToClass) - return XOTclVarErrMsg(interp, "option type= only allowed for object or class", (char *) NULL); - paramPtr->converterArg = Tcl_NewStringObj(option+5, length-5); - INCR_REF_COUNT(paramPtr->converterArg); - } else if (length >= 6 && strncmp(option, "slot=", 5) == 0) { - paramPtr->slotObj = Tcl_NewStringObj(option+5, length-5); - INCR_REF_COUNT(paramPtr->slotObj); - } else { - int i, found = -1; - - for (i=0; stringTypeOpts[i]; i++) { - /* Do not allow abbreviations, so the additional strlen checks - for a full match */ - if (strncmp(option, stringTypeOpts[i], length) == 0 && strlen(stringTypeOpts[i]) == length) { - found = i; - break; - } - } - if (found > -1) { - /* converter is stringType */ - result = ParamOptionSetConverter(interp, paramPtr, "stringtype", convertToTclobj); - paramPtr->converterArg = Tcl_NewStringObj(stringTypeOpts[i], -1); - INCR_REF_COUNT(paramPtr->converterArg); - } else { - /* must be a converter defined via method */ - paramPtr->converterName = ParamCheckObj(interp, option, length); - INCR_REF_COUNT(paramPtr->converterName); - result = ParamOptionSetConverter(interp, paramPtr, ObjStr(paramPtr->converterName), convertViaCmd); - } - } - - if ((paramPtr->flags & disallowedOptions)) { - return XOTclVarErrMsg(interp, "Parameter option '", option, "' not allowed", (char *) NULL); - } - - return result; -} - -static int -ParamParse(Tcl_Interp *interp, CONST char *procName, Tcl_Obj *arg, int disallowedFlags, - XOTclParam *paramPtr, int *possibleUnknowns, int *plainParams) { - int result, npac, isNonposArgument; - size_t nameLength, length, j; - CONST char *argString, *argName; - Tcl_Obj **npav; - - paramPtr->paramObj = arg; - INCR_REF_COUNT(paramPtr->paramObj); - - result = Tcl_ListObjGetElements(interp, arg, &npac, &npav); - if (result != TCL_OK || npac < 1 || npac > 2) { - return XOTclVarErrMsg(interp, "wrong # of elements in parameter definition for method ", - procName, " (should be 1 or 2 list elements): ", - ObjStr(arg), (char *) NULL); - } - - argString = ObjStr(npav[0]); - length = strlen(argString); - - isNonposArgument = *argString == '-'; - - if (isNonposArgument) { - argName = argString+1; - nameLength = length-1; - paramPtr->nrArgs = 1; /* per default 1 argument, switches set their arg numbers */ - } else { - argName = argString; - nameLength = length; - paramPtr->flags |= XOTCL_ARG_REQUIRED; /* positional arguments are required unless we have a default */ - } - - /* fprintf(stderr, "... parsing '%s', name '%s' \n", ObjStr(arg), argName);*/ - - /* find the first ':' */ - for (j=0; jname, argString, j); - paramPtr->nameObj = Tcl_NewStringObj(argName, isNonposArgument ? j-1 : j); - INCR_REF_COUNT(paramPtr->nameObj); - - /* skip space at begin */ - for (start = j+1; start0 && isspace((int)argString[end-1]); end--); - result = ParamOptionParse(interp, argString+start, end-start, disallowedFlags, paramPtr); - if (result != TCL_OK) { - goto param_error; - } - l++; - /* skip space from begin */ - for (start = l; start0 && isspace((int)argString[end-1]); end--); - /* process last option */ - result = ParamOptionParse(interp, argString+start, end-start, disallowedFlags, paramPtr); - if (result != TCL_OK) { - goto param_error; - } - } else { - /* no ':', the whole arg is the name, we have not options */ - NEW_STRING(paramPtr->name, argString, length); - if (isNonposArgument) { - paramPtr->nameObj = Tcl_NewStringObj(argName, length-1); - } else { - (*plainParams) ++; - paramPtr->nameObj = Tcl_NewStringObj(argName, length); - } - INCR_REF_COUNT(paramPtr->nameObj); - } - - /* if we have two arguments in the list, the second one is a default value */ - if (npac == 2) { - - if (disallowedFlags & XOTCL_ARG_HAS_DEFAULT) { - XOTclVarErrMsg(interp, "parameter \"", argString, - "\" is not allowed to have default \"", - ObjStr(npav[1]), "\"", (char *) NULL); - goto param_error; - } - - /* if we have for some reason already a default value, free it */ - if (paramPtr->defaultValue) { - DECR_REF_COUNT(paramPtr->defaultValue); - } - paramPtr->defaultValue = Tcl_DuplicateObj(npav[1]); - INCR_REF_COUNT(paramPtr->defaultValue); - /* - * The argument will be not required for an invocation, since we - * have a default. - */ - paramPtr->flags &= ~XOTCL_ARG_REQUIRED; - } else if (paramPtr->flags & XOTCL_ARG_SUBST_DEFAULT) { - XOTclVarErrMsg(interp, "parameter option substdefault specified for parameter \"", - paramPtr->name, "\" without default value", (char *) NULL); - goto param_error; - } - - /* postprocessing the parameter options */ - - if (paramPtr->converter == NULL) { - /* convertToTclobj() is the default converter */ - paramPtr->converter = convertToTclobj; - } /*else if (paramPtr->converter == convertViaCmd) {*/ - - if ((paramPtr->slotObj || paramPtr->converter == convertViaCmd) && paramPtr->type) { - Tcl_Obj *converterNameObj; - CONST char *converterNameString; - XOTclObject *paramObj; - XOTclClass *pcl; - Tcl_Command cmd; - - result = GetObjectFromObj(interp, paramPtr->slotObj ? paramPtr->slotObj : - XOTclGlobalObjs[XOTE_METHOD_PARAMETER_SLOT_OBJ], - ¶mObj); - if (result != TCL_OK) - return result; - - if (paramPtr->converterName == NULL) { - converterNameObj = ParamCheckObj(interp, paramPtr->type, strlen(paramPtr->type)); - INCR_REF_COUNT(converterNameObj); - } else { - converterNameObj = paramPtr->converterName; - } - converterNameString = ObjStr(converterNameObj); - - cmd = ObjectFindMethod(interp, paramObj, converterNameString, &pcl); - if (cmd == NULL) { - if (paramPtr->converter == convertViaCmd) { - fprintf(stderr, "**** could not find checker method %s defined on %s\n", - converterNameString, objectName(paramObj)); - paramPtr->flags |= XOTCL_ARG_CURRENTLY_UNKNOWN; - /* TODO: for the time being, we do not return an error here */ - } - } else if (paramPtr->converter != convertViaCmd && - strcmp(ObjStr(paramPtr->slotObj), - XOTclGlobalStrings[XOTE_METHOD_PARAMETER_SLOT_OBJ]) != 0) { - /* todo remove me */ - fprintf(stderr, "**** checker method %s defined on %s shadows built-in converter\n", - converterNameString, objectName(paramObj)); - if (paramPtr->converterName == NULL) { - paramPtr->converterName = converterNameObj; - paramPtr->converter = NULL; - result = ParamOptionSetConverter(interp, paramPtr, converterNameString, convertViaCmd); - } - } - if ((paramPtr->flags & XOTCL_ARG_IS_CONVERTER) && paramPtr->converter != convertViaCmd) { - return XOTclVarErrMsg(interp, - "option 'convert' only allowed for application-defined converters", - (char *) NULL); - } - if (converterNameObj != paramPtr->converterName) { - DECR_REF_COUNT(converterNameObj); - } - } - - /* - * If the argument is not required and no default value is - * specified, we have to handle in the client code (eg. in the - * canonical arg handlers for scripted methods) the unknown value - * (e.g. don't set/unset a variable) - */ - if (!(paramPtr->flags & XOTCL_ARG_REQUIRED) && paramPtr->defaultValue == NULL) { - (*possibleUnknowns)++; - } - return TCL_OK; - - param_error: - ckfree((char *)paramPtr->name); - paramPtr->name = NULL - DECR_REF_COUNT(paramPtr->nameObj); - return TCL_ERROR; -} - -static int -ParamDefsParse(Tcl_Interp *interp, CONST char *procName, Tcl_Obj *args, - int allowedOptinons, XOTclParsedParam *parsedParamPtr) { - Tcl_Obj **argsv; - int result, argsc; - - parsedParamPtr->paramDefs = NULL; - parsedParamPtr->possibleUnknowns = 0; - - result = Tcl_ListObjGetElements(interp, args, &argsc, &argsv); - if (result != TCL_OK) { - return XOTclVarErrMsg(interp, "cannot break down non-positional args: ", - ObjStr(args), (char *) NULL); - } - - if (argsc > 0) { - XOTclParam *paramsPtr, *paramPtr, *lastParamPtr; - int i, possibleUnknowns = 0, plainParams = 0; - XOTclParamDefs *paramDefs; - - paramPtr = paramsPtr = ParamsNew(argsc); - - for (i=0; i < argsc; i++, paramPtr++) { - result = ParamParse(interp, procName, argsv[i], allowedOptinons, - paramPtr, &possibleUnknowns, &plainParams); - if (result != TCL_OK) { - ParamsFree(paramsPtr); - return result; - } - } - - /* - * If all arguments are good old Tcl arguments, there is no need - * to use the parameter definition structure. - */ - if (plainParams == argsc) { - ParamsFree(paramsPtr); - return TCL_OK; - } - /* - fprintf(stderr, "we need param definition structure for {%s}, argsc %d plain %d\n", - ObjStr(args), argsc, plainParams); - */ - /* - * Check the last argument. If the last argument is named 'args', - * force converter and make it non-required. - */ - lastParamPtr = paramPtr - 1; - if (isArgsString(lastParamPtr->name)) { - lastParamPtr->converter = convertToNothing; - lastParamPtr->flags &= ~XOTCL_ARG_REQUIRED; - } - - paramDefs = ParamDefsNew(); - paramDefs->paramsPtr = paramsPtr; - paramDefs->nrParams = paramPtr-paramsPtr; - /*fprintf(stderr, "method %s ifsize %d, possible unknowns = %d,\n", - procName, paramPtr-paramDefsPtr, possibleUnknowns);*/ - parsedParamPtr->paramDefs = paramDefs; - parsedParamPtr->possibleUnknowns = possibleUnknowns; - } - return TCL_OK; -} - -static int -MakeProc(Tcl_Namespace *nsPtr, XOTclAssertionStore *aStore, Tcl_Interp *interp, - Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, - Tcl_Obj *postcondition, XOTclObject *object, - int withPublic, int withPer_object, int clsns) { - Tcl_CallFrame frame, *framePtr = &frame; - CONST char *methodName = ObjStr(nameObj); - XOTclParsedParam parsedParam; - Tcl_Obj *ov[4]; - int result; - - /* Check, if we are allowed to redefine the method */ - result = CanRedefineCmd(interp, nsPtr, object, methodName); - if (result == TCL_OK) { - /* Yes, so obtain an method parameter definitions */ - result = ParamDefsParse(interp, methodName, args, XOTCL_DISALLOWED_ARG_METHOD_PARAMETER, &parsedParam); - } - if (result != TCL_OK) { - return result; - } - - ov[0] = NULL; /*objv[0];*/ - ov[1] = nameObj; - - if (parsedParam.paramDefs) { - XOTclParam *pPtr; - Tcl_Obj *argList = Tcl_NewListObj(0, NULL); - - for (pPtr = parsedParam.paramDefs->paramsPtr; pPtr->name; pPtr++) { - if (*pPtr->name == '-') { - Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name+1, -1)); - } else { - Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name, -1)); - } - } - ov[2] = argList; - INCR_REF_COUNT(ov[2]); - /*fprintf(stderr, "final arglist = <%s>\n", ObjStr(argList)); */ - ov[3] = addPrefixToBody(body, 1, &parsedParam); - } else { /* no nonpos arguments */ - ov[2] = args; - ov[3] = addPrefixToBody(body, 0, &parsedParam); - } - - Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, nsPtr, 0); - /* create the method in the provided namespace */ - result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; - if (result == TCL_OK) { - /* retrieve the defined proc */ - Proc *procPtr = FindProcMethod(nsPtr, methodName); - if (procPtr) { - /* modify the cmd of the proc to set the current namespace for the body */ - if (clsns) { - /* - * Set the namespace of the method as inside of the class - */ - if (!object->nsPtr) { - makeObjNamespace(interp, object); - } - /*fprintf(stderr, "obj %s\n", objectName(object)); - fprintf(stderr, "ns %p object->ns %p\n", ns, object->nsPtr); - fprintf(stderr, "ns %s object->ns %s\n", ns->fullName, object->nsPtr->fullName);*/ - procPtr->cmdPtr->nsPtr = (Namespace*) object->nsPtr; - } else { - /* - * Set the namespace of the method to the same namespace the class has - */ - procPtr->cmdPtr->nsPtr = ((Command *)object->id)->nsPtr; - } - - ParamDefsStore(interp, (Tcl_Command)procPtr->cmdPtr, parsedParam.paramDefs); -#if 0 - if (!withPublic) { - Tcl_Command_flags((Tcl_Command)procPtr->cmdPtr) |= XOTCL_CMD_PROTECTED_METHOD; - } -#endif - result = ListMethodHandle(interp, object, withPer_object, methodName); - } - } - Tcl_PopCallFrame(interp); - - if (result == TCL_OK && (precondition || postcondition)) { - AssertionAddProc(interp, methodName, aStore, precondition, postcondition); - } - - if (parsedParam.paramDefs) { - DECR_REF_COUNT(ov[2]); - } - DECR_REF_COUNT(ov[3]); - - return result; -} - -static int -MakeMethod(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl, Tcl_Obj *nameObj, - Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition, - int withPublic, int clsns) { - CONST char *argsStr = ObjStr(args), *bodyStr = ObjStr(body), *nameStr = ObjStr(nameObj); - int result; - - if (precondition && !postcondition) { - return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, - "'; when specifying a precondition (", ObjStr(precondition), - ") a postcondition must be specified as well", - (char *) NULL); - } - - /* if both, args and body are empty strings, we delete the method */ - if (*argsStr == 0 && *bodyStr == 0) { - result = cl ? - XOTclRemoveClassMethod(interp, (XOTcl_Class *)cl, nameStr) : - XOTclRemoveObjectMethod(interp, (XOTcl_Object *)object, nameStr); - } else { - XOTclAssertionStore *aStore = NULL; - if (precondition || postcondition) { - if (cl) { - XOTclClassOpt *opt = XOTclRequireClassOpt(cl); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; - } else { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; - } - } - result = MakeProc(cl ? cl->nsPtr : object->nsPtr, aStore, - interp, nameObj, args, body, precondition, postcondition, - object, withPublic, cl == NULL, clsns); - } - - if (cl) { - /* could be a filter or filter inheritance ... update filter orders */ - FilterInvalidateObjOrders(interp, cl); - } else { - /* could be a filter => recompute filter order */ - FilterComputeDefined(interp, object); - } - - return result; -} - -static int -getMatchObject(Tcl_Interp *interp, Tcl_Obj *patternObj, Tcl_Obj *origObj, - XOTclObject **matchObject, CONST char **pattern) { - if (patternObj) { - *pattern = ObjStr(patternObj); - if (IsXOTclTclObj(interp, patternObj, matchObject)) { - } else if (patternObj == origObj && **pattern != ':') { - /* no meta chars, but no appropriate xotcl object found, so - return empty; we could check above with noMetaChars(pattern) - as well, but the only remaining case are leading colons and - metachars. */ - return 1; - } - } - return 0; -} - -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); -} - -static int -forwardProcessOptions(Tcl_Interp *interp, Tcl_Obj *nameObj, - Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, - int withObjscope, Tcl_Obj *withOnerror, int withVerbose, - Tcl_Obj *target, int objc, Tcl_Obj * CONST objv[], - ForwardCmdClientData **tcdp) { - ForwardCmdClientData *tcd; - int i, result = 0; - - tcd = NEW(ForwardCmdClientData); - memset(tcd, 0, sizeof(ForwardCmdClientData)); - - if (withDefault) { - Tcl_DString ds, *dsPtr = &ds; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, "%1 {", 4); - Tcl_DStringAppend(dsPtr, ObjStr(withDefault), -1); - Tcl_DStringAppend(dsPtr, "}", 1); - XOTclDeprecatedCmd(interp, "forward option","-default ...", Tcl_DStringValue(dsPtr)); - DSTRING_FREE(dsPtr); - - tcd->subcommands = withDefault; - result = Tcl_ListObjLength(interp, withDefault, &tcd->nr_subcommands); - INCR_REF_COUNT(tcd->subcommands); - } - if (withMethodprefix) { - tcd->prefix = withMethodprefix; - INCR_REF_COUNT(tcd->prefix); - } - if (withOnerror) { - tcd->onerror = withOnerror; - INCR_REF_COUNT(tcd->onerror); - } - tcd->objscope = withObjscope; - tcd->verbose = withVerbose; - tcd->needobjmap = 0; - tcd->cmdName = target; - /*fprintf(stderr, "...forwardprocess objc %d\n", objc);*/ - - for (i=0; ineedobjmap |= (*element == '%' && *(element+1) == '@'); - tcd->hasNonposArgs |= (*element == '%' && *(element+1) == '-'); - 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 = nameObj; - } - - /*fprintf(stderr, "cmdName = %s, args = %s, # = %d\n", - ObjStr(tcd->cmdName), tcd->args?ObjStr(tcd->args):"NULL", tcd->nr_args);*/ - - 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 - */ - CONST char *nameString = ObjStr(tcd->cmdName); - if (!isAbsolutePath(nameString)) { - tcd->cmdName = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); - /*fprintf(stderr, "name %s not absolute, therefore qualifying %s\n", nameObj, - ObjStr(tcd->cmdName));*/ - } - } - INCR_REF_COUNT(tcd->cmdName); - - if (withEarlybinding) { - 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->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc; - - /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/ - if (result == TCL_OK) { - *tcdp = tcd; - } else { - forwardCmdDeleteProc((ClientData)tcd); - } - return result; -} - -static XOTclClasses * -ComputePrecedenceList(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, - int withMixins, int withRootClass) { - XOTclClasses *precedenceList = NULL, *pcl, **npl = &precedenceList; - - if (withMixins) { - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - - if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = object->mixinOrder; - - while (ml) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (pattern) { - if (!Tcl_StringMatch(className(mixin), pattern)) continue; - } - npl = XOTclClassListAdd(npl, mixin, NULL); - ml = ml->nextPtr; - } - } - } - - pcl = ComputeOrder(object->cl, object->cl->order, Super); - for (; pcl; pcl = pcl->nextPtr) { - if (withRootClass == 0 && pcl->cl->object.flags & XOTCL_IS_ROOT_CLASS) - continue; - - if (pattern) { - if (!Tcl_StringMatch(className(pcl->cl), pattern)) continue; - } - npl = XOTclClassListAdd(npl, pcl->cl, NULL); - } - return precedenceList; -} - -static CONST char * -StripBodyPrefix(CONST char *body) { - if (strncmp(body, "::nsf::unsetUnknownArgs\n", 24) == 0) - body += 24; - return body; -} - - -static XOTclObjects * -computeSlotObjects(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, int withRootClass) { - XOTclObjects *slotObjects = NULL, **npl = &slotObjects; - XOTclClasses *pl, *fullPrecendenceList; - XOTclObject *childObject, *tmpObject; - Tcl_HashTable slotTable; - - assert(object); - - Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", slotTable); - - fullPrecendenceList = ComputePrecedenceList(interp, object, NULL /* pattern*/, 1, withRootClass); - for (pl=fullPrecendenceList; pl; pl = pl->nextPtr) { - Tcl_DString ds, *dsPtr = &ds; - - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(pl->cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - tmpObject = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (tmpObject) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr, *slotEntry; - Tcl_HashTable *cmdTable; - Tcl_Command cmd; - int new; - - if (!tmpObject->nsPtr) continue; - cmdTable = Tcl_Namespace_cmdTable(tmpObject->nsPtr); - - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - for (; hPtr; 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); - childObject = XOTclGetObjectFromCmdPtr(cmd); - /*fprintf(stderr, "we have true child obj %s\n", objectName(childObject));*/ - npl = XOTclObjectListAdd(npl, childObject); - } - } - DSTRING_FREE(dsPtr); - } - - Tcl_DeleteHashTable(&slotTable); - MEM_COUNT_FREE("Tcl_InitHashTable", slotTable); - - XOTclClassListFree(fullPrecendenceList); - - return slotObjects; -} - -static XOTclClass* -FindCalledClass(Tcl_Interp *interp, XOTclObject *object) { - XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); - CONST char *methodName; - Tcl_Command cmd; - - if (cscPtr->frameType == XOTCL_CSC_TYPE_PLAIN) - return cscPtr->cl; - - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) - methodName = ObjStr(cscPtr->filterStackEntry->calledProc); - else if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && object->mixinStack) - methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); - else - return NULL; - - if (object->nsPtr) { - cmd = FindMethod(object->nsPtr, methodName); - if (cmd) { - /* we called an object specific method */ - return NULL; - } - } - - return SearchCMethod(object->cl, methodName, &cmd); -} - -/* - * Next Primitive Handling - */ -XOTCLINLINE static int -NextSearchMethod(XOTclObject *object, Tcl_Interp *interp, XOTclCallStackContent *cscPtr, - XOTclClass **cl, CONST char **methodName, Tcl_Command *cmd, - int *isMixinEntry, int *isFilterEntry, - int *endOfFilterChain, Tcl_Command *currentCmd) { - int endOfChain = 0, objflags; - - /* - * Next in filters - */ - - objflags = object->flags; /* avoid stalling */ - if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) { - MixinComputeDefined(interp, object); - objflags = object->flags; /* avoid stalling */ - } - - if ((objflags & XOTCL_FILTER_ORDER_VALID) && - object->filterStack && - object->filterStack->currentCmdPtr) { - *cmd = FilterSearchProc(interp, object, currentCmd, cl); - /*fprintf(stderr, "EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ - /* XOTclCallStackDump(interp); XOTclStackDump(interp);*/ - - if (*cmd == 0) { - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - /* reset the information to the values of method, cl - to the values they had before calling the filters */ - *methodName = ObjStr(object->filterStack->calledProc); - endOfChain = 1; - *endOfFilterChain = 1; - *cl = 0; - /*fprintf(stderr, "EndOfChain resetting cl\n");*/ - } - } else { - *methodName = (char *) Tcl_GetCommandName(interp, *cmd); - *endOfFilterChain = 0; - *isFilterEntry = 1; - return TCL_OK; - } - } - - /* - * Next in Mixins - */ - assert(objflags & XOTCL_MIXIN_ORDER_VALID); - /* otherwise: MixinComputeDefined(interp, object); */ - - /*fprintf(stderr, "nextsearch: mixinorder valid %d stack=%p\n", - obj->flags & XOTCL_MIXIN_ORDER_VALID, obj->mixinStack);*/ - - if ((objflags & XOTCL_MIXIN_ORDER_VALID) && object->mixinStack) { - int result = MixinSearchProc(interp, object, *methodName, cl, currentCmd, cmd); - if (result != TCL_OK) { - return result; - } - /*fprintf(stderr, "nextsearch: mixinsearch cmd %p, currentCmd %p\n",*cmd, *currentCmd);*/ - if (*cmd == 0) { - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) { - endOfChain = 1; - *cl = 0; - } - } else { - *isMixinEntry = 1; - return TCL_OK; - } - } - - /* - * 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 a mixin or filter chain has ended -> we have to search - the obj-specific methods as well */ - - if (object->nsPtr && endOfChain) { - *cmd = FindMethod(object->nsPtr, *methodName); - } else { - *cmd = NULL; - } - - - if (!*cmd) { - XOTclClasses *pl; -#if 0 - /* a more explicit version, but slower */ - pl = ComputeOrder(object->cl, object->cl->order, Super); - /* if we have a class, skip to the next class in the precedence order */ - if (*cl) { - for (; pl; pl = pl->nextPtr) { - if (pl->cl == *cl) { - pl = pl->nextPtr; - break; - } - } - } -#else - for (pl = ComputeOrder(object->cl, object->cl->order, Super); *cl && pl; pl = pl->nextPtr) { - if (pl->cl == *cl) { - *cl = NULL; - } - } -#endif - - /* - * search for a further class method - */ - *cl = SearchPLMethod(pl, *methodName, cmd); - /*fprintf(stderr, "no cmd, cl = %p %s\n",*cl, className((*cl)));*/ - } else { - *cl = 0; - } - - return TCL_OK; -} - -static int -XOTclNextMethod(XOTclObject *object, Tcl_Interp *interp, XOTclClass *givenCl, - CONST char *givenMethodName, int objc, Tcl_Obj *CONST objv[], - int useCallstackObjs, XOTclCallStackContent *cscPtr) { - Tcl_Command cmd, currentCmd = NULL; - int result, frameType = XOTCL_CSC_TYPE_PLAIN, - isMixinEntry = 0, isFilterEntry = 0, - endOfFilterChain = 0, decrObjv0 = 0; - int nobjc; Tcl_Obj **nobjv; - XOTclClass **cl = &givenCl; - CONST char **methodName = &givenMethodName; - Tcl_CallFrame *framePtr; - - if (!cscPtr) { - cscPtr = CallStackGetTopFrame(interp, &framePtr); - } else { - /* - * cscPtr was given (i.e. it is not yet on the stack. So we cannot - * get objc from the associated stack frame - */ - framePtr = NULL; - assert(useCallstackObjs == 0); - /* fprintf(stderr, "XOTclNextMethod csc given, use %d, framePtr %p\n", useCallstackObjs, framePtr); */ - } - - /*fprintf(stderr, "XOTclNextMethod givenMethod = %s, csc = %p, useCallstackObj %d, objc %d cfp %p\n", - givenMethodName, cscPtr, useCallstackObjs, objc, framePtr);*/ - - /* if no args are given => use args from stack */ - if (objc < 2 && useCallstackObjs && framePtr) { - if (cscPtr->objv) { - nobjv = cscPtr->objv; - nobjc = cscPtr->objc; - } else { - nobjc = Tcl_CallFrame_objc(framePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(framePtr); - } - } 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 && framePtr) { - nobjv[0] = Tcl_CallFrame_objv(framePtr)[0]; - INCR_REF_COUNT(nobjv[0]); /* we seem to need this here */ - decrObjv0 = 1; - } - } - - /* - * Search the next method & compute its method data - */ - result = NextSearchMethod(object, interp, cscPtr, cl, methodName, &cmd, - &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - if (result != TCL_OK) { - return result; - } - - /* - fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", - *methodName, endOfFilterChain); - - if (obj) - fprintf(stderr, " obj=%s,", objectName(object)); - if ((*cl)) - fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName); - fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n", - isMixinEntry, isFilterEntry, proc); - */ -#if 0 - Tcl_ResetResult(interp); /* needed for bytecode support */ -#endif - if (cmd) { - /* - * change mixin state - */ - if (object->mixinStack) { - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) - cscPtr->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN; - - /* otherwise move the command pointer forward */ - if (isMixinEntry) { - frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - object->mixinStack->currentCmdPtr = currentCmd; - } - } - /* - * change filter state - */ - if (object->filterStack) { - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - /*fprintf(stderr, "next changes filter state\n");*/ - cscPtr->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; - object->filterStack->currentCmdPtr = currentCmd; - } - } - - /* - * now actually call the "next" method - */ - - /* cut the flag, that no stdargs should be used, if it is there */ - if (nobjc > 1) { - CONST char *nobjv1 = ObjStr(nobjv[1]); - if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs")) - nobjc = 1; - } - cscPtr->callType |= XOTCL_CSC_CALL_IS_NEXT; - RUNTIME_STATE(interp)->unknown = 0; - /*fprintf(stderr, "setting unknown to 0\n");*/ - result = MethodDispatch((ClientData)object, interp, nobjc, nobjv, cmd, - object, *cl, *methodName, frameType); - cscPtr->callType &= ~XOTCL_CSC_CALL_IS_NEXT; - - if (cscPtr->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER) - cscPtr->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - else if (cscPtr->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN) - cscPtr->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; -} - -int -XOTclNextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); - - if (!cscPtr) - return XOTclVarErrMsg(interp, "next: can't find self", (char *) NULL); - - if (!cscPtr->cmdPtr) - return XOTclErrMsg(interp, "next: no executing proc", TCL_STATIC); - - return XOTclNextMethod(cscPtr->self, interp, cscPtr->cl, - (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr), - objc, objv, 1, NULL); -} - - -/* - * "self" object command - */ - -static int -FindSelfNext(Tcl_Interp *interp) { - XOTclCallStackContent *cscPtr = CallStackGetTopFrame(interp, NULL); - Tcl_Command cmd, currentCmd = 0; - int result, isMixinEntry = 0, - isFilterEntry = 0, - endOfFilterChain = 0; - XOTclClass *cl = cscPtr->cl; - XOTclObject *object = cscPtr->self; - CONST char *methodName; - - Tcl_ResetResult(interp); - - methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); - if (!methodName) { - return TCL_OK; - } - - result = NextSearchMethod(object, interp, cscPtr, &cl, &methodName, &cmd, - &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - if (cmd) { - Tcl_SetObjResult(interp, MethodHandleObj(cl ? (XOTclObject*)cl : object, - cl == NULL, methodName)); - } - return result; -} - -static Tcl_Obj * -computeLevelObj(Tcl_Interp *interp, CallStackLevel level) { - Tcl_CallFrame *framePtr; - Tcl_Obj *resultObj; - - switch (level) { - case CALLING_LEVEL: XOTclCallStackFindLastInvocation(interp, 1, &framePtr); break; - case ACTIVE_LEVEL: XOTclCallStackFindActiveFrame(interp, 1, &framePtr); break; - default: framePtr = NULL; - } - - if (framePtr) { - /* the call was from an xotcl frame, return absolute frame number */ - char buffer[LONG_AS_STRING]; - int l; - - buffer[0] = '#'; - XOTcl_ltoa(buffer+1, (long)Tcl_CallFrame_level(framePtr), &l); - /*fprintf(stderr, "*** framePtr=%p buffer %s\n", framePtr, buffer);*/ - resultObj = Tcl_NewStringObj(buffer, l+1); - } else { - /* If not called from an xotcl frame, return 1 as default */ - resultObj = Tcl_NewIntObj(1); - } - - return resultObj; -} - -/* - int - 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); - - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } -*/ - -/* - * object creation & destruction - */ - -static int -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(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); - } - - 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 *interp, XOTclObject *object) { - int result = TCL_OK; - if (object->opt && object->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);*/ - - result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, 0); - if (result != TCL_OK) { - int result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY); - if (result != TCL_OK) { - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (unsetInAllNamespaces(interp, nsPtr, object->opt->volatileVarName) == 0) { - fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n", - object->opt->volatileVarName); - } - } - } - if (result == TCL_OK) { - /*fprintf(stderr, "### success unset\n");*/ - } - } - return result; -} - -static char * -XOTclUnsetTrace(ClientData clientData, Tcl_Interp *interp, CONST char *name, CONST char *name2, int flags) -{ - Tcl_Obj *obj = (Tcl_Obj *)clientData; - XOTclObject *object; - char *resultMsg = NULL; - - /*fprintf(stderr, "XOTclUnsetTrace %s flags %.4x %.4x\n", name, flags, - flags & TCL_INTERP_DESTROYED); */ - - if ((flags & TCL_INTERP_DESTROYED) == 0) { - if (GetObjectFromObj(interp, obj, &object) == TCL_OK) { - Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ - INCR_REF_COUNT(res); - - /* clear variable, destroy is called from trace */ - if (object->opt && object->opt->volatileVarName) { - object->opt->volatileVarName = NULL; - } - - if (callDestroyMethod(interp, object, 0) != TCL_OK) { - resultMsg = "Destroy for volatile object failed"; - } else - resultMsg = "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);*/ - } - return resultMsg; -} - -/* - * bring an object into a state, as after initialization - */ -static void -CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *object, int softrecreate) { - /*fprintf(stderr, "CleanupDestroyObject obj %p softrecreate %d nsPtr %p\n", - object, softrecreate, object->nsPtr);*/ - - /* remove the instance, but not for ::Class/::Object */ - if ((object->flags & XOTCL_IS_ROOT_CLASS) == 0 && - (object->flags & XOTCL_IS_ROOT_META_CLASS) == 0 ) { - - if (!softrecreate) { - (void)RemoveInstance(object, object->cl); - } - } - - if (object->nsPtr) { - NSCleanupNamespace(interp, object->nsPtr); - NSDeleteChildren(interp, object->nsPtr); - } - - if (object->varTable) { - TclDeleteVars(((Interp *)interp), object->varTable); - - ckfree((char *)object->varTable); - /*FREE(obj->varTable, obj->varTable);*/ - object->varTable = 0; - } - - if (object->opt) { - XOTclObjectOpt *opt = object->opt; - AssertionRemoveStore(opt->assertions); - opt->assertions = NULL; - -#ifdef XOTCL_METADATA - XOTclMetaDataDestroy(object); -#endif - - if (!softrecreate) { - /* - * Remove this object from all per object mixin lists and clear the mixin list - */ - removeFromObjectMixinsOf(object->id, opt->mixins); - - CmdListRemoveList(&opt->mixins, GuardDel); - CmdListRemoveList(&opt->filters, GuardDel); - FREE(XOTclObjectOpt, opt); - opt = object->opt = 0; - } - } - - object->flags &= ~XOTCL_MIXIN_ORDER_VALID; - if (object->mixinOrder) MixinResetOrder(object); - object->flags &= ~XOTCL_FILTER_ORDER_VALID; - if (object->filterOrder) FilterResetOrder(object); -} - -/* - * do obj initialization & namespace creation - */ -static void -CleanupInitObject(Tcl_Interp *interp, XOTclObject *object, - XOTclClass *cl, Tcl_Namespace *nsPtr, int softrecreate) { - -#ifdef OBJDELETION_TRACE - fprintf(stderr, "+++ CleanupInitObject\n"); -#endif - object->teardown = interp; - object->nsPtr = nsPtr; - if (!softrecreate) { - AddInstance(object, cl); - } - if (object->flags & XOTCL_RECREATE) { - object->opt = 0; - object->varTable = 0; - object->mixinOrder = 0; - object->filterOrder = 0; - object->flags = 0; - } - /* - fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", - obj->cmdName ? objectName(object) : "", object, object->cl);*/ -} - -static void -PrimitiveDestroy(ClientData clientData) { - XOTclObject *object = (XOTclObject*)clientData; - - if (XOTclObjectIsClass(object)) - PrimitiveCDestroy((ClientData) object); - else - PrimitiveODestroy((ClientData) object); -} - -static void -tclDeletesObject(ClientData clientData) { - XOTclObject *object = (XOTclObject*)clientData; - Tcl_Interp *interp; - - object->flags |= XOTCL_TCL_DELETE; - /*fprintf(stderr, "cmd dealloc %p tclDeletesObject (2d)\n", object->id, Tcl_Command_refCount(object->id)); - */ - -#ifdef OBJDELETION_TRACE - fprintf(stderr, "tclDeletesObject %p obj->id %p flags %.6x\n", object, object->id, object->flags); -#endif - if ((object->flags & XOTCL_DURING_DELETE) || !object->teardown) return; - interp = object->teardown; -# ifdef OBJDELETION_TRACE - fprintf(stderr, "... %p %s\n", object, objectName(object)); -# endif - CallStackDestroyObject(interp, object); - /*fprintf(stderr, "tclDeletesObject %p DONE\n", object);*/ -} - -/* - * physical object destroy - */ -static void -PrimitiveODestroy(ClientData clientData) { - XOTclObject *object = (XOTclObject*)clientData; - Tcl_Interp *interp; - - if (!object || !object->teardown) return; - - /*fprintf(stderr, "****** PrimitiveODestroy %p flags %.6x\n", object, object->flags);*/ - assert(!(object->flags & XOTCL_DELETED)); - - /* destroy must have been called already */ - assert(object->flags & XOTCL_DESTROY_CALLED); - - /* - * check and latch against recurrent calls with object->teardown - */ - PRINTOBJ("PrimitiveODestroy", object); - interp = object->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; - -#ifdef OBJDELETION_TRACE - fprintf(stderr, " physical delete of %p id=%p destroyCalled=%d '%s'\n", - object, object->id, (object->flags & XOTCL_DESTROY_CALLED), objectName(object)); -#endif - CleanupDestroyObject(interp, object, 0); - - while (object->mixinStack) - MixinStackPop(object); - - while (object->filterStack) - FilterStackPop(object); - - object->teardown = NULL; - if (object->nsPtr) { - /*fprintf(stderr, "PrimitiveODestroy calls deleteNamespace for object %p nsPtr %p\n", object, object->nsPtr);*/ - XOTcl_DeleteNamespace(interp, object->nsPtr); - object->nsPtr = NULL; - } - - /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", objectName(object));*/ - - object->flags |= XOTCL_DELETED; - objTrace("ODestroy", object); - - DECR_REF_COUNT(object->cmdName); - XOTclCleanupObject(object); - -} - -/* - * reset the object to a fresh, undestroyed state - */ -static void -MarkUndestroyed(XOTclObject *object) { - object->flags &= ~XOTCL_DESTROY_CALLED; -} - -static void -PrimitiveOInit(void *mem, Tcl_Interp *interp, CONST char *name, XOTclClass *cl) { - XOTclObject *object = (XOTclObject*)mem; - Tcl_Namespace *nsPtr; - -#ifdef OBJDELETION_TRACE - fprintf(stderr, "+++ PrimitiveOInit\n"); -#endif - -#ifdef XOTCLOBJ_TRACE - fprintf(stderr, "OINIT %s = %p\n", name, object); -#endif - XOTclObjectRefCountIncr(object); - MarkUndestroyed(object); - - /* - * There might be already a namespace with name name; if this is the - * case, use this namepsace as object namespace. The preexisting - * namespace might contain XOTcl objects. If we would not use the - * namespace as child namespace, we would not recognize the objects - * as child objects, deletions of the object might lead to a crash. - */ - - nsPtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); - /*fprintf(stderr, "PrimitiveOInit %p %s, ns %p\n", object, name, nsPtr); */ - - CleanupInitObject(interp, object, cl, nsPtr, 0); - - /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/ - object->mixinStack = NULL; - object->filterStack = NULL; -} - -/* - * Object creation: create object name (full name) and Tcl command - */ -static XOTclObject* -PrimitiveOCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTclClass *cl) { - XOTclObject *object = (XOTclObject*)ckalloc(sizeof(XOTclObject)); - CONST char *nameString = ObjStr(nameObj); - size_t length; - -#if defined(XOTCLOBJ_TRACE) - fprintf(stderr, "CKALLOC Object %p %s\n", object, nameString); -#endif -#ifdef OBJDELETION_TRACE - fprintf(stderr, "+++ PrimitiveOCreate\n"); -#endif - - memset(object, 0, sizeof(XOTclObject)); - MEM_COUNT_ALLOC("XOTclObject/XOTclClass", object); - assert(object); /* ckalloc panics, if malloc fails */ - assert(isAbsolutePath(nameString)); - length = strlen(nameString); - if (!NSCheckForParent(interp, nameString, length, cl)) { - ckfree((char *) object); - return NULL; - } - - object->id = Tcl_CreateObjCommand(interp, nameString, XOTclObjDispatch, - (ClientData)object, tclDeletesObject); - /*fprintf(stderr, "cmd alloc %p %d (%s)\n", object->id, Tcl_Command_refCount(object->id), nameString);*/ - - PrimitiveOInit(object, interp, nameString, cl); - object->cmdName = nameObj; - /* convert cmdName to Tcl Obj of type cmdName */ - /*Tcl_GetCommandFromObj(interp, obj->cmdName);*/ - - INCR_REF_COUNT(object->cmdName); - objTrace("PrimitiveOCreate", object); - - return object; -} - -static XOTclClass * -DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *mcl, int isMeta) { - XOTclClass *defaultClass = NULL; - - /*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s, isMeta %d\n", - className(cl), className(mcl), isMeta );*/ - - if (mcl) { - int result; - result = setInstVar(interp, (XOTclObject *)mcl, isMeta ? - XOTclGlobalObjs[XOTE_DEFAULTMETACLASS] : - XOTclGlobalObjs[XOTE_DEFAULTSUPERCLASS], NULL); - - if (result == TCL_OK) { - Tcl_Obj *nameObj = Tcl_GetObjResult(interp); - if (GetClassFromObj(interp, nameObj, &defaultClass, NULL) != TCL_OK) { - XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); - } - /*fprintf(stderr, "DefaultSuperClass for %s got from var %s\n", className(cl), ObjStr(nameObj));*/ - - } else { - XOTclClass *result; - XOTclClasses *sc; - - /*fprintf(stderr, "DefaultSuperClass for %s: search in superclasses starting with %p meta %d\n", - className(cl), cl->super, isMeta);*/ - - /* - * check superclasses of metaclass - */ - if (isMeta) { - /*fprintf(stderr, " ... is %s already root meta %d\n", - className(mcl->object.cl), - mcl->object.cl->object.flags & XOTCL_IS_ROOT_META_CLASS);*/ - if (mcl->object.cl->object.flags & XOTCL_IS_ROOT_META_CLASS) { - return mcl->object.cl; - } - } - for (sc = mcl->super; sc && sc->cl != cl; sc = sc->nextPtr) { - /*fprintf(stderr, " ... check ismeta %d %s root mcl %d root cl %d\n", - isMeta, className(sc->cl), - sc->cl->object.flags & XOTCL_IS_ROOT_META_CLASS, - sc->cl->object.flags & XOTCL_IS_ROOT_CLASS);*/ - if (isMeta) { - if (sc->cl->object.flags & XOTCL_IS_ROOT_META_CLASS) { - return sc->cl; - } - } else { - if (sc->cl->object.flags & XOTCL_IS_ROOT_CLASS) { - /*fprintf(stderr, "found root class %p\n", sc->cl);*/ - return sc->cl; - } - } - result = DefaultSuperClass(interp, cl, sc->cl, isMeta); - if (result) { - return result; - } - } - } - } else { - /* during bootstrapping, there might be no meta class defined yet */ - /*fprintf(stderr, "no meta class ismeta %d %s root mcl %d root cl %d\n", - isMeta, className(cl), - cl->object.flags & XOTCL_IS_ROOT_META_CLASS, - cl->object.flags & XOTCL_IS_ROOT_CLASS - );*/ - return NULL; - } - 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, int recreate) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - XOTclClassOpt *clopt = cl->opt; - XOTclClass *baseClass = NULL; - - PRINTOBJ("CleanupDestroyClass", (XOTclObject *)cl); - assert(softrecreate ? recreate == 1 : 1); - - /* fprintf(stderr, "CleanupDestroyClass %p %s (ismeta=%d) softrecreate=%d, recreate=%d, %p\n", cl,className(cl),IsMetaClass(interp, cl, 1), - softrecreate, recreate, clopt);*/ - - /* - * Perform the next steps even with clopt == NULL, since the class - * might be used as a superclass of a per object mixin, so it might - * have no clopt... - */ - MixinInvalidateObjOrders(interp, cl); - FilterInvalidateObjOrders(interp, cl); - - if (clopt) { - /* - * Remove this class from all isClassMixinOf lists and clear the - * class mixin list - */ - RemoveFromClassMixinsOf(clopt->id, clopt->classmixins); - - CmdListRemoveList(&clopt->classmixins, GuardDel); - /*MixinInvalidateObjOrders(interp, cl);*/ - - CmdListRemoveList(&clopt->classfilters, GuardDel); - /*FilterInvalidateObjOrders(interp, cl);*/ - - 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 class mixin lists and clear the - * isClassMixinOf list - */ - RemoveFromClassmixins(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); -#endif - } - - NSCleanupNamespace(interp, cl->nsPtr); - NSDeleteChildren(interp, cl->nsPtr); - - /*fprintf(stderr, " CleanupDestroyClass softrecreate %d\n", softrecreate);*/ - - if (!softrecreate) { - - /* - * Reclass all instances of the current class the the appropriate - * most general class ("baseClass"). The most general class of a - * metaclass is the root meta class, the most general class of an - * object is the root class. Instances of metaclasses can be only - * reset to the root meta class (and not to to the root base - * class). - */ - - baseClass = DefaultSuperClass(interp, cl, cl->object.cl, - IsMetaClass(interp, cl, 1)); - /* - * We do not have to reclassing in case, cl is a root class - */ - if ((cl->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { - - hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); - /*fprintf(stderr, " inst %p %s flags %.6x id %p baseClass %p %s\n", - inst, objectName(inst), inst->flags, inst->id,baseClass,className(baseClass));*/ - if (inst && inst != (XOTclObject*)cl && !(inst->flags & XOTCL_DURING_DELETE) /*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); - } - - if ((clopt) && (!recreate)) { - FREE(XOTclClassOpt, clopt); - clopt = cl->opt = 0; - } - - /* - * 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->object.flags & XOTCL_IS_ROOT_CLASS) == 0) { - /* fprintf(stderr,"subClass %p %s baseClass %p %s\n", - cl,className(cl),baseClass,className(baseClass)); */ - AddSuper(subClass, baseClass); - } - } - /*(void)RemoveSuper(cl, cl->super->cl);*/ - } - -} - -/* - * do class initialization & namespace creation - */ -static void -CleanupInitClass(Tcl_Interp *interp, XOTclClass *cl, Tcl_Namespace *nsPtr, - int softrecreate, int recreate) { - XOTclClass *defaultSuperclass; - - assert(softrecreate ? recreate == 1 : 1); - -#ifdef OBJDELETION_TRACE - 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((XOTclObject*)cl); - - cl->nsPtr = nsPtr; - - 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, 0); - if (cl != defaultSuperclass) { - AddSuper(cl, defaultSuperclass); - } - - cl->color = WHITE; - cl->order = NULL; - - if (!softrecreate) { - Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable", &cl->instances); - } - - if (!recreate) { - cl->opt = NULL; - } -} - -/* - * class physical destruction - */ -static void -PrimitiveCDestroy(ClientData clientData) { - XOTclClass *cl = (XOTclClass*)clientData; - XOTclObject *object = (XOTclObject*)clientData; - Tcl_Interp *interp; - Tcl_Namespace *saved; - - PRINTOBJ("PrimitiveCDestroy", object); - - /* - * check and latch against recurrent calls with obj->teardown - */ - if (!object || !object->teardown) return; - interp = object->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; - - /* - * call and latch user destroy with object->id if we haven't - */ - /*fprintf(stderr, "PrimitiveCDestroy %s flags %.6x\n", objectName(object), object->flags);*/ - - object->teardown = NULL; - CleanupDestroyClass(interp, cl, 0, 0); - - /* - * handoff the primitive teardown - */ - - saved = cl->nsPtr; - object->teardown = interp; - - /* - * class object destroy + physical destroy - */ - /*fprintf(stderr, "primitive cdestroy %p %.6x calls primitive odestroy\n", cl, flags);*/ - PrimitiveODestroy(clientData); - - /*fprintf(stderr, "primitive cdestroy calls deletenamespace for obj %p, nsPtr %p flags %.6x\n", - cl, saved, ((Namespace *)saved)->flags);*/ - saved->clientData = NULL; - XOTcl_DeleteNamespace(interp, saved); - /*fprintf(stderr, "primitive cdestroy %p DONE\n",cl);*/ - return; -} - -/* - * class init - */ -static void -PrimitiveCInit(XOTclClass *cl, Tcl_Interp *interp, CONST char *name) { - Tcl_CallFrame frame, *framePtr = &frame; - Tcl_Namespace *nsPtr; - - /* - * 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; - } - nsPtr = NSGetFreshNamespace(interp, (ClientData)cl, name, 1); - Tcl_PopCallFrame(interp); - - CleanupInitClass(interp, cl, nsPtr, 0, 0); - return; -} - -/* - * class create: creation of namespace + class full name - * calls class object creation - */ -static XOTclClass* -PrimitiveCCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTclClass *class) { - XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass)); - CONST char *nameString = ObjStr(nameObj); - size_t length; - XOTclObject *object = (XOTclObject*)cl; - - /*fprintf(stderr, "CKALLOC Class %p %s\n", cl, nameString);*/ - - memset(cl, 0, sizeof(XOTclClass)); - MEM_COUNT_ALLOC("XOTclObject/XOTclClass", cl); - - /* pass object system from meta class */ - if (class) { - cl->osPtr = class->osPtr; - } - - assert(isAbsolutePath(nameString)); - length = strlen(nameString); - /* - fprintf(stderr, "Class alloc %p '%s'\n", cl, nameString); - */ - /* check whether Object parent NS already exists, - otherwise: error */ - if (!NSCheckForParent(interp, nameString, length, class)) { - ckfree((char *) cl); - return 0; - } - object->id = Tcl_CreateObjCommand(interp, nameString, XOTclObjDispatch, - (ClientData)cl, tclDeletesObject); - /*fprintf(stderr, "cmd alloc %p %d (%s) cl\n", object->id, Tcl_Command_refCount(object->id), nameString);*/ - - PrimitiveOInit(object, interp, nameString, class); - object->cmdName = nameObj; - - /* convert cmdName to Tcl Obj of type cmdName */ - /* Tcl_GetCommandFromObj(interp, obj->cmdName);*/ - - INCR_REF_COUNT(object->cmdName); - PrimitiveCInit(cl, interp, nameString+2); - - objTrace("PrimitiveCCreate", object); - return cl; -} - -/* change XOTcl class conditionally; obj must not be NULL */ - -XOTCLINLINE static int -changeClass(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl) { - assert(object); - - /*fprintf(stderr, "changing %s to class %s ismeta %d\n", - objectName(object), - className(cl), - IsMetaClass(interp, cl, 1));*/ - - if (cl != object->cl) { - if (IsMetaClass(interp, cl, 1)) { - /* 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, object->cl, 1)) { - 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 */ - - /*fprintf(stderr, "target class %s not a meta class, am i a class %d\n", - className(cl), - XOTclObjectIsClass(object) );*/ - - if (XOTclObjectIsClass(object)) { - return XOTclVarErrMsg(interp, "cannot turn class into an object ", - (char *) NULL); - } - } - (void)RemoveInstance(object, object->cl); - AddInstance(object, cl); - - MixinComputeDefined(interp, object); - FilterComputeDefined(interp, object); - } - return TCL_OK; -} - - -/* - * Std object initialization: - * call parameter default values - * apply "-" methods (call "configure" with given arguments) - * call constructor "init", if it was not called before - */ -static int -doObjInitialization(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj *methodObj, *savedObjResult = Tcl_GetObjResult(interp); /* save the result */ - int result; - - INCR_REF_COUNT(savedObjResult); - /* - * clear INIT_CALLED flag - */ - object->flags &= ~XOTCL_INIT_CALLED; - - /* - * call configure methods (starting with '-') - */ - if (CallDirectly(interp, object, XO_o_configure_idx, &methodObj)) { - ALLOC_ON_STACK(Tcl_Obj*, objc, tov); - memcpy(tov+1, objv+2, sizeof(Tcl_Obj *)*(objc-2)); - /* the provided name of the method is just for error reporting */ - tov[0] = methodObj ? methodObj : XOTclGlobalObjs[XOTE_CONFIGURE]; - result = XOTclOConfigureMethod(interp, object, objc-1, tov); - FREE_ON_STACK(Tcl_Obj*, tov); - } else { - result = callMethod((ClientData) object, interp, methodObj, objc, objv+2, 0); - } - - if (result != TCL_OK) { - goto objinitexit; - } - - /* - * check, whether init was called already - */ - if (!(object->flags & XOTCL_INIT_CALLED)) { - int nobjc = 0; - Tcl_Obj **nobjv, *resultObj = Tcl_GetObjResult(interp); - - /* - * Call the scripted constructor and pass the result of - * configure to it as arguments - */ - INCR_REF_COUNT(resultObj); - Tcl_ListObjGetElements(interp, resultObj, &nobjc, &nobjv); - /* CallDirectly does not make much sense, since init is already - defined in predefined */ - methodObj = XOTclMethodObj(interp, object, XO_o_init_idx); - if (methodObj) { - result = callMethod((ClientData) object, interp, methodObj, - nobjc+2, nobjv, XOTCL_CM_NO_PROTECT); - } - object->flags |= XOTCL_INIT_CALLED; - DECR_REF_COUNT(resultObj); - } - - if (result == TCL_OK) { - Tcl_SetObjResult(interp, savedObjResult); - } - objinitexit: - DECR_REF_COUNT(savedObjResult); - return result; -} - - -static int -hasMetaProperty(Tcl_Interp *interp, XOTclClass *cl) { - return cl->object.flags & XOTCL_IS_ROOT_META_CLASS; -} - -static int -IsBaseClass(XOTclClass *cl) { - return cl->object.flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS); -} - - -static int -IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins) { - /* check if class is a meta-class */ - XOTclClasses *pl, *checkList = NULL, *mixinClasses = NULL, *mc; - int hasMCM = 0; - - /* is the class the most general meta-class? */ - if (hasMetaProperty(interp, cl)) - return 1; - - /* is the class a subclass of a meta-class? */ - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - if (hasMetaProperty(interp, pl->cl)) - return 1; - } - - if (withMixins) { - /* has the class metaclass mixed in? */ - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { - XOTclClassOpt *clopt = pl->cl->opt; - if (clopt && clopt->classmixins) { - MixinComputeOrderFullList(interp, - &clopt->classmixins, - &mixinClasses, - &checkList, 0); - } - } - - for (mc=mixinClasses; mc; mc = mc->nextPtr) { - if (IsMetaClass(interp, mc->cl, 0)) { - hasMCM = 1; - break; - } - } - XOTclClassListFree(mixinClasses); - XOTclClassListFree(checkList); - /*fprintf(stderr, "has MC returns %d, mixinClasses = %p\n", - hasMCM, mixinClasses);*/ - } - - return hasMCM; -} - -static int -IsSubType(XOTclClass *subcl, XOTclClass *cl) { - 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; - } - } - } - return success; -} - -static int -HasMixin(Tcl_Interp *interp, XOTclObject *object, XOTclClass *cl) { - - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - - if ((object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - XOTclCmdList *ml; - for (ml = object->mixinOrder; ml; ml = ml->nextPtr) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin == cl) { - return 1; - } - } - } - return 0; -} - -extern int -XOTclCreateObject(Tcl_Interp *interp, Tcl_Obj *nameObj, XOTcl_Class *class) { - XOTclClass *cl = (XOTclClass*) class; - Tcl_Obj *methodObj; - int result; - - INCR_REF_COUNT(nameObj); - - if (CallDirectly(interp, &cl->object, XO_c_create_idx, &methodObj)) { - result = XOTclCCreateMethod(interp, cl, ObjStr(nameObj), 1, &nameObj); - } else { - result = XOTclCallMethodWithArgs((ClientData)cl, interp, methodObj, - nameObj, 1, 0, 0); - } - DECR_REF_COUNT(nameObj); - return result; -} - -extern int -XOTclCreate(Tcl_Interp *interp, XOTcl_Class *class, Tcl_Obj *nameObj, ClientData clientData, - int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = (XOTclClass *) class; - int result; - ALLOC_ON_STACK(Tcl_Obj *, objc+2, ov); - - INCR_REF_COUNT(nameObj); - - ov[0] = NULL; - ov[1] = nameObj; - if (objc>0) { - memcpy(ov+2, objv, sizeof(Tcl_Obj *)*objc); - } - result = XOTclCCreateMethod(interp, cl, ObjStr(nameObj), objc+2, ov); - - FREE_ON_STACK(Tcl_Obj*, ov); - DECR_REF_COUNT(nameObj); - - return result; -} - -int -XOTclDeleteObject(Tcl_Interp *interp, XOTcl_Object *object1) { - XOTclObject *object = (XOTclObject *) object1; - return callDestroyMethod(interp, object, 0); -} - -extern int -XOTclUnsetInstVar2(XOTcl_Object *object1, Tcl_Interp *interp, - CONST char *name1, CONST char *name2, - int flgs) { - XOTclObject *object = (XOTclObject *) object1; - int result; - Tcl_CallFrame frame, *framePtr = &frame; - - XOTcl_PushFrameObj(interp, object, framePtr); - if (object->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - result = Tcl_UnsetVar2(interp, name1, name2, flgs); - XOTcl_PopFrameObj(interp, framePtr); - return result; -} - -static int -GetInstVarIntoCurrentScope(Tcl_Interp *interp, const char *cmdName, XOTclObject *object, - Tcl_Obj *varName, Tcl_Obj *newName) { - Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; - int new = 0, flgs = TCL_LEAVE_ERR_MSG; - Tcl_CallFrame *varFramePtr; - Tcl_CallFrame frame, *framePtr = &frame; - char *varNameString; - - if (CheckVarName(interp, ObjStr(varName)) != TCL_OK) { - return TCL_ERROR; - } - - XOTcl_PushFrameObj(interp, object, framePtr); - if (object->nsPtr) { - flgs = flgs|TCL_NAMESPACE_ONLY; - } - - otherPtr = TclObjLookupVar(interp, varName, NULL, flgs, "define", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - XOTcl_PopFrameObj(interp, framePtr); - - if (otherPtr == NULL) { - return XOTclVarErrMsg(interp, "can't import variable ", ObjStr(varName), - " into method scope: can't find variable on ", objectName(object), - (char *) NULL); - } - - /* - * if newName == NULL -> there is no alias, use varName - * as target link name - */ - 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 instance variable ", ObjStr(varName), - " on ", objectName(object), - ": Variable cannot be an element in an array;", - " use e.g. an alias.", (char *) NULL); - } - - newName = varName; - } - varNameString = ObjStr(newName); - - - - 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 && (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_PROC)) { - varPtr = (Var *)CompiledLocalsLookup((CallFrame *)varFramePtr, varNameString); - - if (varPtr == NULL) { - /* look in frame's local var hashtable */ - TclVarHashTable *varTablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); - - if (varTablePtr == NULL) { - /* - * The variable table does not exist. This seems to be is the - * first access to a variable on this frame. We create the and - * initialize the variable hash table and update the object - */ - /*fprintf(stderr, "+++ create varTable in GetInstVarIntoCurrentScope\n");*/ - Tcl_CallFrame_varTablePtr(varFramePtr) = varTablePtr = VarHashTableCreate(); - } - varPtr = VarHashCreateVar(varTablePtr, 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; - } - - /*fprintf(stderr, "linkvar flags=%x\n", linkPtr->flags); - Tcl_Panic("new linkvar %s... When does this happen?", ObjStr(newName), 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)) { - TclCleanupVar(linkPtr, (Var *) NULL); - } - - } else if (!TclIsVarUndefined(varPtr)) { - return XOTclVarErrMsg(interp, "variable '", varNameString, - "' exists already", (char *) NULL); - } else if (TclIsVarTraced(varPtr)) { - return XOTclVarErrMsg(interp, "variable '", varNameString, - "' has traces: can't use for instvar", (char *) NULL); - } - } - - TclSetVarLink(varPtr); - TclClearVarUndefined(varPtr); - varPtr->value.linkPtr = otherPtr; - VarHashRefCount(otherPtr)++; - - /* fprintf(stderr, "defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n", - ObjStr(newName), objectName(object), - 0, - varPtr->flags, - TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr)); - */ - } else { - return XOTclVarErrMsg(interp, cmdName, - " cannot import variable '", varNameString, - "' into method scope; not called from a method frame", (char *) NULL); - } - return TCL_OK; -} - -extern int -XOTclRemoveObjectMethod(Tcl_Interp *interp, XOTcl_Object *object1, CONST char *methodName) { - XOTclObject *object = (XOTclObject*) object1; - - AliasDelete(interp, object->cmdName, methodName, 1); - - if (object->opt) - AssertionRemoveProc(object->opt->assertions, methodName); - - if (object->nsPtr) { - int rc = NSDeleteCmd(interp, object->nsPtr, methodName); - if (rc < 0) - return XOTclVarErrMsg(interp, objectName(object), " cannot delete method '", methodName, - "' of object ", objectName(object), (char *) NULL); - } - return TCL_OK; -} - -extern int -XOTclRemoveClassMethod(Tcl_Interp *interp, XOTcl_Class *class, CONST char *methodName) { - XOTclClass *cl = (XOTclClass*) class; - XOTclClassOpt *opt = cl->opt; - int rc; - - AliasDelete(interp, class->object.cmdName, methodName, 0); - - if (opt && opt->assertions) - AssertionRemoveProc(opt->assertions, methodName); - - rc = NSDeleteCmd(interp, cl->nsPtr, methodName); - if (rc < 0) - return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", methodName, - "' of class ", className(cl), (char *) NULL); - return TCL_OK; -} - -/* - * obj/cl ClientData setter/getter - */ -extern void -XOTclSetObjClientData(XOTcl_Object *object1, ClientData data) { - XOTclObject *object = (XOTclObject*) object1; - XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); - opt->clientData = data; -} -extern ClientData -XOTclGetObjClientData(XOTcl_Object *object1) { - XOTclObject *object = (XOTclObject*) object1; - return (object && object->opt) ? object->opt->clientData : 0; -} -extern void -XOTclSetClassClientData(XOTcl_Class *cli, 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; -} - -static int -setInstVar(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj) { - Tcl_Obj *result; - int flags = (object->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; - Tcl_CallFrame frame, *framePtr = &frame; - XOTcl_PushFrameObj(interp, object, framePtr); - - if (valueObj == NULL) { - result = Tcl_ObjGetVar2(interp, nameObj, NULL, flags); - } else { - /*fprintf(stderr, "setvar in obj %s: name %s = %s\n", objectName(object), ObjStr(nameObj), ObjStr(value));*/ - result = Tcl_ObjSetVar2(interp, nameObj, NULL, valueObj, flags); - } - XOTcl_PopFrameObj(interp, framePtr); - - if (result) { - Tcl_SetObjResult(interp, result); - return TCL_OK; - } - return TCL_ERROR; -} - -static int -XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - SetterCmdClientData *cd = (SetterCmdClientData*)clientData; - XOTclObject *object = cd->object; - - if (!object) return XOTclObjErrType(interp, objv[0], "object", ObjStr(objv[0])); - if (objc > 2) return XOTclObjErrArgCnt(interp, object->cmdName, objv[0], "?value?"); - - if (cd->paramsPtr && objc == 2) { - Tcl_Obj *outObjPtr; - int result, flags = 0; - ClientData checkedData; - - result = ArgumentCheck(interp, objv[1], cd->paramsPtr, - RUNTIME_STATE(interp)->doCheckArguments, - &flags, &checkedData, &outObjPtr); - - if (result == TCL_OK) { - result = setInstVar(interp, object, objv[0], outObjPtr); - - if (flags & XOTCL_PC_MUST_DECR) { - DECR_REF_COUNT(outObjPtr); - } - } - return result; - - } else { - return setInstVar(interp, object, objv[0], objc == 2 ? objv[1] : NULL); - } -} - -static int -forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - Tcl_Obj *forwardArgObj, ForwardCmdClientData *tcd, Tcl_Obj **out, - Tcl_Obj **freeList, int *inputArg, int *mapvalue, - int firstPosArg, int *outputincr) { - CONST char *forwardArgString = ObjStr(forwardArgObj), *p; - int totalargs = objc + tcd->nr_args - 1; - char c = *forwardArgString, c1; - - /* per default every forwardArgString from the processed list corresponds to exactly - one forwardArgString in the computed final list */ - *outputincr = 1; - p = forwardArgString; - - /*fprintf(stderr, "ForwardArg: processing '%s'\n", forwardArgString);*/ - - if (c == '%' && *(forwardArgString+1) == '@') { - char *remainder = NULL; - long pos; - forwardArgString += 2; - pos = strtol(forwardArgString, &remainder, 0); - /*fprintf(stderr, "strtol('%s) returned %ld '%s'\n", forwardArgString, pos, remainder);*/ - if (forwardArgString == remainder && *forwardArgString == 'e' - && !strncmp(forwardArgString, "end", 3)) { - pos = -1; - remainder += 3; - } else if (pos < 0) { - pos --; - } - if (forwardArgString == remainder || abs(pos) > totalargs) { - return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", - ObjStr(forwardArgObj), (char *) NULL); - } if (!remainder || *remainder != ' ') { - return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(forwardArgObj), - "' use: %@ ", (char *) NULL); - } - - forwardArgString = ++remainder; - /* in case we address from the end, we reduct further to distinguish from -1 (void) */ - if (pos<0) pos--; - /*fprintf(stderr, "remainder = '%s' pos = %ld\n", remainder, pos);*/ - *mapvalue = pos; - forwardArgString = remainder; - c = *forwardArgString; - } - - if (c == '%') { - Tcl_Obj *list = NULL, **listElements; - int nrArgs = objc-1, nrPosArgs = objc-firstPosArg, nrElements = 0; - char *firstActualArgument = nrArgs>0 ? ObjStr(objv[1]) : NULL; - c = *++forwardArgString; - c1 = *(forwardArgString+1); - - if (c == 's' && !strcmp(forwardArgString, "self")) { - *out = tcd->object->cmdName; - } else if (c == 'p' && !strcmp(forwardArgString, "proc")) { - CONST char *methodName = ObjStr(objv[0]); - /* if we dispatch a method via ".", we do not want to see the - "." in the %proc, e.g. for the interceptor slots (such as - .mixin, ... */ - if (FOR_COLON_RESOLVER(methodName)) { - *out = Tcl_NewStringObj(methodName + 1, -1); - } else { - *out = objv[0]; - } - } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { - - if (c1 != '\0') { - if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %1 must be followed by a valid list, given: '", - ObjStr(forwardArgObj), "'", (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); - } - } - /*fprintf(stderr, "nrElements=%d, nra=%d firstPos %d objc %d\n", - nrElements, nrArgs, firstPosArg, objc);*/ - - if (nrElements > nrPosArgs) { - /* insert default subcommand depending on number of arguments */ - /*fprintf(stderr, "inserting listElements[%d] '%s'\n", nrPosArgs, - ObjStr(listElements[nrPosArgs]));*/ - *out = listElements[nrPosArgs]; - } else if (objc<=1) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, "option"); - } else { - /*fprintf(stderr, "copying %%1: '%s'\n", ObjStr(objv[firstPosArg]));*/ - *out = objv[firstPosArg]; - *inputArg = firstPosArg+1; - } - } else if (c == '-') { - CONST char *firstElementString; - int i, insertRequired, done = 0; - - /*fprintf(stderr, "process flag '%s'\n", firstActualArgument);*/ - if (Tcl_ListObjGetElements(interp, forwardArgObj, &nrElements, &listElements) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: '", forwardArgString, "' is not a valid list", - (char *) NULL); - } - if (nrElements < 1 || nrElements > 2) { - return XOTclVarErrMsg(interp, "forward: '", forwardArgString, - "' must contain 1 or 2 arguments", - (char *) NULL); - } - firstElementString = ObjStr(listElements[0]); - firstElementString++; /* we skip the dash */ - - if (firstActualArgument && *firstActualArgument == '-') { - /*fprintf(stderr, "we have a flag in first argument '%s'\n", firstActualArgument);*/ - - for (i = 1; i < firstPosArg; i++) { - if (strcmp(firstElementString, ObjStr(objv[i])) == 0) { - /*fprintf(stderr, "We have a MATCH for '%s' oldInputArg %d\n", forwardArgString, *inputArg);*/ - *out = objv[i]; - /* %1 will start at a different place. Proceed if necessary to firstPosArg */ - if (*inputArg < firstPosArg) { - *inputArg = firstPosArg; - } - done = 1; - break; - } - } - } - - if (!done) { - /* We have a flag in the actual arguments that does not match. - * We proceed to the actual arguments without dashes. - */ - if (*inputArg < firstPosArg) { - *inputArg = firstPosArg; - } - /* - * If the user requested we output the argument also when not - * given in the argument list. - */ - if (nrElements == 2 - && Tcl_GetIntFromObj(interp, listElements[1], &insertRequired) == TCL_OK - && insertRequired) { - /* no match, but insert of flag is required */ - /*fprintf(stderr, "no match, but insert of %s required\n", firstElementString);*/ - *out = Tcl_NewStringObj(firstElementString, -1); - *outputincr = 1; - goto add_to_freelist; - } else { - /* no match, no insert of flag required, we skip the - * forwarder option and output nothing - */ - /*fprintf(stderr, "no match, nrElements %d insert req %d\n", nrElements, insertRequired);*/ - *outputincr = 0; - } - } - - } else if (c == 'a' && !strncmp(forwardArgString, "argcl", 4)) { - if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '", - forwardArgString, "'", (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 ", - forwardArgString, (char *) NULL); - } - *out = listElements[nrArgs]; - } else if (c == '%') { - Tcl_Obj *newarg = Tcl_NewStringObj(forwardArgString, -1); - *out = newarg; - goto add_to_freelist; - } else { - /* evaluating given command */ - int result; - /*fprintf(stderr, "evaluating '%s'\n", forwardArgString);*/ - if ((result = Tcl_EvalEx(interp, forwardArgString, -1, 0)) != TCL_OK) - return result; - *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); - /*fprintf(stderr, "result = '%s'\n", ObjStr(*out));*/ - goto add_to_freelist; - } - } else { - if (p == forwardArgString) - *out = forwardArgObj; - else { - Tcl_Obj *newarg = Tcl_NewStringObj(forwardArgString, -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; -} - - -static int -callForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - ClientData clientData; - int result; - XOTclObject *object = tcd->object; - Tcl_CallFrame frame, *framePtr = &frame; - - if (tcd->verbose) { - Tcl_Obj *cmd = Tcl_NewListObj(objc, objv); - fprintf(stderr, "forwarder calls '%s'\n", ObjStr(cmd)); - DECR_REF_COUNT(cmd); - } - if (tcd->objscope) { - XOTcl_PushFrameObj(interp, object, framePtr); - } - if (tcd->objProc) { -#if 1 || !defined(NRE) - result = (*tcd->objProc)(tcd->clientData, interp, objc, objv); -#else - result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv); -#endif - } else if (IsXOTclTclObj(interp, tcd->cmdName, (XOTclObject**)&clientData)) { - /*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_PopFrameObj(interp, framePtr); - } - 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->object) return XOTclObjErrType(interp, objv[0], "object", ""); - - 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); - } 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(Tcl_Obj *, ov); - return result; - } else { - Tcl_Obj **ov, *freeList=NULL; - int outputincr, firstPosArg=1, totalargs = objc + tcd->nr_args + 3; - ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV); - ALLOC_ON_STACK(int, totalargs, objvmap); - /*fprintf(stderr, "+++ forwardMethod standard case, allocated %d args\n", totalargs);*/ - - ov = &OV[1]; - if (tcd->needobjmap) { - memset(objvmap, -1, sizeof(int)*totalargs); - } - - /* the first argument is always the command, to which we forward */ - if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd, - &ov[outputArg], &freeList, &inputArg, - &objvmap[outputArg], - firstPosArg, &outputincr)) != TCL_OK) { - goto exitforwardmethod; - } - outputArg += outputincr; - - /* if we have nonpos args, determine the first pos arg position for %1 */ - if (tcd->hasNonposArgs) { - firstPosArg = objc; - for (j=outputArg; jargs) { - /* 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 (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);*/ - } - if (tcd->needobjmap) { - /* we have to set the adressing relative from the end; -2 means - last, -3 element before last, etc. */ - int max = objc + tcd->nr_args - inputArg; - 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 0 - for(j=0; jcmdName; - result = callForwarder(tcd, interp, objc, ov); - - if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} - exitforwardmethod: - if (freeList) {DECR_REF_COUNT(freeList);} - FREE_ON_STACK(int,objvmap); - FREE_ON_STACK(Tcl_Obj*,OV); - } - return result; -} - -/* - * copied from Tcl, since not exported - */ -static char * -VwaitVarProc( - ClientData clientData, /* Pointer to integer to set to 1. */ - Tcl_Interp *interp, /* Interpreter containing variable. */ - char *name1, /* Name of variable. */ - char *name2, /* Second part of variable name. */ - int flags) /* Information about what happened. */ -{ - int *donePtr = (int *) clientData; - - *donePtr = 1; - return (char *) NULL; -} - -static int -XOTclProcAliasMethod(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) { - AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; - XOTclObject *self = GetSelfObj(interp); - CONST char *methodName = ObjStr(objv[0]); - - if (self == NULL) { - return XOTclVarErrMsg(interp, "no object active for alias '", - Tcl_GetCommandName(interp, tcd->aliasCmd), - "'; don't call aliased methods via namespace paths", - (char *) NULL); - } - return MethodDispatch((ClientData)self, interp, objc, objv, tcd->aliasedCmd, self, tcd->class, - methodName, 0); -} - -static int -XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; - XOTclObject *object = tcd->object; - Tcl_CallFrame frame, *framePtr = &frame; - int result; - - /*fprintf(stderr, "objscopedMethod obj=%p %s, ptr=%p\n", object, objectName(object), tcd->objProc);*/ - - XOTcl_PushFrameObj(interp, object, framePtr); - -#if !defined(NRE) - result = (*tcd->objProc)(tcd->clientData, interp, objc, objv); -#else - result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv); -#endif - - XOTcl_PopFrameObj(interp, framePtr); - return result; -} - -static void setterCmdDeleteProc(ClientData clientData) { - SetterCmdClientData *setterClientData = (SetterCmdClientData *)clientData; - - if (setterClientData->paramsPtr) { - ParamsFree(setterClientData->paramsPtr); - } - FREE(SetterCmdClientData, setterClientData); -} - -static void aliasCmdDeleteProc(ClientData clientData) { - AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; - ImportRef *refPtr, *prevPtr = NULL; - - /* - * Since we just get the clientData, we have to obtain interp, - * object, methodName and per-object from tcd; the obj might be - * deleted already. We need as well at least still the global - * namespace. - */ - if (tcd->interp && - ((Interp *)(tcd->interp))->globalNsPtr && - RUNTIME_STATE(tcd->interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { - CONST char *methodName = Tcl_GetCommandName(tcd->interp, tcd->aliasCmd); - AliasDelete(tcd->interp, tcd->cmdName, methodName, tcd->class == NULL); - } - - /*fprintf(stderr, "aliasCmdDeleteProc\n");*/ - if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} - if (tcd->aliasedCmd) { - Command *aliasedCmd = (Command *)(tcd->aliasedCmd); - /* - * Clear the aliasCmd from the imported-ref chain of the aliased - * (or real) cmd. This widely resembles what happens in the - * DeleteImportedCmd() (see tclNamesp.c), however, as we do not - * provide for ImportedCmdData client data etc., we cannot - * directly use it. - */ - for (refPtr = aliasedCmd->importRefPtr; refPtr; refPtr = refPtr->nextPtr) { - if (refPtr->importedCmdPtr == (Command *) tcd->aliasCmd) { - if (prevPtr == NULL) { - aliasedCmd->importRefPtr = refPtr->nextPtr; - } else { - prevPtr->nextPtr = refPtr->nextPtr; - } - ckfree((char *) refPtr); - break; - } - prevPtr = refPtr; - } - } - - FREE(AliasCmdClientData, tcd); -} - - -typedef enum {NO_DASH, SKALAR_DASH, LIST_DASH} dashArgType; - -static dashArgType -isDashArg(Tcl_Interp *interp, Tcl_Obj *obj, int firstArg, CONST char **methodName, int *objc, Tcl_Obj **objv[]) { - CONST char *flag; - assert(obj); - - 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(*((flag)+1))) { - if (firstArg) { - /* if the argument contains a space, try to split */ - CONST char *p= flag+1; - while (*p && *p != ' ') p++; - if (*p == ' ') { - if (Tcl_ListObjGetElements(interp, obj, objc, objv) == TCL_OK) { - *methodName = ObjStr(*objv[0]); - if (**methodName == '-') {(*methodName)++ ;} - return LIST_DASH; - } - } - } - *methodName = flag+1; - *objc = 1; - return SKALAR_DASH; - } - return NO_DASH; -} - -static int -callConfigureMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, - int argc, Tcl_Obj *CONST argv[]) { - int result; - Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1); - - /* fprintf(stderr, "callConfigureMethod method %s->'%s' level %d, argc %d\n", - objectName(object), methodName, level, argc);*/ - - if (isInitString(methodName)) { - object->flags |= XOTCL_INIT_CALLED; - } - - Tcl_ResetResult(interp); - INCR_REF_COUNT(methodObj); - result = callMethod((ClientData)object, interp, methodObj, argc, argv, XOTCL_CM_NO_UNKNOWN); - DECR_REF_COUNT(methodObj); - - /*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d %d\n", - methodName, argc+1, obj, result, TCL_ERROR);*/ - - if (result != TCL_OK) { - Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */ - INCR_REF_COUNT(res); - XOTclVarErrMsg(interp, ObjStr(res), " during '", objectName(object), " ", - methodName, "'", (char *) NULL); - DECR_REF_COUNT(res); - } - - return result; -} - - -/* - * class method implementations - */ - -static int isRootNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { - XOTclObjectSystem *osPtr; - - for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { - Tcl_Command cmd = osPtr->rootClass->object.id; - if ((Tcl_Namespace *)((Command *)cmd)->nsPtr == nsPtr) { - return 1; - } - } - return 0; -} - -static Tcl_Namespace * -callingNameSpace(Tcl_Interp *interp) { - Tcl_CallFrame *framePtr; - Tcl_Namespace *nsPtr; - - /*tcl85showStack(interp);*/ - - /* - * Find last incovation outside the XOTcl system namespaces. For - * example, the pre defined slot handlers for relations (defined in - * the too namespace) handle mixin and class registration. etc. If we - * would use this namespace, we would resolve non-fully-qualified - * names against the root namespace). - */ - for (framePtr = activeProcFrame((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)); - framePtr; - framePtr = Tcl_CallFrame_callerVarPtr(framePtr)) { - nsPtr = Tcl_CallFrame_nsPtr(framePtr); - if (isRootNamespace(interp, nsPtr)) { - /*fprintf(stderr, "... %p skip %s\n", framePtr, nsPtr->fullName);*/ - continue; - } - /*fprintf(stderr, "... %p take %s\n", framePtr, nsPtr->fullName); */ - break; - } - - if (!framePtr) { - nsPtr = Tcl_GetGlobalNamespace(interp); - } - - /*fprintf(stderr, " **** callingNameSpace: returns %p %s framePtr %p\n", - nsPtr, nsPtr ? nsPtr->fullName:"(null)", framePtr);*/ - return nsPtr; -} - -/*********************************** - * argument parser - ***********************************/ - -#include "tclAPI.h" - -static int -ArgumentError(Tcl_Interp *interp, CONST char *errorMsg, XOTclParam CONST *paramPtr, - Tcl_Obj *cmdNameObj, Tcl_Obj *methodObj) { - Tcl_Obj *argStringObj = ParamDefsSyntax(interp, paramPtr); - - XOTclObjWrongArgs(interp, errorMsg, cmdNameObj, methodObj, ObjStr(argStringObj)); - DECR_REF_COUNT(argStringObj); - - return TCL_ERROR; -} - -static int -ArgumentCheckHelper(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int *flags, - ClientData *clientData, Tcl_Obj **outObjPtr) { - int objc, i, result; - Tcl_Obj **ov; - - /*fprintf(stderr, "ArgumentCheckHelper\n");*/ - assert(pPtr->flags & XOTCL_ARG_MULTIVALUED); - - result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov); - if (result != TCL_OK) { - return result; - } - - *outObjPtr = Tcl_NewListObj(0, NULL); - INCR_REF_COUNT(*outObjPtr); - - for (i=0; iflags & XOTCL_ARG_ALLOW_EMPTY && *valueString == '\0') { - result = convertToString(interp, ov[i], pPtr, clientData, &elementObjPtr); - } else { - result = (*pPtr->converter)(interp, ov[i], pPtr, clientData, &elementObjPtr); - } - - /*fprintf(stderr, "ArgumentCheckHelper convert %s result %d (%s)\n", - valueString, result, ObjStr(elementObjPtr));*/ - - if (result == TCL_OK) { - Tcl_ListObjAppendElement(interp, *outObjPtr, elementObjPtr); - } else { - Tcl_Obj *resultObj = Tcl_GetObjResult(interp); - INCR_REF_COUNT(resultObj); - XOTclVarErrMsg(interp, "invalid value in \"", ObjStr(objPtr), "\": ", - ObjStr(resultObj), (char *) NULL); - DECR_REF_COUNT(resultObj); - DECR_REF_COUNT(*outObjPtr); - *flags &= ~XOTCL_PC_MUST_DECR; - *outObjPtr = objPtr; - break; - } - } - return result; -} - -static int -ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int doCheck, - int *flags, ClientData *clientData, Tcl_Obj **outObjPtr) { - int result; - - if (doCheck == 0 && (pPtr->flags & (XOTCL_ARG_IS_CONVERTER|XOTCL_ARG_INITCMD)) == 0) { - /*fprintf(stderr, "*** omit argument check for arg %s flags %.6x\n",pPtr->name, pPtr->flags);*/ - *outObjPtr = objPtr; - *clientData = ObjStr(objPtr); - *flags = 0; - return TCL_OK; - } - - if (pPtr->flags & XOTCL_ARG_MULTIVALUED) { - int objc, i; - Tcl_Obj **ov; - - /* - * In the multivalued case, we have either to check a list of - * values or to build a new list of values (in case, the converter - * normalizes the values). - */ - result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov); - if (result != TCL_OK) { - return result; - } - - /* - * Default assumption: outObjPtr is not modified, in cases where - * necessary, we switch to the helper function - */ - *outObjPtr = objPtr; - - for (i=0; iflags & XOTCL_ARG_ALLOW_EMPTY && *valueString == '\0') { - result = convertToString(interp, ov[i], pPtr, clientData, &elementObjPtr); - } else { - result = (*pPtr->converter)(interp, ov[i], pPtr, clientData, &elementObjPtr); - } - - if (result == TCL_OK) { - if (ov[i] != elementObjPtr) { - /* - The elementObjPtr differs from the input tcl_obj, we - switch to the version of this handler building an output - list - */ - /*fprintf(stderr, "switch to output list construction for value %s\n", - ObjStr(elementObjPtr));*/ - *flags |= XOTCL_PC_MUST_DECR; - result = ArgumentCheckHelper(interp, objPtr, pPtr, flags, clientData, outObjPtr); - break; - } - } else { - Tcl_Obj *resultObj = Tcl_GetObjResult(interp); - INCR_REF_COUNT(resultObj); - XOTclVarErrMsg(interp, "invalid value in \"", ObjStr(objPtr), "\": ", - ObjStr(resultObj), (char *) NULL); - DECR_REF_COUNT(resultObj); - break; - } - } - } else { - const char *valueString = ObjStr(objPtr); - if (pPtr->flags & XOTCL_ARG_ALLOW_EMPTY && *valueString == '\0') { - result = convertToString(interp, objPtr, pPtr, clientData, outObjPtr); - } else { - result = (*pPtr->converter)(interp, objPtr, pPtr, clientData, outObjPtr); - } - } - return result; -} - -static int -ArgumentDefaults(parseContext *pcPtr, Tcl_Interp *interp, - XOTclParam CONST *ifd, int nrParams) { - XOTclParam CONST *pPtr; - int i; - - for (pPtr = ifd, i=0; i %p %p, default %s\n", - pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr, - pcPtr->clientData[i], pcPtr->objv[i], - pPtr->defaultValue ? ObjStr(pPtr->defaultValue) : "NONE");*/ - - if (pcPtr->objv[i]) { - /* we got an actual value, which was already checked by objv parser */ - /*fprintf(stderr, "setting passed value for %s to '%s'\n", pPtr->name, ObjStr(pcPtr->objv[i]));*/ - if (pPtr->converter == convertToSwitch) { - int bool; - Tcl_GetBooleanFromObj(interp, pPtr->defaultValue, &bool); - pcPtr->objv[i] = Tcl_NewBooleanObj(!bool); - } - } else { - /* no valued passed, check if default is available */ - - if (pPtr->defaultValue) { - int mustDecrNewValue; - Tcl_Obj *newValue = pPtr->defaultValue; - ClientData checkedData; - - /* we have a default, do we have to subst it? */ - if (pPtr->flags & XOTCL_ARG_SUBST_DEFAULT) { - int result = SubstValue(interp, pcPtr->object, &newValue); - if (result != TCL_OK) { - return result; - } - /*fprintf(stderr, "attribute %s default %p %s => %p '%s'\n", pPtr->name, - pPtr->defaultValue, ObjStr(pPtr->defaultValue), - newValue, ObjStr(newValue));*/ - - /* the according DECR is performed by parseContextRelease() */ - INCR_REF_COUNT(newValue); - mustDecrNewValue = 1; - pcPtr->flags[i] |= XOTCL_PC_MUST_DECR; - pcPtr->mustDecr = 1; - } else { - mustDecrNewValue = 0; - } - - pcPtr->objv[i] = newValue; - /*fprintf(stderr, "==> setting default value '%s' for var '%s' flag %d type %s conv %p\n", - ObjStr(newValue), pPtr->name, pPtr->flags & XOTCL_ARG_INITCMD, - pPtr->type, pPtr->converter);*/ - - /* Check the default value, unless we have an INITCMD or METHOD */ - if ((pPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_METHOD)) == 0) { - int mustDecrList = 0; - if (ArgumentCheck(interp, newValue, pPtr, - RUNTIME_STATE(interp)->doCheckArguments, - &mustDecrList, &checkedData, &pcPtr->objv[i]) != TCL_OK) { - return TCL_ERROR; - } - - if (pcPtr->objv[i] != newValue) { - /* The output tcl_obj differs from the input, so the tcl_obj - was converted; in case we have set prevously must_decr - on newValue, we decr the refcount on newValue here and - clear the flag */ - if (mustDecrNewValue) { - DECR_REF_COUNT(newValue); - pcPtr->flags[i] &= ~XOTCL_PC_MUST_DECR; - } - /* the new output value itself might require a decr, so - set the flag here if required; this is just necessary - for multivalued converted output */ - if (mustDecrList) { - pcPtr->flags[i] |= XOTCL_PC_MUST_DECR; - pcPtr->mustDecr = 1; - } - } - } - } else if (pPtr->flags & XOTCL_ARG_REQUIRED) { - return XOTclVarErrMsg(interp, - pcPtr->object ? objectName(pcPtr->object) : "", - pcPtr->object ? " " : "", - ObjStr(pcPtr->full_objv[0]), ": required argument '", - pPtr->nameObj ? ObjStr(pPtr->nameObj) : pPtr->name, - "' is missing", (char *) NULL); - } else { - /* Use as dummy default value an arbitrary symbol, which must not be - * returned to the Tcl level level; this value is - * unset later by unsetUnknownArgs - */ - pcPtr->objv[i] = XOTclGlobalObjs[XOTE___UNKNOWN__]; - } - } - } - return TCL_OK; -} - -static int -ArgumentParse(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - XOTclObject *object, Tcl_Obj *procNameObj, - XOTclParam CONST *paramPtr, int nrParams, int doCheck, - parseContext *pcPtr) { - int i, o, flagCount, nrReq = 0, nrOpt = 0, dashdash = 0, nrDashdash = 0; - XOTclParam CONST *pPtr; - - parseContextInit(pcPtr, nrParams, object, procNameObj); - -#if defined(PARSE_TRACE) - fprintf(stderr, "BEGIN (%d) [0]%s ", objc, ObjStr(procNameObj)); - for (o=1; oname && o < objc;) { -#if defined(PARSE_TRACE_FULL) - fprintf(stderr, "... (%d) processing [%d]: '%s' %s\n", i, o, - pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req"); -#endif - flagCount = 0; - if (*pPtr->name == '-') { - int p, found; - CONST char *objStr; - /* - * We expect now a non-positional (named) parameter, starting - * with a "-"; such arguments can be given in an arbitrary order - */ - for (p = o; pname && *nppPtr->name == '-'; nppPtr ++) { - if (strcmp(objStr, nppPtr->name) == 0) { - int j = nppPtr-paramPtr; - /*fprintf(stderr, "... flag '%s' o=%d p=%d, objc=%d nrArgs %d\n", objStr, o, p, objc, nppPtr->nrArgs);*/ - if (nppPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; - if (nppPtr->nrArgs == 0) { - pcPtr->clientData[j] = (ClientData)1; /* the flag was given */ - pcPtr->objv[j] = XOTclGlobalObjs[XOTE_ONE]; - } else { - /* we assume for now, nrArgs is at most 1 */ - o++; p++; - if (nppPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; - - if (o < objc) { -#if defined(PARSE_TRACE_FULL) - fprintf(stderr, "... setting cd[%d] '%s' = %s (%d) %s converter %p\n", - i, nppPtr->name, ObjStr(objv[p]), nppPtr->nrArgs, - nppPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req", nppPtr->converter); -#endif - if (ArgumentCheck(interp, objv[p], nppPtr, doCheck, - &pcPtr->flags[j], &pcPtr->clientData[j], &pcPtr->objv[j]) != TCL_OK) { - return TCL_ERROR; - } - - if (pcPtr->flags[j] & XOTCL_PC_MUST_DECR) - pcPtr->mustDecr = 1; - - } else { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Argument for parameter '", objStr, "' expected", (char *) NULL); - return TCL_ERROR; - } - } - flagCount++; - found = 1; - break; - } - } - if (!found) { - /* we did not find the specified flag, the thing starting - with a '-' must be an argument */ - break; - } - } - } - /*fprintf(stderr, "... we found %d flags\n", flagCount);*/ - /* skip in parameter definition until the end of the switches */ - while (pPtr->name && *pPtr->name == '-') {pPtr++, i++;}; - /* under the assumption, flags have no arguments */ - o += flagCount; - /* - * check double dash -- - */ - if (oflags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; - /*fprintf(stderr, "... arg %s req %d converter %p try to set on %d: '%s' convertViaCmd %p\n", - pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr->converter, i, ObjStr(objv[o]), - convertViaCmd);*/ - - if (ArgumentCheck(interp, objv[o], pPtr, doCheck, - &pcPtr->flags[i], &pcPtr->clientData[i], &pcPtr->objv[i]) != TCL_OK) { - return TCL_ERROR; - } - if (pcPtr->flags[i] & XOTCL_PC_MUST_DECR) - pcPtr->mustDecr = 1; - - /* - * objv is always passed via pcPtr->objv - */ -#if defined(PARSE_TRACE_FULL) - fprintf(stderr, "... setting %s pPtr->objv[%d] to [%d]'%s' converter %p\n", - pPtr->name, i, o, ObjStr(objv[o]), pPtr->converter); -#endif - o++; i++; pPtr++; - } - } - pcPtr->lastobjc = pPtr->name ? o : o-1; - pcPtr->objc = i + 1; - - /* Process all args until end of parameter definitions to get correct counters */ - while (pPtr->name) { - if (pPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; - pPtr++; - } - - /* is last argument a vararg? */ - pPtr--; - if (pPtr->converter == convertToNothing) { - pcPtr->varArgs = 1; - /*fprintf(stderr, "last arg of proc '%s' is varargs\n", ObjStr(procNameObj));*/ - } - - /* handle missing or unexpected arguments */ - if (pcPtr->lastobjc < nrReq) { - return ArgumentError(interp, "not enough arguments:", paramPtr, NULL, procNameObj); /* for methods and cmds */ - } - if (!pcPtr->varArgs && objc-nrDashdash-1 > nrReq + nrOpt) { - return ArgumentError(interp, "too many arguments:", paramPtr, NULL, procNameObj); /* for methods and cmds */ - } - - return ArgumentDefaults(pcPtr, interp, paramPtr, nrParams); -} - - -/*********************************** - * Begin result setting commands - * (essentially List*() and support - ***********************************/ -static int -ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, CONST char *pattern) { - Tcl_HashEntry *hPtr; - - if (pattern && noMetaChars(pattern)) { - Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); - INCR_REF_COUNT(patternObj); - - hPtr = tablePtr ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : NULL; - if (hPtr) { - Var *val = VarHashGetValue(hPtr); - Tcl_SetObjResult(interp, VarHashGetKey(val)); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); - } - 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; -} - -static Tcl_Command -GetOriginalCommand(Tcl_Command cmd) /* The imported command for which the original - * command should be returned. */ -{ - Tcl_Command importedCmd; - - while (1) { - /* dereference the namespace import reference chain */ - if ((importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } - /* dereference the XOtcl alias chain */ - if (Tcl_Command_deleteProc(cmd) == aliasCmdDeleteProc) { - AliasCmdClientData *tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd); - cmd = tcd->aliasedCmd; - continue; - } - break; - } - return cmd; -} - -static int -ListProcBody(Tcl_Interp *interp, Proc *procPtr, CONST char *methodName) { - if (procPtr) { - CONST char *body = ObjStr(procPtr->bodyPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); - return TCL_OK; - } - return XOTclErrBadVal(interp, "info body", "a tcl method name", methodName); -} - -static Tcl_Obj* -ListParamDefs(Tcl_Interp *interp, XOTclParam CONST *paramsPtr, int style) { - Tcl_Obj *listObj; - - switch (style) { - case 0: listObj = ParamDefsFormat(interp, paramsPtr); break; - case 1: listObj = ParamDefsList(interp, paramsPtr); break; - case 2: listObj = ParamDefsSyntax(interp, paramsPtr); break; - } - - return listObj; -} - -static int -ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, CONST char *methodName, int withVarnames) { - Proc *procPtr = GetTclProcFromCommand(cmd); - if (procPtr) { - XOTclParamDefs *paramDefs = procPtr ? ParamDefsGet((Tcl_Command)procPtr->cmdPtr) : NULL; - Tcl_Obj *list; - - if (paramDefs) { - /* - * Obtain parameter info from paramDefs - */ - list = ListParamDefs(interp, paramDefs->paramsPtr, withVarnames); - - } else { - /* - * Obtain parameter info from compiled locals - */ - CompiledLocal *args = procPtr->firstLocalPtr; - - list = Tcl_NewListObj(0, NULL); - for ( ; args; args = args->nextPtr) { - Tcl_Obj *innerlist; - - if (!TclIsCompiledLocalArgument(args)) { - continue; - } - - innerlist = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, innerlist, Tcl_NewStringObj(args->name, -1)); - if (!withVarnames && args->defValuePtr) { - Tcl_ListObjAppendElement(interp, innerlist, args->defValuePtr); - } - Tcl_ListObjAppendElement(interp, list, innerlist); - } - } - - Tcl_SetObjResult(interp, list); - return TCL_OK; - - } else if (cmd) { - /* - * If a command is found for the object|class, check whether we - * find the parameter definitions for the C-defined method. - */ - methodDefinition *mdPtr = &method_definitions[0]; - - for (; mdPtr->methodName; mdPtr ++) { - - /*fprintf(stderr, "... comparing %p with %p => %s\n", ((Command *)cmd)->objProc, mdPtr->proc, - mdPtr->methodName);*/ - - if (((Command *)cmd)->objProc == mdPtr->proc) { - XOTclParamDefs paramDefs = {mdPtr->paramDefs, mdPtr->nrParameters}; - Tcl_Obj *list = ListParamDefs(interp, paramDefs.paramsPtr, withVarnames); - - Tcl_SetObjResult(interp, list); - return TCL_OK; - } - } - - if (((Command *)cmd)->objProc == XOTclSetterMethod) { - SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd); - if (cd->paramsPtr) { - Tcl_Obj *list; - XOTclParamDefs paramDefs; - paramDefs.paramsPtr = cd->paramsPtr; - paramDefs.nrParams = 1; - paramDefs.slotObj = NULL; - list = ListParamDefs(interp, paramDefs.paramsPtr, withVarnames); - Tcl_SetObjResult(interp, list); - return TCL_OK; - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj(methodName, -1)); - return TCL_OK; - } - } else if (((Command *)cmd)->objProc == XOTclForwardMethod) { - return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for forwarder '", - methodName, "'", (char *) NULL); - } else { - return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for method '", - methodName, "'", (char *) NULL); - } - } - return XOTclErrBadVal(interp, "info params", "a method name", methodName); -} - -static void -AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd) { - if (tcd->prefix) { - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-methodprefix", -1)); - Tcl_ListObjAppendElement(interp, listObj, tcd->prefix); - } - if (tcd->subcommands) { - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-default", -1)); - Tcl_ListObjAppendElement(interp, listObj, tcd->subcommands); - } - if (tcd->objscope) { - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-objscope", -1)); - } - Tcl_ListObjAppendElement(interp, listObj, tcd->cmdName); - if (tcd->args) { - Tcl_Obj **args; - int nrArgs, i; - Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); - for (i=0; icmdName); - if (withPer_object) { - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6)); - } - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(registerCmdName, -1)); - if (withObjscope) { - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-objscope", 9)); - } - if (Tcl_Command_flags(cmd) & XOTCL_CMD_NONLEAF_METHOD) { - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-nonleaf", 8)); - } - Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(methodName, -1)); -} - -static int -ListMethodHandle(Tcl_Interp *interp, XOTclObject *object, int withPer_object, CONST char *methodName) { - Tcl_SetObjResult(interp, MethodHandleObj(object, withPer_object, methodName)); - return TCL_OK; -} - -static int -ListMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *methodName, Tcl_Command cmd, - int subcmd, int withPer_object) { - - /*fprintf(stderr, "ListMethodtype %s %s %p subcmd %d per-object %d\n", - objectName(object), methodName, cmd, subcmd, withPer_object);*/ - - if (!cmd) { - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); - } else { - Tcl_ObjCmdProc *procPtr = Tcl_Command_objProc(cmd); - int outputPerObject = 0; - Tcl_Obj *resultObj; - - if (*methodName == ':') { - /* - * We have a fully qualified method name, maybe an object handle - */ - CONST char *procName = Tcl_GetCommandName(interp, cmd); - size_t objNameLength = strlen(methodName) - strlen(procName) - 2; - Tcl_DString ds, *dsPtr = &ds; - - if (objNameLength > 0) { - XOTclObject *object1; - int fromClassNS; - - Tcl_DStringInit(dsPtr); - Tcl_DStringAppend(dsPtr, methodName, objNameLength); - object1 = GetObjectFromNsName(interp, Tcl_DStringValue(dsPtr), &fromClassNS); - if (object1) { - /* - * The command was from an object, return therefore this - * object as reference. - */ - /*fprintf(stderr, "We are flipping the object to %s, method %s to %s !fromClassNS %d\n", - objectName(object1), methodName, procName, !fromClassNS);*/ - object = object1; - methodName = procName; - withPer_object = fromClassNS ? 0 : 1; - } - Tcl_DStringFree(dsPtr); - } - } - - if (!XOTclObjectIsClass(object)) { - withPer_object = 1; - /* don't output "object" modifier, if object is not a class */ - outputPerObject = 0; - } else { - outputPerObject = withPer_object; - } - - switch (subcmd) { - case InfomethodsubcmdHandleIdx: - { - return ListMethodHandle(interp, object, withPer_object, methodName); - } - case InfomethodsubcmdArgsIdx: - { - Tcl_Command importedCmd = GetOriginalCommand(cmd); - return ListCmdParams(interp, importedCmd, methodName, 1); - } - case InfomethodsubcmdParameterIdx: - { - Tcl_Command importedCmd = GetOriginalCommand(cmd); - return ListCmdParams(interp, importedCmd, methodName, 0); - } - case InfomethodsubcmdParametersyntaxIdx: - { - Tcl_Command importedCmd = GetOriginalCommand(cmd); - return ListCmdParams(interp, importedCmd, methodName, 2); - } - case InfomethodsubcmdPreconditionIdx: - { - XOTclProcAssertion *procs; - if (withPer_object) { - procs = object->opt ? AssertionFindProcs(object->opt->assertions, methodName) : NULL; - } else { - XOTclClass *class = (XOTclClass *)object; - procs = class->opt ? AssertionFindProcs(class->opt->assertions, methodName) : NULL; - } - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); - return TCL_OK; - } - case InfomethodsubcmdPostconditionIdx: - { - XOTclProcAssertion *procs; - if (withPer_object) { - procs = object->opt ? AssertionFindProcs(object->opt->assertions, methodName) : NULL; - } else { - XOTclClass *class = (XOTclClass *)object; - procs = class->opt ? AssertionFindProcs(class->opt->assertions, methodName) : NULL; - } - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); - return TCL_OK; - } - - } - - /* - * Subcommands different per type of method. The Converter in - * InfoMethods defines the types: - * - * "all|scripted|system|alias|forwarder|object|setter" - */ - if (GetTclProcFromCommand(cmd)) { - /* a scripted method */ - switch (subcmd) { - - case InfomethodsubcmdTypeIdx: - Tcl_SetObjResult(interp, Tcl_NewStringObj("scripted", -1)); - break; - - case InfomethodsubcmdBodyIdx: - ListProcBody(interp, GetTclProcFromCommand(cmd), methodName); - break; - - case InfomethodsubcmdDefinitionIdx: - { - XOTclAssertionStore *assertions; - - resultObj = Tcl_NewListObj(0, NULL); - /* todo: don't hard-code registering command name "method" / XOTE_METHOD */ - AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_METHOD], - object, methodName, cmd, 0, outputPerObject); - ListCmdParams(interp, cmd, methodName, 0); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp)); - ListProcBody(interp, GetTclProcFromCommand(cmd), methodName); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp)); - - if (withPer_object) { - assertions = object->opt ? object->opt->assertions : NULL; - } else { - XOTclClass *class = (XOTclClass *)object; - assertions = class->opt ? class->opt->assertions : NULL; - } - if (assertions) { - XOTclProcAssertion *procs = AssertionFindProcs(assertions, methodName); - if (procs) { - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-precondition", -1)); - Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->pre)); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-postcondition", -1)); - Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->post)); - } - } - Tcl_SetObjResult(interp, resultObj); - break; - } - } - - } else if (procPtr == XOTclForwardMethod) { - /* forwarder */ - switch (subcmd) { - case InfomethodsubcmdTypeIdx: - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_FORWARD]); - break; - case InfomethodsubcmdDefinitionIdx: - { - ClientData clientData = cmd ? Tcl_Command_objClientData(cmd) : NULL; - - if (clientData) { - resultObj = Tcl_NewListObj(0, NULL); - /* todo: don't hard-code registering command name "forward" / XOTE_FORWARD*/ - AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_FORWARD], - object, methodName, cmd, 0, outputPerObject); - AppendForwardDefinition(interp, resultObj, clientData); - Tcl_SetObjResult(interp, resultObj); - break; - } - } - } - - } else if (procPtr == XOTclSetterMethod) { - /* setter methods */ - switch (subcmd) { - case InfomethodsubcmdTypeIdx: - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_SETTER]); - break; - case InfomethodsubcmdDefinitionIdx: { - SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd); - - resultObj = Tcl_NewListObj(0, NULL); - /* todo: don't hard-code registering command name "setter" / XOTE_SETTER */ - - AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_SETTER], object, - cd->paramsPtr ? ObjStr(cd->paramsPtr->paramObj) : methodName, - cmd, 0, outputPerObject); - Tcl_SetObjResult(interp, resultObj); - break; - } - } -#if 0 - } else if (procPtr == XOTclObjDispatch) { - /* - Also some aliases come with procPtr == XOTclObjDispatch. In - order to dinstinguish between "object" and alias, we would - have to do the lookup for the entryObj in advance and alter - e.g. the procPtr. - */ - switch (subcmd) { - case InfomethodsubcmdTypeIdx: - Tcl_SetObjResult(interp, Tcl_NewStringObj("object", -1)); - break; - case InfomethodsubcmdDefinitionIdx: - { - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); - break; - } - } -#endif - } else { - /* - * The cmd must be an alias or object. - * - * Note that some aliases come with procPtr == XOTclObjDispatch. - * In order to dinstinguish between "object" and alias, we have - * to do the lookup for the entryObj to determine wether it is - * really an alias. - */ - - Tcl_Obj *entryObj = AliasGet(interp, object->cmdName, methodName, withPer_object); - /*fprintf(stderr, "aliasGet %s -> %s (%d) returned %p\n", - objectName(object), methodName, withPer_object, entryObj);*/ - - if (entryObj) { - /* is an alias */ - switch (subcmd) { - case InfomethodsubcmdTypeIdx: - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_ALIAS]); - break; - case InfomethodsubcmdDefinitionIdx: - { - int nrElements; - Tcl_Obj **listElements; - resultObj = Tcl_NewListObj(0, NULL); - Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements); - /* todo: don't hard-code registering command name "alias" / XOTE_ALIAS */ - AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_ALIAS], - object, methodName, cmd, nrElements!=1, outputPerObject); - Tcl_ListObjAppendElement(interp, resultObj, listElements[nrElements-1]); - Tcl_SetObjResult(interp, resultObj); - break; - } - } - } else { - /* check, to be on the safe side */ - if (procPtr == XOTclObjDispatch) { - /* is an object */ - switch (subcmd) { - case InfomethodsubcmdTypeIdx: - Tcl_SetObjResult(interp, Tcl_NewStringObj("object", -1)); - break; - case InfomethodsubcmdDefinitionIdx: - { - /* yyyy */ - XOTclObject *subObject = XOTclGetObjectFromCmdPtr(cmd); - assert(subObject); - resultObj = Tcl_NewListObj(0, NULL); - /* we can make - create - or something similar to the other definition cmds - createChild - */ - AppendMethodRegistration(interp, resultObj, "create", - &(subObject->cl)->object, - ObjStr(subObject->cmdName), cmd, 0, 0); - /* - AppendMethodRegistration(interp, resultObj, "subobject", - object, methodName, cmd, 0, 0); - Tcl_ListObjAppendElement(interp, resultObj, subObject->cmdName);*/ - - Tcl_SetObjResult(interp, resultObj); - break; - } - } - } else { - /* should never happen */ - fprintf(stderr, "should never happen, maybe someone deleted the alias %s for object %s\n", - methodName, objectName(object)); - Tcl_ResetResult(interp); - } - } - } - } - return TCL_OK; -} - -static int -ProtectionMatches(Tcl_Interp *interp, int withCallprotection, Tcl_Command cmd) { - int result, isProtected = Tcl_Command_flags(cmd) & XOTCL_CMD_PROTECTED_METHOD; - if (withCallprotection == CallprotectionNULL) { - withCallprotection = CallprotectionPublicIdx; - } - switch (withCallprotection) { - case CallprotectionAllIdx: result = 1; break; - case CallprotectionPublicIdx: result = (isProtected == 0); break; - case CallprotectionProtectedIdx: result = (isProtected == 1); break; - default: result = 1; - } - return result; -} - -static int -MethodTypeMatches(Tcl_Interp *interp, int methodType, Tcl_Command cmd, - XOTclObject *object, CONST char *key, int withPer_object) { - Tcl_Command importedCmd; - Tcl_ObjCmdProc *proc, *resolvedProc; - - proc = Tcl_Command_objProc(cmd); - importedCmd = GetOriginalCommand(cmd); - resolvedProc = Tcl_Command_objProc(importedCmd); - - if (methodType == XOTCL_METHODTYPE_ALIAS) { - if (!(proc == XOTclProcAliasMethod || AliasGet(interp, object->cmdName, key, withPer_object))) { - return 0; - } - } else { - if (proc == XOTclProcAliasMethod) { - if ((methodType & XOTCL_METHODTYPE_ALIAS) == 0) return 0; - } - /* the following cases are disjoint */ - if (CmdIsProc(importedCmd)) { - /*fprintf(stderr,"%s scripted %d\n", key, methodType & XOTCL_METHODTYPE_SCRIPTED);*/ - if ((methodType & XOTCL_METHODTYPE_SCRIPTED) == 0) return 0; - } else if (resolvedProc == XOTclForwardMethod) { - if ((methodType & XOTCL_METHODTYPE_FORWARDER) == 0) return 0; - } else if (resolvedProc == XOTclSetterMethod) { - if ((methodType & XOTCL_METHODTYPE_SETTER) == 0) return 0; - } else if (resolvedProc == XOTclObjDispatch) { - if ((methodType & XOTCL_METHODTYPE_OBJECT) == 0) return 0; - } else if ((methodType & XOTCL_METHODTYPE_OTHER) == 0) { - /* fprintf(stderr,"OTHER %s not wanted %.4x\n", key, methodType);*/ - return 0; - } - /* XOTclObjscopedMethod ??? */ - } - return 1; -} - -static int -ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, CONST char *pattern, - int methodType, int withCallprotection, - Tcl_HashTable *dups, XOTclObject *object, int withPer_object) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr, *duphPtr; - Tcl_Command cmd; - char *key; - int new; - - if (pattern && noMetaChars(pattern)) { - /* We have a pattern that can be used for direct lookup; - * no need to iterate - */ - hPtr = table ? Tcl_CreateHashEntry(table, pattern, NULL) : NULL; - if (hPtr) { - key = Tcl_GetHashKey(table, hPtr); - cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - - if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD && !XOTclObjectIsClass(object)) { - return TCL_OK; - } - - if (ProtectionMatches(interp, withCallprotection, cmd) - && MethodTypeMatches(interp, methodType, cmd, object, key, withPer_object)) { - if (dups) { - duphPtr = Tcl_CreateHashEntry(dups, key, &new); - if (new) { - Tcl_AppendElement(interp, key); - } - } else { - Tcl_AppendElement(interp, key); - } - } - } - return TCL_OK; - - } else { - hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(table, hPtr); - cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - - if (Tcl_Command_flags(cmd) & XOTCL_CMD_CLASS_ONLY_METHOD && !XOTclObjectIsClass(object)) continue; - if (pattern && !Tcl_StringMatch(key, pattern)) continue; - if (!ProtectionMatches(interp, withCallprotection, cmd) - || !MethodTypeMatches(interp, methodType, cmd, object, key, withPer_object) - ) continue; - - if (dups) { - duphPtr = Tcl_CreateHashEntry(dups, key, &new); - if (!new) continue; - } - Tcl_AppendElement(interp, key); - } - } - /*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/ - return TCL_OK; -} - -static int -ListChildren(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, int classesOnly) { - XOTclObject *childObject; - Tcl_HashTable *cmdTable; - - if (!object->nsPtr) return TCL_OK; - - cmdTable = Tcl_Namespace_cmdTable(object->nsPtr); - if (pattern && noMetaChars(pattern)) { - - if ((childObject = XOTclpGetObject(interp, pattern)) && - (!classesOnly || XOTclObjectIsClass(childObject)) && - (Tcl_Command_nsPtr(childObject->id) == object->nsPtr) /* true children */ - ) { - Tcl_SetObjResult(interp, childObject->cmdName); - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); - } - - } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - char *key; - - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(cmdTable, hPtr); - if (!pattern || Tcl_StringMatch(key, pattern)) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - - /*fprintf(stderr, "... check %s child key %s child object %p %p\n", - objectName(object),key,XOTclpGetObject(interp, key), - XOTclGetObjectFromCmdPtr(cmd));*/ - - if ((childObject = XOTclGetObjectFromCmdPtr(cmd)) && - (!classesOnly || XOTclObjectIsClass(childObject)) && - (Tcl_Command_nsPtr(childObject->id) == object->nsPtr) /* true children */ - ) { - Tcl_ListObjAppendElement(interp, list, childObject->cmdName); - } - } - } - Tcl_SetObjResult(interp, list); - } - - return TCL_OK; -} - -static int -ListForward(Tcl_Interp *interp, Tcl_HashTable *table, CONST char *pattern, int withDefinition) { - if (withDefinition) { - Tcl_HashEntry *hPtr = table && pattern ? Tcl_CreateHashEntry(table, pattern, NULL) : NULL; - /* notice: we don't use pattern for wildcard matching here; - pattern can only contain wildcards when used without - "-definition" */ - 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_Command_objProc(cmd) == XOTclForwardMethod) { - Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); - AppendForwardDefinition(interp, listObj, tcd); - Tcl_SetObjResult(interp, listObj); - return TCL_OK; - } - } - return XOTclVarErrMsg(interp, "'", pattern, "' is not a forwarder", (char *) NULL); - } - return ListMethodKeys(interp, table, pattern, XOTCL_METHODTYPE_FORWARDER, CallprotectionAllIdx, NULL, NULL, 0); -} - -static int -ListDefinedMethods(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, - int withPer_object, int methodType, int withCallproctection, - int noMixins, int inContext) { - Tcl_HashTable *cmdTable; - - if (XOTclObjectIsClass(object) && !withPer_object) { - cmdTable = Tcl_Namespace_cmdTable(((XOTclClass *)object)->nsPtr); - } else { - cmdTable = object->nsPtr ? Tcl_Namespace_cmdTable(object->nsPtr) : NULL; - } - ListMethodKeys(interp, cmdTable, pattern, methodType, withCallproctection, - NULL, object, withPer_object); - return TCL_OK; -} - -static int -ListCallableMethods(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern, - int methodType, int withCallprotection, - int withApplication, int noMixins, int inContext) { - XOTclClasses *pl; - int withPer_object = 1; - Tcl_HashTable *cmdTable, dupsTable, *dups = &dupsTable; - - /* - * TODO: we could make this faster for patterns without metachars - * by letting ListMethodKeys() to signal us when an entry was found. - * we wait, until the we decided about "info methods defined" - * vs. "info method search" vs. "info defined" etc. - */ - if (withCallprotection == CallprotectionNULL) { - withCallprotection = CallprotectionPublicIdx; - } - - if (withApplication && object->flags & IsBaseClass((XOTclClass*)object)) { - return TCL_OK; - } - - Tcl_InitHashTable(dups, TCL_STRING_KEYS); - if (object->nsPtr) { - cmdTable = Tcl_Namespace_cmdTable(object->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, - dups, object, withPer_object); - } - - if (!noMixins) { - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - if (object->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml; - XOTclClass *mixin; - for (ml = object->mixinOrder; ml; ml = ml->nextPtr) { - int guardOk = TCL_OK; - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - assert(mixin); - - if (inContext) { - if (!RUNTIME_STATE(interp)->guardCount) { - guardOk = GuardCall(object, 0, 0, interp, ml->clientData, NULL); - } - } - if (mixin && guardOk == TCL_OK) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, - dups, object, withPer_object); - } - } - } - } - - /* append method keys from inheritance order */ - for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); - if (withApplication && IsBaseClass(pl->cl)) { - break; - } - ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, - dups, object, withPer_object); - } - Tcl_DeleteHashTable(dups); - return TCL_OK; -} - -static int -ListSuperclasses(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *pattern, int withClosure) { - XOTclObject *matchObject = NULL; - Tcl_Obj *patternObj = NULL, *outObjPtr; - CONST char *patternString = NULL; - int rc; - - if (pattern && - convertToObjpattern(interp, pattern, NULL, (ClientData *)&patternObj, &outObjPtr) == TCL_OK) { - if (getMatchObject(interp, patternObj, pattern, &matchObject, &patternString) == -1) { - if (patternObj) { - DECR_REF_COUNT(patternObj); - } - return TCL_OK; - } - } - - if (withClosure) { - XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); - if (pl) pl=pl->nextPtr; - rc = AppendMatchingElementsFromClasses(interp, pl, patternString, matchObject); - } else { - XOTclClasses *clSuper = XOTclReverseClasses(cl->super); - rc = AppendMatchingElementsFromClasses(interp, clSuper, patternString, matchObject); - XOTclClassListFree(clSuper); - } - - if (matchObject) { - Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - } - - if (patternObj) { - DECR_REF_COUNT(patternObj); - } - return TCL_OK; -} - - -/******************************** - * End result setting commands - ********************************/ - -static CONST char* AliasIndex(Tcl_DString *dsPtr, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object) { - Tcl_DStringInit(dsPtr); - Tcl_DStringAppend(dsPtr, ObjStr(cmdName), -1); - Tcl_DStringAppend(dsPtr, ",", 1); - Tcl_DStringAppend(dsPtr, methodName, -11); - if (withPer_object) { - Tcl_DStringAppend(dsPtr, ",1", 2); - } else { - Tcl_DStringAppend(dsPtr, ",0", 2); - } - /*fprintf(stderr, "AI %s\n", Tcl_DStringValue(dsPtr));*/ - return Tcl_DStringValue(dsPtr); -} - -static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object, - CONST char *cmd) { - Tcl_DString ds, *dsPtr = &ds; - Tcl_SetVar2Ex(interp, XOTclGlobalStrings[XOTE_ALIAS_ARRAY], - AliasIndex(dsPtr, cmdName, methodName, withPer_object), - Tcl_NewStringObj(cmd, -1), - TCL_GLOBAL_ONLY); - /*fprintf(stderr, "aliasAdd ::nsf::alias(%s) '%s' returned %p\n", - AliasIndex(dsPtr, cmdName, methodName, withPer_object), cmd, 1);*/ - Tcl_DStringFree(dsPtr); - return TCL_OK; -} - -static int AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object) { - Tcl_DString ds, *dsPtr = &ds; - int result = Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_ALIAS_ARRAY], - AliasIndex(dsPtr, cmdName, methodName, withPer_object), - TCL_GLOBAL_ONLY); - /*fprintf(stderr, "aliasDelete ::nsf::alias(%s) returned %d (%d)\n", - AliasIndex(dsPtr, cmdName, methodName, withPer_object), result);*/ - Tcl_DStringFree(dsPtr); - return result; -} - -static Tcl_Obj *AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object) { - Tcl_DString ds, *dsPtr = &ds; - Tcl_Obj *obj = Tcl_GetVar2Ex(interp, XOTclGlobalStrings[XOTE_ALIAS_ARRAY], - AliasIndex(dsPtr, cmdName, methodName, withPer_object), - TCL_GLOBAL_ONLY); - /*fprintf(stderr, "aliasGet returns %p\n", object);*/ - Tcl_DStringFree(dsPtr); - return obj; -} - - -/********************************* - * Begin generated XOTcl commands - *********************************/ -/* -xotclCmd alias XOTclAliasCmd { - {-argName "object" -type object} - {-argName "-per-object"} - {-argName "methodName"} - {-argName "-nonleaf"} - {-argName "-objscope"} - {-argName "cmdName" -required 1 -type tclobj} -} -*/ -static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, - CONST char *methodName, int withNonleaf, int withObjscope, - Tcl_Obj *cmdName) { - Tcl_ObjCmdProc *objProc, *newObjProc = NULL; - Tcl_CmdDeleteProc *deleteProc = NULL; - AliasCmdClientData *tcd = NULL; /* make compiler happy */ - Tcl_Command cmd, newCmd = NULL; - Tcl_Namespace *nsPtr; - int flags, result; - XOTclClass *cl = (withPer_object || ! XOTclObjectIsClass(object)) ? NULL : (XOTclClass *)object; - - cmd = Tcl_GetCommandFromObj(interp, cmdName); - if (cmd == NULL) { - return XOTclVarErrMsg(interp, "cannot lookup command '", - ObjStr(cmdName), "'", (char *) NULL); - } - - cmd = GetOriginalCommand(cmd); - objProc = Tcl_Command_objProc(cmd); - - /* objProc is either ... - - 1. XOTclObjDispatch: a command representing an XOTcl object - - 2. TclObjInterpProc: a cmd standing for a - Tcl proc (including XOTcl methods), verified through - CmdIsProc() -> to be wrapped by XOTclProcAliasMethod() - - 3. XOTclForwardMethod: an XOTcl forwarder - - 4. XOTclSetterMethod: an XOTcl setter - - 5. arbitrary Tcl commands (e.g. set, ..., ::nsf::relation, ...) - - TODO GN: i think, we should use XOTclProcAliasMethod, whenever the clientData - is not 0. These are the cases, where the clientData will be freed, - when the original command is deleted. - */ - - if (withObjscope) { - newObjProc = XOTclObjscopedMethod; - } - - if (objProc == XOTclObjDispatch) { - /* - * if we register an alias for an object, we have to take care to - * handle cases, where the aliased object is destroyed and the - * alias points to nowhere. We realize this via using the object - * refcount. - */ - /*fprintf(stderr, "registering an object %p\n", tcd);*/ - - XOTclObjectRefCountIncr((XOTclObject *)Tcl_Command_objClientData(cmd)); - - /*newObjProc = XOTclProcAliasMethod;*/ - - } else if (CmdIsProc(cmd)) { - /* - * if we have a tcl proc|xotcl-method as alias, then use the - * wrapper, which will be deleted automatically when the original - * proc/method is deleted. - */ - newObjProc = XOTclProcAliasMethod; - - if (withObjscope) { - return XOTclVarErrMsg(interp, "cannot use -objscope for tcl implemented command '", - ObjStr(cmdName), "'", (char *) NULL); - } - } - - if (newObjProc) { - /* add a wrapper */ - tcd = NEW(AliasCmdClientData); - tcd->cmdName = object->cmdName; - tcd->interp = interp; /* just for deleting the associated variable */ - tcd->object = object; - tcd->class = cl ? (XOTclClass *) object : NULL; - tcd->objProc = objProc; - tcd->aliasedCmd = cmd; - tcd->clientData = Tcl_Command_objClientData(cmd); - objProc = newObjProc; - deleteProc = aliasCmdDeleteProc; - if (tcd->cmdName) {INCR_REF_COUNT(tcd->cmdName);} - } else { - /* call the command directly (must be a c-implemented command not - * depending on a volatile client data) - */ - tcd = Tcl_Command_objClientData(cmd); - } - - flags = 0; - - if (cl) { - result = XOTclAddClassMethod(interp, (XOTcl_Class *)cl, methodName, - objProc, tcd, deleteProc, flags); - nsPtr = cl->nsPtr; - } else { - result = XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, - objProc, tcd, deleteProc, flags); - nsPtr = object->nsPtr; - } - - if (result == TCL_OK) { - newCmd = FindMethod(nsPtr, methodName); - } - - if (newObjProc) { - /* - * Define the reference chain like for 'namespace import' to - * obtain automatic deletes when the original command is deleted. - */ - ImportRef *refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); - refPtr->importedCmdPtr = (Command *) newCmd; - refPtr->nextPtr = ((Command *) tcd->aliasedCmd)->importRefPtr; - ((Command *) tcd->aliasedCmd)->importRefPtr = refPtr; - tcd->aliasCmd = newCmd; - } - - if (newCmd) { - Tcl_DString ds, *dsPtr = &ds; - Tcl_DStringInit(dsPtr); - /*if (withPer_object) {Tcl_DStringAppend(dsPtr, "-per-object ", -1);}*/ - if (withObjscope) {Tcl_DStringAppend(dsPtr, "-objscope ", -1);} - Tcl_DStringAppend(dsPtr, ObjStr(cmdName), -1); - AliasAdd(interp, object->cmdName, methodName, cl == NULL, Tcl_DStringValue(dsPtr)); - Tcl_DStringFree(dsPtr); - - if (!withObjscope && withNonleaf) { - Tcl_Command_flags(newCmd) |= XOTCL_CMD_NONLEAF_METHOD; - /*fprintf(stderr, "setting aliased for cmd %p %s flags %.6x, tcd = %p\n", - newCmd,methodName,Tcl_Command_flags(newCmd), tcd);*/ - } - - result = ListMethodHandle(interp, object, cl == NULL, methodName); - } - - return result; -} - -/* -xotclCmd assertion XOTclAssertionCmd { - {-argName "object" -type object} - {-argName "assertionsubcmd" -required 1 -type "check|object-invar|class-invar"} - {-argName "arg" -required 0 -type tclobj} -} - - Make "::nsf::assertion" a cmd rather than a method, otherwise we - cannot define e.g. a "method check options {...}" to reset the check - options in case of a failed option, since assertion checking would - be applied on the sketched method already. -*/ - -static int XOTclAssertionCmd(Tcl_Interp *interp, XOTclObject *object, int subcmd, Tcl_Obj *arg) { - XOTclClass *class; - - switch (subcmd) { - case AssertionsubcmdCheckIdx: - if (arg) { - return AssertionSetCheckOptions(interp, object, arg); - } else { - return AssertionListCheckOption(interp, object); - } - break; - - case AssertionsubcmdObject_invarIdx: - if (arg) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); - AssertionSetInvariants(interp, &opt->assertions, arg); - } else { - if (object->opt && object->opt->assertions) { - Tcl_SetObjResult(interp, AssertionList(interp, object->opt->assertions->invariants)); - } - } - break; - - case AssertionsubcmdClass_invarIdx: - class = (XOTclClass *)object; - if (arg) { - XOTclClassOpt *opt = XOTclRequireClassOpt(class); - AssertionSetInvariants(interp, &opt->assertions, arg); - } else { - if (class->opt && class->opt->assertions) { - Tcl_SetObjResult(interp, AssertionList(interp, class->opt->assertions->invariants)); - } - } - } - return TCL_OK; -} - -/* -xotclCmd configure XOTclConfigureCmd { - {-argName "configureoption" -required 1 -type "filter|softrecreate|objectsystems|keepinitcmd|checkresult"} - {-argName "value" -required 0 -type tclobj} -} -*/ -static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *valueObj) { - int bool; - - if (configureoption == ConfigureoptionObjectsystemsIdx) { - XOTclObjectSystem *osPtr; - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - - for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { - Tcl_Obj *osObj = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, osObj, osPtr->rootClass->object.cmdName); - Tcl_ListObjAppendElement(interp, osObj, osPtr->rootMetaClass->object.cmdName); - Tcl_ListObjAppendElement(interp, list, osObj); - } - Tcl_SetObjResult(interp, list); - return TCL_OK; - } - - if (valueObj) { - int result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); - if (result != TCL_OK) - return result; - } - - switch (configureoption) { - case ConfigureoptionFilterIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doFilters)); - if (valueObj) - RUNTIME_STATE(interp)->doFilters = bool; - break; - - case ConfigureoptionSoftrecreateIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doSoftrecreate)); - if (valueObj) - RUNTIME_STATE(interp)->doSoftrecreate = bool; - break; - - case ConfigureoptionKeepinitcmdIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doKeepinitcmd)); - if (valueObj) - RUNTIME_STATE(interp)->doKeepinitcmd = bool; - break; - - case ConfigureoptionCheckresultsIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doCheckResults)); - if (valueObj) - RUNTIME_STATE(interp)->doCheckResults = bool; - break; - - case ConfigureoptionCheckargumentsIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (RUNTIME_STATE(interp)->doCheckArguments)); - if (valueObj) - RUNTIME_STATE(interp)->doCheckArguments = bool; - break; - } - return TCL_OK; -} - - -/* -xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { - {-argName "rootClass" -required 1 -type tclobj} - {-argName "rootMetaClass" -required 1 -type tclobj} - {-argName "systemMethods" -required 0 -type tclobj} -} -*/ -static int -XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *Object, Tcl_Obj *Class, Tcl_Obj *systemMethodsObj) { - XOTclClass *theobj; - XOTclClass *thecls; - XOTclObjectSystem *osPtr = NEW(XOTclObjectSystem); - - memset(osPtr, 0, sizeof(XOTclObjectSystem)); - - if (systemMethodsObj) { - int oc, i, idx, result; - Tcl_Obj **ov; - - if ((result = Tcl_ListObjGetElements(interp, systemMethodsObj, &oc, &ov)) == TCL_OK) { - if (oc % 2) { - ObjectSystemFree(interp, osPtr); - return XOTclErrMsg(interp, "System methods must be provided as pairs", TCL_STATIC); - } - for (i=0; imethods[idx] = ov[i+1]; - INCR_REF_COUNT(osPtr->methods[idx]); - } - } else { - ObjectSystemFree(interp, osPtr); - return XOTclErrMsg(interp, "Provided system methods are not a proper list", TCL_STATIC); - } - } - /* - Create a basic object system with the basic root class Object and - the basic metaclass Class, and store them in the RUNTIME STATE if - successful - */ - theobj = PrimitiveCCreate(interp, Object, NULL); - thecls = PrimitiveCCreate(interp, Class, NULL); - /* fprintf(stderr, "CreateObjectSystem created base classes \n"); */ - -#if defined(PROFILE) - XOTclProfileInit(interp); -#endif - - /* check whether Object and Class creation was successful */ - if (!theobj || !thecls) { - int i; - - if (thecls) PrimitiveCDestroy((ClientData) thecls); - if (theobj) PrimitiveCDestroy((ClientData) theobj); - - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - DECR_REF_COUNT(XOTclGlobalObjs[i]); - } - FREE(Tcl_Obj **, XOTclGlobalObjs); - FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); - ObjectSystemFree(interp, osPtr); - - return XOTclErrMsg(interp, "Creation of object system failed", TCL_STATIC); - } - - theobj->osPtr = osPtr; - thecls->osPtr = osPtr; - osPtr->rootClass = theobj; - osPtr->rootMetaClass = thecls; - - theobj->object.flags |= XOTCL_IS_ROOT_CLASS; - thecls->object.flags |= XOTCL_IS_ROOT_META_CLASS; - - ObjectSystemAdd(interp, osPtr); - - AddInstance((XOTclObject*)theobj, thecls); - AddInstance((XOTclObject*)thecls, thecls); - AddSuper(thecls, theobj); - - return TCL_OK; -} - -/* -xotclCmd deprecated XOTclDeprecatedCmd { - {-argName "what" -required 1} - {-argName "oldCmd" -required 1} - {-argName "newCmd" -required 0} -} -*/ -/* - * Prints a msg to the screen that oldCmd is deprecated - * optinal: give a new cmd - */ -static int -XOTclDeprecatedCmd(Tcl_Interp *interp, CONST char *what, CONST char *oldCmd, CONST char *newCmd) { - fprintf(stderr, "**\n**\n** The %s <%s> is deprecated.\n", what, oldCmd); - if (newCmd) - fprintf(stderr, "** Use <%s> instead.\n", newCmd); - fprintf(stderr, "**\n"); - return TCL_OK; -} - -/* -xotclCmd dispatch XOTclDispatchCmd { - {-argName "object" -required 1 -type object} - {-argName "-objscope"} - {-argName "command" -required 1 -type tclobj} - {-argName "args" -type args} -} -*/ -static int -XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, - Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]) { - int result; - CONST char *methodName = ObjStr(command); - register CONST char *n = methodName + strlen(methodName); - - /* fprintf(stderr, "Dispatch obj=%s, o=%p cmd m='%s'\n", objectName(object), object, methodName);*/ - - /* - * If the specified method is a fully qualified cmd name like - * e.g. ::nsf::cmd::Class::alloc, this method is called on the - * specified , no matter whether it was registered on - * it. - */ - - /*search for last '::'*/ - while ((*n != ':' || *(n-1) != ':') && n-1 > methodName) {n--; } - if (*n == ':' && n > methodName && *(n-1) == ':') {n--;} - - if ((n-methodName)>1 || *methodName == ':') { - Tcl_DString parentNSName, *dsp = &parentNSName; - Tcl_Namespace *nsPtr; - Tcl_Command cmd, importedCmd; - CONST char *parentName, *tail = n+2; - DSTRING_INIT(dsp); - - /* - * We have an absolute name. We assume, the name is the name of a - * tcl command, that will be dispatched. If "withObjscope is - * specified, a callstack frame is pushed to make instvars - * accessible for the command. - */ - - /*fprintf(stderr, "colon name %s\n", tail);*/ - if (n-methodName != 0) { - Tcl_DStringAppend(dsp, methodName, (n-methodName)); - parentName = Tcl_DStringValue(dsp); - nsPtr = Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); - DSTRING_FREE(dsp); - } else { - nsPtr = Tcl_FindNamespace(interp, "::", (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); - } - if (!nsPtr) { - return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", - methodName, "'", (char *) NULL); - } - cmd = FindMethod(nsPtr, tail); - if (cmd && (importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } - /*fprintf(stderr, " .... findmethod '%s' in %s returns %p\n", tail, nsPtr->fullName, cmd);*/ - - if (cmd == NULL) { - return XOTclVarErrMsg(interp, "cannot lookup command '", - tail, "'", (char *) NULL); - } - { Tcl_CallFrame frame, *framePtr = &frame; - - if (withObjscope) { - XOTcl_PushFrameObj(interp, object, framePtr); - } - /* - * Since we know, that we are always called with a full argument - * vector, we can include the cmd name in the objv by using - * nobjv-1; this way, we avoid a memcpy() - */ - - result = MethodDispatch((ClientData)object, interp, - nobjc+1, nobjv-1, cmd, object, - NULL /*XOTclClass *cl*/, tail, - XOTCL_CSC_TYPE_PLAIN); - if (withObjscope) { - XOTcl_PopFrameObj(interp, framePtr); - } - } - } else { - /* - * No colons in command name, use method from the precedence - * order, with filters etc. -- strictly speaking unneccessary, - * since we could dispatch the method also without - * XOTclDispatchCmd(), but it can be used to invoke protected - * methods. 'withObjscope' is here a no-op. - */ - Tcl_Obj *arg; - Tcl_Obj *CONST *objv; - - if (nobjc >= 1) { - arg = nobjv[0]; - objv = nobjv+1; - } else { - arg = NULL; - objv = NULL; - } - result = XOTclCallMethodWithArgs((ClientData)object, interp, command, arg, - nobjc, objv, XOTCL_CM_NO_UNKNOWN); - } - - return result; -} - -/* -xotclCmd colon XOTclColonCmd { - {-argName "args" -type allargs} -} -*/ -static int XOTclColonCmd(Tcl_Interp *interp, int nobjc, Tcl_Obj *CONST nobjv[]) { - XOTclObject *self = GetSelfObj(interp); - if (!self) { - return XOTclVarErrMsg(interp, "Cannot resolve 'self', probably called outside the context of an XOTcl Object", - (char *) NULL); - } - /*fprintf(stderr, "Colon dispatch %s on %s\n", ObjStr(nobjv[0]), objectName(self));*/ - - return ObjectDispatch(self, interp, nobjc, nobjv, XOTCL_CM_NO_SHIFT); -} - -/* -xotclCmd existsvar XOTclExistsVarCmd { - {-argName "object" -required 1 -type object} - {-argName "var" -required 1} -} -*/ -static int XOTclExistsVarCmd(Tcl_Interp *interp, XOTclObject *object, CONST char *varName) { - if (CheckVarName(interp, varName) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), varExists(interp, object, varName, NULL, 1, 1)); - return TCL_OK; -} - - -/* -xotclCmd finalize XOTclFinalizeObjCmd { -} -*/ -/* - * ::nsf::finalize command - */ -static int -XOTclFinalizeObjCmd(Tcl_Interp *interp) { - int result; - - /*fprintf(stderr, "+++ call tcl-defined exit handler\n"); */ - -#if defined(PROFILE) - XOTclProfilePrintData(interp); -#endif - /* - * evaluate user-defined exit handler - */ - result = Tcl_Eval(interp, "::nsf::__exitHandler"); - - if (result != TCL_OK) { - fprintf(stderr, "User defined exit handler contains errors!\n" - "Error in line %d: %s\nExecution interrupted.\n", - Tcl_GetErrorLine(interp), ObjStr(Tcl_GetObjResult(interp))); - } - - ObjectSystemsCleanup(interp); - -#ifdef DO_CLEANUP - /*fprintf(stderr, "CLEANUP TOP NS\n");*/ - Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "", 1); - Tcl_DeleteNamespace(RUNTIME_STATE(interp)->XOTclClassesNS); - Tcl_DeleteNamespace(RUNTIME_STATE(interp)->XOTclNS); -#endif - - return TCL_OK; -} - -/* -xotclCmd forward XOTclForwardCmd { - {-argName "object" -required 1 -type object} - {-argName "-per-object"} - {-argName "method" -required 1 -type tclobj} - {-argName "-default" -nrargs 1 -type tclobj} - {-argName "-earlybinding"} - {-argName "-methodprefix" -nrargs 1 -type tclobj} - {-argName "-objscope"} - {-argName "-onerror" -nrargs 1 -type tclobj} - {-argName "-verbose"} - {-argName "target" -type tclobj} - {-argName "args" -type args} -} -*/ -static int XOTclForwardCmd(Tcl_Interp *interp, - XOTclObject *object, int withPer_object, - Tcl_Obj *methodObj, - Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, - int withObjscope, Tcl_Obj *withOnerror, int withVerbose, - Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]) { - ForwardCmdClientData *tcd = NULL; - int result; - - result = forwardProcessOptions(interp, methodObj, - withDefault, withEarlybinding, withMethodprefix, - withObjscope, withOnerror, withVerbose, - target, nobjc, nobjv, &tcd); - if (result == TCL_OK) { - CONST char *methodName = NSTail(ObjStr(methodObj)); - XOTclClass *cl = - (withPer_object || ! XOTclObjectIsClass(object)) ? - NULL : (XOTclClass *)object; - - tcd->object = object; - if (cl == NULL) { - result = XOTclAddObjectMethod(interp, (XOTcl_Object *)object, methodName, - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc, 0); - } else { - result = XOTclAddClassMethod(interp, (XOTcl_Class*)cl, methodName, - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc, 0); - } - if (result == TCL_OK) { - result = ListMethodHandle(interp, object, cl == NULL, methodName); - } - } - - if (result != TCL_OK) { - forwardCmdDeleteProc((ClientData)tcd); - } - return result; -} - -/* -xotclCmd importvar XOTclImportvarCmd { - {-argName "object" -type object} - {-argName "args" -type args} -} -*/ -static int -XOTclImportvar(Tcl_Interp *interp, XOTclObject *object, const char *cmdName, int objc, Tcl_Obj *CONST objv[]) { - int i, result = TCL_OK; - - for (i=0; iparsedParamPtr) { - /*fprintf(stderr, " %s invalidate %p\n", className(cl), cl->parsedParamPtr);*/ - ParsedParamFree(cl->parsedParamPtr); - cl->parsedParamPtr = NULL; - } - return TCL_OK; -} - -/* -xotclCmd is XOTclIsCmd { - {-argName "-complain"} - {-argName "constraint" -required 1 -type tclobj} - {-argName "value" -required 1 -type tclobj} -} -*/ -static int XOTclIsCmd(Tcl_Interp *interp, int withComplain, Tcl_Obj *constraintObj, Tcl_Obj *valueObj) { - XOTclParam *paramPtr = NULL; - int result; - - result = Parametercheck(interp, constraintObj, valueObj, "value:", 1, ¶mPtr); - - if (paramPtr == NULL) { - /* - * We could not convert the arguments. Even with noComplain, we - * report the invalid converter spec as exception - */ - return TCL_ERROR; - } - - if (paramPtr->converter == convertViaCmd - && (withComplain == 0 || result == TCL_OK)) { - Tcl_ResetResult(interp); - } - - if (withComplain == 0) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); - result = TCL_OK; - } else if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } - - return result; -} - -/* -xotclCmd isobject XOTclIsObjectCmd { - {-argName "object" -required 1 -type tclobj} -} -*/ -static int XOTclIsObjectCmd(Tcl_Interp *interp, Tcl_Obj *valueObj) { - XOTclObject *object; - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), GetObjectFromObj(interp, valueObj, &object) == TCL_OK); - return TCL_OK; -} - - -/* -xotclCmd method XOTclMethodCmd { - {-argName "object" -required 1 -type object} - {-argName "-inner-namespace"} - {-argName "-per-object"} - {-argName "-public"} - {-argName "name" -required 1 -type tclobj} - {-argName "args" -required 1 -type tclobj} - {-argName "body" -required 1 -type tclobj} - {-argName "-precondition" -nrargs 1 -type tclobj} - {-argName "-postcondition" -nrargs 1 -type tclobj} -} -*/ -static int XOTclMethodCmd(Tcl_Interp *interp, XOTclObject *object, - int withInner_namespace, int withPer_object, int withPublic, - Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { - XOTclClass *cl = - (withPer_object || ! XOTclObjectIsClass(object)) ? - NULL : (XOTclClass *)object; - - if (cl == 0) { - requireObjNamespace(interp, object); - } - return MakeMethod(interp, object, cl, nameObj, args, body, - withPrecondition, withPostcondition, - withPublic, withInner_namespace); -} - -/* -xotclCmd methodproperty XOTclMethodPropertyCmd { - {-argName "object" -required 1 -type object} - {-argName "-per-object"} - {-argName "methodName" -required 1 -type tclobj} - {-argName "methodproperty" -required 1 -type "class-only|protected|redefine-protected|returns|slotobj"} - {-argName "value" -type tclobj} -} -*/ -static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, - Tcl_Obj *methodObj, int methodproperty, Tcl_Obj *valueObj) { - CONST char *methodName = ObjStr(methodObj); - Tcl_Command cmd = NULL; - - /*fprintf(stderr, "methodProperty for method '%s' prop %d value %s\n", - methodName, methodproperty, valueObj ? ObjStr(valueObj) : "NULL");*/ - - if (*methodName == ':') { - cmd = Tcl_GetCommandFromObj(interp, methodObj); - if (!cmd) { - return XOTclVarErrMsg(interp, "Cannot lookup object method '", - methodName, "' for object ", objectName(object), - (char *) NULL); - } - } else { - XOTclClass *cl; - - if (withPer_object) { - cl = NULL; - } else { - cl = XOTclObjectIsClass(object) ? (XOTclClass *)object : NULL; - } - - if (cl == NULL) { - if (object->nsPtr) - cmd = FindMethod(object->nsPtr, methodName); - if (!cmd) { - return XOTclVarErrMsg(interp, "Cannot lookup object method '", - methodName, "' for object ", objectName(object), - (char *) NULL); - } - } else { - if (cl->nsPtr) - cmd = FindMethod(cl->nsPtr, methodName); - if (!cmd) - return XOTclVarErrMsg(interp, "Cannot lookup method '", - methodName, "' from class ", objectName(object), - (char *) NULL); - } - } - - switch (methodproperty) { - case MethodpropertyClass_onlyIdx: /* fall through */ - case MethodpropertyProtectedIdx: /* fall through */ - case MethodpropertyRedefine_protectedIdx: - { - int flag = methodproperty == MethodpropertyProtectedIdx ? - XOTCL_CMD_PROTECTED_METHOD : - methodproperty == MethodpropertyRedefine_protectedIdx ? - XOTCL_CMD_REDEFINE_PROTECTED_METHOD - :XOTCL_CMD_CLASS_ONLY_METHOD; - - if (valueObj) { - int bool, result; - result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); - if (result != TCL_OK) { - return result; - } - if (bool) { - Tcl_Command_flags(cmd) |= flag; - } else { - Tcl_Command_flags(cmd) &= ~flag; - } - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (Tcl_Command_flags(cmd) & flag) != 0); - break; - } - case MethodpropertySlotobjIdx: - case MethodpropertyReturnsIdx: - { - XOTclParamDefs *paramDefs; - Tcl_Obj **objPtr; - - if (valueObj == NULL && methodproperty == MethodpropertySlotobjIdx) { - return XOTclVarErrMsg(interp, "Option 'slotobj' of method ", methodName, - " requires argument '", (char *) NULL); - } - - paramDefs = ParamDefsGet(cmd); - /*fprintf(stderr, "MethodProperty, ParamDefsGet cmd %p paramDefs %p returns %p\n", - cmd, paramDefs, paramDefs?paramDefs->returns:NULL);*/ - - if (paramDefs == NULL) { - paramDefs = ParamDefsNew(); - ParamDefsStore(interp, cmd, paramDefs); - /*fprintf(stderr, "new param defs %p for cmd %p %s\n", paramDefs, cmd, methodName);*/ - } - objPtr = methodproperty == MethodpropertySlotobjIdx ? ¶mDefs->slotObj : ¶mDefs->returns; - if (valueObj == NULL) { - /* must be a returns query */ - Tcl_SetObjResult(interp, *objPtr ? *objPtr : XOTclGlobalObjs[XOTE_EMPTY]); - } else { - const char *valueString = ObjStr(valueObj); - /* Set a new value; if there is already a value, free it */ - if (*objPtr) { - DECR_REF_COUNT(*objPtr); - } - if (*valueString == '\0') { - /* set the value to NULL */ - *objPtr = NULL; - } else { - *objPtr = valueObj; - INCR_REF_COUNT(*objPtr); - } - } - break; - } - } - - return TCL_OK; -} - -/* -xotclCmd my XOTclMyCmd { - {-argName "-local"} - {-argName "method" -required 1 -type tclobj} - {-argName "args" -type args} -} -*/ -static int XOTclMyCmd(Tcl_Interp *interp, int withLocal, Tcl_Obj *methodObj, int nobjc, Tcl_Obj *CONST nobjv[]) { - XOTclObject *self = GetSelfObj(interp); - int result; - - if (!self) { - return XOTclVarErrMsg(interp, "Cannot resolve 'self', probably called outside the context of an XOTcl Object", - (char *) NULL); - } - - if (withLocal) { - XOTclClass *cl = self->cl; - CONST char *methodName = ObjStr(methodObj); - Tcl_Command cmd = FindMethod(cl->nsPtr, methodName); - if (cmd == NULL) { - return XOTclVarErrMsg(interp, objectName(self), - ": unable to dispatch local method '", - methodName, "' in class ", className(cl), - (char *) NULL); - } - result = MethodDispatch((ClientData)self, interp, nobjc+2, nobjv, cmd, self, cl, - methodName, 0); - } else { - result = callMethod((ClientData)self, interp, methodObj, nobjc+2, nobjv, 0); - } - return result; -} - -/* -xotclCmd namespace_copycmds XOTclNSCopyCmds { - {-argName "fromNs" -required 1 -type tclobj} - {-argName "toNs" -required 1 -type tclobj} -} -*/ -static int XOTclNSCopyCmds(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs) { - Tcl_Command cmd; - Tcl_Obj *newFullCmdName, *oldFullCmdName; - CONST char *newName, *oldName, *name; - Tcl_Namespace *fromNsPtr, *toNsPtr; - Tcl_HashTable *cmdTable; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - XOTclObject *object; - XOTclClass *cl; - int fromClassNS; - - fromNsPtr = ObjFindNamespace(interp, fromNs); - if (!fromNsPtr) - return TCL_OK; - - name = ObjStr(fromNs); - - /* check, if we work on an object or class namespace */ - object = GetObjectFromNsName(interp, name, &fromClassNS); - - if (object == NULL) { - return XOTclVarErrMsg(interp, "argument 1 '", ObjStr(fromNs), "' is not an object", - NULL); - } - - cl = fromClassNS ? (XOTclClass *)object : NULL; - - /* object = XOTclpGetObject(interp, ObjStr(fromNs));*/ - - toNsPtr = ObjFindNamespace(interp, toNs); - if (!toNsPtr) - return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ", - ObjStr(toNs), " does not exist", (char *) NULL); - /* - * copy all procs & commands in the ns - */ - cmdTable = Tcl_Namespace_cmdTable(fromNsPtr); - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - while (hPtr) { - /*fprintf(stderr, "copy cmdTable = %p, first=%p\n", cmdTable, hPtr);*/ - name = Tcl_GetHashKey(cmdTable, hPtr); - - /* - * construct full cmd names - */ - newFullCmdName = Tcl_NewStringObj(toNsPtr->fullName, -1); - oldFullCmdName = Tcl_NewStringObj(fromNsPtr->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); - - /*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 scripted method 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 (CmdIsProc(cmd)) { - Proc *procPtr = (Proc*) Tcl_Command_objClientData(cmd); - Tcl_Obj *arglistObj; - int result; - - /* - * Build a list containing the arguments of the proc - */ - result = ListCmdParams(interp, cmd, oldName, 0); - if (result != TCL_OK) { - return result; - } - - arglistObj = Tcl_GetObjResult(interp); - INCR_REF_COUNT(arglistObj); - - if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { - Tcl_DString ds, *dsPtr = &ds; - - if (cl) { - /* XOTcl class-methods */ - XOTclProcAssertion *procs; - procs = cl->opt ? AssertionFindProcs(cl->opt->assertions, name) : 0; - - DSTRING_INIT(dsPtr); - Tcl_DStringAppendElement(dsPtr, "::nsf::method"); - Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(toNsPtr->fullName)); - 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 { - /* XOTcl object-methods */ - XOTclObject *object = XOTclpGetObject(interp, fromNsPtr->fullName); - XOTclProcAssertion *procs; - - if (object) { - procs = object->opt ? AssertionFindProcs(object->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); - } - - DSTRING_INIT(dsPtr); - Tcl_DStringAppendElement(dsPtr, "::nsf::method"); - Tcl_DStringAppendElement(dsPtr, toNsPtr->fullName); - Tcl_DStringAppendElement(dsPtr, "-per-object"); - Tcl_DStringAppendElement(dsPtr, name); - Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); - Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); - if (procs) { - XOTclRequireObjectOpt(object); - 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); - } - } 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_CMD_NONLEAF_METHOD) { - /* if client data is 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_CMD_NONLEAF_METHOD) { - Tcl_CreateCommand(interp, newName, Tcl_Command_proc(cmd), - Tcl_Command_clientData(cmd), deleteProc); - } - } - } - } - hPtr = Tcl_NextHashEntry(&hSrch); - DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); - } - return TCL_OK; -} - -/* -xotclCmd namespace_copyvars XOTclNSCopyVars { - {-argName "fromNs" -required 1 -type tclobj} - {-argName "toNs" -required 1 -type tclobj} -} -*/ -static int -XOTclNSCopyVars(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs) { - Tcl_Namespace *fromNsPtr, *toNsPtr; - Var *varPtr = NULL; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - TclVarHashTable *varTable; - XOTclObject *object, *destObject; - CONST char *destFullName; - Tcl_Obj *destFullNameObj; - Tcl_CallFrame frame, *framePtr = &frame; - Tcl_Obj *varNameObj = NULL; - - fromNsPtr = ObjFindNamespace(interp, fromNs); - /*fprintf(stderr, "copyvars from %s to %s, ns=%p\n", ObjStr(objv[1]), ObjStr(objv[2]), ns);*/ - - if (fromNsPtr) { - toNsPtr = ObjFindNamespace(interp, toNs); - if (!toNsPtr) - return XOTclVarErrMsg(interp, "CopyVars: Destination namespace ", - ObjStr(toNs), " does not exist", (char *) NULL); - - object = XOTclpGetObject(interp, ObjStr(fromNs)); - destFullName = toNsPtr->fullName; - destFullNameObj = Tcl_NewStringObj(destFullName, -1); - INCR_REF_COUNT(destFullNameObj); - varTable = Tcl_Namespace_varTable(fromNsPtr); - Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, toNsPtr, 0); - } else { - XOTclObject *newObject; - if (GetObjectFromObj(interp, fromNs, &object) != TCL_OK) { - return XOTclVarErrMsg(interp, "CopyVars: Origin object/namespace ", - ObjStr(fromNs), " does not exist", (char *) NULL); - } - if (GetObjectFromObj(interp, toNs, &newObject) != TCL_OK) { - return XOTclVarErrMsg(interp, "CopyVars: Destination object/namespace ", - ObjStr(toNs), " does not exist", (char *) NULL); - } - varTable = object->varTable; - destFullNameObj = newObject->cmdName; - destFullName = ObjStr(destFullNameObj); - } - - destObject = XOTclpGetObject(interp, destFullName); - - /* copy all vars in the ns */ - hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : NULL; - while (hPtr) { - - 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 (object) { - /* fprintf(stderr, "copy in obj %s var %s val '%s'\n", objectName(object), ObjStr(varNameObj), - ObjStr(valueOfVar(Tcl_Obj, varPtr, objPtr)));*/ - - /* can't rely on "set", if there are multiple object systems */ - setInstVar(interp, destObject, varNameObj, valueOfVar(Tcl_Obj, varPtr, objPtr)); - } 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); - - if (TclIsVarScalar(eltVar)) { - if (object) { - XOTcl_ObjSetVar2((XOTcl_Object*)destObject, interp, varNameObj, eltNameObj, - valueOfVar(Tcl_Obj, eltVar, objPtr), 0); - } 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 (fromNsPtr) { - DECR_REF_COUNT(destFullNameObj); - Tcl_PopCallFrame(interp); - } - return TCL_OK; -} - -/* -xotclCmd __qualify XOTclQualifyObjCmd { - {-argName "name" -required 1 -type tclobj} -} -*/ -static int XOTclQualifyObjCmd(Tcl_Interp *interp, Tcl_Obj *nameObj) { - CONST char *nameString = ObjStr(nameObj); - - if (isAbsolutePath(nameString)) { - Tcl_SetObjResult(interp, nameObj); - } else { - Tcl_SetObjResult(interp, NameInNamespaceObj(interp, nameString, callingNameSpace(interp))); - } - return TCL_OK; -} - -/* -xotclCmd relation XOTclRelationCmd { - {-argName "object" -type object} - {-argName "relationtype" -required 1 -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"} - {-argName "value" -required 0 -type tclobj} -} -*/ -static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, - int relationtype, Tcl_Obj *valueObj) { - int oc; Tcl_Obj **ov; - XOTclObject *nObject = NULL; - XOTclClass *cl = NULL; - XOTclObjectOpt *objopt = NULL; - XOTclClassOpt *clopt = NULL, *nclopt = NULL; - int i; - - /* fprintf(stderr, "XOTclRelationCmd %s rel=%d val='%s'\n", - objectName(object), relationtype, valueObj ? ObjStr(valueObj) : "NULL");*/ - - if (relationtype == RelationtypeClass_mixinIdx || - relationtype == RelationtypeClass_filterIdx) { - if (XOTclObjectIsClass(object)) { - cl = (XOTclClass *)object; - } else { - /* fall back to per-object case */ - relationtype = (relationtype == RelationtypeClass_mixinIdx) ? - RelationtypeObject_mixinIdx : - RelationtypeObject_filterIdx ; - } - } - - switch (relationtype) { - case RelationtypeObject_filterIdx: - case RelationtypeObject_mixinIdx: - if (valueObj == NULL) { - objopt = object->opt; - switch (relationtype) { - case RelationtypeObject_mixinIdx: - return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; - case RelationtypeObject_filterIdx: - return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; - } - } - if (Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK) - return TCL_ERROR; - objopt = XOTclRequireObjectOpt(object); - break; - - case RelationtypeClass_mixinIdx: - case RelationtypeClass_filterIdx: - - if (valueObj == NULL) { - clopt = cl->opt; - switch (relationtype) { - case RelationtypeClass_mixinIdx: - return clopt ? MixinInfo(interp, clopt->classmixins, NULL, 1, NULL) : TCL_OK; - case RelationtypeClass_filterIdx: - return objopt ? FilterInfo(interp, clopt->classfilters, NULL, 1, 0) : TCL_OK; - } - } - - if (Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK) - return TCL_ERROR; - clopt = XOTclRequireClassOpt(cl); - break; - - case RelationtypeSuperclassIdx: - if (!XOTclObjectIsClass(object)) - return XOTclObjErrType(interp, object->cmdName, "class", "relationtype"); - cl = (XOTclClass *)object; - if (valueObj == NULL) { - return ListSuperclasses(interp, cl, NULL, 0); - } - if (Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK) - return TCL_ERROR; - return SuperclassAdd(interp, cl, oc, ov, valueObj, cl->object.cl); - - case RelationtypeClassIdx: - if (valueObj == NULL) { - Tcl_SetObjResult(interp, object->cl->object.cmdName); - return TCL_OK; - } - GetClassFromObj(interp, valueObj, &cl, object->cl); - if (!cl) return XOTclErrBadVal(interp, "class", "a class", objectName(object)); - return changeClass(interp, object, cl); - - case RelationtypeRootclassIdx: - { - XOTclClass *metaClass; - - if (!XOTclObjectIsClass(object)) - return XOTclObjErrType(interp, object->cmdName, "class", "relationtype"); - cl = (XOTclClass *)object; - - if (valueObj == NULL) { - return XOTclVarErrMsg(interp, "metaclass must be specified as third argument", - (char *) NULL); - } - GetClassFromObj(interp, valueObj, &metaClass, NULL); - if (!metaClass) return XOTclObjErrType(interp, valueObj, "class", ""); - - cl->object.flags |= XOTCL_IS_ROOT_CLASS; - metaClass->object.flags |= XOTCL_IS_ROOT_META_CLASS; - - return TCL_OK; - - /* todo: - need to remove these properties? - allow to delete a classystem at runtime? - */ - } - } - - switch (relationtype) { - case RelationtypeObject_mixinIdx: - { - XOTclCmdList *newMixinCmdList = NULL; - - for (i = 0; i < oc; i++) { - if (MixinAdd(interp, &newMixinCmdList, ov[i], object->cl->object.cl) != TCL_OK) { - CmdListRemoveList(&newMixinCmdList, GuardDel); - return TCL_ERROR; - } - } - - 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(object->id, clopt->isObjectMixinOf); - if (del) { - /* fprintf(stderr, "Removing object %s from isObjectMixinOf of class %s\n", - objectName(object), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */ - del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } - } - } - CmdListRemoveList(&objopt->mixins, GuardDel); - } - - object->flags &= ~XOTCL_MIXIN_ORDER_VALID; - /* - * since mixin procs may be used as filters -> we have to invalidate - */ - object->flags &= ~XOTCL_FILTER_ORDER_VALID; - - /* - * now add the specified mixins - */ - objopt->mixins = newMixinCmdList; - for (i = 0; i < oc; i++) { - Tcl_Obj *ocl = NULL; - - /* fprintf(stderr, "Added to mixins of %s: %s\n", objectName(object), ObjStr(ov[i])); */ - Tcl_ListObjIndex(interp, ov[i], 0, &ocl); - GetObjectFromObj(interp, ocl, &nObject); - if (nObject) { - /* fprintf(stderr, "Registering object %s to isObjectMixinOf of class %s\n", - objectName(object), objectName(nObject)); */ - nclopt = XOTclRequireClassOpt((XOTclClass*)nObject); - CmdListAdd(&nclopt->isObjectMixinOf, object->id, NULL, /*noDuplicates*/ 1); - } /* else fprintf(stderr, "Problem registering %s as a mixinof of %s\n", - ObjStr(ov[i]), className(cl)); */ - } - - MixinComputeDefined(interp, object); - FilterComputeDefined(interp, object); - break; - } - - case RelationtypeObject_filterIdx: - - if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); - - object->flags &= ~XOTCL_FILTER_ORDER_VALID; - for (i = 0; i < oc; i ++) { - if (FilterAdd(interp, &objopt->filters, ov[i], object, 0) != TCL_OK) - return TCL_ERROR; - } - /*FilterComputeDefined(interp, object);*/ - break; - - case RelationtypeClass_mixinIdx: - { - XOTclCmdList *newMixinCmdList = NULL; - - for (i = 0; i < oc; i++) { - if (MixinAdd(interp, &newMixinCmdList, ov[i], cl->object.cl) != TCL_OK) { - CmdListRemoveList(&newMixinCmdList, GuardDel); - return TCL_ERROR; - } - } - if (clopt->classmixins) { - RemoveFromClassMixinsOf(cl->object.id, clopt->classmixins); - CmdListRemoveList(&clopt->classmixins, GuardDel); - } - - MixinInvalidateObjOrders(interp, cl); - /* - * since mixin procs may be used as filters, - * we have to invalidate the filters as well - */ - FilterInvalidateObjOrders(interp, cl); - clopt->classmixins = newMixinCmdList; - for (i = 0; i < oc; i++) { - Tcl_Obj *ocl = NULL; - /* fprintf(stderr, "Added to classmixins of %s: %s\n", - className(cl), ObjStr(ov[i])); */ - - Tcl_ListObjIndex(interp, ov[i], 0, &ocl); - GetObjectFromObj(interp, ocl, &nObject); - if (nObject) { - /* fprintf(stderr, "Registering class %s to isClassMixinOf of class %s\n", - className(cl), objectName(nObject)); */ - nclopt = XOTclRequireClassOpt((XOTclClass*) nObject); - CmdListAdd(&nclopt->isClassMixinOf, cl->object.id, NULL, /*noDuplicates*/ 1); - } /* else fprintf(stderr, "Problem registering %s as a class-mixin of %s\n", - ObjStr(ov[i]), className(cl)); */ - } - break; - } - - case RelationtypeClass_filterIdx: - - if (clopt->classfilters) CmdListRemoveList(&clopt->classfilters, GuardDel); - - FilterInvalidateObjOrders(interp, cl); - for (i = 0; i < oc; i ++) { - if (FilterAdd(interp, &clopt->classfilters, ov[i], 0, cl) != TCL_OK) - return TCL_ERROR; - } - break; - - } - return TCL_OK; -} - -/* -xotclCmd current XOTclCurrentCmd { - {-argName "currentoption" -required 0 -type "proc|method|object|class|activelevel|args|activemixin|calledproc|calledmethod|calledclass|callingproc|callingmethod|callingclass|callinglevel|callingobject|filterreg|isnextcall|next"} -} -*/ -static int XOTclCurrentCmd(Tcl_Interp *interp, int selfoption) { - XOTclObject *object = GetSelfObj(interp); - XOTclCallStackContent *cscPtr; - int result = TCL_OK; - - /*fprintf(stderr, "getSelfObj returns %p\n", object); tcl85showStack(interp);*/ - - if (selfoption == 0 || selfoption == CurrentoptionObjectIdx) { - if (object) { - Tcl_SetObjResult(interp, object->cmdName); - return TCL_OK; - } else { - return XOTclVarErrMsg(interp, "No current object", (char *) NULL); - } - } - - if (!object && selfoption != CurrentoptionCallinglevelIdx) { - return XOTclVarErrMsg(interp, "No current object", (char *) NULL); - } - - switch (selfoption) { - case CurrentoptionMethodIdx: /* fall through */ - case CurrentoptionProcIdx: - cscPtr = CallStackGetTopFrame(interp, NULL); - if (cscPtr) { - CONST char *procName = Tcl_GetCommandName(interp, cscPtr->cmdPtr); - Tcl_SetResult(interp, (char *)procName, TCL_VOLATILE); - } else { - return XOTclVarErrMsg(interp, "Can't find proc", (char *) NULL); - } - break; - - case CurrentoptionClassIdx: /* class subcommand */ - cscPtr = CallStackGetTopFrame(interp, NULL); - Tcl_SetObjResult(interp, cscPtr->cl ? cscPtr->cl->object.cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - break; - - case CurrentoptionActivelevelIdx: - Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); - break; - - case CurrentoptionArgsIdx: { - int nobjc; - Tcl_Obj **nobjv; - Tcl_CallFrame *topFramePtr; - - cscPtr = CallStackGetTopFrame(interp, &topFramePtr); - if (cscPtr->objv) { - nobjc = cscPtr->objc; - nobjv = cscPtr->objv; - } else { - nobjc = Tcl_CallFrame_objc(topFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(topFramePtr); - } - Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1)); - break; - } - - case CurrentoptionActivemixinIdx: { - XOTclObject *object = NULL; - if (RUNTIME_STATE(interp)->cmdPtr) { - object = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); - } - Tcl_SetObjResult(interp, object ? object->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - break; - } - - case CurrentoptionCalledprocIdx: - case CurrentoptionCalledmethodIdx: - cscPtr = CallStackFindActiveFilter(interp); - if (cscPtr) { - Tcl_SetObjResult(interp, cscPtr->filterStackEntry->calledProc); - } else { - result = XOTclVarErrMsg(interp, "called from outside of a filter", - (char *) NULL); - } - break; - - case CurrentoptionCalledclassIdx: - Tcl_SetResult(interp, className(FindCalledClass(interp, object)), TCL_VOLATILE); - break; - - case CurrentoptionCallingmethodIdx: - case CurrentoptionCallingprocIdx: - cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); - Tcl_SetResult(interp, cscPtr ? (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr) : "", - TCL_VOLATILE); - break; - - case CurrentoptionCallingclassIdx: - cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); - Tcl_SetObjResult(interp, cscPtr && cscPtr->cl ? cscPtr->cl->object.cmdName : - XOTclGlobalObjs[XOTE_EMPTY]); - break; - - case CurrentoptionCallinglevelIdx: - if (!object) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); - } - break; - - case CurrentoptionCallingobjectIdx: - cscPtr = XOTclCallStackFindLastInvocation(interp, 1, NULL); - Tcl_SetObjResult(interp, cscPtr ? cscPtr->self->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - break; - - case CurrentoptionFilterregIdx: - cscPtr = CallStackFindActiveFilter(interp); - if (cscPtr) { - Tcl_SetObjResult(interp, FilterFindReg(interp, object, cscPtr->cmdPtr)); - } else { - result = XOTclVarErrMsg(interp, - "called from outside of a filter", - (char *) NULL); - } - break; - - case CurrentoptionIsnextcallIdx: { - Tcl_CallFrame *framePtr; - cscPtr = CallStackGetTopFrame(interp, &framePtr); - framePtr = nextFrameOfType(Tcl_CallFrame_callerPtr(framePtr), FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD); - cscPtr = framePtr ? Tcl_CallFrame_clientData(framePtr) : NULL; - - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (cscPtr && (cscPtr->callType & XOTCL_CSC_CALL_IS_NEXT))); - break; - } - - case CurrentoptionNextIdx: - result = FindSelfNext(interp); - break; - } - - return result; -} - -/* -xotclCmd setvar XOTclSetVarCmd { - {-argName "object" -required 1 -type object} - {-argName "variable" -required 1 -type tclobj} - {-argName "value" -required 0 -type tclobj} -} -*/ -static int XOTclSetVarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *valueObj) { - if (CheckVarName(interp, ObjStr(variable)) != TCL_OK) { - return TCL_ERROR; - } - return setInstVar(interp, object, variable, valueObj); -} - -/* -xotclCmd setter XOTclSetterCmd { - {-argName "object" -required 1 -type object} - {-argName "-per-object"} - {-argName "parameter" -type tclobj} - } -*/ -static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, Tcl_Obj *parameter) { - XOTclClass *cl = (withPer_object || ! XOTclObjectIsClass(object)) ? NULL : (XOTclClass *)object; - CONST char *methodName = ObjStr(parameter); - SetterCmdClientData *setterClientData; - size_t j, length; - int result; - - if (*methodName == '-') { - return XOTclVarErrMsg(interp, - "method name \"", methodName, "\" must not start with a dash", - (char *) NULL); - - } - - setterClientData = NEW(SetterCmdClientData); - setterClientData->paramsPtr = NULL; - length = strlen(methodName); - - for (j=0; jparamsPtr = ParamsNew(1); - result = ParamParse(interp, "setter", parameter, - XOTCL_DISALLOWED_ARG_SETTER|XOTCL_ARG_HAS_DEFAULT, - setterClientData->paramsPtr, &possibleUnknowns, &plainParams); - - if (result != TCL_OK) { - setterCmdDeleteProc((ClientData)setterClientData); - return result; - } - methodName = setterClientData->paramsPtr->name; - } else { - setterClientData->paramsPtr = NULL; - } - - if (cl) { - result = XOTclAddClassMethod(interp, (XOTcl_Class *)cl, methodName, - (Tcl_ObjCmdProc*)XOTclSetterMethod, - (ClientData)setterClientData, setterCmdDeleteProc, 0); - } else { - result = XOTclAddObjectMethod(interp, (XOTcl_Object *)object, methodName, - (Tcl_ObjCmdProc*)XOTclSetterMethod, - (ClientData)setterClientData, setterCmdDeleteProc, 0); - } - if (result == TCL_OK) { - result = ListMethodHandle(interp, object, cl == NULL, methodName); - } else { - setterCmdDeleteProc((ClientData)setterClientData); - } - return result; -} - -typedef struct XOTclParamWrapper { - XOTclParam *paramPtr; - int refCount; - int canFree; -} XOTclParamWrapper; - -static Tcl_DupInternalRepProc ParamDupInteralRep; -static Tcl_FreeInternalRepProc ParamFreeInternalRep; -static Tcl_UpdateStringProc ParamUpdateString; - -static void ParamUpdateString(Tcl_Obj *objPtr) { - Tcl_Panic("%s of type %s should not be called", "updateStringProc", - objPtr->typePtr->name); -} - -static void ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Panic("%s of type %s should not be called", "dupStringProc", - srcPtr->typePtr->name); -} - -static int ParamSetFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr); -static Tcl_ObjType paramObjType = { - "xotclParam", /* name */ - ParamFreeInternalRep, /* freeIntRepProc */ - ParamDupInteralRep, /* dupIntRepProc */ - ParamUpdateString, /* updateStringProc */ - ParamSetFromAny /* setFromAnyProc */ -}; - -static void -ParamFreeInternalRep( - register Tcl_Obj *objPtr) /* Param structure object with internal - * representation to free. */ -{ - XOTclParamWrapper *paramWrapperPtr = (XOTclParamWrapper *)objPtr->internalRep.twoPtrValue.ptr1; - - if (paramWrapperPtr != NULL) { - /* fprintf(stderr, "ParamFreeInternalRep freeing wrapper %p paramPtr %p refCount %dcanFree %d\n", - paramWrapperPtr, paramWrapperPtr->paramPtr, paramWrapperPtr->refCount, - paramWrapperPtr->canFree);*/ - - if (paramWrapperPtr->canFree) { - ParamsFree(paramWrapperPtr->paramPtr); - FREE(XOTclParamWrapper, paramWrapperPtr); - } else { - paramWrapperPtr->refCount--; - } - } -} - -static int -ParamSetFromAny2( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - const char *varNamePrefix, /* shows up as varname in error message */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - XOTclParamWrapper *paramWrapperPtr = NEW(XOTclParamWrapper); - Tcl_Obj *fullParamObj = Tcl_NewStringObj(varNamePrefix, -1); - int result, possibleUnknowns = 0, plainParams = 0; - - paramWrapperPtr->paramPtr = ParamsNew(1); - paramWrapperPtr->refCount = 1; - paramWrapperPtr->canFree = 0; - /*fprintf(stderr, "allocating %p\n",paramWrapperPtr->paramPtr);*/ - - Tcl_AppendLimitedToObj(fullParamObj, ObjStr(objPtr), -1, INT_MAX, NULL); - INCR_REF_COUNT(fullParamObj); - result = ParamParse(interp, "valuecheck", fullParamObj, - XOTCL_DISALLOWED_ARG_VALUEECHECK /* disallowed options */, - paramWrapperPtr->paramPtr, &possibleUnknowns, &plainParams); - /* Here, we want to treat currently unknown user level converters as - error. - */ - if (paramWrapperPtr->paramPtr->flags & XOTCL_ARG_CURRENTLY_UNKNOWN) { - ParamsFree(paramWrapperPtr->paramPtr); - FREE(XOTclParamWrapper, paramWrapperPtr); - result = TCL_ERROR; - } else if (result == TCL_OK) { - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *)paramWrapperPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = ¶mObjType; - } - - DECR_REF_COUNT(fullParamObj); - return result; -} - -static int -ParamSetFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - return ParamSetFromAny2(interp, "value:", objPtr); -} - -static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, - const char *varNamePrefix, int doCheck, XOTclParam **paramPtrPtr) { - XOTclParamWrapper *paramWrapperPtr; - Tcl_Obj *outObjPtr = NULL; - XOTclParam *paramPtr; - ClientData checkedData; - int result, flags = 0; - - /*fprintf(stderr, "ParamSetFromAny %s value %p %s\n", - ObjStr(objPtr), valueObj, ObjStr(valueObj));*/ - - if (objPtr->typePtr == ¶mObjType) { - paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; - } else { - result = ParamSetFromAny2(interp, varNamePrefix, objPtr); - if (result == TCL_OK) { - paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; - } else { - return XOTclVarErrMsg(interp, - "invalid value constraints \"", ObjStr(objPtr), "\"", - (char *) NULL); - } - } - paramPtr = paramWrapperPtr->paramPtr; - if (paramPtrPtr) *paramPtrPtr = paramPtr; - - /* if (!doCheck) { - outObjPtr = valueObj; - checkedData = ObjStr(valueObj); - return TCL_OK; - }*/ - - result = ArgumentCheck(interp, valueObj, paramPtr, doCheck, &flags, &checkedData, &outObjPtr); - - /*fprintf(stderr, "ParamSetFromAny paramPtr %p final refcount of wrapper %d can free %d\n", - paramPtr, paramWrapperPtr->refCount, paramWrapperPtr->canFree);*/ - - if (paramWrapperPtr->refCount == 0) { - /* fprintf(stderr, "ParamSetFromAny paramPtr %p manual free\n",paramPtr);*/ - ParamsFree(paramWrapperPtr->paramPtr); - FREE(XOTclParamWrapper, paramWrapperPtr); - } else { - paramWrapperPtr->canFree = 1; - } - - if (flags & XOTCL_PC_MUST_DECR) { - DECR_REF_COUNT(outObjPtr); - } - - return result; -} - -/*************************** - * End generated XOTcl commands - ***************************/ - -/*************************** - * Begin Object Methods - ***************************/ -static int XOTclOAutonameMethod(Tcl_Interp *interp, XOTclObject *object, int withInstance, int withReset, - Tcl_Obj *nameObj) { - Tcl_Obj *autoname = AutonameIncr(interp, nameObj, object, withInstance, withReset); - 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; -} - -static int XOTclOCleanupMethod(Tcl_Interp *interp, XOTclObject *object) { - XOTclClass *cl = XOTclObjectToClass(object); - int softrecreate; - Tcl_Obj *savedNameObj; - -#if defined(OBJDELETION_TRACE) - fprintf(stderr, "+++ XOTclOCleanupMethod\n"); -#endif - PRINTOBJ("XOTclOCleanupMethod", object); - - savedNameObj = object->cmdName; - INCR_REF_COUNT(savedNameObj); - - /* save and pass around softrecreate*/ - softrecreate = object->flags & XOTCL_RECREATE && RUNTIME_STATE(interp)->doSoftrecreate; - - CleanupDestroyObject(interp, object, softrecreate); - CleanupInitObject(interp, object, object->cl, object->nsPtr, softrecreate); - - if (cl) { - CleanupDestroyClass(interp, cl, softrecreate, 1); - CleanupInitClass(interp, cl, cl->nsPtr, softrecreate, 1); - } - - DECR_REF_COUNT(savedNameObj); - return TCL_OK; -} - -static int -GetObjectParameterDefinition(Tcl_Interp *interp, CONST char *methodName, XOTclObject *object, - XOTclParsedParam *parsedParamPtr) { - int result; - Tcl_Obj *rawConfArgs; - - /* - * Parameter definitions are cached in the class, for which - * instances are created. The parameter definitions are flushed in - * the following situations: - * - * a) on class cleanup: ParsedParamFree(cl->parsedParamPtr) - * b) on class structure changes, - * c) when classmixins are added, - * d) when new slots are defined, - * e) when slots are removed - * - * When slot defaults or types are changed, the slots have to - * perform a manual "::nsf::invalidateobjectparameter $domain" - */ - - /* - * Check, if there is already a parameter definition available for - * creating objects of this class. - */ - if (object->cl->parsedParamPtr) { - parsedParamPtr->paramDefs = object->cl->parsedParamPtr->paramDefs; - parsedParamPtr->possibleUnknowns = object->cl->parsedParamPtr->possibleUnknowns; - result = TCL_OK; - } else { - /* - * There is no parameter definition available, get a new one in - * the the string representation. - */ - /*fprintf(stderr, "calling %s objectparameter\n", objectName(object));*/ - Tcl_Obj *methodObj = XOTclMethodObj(interp, object, XO_o_objectparameter_idx); - - if (methodObj) { - result = callMethod((ClientData) object, interp, methodObj, - 2, 0, XOTCL_CM_NO_PROTECT); - - if (result == TCL_OK) { - rawConfArgs = Tcl_GetObjResult(interp); - /*fprintf(stderr, ".... rawConfArgs for %s => %s\n", objectName(object), ObjStr(rawConfArgs));*/ - INCR_REF_COUNT(rawConfArgs); - - /* Parse the string representation to obtain the internal representation */ - result = ParamDefsParse(interp, methodName, rawConfArgs, XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER, parsedParamPtr); - if (result == TCL_OK) { - XOTclParsedParam *ppDefPtr = NEW(XOTclParsedParam); - ppDefPtr->paramDefs = parsedParamPtr->paramDefs; - ppDefPtr->possibleUnknowns = parsedParamPtr->possibleUnknowns; - object->cl->parsedParamPtr = ppDefPtr; - } - DECR_REF_COUNT(rawConfArgs); - } - } else { - parsedParamPtr->paramDefs = NULL; - parsedParamPtr->possibleUnknowns = 0; - result = TCL_OK; - } - } - return result; -} - -static int -XOTclOConfigureMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { - int result, i, remainingArgsc; - XOTclParsedParam parsedParam; - XOTclParam *paramPtr; - XOTclParamDefs *paramDefs; - Tcl_Obj *newValue; - parseContext pc; - Tcl_CallFrame frame, *framePtr = &frame; - -#if 0 - fprintf(stderr, "XOTclOConfigureMethod %s %d ",objectName(object), objc); - - for(i=0; iparamsPtr; paramPtr->name; paramPtr++, i++) { - - newValue = pc.full_objv[i]; - /*fprintf(stderr, "new Value of %s = %p '%s', type %s", - ObjStr(paramPtr->nameObj), - newValue, newValue ? ObjStr(newValue) : "(null)", paramPtr->type); */ - - if (newValue == XOTclGlobalObjs[XOTE___UNKNOWN__]) { - /* nothing to do here */ - continue; - } - - /* special setter due to relation handling */ - if (paramPtr->converter == convertToRelation) { - ClientData relIdx; - Tcl_Obj *relationObj = paramPtr->converterArg ? paramPtr->converterArg : paramPtr->nameObj, - *outObjPtr; - - result = convertToRelationtype(interp, relationObj, paramPtr, &relIdx, &outObjPtr); - - if (result == TCL_OK) { - result = XOTclRelationCmd(interp, object, PTR2INT(relIdx), newValue); - } - - if (result != TCL_OK) { - XOTcl_PopFrameObj(interp, framePtr); - parseContextRelease(&pc); - goto configure_exit; - } - /* done with relation handling */ - continue; - } - - /* special setter for init commands */ - if (paramPtr->flags & (XOTCL_ARG_INITCMD|XOTCL_ARG_METHOD)) { - CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); - XOTclCallStackContent csc, *cscPtr = &csc; - Tcl_CallFrame frame2, *framePtr2 = &frame2; - - /* The current callframe of configure uses an objscope, such - that setvar etc. are able to access variables like "a" as a - local variable. However, in the init block, we do not like - that behavior, since this should look like like a proc body. - So we push yet another callframe without providing the - varframe. - - The new frame will have the namespace of the caller to avoid - the current objscope. XOTcl_PushFrameCsc() will establish - a CMETHOD frame. - */ - - Tcl_Interp_varFramePtr(interp) = varFramePtr->callerPtr; - CscInit(cscPtr, object, NULL /*cl*/, NULL/*cmd*/, XOTCL_CSC_TYPE_PLAIN); - XOTcl_PushFrameCsc(interp, cscPtr, framePtr2); - - if (paramPtr->flags & XOTCL_ARG_INITCMD) { - result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT); - - } else /* must be XOTCL_ARG_METHOD */ { - Tcl_Obj *ov[3]; - int oc = 0; - if (paramPtr->converterArg) { - /* if arg= was given, pass it as first argument */ - ov[0] = paramPtr->converterArg; - oc = 1; - } - if (paramPtr->nrArgs == 1) { - ov[oc] = newValue; - oc ++; - } - result = XOTclCallMethodWithArgs((ClientData) object, interp, paramPtr->nameObj, - ov[0], oc, &ov[1], 0); - } - /* - Pop previously stacked frame for eval context and set the - varFramePtr to the previous value. - */ - XOTcl_PopFrameCsc(interp, framePtr2); - CscFinish(interp, cscPtr); - Tcl_Interp_varFramePtr(interp) = varFramePtr; - - /*fprintf(stderr, "XOTclOConfigureMethod_ attribute %s evaluated %s => (%d)\n", - ObjStr(paramPtr->nameObj), ObjStr(newValue), result);*/ - - if (result != TCL_OK) { - XOTcl_PopFrameObj(interp, framePtr); - parseContextRelease(&pc); - goto configure_exit; - } - - if (paramPtr->flags & XOTCL_ARG_INITCMD && RUNTIME_STATE(interp)->doKeepinitcmd) { - Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, newValue, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - } - - /* done with init command handling */ - continue; - } - - /* set the variables unless the last argument of the definition is varArgs */ - if (i < paramDefs->nrParams || !pc.varArgs) { - /* standard setter */ -#if defined(CONFIGURE_ARGS_TRACE) - fprintf(stderr, "*** %s SET %s '%s'\n", objectName(object), ObjStr(paramPtr->nameObj), ObjStr(newValue)); -#endif - Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, newValue, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - } - } - - XOTcl_PopFrameObj(interp, framePtr); - - remainingArgsc = pc.objc - paramDefs->nrParams; - - /* - Call residualargs when we have varargs and left over arguments - */ - if (pc.varArgs && remainingArgsc > 0) { - Tcl_Obj *methodObj; - - if (CallDirectly(interp, object, XO_o_residualargs_idx, &methodObj)) { - i -= 2; - if (methodObj) {pc.full_objv[i] = methodObj;} - result = XOTclOResidualargsMethod(interp, object, remainingArgsc+1, pc.full_objv + i); - } else { - result = callMethod((ClientData) object, interp, - methodObj, remainingArgsc+2, pc.full_objv + i-1, 0); - } - if (result != TCL_OK) { - parseContextRelease(&pc); - goto configure_exit; - } - } else { - Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); - } - - parseContextRelease(&pc); - - configure_exit: - return result; -} - -static int XOTclODestroyMethod(Tcl_Interp *interp, XOTclObject *object) { - PRINTOBJ("XOTclODestroyMethod", object); - - /*fprintf(stderr,"XOTclODestroyMethod %p %s flags %.6x activation %d cmd %p cmd->flags %.6x\n", - object, ((Command*)object->id)->flags == 0 ? objectName(object) : "(deleted)", - object->flags, object->activationCount, object->id, ((Command*)object->id)->flags);*/ - - /* - * XOTCL_DESTROY_CALLED might be set already be callDestroyMethod(), - * the implicit destroy calls. It is necessary to set it here for - * the explicit destroy calls in the script, which reach the - * Object->destroy. - */ - - if ((object->flags & XOTCL_DESTROY_CALLED) == 0) { - object->flags |= XOTCL_DESTROY_CALLED; - } - - if ((object->flags & XOTCL_DURING_DELETE) == 0) { - int result; - Tcl_Obj *methodObj; - - /*fprintf(stderr, " call dealloc on %p %s\n", object, - ((Command*)object->id)->flags == 0 ? objectName(object) : "(deleted)");*/ - - if (CallDirectly(interp, &object->cl->object, XO_c_dealloc_idx, &methodObj)) { - result = DoDealloc(interp, object); - } else { - /*fprintf(stderr, "call dealloc\n");*/ - result = XOTclCallMethodWithArgs((ClientData)object->cl, interp, methodObj, - object->cmdName, 1, NULL, 0); - if (result != TCL_OK) { - /* - * In case, the call of the dealloc method has failed above (e.g. NS_DYING), - * we have to call dealloc manually, otherwise we have a memory leak - */ - /*object->flags |= XOTCL_CMD_NOT_FOUND;*/ - /*fprintf(stderr, "*** dealloc failed for %p %s flags %.6x, retry\n", - object, objectName(object), object->flags);*/ - result = DoDealloc(interp, object); - } - } - return result; - } else { -#if defined(OBJDELETION_TRACE) - fprintf(stderr, " Object->destroy already during delete, don't call dealloc %p\n", object); -#endif - } - return TCL_OK; -} - -static int XOTclOExistsMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *var) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), varExists(interp, object, var, NULL, 1, 1)); - return TCL_OK; -} - -static int XOTclOFilterGuardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter, Tcl_Obj *guardObj) { - XOTclObjectOpt *opt = object->opt; - - if (opt && opt->filters) { - XOTclCmdList *h = CmdListFindNameInList(interp, filter, opt->filters); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, guardObj); - object->flags &= ~XOTCL_FILTER_ORDER_VALID; - return TCL_OK; - } - } - - return XOTclVarErrMsg(interp, "Filterguard: can't find filter ", - filter, " on ", objectName(object), (char *) NULL); -} - -/* - * Searches for filter on [self] and returns fully qualified name - * if it is not found it returns an empty string - */ -static int FilterSearchMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter) { - CONST char *filterName; - XOTclCmdList *cmdList; - XOTclClass *fcl; - - Tcl_ResetResult(interp); - - if (!(object->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(interp, object); - if (!(object->flags & XOTCL_FILTER_ORDER_DEFINED)) - return TCL_OK; - - for (cmdList = object->filterOrder; cmdList; cmdList = cmdList->nextPtr) { - filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); - if (filterName[0] == filter[0] && !strcmp(filterName, filter)) - break; - } - - if (!cmdList) - return TCL_OK; - - fcl = cmdList->clorobj; - return ListMethodHandle(interp, (XOTclObject*)fcl, !XOTclObjectIsClass(&fcl->object), filterName); -} - -static int XOTclOInstVarMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { - callFrameContext ctx = {0}; - int result; - - if (object && (object->filterStack || object->mixinStack) ) { - CallStackUseActiveFrames(interp, &ctx); - } - if (!Tcl_Interp_varFramePtr(interp)) { - CallStackRestoreSavedFrames(interp, &ctx); - return XOTclVarErrMsg(interp, "instvar used on ", objectName(object), - ", but callstack is not in procedure scope", - (char *) NULL); - } - - result = XOTclImportvar(interp, object, ObjStr(objv[0]), objc-1, objv+1); - CallStackRestoreSavedFrames(interp, &ctx); - return result; -} - -static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *mixin, Tcl_Obj *guardObj) { - XOTclObjectOpt *opt = object->opt; - - if (opt && opt->mixins) { - XOTclClass *mixinCl = XOTclpGetClass(interp, mixin); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); - } - if (mixinCmd) { - XOTclCmdList *h = CmdListFindCmdInList(mixinCmd, opt->mixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, guardObj); - object->flags &= ~XOTCL_MIXIN_ORDER_VALID; - return TCL_OK; - } - } - } - - return XOTclVarErrMsg(interp, "Mixinguard: can't find mixin ", - mixin, " on ", objectName(object), (char *) NULL); -} - -#if 0 -/* method for calling e.g. $obj __next */ -static int XOTclONextMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { - XOTclCallStackContent *cscPtr = CallStackGetObjectFrame(interp, object); - CONST char *methodName; - - if (!cscPtr) - return XOTclVarErrMsg(interp, "__next: can't find object", - objectName(object), (char *) NULL); - methodName = (char *)Tcl_GetCommandName(interp, cscPtr->cmdPtr); - /* fprintf(stderr, "methodName %s\n", methodName);*/ - return XOTclNextMethod(object, interp, cscPtr->cl, methodName, objc-1, &objv[1], 0, NULL); -} -#endif - -static int XOTclONoinitMethod(Tcl_Interp *interp, XOTclObject *object) { - object->flags |= XOTCL_INIT_CALLED; - return TCL_OK; -} - - -static int XOTclORequireNamespaceMethod(Tcl_Interp *interp, XOTclObject *object) { - requireObjNamespace(interp, object); - return TCL_OK; -} - -static int XOTclOResidualargsMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj **argv, **nextArgv, *resultObj; - int i, start = 1, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; - CONST char *methodName, *nextMethodName; - - /* find arguments without leading dash */ - for (i=start; i < objc; i++) { - if ((isdasharg = isDashArg(interp, objv[i], 1, &methodName, &argc, &argv))) { - break; - } - } - normalArgs = i-1; - - 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], j==i+1, &nextMethodName, &nextArgc, &nextArgv))) { - break; - } - } - result = callConfigureMethod(interp, object, 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 (i2) { - 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; - } - - objc -= i; - objv += i; - - if (!framePtr) { - XOTclCallStackFindLastInvocation(interp, 1, &framePtr); - if (!framePtr) { - framePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)->callerVarPtr; - if (!framePtr) { - framePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - } - } - } - - savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; - - /* - * 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)", Tcl_GetErrorLine(interp)); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - - /* - * Restore the variable frame, and return. - */ - - Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr; - return result; -} - -static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj *frameInfoObj = NULL; - int i, result = TCL_ERROR; - CONST char *frameInfo; - callFrameContext ctx = {0}; - - 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 (object && (object->filterStack || object->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; - } - - if (frameInfoObj) { - DECR_REF_COUNT(frameInfoObj); - } - CallStackRestoreSavedFrames(interp, &ctx); - return result; -} - -static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *object) { - Tcl_Obj *objPtr = object->cmdName; - int result = TCL_ERROR; - CONST char *fullName = ObjStr(objPtr); - CONST char *vn; - callFrameContext ctx = {0}; - - 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); - - if (Tcl_SetVar2(interp, vn, NULL, fullName, 0)) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); - - /*fprintf(stderr, "### setting trace for %s on frame %p\n", fullName, - Tcl_Interp_varFramePtr(interp)); - tcl85showStack(interp);*/ - result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS, - (Tcl_VarTraceProc*)XOTclUnsetTrace, - (ClientData)objPtr); - opt->volatileVarName = vn; - } - CallStackRestoreSavedFrames(interp, &ctx); - - if (result == TCL_OK) { - INCR_REF_COUNT(objPtr); - } - return result; -} - -static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *varname) { - int done, foundEvent; - int flgs = TCL_TRACE_WRITES|TCL_TRACE_UNSETS; - Tcl_CallFrame frame, *framePtr = &frame; - - /* - * Make sure the var table exists and the varname is in there - */ - if (NSRequireVariableOnObj(interp, object, varname, flgs) == 0) - return XOTclVarErrMsg(interp, "Can't lookup (and create) variable ", - varname, " on ", objectName(object), (char *) NULL); - - XOTcl_PushFrameObj(interp, object, framePtr); - /* - * 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, varname, 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, varname, flgs, (Tcl_VarTraceProc *)VwaitVarProc, - (ClientData) &done); - XOTcl_PopFrameObj(interp, framePtr); - /* - * 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 '", varname, - "': would wait forever", (char *) NULL); - } - return TCL_OK; -} - -/*************************** - * End Object Methods - ***************************/ - - -/*************************** - * Begin Class Methods - ***************************/ - -static int XOTclCAllocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj) { - Tcl_Obj *tmpName = NULL; - CONST char *nameString = ObjStr(nameObj); - int result; - - /* - * create a new object from scratch - */ - - /*fprintf(stderr, " **** 0 class '%s' wants to alloc '%s'\n", className(cl), nameString);*/ - if (!NSCheckColons(nameString, 0)) { - return XOTclVarErrMsg(interp, "Cannot allocate object -- illegal name '", - nameString, "'", (char *) NULL); - } - - /* - * If the path is not absolute, we add the appropriate namespace - */ - if (!isAbsolutePath(nameString)) { - nameObj = tmpName = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); - INCR_REF_COUNT(tmpName); - /*fprintf(stderr, " **** NoAbsoluteName for '%s' -> determined = '%s'\n", - name, ObjStr(tmpName));*/ - nameString = ObjStr(tmpName); - } - - if (IsMetaClass(interp, cl, 1)) { - /* - * if the base class is a meta-class, we create a class - */ - XOTclClass *newcl = PrimitiveCCreate(interp, nameObj, cl); - if (newcl == 0) { - result = XOTclVarErrMsg(interp, "Class alloc failed for '", nameString, - "' (possibly parent namespace does not exist)", - (char *) NULL); - } else { - Tcl_SetObjResult(interp, nameObj); - result = TCL_OK; - } - } else { - /* - * if the base class is an ordinary class, we create an object - */ - XOTclObject *newObj = PrimitiveOCreate(interp, nameObj, cl); - if (newObj == 0) - result = XOTclVarErrMsg(interp, "Object alloc failed for '", nameString, - "' (possibly parent namespace does not exist)", - (char *) NULL); - else { - Tcl_SetObjResult(interp, nameObj); - result = TCL_OK; - } - } - - if (tmpName) { - DECR_REF_COUNT(tmpName); - } - - return result; -} - -static int -XOTclCCreateMethod(Tcl_Interp *interp, XOTclClass *cl, CONST char *specifiedName, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *newObject = NULL; - Tcl_Obj *nameObj, *methodObj, *tmpObj = NULL; - Tcl_Obj **nobjv; - int result; - CONST char *nameString = specifiedName; - ALLOC_ON_STACK(Tcl_Obj*, objc, tov); - - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { - fprintf(stderr, "### Can't create object %s during shutdown\n", ObjStr(objv[1])); - return TCL_OK; /* don't fail, if this happens during destroy, it might be canceled */ - } - - /* - * complete the name if it is not absolute - */ - if (!isAbsolutePath(nameString)) { - tmpObj = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); - nameString = ObjStr(tmpObj); - /*fprintf(stderr, " **** fixed name is '%s'\n", nameString);*/ - INCR_REF_COUNT(tmpObj); - memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); - tov[1] = tmpObj; - nameObj = tmpObj; - nobjv = tov; - } else { - nameObj = objv[1]; - nobjv = (Tcl_Obj **)objv; - } - - /* - * Check whether we have to call recreate (i.e. when the - * object exists already) - */ - newObject = XOTclpGetObject(interp, nameString); - - /*fprintf(stderr, "+++ createspecifiedName '%s', nameString '%s', newObject=%p ismeta(%s) %d, ismeta(%s) %d\n", - specifiedName, nameString, newObject, - className(cl), IsMetaClass(interp, cl, 1), - newObject ? ObjStr(newObject->cl->object.cmdName) : "NULL", - newObject ? IsMetaClass(interp, newObject->cl, 1) : 0 - );*/ - - /* don't allow to - - recreate an object as a class, - - recreate a class as an object, and to - - recreate an object in a different obejct system - - In these clases, we use destroy + create instead of recrate. - */ - - if (newObject - && (IsMetaClass(interp, cl, 1) == IsMetaClass(interp, newObject->cl, 1)) - && GetObjectSystem(newObject) == cl->osPtr) { - - /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d oldOs %p != newOs %p EQ %d\n", - ObjStr(nameObj), objc+1, - GetObjectSystem(newObject), cl->osPtr, - GetObjectSystem(newObject) != cl->osPtr - ); - */ - - /* call recreate --> initialization */ - if (CallDirectly(interp, &cl->object, XO_c_recreate_idx, &methodObj)) { - result = RecreateObject(interp, cl, newObject, objc, nobjv); - } else { - result = callMethod((ClientData) cl, interp, methodObj, - objc+1, nobjv+1, XOTCL_CM_NO_PROTECT); - } - - if (result != TCL_OK) - goto create_method_exit; - - Tcl_SetObjResult(interp, newObject->cmdName); - nameObj = newObject->cmdName; - objTrace("RECREATE", newObject); - - } else { - /* - * newObject might exist here, but will be automatically destroyed by - * alloc - */ - - /*fprintf(stderr, "alloc ... %s\n", ObjStr(nameObj));*/ - if (CallDirectly(interp, &cl->object, XO_c_alloc_idx, &methodObj)) { - result = XOTclCAllocMethod(interp, cl, nameObj); - } else { - result = callMethod((ClientData) cl, interp, methodObj, - 3, &nameObj, 0); - } - if (result != TCL_OK) - goto create_method_exit; - - nameObj = Tcl_GetObjResult(interp); - - if (GetObjectFromObj(interp, nameObj, &newObject) != TCL_OK) { - result = XOTclErrMsg(interp, "couldn't find result of alloc", TCL_STATIC); - goto create_method_exit; - } - - /*(void)RemoveInstance(newObject, newObject->cl);*/ /* TODO needed? remove? */ - AddInstance(newObject, cl); - - objTrace("CREATE", newObject); - - /* in case, the object is destroyed during initialization, we incr refcount */ - INCR_REF_COUNT(nameObj); - result = doObjInitialization(interp, newObject, objc, objv); - DECR_REF_COUNT(nameObj); - } - create_method_exit: - - /*fprintf(stderr, "create -- end ... %s => %d\n", ObjStr(nameObj), result);*/ - if (tmpObj) {DECR_REF_COUNT(tmpObj);} - FREE_ON_STACK(Tcl_Obj *, tov); - return result; -} - -static int DoDealloc(Tcl_Interp *interp, XOTclObject *object) { - int result; - - /*fprintf(stderr, "DoDealloc obj= %s %p flags %.6x activation %d cmd %p opt=%p\n", - objectName(object), object, object->flags, object->activationCount, - object->id, object->opt);*/ - - result = freeUnsetTraceVariable(interp, object); - if (result != TCL_OK) { - return result; - } - - /* - * latch, and call delete command if not already in progress - */ - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != - XOTCL_EXITHANDLER_ON_SOFT_DESTROY) { - CallStackDestroyObject(interp, object); - } - - return TCL_OK; -} - - -static int XOTclCDeallocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *obj) { - XOTclObject *object; - - /* fprintf(stderr, "XOTclCDeallocMethod obj %p %s\n",obj, ObjStr(obj));*/ - - if (GetObjectFromObj(interp, obj, &object) != TCL_OK) { - fprintf(stderr, "XOTcl object %s does not exist\n", ObjStr(obj)); - return XOTclVarErrMsg(interp, "Can't destroy object ", - ObjStr(obj), " that does not exist.", (char *) NULL); - } - - return DoDealloc(interp, object); -} - -static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, - int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj *fullnameObj; - int result, prefixLength; - Tcl_DString dFullname, *dsPtr = &dFullname; - XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; - - Tcl_DStringInit(dsPtr); - if (withChildof) { - Tcl_DStringAppend(dsPtr, objectName(withChildof), -1); - Tcl_DStringAppend(dsPtr, "::__#", 5); - } else { - Tcl_DStringAppend(dsPtr, "::nsf::__#", 10); - } - 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); - } - - fullnameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); - - INCR_REF_COUNT(fullnameObj); - - { - Tcl_Obj *methodObj; - int callDirectly; - ALLOC_ON_STACK(Tcl_Obj*, objc+3, ov); - - callDirectly = CallDirectly(interp, &cl->object, XO_c_create_idx, &methodObj); - - ov[0] = objv[0]; - ov[1] = methodObj; - ov[2] = fullnameObj; - if (objc >= 1) - memcpy(ov+3, objv, sizeof(Tcl_Obj *)*objc); - - if (callDirectly) { - result = XOTclCCreateMethod(interp, cl, ObjStr(fullnameObj), objc+2, ov+1); - } else { - result = ObjectDispatch((ClientData)cl, interp, objc+3, ov, 0); - } - - FREE_ON_STACK(Tcl_Obj *, ov); - } - - DECR_REF_COUNT(fullnameObj); - Tcl_DStringFree(dsPtr); - - return result; -} - -static int XOTclCFilterGuardMethod(Tcl_Interp *interp, XOTclClass *cl, - CONST char *filter, Tcl_Obj *guardObj) { - XOTclClassOpt *opt = cl->opt; - - if (opt && opt->classfilters) { - XOTclCmdList *h = CmdListFindNameInList(interp, filter, opt->classfilters); - if (h) { - if (h->clientData) - GuardDel(h); - GuardAdd(interp, h, guardObj); - FilterInvalidateObjOrders(interp, cl); - return TCL_OK; - } - } - - return XOTclVarErrMsg(interp, "filterguard: can't find filter ", - filter, " on ", className(cl), (char *) NULL); -} - -static int XOTclCMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, CONST char *mixin, Tcl_Obj *guardObj) { - XOTclClassOpt *opt = cl->opt; - - if (opt && opt->classmixins) { - XOTclClass *mixinCl = XOTclpGetClass(interp, mixin); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); - } - if (mixinCmd) { - XOTclCmdList *h = CmdListFindCmdInList(mixinCmd, opt->classmixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, guardObj); - MixinInvalidateObjOrders(interp, cl); - return TCL_OK; - } - } - } - - return XOTclVarErrMsg(interp, "mixinguard: can't find mixin ", - mixin, " on ", className(cl), (char *) NULL); -} - -static int RecreateObject(Tcl_Interp *interp, XOTclClass *class, XOTclObject *object, - int objc, Tcl_Obj *CONST objv[]) { - int result; - - object->flags |= XOTCL_RECREATE; - - /* - * First, cleanup the data from the object. - * - * Check whether we have a pending destroy on the object; if yes, - * clear it, such that the recreated object and won't be destroyed - * on a POP - */ - MarkUndestroyed(object); - - /* - * ensure correct class for object - */ - result = changeClass(interp, object, class); - - if (result == TCL_OK) { - Tcl_Obj *methodObj; - /* - * dispatch "cleanup" method - */ - if (CallDirectly(interp, object, XO_o_cleanup_idx, &methodObj)) { - result = XOTclOCleanupMethod(interp, object); - } else { - result = callMethod((ClientData) object, interp, methodObj, - 2, 0, XOTCL_CM_NO_PROTECT); - } - } - - /* - * Second: if cleanup was successful, initialize the object as usual - */ - if (result == TCL_OK) { - result = doObjInitialization(interp, object, objc, objv); - if (result == TCL_OK) { - Tcl_SetObjResult(interp, object->cmdName); - } - } - return result; -} - -static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj, - int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *object; - - if (GetObjectFromObj(interp, nameObj, &object) != TCL_OK) - return XOTclVarErrMsg(interp, "can't recreate non existing object ", - ObjStr(nameObj), (char *) NULL); - - return RecreateObject(interp, cl, object, objc, objv); -} - -/*************************** - * End Class Methods - ***************************/ - -#if 0 -/*************************** - * Begin check Methods - ***************************/ -static int XOTclCheckBooleanArgs(Tcl_Interp *interp, CONST char *name, Tcl_Obj *valueObj) { - int result, bool; - Tcl_Obj *boolean; - - if (value == NULL) { - /* the variable is not yet defined (set), so we cannot check - whether it is boolean or not */ - return TCL_OK; - } - - boolean = Tcl_DuplicateObj(valueObj); - INCR_REF_COUNT(boolean); - result = Tcl_GetBooleanFromObj(interp, boolean, &bool); - DECR_REF_COUNT(boolean); - - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); - return TCL_OK; -} - -static int XOTclCheckRequiredArgs(Tcl_Interp *interp, CONST char *name, Tcl_Obj *valueObj) { - if (value == NULL) { - return XOTclVarErrMsg(interp, "required arg: '", name, "' missing", - (char *) NULL); - } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; -} -/*************************** - * End check Methods - ***************************/ -#endif - -static int AggregatedMethodType(int methodType) { - switch (methodType) { - case MethodtypeNULL: /* default */ - /* TODO remove comment when settled. - methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN; - break;*/ - case MethodtypeAllIdx: - methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN|XOTCL_METHODTYPE_OBJECT; - break; - case MethodtypeScriptedIdx: - /*methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_ALIAS;*/ - methodType = XOTCL_METHODTYPE_SCRIPTED; - break; - case MethodtypeBuiltinIdx: - methodType = XOTCL_METHODTYPE_BUILTIN|XOTCL_METHODTYPE_OBJECT; - break; - case MethodtypeForwarderIdx: - methodType = XOTCL_METHODTYPE_FORWARDER; - break; - case MethodtypeAliasIdx: - methodType = XOTCL_METHODTYPE_ALIAS; - break; - case MethodtypeSetterIdx: - methodType = XOTCL_METHODTYPE_SETTER; - break; - case MethodtypeObjectIdx: - methodType = XOTCL_METHODTYPE_OBJECT; - break; - default: - methodType = 0; - } - - return methodType; -} - -/*************************** - * Begin Object Info Methods - ***************************/ -/* -objectInfoMethod callable XOTclObjInfoCallableMethod { - {-argName "infocallablesubcmd" -nrargs 1 -type "filter|method|methods" -required 1} - {-argName "-methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"} - {-argName "-callprotection" -nrargs 1 -type "all|protected|public" -default all} - {-argName "-application"} - {-argName "-nomixins"} - {-argName "-incontext"} - {-argName "pattern" -required 0} -} -*/ -static int XOTclObjInfoCallableMethod(Tcl_Interp *interp, XOTclObject *object, - int subcmd, - int withMethodtype, int withCallprotection, - int withApplication, - int withNomixins, int withIncontext, CONST char *pattern) { - - if (subcmd != InfocallablesubcmdMethodsIdx) { - if (withMethodtype || withCallprotection || withApplication || withNomixins || withIncontext) { - return XOTclVarErrMsg(interp, "options -methodtype, -callprotection, -application, ", - "-nomixins, -incontext are only valued for subcommand 'methods'", - (char *) NULL); - } - if (pattern == NULL) { - return XOTclVarErrMsg(interp, "methodname must be provided as last argument", - (char *) NULL); - } - } - switch (subcmd) { - case InfocallablesubcmdMethodIdx: - { - XOTclClass *pcl = NULL; - Tcl_Command cmd = ObjectFindMethod(interp, object, pattern, &pcl); - - if (cmd) { - XOTclObject *pobj = pcl ? &pcl->object : object; - int perObject = (pcl == NULL); - ListMethod(interp, pobj, pattern, cmd, InfomethodsubcmdHandleIdx, perObject); - } - return TCL_OK; - } - case InfocallablesubcmdMethodsIdx: - { - return ListCallableMethods(interp, object, pattern, - AggregatedMethodType(withMethodtype), withCallprotection, - withApplication, withNomixins, withIncontext); - } - case InfocallablesubcmdFilterIdx: - { - return FilterSearchMethod(interp, object, pattern); - } - default: - fprintf(stderr, "should never happen, subcmd %d pattern '%s'\n", subcmd, pattern); - - assert(0); /* should never happen */ - } -} - -/* -objectInfoMethod children XOTclObjInfoChildrenMethod { - {-argName "pattern" -required 0} -} -*/ -static int XOTclObjInfoChildrenMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern) { - return ListChildren(interp, object, pattern, 0); -} - -/* -objectInfoMethod class XOTclObjInfoClassMethod { -} -*/ -static int XOTclObjInfoClassMethod(Tcl_Interp *interp, XOTclObject *object) { - Tcl_SetObjResult(interp, object->cl->object.cmdName); - return TCL_OK; -} - -/* -objectInfoMethod filterguard XOTclObjInfoFilterguardMethod { - {-argName "filter" -required 1} -} -*/ -static int XOTclObjInfoFilterguardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *filter) { - return object->opt ? GuardList(interp, object->opt->filters, filter) : TCL_OK; -} - -/* -objectInfoMethod filtermethods XOTclObjInfoFiltermethodsMethod { - {-argName "-guards"} - {-argName "-order"} - {-argName "pattern"} -} -*/ -static int XOTclObjInfoFiltermethodsMethod(Tcl_Interp *interp, XOTclObject *object, - int withGuards, int withOrder, - CONST char *pattern) { - XOTclObjectOpt *opt = object->opt; - - if (withOrder) { - if (!(object->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(interp, object); - return FilterInfo(interp, object->filterOrder, pattern, withGuards, 1); - } - return opt ? FilterInfo(interp, opt->filters, pattern, withGuards, 0) : TCL_OK; -} - -/* -objectInfoMethod forward XOTclObjInfoForwardMethod { - {-argName "-definition"} - {-argName "name"} -} -*/ -static int XOTclObjInfoForwardMethod(Tcl_Interp *interp, XOTclObject *object, int withDefinition, CONST char *pattern) { - return object->nsPtr ? - ListForward(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern, withDefinition) : - TCL_OK; -} - -/* -objectInfoMethod hasmixin XOTclObjInfoHasMixinMethod { - {-argName "class" -type class} -} -*/ -static int -XOTclObjInfoHasMixinMethod(Tcl_Interp *interp, XOTclObject *object, XOTclClass *mixinClass) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), HasMixin(interp, object, mixinClass)); - return TCL_OK; -} - -/* -objectInfoMethod hasnamespace XOTclObjInfoHasnamespaceMethod { -} -*/ -static int XOTclObjInfoHasnamespaceMethod(Tcl_Interp *interp, XOTclObject *object) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), object->nsPtr != NULL); - return TCL_OK; -} - -/* -objectInfoMethod hastype XOTclObjInfoHasTypeMethod { - {-argName "class" -type class} -} -*/ -static int -XOTclObjInfoHasTypeMethod(Tcl_Interp *interp, XOTclObject *object, XOTclClass *typeClass) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), IsSubType(object->cl, typeClass)); - return TCL_OK; -} - -/* -objectInfoMethod is XOTclObjInfoIsMethod { - {-argName "objectkind" -type "class|baseclass|metaclass"} -} -*/ -static int XOTclObjInfoIsMethod(Tcl_Interp *interp, XOTclObject *object, int objectkind) { - int success = 0; - - switch (objectkind) { - case ObjectkindClassIdx: - success = (XOTclObjectIsClass(object) > 0); - break; - - case ObjectkindMetaclassIdx: - success = XOTclObjectIsClass(object) - && IsMetaClass(interp, (XOTclClass*)object, 1); - break; - - case ObjectkindBaseclassIdx: - success = XOTclObjectIsClass(object) - && IsBaseClass((XOTclClass*)object); - break; - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; -} - -/* -objectInfoMethod method XOTclObjInfoMethodMethod { - {-argName "infomethodsubcmd" -type "args|body|definition|handle|parameter|parametersyntax|type|precondition|postcondition"} - {-argName "name"} -} -*/ -static int XOTclObjInfoMethodMethod(Tcl_Interp *interp, XOTclObject *object, - int subcmd, CONST char *methodName) { - Tcl_Namespace *nsPtr = object->nsPtr; - Tcl_Command cmd; - - if (*methodName == ':') { - Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1); - cmd = Tcl_GetCommandFromObj(interp, methodObj); - } else { - cmd = nsPtr ? FindMethod(nsPtr, methodName) : NULL; - } - return ListMethod(interp, object, methodName, cmd, subcmd, 1); -} - -/* -objectInfoMethod methods XOTclObjInfoMethodsMethod { - {-argName "-methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"} - {-argName "-callprotection" -nrargs 1 -type "all|protected|public" -default public} - {-argName "-nomixins"} - {-argName "-incontext"} - {-argName "pattern"} -} -*/ -static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, - int withMethodtype, int withCallproctection, - int withNomixins, int withIncontext, CONST char *pattern) { - return ListDefinedMethods(interp, object, pattern, 1 /* per-object */, - AggregatedMethodType(withMethodtype), withCallproctection, - withNomixins, withIncontext); -} - -/* -objectInfoMethod mixinclasses XOTclObjInfoMixinclassesMethod { - {-argName "-guards"} - {-argName "-order"} - {-argName "pattern" -type objpattern} -} -*/ -static int XOTclObjInfoMixinclassesMethod(Tcl_Interp *interp, XOTclObject *object, - int withGuards, int withOrder, - CONST char *patternString, XOTclObject *patternObj) { - - if (withOrder) { - if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, object); - return MixinInfo(interp, object->mixinOrder, patternString, - withGuards, patternObj); - } - return object->opt ? MixinInfo(interp, object->opt->mixins, patternString, withGuards, patternObj) : TCL_OK; -} - -/* -objectInfoMethod mixinguard XOTclObjInfoMixinguardMethod { - {-argName "mixin" -required 1} -} -*/ -static int XOTclObjInfoMixinguardMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *mixin) { - return object->opt ? GuardList(interp, object->opt->mixins, mixin) : TCL_OK; -} - -/* -objectInfoMethod parent XOTclObjInfoParentMethod { -} -*/ -static int XOTclObjInfoParentMethod(Tcl_Interp *interp, XOTclObject *object) { - if (object->id) { - Tcl_SetResult(interp, NSCmdFullName(object->id), TCL_VOLATILE); - } - return TCL_OK; -} - -/* -objectInfoMethod precedence XOTclObjInfoPrecedenceMethod { - {-argName "-intrinsic"} - {-argName "pattern" -required 0} -} -*/ -static int XOTclObjInfoPrecedenceMethod(Tcl_Interp *interp, XOTclObject *object, - int withIntrinsicOnly, CONST char *pattern) { - XOTclClasses *precedenceList = NULL, *pl; - - precedenceList = ComputePrecedenceList(interp, object, pattern, !withIntrinsicOnly, 1); - for (pl = precedenceList; pl; pl = pl->nextPtr) { - Tcl_AppendElement(interp, className(pl->cl)); - } - XOTclClassListFree(precedenceList); - return TCL_OK; -} - -/* -objectInfoMethod slotobjects XOTclObjInfoSlotObjectsMethod { - {-argName "pattern" -required 0} -} -*/ -static int XOTclObjInfoSlotObjectsMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern) { - XOTclObjects *pl, *slotObjects; - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - /*XOTclClass *slotClass = XOTclpGetClass(interp, "::nx::Slot");*/ - - slotObjects = computeSlotObjects(interp, object, pattern /* not used */, 1); - - for (pl=slotObjects; pl; pl = pl->nextPtr) { - /*if (slotClass && !IsSubType(pl->obj->cl, slotClass)) continue;*/ - Tcl_ListObjAppendElement(interp, list, pl->obj->cmdName); - } - - XOTclObjectListFree(slotObjects); - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - -/* -objectInfoMethod vars XOTclObjInfoVarsMethod { - {-argName "pattern" -required 0} -} -*/ -static int XOTclObjInfoVarsMethod(Tcl_Interp *interp, XOTclObject *object, CONST char *pattern) { - Tcl_Obj *varlist, *okList, *element; - int i, length; - TclVarHashTable *varTable = object->nsPtr ? Tcl_Namespace_varTable(object->nsPtr) : object->varTable; - - ListVarKeys(interp, VarHashTable(varTable), pattern); - varlist = Tcl_GetObjResult(interp); - - Tcl_ListObjLength(interp, varlist, &length); - okList = Tcl_NewListObj(0, NULL); - for (i=0; iopt ? GuardList(interp, class->opt->classfilters, filter) : TCL_OK; -} - -/* -classInfoMethod filtermethods XOTclClassInfoFiltermethodsMethod { - {-argName "-guards"} - {-argName "pattern"} -} -*/ -static int XOTclClassInfoFiltermethodsMethod(Tcl_Interp *interp, XOTclClass *class, - int withGuards, CONST char *pattern) { - return class->opt ? FilterInfo(interp, class->opt->classfilters, pattern, withGuards, 0) : TCL_OK; -} - -/* -classInfoMethod forward XOTclClassInfoForwardMethod { - {-argName "-definition"} - {-argName "name"} -} -*/ -static int XOTclClassInfoForwardMethod(Tcl_Interp *interp, XOTclClass *class, - int withDefinition, CONST char *pattern) { - return ListForward(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, withDefinition); -} - -/* -classInfoMethod heritage XOTclClassInfoHeritageMethod { - {-argName "pattern"} -} -*/ -static int XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *cl, CONST 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; -} - -/* - * get all instances of a class recursively into an initialized - * String key hashtable - */ -static int XOTclClassInfoInstancesMethod1(Tcl_Interp *interp, XOTclClass *startCl, - int withClosure, CONST char *pattern, XOTclObject *matchObject) { - Tcl_HashTable *table = &startCl->instances; - XOTclClasses *sc; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - int rc = 0; - - /*fprintf(stderr, "XOTclClassInfoInstancesMethod: clo %d pattern %s match %p\n", - withClosure, pattern, matchObject);*/ - - for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); - /*fprintf(stderr, "match '%s' %p %p '%s'\n", - matchObject ? objectName(matchObject) : "NULL", matchObject, inst, objectName(inst));*/ - if (matchObject && inst == matchObject) { - Tcl_SetObjResult(interp, matchObject->cmdName); - return 1; - } - AppendMatchingElement(interp, inst->cmdName, pattern); - } - if (withClosure) { - for (sc = startCl->sub; sc; sc = sc->nextPtr) { - rc = XOTclClassInfoInstancesMethod1(interp, sc->cl, withClosure, pattern, matchObject); - if (rc) break; - } - } - return rc; -} - -/* -classInfoMethod instances XOTclClassInfoInstancesMethod { - {-argName "-closure"} - {-argName "pattern" -type objpattern} -} -*/ -static int XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *startCl, - int withClosure, CONST char *pattern, XOTclObject *matchObject) { - XOTclClassInfoInstancesMethod1(interp, startCl, withClosure, pattern, matchObject); - return TCL_OK; -} - -/* -classInfoMethod method XOTclClassInfoMethodMethod { - {-argName "infomethodsubcmd" -type "args|body|definition|handle|parameter|parametersyntax|type|precondition|postcondition"} - {-argName "name"} -} -*/ -static int XOTclClassInfoMethodMethod(Tcl_Interp *interp, XOTclClass *class, - int subcmd, CONST char *methodName) { - Tcl_Namespace *nsPtr = class->nsPtr; - Tcl_Command cmd; - - if (*methodName == ':') { - Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1); - cmd = Tcl_GetCommandFromObj(interp, methodObj); - } else { - cmd = nsPtr ? FindMethod(nsPtr, methodName) : NULL; - } - return ListMethod(interp, &class->object, methodName, cmd, subcmd, 0); -} - -/* -classInfoMethod methods XOTclClassInfoMethodsMethod { - {-argName "-methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"} - {-argName "-callprotection" -nrargs 1 -type "all|protected|public" -default public} - {-argName "-nomixins"} - {-argName "-incontext"} - {-argName "pattern"} -} -*/ -static int XOTclClassInfoMethodsMethod(Tcl_Interp *interp, XOTclClass *class, - int withMethodtype, int withCallproctection, - int withNomixins, int withIncontext, CONST char *pattern) { - return ListDefinedMethods(interp, &class->object, pattern, 0 /* per-object */, - AggregatedMethodType(withMethodtype), withCallproctection, - withNomixins, withIncontext); -} - -/* -classInfoMethod mixinclasses XOTclClassInfoMixinclassesMethod { - {-argName "-closure"} - {-argName "-guards"} - {-argName "pattern" -type objpattern} -} -*/ -static int XOTclClassInfoMixinclassesMethod(Tcl_Interp *interp, XOTclClass *class, - int withClosure, int withGuards, - CONST char *patternString, XOTclObject *patternObj) { - XOTclClassOpt *opt = class->opt; - int rc; - - if (withClosure) { - Tcl_HashTable objTable, *commandTable = &objTable; - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); - rc = getAllClassMixins(interp, commandTable, class, withGuards, patternString, patternObj); - if (patternObj && rc && !withGuards) { - Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - } - Tcl_DeleteHashTable(commandTable); - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); - } else { - rc = opt ? MixinInfo(interp, opt->classmixins, patternString, withGuards, patternObj) : TCL_OK; - } - - return TCL_OK; -} - -/* -classInfoMethod mixinguard XOTclClassInfoMixinguardMethod { - {-argName "mixin" -required 1} -} -*/ -static int XOTclClassInfoMixinguardMethod(Tcl_Interp *interp, XOTclClass *class, CONST char *mixin) { - return class->opt ? GuardList(interp, class->opt->classmixins, mixin) : TCL_OK; -} - -/* -classInfoMethod mixinof XOTclClassInfoMixinOfMethod { - {-argName "-closure"} - {-argName "-scope" -required 0 -nrargs 1 -type "all|class|object"} - {-argName "pattern" -type objpattern} -} -*/ -static int XOTclClassInfoMixinOfMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, int withScope, - CONST char *patternString, XOTclObject *patternObj) { - XOTclClassOpt *opt = class->opt; - int perClass, perObject; - int rc; - - if (withScope == ScopeNULL || withScope == ScopeAllIdx) { - perClass = 1; - perObject = 1; - } else if (withScope == ScopeClassIdx) { - perClass = 1; - perObject = 0; - } else { - perClass = 0; - perObject = 1; - } - - if (opt && !withClosure) { - if (perClass) { - rc = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf, patternString, patternObj); - if (rc && patternObj) {goto finished;} - } - if (perObject) { - rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, patternString, patternObj); - } - } else if (withClosure) { - Tcl_HashTable objTable, *commandTable = &objTable; - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); - if (perClass) { - rc = getAllClassMixinsOf(interp, commandTable, class, 0, 1, patternString, patternObj); - if (rc && patternObj) {goto finished;} - } - if (perObject) { - rc = getAllObjectMixinsOf(interp, commandTable, class, 0, 1, patternString, patternObj); - } - Tcl_DeleteHashTable(commandTable); - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); - } - - finished: - if (patternObj) { - Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - } - return TCL_OK; -} - -/* -classInfoMethod slots XOTclClassInfoSlotsMethod { -} -*/ -static int XOTclClassInfoSlotsMethod(Tcl_Interp *interp, XOTclClass *class) { - Tcl_DString ds, *dsPtr = &ds; - XOTclObject *object; - int result; - - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(class), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - object = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (object) { - result = ListChildren(interp, object, NULL, 0); - } else { - result = TCL_OK; - } - DSTRING_FREE(dsPtr); - return result; -} - -/* -classInfoMethod subclass XOTclClassInfoSubclassMethod { - {-argName "-closure"} - {-argName "pattern" -type objpattern} -} -*/ -static int XOTclClassInfoSubclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, - CONST char *patternString, XOTclObject *patternObj) { - int rc; - if (withClosure) { - XOTclClasses *saved = class->order, *subclasses; - class->order = NULL; - subclasses = ComputeOrder(class, class->order, Sub); - class->order = saved; - rc = AppendMatchingElementsFromClasses(interp, subclasses ? subclasses->nextPtr:NULL, - patternString, patternObj); - XOTclClassListFree(subclasses); - } else { - rc = AppendMatchingElementsFromClasses(interp, class->sub, patternString, patternObj); - } - - if (patternObj) { - Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - } - - return TCL_OK; -} - -/* -classInfoMethod superclass XOTclClassInfoSuperclassMethod { - {-argName "-closure"} - {-argName "pattern" -type tclobj} -} -*/ -static int XOTclClassInfoSuperclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, Tcl_Obj *pattern) { - return ListSuperclasses(interp, class, pattern, withClosure); -} - -/*************************** - * End Class Info methods - ***************************/ - -/* - * New Tcl Commands - */ - -static int -ProcessMethodArguments(parseContext *pcPtr, Tcl_Interp *interp, - XOTclObject *object, int pushFrame, - XOTclParamDefs *paramDefs, - CONST char *methodName, int objc, Tcl_Obj *CONST objv[]) { - int result; - Tcl_CallFrame frame, *framePtr = &frame; - - if (object && pushFrame) { - XOTcl_PushFrameObj(interp, object, framePtr); - } - - result = ArgumentParse(interp, objc, objv, object, objv[0], - paramDefs->paramsPtr, paramDefs->nrParams, - RUNTIME_STATE(interp)->doCheckArguments, - pcPtr); - if (object && pushFrame) { - XOTcl_PopFrameObj(interp, framePtr); - } - if (result != TCL_OK) { - return result; - } - - /* - * Set objc of the parse context to the number of defined parameters. - * pcPtr->objc and paramDefs->nrParams will be equivalent in cases - * where argument values are passed to the call in absence of var - * args ('args'). Treating "args is more involved (see below). - */ - pcPtr->objc = paramDefs->nrParams + 1; - - if (pcPtr->varArgs) { - /* - * The last argument was "args". - */ - int elts = objc - pcPtr->lastobjc; - - if (elts == 0) { - /* - * No arguments were passed to "args". We simply decrement objc. - */ - pcPtr->objc--; - } else if (elts > 1) { - /* - * Multiple arguments were passed to "args". pcPtr->objv is - * pointing to the first of the var args. We have to copy the - * remaining actual argument vector objv to the parse context. - */ - - /*XOTclPrintObjv("actual: ", objc, objv);*/ - parseContextExtendObjv(pcPtr, paramDefs->nrParams, elts-1, objv + 1 + pcPtr->lastobjc); - } else { - /* - * A single argument was passed to "args". There is no need to - * mutate the pcPtr->objv, because this has been achieved in - * ArgumentParse (i.e., pcPtr->objv[i] contains this element). - */ - } - } - - return TCL_OK; -} - -/* XOTclUnsetUnknownArgsCmd was developed and tested for Tcl 8.5 and - * needs probably modifications for earlier versions of Tcl. However, - * since CANONICAL_ARGS requires Tcl 8.5 this is not an issue. - */ -int -XOTclUnsetUnknownArgsCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) { - CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); - Proc *proc = Tcl_CallFrame_procPtr(varFramePtr); - int i; - - if (proc) { - CompiledLocal *ap; - Var *varPtr; - for (ap = proc->firstLocalPtr, i=0; ap; ap = ap->nextPtr, i++) { - if (!TclIsCompiledLocalArgument(ap)) continue; - varPtr = &Tcl_CallFrame_compiledLocals(varFramePtr)[i]; - /*fprintf(stderr, "XOTclUnsetUnknownArgsCmd var '%s' i %d fi %d var %p flags %.8x obj %p unk %p\n", - ap->name, i, ap->frameIndex, varPtr, varPtr->flags, varPtr->value.objPtr, - XOTclGlobalObjs[XOTE___UNKNOWN__]);*/ - if (varPtr->value.objPtr != XOTclGlobalObjs[XOTE___UNKNOWN__]) continue; - /*fprintf(stderr, "XOTclUnsetUnknownArgsCmd must unset %s\n", ap->name);*/ - Tcl_UnsetVar2(interp, ap->name, NULL, 0); - } - } - - return TCL_OK; -} - -#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, className(cl));*/ - for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr); - assert(inst); - assert(inst->refCount>0); - assert(inst->cmdName->refCount>0); - if (XOTclObjectIsClass(inst)) { - checkAllInstances(interp, (XOTclClass*) inst, lvl+1); - } - } - } -} -#endif - -#ifdef DO_FULL_CLEANUP -/* delete global variables and procs */ -static void -deleteProcsAndVars(Tcl_Interp *interp) { - Tcl_Namespace *nsPtr = Tcl_GetGlobalNamespace(interp); - Tcl_HashTable *varTable = nsPtr ? Tcl_Namespace_varTable(ns) : NULL; - Tcl_HashTable *cmdTable = nsPtr ? Tcl_Namespace_cmdTable(ns) : NULL; - Tcl_HashSearch search; - Var *varPtr; - Tcl_Command cmd; - register Tcl_HashEntry *entryPtr; - char *varName; - - 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); - } - } - 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); - - /*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); - } - } -} -#endif - - -#ifdef DO_CLEANUP -static int -ClassHasSubclasses(XOTclClass *cl) { - return (cl->sub != NULL); -} - -static int -ClassHasInstances(XOTclClass *cl) { - Tcl_HashSearch hSrch; - return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL); -} - -static int -ObjectHasChildren(Tcl_Interp *interp, XOTclObject *object) { - Tcl_Namespace *ns = object->nsPtr; - int result = 0; - - if (ns) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSrch; - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Command cmd = Tcl_GetHashValue(hPtr); - XOTclObject *childObject = XOTclGetObjectFromCmdPtr(cmd); - - if (childObject) { - result = 1; - break; - } - } - } - return result; -} - -static void -finalObjectDeletion(Tcl_Interp *interp, XOTclObject *object) { - /* If a call to exit happens from a higher stack frame, the - obejct refcount might not be decremented corectly. If we are - in the phyical destroy round, we can set the counter to an - appropriate value to ensure deletion. - - todo: remove debug line - */ - if (object->refCount != 1) { - fprintf(stderr, "*** have to fix refcount for obj %p refcount %d",object, object->refCount); - if (object->refCount > 1) { - fprintf(stderr, " (name %s)",objectName(object)); - } - fprintf(stderr, "\n"); - object->refCount = 1; - } - assert(object->activationCount == 0); - /*fprintf(stderr, "finalObjectDeletion obj %p activationcount %d\n", object, object->activationCount);*/ - if (object->id) { - /*fprintf(stderr, "cmd dealloc %p final delete refCount %d\n", object->id, Tcl_Command_refCount(object->id));*/ - Tcl_DeleteCommandFromToken(interp, object->id); - } -} - -static void -freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable) { - Tcl_HashEntry *hPtr, *hPtr2; - Tcl_HashSearch hSrch, hSrch2; - XOTclObject *object; - int deleted = 0; - - /*fprintf(stderr, "freeAllXOTclObjectsAndClasses in %p\n", interp);*/ - - RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; - - /* - * First delete all child commands of all objects, which are not - * objects themselves. This will for example delete namespace - * imported commands and objects and will resolve potential loops in - * the dependency graph. The result is a plain object/class tree. - */ - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); - object = XOTclpGetObject(interp, key); - - /* delete per-object methods */ - if (object && object->nsPtr) { - for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(object->nsPtr), &hSrch2); hPtr2; - hPtr2 = Tcl_NextHashEntry(&hSrch2)) { - Tcl_Command cmd = Tcl_GetHashValue(hPtr2); - if (cmd && Tcl_Command_objProc(cmd) != XOTclObjDispatch) { - Tcl_DeleteCommandFromToken(interp, cmd); - deleted ++; - } - } - } - - /* - * Delete class methods; these methods might have aliases (dependencies) to - * objects, which will resolved this way. - */ - if (XOTclObjectIsClass(object)) { - for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(((XOTclClass *)object)->nsPtr), &hSrch2); hPtr2; - hPtr2 = Tcl_NextHashEntry(&hSrch2)) { - Tcl_Command cmd = Tcl_GetHashValue(hPtr2); - if (cmd) { - Tcl_DeleteCommandFromToken(interp, cmd); - deleted ++; - } - } - } - } - /*fprintf(stderr, "deleted %d cmds\n", deleted);*/ - - /* - * Finally delete the object/class tree in a bottom up manner, - * deleteing all objects without dependencies first. Finally, only - * the root classes of the object system will remain, which are - * deleted separately. - */ - - while (1) { - /* - * Delete all plain objects without dependencies - */ - deleted = 0; - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); - - object = XOTclpGetObject(interp, key); - if (object && !XOTclObjectIsClass(object) && !ObjectHasChildren(interp, object)) { - /*fprintf(stderr, " ... delete object %s %p, class=%s id %p\n", key, object, - className(object->cl), object->id);*/ - - freeUnsetTraceVariable(interp, object); - if (object->id) finalObjectDeletion(interp, object); - Tcl_DeleteHashEntry(hPtr); - deleted++; - } - } - /* fprintf(stderr, "deleted %d Objects without dependencies\n", deleted);*/ - if (deleted > 0) { - continue; - } - - /* - * Delete all classes without dependencies - */ - for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(commandNameTable, hPtr); - XOTclClass *cl = XOTclpGetClass(interp, key); - - /*fprintf(stderr, "cl key = %s %p\n", key, cl);*/ - if (cl - && !ObjectHasChildren(interp, (XOTclObject*)cl) - && !ClassHasInstances(cl) - && !ClassHasSubclasses(cl) - && !IsBaseClass(cl) - ) { - /*fprintf(stderr, " ... delete class %s %p\n", key, cl); */ - freeUnsetTraceVariable(interp, &cl->object); - if (cl->object.id) finalObjectDeletion(interp, &cl->object); - - Tcl_DeleteHashEntry(hPtr); - deleted++; - } - } - /*fprintf(stderr, "deleted %d Classes\n", deleted);*/ - if (deleted == 0) { - break; - } - } -} - -#endif /* DO_CLEANUP */ - -/* - * Exit Handler - */ -static void -ExitHandler(ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *)clientData; - int i, flags; - - /*fprintf(stderr, "ExitHandler\n");*/ - - /* - * Don't use exit handler, if the interpreter is alread destroyed. - * 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.4.*, 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; - - CallStackPopAll(interp); - - if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { - XOTclFinalizeObjCmd(interp); - } - - /* must be before freeing of XOTclGlobalObjs */ - XOTclShadowTclCommands(interp, SHADOW_UNLOAD); - - /* free global objects */ - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - DECR_REF_COUNT(XOTclGlobalObjs[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"); */ -#endif - MEM_COUNT_DUMP(); - - FREE(Tcl_Obj**, XOTclGlobalObjs); - FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); - - Tcl_Interp_flags(interp) = flags; - Tcl_Release((ClientData) interp); -} - - -#if defined(TCL_THREADS) -/* - * Gets activated at thread-exit - */ -static void -XOTcl_ThreadExitProc(ClientData clientData) { - /*fprintf(stderr, "+++ XOTcl_ThreadExitProc\n");*/ - - void XOTcl_ExitProc(ClientData clientData); - Tcl_DeleteExitHandler(XOTcl_ExitProc, clientData); - ExitHandler(clientData); -} -#endif - -/* - * Gets activated at application-exit - */ -void -XOTcl_ExitProc(ClientData clientData) { - /*fprintf(stderr, "+++ XOTcl_ExitProc\n");*/ -#if defined(TCL_THREADS) - Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, clientData); -#endif - ExitHandler(clientData); -} - - -/* - * Registers thread/appl exit handlers. - */ -static void -RegisterExitHandlers(ClientData clientData) { - Tcl_Preserve(clientData); -#if defined(TCL_THREADS) - Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, clientData); -#endif - Tcl_CreateExitHandler(XOTcl_ExitProc, clientData); -} - -/* - * Tcl extension initialization routine - */ - -extern int -Nsf_Init(Tcl_Interp *interp) { - ClientData runtimeState; - int result, i; -#ifdef XOTCL_BYTECODE - XOTclCompEnv *interpstructions = XOTclGetCompEnv(); -#endif - static XOTclMutex initMutex = 0; - -#ifdef USE_TCL_STUBS - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { - return TCL_ERROR; - } -#endif - -#if defined(TCL_MEM_DEBUG) - TclDumpMemoryInfo(stderr); -#endif - - MEM_COUNT_INIT(); - - /* init global variables for tcl types */ - XOTclMutexLock(&initMutex); - byteCodeType = Tcl_GetObjType("bytecode"); - tclCmdNameType = Tcl_GetObjType("cmdName"); - listType = Tcl_GetObjType("list"); - XOTclMutexUnlock(&initMutex); - - /* - 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)); - */ - - /* - * Runtime State stored in the client data of the Interp's global - * Namespace in order to avoid global state information - */ - runtimeState = (ClientData) NEW(XOTclRuntimeState); - memset(runtimeState, 0, sizeof(XOTclRuntimeState)); - -#if USE_ASSOC_DATA - Tcl_SetAssocData(interp, "XOTclRuntimeState", NULL, runtimeState); -#else - Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState; -#endif - - RUNTIME_STATE(interp)->doFilters = 1; - RUNTIME_STATE(interp)->doCheckResults = 1; - RUNTIME_STATE(interp)->doCheckArguments = 1; - - /* create xotcl namespace */ - RUNTIME_STATE(interp)->XOTclNS = - Tcl_CreateNamespace(interp, "::nsf", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); - - 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; - - /* XOTclClasses in separate Namespace / Objects */ - RUNTIME_STATE(interp)->XOTclClassesNS = - Tcl_CreateNamespace(interp, "::nsf::classes", (ClientData)NULL, - (Tcl_NamespaceDeleteProc*)NULL); - MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclClassesNS); - - - /* cache interpreters proc interpretation functions */ - RUNTIME_STATE(interp)->objInterpProc = TclGetObjInterpProc(); - RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF; - - RegisterExitHandlers((ClientData)interp); - XOTclStringIncrInit(&RUNTIME_STATE(interp)->iss); - /* initialize global Tcl_Obj */ - XOTclGlobalObjs = NEW_ARRAY(Tcl_Obj*, nr_elements(XOTclGlobalStrings)); - - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - XOTclGlobalObjs[i] = Tcl_NewStringObj(XOTclGlobalStrings[i], -1); - INCR_REF_COUNT(XOTclGlobalObjs[i]); - } - - /* create namespaces for the different command types */ - Tcl_CreateNamespace(interp, "::nsf::cmd", 0, (Tcl_NamespaceDeleteProc*)NULL); - for (i=0; i < nr_elements(method_command_namespace_names); i++) { - Tcl_CreateNamespace(interp, method_command_namespace_names[i], 0, (Tcl_NamespaceDeleteProc*)NULL); - } - - /* create all method commands (will use the namespaces above) */ - for (i=0; i < nr_elements(method_definitions)-1; i++) { - Tcl_CreateObjCommand(interp, method_definitions[i].methodName, method_definitions[i].proc, 0, 0); - } - - /* - * overwritten tcl objs - */ - result = XOTclShadowTclCommands(interp, SHADOW_LOAD); - if (result != TCL_OK) - return result; - - /* - * new tcl cmds - */ -#ifdef XOTCL_BYTECODE - instructions[INST_NEXT].cmdPtr = (Command *) -#endif - Tcl_CreateObjCommand(interp, "::nsf::next", XOTclNextObjCmd, 0, 0); -#ifdef XOTCL_BYTECODE - instructions[INST_SELF].cmdPtr = (Command *)Tcl_FindCommand(interp, "::nsf::current", 0, 0); -#endif - /*Tcl_CreateObjCommand(interp, "::nsf::K", XOTclKObjCmd, 0, 0);*/ - - Tcl_CreateObjCommand(interp, "::nsf::unsetUnknownArgs", XOTclUnsetUnknownArgsCmd, 0, 0); - -#ifdef XOTCL_BYTECODE - XOTclBytecodeInit(); -#endif - - Tcl_SetVar(interp, "::nsf::version", NSF_VERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "::nsf::patchlevel", NSF_PATCHLEVEL, TCL_GLOBAL_ONLY); - - Tcl_AddInterpResolvers(interp,"nxt", - (Tcl_ResolveCmdProc*)InterpColonCmdResolver, - InterpColonVarResolver, - (Tcl_ResolveCompiledVarProc*)InterpCompiledColonVarResolver); - RUNTIME_STATE(interp)->colonCmd = Tcl_FindCommand(interp, "::nsf::colon", 0, 0); - - /* - * 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) { - 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 */ -# ifdef COMPILE_XOTCL_STUBS -# if defined(PRE86) - Tcl_PkgProvideEx(interp, "nsf", PACKAGE_VERSION, (ClientData)&xotclStubs); -# else - Tcl_PkgProvideEx(interp, "nsf", PACKAGE_VERSION, (ClientData)&xotclConstStubPtr); -# endif -# else - Tcl_PkgProvide(interp, "nsf", PACKAGE_VERSION); -# endif -#endif - -#if !defined(TCL_THREADS) - 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); - - return TCL_OK; -} - - -extern int -Next_SafeInit(Tcl_Interp *interp) { - /*** dummy for now **/ - return Nsf_Init(interp); -} - Index: generic/xotcl.h =================================================================== diff -u -N --- generic/xotcl.h (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ generic/xotcl.h (revision 0) @@ -1,179 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * This software is based upon MIT Object Tcl by David Wetherall and - * Christopher J. Lindblad, that contains the following copyright - * message: - * - * Copyright 1993 Massachusetts Institute of Technology - * - * Permission to use, copy, modify, distribute, and sell this - * software and its documentation for any purpose is hereby granted - * without fee, provided that the above copyright notice appear in - * all copies and that both that copyright notice and this permission - * notice appear in supporting documentation, and that the name of - * M.I.T. not be used in advertising or publicity pertaining to - * distribution of the software without specific, written prior - * permission. M.I.T. makes no representations about the suitability - * of this software for any purpose. It is provided "as is" without - * express or implied warranty. - * */ - -#ifndef _xotcl_h_ -#define _xotcl_h_ - -#include "tcl.h" - -#undef TCL_STORAGE_CLASS -#ifdef BUILD_xotcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_XOTCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif -#endif - -/* - * prevent old TCL-versions - */ - -#if TCL_MAJOR_VERSION < 8 -# error Tcl distribution is TOO OLD, we require at least tcl8.5 -#endif - -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<5 -# error Tcl distribution is TOO OLD, we require at least tcl8.5 -#endif - -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<6 -# define PRE86 -#endif - -#if defined(PRE86) -# define CONST86 -# define Tcl_GetErrorLine(interp) (interp)->errorLine -#else -# define NRE -#endif - -/* - * Feature activation/deactivation - */ - -/* activate bytecode support -#define XOTCL_BYTECODE -*/ - -/* activate/deacticate profiling information at the end - of running the program -#define PROFILE -*/ - -/* activate/deacticate assert -#define NDEBUG 1 -*/ - -/* activate/deacticate memory tracing -#define XOTCL_MEM_TRACE 1 -#define XOTCL_MEM_COUNT 1 -*/ - -/* turn tracing output on/off -#define XOTCLOBJ_TRACE 1 - -#define CALLSTACK_TRACE 1 -#define DISPATCH_TRACE 1 -#define NAMESPACE_TRACE 1 -#define OBJDELETION_TRACE 1 -#define STACK_TRACE 1 -#define TCL85STACK_TRACE 1 -#define PARSE_TRACE 1 -#define PARSE_TRACE_FULL 1 -#define CONFIGURE_ARGS_TRACE 1 -#define TCL_STACK_ALLOC_TRACE 1 -#define VAR_RESOLVER_TRACE 1 -#define CMD_RESOLVER_TRACE 1 -*/ - -#if defined(PARSE_TRACE_FULL) -# define PARSE_TRACE 1 -#endif - -#ifdef XOTCL_MEM_COUNT -# define DO_FULL_CLEANUP 1 -#endif - -#ifdef AOL_SERVER -# ifndef TCL_THREADS -# define TCL_THREADS -# endif -#endif - -#ifdef TCL_THREADS -# define DO_CLEANUP -#endif - -#ifdef DO_FULL_CLEANUP -# define DO_CLEANUP -#endif - -/* - * A special definition used to allow this header file to be included - * in resource files so that they can get obtain version information from - * this file. Resource compilers don't like all the C stuff, like typedefs - * and procedure declarations, that occur below. - */ - -#ifndef RC_INVOKED - -/* - * The structures XOTcl_Object and XOTcl_Class define mostly opaque - * data structures for the internal use strucures XOTclObject and - * XOTclClass (both defined in XOTclInt.h). Modification of elements - * visible elements must be mirrored in both incarnations. - */ - -typedef struct XOTcl_Object { - Tcl_Obj *cmdName; -} XOTcl_Object; - -typedef struct XOTcl_Class { - struct XOTcl_Object object; -} XOTcl_Class; - - -/* - * Include the public function declarations that are accessible via - * the stubs table. - */ -#include "nsfDecls.h" - -/* - * Xotcl_InitStubs is used by extensions that can be linked - * against the xotcl stubs library. If we are not using stubs - * then this reduces to package require. - */ - -#ifdef USE_XOTCL_STUBS - -# ifdef __cplusplus -extern "C" -# endif -CONST char * -Nx_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, CONST char *version, int exact)); -#else -# define Xotcl_InitStubs(interp, version, exact) \ - Tcl_PkgRequire(interp, "nx", version, exact) -#endif - -#endif /* RC_INVOKED */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT - -#endif /* _xotcl_h_ */ Index: generic/xotclAccessInt.h =================================================================== diff -u -N --- generic/xotclAccessInt.h (revision d337d1f94a287b8d694b50c4b1000151de21098c) +++ generic/xotclAccessInt.h (revision 0) @@ -1,79 +0,0 @@ -#define Tcl_Interp_numLevels(interp) ((Interp *)interp)->numLevels -#define Tcl_Interp_framePtr(interp) ((Tcl_CallFrame *)((Interp *)interp)->framePtr) -#define Tcl_Interp_varFramePtr(interp) (((Interp *)interp)->varFramePtr) -#define Tcl_Interp_cmdFramePtr(interp) (((Interp *)interp)->cmdFramePtr) -#define Tcl_Interp_globalNsPtr(interp) ((Tcl_Namespace *)((Interp *)interp)->globalNsPtr) -#define Tcl_Interp_flags(interp) ((Interp *)interp)->flags -#if DISPATCH_TRACE -#define Tcl_Interp_returnCode(interp) ((Interp *)interp)->returnCode -#endif -#define Tcl_Interp_threadId(interp) ((Interp *)interp)->threadId - -#define Tcl_CallFrame_callerPtr(cf) ((Tcl_CallFrame*)((CallFrame *)cf)->callerPtr) -#define Tcl_CallFrame_procPtr(cf) ((CallFrame *)cf)->procPtr -#define Tcl_CallFrame_varTablePtr(cf) ((CallFrame *)cf)->varTablePtr -#define Tcl_CallFrame_level(cf) ((CallFrame *)cf)->level -#define Tcl_CallFrame_isProcCallFrame(cf) ((CallFrame *)cf)->isProcCallFrame -#define Tcl_CallFrame_compiledLocals(cf) ((CallFrame *)cf)->compiledLocals -#define Tcl_CallFrame_numCompiledLocals(cf) ((CallFrame *)cf)->numCompiledLocals -#define Tcl_CallFrame_callerVarPtr(cf) ((Tcl_CallFrame*)((CallFrame *)cf)->callerVarPtr) -#define Tcl_CallFrame_objc(cf) ((CallFrame *)cf)->objc -#define Tcl_CallFrame_objv(cf) ((CallFrame *)cf)->objv -#define Tcl_CallFrame_clientData(cf) ((CallFrame *)cf)->clientData -#define Tcl_CallFrame_nsPtr(cf) ((Tcl_Namespace *)((CallFrame *)cf)->nsPtr) - -#define Tcl_Namespace_cmdTable(nsPtr) &((Namespace *)nsPtr)->cmdTable -#define Tcl_Namespace_varTable(nsPtr) &((Namespace *)nsPtr)->varTable -#define Tcl_Namespace_childTable(nsPtr) &((Namespace *)nsPtr)->childTable -#define Tcl_Namespace_activationCount(nsPtr) ((Namespace *)nsPtr)->activationCount -#define Tcl_Namespace_deleteProc(nsPtr) ((Namespace *)nsPtr)->deleteProc - -#define Tcl_Command_refCount(cmd) ((Command *)cmd)->refCount -#define Tcl_Command_cmdEpoch(cmd) ((Command *)cmd)->cmdEpoch -#define Tcl_Command_flags(cmd) ((Command *)cmd)->flags -/* the following items could be obtained from - Tcl_GetCommandInfoFromToken(cmd, infoPtr) */ -#define Tcl_Command_nsPtr(cmd) ((Tcl_Namespace*)(((Command *)cmd)->nsPtr)) -#define Tcl_Command_objProc(cmd) ((Command *)cmd)->objProc -#define Tcl_Command_objClientData(cmd) ((Command *)cmd)->objClientData -#define Tcl_Command_proc(cmd) ((Command *)cmd)->proc -#define Tcl_Command_clientData(cmd) ((Command *)cmd)->clientData -#define Tcl_Command_deleteProc(cmd) ((Command *)cmd)->deleteProc -#define Tcl_Command_deleteData(cmd) ((Command *)cmd)->deleteData - -/* - * Conversion from CmdPtr to Class / Object - */ - -static XOTCLINLINE ClientData -XOTclGetClientDataFromCmdPtr(Tcl_Command cmd) { - assert(cmd); - /*fprintf(stderr, "objProc=%p %p\n",Tcl_Command_objProc(cmd),XOTclObjDispatch);*/ - if (Tcl_Command_objProc(cmd) == XOTclObjDispatch /* && !Tcl_Command_cmdEpoch(cmd)*/) - return Tcl_Command_objClientData(cmd); - else { - cmd = TclGetOriginalCommand(cmd); - if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) { - /*fprintf(stderr, "???? got cmd right in 2nd round\n");*/ - return Tcl_Command_objClientData(cmd); - } - return NULL; - } -} - -static XOTCLINLINE XOTclClass* -XOTclGetClassFromCmdPtr(Tcl_Command cmd) { - ClientData cd = XOTclGetClientDataFromCmdPtr(cmd); - /*fprintf(stderr, "cd=%p\n",cd);*/ - if (cd) - return XOTclObjectToClass(cd); - else - return 0; -} - -static XOTCLINLINE XOTclObject* -XOTclGetObjectFromCmdPtr(Tcl_Command cmd) { - return (XOTclObject*) XOTclGetClientDataFromCmdPtr(cmd); -} - - Index: generic/xotclCompile.c =================================================================== diff -u -N --- generic/xotclCompile.c (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ generic/xotclCompile.c (revision 0) @@ -1,144 +0,0 @@ -#include "xotclInt.h" - -#ifdef XOTCL_BYTECODE -#include - -static CompileProc - initProcNsCompile, nextCompile, - selfCompile, selfDispatchCompile; - -static InstructionDesc instructionTable[] = { - {"initProc", 1, 0, {OPERAND_NONE}}, - {"next", 1, 0, {OPERAND_NONE}}, - {"self", 1, 0, {OPERAND_NONE}}, - {"dispatch", 2, 1, {OPERAND_UINT1}}, -}; - -static XOTclCompEnv instructions[] = { - {0, 0, initProcNsCompile, XOTclInitProcNSCmd}, - {0, 0, nextCompile, XOTclNextObjCmd}, - {0, 0, selfCompile, XOTclGetSelfObjCmd}, - {0, 0, selfDispatchCompile, /*XOTclSelfDispatchCmd*/XOTclDirectSelfDispatch}, - 0 -}; - -XOTclCompEnv * -XOTclGetCompEnv() { - return &instructions[0]; -} - - -static int -initProcNsCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) { - - if (parsePtr->numWords != 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be '::xotcl::initProcNS'", -1); - envPtr->maxStackDepth = 0; - return TCL_ERROR; - } - - TclEmitOpcode(instructions[INST_INITPROC].bytecode, envPtr); - envPtr->maxStackDepth = 0; - - return TCL_OK; -} - -static int -nextCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) { - - if (parsePtr->numWords != 1) - return TCL_OUT_LINE_COMPILE; - - TclEmitOpcode(instructions[INST_NEXT].bytecode, envPtr); - envPtr->maxStackDepth = 0; - - return TCL_OK; -} -static int -selfCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) { - - if (parsePtr->numWords != 1) - return TCL_OUT_LINE_COMPILE; - - TclEmitOpcode(instructions[INST_SELF].bytecode, envPtr); - envPtr->maxStackDepth = 0; - - return TCL_OK; -} -static int -selfDispatchCompile(Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) { - - Tcl_Token *tokenPtr; - int code, wordIdx; - /* - fprintf(stderr, "****** selfDispatchCompile words=%d tokens=%d, avail=%d\n", - parsePtr->numWords,parsePtr->numTokens,parsePtr->tokensAvailable); - */ - - if (parsePtr->numWords > 255) - return TCL_OUT_LINE_COMPILE; - - /*TclEmitOpcode(instructions[INST_SELF].bytecode, envPtr);*/ - - for (wordIdx=0, tokenPtr = parsePtr->tokenPtr + 0; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { - - /* - fprintf(stderr," %d: %p token type=%d size=%d\n", - wordIdx,tokenPtr,tokenPtr->type,tokenPtr->size ); - */ - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterLiteral(envPtr, tokenPtr->start, - tokenPtr->size, 0), envPtr); - envPtr->maxStackDepth = 1; - /* - fprintf(stderr," %d: simple '%s' components=%d\n", - wordIdx,tokenPtr->start, tokenPtr->numComponents); - */ - } else { - /* - fprintf(stderr," %d NOT simple '%s' components=%d\n", - wordIdx,tokenPtr->start, tokenPtr->numComponents); - */ - code = TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - return code; - } - } - } - - /*fprintf(stderr, "maxdepth=%d, onStack=%d\n",envPtr->maxStackDepth,wordIdx); - */ - TclEmitInstInt1(instructions[INST_SELF_DISPATCH].bytecode, wordIdx, envPtr); - envPtr->maxStackDepth = 0; - - return TCL_OK; -} - - - -void -XOTclBytecodeInit() { - int i; - for(i=0; iobjClientData))) { - instructions[i].cmdPtr->compileProc = instructions[i].compileProc; - } - - } - /*tclTraceCompile = 2;*/ - -} - -#endif Index: generic/xotclError.c =================================================================== diff -u -N --- generic/xotclError.c (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/xotclError.c (revision 0) @@ -1,117 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * - * xotclError.c -- - * - * error return functions for XOTcl - * - */ - -#include "xotclInt.h" - -int -XOTclErrMsg(Tcl_Interp *interp, char *msg, Tcl_FreeProc* type) { - Tcl_SetResult(interp, msg, type); - return TCL_ERROR; -} - -int -XOTclVarErrMsg TCL_VARARGS_DEF (Tcl_Interp *, arg1) { - va_list argList; - char *string; - Tcl_Interp *interp; - - interp = TCL_VARARGS_START(Tcl_Interp *, arg1, argList); - Tcl_ResetResult(interp); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - Tcl_AppendResult(interp, string, (char *) NULL); - } - va_end(argList); - return TCL_ERROR; -} - - -int -XOTclErrInProc(Tcl_Interp *interp, Tcl_Obj *objName, - Tcl_Obj *clName, CONST char *procName) { - Tcl_DString errMsg; - char *cName, *space; - ALLOC_DSTRING(&errMsg, "\n "); - if (clName) { - cName = ObjStr(clName); - space = " "; - } else { - cName = ""; - space =""; - } - Tcl_DStringAppend(&errMsg, ObjStr(objName),-1); - Tcl_DStringAppend(&errMsg, space, -1); - Tcl_DStringAppend(&errMsg, cName, -1); - Tcl_DStringAppend(&errMsg, "->", 2); - Tcl_DStringAppend(&errMsg, procName, -1); - Tcl_AddErrorInfo (interp, Tcl_DStringValue(&errMsg)); - DSTRING_FREE(&errMsg); - return TCL_ERROR; -} - -int -XOTclObjWrongArgs(Tcl_Interp *interp, char *msg, Tcl_Obj *cmdName, Tcl_Obj *methodName, char *arglist) { - int need_space = 0; - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, msg, " should be \"", (char *) NULL); - if (cmdName) { - Tcl_AppendResult(interp, ObjStr(cmdName), (char *) NULL); - need_space = 1; - } - if (methodName) { - if (need_space) Tcl_AppendResult(interp, " ", (char *) NULL); - Tcl_AppendResult(interp, ObjStr(methodName), (char *) NULL); - need_space = 1; - } - if (arglist != NULL) { - if (need_space) Tcl_AppendResult(interp, " ", (char *) NULL); - Tcl_AppendResult(interp, arglist, (char *) NULL); - } - Tcl_AppendResult(interp, "\"", (char *) NULL); - return TCL_ERROR; -} - -int -XOTclObjErrArgCnt(Tcl_Interp *interp, Tcl_Obj *cmdName, Tcl_Obj *methodName, char *arglist) { - return XOTclObjWrongArgs(interp, "wrong # args:", cmdName, methodName, arglist); -} - -int -XOTclErrBadVal(Tcl_Interp *interp, char *context, char *expected, CONST char *value) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, context, ": expected ", expected, " but got '", - value, "'", (char *) NULL); - return TCL_ERROR; -} - -int -XOTclErrBadVal_(Tcl_Interp *interp, char *expected, char *value) { - fprintf(stderr, "Deprecated call, recompile your program with xotcl 1.5 or newer\n"); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, ": expected ", expected, " but got '", - value, "'", (char *) NULL); - return TCL_ERROR; -} - -extern int -XOTclObjErrType(Tcl_Interp *interp, Tcl_Obj *value, char *type, char *parameterName) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp,"expected ", type, " but got \"", ObjStr(value), "\"", - parameterName ? " for parameter " : "", - parameterName ? parameterName : "", - (char *) NULL); - return TCL_ERROR; -} Index: generic/xotclInt.h =================================================================== diff -u -N --- generic/xotclInt.h (revision 1d47ca3db133ff4eef6bf13f35c5f4e7bfd49a20) +++ generic/xotclInt.h (revision 0) @@ -1,808 +0,0 @@ -/* -*- Mode: c++ -*- - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * xotclInt.h -- - * - * Mostly internally used API Functions - */ - -#ifndef _xotcl_int_h_ -#define _xotcl_int_h_ - -#if defined(HAVE_STDINT_H) -# define HAVE_INTPTR_T -# define HAVE_UINTPTR_T -#endif - -#include -#include "xotcl.h" - -#include -#include -#include - -#if defined(HAVE_TCL_COMPILE_H) -# include -#endif - -#if defined(PROFILE) -# include -#endif - -#ifdef DMALLOC -# include "dmalloc.h" -#endif - -#ifdef BUILD_xotcl -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT -#endif - -/* -#define XOTCL_METADATA -*/ - -/* - * Makros - */ - -#if defined(PRE86) -# define Tcl_NRCallObjProc(interp, proc, cd, objc, objv) \ - (*(proc))((cd), (interp), (objc), (objv)) -#endif - -#ifdef XOTCL_MEM_COUNT -Tcl_HashTable xotclMemCount; -extern int xotclMemCountInterpCounter; -typedef struct XOTclMemCounter { - int peak; - int count; -} XOTclMemCounter; -# define MEM_COUNT_ALLOC(id,p) XOTclMemCountAlloc(id,p) -# define MEM_COUNT_FREE(id,p) XOTclMemCountFree(id,p) -# define MEM_COUNT_INIT() \ - if (xotclMemCountInterpCounter == 0) { \ - Tcl_InitHashTable(&xotclMemCount, TCL_STRING_KEYS); \ - xotclMemCountInterpCounter = 1; \ - } -# define MEM_COUNT_DUMP() XOTclMemCountDump(interp) -# define MEM_COUNT_OPEN_FRAME() -/*if (obj->varTable) noTableBefore = 0*/ -# define MEM_COUNT_CLOSE_FRAME() -/* if (obj->varTable && noTableBefore) \ - XOTclMemCountAlloc("obj->varTable",NULL)*/ -#else -# define MEM_COUNT_ALLOC(id,p) -# define MEM_COUNT_FREE(id,p) -# define MEM_COUNT_INIT() -# define MEM_COUNT_DUMP() -# define MEM_COUNT_OPEN_FRAME() -# define MEM_COUNT_CLOSE_FRAME() -#endif - -#define DSTRING_INIT(dsPtr) Tcl_DStringInit(dsPtr); MEM_COUNT_ALLOC("DString",dsPtr) -#define DSTRING_FREE(dsPtr) Tcl_DStringFree(dsPtr); MEM_COUNT_FREE("DString",dsPtr) - -#if USE_ASSOC_DATA -# define RUNTIME_STATE(interp) ((XOTclRuntimeState*)Tcl_GetAssocData((interp), "XOTclRuntimeState", NULL)) -#else -# define RUNTIME_STATE(interp) ((XOTclRuntimeState*)((Interp*)(interp))->globalNsPtr->clientData) -#endif - - -#define ALLOC_NAME_NS(DSP, NS, NAME) \ - DSTRING_INIT(DSP);\ - Tcl_DStringAppend(DSP, NS, -1),\ - Tcl_DStringAppend(DSP, "::", 2),\ - Tcl_DStringAppend(DSP, NAME, -1) -#define ALLOC_TOP_NS(DSP, NAME) \ - DSTRING_INIT(DSP);\ - Tcl_DStringAppend(DSP, "::", 2),\ - Tcl_DStringAppend(DSP, NAME, -1) -#define ALLOC_DSTRING(DSP,ENTRY) \ - DSTRING_INIT(DSP);\ - Tcl_DStringAppend(DSP, ENTRY, -1) - -#define nr_elements(arr) ((int) (sizeof(arr) / sizeof(arr[0]))) - -# define NEW(type) \ - (type *)ckalloc(sizeof(type)); MEM_COUNT_ALLOC(#type, NULL) -# define NEW_ARRAY(type,n) \ - (type *)ckalloc(sizeof(type)*(n)); MEM_COUNT_ALLOC(#type "*", NULL) -# define FREE(type, var) \ - ckfree((char*) var); MEM_COUNT_FREE(#type,var) - -#define isAbsolutePath(m) (*m == ':' && m[1] == ':') -#define isArgsString(m) (\ - *m == 'a' && m[1] == 'r' && m[2] == 'g' && m[3] == 's' && \ - m[4] == '\0') -#define isBodyString(m) (\ - *m == 'b' && m[1] == 'o' && m[2] == 'd' && m[3] == 'y' && \ - m[4] == '\0') -#define isCheckString(m) (\ - *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ - m[4] == 'k' && m[5] == '\0') -#define isCheckObjString(m) (\ - *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ - m[4] == 'k' && m[5] == 'o' && m[6] == 'b' && m[7] == 'j' && \ - m[8] == '\0') -#define isCreateString(m) (\ - *m == 'c' && m[1] == 'r' && m[2] == 'e' && m[3] == 'a' && \ - m[4] == 't' && m[5] == 'e' && m[6] == '\0') -#define isInitString(m) (\ - *m == 'i' && m[1] == 'n' && m[2] == 'i' && m[3] == 't' && \ - m[4] == '\0') -#define isTypeString(m) (\ - *m == 't' && m[1] == 'y' && m[2] == 'p' && m[3] == 'e' && \ - m[4] == '\0') -#define isObjectString(m) (\ - *m == 'o' && m[1] == 'b' && m[2] == 'j' && m[3] == 'e' && \ - m[4] == 'c' && m[5] == 't' && m[6] == '\0') -#define isClassString(m) (\ - *m == 'c' && m[1] == 'l' && m[2] == 'a' && m[3] == 's' && \ - m[4] == 's' && m[5] == '\0') - -#if (defined(sun) || defined(__hpux)) && !defined(__GNUC__) -# define USE_ALLOCA -#endif - -#if defined(__IBMC__) && !defined(__GNUC__) -# if __IBMC__ >= 0x0306 -# define USE_ALLOCA -# else -# define USE_MALLOC -# endif -#endif - -#if defined(VISUAL_CC) -# define USE_MALLOC -#endif - -#if defined(__GNUC__) && !defined(USE_ALLOCA) && !defined(USE_MALLOC) -# if !defined(NDEBUG) -# define ALLOC_ON_STACK(type,n,var) \ - int __##var##_count = (n); type __##var[n+2]; \ - type *var = __##var + 1; var[-1] = var[__##var##_count] = (type)0xdeadbeaf -# define FREE_ON_STACK(type,var) \ - assert(var[-1] == var[__##var##_count] && var[-1] == (type)0xdeadbeaf) -# else -# define ALLOC_ON_STACK(type,n,var) type var[(n)] -# define FREE_ON_STACK(type,var) -# endif -#elif defined(USE_ALLOCA) -# define ALLOC_ON_STACK(type,n,var) type *var = (type *)alloca((n)*sizeof(type)) -# define FREE_ON_STACK(type,var) -#else -# define ALLOC_ON_STACK(type,n,var) type *var = (type *)ckalloc((n)*sizeof(type)) -# define FREE_ON_STACK(type,var) ckfree((char*)var) -#endif - -#ifdef USE_ALLOCA -# include -#endif - -#ifdef __WIN32__ -# define XOTCLINLINE -# define XOTclNewObj(A) A=Tcl_NewObj() -# define DECR_REF_COUNT(A) \ - MEM_COUNT_FREE("INCR_REF_COUNT",A); Tcl_DecrRefCount(A) -#else -/* - * This was defined to be inline for anything !sun or __IBMC__ >= 0x0306, - * but __hpux should also be checked - switched to only allow in gcc - JH - */ -# if defined(__GNUC__) -# define XOTCLINLINE inline -# else -# define XOTCLINLINE -# endif -# ifdef USE_TCL_STUBS -# define XOTclNewObj(A) A=Tcl_NewObj() -# define DECR_REF_COUNT(A) \ - MEM_COUNT_FREE("INCR_REF_COUNT",A); assert((A)->refCount > -1); \ - Tcl_DecrRefCount(A) -# else -# define XOTclNewObj(A) TclNewObj(A) -# define DECR_REF_COUNT(A) \ - MEM_COUNT_FREE("INCR_REF_COUNT",A); TclDecrRefCount(A) -# endif -#endif - -#if defined(TCL_THREADS) -# define XOTclMutex Tcl_Mutex -# define XOTclMutexLock(a) Tcl_MutexLock(a) -# define XOTclMutexUnlock(a) Tcl_MutexUnlock(a) -#else -# define XOTclMutex int -# define XOTclMutexLock(a) (*(a))++ -# define XOTclMutexUnlock(a) (*(a))-- -#endif - -#define ObjStr(obj) (obj)->bytes ? (obj)->bytes : Tcl_GetString(obj) - -#define INCR_REF_COUNT(A) MEM_COUNT_ALLOC("INCR_REF_COUNT",A); Tcl_IncrRefCount(A) - -#ifdef OBJDELETION_TRACE -# define PRINTOBJ(ctx,obj) \ - fprintf(stderr, " %s %p %s oid=%p teardown=%p destroyCalled=%d\n", \ - ctx,obj,(obj)->teardown?ObjStr((obj)->cmdName):"(deleted)", \ - (obj)->id, (obj)->teardown, \ - ((obj)->flags & XOTCL_DESTROY_CALLED)) -#else -# define PRINTOBJ(ctx,obj) -#endif - -#define className(cl) (cl ? ObjStr(cl->object.cmdName) : "") -#define objectName(obj) (ObjStr(obj->cmdName)) - - -#define LONG_AS_STRING 32 - -/* TCL_CONTINUE is defined as 4, from 5 on we can - use app-specific return codes */ -#define XOTCL_CHECK_FAILED 6 - -/* flags for call method */ -#define XOTCL_CM_NO_UNKNOWN 1 -#define XOTCL_CM_NO_SHIFT 2 -#define XOTCL_CM_NO_PROTECT 4 -#define XOTCL_CM_NO_OBJECT_METHOD 8 -#define XOTCL_CM_DELGATE 0x10 - -/* - * - * XOTcl Structures - * - */ - -/* - * Filter structures - */ -typedef struct XOTclFilterStack { - Tcl_Command currentCmdPtr; - Tcl_Obj *calledProc; - struct XOTclFilterStack *nextPtr; -} XOTclFilterStack; - -typedef struct XOTclTclObjList { - Tcl_Obj *content; - struct XOTclTclObjList *nextPtr; -} XOTclTclObjList; - -/* - * Assertion structures - */ - -typedef struct XOTclProcAssertion { - XOTclTclObjList *pre; - XOTclTclObjList *post; -} XOTclProcAssertion; - -typedef struct XOTclAssertionStore { - XOTclTclObjList *invariants; - Tcl_HashTable procs; -} XOTclAssertionStore; - -typedef enum { /* powers of 2; add to ALL, if default; */ - CHECK_NONE = 0, CHECK_CLINVAR = 1, CHECK_OBJINVAR = 2, - CHECK_PRE = 4, CHECK_POST = 8, - CHECK_INVAR = CHECK_CLINVAR + CHECK_OBJINVAR, - CHECK_ALL = CHECK_INVAR + CHECK_PRE + CHECK_POST -} CheckOptions; - -void XOTclAssertionRename(Tcl_Interp *interp, Tcl_Command cmd, - XOTclAssertionStore *as, - char *oldSimpleCmdName, char *newName); -/* - * mixins - */ -typedef struct XOTclMixinStack { - Tcl_Command currentCmdPtr; - struct XOTclMixinStack *nextPtr; -} XOTclMixinStack; - -/* - * Generic command pointer list - */ -typedef struct XOTclCmdList { - Tcl_Command cmdPtr; - ClientData clientData; - struct XOTclClass *clorobj; - struct XOTclCmdList *nextPtr; -} XOTclCmdList; - -typedef void (XOTclFreeCmdListClientData) _ANSI_ARGS_((XOTclCmdList*)); - -/* for incr string */ -typedef struct XOTclStringIncrStruct { - char *buffer; - char *start; - size_t bufSize; - int length; -} XOTclStringIncrStruct; - -/* - * cmd flags - */ - -#define XOTCL_CMD_PROTECTED_METHOD 0x00010000 -#define XOTCL_CMD_REDEFINE_PROTECTED_METHOD 0x00020000 -/* XOTCL_CMD_NONLEAF_METHOD is used to flag, if a Method implemented via cmd calls "next" */ -#define XOTCL_CMD_NONLEAF_METHOD 0x00040000 -#define XOTCL_CMD_CLASS_ONLY_METHOD 0x00080000 -/* - * object flags ... - */ - -/* DESTROY_CALLED indicates that destroy was called on obj */ -#define XOTCL_DESTROY_CALLED 0x0001 -/* INIT_CALLED indicates that init was called on obj */ -#define XOTCL_INIT_CALLED 0x0002 -/* MIXIN_ORDER_VALID set when mixin order is valid */ -#define XOTCL_MIXIN_ORDER_VALID 0x0004 -/* MIXIN_ORDER_DEFINED set, when mixins are defined for obj */ -#define XOTCL_MIXIN_ORDER_DEFINED 0x0008 -#define XOTCL_MIXIN_ORDER_DEFINED_AND_VALID 0x000c -/* FILTER_ORDER_VALID set, when filter order is valid */ -#define XOTCL_FILTER_ORDER_VALID 0x0010 -/* FILTER_ORDER_DEFINED set, when filters are defined for obj */ -#define XOTCL_FILTER_ORDER_DEFINED 0x0020 -#define XOTCL_FILTER_ORDER_DEFINED_AND_VALID 0x0030 -/* CLASS properties for objects */ -#define XOTCL_IS_CLASS 0x0040 -#define XOTCL_IS_ROOT_META_CLASS 0x0080 -#define XOTCL_IS_ROOT_CLASS 0x0100 -#define XOTCL_TCL_DELETE 0x0200 -/* DESTROYED set, when object is physically destroyed with PrimitiveODestroy */ -/*#define XOTCL_CMD_NOT_FOUND 0x1000*/ -#define XOTCL_DURING_DELETE 0x2000 -#define XOTCL_DELETED 0x4000 -#define XOTCL_RECREATE 0x8000 - -/* flags for XOTclParams */ - -#define XOTCL_ARG_REQUIRED 0x0001 -#define XOTCL_ARG_MULTIVALUED 0x0002 -#define XOTCL_ARG_NOARG 0x0004 -#define XOTCL_ARG_CURRENTLY_UNKNOWN 0x0008 -#define XOTCL_ARG_SUBST_DEFAULT 0x0010 -#define XOTCL_ARG_ALLOW_EMPTY 0x0020 -#define XOTCL_ARG_INITCMD 0x0040 -#define XOTCL_ARG_METHOD 0x0080 -#define XOTCL_ARG_RELATION 0x0100 -#define XOTCL_ARG_SWITCH 0x0200 -#define XOTCL_ARG_HAS_DEFAULT 0x1000 -#define XOTCL_ARG_IS_CONVERTER 0x2000 - -/* disallowed options */ -#define XOTCL_DISALLOWED_ARG_METHOD_PARAMETER (XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION) -#define XOTCL_DISALLOWED_ARG_SETTER (XOTCL_ARG_SUBST_DEFAULT|XOTCL_DISALLOWED_ARG_METHOD_PARAMETER) -#define XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER 0 -#define XOTCL_DISALLOWED_ARG_VALUEECHECK (XOTCL_ARG_SUBST_DEFAULT|XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_SWITCH|XOTCL_ARG_CURRENTLY_UNKNOWN) - - -/* method types */ -#define XOTCL_METHODTYPE_ALIAS 0x0001 -#define XOTCL_METHODTYPE_SCRIPTED 0x0002 -#define XOTCL_METHODTYPE_SETTER 0x0004 -#define XOTCL_METHODTYPE_FORWARDER 0x0008 -#define XOTCL_METHODTYPE_OBJECT 0x0010 -#define XOTCL_METHODTYPE_OTHER 0x0100 -#define XOTCL_METHODTYPE_BUILTIN XOTCL_METHODTYPE_ALIAS|XOTCL_METHODTYPE_SETTER|XOTCL_METHODTYPE_FORWARDER|XOTCL_METHODTYPE_OTHER - - -/* flags for parseContext */ -#define XOTCL_PC_MUST_DECR 0x0001 - -#define XOTclObjectSetClass(obj) \ - (obj)->flags |= XOTCL_IS_CLASS -#define XOTclObjectClearClass(obj) \ - (obj)->flags &= ~XOTCL_IS_CLASS -#define XOTclObjectIsClass(obj) \ - ((obj)->flags & XOTCL_IS_CLASS) -#define XOTclObjectToClass(obj) \ - (XOTclClass*)((((XOTclObject*)obj)->flags & XOTCL_IS_CLASS)?obj:0) - - -/* - * object and class internals - */ -struct XOTclParam; -typedef int (XOTclTypeConverter)(Tcl_Interp *interp, - Tcl_Obj *obj, - struct XOTclParam CONST *pPtr, - ClientData *clientData, - Tcl_Obj **outObjPtr); - -typedef struct XOTclParam { - char *name; - int flags; - int nrArgs; - XOTclTypeConverter *converter; - Tcl_Obj *converterArg; - Tcl_Obj *defaultValue; - CONST char *type; - Tcl_Obj *nameObj; - Tcl_Obj *converterName; - Tcl_Obj *paramObj; - Tcl_Obj *slotObj; -} XOTclParam; - -typedef struct XOTclParamDefs { - XOTclParam *paramsPtr; - int nrParams; - Tcl_Obj *slotObj; - Tcl_Obj *returns; -} XOTclParamDefs; - -typedef struct XOTclParsedParam { - XOTclParamDefs *paramDefs; - int possibleUnknowns; -} XOTclParsedParam; - -typedef struct XOTclObjectOpt { - XOTclAssertionStore *assertions; - XOTclCmdList *filters; - XOTclCmdList *mixins; -#ifdef XOTCL_METADATA - Tcl_HashTable metaData; -#endif - ClientData clientData; - CONST char *volatileVarName; - short checkoptions; -} XOTclObjectOpt; - -typedef struct XOTclObject { - Tcl_Obj *cmdName; - Tcl_Command id; - Tcl_Interp *teardown; - struct XOTclClass *cl; - TclVarHashTable *varTable; - Tcl_Namespace *nsPtr; - XOTclObjectOpt *opt; - struct XOTclCmdList *filterOrder; - struct XOTclCmdList *mixinOrder; - XOTclFilterStack *filterStack; - XOTclMixinStack *mixinStack; - int refCount; - short flags; - short activationCount; -} XOTclObject; - -typedef struct XOTclObjects { - struct XOTclObject *obj; - struct XOTclObjects *nextPtr; -} XOTclObjects; - -typedef struct XOTclClassOpt { - XOTclCmdList *classfilters; - XOTclCmdList *classmixins; - XOTclCmdList *isObjectMixinOf; - XOTclCmdList *isClassMixinOf; - XOTclAssertionStore *assertions; -#ifdef XOTCL_OBJECTDATA - Tcl_HashTable *objectdata; -#endif - Tcl_Command id; - ClientData clientData; -} XOTclClassOpt; - -typedef struct XOTclClass { - struct XOTclObject object; - struct XOTclClasses *super; - struct XOTclClasses *sub; - struct XOTclObjectSystem *osPtr; - struct XOTclClasses *order; - Tcl_HashTable instances; - Tcl_Namespace *nsPtr; - XOTclParsedParam *parsedParamPtr; - XOTclClassOpt *opt; - short color; -} XOTclClass; - -typedef struct XOTclClasses { - struct XOTclClass *cl; - ClientData clientData; - struct XOTclClasses *nextPtr; -} XOTclClasses; - -typedef enum SystemMethodsIdx { - XO_c_alloc_idx, - XO_c_create_idx, - XO_c_dealloc_idx, - XO_c_recreate_idx, - XO_c_requireobject_idx, - XO_o_cleanup_idx, - XO_o_configure_idx, - XO_o_defaultmethod_idx, - XO_o_destroy_idx, - XO_o_init_idx, - XO_o_move_idx, - XO_o_objectparameter_idx, - XO_o_residualargs_idx, - XO_o_unknown_idx -} SystemMethodsIdx; - -#if !defined(XOTCL_C) -extern CONST char *XOTcl_SytemMethodOpts[]; -#else -CONST char *XOTcl_SytemMethodOpts[] = { - "-class.alloc", - "-class.create", - "-class.dealloc", - "-class.recreate", - "-class.requireobject", - "-object.cleanup", - "-object.configure", - "-object.defaultmethod", - "-object.destroy", - "-object.init", - "-object.move", - "-object.objectparameter", - "-object.residualargs", - "-object.unknown", - NULL -}; -#endif - -typedef struct XOTclObjectSystem { - XOTclClass *rootClass; - XOTclClass *rootMetaClass; - int overloadedMethods; - int definedMethods; - Tcl_Obj *methods[XO_o_unknown_idx+1]; - struct XOTclObjectSystem *nextPtr; -} XOTclObjectSystem; - - - - -/* XOTcl global names and strings */ -/* these are names and contents for global (corresponding) Tcl_Objs - and Strings - otherwise these "constants" would have to be built - every time they are used; now they are built once in XOTcl_Init */ -typedef enum { - XOTE_EMPTY, XOTE_ONE, - /* methods called internally */ - XOTE_CONFIGURE, - /* var names */ - XOTE_AUTONAMES, XOTE_DEFAULTMETACLASS, XOTE_DEFAULTSUPERCLASS, - XOTE_ALIAS_ARRAY, - /* object/class names */ - XOTE_METHOD_PARAMETER_SLOT_OBJ, - /* constants */ - XOTE_ALIAS, XOTE_ARGS, XOTE_CMD, XOTE_FILTER, XOTE_FORWARD, - XOTE_METHOD, XOTE_OBJECT, XOTE_SETTER, - XOTE_GUARD_OPTION, XOTE___UNKNOWN__, - /* Patly redefined Tcl commands; leave them together at the end */ - XOTE_EXPR, XOTE_FORMAT, XOTE_INFO, XOTE_INFO_FRAME, XOTE_INTERP, XOTE_IS, XOTE_RENAME, XOTE_SUBST -} XOTclGlobalNames; -#if !defined(XOTCL_C) -extern char *XOTclGlobalStrings[]; -#else -char *XOTclGlobalStrings[] = { - "", "1", - /* methods called internally */ - "configure", - /* var names */ - "__autonames", "__default_metaclass", "__default_superclass", - "::nsf::alias", - /* object/class names */ - "::nx::methodParameterSlot", - /* constants */ - "alias", "args", "cmd", "filter", "forward", - "method", "object", "setter", - "-guard", "__unknown__", - /* tcl commands */ - "expr", "format", "info", "::tcl::info::frame", "interp", "::tcl::string::is", "rename", "subst", -}; -#endif - -#define XOTclGlobalObjs RUNTIME_STATE(interp)->methodObjNames - -/* XOTcl ShadowTclCommands */ -typedef struct XOTclShadowTclCommandInfo { - TclObjCmdProcType proc; - ClientData clientData; -} XOTclShadowTclCommandInfo; -typedef enum {SHADOW_LOAD=1, SHADOW_UNLOAD=0, SHADOW_REFETCH=2} XOTclShadowOperations; - -int XOTclCallCommand(Tcl_Interp *interp, XOTclGlobalNames name, - int objc, Tcl_Obj *CONST objv[]); -int XOTclShadowTclCommands(Tcl_Interp *interp, XOTclShadowOperations load); -Tcl_Obj * XOTclMethodObj(Tcl_Interp *interp, XOTclObject *object, int methodIdx); - - -/* - * XOTcl CallStack - */ -typedef struct XOTclCallStackContent { - XOTclObject *self; - XOTclClass *cl; - Tcl_Command cmdPtr; - XOTclFilterStack *filterStackEntry; - Tcl_Obj ** objv; - int objc; - unsigned short frameType; - unsigned short callType; -} XOTclCallStackContent; - -#define XOTCL_CSC_TYPE_PLAIN 0 -#define XOTCL_CSC_TYPE_ACTIVE_MIXIN 1 -#define XOTCL_CSC_TYPE_ACTIVE_FILTER 2 -#define XOTCL_CSC_TYPE_INACTIVE 4 -#define XOTCL_CSC_TYPE_INACTIVE_MIXIN 5 -#define XOTCL_CSC_TYPE_INACTIVE_FILTER 6 -#define XOTCL_CSC_TYPE_GUARD 16 - -#define XOTCL_CSC_CALL_IS_NEXT 1 -#define XOTCL_CSC_CALL_IS_GUARD 2 - -#if defined(PROFILE) -typedef struct XOTclProfile { - long int overallTime; - Tcl_HashTable objectData; - Tcl_HashTable methodData; -} XOTclProfile; -#endif - -typedef struct XOTclRuntimeState { - Tcl_Namespace *XOTclClassesNS; - Tcl_Namespace *XOTclNS; - /* - * definitions of the main xotcl objects - */ - struct XOTclObjectSystem *objectSystems; - Tcl_ObjCmdProc *objInterpProc; - Tcl_Obj **methodObjNames; - struct XOTclShadowTclCommandInfo *tclCommands; - int errorCount; - /* these flags could move into a bitarray, but are used only once per interp*/ - int unknown; - int doFilters; - int doSoftrecreate; - int doKeepinitcmd; - int doCheckResults; - int doCheckArguments; - int exitHandlerDestroyRound; - int returnCode; - int overloadedMethods; - long newCounter; - XOTclStringIncrStruct iss; - XOTclObject *delegatee; - Proc fakeProc; - Tcl_Namespace *fakeNS; - NsfStubs *nsfStubs; - Tcl_CallFrame *varFramePtr; - Tcl_Command cmdPtr; /* used for ACTIVE_MIXIN */ - Tcl_Command colonCmd; -#if defined(PROFILE) - XOTclProfile profile; -#endif - short guardCount; - ClientData clientData; -} XOTclRuntimeState; - -#define XOTCL_EXITHANDLER_OFF 0 -#define XOTCL_EXITHANDLER_ON_SOFT_DESTROY 1 -#define XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY 2 - - -#ifdef XOTCL_OBJECTDATA -extern void -XOTclSetObjectData(struct XOTclObject *obj, struct XOTclClass *cl, - ClientData data); -extern int -XOTclGetObjectData(struct XOTclObject *obj, struct XOTclClass *cl, - ClientData *data); -extern int -XOTclUnsetObjectData(struct XOTclObject *obj, struct XOTclClass *cl); -extern void -XOTclFreeObjectData(XOTclClass *cl); -#endif - -/* - * - * internally used API functions - * - */ - -#include "nsfIntDecls.h" - -/* - * Profiling functions - */ - -#if defined(PROFILE) -extern void -XOTclProfileFillTable(Tcl_HashTable *table, Tcl_DString *key, - double totalMicroSec); -extern void -XOTclProfileEvaluateData(Tcl_Interp *interp, long int startSec, long int startUsec, - XOTclObject *obj, XOTclClass *cl, char *methodName); -extern void -XOTclProfilePrintTable(Tcl_HashTable *table); - -extern void -XOTclProfilePrintData(Tcl_Interp *interp); - -extern void -XOTclProfileInit(Tcl_Interp *interp); -#endif - -/* - * MEM Counting - */ -#ifdef XOTCL_MEM_COUNT -void XOTclMemCountAlloc(char *id, void *); -void XOTclMemCountFree(char *id, void *); -void XOTclMemCountDump(); -#endif /* XOTCL_MEM_COUNT */ -/* - * old, deprecated meta-data command - */ -#if defined(XOTCL_METADATA) -extern void -XOTclMetaDataDestroy(XOTclObject *obj); -extern void -XOTclMetaDataInit(XOTclObject *obj); -extern int -XOTclOMetaDataMethod (ClientData cd, Tcl_Interp *interp, - int objc, Tcl_Obj *objv[]); -#endif /* XOTCL_METADATA */ - - -/* - * bytecode support - */ -#ifdef XOTCL_BYTECODE -typedef struct XOTclCompEnv { - int bytecode; - Command *cmdPtr; - CompileProc *compileProc; - Tcl_ObjCmdProc *callProc; -} XOTclCompEnv; - -typedef enum {INST_INITPROC, INST_NEXT, INST_SELF, INST_SELF_DISPATCH, - LAST_INSTRUCTION} XOTclByteCodeInstructions; - - -extern XOTclCompEnv *XOTclGetCompEnv(); - -Tcl_ObjCmdProc XOTclInitProcNSCmd, XOTclSelfDispatchCmd, - XOTclNextObjCmd, XOTclGetSelfObjCmd; - -int XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -#endif - -int -XOTclObjDispatch(ClientData cd, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); - -/* functions from xotclUtil.c */ -char *XOTcl_ltoa(char *buf, long i, int *len); -char *XOTclStringIncr(XOTclStringIncrStruct *iss); -void XOTclStringIncrInit(XOTclStringIncrStruct *iss); -void XOTclStringIncrFree(XOTclStringIncrStruct *iss); - - -/* - Tcl uses 01 and 02, TclOO uses 04 and 08, so leave some space free - for further extensions of tcl and tcloo... -*/ -#define FRAME_IS_XOTCL_OBJECT 0x10000 -#define FRAME_IS_XOTCL_METHOD 0x20000 -#define FRAME_IS_XOTCL_CMETHOD 0x40000 - -#if !defined(NDEBUG) -/*# define XOTCLINLINE*/ -#endif - -/*** common win sermon ***/ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT - -#endif /* _xotcl_int_h_ */ Index: generic/xotclMetaData.c =================================================================== diff -u -N --- generic/xotclMetaData.c (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/xotclMetaData.c (revision 0) @@ -1,175 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * - * xotclReference.c -- - * - * XOTcl Object References - * - */ - -#include "xotclInt.h" - -#ifdef XOTCL_METADATA -/* - * Meta Data - */ - -void -XOTclMetaDataRemoveDepending(XOTclClass *cl, char *name) { - XOTclClasses *saved = cl->order, *clPtr; - cl->order = 0; - - clPtr = XOTclComputeDependents(cl); - - while (clPtr != 0) { - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*) - Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - Tcl_HashEntry *h1Ptr = 0; - if (obj->opt) - h1Ptr = Tcl_FindHashEntry(&obj->opt->metaData, name); - if (h1Ptr) { - Tcl_DeleteHashEntry(h1Ptr); - } - } - clPtr = clPtr->next; - } - - XOTclRemoveClasses(cl->order); - cl->order = saved; -} - -int -XOTclMetaDataInheritance (XOTclObject *obj, char *name) { - XOTclClasses *clPtr; - assert(obj); - - if (!obj->cl->order) - obj->cl->order = XOTclComputePrecedence(obj->cl); - clPtr = obj->cl->order; - if (clPtr) { - while (clPtr != 0) { - if (clPtr->cl->object.opt) { - if (Tcl_FindHashEntry(&clPtr->cl->object.opt->metaData, name)) { - return 1; - } - } - clPtr = clPtr->next; - } - } - return 0; -} - -void -XOTclMetaDataDestroy(XOTclObject *obj) { - if (obj->opt) - Tcl_DeleteHashTable(&obj->opt->metaData); -} - -void -XOTclMetaDataInit(XOTclObject *obj) { - XOTclRequireObjectOpt(obj); - Tcl_InitHashTable(&obj->opt->metaData, TCL_STRING_KEYS); -} - -int -XOTclOMetaDataMethod (ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclClass *cl = XOTclObjectToClass(cd); - char *option; int add = -1; - int result = TCL_OK; - int oc; Tcl_Obj* *ov; int i; - - if (!obj) return XOTclObjErrType(interp, obj->cmdName, "Object", ""); - if (objc < 2) - return XOTclObjErrArgCnt(interp,obj->cmdName, - "metadata ?(add|remove)? metaDataList"); - - option = ObjStr(objv[1]); - switch (*option) { - case 'a': - if (strcmp(option,"add") == 0) add = 1; break; - case 'r': - if (strcmp(option,"remove") == 0) add = 0; break; - } - if (add == -1) { - if (objc == 2) { - if (obj->opt) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, option); - if (hPtr) { - Tcl_Obj *entry = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - if (entry) { - Tcl_SetObjResult(interp, (Tcl_Obj *) Tcl_GetHashValue(hPtr)); - } else { - Tcl_ResetResult(interp); - } - } - return TCL_OK; - } - } - if (objc == 3) { - if (obj->opt) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, option); - if (!hPtr) { - int nw; - if (XOTclMetaDataInheritance(obj, option)) { - hPtr = Tcl_CreateHashEntry(&obj->opt->metaData, option, &nw); - if (!nw) - return XOTclVarErrMsg(interp, - "MetaData: Can't create MetaData Entry: ", - option, (char*) NULL); - } - } - if (hPtr) { - Tcl_Obj *entry = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - if (entry) - DECR_REF_COUNT(entry); - INCR_REF_COUNT(objv[2]); - Tcl_SetHashValue(hPtr, (ClientData) objv[2]); - return TCL_OK; - } - } - } - return XOTclVarErrMsg(interp,"MetaData: Unknown option; given Option: ", - option, (char*) NULL); - } - - if (Tcl_ListObjGetElements(interp, objv[2], &oc, &ov) == TCL_OK) { - for (i = 0; i < oc; i ++) { - char *value = ObjStr (ov[i]); - if (obj->opt) { - if (add) { - int nw; - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, value); - if (hPtr) - return XOTclVarErrMsg(interp, - "Can't add MetaData, MetaData exists: ", - value, - (char*) NULL); - hPtr = Tcl_CreateHashEntry(&obj->opt->metaData, value, &nw); - if (!nw) - return XOTclVarErrMsg(interp, - "MetaData: Can't create MetaData Entry: ", - value,(char*) NULL); - } else { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, value); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - if (cl) { - XOTclMetaDataRemoveDepending(cl, value); - } - } - } - } - } - } - return result; -} -#endif Index: generic/xotclObjectData.c =================================================================== diff -u -N --- generic/xotclObjectData.c (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ generic/xotclObjectData.c (revision 0) @@ -1,61 +0,0 @@ -/* -*- Mode: c++ -*- - * xotclObjectData.c - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2008 Gustaf Neumann, Uwe Zdun - * - * - * xotclObjectData.c -- - * - * XOTcl Object Data, needs XOTCL_OBJECTDATA to be compiled in - * - */ - -#include "xotclInt.h" - -#ifdef XOTCL_OBJECTDATA -extern void -XOTclFreeObjectData(XOTclClass* cl) { - if (cl->opt && cl->opt->objectdata) { - Tcl_DeleteHashTable(cl->opt->objectdata); - ckfree((char*)cl->opt->objectdata); - cl->opt->objectdata = 0; - } -} -extern void -XOTclSetObjectData(XOTclObject* obj, XOTclClass* cl, ClientData data) { - Tcl_HashEntry *hPtr; - int nw; - - XOTclRequireClassOpt(cl); - - if (!cl->opt->objectdata) { - cl->opt->objectdata = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(cl->opt->objectdata, TCL_ONE_WORD_KEYS); - } - hPtr = Tcl_CreateHashEntry(cl->opt->objectdata, (char*)obj, &nw); - Tcl_SetHashValue(hPtr, data); -} - -extern int -XOTclGetObjectData(XOTclObject* obj, XOTclClass* cl, ClientData* data) { - Tcl_HashEntry *hPtr; - if (!cl->opt || !cl->opt->objectdata) - return 0; - hPtr = Tcl_FindHashEntry(cl->opt->objectdata, (char*)obj); - if (data) *data = hPtr ? Tcl_GetHashValue(hPtr) : 0; - return hPtr != 0; -} - -extern int -XOTclUnsetObjectData(XOTclObject* obj, XOTclClass* cl) { - Tcl_HashEntry *hPtr; - - if (!cl->opt || !cl->opt->objectdata) - return 0; - hPtr = Tcl_FindHashEntry(cl->opt->objectdata, (char*)obj); - if (hPtr) Tcl_DeleteHashEntry(hPtr); - return hPtr != 0; -} -#endif Index: generic/xotclProfile.c =================================================================== diff -u -N --- generic/xotclProfile.c (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/xotclProfile.c (revision 0) @@ -1,144 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * - * xotclProfile.c -- - * - * Profiling information printout for XOTcl - * - * For profiling infos PROFILE (xotcl.h) flag must be activated - * - */ - -#include "xotclInt.h" - -#if defined(PROFILE) -void -XOTclProfileFillTable(Tcl_HashTable* table, Tcl_DString* key, - double totalMicroSec) { - Tcl_HashEntry* hPtr; - char* keyStr = Tcl_DStringValue(key); - long int* value; - - hPtr = Tcl_FindHashEntry(table, keyStr); - if (!hPtr) { - int nw; - hPtr = Tcl_CreateHashEntry(table, keyStr, &nw); - if (!nw) - return; - value = (long int*) ckalloc (sizeof(long int)); - *value = 0; - Tcl_SetHashValue(hPtr, (ClientData) value); - } else - value = (long int*) Tcl_GetHashValue (hPtr); - - *value += totalMicroSec; - - - /* { - long int* d = (long int*) Tcl_GetHashValue (hPtr); - fprintf(stderr, "Entered %s ... %ld\n", Tcl_GetHashKey(table, hPtr), *d); - }*/ - -} - -void -XOTclProfileEvaluateData(Tcl_Interp* interp, long int startSec, long int startUsec, - XOTclObject* obj, XOTclClass *cl, char *methodName) { - double totalMicroSec; - struct timeval trt; - Tcl_DString objectKey, methodKey; - - XOTclProfile* profile = &RUNTIME_STATE(interp)->profile; - - gettimeofday(&trt, NULL); - - totalMicroSec = (trt.tv_sec - startSec) * 1000000 + - (trt.tv_usec - startUsec); - - profile->overallTime += totalMicroSec; - - if (obj->teardown == 0 || !obj->id || obj->destroyCalled) - return; - - ALLOC_DSTRING(&objectKey, ObjStr(obj->cmdName)); - - if (cl) - ALLOC_DSTRING(&methodKey, ObjStr(cl->object.cmdName)); - else - ALLOC_DSTRING(&methodKey, ObjStr(obj->cmdName)); - Tcl_DStringAppend(&methodKey, "->", 2); - Tcl_DStringAppend(&methodKey, methodName, -1); - if (cl) - Tcl_DStringAppend(&methodKey, " (instproc)", 11); - else - Tcl_DStringAppend(&methodKey, " (proc)", 7); - - XOTclProfileFillTable(&profile->objectData, &objectKey, totalMicroSec); - XOTclProfileFillTable(&profile->methodData, &methodKey, totalMicroSec); - DSTRING_FREE(&objectKey); - DSTRING_FREE(&methodKey); -} - -void -XOTclProfilePrintTable(Tcl_HashTable* table) { - Tcl_HashEntry* topValueHPtr; - long int* topValue; - - do { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = table ? - Tcl_FirstHashEntry(table, &hSrch) : 0; - char* topKey = 0; - - topValueHPtr = 0; - topValue = 0; - - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - long int *val = (long int*) Tcl_GetHashValue(hPtr); - if (val && (!topValue || (topValue && *val >= *topValue))) { - topValue = val; - topValueHPtr = hPtr; - topKey = Tcl_GetHashKey(table, hPtr); - } - } - - if (topValueHPtr) { - fprintf(stderr, " %15ld %s\n", *topValue, topKey); - ckfree((char*) topValue); - Tcl_DeleteHashEntry(topValueHPtr); - } - } while (topValueHPtr); -} - -void -XOTclProfilePrintData(Tcl_Interp *interp) { - XOTclProfile* profile = &RUNTIME_STATE(interp)->profile; - - fprintf(stderr, "------------------------------------------------------------------\n"); - fprintf(stderr, "\nXOTcl Profile Information\n\n"); - fprintf(stderr, "------------------------------------------------------------------\n"); - fprintf(stderr, "Overall Elapsed Time %ld\n", - profile->overallTime); - fprintf(stderr, "------------------------------------------------------------------\n"); - fprintf(stderr, " MICROSECONDS OBJECT-NAME\n"); - XOTclProfilePrintTable(&profile->objectData); - fprintf(stderr, "------------------------------------------------------------------\n"); - fprintf(stderr, " MICROSECONDS (CL/OBJ)->METHOD-NAME\n"); - XOTclProfilePrintTable(&profile->methodData); - fprintf(stderr, "------------------------------------------------------------------\n"); -} - -void -XOTclProfileInit(Tcl_Interp *interp) { - RUNTIME_STATE(interp)->profile.overallTime = 0; - Tcl_InitHashTable(&RUNTIME_STATE(interp)->profile.objectData, - TCL_STRING_KEYS); - Tcl_InitHashTable(&RUNTIME_STATE(interp)->profile.methodData, - TCL_STRING_KEYS); -} - -#endif Index: generic/xotclShadow.c =================================================================== diff -u -N --- generic/xotclShadow.c (revision 335be502582c8dbf25ed808978d56a8fde39c991) +++ generic/xotclShadow.c (revision 0) @@ -1,231 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * - * xotclShadow.c -- - * - * Shadowing (overloading) and accessing global tcl obj commands - * - */ - -#include "xotclInt.h" -#include "xotclAccessInt.h" - -static int -XOTclReplaceCommandCleanup(Tcl_Interp *interp, XOTclGlobalNames name) { - Tcl_Command cmd; - int result = TCL_OK; - XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; - - /*fprintf(stderr," cleanup for %s ti=%p in %p\n", XOTclGlobalStrings[name], ti, interp);*/ - cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjs[name]); - if (cmd != NULL) { - Tcl_Command_objProc(cmd) = ti->proc; - ti->proc = NULL; - } else { - result = TCL_ERROR; - } - - return result; -} - -static void -XOTclReplaceCommandCheck(Tcl_Interp *interp, XOTclGlobalNames name, Tcl_ObjCmdProc *proc) { - Tcl_Command cmd; - XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; - cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjs[name]); - - if (cmd != NULL && ti->proc && Tcl_Command_objProc(cmd) != proc) { - /* - fprintf(stderr, "we have to do something about %s %p %p\n", - XOTclGlobalStrings[name], Tcl_Command_objProc(cmd), proc); - */ - ti->proc = Tcl_Command_objProc(cmd); - ti->clientData = Tcl_Command_objClientData(cmd); - Tcl_Command_objProc(cmd) = proc; - } -} - -static int -XOTclReplaceCommand(Tcl_Interp *interp, XOTclGlobalNames name, - Tcl_ObjCmdProc *xotclReplacementProc, int pass) { - Tcl_Command cmd; - XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; - int result = TCL_OK; - - /*fprintf(stderr,"XOTclReplaceCommand %d\n",name);*/ - cmd = Tcl_GetCommandFromObj(interp, XOTclGlobalObjs[name]); - - if (cmd == NULL) { - result = TCL_ERROR; - } else { - Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); - if (xotclReplacementProc != objProc) { - if (pass == 0) { /* setting values on first pass (must be locked here) */ - ti->proc = objProc; - ti->clientData = Tcl_Command_objClientData(cmd); - } else if (ti->proc != objProc) { - /*fprintf(stderr, "we have to refetch command for %s\n",XOTclGlobalStrings[name]);*/ - ti->proc = objProc; - ti->clientData = Tcl_Command_objClientData(cmd); - } - if (xotclReplacementProc) { - Tcl_Command_objProc(cmd) = xotclReplacementProc; - /*Tcl_CreateObjCommand(interp, XOTclGlobalStrings[name], xotclReplacementProc, 0, 0);*/ - } - } - } - return result; -} - -static int -XOTcl_RenameObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - /* this call the Tcl_RenameObjCmd, but it ensures before that - the renamed obj, functions, etc. are not part of XOTcl */ - Tcl_Command cmd; - - /* wrong # args => normal Tcl ErrMsg*/ - if (objc != 3) { - return XOTclCallCommand(interp, XOTE_RENAME, objc, objv); - } - - /* if an obj/cl should be renamed => call the XOTcl move method */ - cmd = Tcl_FindCommand(interp, ObjStr(objv[1]), (Tcl_Namespace *)NULL,0); - if (cmd) { - XOTclObject *object = XOTclGetObjectFromCmdPtr(cmd); - Tcl_Obj *methodObj = object ? XOTclMethodObj(interp, object, XO_o_move_idx) : NULL; - if (object && methodObj) { - return XOTclCallMethodWithArgs((ClientData)object, interp, - methodObj, objv[2], 1, 0, 0); - } - } - - /* Actually rename the cmd using Tcl's rename*/ - return XOTclCallCommand(interp, XOTE_RENAME, objc, objv); -} - -static int -XOTcl_InfoFrameObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result; - - result = XOTclCallCommand(interp, XOTE_INFO_FRAME, objc, objv); - - if (result == TCL_OK && objc == 2) { - int level, topLevel, frameFlags; - CONST char *frameType; - CmdFrame *framePtr = Tcl_Interp_cmdFramePtr(interp); - CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); - Tcl_Obj *resultObj = Tcl_GetObjResult(interp); - - /* level must be ok, otherwise we weould not have a TCL_OK */ - Tcl_GetIntFromObj(interp, objv[1], &level); - - /* todo: coroutine level messing is missing */ - topLevel = framePtr == NULL ? 0 : framePtr->level; - - if (level > 0) { - level -= topLevel; - } - /*fprintf(stderr, "topLevel %d level %d\n",topLevel, level);*/ - while (++level <= 0) { - framePtr = framePtr->nextPtr; - varFramePtr = varFramePtr->callerPtr; - } - frameFlags = Tcl_CallFrame_isProcCallFrame(varFramePtr); - /*fprintf(stderr, " ... frame %p varFramePtr %p frameFlags %.6x\n", framePtr, varFramePtr, frameFlags); - tcl85showStack(interp);*/ - if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - XOTclCallStackContent *cscPtr = - ((XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr)); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("object",6)); - Tcl_ListObjAppendElement(interp, resultObj, cscPtr->self->cmdName); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("class",5)); - Tcl_ListObjAppendElement(interp, resultObj, - cscPtr->cl ? cscPtr->cl->object.cmdName : XOTclGlobalObjs[XOTE_EMPTY]); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("frametype",9)); - if (cscPtr->frameType == XOTCL_CSC_TYPE_PLAIN) { - frameType = "intrinsic"; - } else if (cscPtr->frameType & XOTCL_CSC_TYPE_ACTIVE_MIXIN) { - frameType = "mixin"; - } else if (cscPtr->frameType & XOTCL_CSC_TYPE_ACTIVE_FILTER) { - frameType = "filter"; - } else if (cscPtr->frameType & XOTCL_CSC_TYPE_GUARD) { - frameType = "guard"; - } else { - frameType = "unknown"; - } - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(frameType,-1)); - } - } - - return result; -} - -/* - * Obtain the names of the tcl commands - * not available through the stub interface and overload some global commands - */ -int -XOTclShadowTclCommands(Tcl_Interp *interp, XOTclShadowOperations load) { - int rc = TCL_OK; - if (load == SHADOW_LOAD) { - int initialized = (RUNTIME_STATE(interp)->tclCommands != NULL); - assert(initialized == 0); - RUNTIME_STATE(interp)->tclCommands = - NEW_ARRAY(XOTclShadowTclCommandInfo, XOTE_SUBST - XOTE_EXPR + 1); - - /*fprintf(stderr, "+++ load tcl commands %d %d\n", load, initialized);*/ - -#ifdef USE_TCL_STUBS - /* no commands are overloaded, these are only used for calling - e.g. Tcl_ExprObjCmd(), Tcl_IncrObjCmd() and Tcl_SubstObjCmd(), - which are not available in though the stub table */ - rc |= XOTclReplaceCommand(interp, XOTE_EXPR, NULL, initialized); - rc |= XOTclReplaceCommand(interp, XOTE_SUBST, NULL, initialized); -#endif - rc |= XOTclReplaceCommand(interp, XOTE_FORMAT, NULL, initialized); - rc |= XOTclReplaceCommand(interp, XOTE_INTERP, NULL, initialized); - rc |= XOTclReplaceCommand(interp, XOTE_IS, NULL, initialized); - - /* for the following commands, we have to add our own semantics */ - rc |= XOTclReplaceCommand(interp, XOTE_INFO_FRAME, XOTcl_InfoFrameObjCmd, initialized); - rc |= XOTclReplaceCommand(interp, XOTE_RENAME, XOTcl_RenameObjCmd, initialized); - - } else if (load == SHADOW_REFETCH) { - XOTclReplaceCommandCheck(interp, XOTE_RENAME, XOTcl_RenameObjCmd); - } else { - XOTclReplaceCommandCleanup(interp, XOTE_RENAME); - XOTclReplaceCommandCleanup(interp, XOTE_INFO_FRAME); - FREE(XOTclShadowTclCommandInfo*, RUNTIME_STATE(interp)->tclCommands); - RUNTIME_STATE(interp)->tclCommands = NULL; - } - return rc; -} - -/* - * call a Tcl command with given objv's ... replace objv[0] - * with the given command name - */ -int XOTclCallCommand(Tcl_Interp *interp, XOTclGlobalNames name, - int objc, Tcl_Obj *CONST objv[]) { - int result; - XOTclShadowTclCommandInfo *ti = &RUNTIME_STATE(interp)->tclCommands[name-XOTE_EXPR]; - ALLOC_ON_STACK(Tcl_Obj*,objc, ov); - /* - {int i; - fprintf(stderr,"calling %s (%p %p) in %p, objc=%d ", - XOTclGlobalStrings[name],ti,ti->proc, interp, objc); - for(i=0;i 1) - memcpy(ov+1, objv+1, sizeof(Tcl_Obj *)*(objc-1)); - result = Tcl_NRCallObjProc(interp, ti->proc, ti->clientData, objc, objv); - FREE_ON_STACK(Tcl_Obj *, ov); - return result; -} Index: generic/xotclStack85.c =================================================================== diff -u -N --- generic/xotclStack85.c (revision 89b5047e54e47a88a7de75d8523a07ffa5743407) +++ generic/xotclStack85.c (revision 0) @@ -1,532 +0,0 @@ - -static TclVarHashTable *VarHashTableCreate(); -static void XOTclCleanupObject(XOTclObject *object); - -void tcl85showStack(Tcl_Interp *interp) { - Tcl_CallFrame *framePtr; - - fprintf(stderr, "tcl85showStack framePtr %p varFramePtr %p\n", - Tcl_Interp_framePtr(interp), Tcl_Interp_varFramePtr(interp)); - /* framePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { - fprintf(stderr, "... frame %p flags %.6x cd %p objv[0] %s\n", - framePtr, Tcl_CallFrame_isProcCallFrame(framePtr), - Tcl_CallFrame_clientData(framePtr), - Tcl_CallFrame_objc(framePtr) ? ObjStr(Tcl_CallFrame_objv(framePtr)[0]) : "(null)"); - }*/ - framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); - for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { - int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); - XOTclCallStackContent *cscPtr = - (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) ? - ((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr)) : NULL; - - fprintf(stderr, "... var frame %p flags %.6x cd %p lvl %d ns %p %s ov %s %d", - framePtr, frameFlags, - Tcl_CallFrame_clientData(framePtr), - Tcl_CallFrame_level(framePtr), - Tcl_CallFrame_nsPtr(framePtr), Tcl_CallFrame_nsPtr(framePtr)->fullName, - Tcl_CallFrame_objc(framePtr) ? ObjStr(Tcl_CallFrame_objv(framePtr)[0]) : "(null)", - Tcl_CallFrame_objc(framePtr) ? Tcl_CallFrame_objc(framePtr) : -1); - if (cscPtr) { - fprintf(stderr, " frameType %d callType %d (%p %s)\n", - cscPtr ? cscPtr->frameType : -1, - cscPtr ? cscPtr->callType : -1, - cscPtr ? cscPtr->self : NULL, - cscPtr ? objectName(cscPtr->self) : ""); - } else { - fprintf(stderr, " no csc"); - if (frameFlags & FRAME_IS_XOTCL_OBJECT) { - XOTclObject *object = (XOTclObject *)Tcl_CallFrame_clientData(framePtr); - fprintf(stderr, " obj %p %s", object, objectName(object)); - } - fprintf(stderr, "\n"); - } - } -} - -/* - * Push and pop operations. - * - * Note that it is possible that between push and pop - * a object->nsPtr can be created (e.g. during a read trace) - */ - -static void XOTcl_PushFrameObj(Tcl_Interp *interp, XOTclObject *object, Tcl_CallFrame *framePtr) { - /*fprintf(stderr,"PUSH OBJECT_FRAME (XOTcl_PushFrame) frame %p\n",framePtr);*/ - if (object->nsPtr) { - /*fprintf(stderr,"XOTcl_PushFrame frame %p with object->nsPtr %p\n", framePtr, object->nsPtr);*/ - Tcl_PushCallFrame(interp, framePtr, object->nsPtr, - 0|FRAME_IS_XOTCL_OBJECT); - } else { - /*fprintf(stderr,"XOTcl_PushFrame frame %p (with fakeProc)\n",framePtr);*/ - Tcl_PushCallFrame(interp, framePtr, Tcl_CallFrame_nsPtr(Tcl_Interp_varFramePtr(interp)), - 1|FRAME_IS_XOTCL_OBJECT); - - Tcl_CallFrame_procPtr(framePtr) = &RUNTIME_STATE(interp)->fakeProc; - if (object->varTable == NULL) { - object->varTable = VarHashTableCreate(); - /*fprintf(stderr, "+++ create varTable %p in PushFrameObj obj %p framePtr %p\n", - object->varTable, object, framePtr);*/ - } - Tcl_CallFrame_varTablePtr(framePtr) = object->varTable; - /*fprintf(stderr,"+++ setting varTable %p in varFrame %p\n",object->varTable,framePtr);*/ - } - Tcl_CallFrame_clientData(framePtr) = (ClientData)object; -} - -static void XOTcl_PopFrameObj(Tcl_Interp *interp, Tcl_CallFrame *framePtr) { - /*fprintf(stderr,"POP OBJECT_FRAME (XOTcl_PopFrame) frame %p, vartable %p set to NULL, already %d\n", - framePtr, Tcl_CallFrame_varTablePtr(framePtr), Tcl_CallFrame_varTablePtr(framePtr) == NULL);*/ - Tcl_CallFrame_varTablePtr(framePtr) = NULL; - Tcl_PopCallFrame(interp); -} - -static void XOTcl_PushFrameCsc(Tcl_Interp *interp, XOTclCallStackContent *cscPtr, Tcl_CallFrame *framePtr) { - CallFrame *varFramePtr = Tcl_Interp_varFramePtr(interp); - - /*fprintf(stderr,"PUSH CMETHOD_FRAME (XOTcl_PushFrame) frame %p object->nsPtr %p interp ns %p\n", - framePtr,object->nsPtr, - Tcl_CallFrame_nsPtr(varFramePtr));*/ - - Tcl_PushCallFrame(interp, framePtr, Tcl_CallFrame_nsPtr(varFramePtr), - 1|FRAME_IS_XOTCL_CMETHOD); - Tcl_CallFrame_clientData(framePtr) = (ClientData)cscPtr; - Tcl_CallFrame_procPtr(framePtr) = &RUNTIME_STATE(interp)->fakeProc; -} - -static void XOTcl_PopFrameCsc(Tcl_Interp *interp, Tcl_CallFrame *framePtr) { - /*fprintf(stderr,"POP CMETHOD_FRAME (XOTcl_PopFrame) frame %p, varTable = %p\n", - framePtr, Tcl_CallFrame_varTablePtr(framePtr));*/ - Tcl_PopCallFrame(interp); -} - -/* - * stack query operations - */ - -static Tcl_CallFrame * -activeProcFrame(Tcl_CallFrame *framePtr) { - for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { - register int flag = Tcl_CallFrame_isProcCallFrame(framePtr); - - if (flag & FRAME_IS_XOTCL_METHOD) { - /* never return an inactive method frame */ - if (!(((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr))->frameType - & XOTCL_CSC_TYPE_INACTIVE)) break; - } else { - if (flag & (FRAME_IS_XOTCL_CMETHOD|FRAME_IS_XOTCL_OBJECT)) continue; - if (flag == 0 || flag & FRAME_IS_PROC) break; - } - } - return framePtr; -} - -static Tcl_CallFrame * -nextFrameOfType(Tcl_CallFrame *framePtr, int flags) { - for (; framePtr; framePtr = Tcl_CallFrame_callerPtr(framePtr)) { - if (Tcl_CallFrame_isProcCallFrame(framePtr) & flags) - return framePtr; - } - return framePtr; -} - -XOTCLINLINE static XOTclObject* -GetSelfObj(Tcl_Interp *interp) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - /*fprintf(stderr, "GetSelfObj interp has frame %p and varframe %p\n", - Tcl_Interp_framePtr(interp),Tcl_Interp_varFramePtr(interp));*/ - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - register int flag = Tcl_CallFrame_isProcCallFrame(varFramePtr); -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "GetSelfObj check frame %p flags %.6x cd %p objv[0] %s\n", - varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr), - Tcl_CallFrame_clientData(varFramePtr), - Tcl_CallFrame_objc(varFramePtr) ? ObjStr(Tcl_CallFrame_objv(varFramePtr)[0]) : "(null)"); -#endif - if (flag & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "... self returns %p %.6x %s\n", cscPtr->self, - cscPtr->self->flags, objectName(cscPtr->self)); -#endif - return cscPtr->self; - } else if (flag & FRAME_IS_XOTCL_OBJECT) { -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "... self returns %s\n", - objectName(((XOTclObject*)Tcl_CallFrame_clientData(varFramePtr)))); -#endif - return (XOTclObject *)Tcl_CallFrame_clientData(varFramePtr); - } - } - return NULL; -} - -static XOTclCallStackContent* -CallStackGetFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { -# if defined(TCL85STACK_TRACE) - fprintf(stderr, "... check frame %p flags %.6x cd %p objv[0] %s\n", - varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr), - Tcl_CallFrame_clientData(varFramePtr), - Tcl_CallFrame_objc(varFramePtr) ? ObjStr(Tcl_CallFrame_objv(varFramePtr)[0]) : "(null)"); -# endif - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - if (framePtrPtr) *framePtrPtr = varFramePtr; - return (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - } - } - if (framePtrPtr) *framePtrPtr = NULL; - return NULL; -} - -XOTCLINLINE static XOTclCallStackContent* -CallStackGetTopFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr) { - return CallStackGetFrame(interp, framePtrPtr); -} - -/* find last invocation of a scripted method */ -static XOTclCallStackContent * -XOTclCallStackFindLastInvocation(Tcl_Interp *interp, int offset, Tcl_CallFrame **framePtrPtr) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - int lvl = Tcl_CallFrame_level(varFramePtr); - - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_XOTCL_METHOD) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - if ((cscPtr->callType & XOTCL_CSC_CALL_IS_NEXT) || (cscPtr->frameType & XOTCL_CSC_TYPE_INACTIVE)) { - continue; - } - if (offset) { - offset--; - } else { - if (Tcl_CallFrame_level(varFramePtr) < lvl) { - if (framePtrPtr) *framePtrPtr = varFramePtr; - return cscPtr; - } - } - } - } - if (framePtrPtr) *framePtrPtr = NULL; - return NULL; -} - -static XOTclCallStackContent * -XOTclCallStackFindActiveFrame(Tcl_Interp *interp, int offset, Tcl_CallFrame **framePtrPtr) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - /* skip #offset frames */ - for (; offset>0 && varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr), offset--); - - /* search for first active frame and set tcl frame pointers */ - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_XOTCL_METHOD/*(FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)*/) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - if (!(cscPtr->frameType & XOTCL_CSC_TYPE_INACTIVE)) { - /* we found the highest active frame */ - if (framePtrPtr) *framePtrPtr = varFramePtr; - return cscPtr; - } - } - } - /* we could not find an active frame; called from toplevel? */ - if (framePtrPtr) *framePtrPtr = NULL; - return NULL; -} - -static void -CallStackUseActiveFrames(Tcl_Interp *interp, callFrameContext *ctx) { - Tcl_CallFrame - *inFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp), - *framePtr; - - /*XOTclCallStackFindActiveFrame(interp, 0, &activeFramePtr);*/ -# if defined(TCL85STACK_TRACE) - tcl85showStack(interp); -# endif - /* Get the first active non object frame */ - framePtr = activeProcFrame(inFramePtr); - - /*fprintf(stderr,"... use frameptr %p \n", framePtr);*/ - - if (inFramePtr == framePtr) { - /* call frame pointers are fine */ - ctx->framesSaved = 0; - } else { - ctx->varFramePtr = inFramePtr; - Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; - ctx->framesSaved = 1; - } -} - - -static XOTclCallStackContent * -CallStackFindActiveFilter(Tcl_Interp *interp) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - if (cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - return cscPtr; - } - } - } - /* for some reasons, we could not find invocation (topLevel, destroy) */ - return NULL; -} - -/* - * check, if there is an active filters on "obj" using cmd - */ -XOTCLINLINE static int -FilterActiveOnObj(Tcl_Interp *interp, XOTclObject *object, Tcl_Command cmd) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - if (cmd == cscPtr->cmdPtr && object == cscPtr->self && - cscPtr->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - return 1; - } - } - } - return 0; -} - -static void -CallStackReplaceVarTableReferences(Tcl_Interp *interp, TclVarHashTable *oldVarTablePtr, TclVarHashTable *newVarTablePtr) { - Tcl_CallFrame *framePtr; - - for (framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); framePtr; - framePtr = Tcl_CallFrame_callerPtr(framePtr)) { - int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); - - if (!(frameFlags & FRAME_IS_XOTCL_OBJECT)) continue; - if (!(Tcl_CallFrame_varTablePtr(framePtr) == oldVarTablePtr)) continue; - - /*fprintf(stderr, "+++ makeObjNamespace replacing vartable %p with %p in frame %p\n", - oldVarTablePtr, newVarTablePtr, framePtr);*/ - Tcl_CallFrame_varTablePtr(framePtr) = newVarTablePtr; - } -} - -static void -CallStackClearCmdReferences(Tcl_Interp *interp, Tcl_Command cmd) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - if (cscPtr->cmdPtr == cmd) { - cscPtr->cmdPtr = NULL; - } - } - } -} - - -#if 0 -/* just used by XOTclONextMethod() */ -static XOTclCallStackContent* -CallStackGetObjectFrame(Tcl_Interp *interp, XOTclObject *object) { - register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - - for (; varFramePtr; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) { - if (Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - XOTclCallStackContent *cscPtr = (XOTclCallStackContent *)Tcl_CallFrame_clientData(varFramePtr); - if (cscPtr->self == object) { - return cscPtr; - } - } - } - return NULL; -} -#endif - -/* - * Pop any callstack entry that is still alive (e.g. - * if "exit" is called and we were jumping out of the - * callframe - */ -static void CallStackPopAll(Tcl_Interp *interp) { - /*tcl85showStack(interp);*/ - - while (1) { - Tcl_CallFrame *framePtr = Tcl_Interp_framePtr(interp); - int frameFlags; - - if (!framePtr) break; - if (Tcl_CallFrame_level(framePtr) == 0) break; - - frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); - /*fprintf(stderr, "--- popping %p frameflags %.6x\n", framePtr, frameFlags);*/ - - if (frameFlags & (FRAME_IS_XOTCL_METHOD|FRAME_IS_XOTCL_CMETHOD)) { - /* free the call stack content; we need this just for decr activation count */ - XOTclCallStackContent *cscPtr = ((XOTclCallStackContent *)Tcl_CallFrame_clientData(framePtr)); - CscFinish(interp, cscPtr); - } else if (frameFlags & FRAME_IS_XOTCL_OBJECT) { - Tcl_CallFrame_varTablePtr(framePtr) = NULL; - } - - /* pop the Tcl frame */ - Tcl_PopCallFrame(interp); - } -} - -/* - *---------------------------------------------------------------------- - * CscInit -- - * - * Initialize call stack content and track activation counts - * of involved objects and classes - * - * Results: - * None. - * - * Side effects: - * Initialized Csc, updated activation counts - * - *---------------------------------------------------------------------- - */ - -XOTCLINLINE static void -CscInit(/*@notnull@*/ XOTclCallStackContent *cscPtr, XOTclObject *object, XOTclClass *cl, Tcl_Command cmd, int frameType) { - - assert(cscPtr); - - /* - * track object activations - */ - object->activationCount ++; - - /* - * track class activations - */ - if (cl) { - Namespace *nsPtr = ((Command *)cmd)->nsPtr; - cl->object.activationCount ++; - /*fprintf(stderr, "... %s cmd %s cmd ns %p (%s, refCount %d ++) obj ns %p parent %p\n", - className(cl), - Tcl_GetCommandName(object->teardown, cmd), - nsPtr, nsPtr->fullName, nsPtr->refCount, - cl->object.nsPtr,cl->object.nsPtr ? ((Namespace*)cl->object.nsPtr)->parentPtr : NULL);*/ - - /* incremement the namespace ptr in case tcl tries to delete this namespace - during the invocation */ - nsPtr->refCount ++; - } - - /* fprintf(stderr, "incr activationCount for %s to %d\n", objectName(object), object->activationCount); */ - cscPtr->self = object; - cscPtr->cl = cl; - cscPtr->cmdPtr = cmd; - cscPtr->frameType = frameType; - cscPtr->callType = 0; - cscPtr->filterStackEntry = frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER ? object->filterStack : NULL; - cscPtr->objv = NULL; - -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "PUSH csc %p type %d obj %s, self=%p cmd=%p (%s) id=%p (%s) obj refcount %d name refcount %d\n", - cscPtr, frameType, objectName(object), object, - cmd, (char *) Tcl_GetCommandName(object->teardown, cmd), - object->id, object->id ? Tcl_GetCommandName(object->teardown, object->id) : "(deleted)", - object->id ? Tcl_Command_refCount(object->id) : -100, object->cmdName->refCount - ); -#endif -} - -/* - *---------------------------------------------------------------------- - * CscFinish -- - * - * Counterpart of CscInit(). Decrement activation counts - * and delete objects/classes if necessary. - * - * Results: - * None. - * - * Side effects: - * potentially deletes objects, classes or namespaces. - * - *---------------------------------------------------------------------- - */ -XOTCLINLINE static void -CscFinish(Tcl_Interp *interp, XOTclCallStackContent *cscPtr) { - XOTclObject *object = cscPtr->self; - int allowDestroy = RUNTIME_STATE(interp)->exitHandlerDestroyRound != - XOTCL_EXITHANDLER_ON_SOFT_DESTROY; - -#if defined(TCL85STACK_TRACE) - fprintf(stderr, "POP csc=%p, obj %s method %s\n", cscPtr, objectName(object), - Tcl_GetCommandName(interp, cscPtr->cmdPtr)); -#endif - /* - tracking activations of objects - */ - object->activationCount --; - - /*fprintf(stderr, "decr activationCount for %s to %d cscPtr->cl %p\n", objectName(cscPtr->self), - cscPtr->self->activationCount, cscPtr->cl);*/ - - if (object->activationCount < 1 && object->flags & XOTCL_DESTROY_CALLED && allowDestroy) { - CallStackDoDestroy(interp, object); - } -#if defined(OBJDELETION_TRACE) - else if (!allowDestroy) { - fprintf(stderr,"checkFree %p %s\n",object, objectName(object)); - } -#endif - - /* - tracking activations of classes - */ - if (cscPtr->cl) { - Namespace *nsPtr = cscPtr->cmdPtr ? ((Command *)(cscPtr->cmdPtr))->nsPtr : NULL; - - object = &cscPtr->cl->object; - object->activationCount --; - /* fprintf(stderr, "CscFinish cl=%p %s (%d) flags %.6x cl ns=%p cmd %p cmd ns %p\n", - object, objectName(object), object->activationCount, object->flags, cscPtr->cl->nsPtr, - cscPtr->cmdPtr, ((Command *)cscPtr->cmdPtr)->nsPtr); */ - - /*fprintf(stderr, "CscFinish check ac %d flags %.6x\n", - object->activationCount, object->flags & XOTCL_DESTROY_CALLED);*/ - - if (object->activationCount < 1 && object->flags & XOTCL_DESTROY_CALLED && allowDestroy) { - CallStackDoDestroy(interp, object); - } -#if defined(OBJDELETION_TRACE) - else if (!allowDestroy) { - fprintf(stderr,"checkFree %p %s\n",object, objectName(object)); - } -#endif - - if (nsPtr) { - nsPtr->refCount--; - /*fprintf(stderr, "CscFinish parent %s activationCount %d flags %.4x refCount %d\n", - nsPtr->fullName, nsPtr->activationCount, nsPtr->flags, nsPtr->refCount);*/ - - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { - /* the namspace refcound has reached 0, we have to free - it. unfortunately, NamespaceFree() is not exported */ - /* TODO: remove me finally */ - fprintf(stderr, "HAVE TO FREE %p\n",nsPtr); - /*NamespaceFree(nsPtr);*/ - ckfree(nsPtr->fullName); - ckfree(nsPtr->name); - ckfree((char*)nsPtr); - } - } - - } - /*fprintf(stderr, "CscFinish done\n");*/ - -} - - Index: generic/xotclTrace.c =================================================================== diff -u -N --- generic/xotclTrace.c (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/xotclTrace.c (revision 0) @@ -1,144 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * - * xotclTrace.c -- - * - * Tracing facilities for XOTcl - * - */ - -#include "xotclInt.h" -#include "xotclAccessInt.h" - -void -XOTclStackDump(Tcl_Interp *interp) { - Interp *iPtr = (Interp *)interp; - CallFrame *f = iPtr->framePtr, *v = iPtr->varFramePtr; - Tcl_Obj *varCmdObj; - - XOTclNewObj(varCmdObj); - fprintf (stderr, " TCL STACK:\n"); - if (f == 0) fprintf(stderr, "- "); - while (f) { - Tcl_Obj *cmdObj; - XOTclNewObj(cmdObj); - fprintf(stderr, "\tFrame=%p ", f); - if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) { - fprintf(stderr,"caller %p ",Tcl_CallFrame_callerPtr(f)); - fprintf(stderr,"callerV %p ",Tcl_CallFrame_callerVarPtr(f)); - Tcl_GetCommandFullName(interp, (Tcl_Command) f->procPtr->cmdPtr, cmdObj); - fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level); - DECR_REF_COUNT(cmdObj); - } else { - if (f && f->varTablePtr) { - fprintf(stderr, "var_table = %p ",f->varTablePtr); - } - fprintf(stderr, "- \n"); - } - - f = f->callerPtr; - } - - fprintf (stderr, " VARFRAME:\n"); - fprintf(stderr, "\tFrame=%p ", v); - if (v) { - fprintf(stderr, "caller %p var_table %p ", v->callerPtr, v->varTablePtr); - /* if (v->varTablePtr) - panic(0, "testing");*/ - } - if (v && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) { - Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj); - if (varCmdObj) { - fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level); - } - } else fprintf(stderr, "- \n"); - DECR_REF_COUNT(varCmdObj); -} - -void -XOTclPrintObjv(char *string, int objc, Tcl_Obj *CONST objv[]) { - int j; - fprintf(stderr, "%s", string); - for (j = 0; j < objc; j++) { - /*fprintf(stderr, " objv[%d]=%s, ",j, objv[j] ? ObjStr(objv[j]) : "NULL");*/ - fprintf(stderr, " objv[%d]=%s %p, ",j, objv[j] ? ObjStr(objv[j]) : "NULL", objv[j]); - } - fprintf(stderr, "\n"); -} - -#ifdef XOTCL_MEM_COUNT -void -XOTclMemCountAlloc(char *id, void *p) { - int new; - XOTclMemCounter *entry; - Tcl_HashTable *table = &xotclMemCount; - Tcl_HashEntry *hPtr; - hPtr = Tcl_CreateHashEntry(table, id, &new); -#ifdef XOTCL_MEM_TRACE - fprintf(stderr, "+++ alloc %s %p\n",id,p); -#endif - /*fprintf(stderr,"+++alloc '%s'\n",id);*/ - if (new) { - entry = (XOTclMemCounter*)ckalloc(sizeof(XOTclMemCounter)); - entry->count = 1; - entry->peak = 1; - Tcl_SetHashValue(hPtr, entry); - } else { - entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); - entry->count++; - if (entry->count > entry->peak) - entry->peak = entry->count; - } -} - -void -XOTclMemCountFree(char *id, void *p) { - XOTclMemCounter *entry; - Tcl_HashTable *table = &xotclMemCount; - Tcl_HashEntry *hPtr; -#ifdef XOTCL_MEM_TRACE - fprintf(stderr, "+++ free %s %p\n",id,p); -#endif - - hPtr = Tcl_FindHashEntry(table, id); - if (!hPtr) { - fprintf(stderr, "******** MEM COUNT ALERT: Trying to free <%s>, but was not allocated\n", id); - return; - } - entry = (XOTclMemCounter *)Tcl_GetHashValue(hPtr); - entry->count--; -} - -void -XOTclMemCountDump() { - Tcl_HashTable *table = &xotclMemCount; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - int count = 0; - - xotclMemCountInterpCounter--; - if (xotclMemCountInterpCounter != 0) { - return; - } - - fprintf(stderr, "******** XOTcl MEM Count *********\n* count peak\n"); - - for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - char *id = Tcl_GetHashKey(table, hPtr); - XOTclMemCounter *entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); - count += entry->count; - fprintf(stderr, "* %4d %6d %s\n", entry->count, entry->peak, id); - ckfree ((char*) entry); - } - - Tcl_DeleteHashTable(table); - - fprintf(stderr, "******** Count Overall = %d\n", count); -} - -#endif Index: generic/xotclUtil.c =================================================================== diff -u -N --- generic/xotclUtil.c (revision 11d5a8a7fab7ba69a94b161bb9c0aae5a2636e7b) +++ generic/xotclUtil.c (revision 0) @@ -1,124 +0,0 @@ -/* -*- Mode: c++ -*- - * - * Extended Object Tcl (XOTcl) - * - * Copyright (C) 1999-2010 Gustaf Neumann, Uwe Zdun - * - * - * xotclUtil.c -- - * - * Utility functions - * - */ - -#include "xotclInt.h" - -char * -XOTcl_ltoa(char *buf, long i, int *len) /* fast version of sprintf(buf,"%ld",l); */ { - int nr_written, negative; - char tmp[LONG_AS_STRING], *pointer = &tmp[1], *string, *p; - *tmp = 0; - - if (i<0) { - i = -i; - negative = nr_written = 1; - } else - nr_written = negative = 0; - - do { - nr_written++; - *pointer++ = i%10 + '0'; - i/=10; - } while (i); - - p = string = buf; - if (negative) - *p++ = '-'; - - while ((*p++ = *--pointer)); /* copy number (reversed) from tmp to buf */ - if (len) *len = nr_written; - return string; -} - - -static char *alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; -static int blockIncrement = 8; -/* -static char *alphabet = "ab"; -static int blockIncrement = 2; -*/ -static unsigned char chartable[255] = {0}; - - -char * -XOTclStringIncr(XOTclStringIncrStruct *iss) { - char newch, *currentChar; - - currentChar = iss->buffer + iss->bufSize - 2; - newch = *(alphabet + chartable[(unsigned)*currentChar]); - - while (1) { - if (newch) { /* no overflow */ - *currentChar = newch; - break; - } else { /* overflow */ - *currentChar = *alphabet; /* use first char from alphabet */ - currentChar--; - assert(currentChar >= iss->buffer); - - newch = *(alphabet + chartable[(unsigned)*currentChar]); - if (currentChar < iss->start) { - iss->length++; - if (currentChar == iss->buffer) { - size_t newBufSize = iss->bufSize + blockIncrement; - char *newBuffer = ckalloc(newBufSize); - currentChar = newBuffer+blockIncrement; - /*memset(newBuffer, 0, blockIncrement);*/ - memcpy(currentChar, iss->buffer, iss->bufSize); - *currentChar = newch; - iss->start = currentChar; - ckfree(iss->buffer); - iss->buffer = newBuffer; - iss->bufSize = newBufSize; - } else { - iss->start = currentChar; - } - } - } - } - assert(iss->buffer[iss->bufSize-1] == 0); - assert(iss->buffer[iss->bufSize-2] != 0); - assert(iss->length < iss->bufSize); - assert(iss->start + iss->length + 1 == iss->buffer + iss->bufSize); - - return iss->start; -} - - -void -XOTclStringIncrInit(XOTclStringIncrStruct *iss) { - char *p; - int i = 0; - const size_t bufSize = blockIncrement>2 ? blockIncrement : 2; - - for (p=alphabet; *p; p++) { - chartable[(int)*p] = ++i; - } - - iss->buffer = ckalloc(bufSize); - memset(iss->buffer, 0, bufSize); - iss->start = iss->buffer + bufSize-2; - iss->bufSize = bufSize; - iss->length = 1; - /* - for (i=1; i<50; i++) { - XOTclStringIncr(iss); - fprintf(stderr, "string '%s' (%d)\n", iss->start, iss->length); - } - */ -} - -void -XOTclStringIncrFree(XOTclStringIncrStruct *iss) { - ckfree(iss->buffer); -} Index: library/xotcl/library/store/XOTclGdbm/xotcl.m4 =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/store/XOTclGdbm/xotcl.m4 (.../xotcl.m4) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/store/XOTclGdbm/xotcl.m4 (.../xotcl.m4) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -4,14 +4,15 @@ # a Tcl extension. # # Copyright (c) 1999 Scriptics Corporation. +# Copyright (c) 1999-2008 Gustaf Neumann, Uwe Zdun # -# See the file "license.terms" for information on usage and redistribution +# See the file "tcl-license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------------------ -# SC_PATH_XOTCLCONFIG -- +# SC_PATH_NSFCONFIG -- # -# Locate the xotclConfig.sh file and perform a sanity check on +# Locate the nsfConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: @@ -23,11 +24,11 @@ # --with-xotcl=... # # Defines the following vars: -# XOTCL_BIN_DIR Full path to the directory containing -# the xotclConfig.sh file +# NX_BIN_DIR Full path to the directory containing +# the nsfConfig.sh file #------------------------------------------------------------------------ -AC_DEFUN(SC_PATH_XOTCLCONFIG, [ +AC_DEFUN(SC_PATH_NSFCONFIG, [ # # Ok, lets find the tcl configuration # First, look for one uninstalled. @@ -36,21 +37,21 @@ if test x"${no_xotcl}" = x ; then # we reset no_xotcl in case something fails here no_xotcl=true - AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (xotclConfig.sh)], with_xotclconfig=${withval}) + AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (nsfConfig.sh)], with_nsfconfig=${withval}) AC_MSG_CHECKING([for XOTcl configuration]) - AC_CACHE_VAL(ac_cv_c_xotclconfig,[ + AC_CACHE_VAL(ac_cv_c_nsfconfig,[ # First check to see if --with-xotcl was specified. - if test x"${with_xotclconfig}" != x ; then - if test -f "${with_xotclconfig}/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd ${with_xotclconfig}; pwd)` + if test x"${with_nsfconfig}" != x ; then + if test -f "${with_nsfconfig}/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd ${with_nsfconfig}; pwd)` else - AC_MSG_ERROR([${with_xotclconfig} directory doesn't contain xotclConfig.sh]) + AC_MSG_ERROR([${with_nsfconfig} directory doesn't contain nsfConfig.sh]) fi fi # then check for a private Tcl installation - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in \ ${srcdir}/../xotcl \ `ls -dr ${srcdir}/../xotcl-* 2>/dev/null` \ @@ -62,60 +63,60 @@ `ls -dr ${srcdir}/../../../../xotcl-* 2>/dev/null` \ ${srcdir}/../../../../../xotcl \ `ls -dr ${srcdir}/../../../../../xotcl-* 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi # check in a few common install locations - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi ]) - if test x"${ac_cv_c_xotclconfig}" = x ; then - XOTCL_BIN_DIR="# no XOTcl configs found" + if test x"${ac_cv_c_nsfconfig}" = x ; then + NX_BIN_DIR="# no XOTcl configs found" AC_MSG_WARN(Can't find XOTcl configuration definitions) exit 0 else no_xotcl= - XOTCL_BIN_DIR=${ac_cv_c_xotclconfig} - AC_MSG_RESULT(found $XOTCL_BIN_DIR/xotclConfig.sh) + NX_BIN_DIR=${ac_cv_c_nsfconfig} + AC_MSG_RESULT(found $NX_BIN_DIR/nsfConfig.sh) fi fi ]) #------------------------------------------------------------------------ -# SC_LOAD_XOTCLCONFIG -- +# SC_LOAD_NSFCONFIG -- # # Load the tclConfig.sh file # # Arguments: # # Requires the following vars to be set: -# XOTCL_BIN_DIR +# NX_BIN_DIR # # Results: # # Subst the vars: # #------------------------------------------------------------------------ -AC_DEFUN(SC_LOAD_XOTCLCONFIG, [ - AC_MSG_CHECKING([for existence of $XOTCL_BIN_DIR/xotclConfig.sh]) +AC_DEFUN(SC_LOAD_NSFCONFIG, [ + AC_MSG_CHECKING([for existence of $NX_BIN_DIR/nsfConfig.sh]) - if test -f "$XOTCL_BIN_DIR/xotclConfig.sh" ; then + if test -f "$NX_BIN_DIR/nsfConfig.sh" ; then AC_MSG_RESULT([loading]) - . $XOTCL_BIN_DIR/xotclConfig.sh + . $NX_BIN_DIR/nsfConfig.sh else AC_MSG_RESULT([file not found]) fi @@ -124,16 +125,16 @@ # The eval is required to do the TCL_DBGX substitution in the # TCL_LIB_FILE variable # - AC_SUBST(XOTCL_VERSION) - AC_SUBST(XOTCL_MAJOR_VERSION) - AC_SUBST(XOTCL_MINOR_VERSION) - AC_SUBST(XOTCL_RELEASE_LEVEL) - AC_SUBST(XOTCL_LIB_FILE) - AC_SUBST(XOTCL_BUILD_LIB_SPEC) - AC_SUBST(XOTCL_LIB_SPEC) - AC_SUBST(XOTCL_STUB_LIB_FILE) - AC_SUBST(XOTCL_BUILD_STUB_LIB_SPEC) - AC_SUBST(XOTCL_STUB_LIB_SPEC) - AC_SUBST(XOTCL_SRC_DIR) + AC_SUBST(NX_VERSION) + AC_SUBST(NX_MAJOR_VERSION) + AC_SUBST(NX_MINOR_VERSION) + AC_SUBST(NX_RELEASE_LEVEL) + AC_SUBST(NX_LIB_FILE) + AC_SUBST(NX_BUILD_LIB_SPEC) + AC_SUBST(NX_LIB_SPEC) + AC_SUBST(NX_STUB_LIB_FILE) + AC_SUBST(NX_BUILD_STUB_LIB_SPEC) + AC_SUBST(NX_STUB_LIB_SPEC) + AC_SUBST(NX_SRC_DIR) ]) Index: library/xotcl/library/store/XOTclGdbm/xotclgdbm.c =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/store/XOTclGdbm/xotclgdbm.c (.../xotclgdbm.c) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/store/XOTclGdbm/xotclgdbm.c (.../xotclgdbm.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -9,7 +9,7 @@ #include #include #include -#include +#include #if (TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<1) # define TclObjStr(obj) Tcl_GetStringFromObj(obj, ((int*)NULL)) @@ -321,8 +321,8 @@ if (Tcl_InitStubs(in, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } -# ifdef USE_XOTCL_STUBS - if (Xotcl_InitStubs(in, "1.1", 0) == NULL) { +# ifdef USE_NSF_STUBS + if (Nsf_InitStubs(in, "1.1", 0) == NULL) { return TCL_ERROR; } # endif Index: library/xotcl/library/store/XOTclSdbm/Makefile.vc =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/store/XOTclSdbm/Makefile.vc (.../Makefile.vc) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/store/XOTclSdbm/Makefile.vc (.../Makefile.vc) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -1,224 +1,224 @@ -###################################################################### -# -# XOTclSdbm Makefile for Visual C++ -# -###################################################################### - -# Be sure to adapt the "configs.vc" file in the toplevel directory -# to your system settings. -!include "..\..\..\win\configs.vc" - -BINROOT = . -ROOT = .. -NAMEPREFIX = lib -NAME = xotclsdbm -XOTCL_DIR = ..\..\.. -GENERICDIR = . -WINDIR = . - -###################################################################### - -!if $(DEBUG) -TMPNAME = Debug -DBGX = d -!else -TMPNAME = Release -DBGX = -!endif - -TMP_DIR = $(BINROOT)\$(TMPNAME) -OUT_DIR = $(TMP_DIR) - -!if $(STATIC_BUILD) -OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) -TARGET = "$(OUT_DIR)\$(OUTNAME).lib" -!else -OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) -IMPLIB = "$(OUT_DIR)\$(OUTNAME).lib" -TARGET = "$(OUT_DIR)\$(OUTNAME).dll" -!endif - -TCLSTUBLIB = "$(TCLROOT)\win\Release\tclstub$(TCL_VERSION).lib" -TCLIMPLIB = "$(TCLROOT)\win\$(OUT_DIR)\tcl$(TCL_VERSION)$(DBGX).lib" -TCLSH = "$(TCLROOT)\win\$(OUT_DIR)\tclsh$(TCL_VERSION)$(DBGX).exe" - -XOTCLSTUBLIB = "$(XOTCL_DIR)\win\Release\libxotclstub$(XOTCL_VERSION).lib" -XOTCLIMPLIB = "$(XOTCL_DIR)\win\$(OUT_DIR)\libxotcl$(XOTCL_VERSION)$(DBGX).lib" - -LIB_INSTALL_DIR = $(INSTALLDIR)\lib -BIN_INSTALL_DIR = $(INSTALLDIR)\bin -SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\xotcl$(XOTCL_VERSION) -INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include - -OBJS = $(TMP_DIR)\hash.obj \ - $(TMP_DIR)\pair.obj \ - $(TMP_DIR)\sdbm.obj \ - $(TMP_DIR)\xotclsdbm.obj \ -!if $(STATIC_BUILD) == 0 - $(TMP_DIR)\dllEntryPoint.obj -!endif - -###################################################################### -# Link flags -###################################################################### - -!if $(DEBUG) -ldebug = -debug:full -debugtype:cv -pdb:none -!else -ldebug = -release -opt:ref -!endif - -# declarations common to all linker options -lcommon = -nologo -link50compat -machine:$(MACHINE) - -LFLAGS = $(lcommon) -subsystem:windows -dll - -!if $(USE_TCL_STUBS) == 0 -LLIBS = $(TCLIMPLIB) $(XOTCLIMPLIB) -!else -### should be: -### LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) when xotcl stub lib is mature -### LLIBS = $(TCLSTUBLIB) $(XOTCLIMPLIB) -LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) -!endif - -###################################################################### -# Compile flags -###################################################################### - -!IF $(DEBUG) == 0 -!IF "$(MACHINE)" == "ALPHA" -# MSVC on Alpha doesn't understand -Ot -cdebug = -O2i -!ELSE -cdebug = -Ox -!ENDIF -!ELSE -!if $(MSDEV_VER) < 6 -cdebug = -Zi -Od -WX -!else -cdebug = -ZI -Od -WX -!endif -!ENDIF - -!if $(STATIC_BUILD) -cdll = -!else -cdll = -GD -!endif - -# declarations common to all compiler options -ccommon = -nologo -c -W3 -YX \ - - -!if $(STATIC_BUILD) && $(NOMSVCRT) -crt = -MT$(DBGX) -!else -crt = -MD$(DBGX) -!endif - -INCLUDES = -I"$(TCLROOT)\generic" -I"$(XOTCL_DIR)\generic" - -DEFINES = -DBUILD_$(NAME) -DTCL_THREADS=1 \ - -DXOLIBPKG=$(INST_XOLIBPKG) \ - -DXOTCLVERSION=$(XOTCLVERSION) \ - -DPACKAGE_VERSION=$(XOTCLVERSION) \ - -DVERSION=$(XOTCLVERSION) \ - -DXOTCLPATCHLEVEL=$(XOTCLPATCHLEVEL) \ - -D__WIN32__ -DVISUAL_CC - -EXE_CFLAGS = $(ccommon) $(cdebug) $(crt) $(cdll) $(INCLUDES) $(DEFINES) - -!if $(USE_TCL_STUBS) -#CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS -CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS -DUSE_XOTCL_STUBS -!else -CFLAGS = $(EXE_CFLAGS) -!endif - -###################################################################### -# Project specific targets -###################################################################### - -all : libs ./pkgIndex.tcl - -libs : setup $(TARGET) - copy $(TARGET) .. - -setup : - @$(vcvars) > nul - @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\ - echo Created directory '$(TMP_DIR)' - @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\ - echo Created directory '$(OUT_DIR)' - -$(TARGET) : $(OBJS) -!if $(STATIC_BUILD) - $(lib32) -nologo -machine:$(MACHINE) -out:$@ @<< -!else - $(link32) $(LFLAGS) -base:@$(XOTCL_DIR)\win\dllBase.txt,$@ -out:$@ $(LLIBS) @<< -!endif - $(OBJS) -<< - -./pkgIndex.tcl : $(TARGET) - echo package ifneeded xotcl::store::sdbm $(XOTCL_VERSION) [list load [file join $$dir $(TMPNAME)/$(OUTNAME).dll]] > \ - ".\pkgIndex.tcl" - -install : all - if not exist "$(INSTALLDIR)" mkdir "$(INSTALLDIR)" - if not exist "$(BIN_INSTALL_DIR)" mkdir "$(BIN_INSTALL_DIR)" - if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" - if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" - if not exist "$(INCLUDE_INSTALL_DIR)" mkdir "$(INCLUDE_INSTALL_DIR)" - copy $(TARGET) "$(SCRIPT_INSTALL_DIR)" - -###################################################################### -# Inference rules. Use batch-mode when supported. -###################################################################### - -!if $(_NMAKE_VER) < 162 -{$(WINDIR)}.c{$(TMP_DIR)}.obj : -!else -{$(WINDIR)}.c{$(TMP_DIR)}.obj :: -!endif - $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< -$< -<< - -!if $(_NMAKE_VER) < 162 -{$(GENERICDIR)}.c{$(TMP_DIR)}.obj : -!else -{$(GENERICDIR)}.c{$(TMP_DIR)}.obj :: -!endif - $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< -$< -<< - -#{$(RCDIR)}.rc{$(TMP_DIR)}.res : -# $(rc32) -fo $@ -DDEBUG=$(DEBUG) $(XOTCL_VERSION_DEFINES) $(XOTCL_INCLUDES) $(TCL_INCLUDES) $(XOTCL_DEFINES) $< - -###################################################################### -# Clean up -###################################################################### - -tidy : - -del $(TMP_DIR)\*.pch - -del $(TMP_DIR)\*.obj - -del $(TMP_DIR)\*.res - -del .\*.pch - -del .\*.pdb - -clean : tidy - -del $(OUT_DIR)\*.exp - -del $(OUT_DIR)\*.lib - -del $(OUT_DIR)\*.dll - -del $(OUT_DIR)\*.tcl - -del ..\*.exp - -del ..\*.lib - -del ..\*.dll - -distclean : clean - -rmdir $(OUT_DIR) - -rmdir $(TMP_DIR) - +###################################################################### +# +# XOTclSdbm Makefile for Visual C++ +# +###################################################################### + +# Be sure to adapt the "configs.vc" file in the toplevel directory +# to your system settings. +!include "..\..\..\win\configs.vc" + +BINROOT = . +ROOT = .. +NAMEPREFIX = lib +NAME = xotclsdbm +XOTCL_DIR = ..\..\.. +GENERICDIR = . +WINDIR = . + +###################################################################### + +!if $(DEBUG) +TMPNAME = Debug +DBGX = d +!else +TMPNAME = Release +DBGX = +!endif + +TMP_DIR = $(BINROOT)\$(TMPNAME) +OUT_DIR = $(TMP_DIR) + +!if $(STATIC_BUILD) +OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) +TARGET = "$(OUT_DIR)\$(OUTNAME).lib" +!else +OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) +IMPLIB = "$(OUT_DIR)\$(OUTNAME).lib" +TARGET = "$(OUT_DIR)\$(OUTNAME).dll" +!endif + +TCLSTUBLIB = "$(TCLROOT)\win\Release\tclstub$(TCL_VERSION).lib" +TCLIMPLIB = "$(TCLROOT)\win\$(OUT_DIR)\tcl$(TCL_VERSION)$(DBGX).lib" +TCLSH = "$(TCLROOT)\win\$(OUT_DIR)\tclsh$(TCL_VERSION)$(DBGX).exe" + +XOTCLSTUBLIB = "$(XOTCL_DIR)\win\Release\libxotclstub$(XOTCL_VERSION).lib" +XOTCLIMPLIB = "$(XOTCL_DIR)\win\$(OUT_DIR)\libxotcl$(XOTCL_VERSION)$(DBGX).lib" + +LIB_INSTALL_DIR = $(INSTALLDIR)\lib +BIN_INSTALL_DIR = $(INSTALLDIR)\bin +SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\xotcl$(XOTCL_VERSION) +INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include + +OBJS = $(TMP_DIR)\hash.obj \ + $(TMP_DIR)\pair.obj \ + $(TMP_DIR)\sdbm.obj \ + $(TMP_DIR)\xotclsdbm.obj \ +!if $(STATIC_BUILD) == 0 + $(TMP_DIR)\dllEntryPoint.obj +!endif + +###################################################################### +# Link flags +###################################################################### + +!if $(DEBUG) +ldebug = -debug:full -debugtype:cv -pdb:none +!else +ldebug = -release -opt:ref +!endif + +# declarations common to all linker options +lcommon = -nologo -link50compat -machine:$(MACHINE) + +LFLAGS = $(lcommon) -subsystem:windows -dll + +!if $(USE_TCL_STUBS) == 0 +LLIBS = $(TCLIMPLIB) $(XOTCLIMPLIB) +!else +### should be: +### LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) when xotcl stub lib is mature +### LLIBS = $(TCLSTUBLIB) $(XOTCLIMPLIB) +LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) +!endif + +###################################################################### +# Compile flags +###################################################################### + +!IF $(DEBUG) == 0 +!IF "$(MACHINE)" == "ALPHA" +# MSVC on Alpha doesn't understand -Ot +cdebug = -O2i +!ELSE +cdebug = -Ox +!ENDIF +!ELSE +!if $(MSDEV_VER) < 6 +cdebug = -Zi -Od -WX +!else +cdebug = -ZI -Od -WX +!endif +!ENDIF + +!if $(STATIC_BUILD) +cdll = +!else +cdll = -GD +!endif + +# declarations common to all compiler options +ccommon = -nologo -c -W3 -YX \ + + +!if $(STATIC_BUILD) && $(NOMSVCRT) +crt = -MT$(DBGX) +!else +crt = -MD$(DBGX) +!endif + +INCLUDES = -I"$(TCLROOT)\generic" -I"$(XOTCL_DIR)\generic" + +DEFINES = -DBUILD_$(NAME) -DTCL_THREADS=1 \ + -DXOLIBPKG=$(INST_XOLIBPKG) \ + -DXOTCLVERSION=$(XOTCLVERSION) \ + -DPACKAGE_VERSION=$(XOTCLVERSION) \ + -DVERSION=$(XOTCLVERSION) \ + -DXOTCLPATCHLEVEL=$(XOTCLPATCHLEVEL) \ + -D__WIN32__ -DVISUAL_CC + +EXE_CFLAGS = $(ccommon) $(cdebug) $(crt) $(cdll) $(INCLUDES) $(DEFINES) + +!if $(USE_TCL_STUBS) +#CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS +CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS -DUSE_NSF_STUBS +!else +CFLAGS = $(EXE_CFLAGS) +!endif + +###################################################################### +# Project specific targets +###################################################################### + +all : libs ./pkgIndex.tcl + +libs : setup $(TARGET) + copy $(TARGET) .. + +setup : + @$(vcvars) > nul + @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\ + echo Created directory '$(TMP_DIR)' + @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\ + echo Created directory '$(OUT_DIR)' + +$(TARGET) : $(OBJS) +!if $(STATIC_BUILD) + $(lib32) -nologo -machine:$(MACHINE) -out:$@ @<< +!else + $(link32) $(LFLAGS) -base:@$(XOTCL_DIR)\win\dllBase.txt,$@ -out:$@ $(LLIBS) @<< +!endif + $(OBJS) +<< + +./pkgIndex.tcl : $(TARGET) + echo package ifneeded xotcl::store::sdbm $(XOTCL_VERSION) [list load [file join $$dir $(TMPNAME)/$(OUTNAME).dll]] > \ + ".\pkgIndex.tcl" + +install : all + if not exist "$(INSTALLDIR)" mkdir "$(INSTALLDIR)" + if not exist "$(BIN_INSTALL_DIR)" mkdir "$(BIN_INSTALL_DIR)" + if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" + if not exist "$(INCLUDE_INSTALL_DIR)" mkdir "$(INCLUDE_INSTALL_DIR)" + copy $(TARGET) "$(SCRIPT_INSTALL_DIR)" + +###################################################################### +# Inference rules. Use batch-mode when supported. +###################################################################### + +!if $(_NMAKE_VER) < 162 +{$(WINDIR)}.c{$(TMP_DIR)}.obj : +!else +{$(WINDIR)}.c{$(TMP_DIR)}.obj :: +!endif + $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< +$< +<< + +!if $(_NMAKE_VER) < 162 +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj : +!else +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj :: +!endif + $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< +$< +<< + +#{$(RCDIR)}.rc{$(TMP_DIR)}.res : +# $(rc32) -fo $@ -DDEBUG=$(DEBUG) $(XOTCL_VERSION_DEFINES) $(XOTCL_INCLUDES) $(TCL_INCLUDES) $(XOTCL_DEFINES) $< + +###################################################################### +# Clean up +###################################################################### + +tidy : + -del $(TMP_DIR)\*.pch + -del $(TMP_DIR)\*.obj + -del $(TMP_DIR)\*.res + -del .\*.pch + -del .\*.pdb + +clean : tidy + -del $(OUT_DIR)\*.exp + -del $(OUT_DIR)\*.lib + -del $(OUT_DIR)\*.dll + -del $(OUT_DIR)\*.tcl + -del ..\*.exp + -del ..\*.lib + -del ..\*.dll + +distclean : clean + -rmdir $(OUT_DIR) + -rmdir $(TMP_DIR) + Index: library/xotcl/library/store/XOTclSdbm/xotcl.m4 =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/store/XOTclSdbm/xotcl.m4 (.../xotcl.m4) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/store/XOTclSdbm/xotcl.m4 (.../xotcl.m4) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -4,14 +4,15 @@ # a Tcl extension. # # Copyright (c) 1999 Scriptics Corporation. +# Copyright (c) 1999-2008 Gustaf Neumann, Uwe Zdun # -# See the file "license.terms" for information on usage and redistribution +# See the file "tcl-license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------------------ -# SC_PATH_XOTCLCONFIG -- +# SC_PATH_NSFCONFIG -- # -# Locate the xotclConfig.sh file and perform a sanity check on +# Locate the nsfConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: @@ -23,11 +24,11 @@ # --with-xotcl=... # # Defines the following vars: -# XOTCL_BIN_DIR Full path to the directory containing -# the xotclConfig.sh file +# NX_BIN_DIR Full path to the directory containing +# the nsfConfig.sh file #------------------------------------------------------------------------ -AC_DEFUN(SC_PATH_XOTCLCONFIG, [ +AC_DEFUN(SC_PATH_NSFCONFIG, [ # # Ok, lets find the tcl configuration # First, look for one uninstalled. @@ -36,21 +37,21 @@ if test x"${no_xotcl}" = x ; then # we reset no_xotcl in case something fails here no_xotcl=true - AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (xotclConfig.sh)], with_xotclconfig=${withval}) + AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (nsfConfig.sh)], with_nsfconfig=${withval}) AC_MSG_CHECKING([for XOTcl configuration]) - AC_CACHE_VAL(ac_cv_c_xotclconfig,[ + AC_CACHE_VAL(ac_cv_c_nsfconfig,[ # First check to see if --with-xotcl was specified. - if test x"${with_xotclconfig}" != x ; then - if test -f "${with_xotclconfig}/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd ${with_xotclconfig}; pwd)` + if test x"${with_nsfconfig}" != x ; then + if test -f "${with_nsfconfig}/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd ${with_nsfconfig}; pwd)` else - AC_MSG_ERROR([${with_xotclconfig} directory doesn't contain xotclConfig.sh]) + AC_MSG_ERROR([${with_nsfconfig} directory doesn't contain nsfConfig.sh]) fi fi # then check for a private Tcl installation - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in \ ${srcdir}/../xotcl \ `ls -dr ${srcdir}/../xotcl-* 2>/dev/null` \ @@ -62,60 +63,60 @@ `ls -dr ${srcdir}/../../../../xotcl-* 2>/dev/null` \ ${srcdir}/../../../../../xotcl \ `ls -dr ${srcdir}/../../../../../xotcl-* 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi # check in a few common install locations - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi ]) - if test x"${ac_cv_c_xotclconfig}" = x ; then - XOTCL_BIN_DIR="# no XOTcl configs found" + if test x"${ac_cv_c_nsfconfig}" = x ; then + NX_BIN_DIR="# no XOTcl configs found" AC_MSG_WARN(Can't find XOTcl configuration definitions) exit 0 else no_xotcl= - XOTCL_BIN_DIR=${ac_cv_c_xotclconfig} - AC_MSG_RESULT(found $XOTCL_BIN_DIR/xotclConfig.sh) + NX_BIN_DIR=${ac_cv_c_nsfconfig} + AC_MSG_RESULT(found $NX_BIN_DIR/nsfConfig.sh) fi fi ]) #------------------------------------------------------------------------ -# SC_LOAD_XOTCLCONFIG -- +# SC_LOAD_NSFCONFIG -- # # Load the tclConfig.sh file # # Arguments: # # Requires the following vars to be set: -# XOTCL_BIN_DIR +# NX_BIN_DIR # # Results: # # Subst the vars: # #------------------------------------------------------------------------ -AC_DEFUN(SC_LOAD_XOTCLCONFIG, [ - AC_MSG_CHECKING([for existence of $XOTCL_BIN_DIR/xotclConfig.sh]) +AC_DEFUN(SC_LOAD_NSFCONFIG, [ + AC_MSG_CHECKING([for existence of $NX_BIN_DIR/nsfConfig.sh]) - if test -f "$XOTCL_BIN_DIR/xotclConfig.sh" ; then + if test -f "$NX_BIN_DIR/nsfConfig.sh" ; then AC_MSG_RESULT([loading]) - . $XOTCL_BIN_DIR/xotclConfig.sh + . $NX_BIN_DIR/nsfConfig.sh else AC_MSG_RESULT([file not found]) fi @@ -124,16 +125,16 @@ # The eval is required to do the TCL_DBGX substitution in the # TCL_LIB_FILE variable # - AC_SUBST(XOTCL_VERSION) - AC_SUBST(XOTCL_MAJOR_VERSION) - AC_SUBST(XOTCL_MINOR_VERSION) - AC_SUBST(XOTCL_RELEASE_LEVEL) - AC_SUBST(XOTCL_LIB_FILE) - AC_SUBST(XOTCL_BUILD_LIB_SPEC) - AC_SUBST(XOTCL_LIB_SPEC) - AC_SUBST(XOTCL_STUB_LIB_FILE) - AC_SUBST(XOTCL_BUILD_STUB_LIB_SPEC) - AC_SUBST(XOTCL_STUB_LIB_SPEC) - AC_SUBST(XOTCL_SRC_DIR) + AC_SUBST(NX_VERSION) + AC_SUBST(NX_MAJOR_VERSION) + AC_SUBST(NX_MINOR_VERSION) + AC_SUBST(NX_RELEASE_LEVEL) + AC_SUBST(NX_LIB_FILE) + AC_SUBST(NX_BUILD_LIB_SPEC) + AC_SUBST(NX_LIB_SPEC) + AC_SUBST(NX_STUB_LIB_FILE) + AC_SUBST(NX_BUILD_STUB_LIB_SPEC) + AC_SUBST(NX_STUB_LIB_SPEC) + AC_SUBST(NX_SRC_DIR) ]) Index: library/xotcl/library/store/XOTclSdbm/xotclsdbm.c =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/store/XOTclSdbm/xotclsdbm.c (.../xotclsdbm.c) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/store/XOTclSdbm/xotclsdbm.c (.../xotclsdbm.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -8,7 +8,7 @@ #include #include "sdbm.h" #include -#include +#include #if (TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<1) # define TclObjStr(obj) Tcl_GetStringFromObj(obj, ((int*)NULL)) @@ -357,8 +357,8 @@ if (Tcl_InitStubs(in, "8.1", 0) == NULL) { return TCL_ERROR; } -# ifdef USE_XOTCL_STUBS - if (Xotcl_InitStubs(in, "1.1", 0) == NULL) { +# ifdef USE_NSF_STUBS + if (Nsf_InitStubs(in, "1.1", 0) == NULL) { return TCL_ERROR; } # endif Index: library/xotcl/library/xml/TclExpat-1.1/Makefile.vc =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/xml/TclExpat-1.1/Makefile.vc (.../Makefile.vc) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/xml/TclExpat-1.1/Makefile.vc (.../Makefile.vc) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -1,239 +1,239 @@ -###################################################################### -# -# XOTclExpat Makefile for Visual C++ -# -###################################################################### - -# Be sure to adapt the "configs.vc" file in the toplevel directory -# to your system settings. -!include "..\..\..\win\configs.vc" - -BINROOT = . -ROOT = .. -NAMEPREFIX = lib -NAME = xotclexpat -XOTCL_DIR = ..\..\.. -GENERICDIR = . -WINDIR = . - -###################################################################### - -!if $(DEBUG) -TMPNAME = Debug -DBGX = d -!else -TMPNAME = Release -DBGX = -!endif - -TMP_DIR = $(BINROOT)\$(TMPNAME) -OUT_DIR = $(TMP_DIR) - -!if $(STATIC_BUILD) -OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) -TARGET = "$(OUT_DIR)\$(OUTNAME).lib" -!else -OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) -IMPLIB = "$(OUT_DIR)\$(OUTNAME).lib" -TARGET = "$(OUT_DIR)\$(OUTNAME).dll" -!endif - -TCLSTUBLIB = "$(TCLROOT)\win\Release\tclstub$(TCL_VERSION).lib" -TCLIMPLIB = "$(TCLROOT)\win\$(OUT_DIR)\tcl$(TCL_VERSION)$(DBGX).lib" -TCLSH = "$(TCLROOT)\win\$(OUT_DIR)\tclsh$(TCL_VERSION)$(DBGX).exe" - -XOTCLSTUBLIB = "$(XOTCL_DIR)\win\Release\libxotclstub$(XOTCL_VERSION).lib" -XOTCLIMPLIB = "$(XOTCL_DIR)\win\$(OUT_DIR)\libxotcl$(XOTCL_VERSION)$(DBGX).lib" - -LIB_INSTALL_DIR = $(INSTALLDIR)\lib -BIN_INSTALL_DIR = $(INSTALLDIR)\bin -SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\xotcl$(XOTCL_VERSION) -INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include - -OBJS = $(TMP_DIR)\xmltok.obj \ - $(TMP_DIR)\xmlrole.obj \ - $(TMP_DIR)\xmlwf.obj \ - $(TMP_DIR)\codepage.obj \ - $(TMP_DIR)\xmlparse.obj \ - $(TMP_DIR)\hashtable.obj \ - $(TMP_DIR)\win32filemap.obj \ - $(TMP_DIR)\tclexpat.obj \ -!if $(STATIC_BUILD) == 0 - $(TMP_DIR)\dllEntryPoint.obj -!endif - -###################################################################### -# Link flags -###################################################################### - -!if $(DEBUG) -ldebug = -debug:full -debugtype:cv -pdb:none -!else -ldebug = -release -opt:ref -!endif - -# declarations common to all linker options -lcommon = -nologo -link50compat -machine:$(MACHINE) - -LFLAGS = $(lcommon) -subsystem:windows -dll - -!if $(USE_TCL_STUBS) == 0 -LLIBS = $(TCLIMPLIB) $(XOTCLIMPLIB) -!else -### should be: -### LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) when xotcl stub lib is mature -### LLIBS = $(TCLSTUBLIB) $(XOTCLIMPLIB) -LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) -!endif - -###################################################################### -# Compile flags -###################################################################### - -!IF $(DEBUG) == 0 -!IF "$(MACHINE)" == "ALPHA" -# MSVC on Alpha doesn't understand -Ot -cdebug = -O2i -!ELSE -cdebug = -Ox -!ENDIF -!ELSE -!if $(MSDEV_VER) < 6 -cdebug = -Zi -Od -WX -!else -cdebug = -ZI -Od -WX -!endif -!ENDIF - -!if $(STATIC_BUILD) -cdll = -!else -cdll = -GD -!endif - -# declarations common to all compiler options -ccommon = -nologo -c -W3 -YX \ - - -!if $(STATIC_BUILD) && $(NOMSVCRT) -crt = -MT$(DBGX) -!else -crt = -MD$(DBGX) -!endif - -INCLUDES = -I"$(TCLROOT)\generic" -I"$(XOTCL_DIR)\generic" -I"." - -DEFINES = -DBUILD_$(NAME) -DTCL_THREADS=1 \ - -DXOLIBPKG=$(INST_XOLIBPKG) \ - -DXOTCLVERSION=$(XOTCLVERSION) \ - -DPACKAGE_VERSION=$(XOTCLVERSION) \ - -DVERSION=$(XOTCLVERSION) \ - -DXOTCLPATCHLEVEL=$(XOTCLPATCHLEVEL) \ - -D__WIN32__ -DVISUAL_CC - -EXE_CFLAGS = $(ccommon) $(cdebug) $(crt) $(cdll) $(INCLUDES) $(DEFINES) - -!if $(USE_TCL_STUBS) -#CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS -CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS -DUSE_XOTCL_STUBS -!else -CFLAGS = $(EXE_CFLAGS) -!endif - -###################################################################### -# Project specific targets -###################################################################### - -all : libs - -libs : setup $(TARGET) - copy $(TARGET) .. - -setup : - @$(vcvars) > nul - @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\ - echo Created directory '$(TMP_DIR)' - @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\ - echo Created directory '$(OUT_DIR)' - -$(TARGET) : $(OBJS) -!if $(STATIC_BUILD) - $(lib32) -nologo -machine:$(MACHINE) -out:$@ @<< -!else - $(link32) $(LFLAGS) -base:@$(XOTCL_DIR)\win\dllBase.txt,$@ -out:$@ $(LLIBS) @<< -!endif - $(OBJS) -<< - - -install : all - if not exist "$(INSTALLDIR)" mkdir "$(INSTALLDIR)" - if not exist "$(BIN_INSTALL_DIR)" mkdir "$(BIN_INSTALL_DIR)" - if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" - if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" - if not exist "$(INCLUDE_INSTALL_DIR)" mkdir "$(INCLUDE_INSTALL_DIR)" - copy $(TARGET) "$(SCRIPT_INSTALL_DIR)" - -###################################################################### -# Inference rules. Use batch-mode when supported. -###################################################################### - -!if $(_NMAKE_VER) < 162 -{$(WINDIR)}.c{$(TMP_DIR)}.obj : -!else -{$(WINDIR)}.c{$(TMP_DIR)}.obj :: -!endif - $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< -$< -<< - -!if $(_NMAKE_VER) < 162 -{$(GENERICDIR)}.c{$(TMP_DIR)}.obj : -!else -{$(GENERICDIR)}.c{$(TMP_DIR)}.obj :: -!endif - $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< -$< -<< - -#$(TMP_DIR)\xmltok.obj : expat\xmltok\xmltok.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? -#$(TMP_DIR)\xmlrole.obj : expat\xmltok\xmlrole.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? -#$(TMP_DIR)\xmlwf.obj : expat\xmlwf\xmlwf.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? -#$(TMP_DIR)\readfilemap.obj : expat\xmlwf\readfilemap.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? -#$(TMP_DIR)\codepage.obj : expat\xmlwf\codepage.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? -#$(TMP_DIR)\xmlparse.obj : expat\xmlparse\xmlparse.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? -#$(TMP_DIR)\hashtable.obj : expat\xmlparse\hashtable.c -# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? - -#{$(RCDIR)}.rc{$(TMP_DIR)}.res : -# $(rc32) -fo $@ -DDEBUG=$(DEBUG) $(XOTCL_VERSION_DEFINES) $(XOTCL_INCLUDES) $(TCL_INCLUDES) $(XOTCL_DEFINES) $< - -###################################################################### -# Clean up -###################################################################### - -tidy : - -del $(TMP_DIR)\*.pch - -del $(TMP_DIR)\*.obj - -del $(TMP_DIR)\*.res - -del .\*.pch - -del .\*.pdb - -clean : tidy - -del $(OUT_DIR)\*.exp - -del $(OUT_DIR)\*.lib - -del $(OUT_DIR)\*.dll - -del ..\*.exp - -del ..\*.lib - -del ..\*.dll - -distclean : clean - -rmdir $(OUT_DIR) - -rmdir $(TMP_DIR) - +###################################################################### +# +# XOTclExpat Makefile for Visual C++ +# +###################################################################### + +# Be sure to adapt the "configs.vc" file in the toplevel directory +# to your system settings. +!include "..\..\..\win\configs.vc" + +BINROOT = . +ROOT = .. +NAMEPREFIX = lib +NAME = xotclexpat +XOTCL_DIR = ..\..\.. +GENERICDIR = . +WINDIR = . + +###################################################################### + +!if $(DEBUG) +TMPNAME = Debug +DBGX = d +!else +TMPNAME = Release +DBGX = +!endif + +TMP_DIR = $(BINROOT)\$(TMPNAME) +OUT_DIR = $(TMP_DIR) + +!if $(STATIC_BUILD) +OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) +TARGET = "$(OUT_DIR)\$(OUTNAME).lib" +!else +OUTNAME = $(NAMEPREFIX)$(NAME)$(XOTCL_VERSION)$(DBGX) +IMPLIB = "$(OUT_DIR)\$(OUTNAME).lib" +TARGET = "$(OUT_DIR)\$(OUTNAME).dll" +!endif + +TCLSTUBLIB = "$(TCLROOT)\win\Release\tclstub$(TCL_VERSION).lib" +TCLIMPLIB = "$(TCLROOT)\win\$(OUT_DIR)\tcl$(TCL_VERSION)$(DBGX).lib" +TCLSH = "$(TCLROOT)\win\$(OUT_DIR)\tclsh$(TCL_VERSION)$(DBGX).exe" + +XOTCLSTUBLIB = "$(XOTCL_DIR)\win\Release\libxotclstub$(XOTCL_VERSION).lib" +XOTCLIMPLIB = "$(XOTCL_DIR)\win\$(OUT_DIR)\libxotcl$(XOTCL_VERSION)$(DBGX).lib" + +LIB_INSTALL_DIR = $(INSTALLDIR)\lib +BIN_INSTALL_DIR = $(INSTALLDIR)\bin +SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\xotcl$(XOTCL_VERSION) +INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include + +OBJS = $(TMP_DIR)\xmltok.obj \ + $(TMP_DIR)\xmlrole.obj \ + $(TMP_DIR)\xmlwf.obj \ + $(TMP_DIR)\codepage.obj \ + $(TMP_DIR)\xmlparse.obj \ + $(TMP_DIR)\hashtable.obj \ + $(TMP_DIR)\win32filemap.obj \ + $(TMP_DIR)\tclexpat.obj \ +!if $(STATIC_BUILD) == 0 + $(TMP_DIR)\dllEntryPoint.obj +!endif + +###################################################################### +# Link flags +###################################################################### + +!if $(DEBUG) +ldebug = -debug:full -debugtype:cv -pdb:none +!else +ldebug = -release -opt:ref +!endif + +# declarations common to all linker options +lcommon = -nologo -link50compat -machine:$(MACHINE) + +LFLAGS = $(lcommon) -subsystem:windows -dll + +!if $(USE_TCL_STUBS) == 0 +LLIBS = $(TCLIMPLIB) $(XOTCLIMPLIB) +!else +### should be: +### LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) when xotcl stub lib is mature +### LLIBS = $(TCLSTUBLIB) $(XOTCLIMPLIB) +LLIBS = $(TCLSTUBLIB) $(XOTCLSTUBLIB) +!endif + +###################################################################### +# Compile flags +###################################################################### + +!IF $(DEBUG) == 0 +!IF "$(MACHINE)" == "ALPHA" +# MSVC on Alpha doesn't understand -Ot +cdebug = -O2i +!ELSE +cdebug = -Ox +!ENDIF +!ELSE +!if $(MSDEV_VER) < 6 +cdebug = -Zi -Od -WX +!else +cdebug = -ZI -Od -WX +!endif +!ENDIF + +!if $(STATIC_BUILD) +cdll = +!else +cdll = -GD +!endif + +# declarations common to all compiler options +ccommon = -nologo -c -W3 -YX \ + + +!if $(STATIC_BUILD) && $(NOMSVCRT) +crt = -MT$(DBGX) +!else +crt = -MD$(DBGX) +!endif + +INCLUDES = -I"$(TCLROOT)\generic" -I"$(XOTCL_DIR)\generic" -I"." + +DEFINES = -DBUILD_$(NAME) -DTCL_THREADS=1 \ + -DXOLIBPKG=$(INST_XOLIBPKG) \ + -DXOTCLVERSION=$(XOTCLVERSION) \ + -DPACKAGE_VERSION=$(XOTCLVERSION) \ + -DVERSION=$(XOTCLVERSION) \ + -DXOTCLPATCHLEVEL=$(XOTCLPATCHLEVEL) \ + -D__WIN32__ -DVISUAL_CC + +EXE_CFLAGS = $(ccommon) $(cdebug) $(crt) $(cdll) $(INCLUDES) $(DEFINES) + +!if $(USE_TCL_STUBS) +#CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS +CFLAGS = $(EXE_CFLAGS) -DUSE_TCL_STUBS -DUSE_NSF_STUBS +!else +CFLAGS = $(EXE_CFLAGS) +!endif + +###################################################################### +# Project specific targets +###################################################################### + +all : libs + +libs : setup $(TARGET) + copy $(TARGET) .. + +setup : + @$(vcvars) > nul + @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\ + echo Created directory '$(TMP_DIR)' + @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\ + echo Created directory '$(OUT_DIR)' + +$(TARGET) : $(OBJS) +!if $(STATIC_BUILD) + $(lib32) -nologo -machine:$(MACHINE) -out:$@ @<< +!else + $(link32) $(LFLAGS) -base:@$(XOTCL_DIR)\win\dllBase.txt,$@ -out:$@ $(LLIBS) @<< +!endif + $(OBJS) +<< + + +install : all + if not exist "$(INSTALLDIR)" mkdir "$(INSTALLDIR)" + if not exist "$(BIN_INSTALL_DIR)" mkdir "$(BIN_INSTALL_DIR)" + if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" + if not exist "$(INCLUDE_INSTALL_DIR)" mkdir "$(INCLUDE_INSTALL_DIR)" + copy $(TARGET) "$(SCRIPT_INSTALL_DIR)" + +###################################################################### +# Inference rules. Use batch-mode when supported. +###################################################################### + +!if $(_NMAKE_VER) < 162 +{$(WINDIR)}.c{$(TMP_DIR)}.obj : +!else +{$(WINDIR)}.c{$(TMP_DIR)}.obj :: +!endif + $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< +$< +<< + +!if $(_NMAKE_VER) < 162 +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj : +!else +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj :: +!endif + $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$(TMP_DIR)\ @<< +$< +<< + +#$(TMP_DIR)\xmltok.obj : expat\xmltok\xmltok.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? +#$(TMP_DIR)\xmlrole.obj : expat\xmltok\xmlrole.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? +#$(TMP_DIR)\xmlwf.obj : expat\xmlwf\xmlwf.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? +#$(TMP_DIR)\readfilemap.obj : expat\xmlwf\readfilemap.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? +#$(TMP_DIR)\codepage.obj : expat\xmlwf\codepage.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? +#$(TMP_DIR)\xmlparse.obj : expat\xmlparse\xmlparse.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? +#$(TMP_DIR)\hashtable.obj : expat\xmlparse\hashtable.c +# $(cc32) -DDLL_BUILD $(CFLAGS) -Fo$@ $? + +#{$(RCDIR)}.rc{$(TMP_DIR)}.res : +# $(rc32) -fo $@ -DDEBUG=$(DEBUG) $(XOTCL_VERSION_DEFINES) $(XOTCL_INCLUDES) $(TCL_INCLUDES) $(XOTCL_DEFINES) $< + +###################################################################### +# Clean up +###################################################################### + +tidy : + -del $(TMP_DIR)\*.pch + -del $(TMP_DIR)\*.obj + -del $(TMP_DIR)\*.res + -del .\*.pch + -del .\*.pdb + +clean : tidy + -del $(OUT_DIR)\*.exp + -del $(OUT_DIR)\*.lib + -del $(OUT_DIR)\*.dll + -del ..\*.exp + -del ..\*.lib + -del ..\*.dll + +distclean : clean + -rmdir $(OUT_DIR) + -rmdir $(TMP_DIR) + Index: library/xotcl/library/xml/TclExpat-1.1/tclexpat.c =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/xml/TclExpat-1.1/tclexpat.c (.../tclexpat.c) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/xml/TclExpat-1.1/tclexpat.c (.../tclexpat.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -19,7 +19,7 @@ */ #include -#include +#include #include #include "xmlparse.h" @@ -175,8 +175,8 @@ if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { return TCL_ERROR; } -#ifdef USE_XOTCL_STUBS - if (Xotcl_InitStubs(interp, "1.1", 0) == NULL) { +#ifdef USE_NSF_STUBS + if (Nsf_InitStubs(interp, "1.1", 0) == NULL) { return TCL_ERROR; } #endif Index: library/xotcl/library/xml/TclExpat-1.1/xotcl.m4 =================================================================== diff -u -N -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r0e8b567e2a1808c514f6340430920ad4d59953bc --- library/xotcl/library/xml/TclExpat-1.1/xotcl.m4 (.../xotcl.m4) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/xml/TclExpat-1.1/xotcl.m4 (.../xotcl.m4) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -4,14 +4,15 @@ # a Tcl extension. # # Copyright (c) 1999 Scriptics Corporation. +# Copyright (c) 1999-2008 Gustaf Neumann, Uwe Zdun # -# See the file "license.terms" for information on usage and redistribution +# See the file "tcl-license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------------------ -# SC_PATH_XOTCLCONFIG -- +# SC_PATH_NSFCONFIG -- # -# Locate the xotclConfig.sh file and perform a sanity check on +# Locate the nsfConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: @@ -23,11 +24,11 @@ # --with-xotcl=... # # Defines the following vars: -# XOTCL_BIN_DIR Full path to the directory containing -# the xotclConfig.sh file +# NX_BIN_DIR Full path to the directory containing +# the nsfConfig.sh file #------------------------------------------------------------------------ -AC_DEFUN(SC_PATH_XOTCLCONFIG, [ +AC_DEFUN(SC_PATH_NSFCONFIG, [ # # Ok, lets find the tcl configuration # First, look for one uninstalled. @@ -36,21 +37,21 @@ if test x"${no_xotcl}" = x ; then # we reset no_xotcl in case something fails here no_xotcl=true - AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (xotclConfig.sh)], with_xotclconfig=${withval}) + AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (nsfConfig.sh)], with_nsfconfig=${withval}) AC_MSG_CHECKING([for XOTcl configuration]) - AC_CACHE_VAL(ac_cv_c_xotclconfig,[ + AC_CACHE_VAL(ac_cv_c_nsfconfig,[ # First check to see if --with-xotcl was specified. - if test x"${with_xotclconfig}" != x ; then - if test -f "${with_xotclconfig}/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd ${with_xotclconfig}; pwd)` + if test x"${with_nsfconfig}" != x ; then + if test -f "${with_nsfconfig}/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd ${with_nsfconfig}; pwd)` else - AC_MSG_ERROR([${with_xotclconfig} directory doesn't contain xotclConfig.sh]) + AC_MSG_ERROR([${with_nsfconfig} directory doesn't contain nsfConfig.sh]) fi fi # then check for a private Tcl installation - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in \ ${srcdir}/../xotcl \ `ls -dr ${srcdir}/../xotcl-* 2>/dev/null` \ @@ -62,60 +63,60 @@ `ls -dr ${srcdir}/../../../../xotcl-* 2>/dev/null` \ ${srcdir}/../../../../../xotcl \ `ls -dr ${srcdir}/../../../../../xotcl-* 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi # check in a few common install locations - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi ]) - if test x"${ac_cv_c_xotclconfig}" = x ; then - XOTCL_BIN_DIR="# no XOTcl configs found" + if test x"${ac_cv_c_nsfconfig}" = x ; then + NX_BIN_DIR="# no XOTcl configs found" AC_MSG_WARN(Can't find XOTcl configuration definitions) exit 0 else no_xotcl= - XOTCL_BIN_DIR=${ac_cv_c_xotclconfig} - AC_MSG_RESULT(found $XOTCL_BIN_DIR/xotclConfig.sh) + NX_BIN_DIR=${ac_cv_c_nsfconfig} + AC_MSG_RESULT(found $NX_BIN_DIR/nsfConfig.sh) fi fi ]) #------------------------------------------------------------------------ -# SC_LOAD_XOTCLCONFIG -- +# SC_LOAD_NSFCONFIG -- # # Load the tclConfig.sh file # # Arguments: # # Requires the following vars to be set: -# XOTCL_BIN_DIR +# NX_BIN_DIR # # Results: # # Subst the vars: # #------------------------------------------------------------------------ -AC_DEFUN(SC_LOAD_XOTCLCONFIG, [ - AC_MSG_CHECKING([for existence of $XOTCL_BIN_DIR/xotclConfig.sh]) +AC_DEFUN(SC_LOAD_NSFCONFIG, [ + AC_MSG_CHECKING([for existence of $NX_BIN_DIR/nsfConfig.sh]) - if test -f "$XOTCL_BIN_DIR/xotclConfig.sh" ; then + if test -f "$NX_BIN_DIR/nsfConfig.sh" ; then AC_MSG_RESULT([loading]) - . $XOTCL_BIN_DIR/xotclConfig.sh + . $NX_BIN_DIR/nsfConfig.sh else AC_MSG_RESULT([file not found]) fi @@ -124,16 +125,16 @@ # The eval is required to do the TCL_DBGX substitution in the # TCL_LIB_FILE variable # - AC_SUBST(XOTCL_VERSION) - AC_SUBST(XOTCL_MAJOR_VERSION) - AC_SUBST(XOTCL_MINOR_VERSION) - AC_SUBST(XOTCL_RELEASE_LEVEL) - AC_SUBST(XOTCL_LIB_FILE) - AC_SUBST(XOTCL_BUILD_LIB_SPEC) - AC_SUBST(XOTCL_LIB_SPEC) - AC_SUBST(XOTCL_STUB_LIB_FILE) - AC_SUBST(XOTCL_BUILD_STUB_LIB_SPEC) - AC_SUBST(XOTCL_STUB_LIB_SPEC) - AC_SUBST(XOTCL_SRC_DIR) + AC_SUBST(NX_VERSION) + AC_SUBST(NX_MAJOR_VERSION) + AC_SUBST(NX_MINOR_VERSION) + AC_SUBST(NX_RELEASE_LEVEL) + AC_SUBST(NX_LIB_FILE) + AC_SUBST(NX_BUILD_LIB_SPEC) + AC_SUBST(NX_LIB_SPEC) + AC_SUBST(NX_STUB_LIB_FILE) + AC_SUBST(NX_BUILD_STUB_LIB_SPEC) + AC_SUBST(NX_STUB_LIB_SPEC) + AC_SUBST(NX_SRC_DIR) ]) Index: nsfConfig.sh.in =================================================================== diff -u -N --- nsfConfig.sh.in (revision 0) +++ nsfConfig.sh.in (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -0,0 +1,69 @@ +# xotclConfig.sh -- +# +# This shell script (for sh) is generated automatically by XOTcl's +# configure script. It will create shell variables for most of +# the configuration options discovered by the configure script. +# This script is intended to be included by the configure scripts +# for XOTcl extensions so that they don't have to figure this all +# out for themselves. This file does not duplicate information +# already provided by tclConfig.sh, so you may need to use that +# file in addition to this one. +# +# The information in this file is specific to a single platform. + +# XOTcl's version number. +XOTCL_VERSION='@XOTCL_VERSION@' +XOTCL_MAJOR_VERSION='@XOTCL_MAJOR_VERSION@' +XOTCL_MINOR_VERSION='@XOTCL_MINOR_VERSION@' +XOTCL_RELEASE_LEVEL='@XOTCL_RELEASE_LEVEL@' + +# String to pass to compiles to pick up includes during build +# (i.e., assuming nothing has been installed) +XOTCL_BUILD_INCLUDE_DIR='@XOTCL_BUILD_INCLUDE_DIR@' +XOTCL_BUILD_INCLUDE_SPEC="-I${XOTCL_BUILD_INCLUDE_DIR}" + +# String to pass to compiles to pick up the XOTcl includes from their +# installed directory. +XOTCL_INCLUDE_DIR="@pkgincludedir@" +XOTCL_INCLUDE_SPEC="-I$XOTCL_INCLUDE_DIR" + +# The name of the XOTcl library (may be either a .a file or a shared library): +XOTCL_LIB_FILE=@PKG_LIB_FILE@ + +# String to pass to linker to pick up the XOTcl library from its +# build directory. +XOTCL_BUILD_LIB_SPEC='@XOTCL_BUILD_LIB_SPEC@' + +# String to pass to linker to pick up the XOTcl library from its +# installed directory. +XOTCL_LIB_SPEC='@XOTCL_LIB_SPEC@' + +# The name of the XOTcl stub library (a .a file): +# XOTCL_STUB_LIB_FILE=@PKG_STUB_LIB_FILE@ + +# String to pass to linker to pick up the XOTcl stub library from its +# build directory. +XOTCL_BUILD_STUB_LIB_SPEC='@XOTCL_BUILD_STUB_LIB_SPEC@' + +# String to pass to linker to pick up the XOTcl stub library from its +# installed directory. +XOTCL_STUB_LIB_SPEC='@XOTCL_STUB_LIB_SPEC@' + +# Name of the xotcl stub library with full path in build and install directory +XOTCL_BUILD_STUB_LIB_PATH='@XOTCL_BUILD_STUB_LIB_PATH@' +XOTCL_STUB_LIB_PATH='@XOTCL_STUB_LIB_PATH@' + +# Location of the top-level source directories from which XOTcl +# was built. This is the directory that contains generic, unix, etc. +# If XOTcl was compiled in a different place than the directory +# containing the source files, this points to the location of the sources, +# not the location where XOTcl was compiled. +XOTCL_SRC_DIR='@XOTCL_SRC_DIR@' + +# shared and unshared library suffix +XOTCL_SHARED_LIB_SUFFIX=@SHARED_LIB_SUFFIX@ +XOTCL_UNSHARED_LIB_SUFFIX=@UNSHARED_LIB_SUFFIX@ + +# the shell in whose installation dirs the xotcl package is installed +XOTCL_COMPATIBLE_TCLSH=@XOTCL_COMPATIBLE_TCLSH@ + Index: unix/tkAppInit.c =================================================================== diff -u -N -r2111020b49da8ce57758e51accf0b6073037f0d2 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- unix/tkAppInit.c (.../tkAppInit.c) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ unix/tkAppInit.c (.../tkAppInit.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -18,7 +18,7 @@ #include "tk.h" #include "locale.h" -#include +#include /* *---------------------------------------------------------------------- Index: unix/xotcl.spec.in =================================================================== diff -u -N -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- unix/xotcl.spec.in (.../xotcl.spec.in) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ unix/xotcl.spec.in (.../xotcl.spec.in) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -50,7 +50,7 @@ %_prefix/lib/xotclgdbm* %_prefix/lib/xotclsdbm* %_prefix/lib/xotclConfig.sh -%_includedir/xotcl.h -%_includedir/xotclInt.h +%_includedir/nsf.h +%_includedir/nsfInt.h %_includedir/xotclDecls.h -%_includedir/xotclIntDecls.h \ No newline at end of file +%_includedir/nsfIntDecls.h \ No newline at end of file Index: win/Makefile.vc =================================================================== diff -u -N -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- win/Makefile.vc (.../Makefile.vc) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ win/Makefile.vc (.../Makefile.vc) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -294,7 +294,7 @@ # if not exist "$(INCLUDE_INSTALL_DIR)" mkdir "$(INCLUDE_INSTALL_DIR)" # copy $(XOTCLTARGET) "$(SCRIPT_INSTALL_DIR)" # -copy $(XOTCLSTUBLIB) "$(LIB_INSTALL_DIR)" -# copy $(ROOT)\generic\xotcl.h "$(INCLUDE_INSTALL_DIR)" +# copy $(ROOT)\generic\nsf.h "$(INCLUDE_INSTALL_DIR)" # copy $(ROOT)\generic\xotclDecls.h "$(INCLUDE_INSTALL_DIR)" # copy $(ROOT)\library\*.* "$(SCRIPT_INSTALL_DIR)" # echo package ifneeded XOTcl $(XOTCL_DOTVERSION) [list load [file join $$dir ../../bin $(XOTCLOUTNAME).dll] XOTcl] > \ @@ -306,7 +306,7 @@ genstubs: $(TCLSH) $(TCLROOT)\tools\genStubs.tcl $(GENERICDIR) \ - $(GENERICDIR)\xotcl.decls $(GENERICDIR)\xotclInt.decls + $(GENERICDIR)\xotcl.decls $(GENERICDIR)\nsfInt.decls ###################################################################### # Special case object file targets Index: win/rc/xotcl.rc =================================================================== diff -u -N -r2111020b49da8ce57758e51accf0b6073037f0d2 -r0e8b567e2a1808c514f6340430920ad4d59953bc --- win/rc/xotcl.rc (.../xotcl.rc) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ win/rc/xotcl.rc (.../xotcl.rc) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -5,7 +5,7 @@ #include #define RESOURCE_INCLUDED -#include +#include // Index: win/winMain.c =================================================================== diff -u -N -r78e6c23b4195221aba2a75be9e813382d74f20fb -r0e8b567e2a1808c514f6340430920ad4d59953bc --- win/winMain.c (.../winMain.c) (revision 78e6c23b4195221aba2a75be9e813382d74f20fb) +++ win/winMain.c (.../winMain.c) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -1,429 +1,429 @@ -/* - * winMain.c -- - * - * Main entry point for wish and other Tk-based applications. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "tcl-license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - */ - -#include -#define WIN32_LEAN_AND_MEAN -#include -#undef WIN32_LEAN_AND_MEAN -#include -#include -#if defined(VISUAL_CC) -# include "xotcl.h" -#else -# include -#endif - -#include "tkInt.h" - -/* - * The following declarations refer to internal Tk routines. These - * interfaces are available for use, but are not supported. - */ -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 -EXTERN void TkConsoleCreate(void); -EXTERN int TkConsoleInit(Tcl_Interp *interp); -#endif -/* - * Forward declarations for procedures defined later in this file: - */ - -static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); -static void WishPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); - -#ifdef TK_TEST -extern int Tktest_Init(Tcl_Interp *interp); -#endif /* TK_TEST */ - -#ifdef TCL_TEST -extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#endif /* TCL_TEST */ - -static BOOL consoleRequired = TRUE; - - -/* - *---------------------------------------------------------------------- - * - * WinMain -- - * - * Main entry point from Windows. - * - * Results: - * Returns false if initialization fails, otherwise it never - * returns. - * - * Side effects: - * Just about anything, since from here we call arbitrary Tcl code. - * - *---------------------------------------------------------------------- - */ - -int APIENTRY -WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) - HINSTANCE hInstance; - HINSTANCE hPrevInstance; - LPSTR lpszCmdLine; - int nCmdShow; -{ - char **argv; - int argc; -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 - char buffer[MAX_PATH+1]; - char *p; -#endif - Tcl_SetPanicProc(WishPanic); - - /* - * Set up the default locale to be standard "C" locale so parsing - * is performed correctly. - */ - - setlocale(LC_ALL, "C"); -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION>1 - setargv(&argc, &argv); -#endif - /* - * Increase the application queue size from default value of 8. - * At the default value, cross application SendMessage of WM_KILLFOCUS - * will fail because the handler will not be able to do a PostMessage! - * This is only needed for Windows 3.x, since NT dynamically expands - * the queue. - */ - - SetMessageQueue(64); - - /* - * Create the console channels and install them as the standard - * channels. All I/O will be discarded until Tk_CreateConsoleWindow is - * called to attach the console to a text widget. - */ -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 - TkConsoleCreate(); - - setargv(&argc, &argv); - - /* - * Replace argv[0] with full pathname of executable, and forward - * slashes substituted for backslashes. - */ - - GetModuleFileName(NULL, buffer, sizeof(buffer)); - argv[0] = buffer; - for (p = buffer; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } -#endif - consoleRequired = TRUE; - - Tk_Main(argc, argv, Tcl_AppInit); - return 1; -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - if (Tcl_Init(interp) == TCL_ERROR) { - goto error; - } - if (Tk_Init(interp) == TCL_ERROR) { - goto error; - } - Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); - - /* - if (Xotcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "XOTcl", Xotcl_Init, 0); - */ - if (Tcl_PkgRequire(interp, "XOTcl", XOTCLVERSION, 1) == NULL) { - return TCL_ERROR; - } - - /* - * This is xotclsh, so import all xotcl commands by - * default into the global namespace. - */ - if (Tcl_Import(interp, Tcl_GetGlobalNamespace(interp), - "::xotcl::*", /* allowOverwrite */ 1) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Initialize the console only if we are running as an interactive - * application. - */ -#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 - if (TkConsoleInit(interp) == TCL_ERROR) { - goto error; - } -#else - if (consoleRequired) { - if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) { - goto error; - } - } -#endif - -#ifdef TCL_TEST - if (Tcltest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, - (Tcl_PackageInitProc *) NULL); - if (TclObjTest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif /* TCL_TEST */ - -#ifdef TK_TEST - if (Tktest_Init(interp) == TCL_ERROR) { - goto error; - } - Tcl_StaticPackage(interp, "Tktest", Tktest_Init, - (Tcl_PackageInitProc *) NULL); -#endif /* TK_TEST */ - - Tcl_SetVar(interp, "tcl_rcFileName", "~/wishrc.tcl", TCL_GLOBAL_ONLY); - return TCL_OK; - -error: - WishPanic(Tcl_GetStringResult(interp)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * WishPanic -- - * - * Display a message and exit. - * - * Results: - * None. - * - * Side effects: - * Exits the program. - * - *---------------------------------------------------------------------- - */ - -void -WishPanic TCL_VARARGS_DEF(CONST char *,arg1) -{ - va_list argList; - char buf[1024]; - CONST char *format; - - format = TCL_VARARGS_START(CONST char *,arg1,argList); - vsprintf(buf, format, argList); - - MessageBeep(MB_ICONEXCLAMATION); - MessageBox(NULL, buf, "Fatal Error in Wish", - MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); -#ifdef _MSC_VER - DebugBreak(); -#endif - ExitProcess(1); -} -/* - *------------------------------------------------------------------------- - * - * setargv -- - * - * Parse the Windows command line string into argc/argv. Done here - * because we don't trust the builtin argument parser in crt0. - * Windows applications are responsible for breaking their command - * line into arguments. - * - * 2N backslashes + quote -> N backslashes + begin quoted string - * 2N + 1 backslashes + quote -> literal - * N backslashes + non-quote -> literal - * quote + quote in a quoted string -> single quote - * quote + quote not in quoted string -> empty string - * quote -> begin quoted string - * - * Results: - * Fills argcPtr with the number of arguments and argvPtr with the - * array of arguments. - * - * Side effects: - * Memory allocated. - * - *-------------------------------------------------------------------------- - */ - -static void -setargv(argcPtr, argvPtr) - int *argcPtr; /* Filled with number of argument strings. */ - char ***argvPtr; /* Filled with argument strings (malloc'd). */ -{ - char *cmdLine, *p, *arg, *argSpace; - char **argv; - int argc, size, inquote, copy, slashes; - - cmdLine = GetCommandLine(); /* INTL: BUG */ - - /* - * Precompute an overly pessimistic guess at the number of arguments - * in the command line by counting non-space spans. - */ - - size = 2; - for (p = cmdLine; *p != '\0'; p++) { - if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - size++; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - p++; - } - if (*p == '\0') { - break; - } - } - } - argSpace = (char *) Tcl_Alloc( - (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); - argv = (char **) argSpace; - argSpace += size * sizeof(char *); - size--; - - p = cmdLine; - for (argc = 0; argc < size; argc++) { - argv[argc] = arg = argSpace; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ - p++; - } - if (*p == '\0') { - break; - } - - inquote = 0; - slashes = 0; - while (1) { - copy = 1; - while (*p == '\\') { - slashes++; - p++; - } - if (*p == '"') { - if ((slashes & 1) == 0) { - copy = 0; - if ((inquote) && (p[1] == '"')) { - p++; - copy = 1; - } else { - inquote = !inquote; - } - } - slashes >>= 1; - } - - while (slashes) { - *arg = '\\'; - arg++; - slashes--; - } - - if ((*p == '\0') - || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ - break; - } - if (copy != 0) { - *arg = *p; - arg++; - } - p++; - } - *arg = '\0'; - argSpace = arg + 1; - } - argv[argc] = NULL; - - *argcPtr = argc; - *argvPtr = argv; -} - - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * Main entry point from the console. - * - * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the applications does. - * - *---------------------------------------------------------------------- - */ - -int main(int argc, char **argv) -{ - Tcl_SetPanicProc(WishPanic); - - /* - * Set up the default locale to be standard "C" locale so parsing - * is performed correctly. - */ - - setlocale(LC_ALL, "C"); - /* - * Increase the application queue size from default value of 8. - * At the default value, cross application SendMessage of WM_KILLFOCUS - * will fail because the handler will not be able to do a PostMessage! - * This is only needed for Windows 3.x, since NT dynamically expands - * the queue. - */ - - SetMessageQueue(64); - - /* - * Create the console channels and install them as the standard - * channels. All I/O will be discarded until Tk_CreateConsoleWindow is - * called to attach the console to a text widget. - */ - - consoleRequired = FALSE; - - Tk_Main(argc, argv, Tcl_AppInit); - return 0; -} - +/* + * winMain.c -- + * + * Main entry point for wish and other Tk-based applications. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * + * See the file "tcl-license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + */ + +#include +#define WIN32_LEAN_AND_MEAN +#include +#undef WIN32_LEAN_AND_MEAN +#include +#include +#if defined(VISUAL_CC) +# include "nsf.h" +#else +# include +#endif + +#include "tkInt.h" + +/* + * The following declarations refer to internal Tk routines. These + * interfaces are available for use, but are not supported. + */ +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 +EXTERN void TkConsoleCreate(void); +EXTERN int TkConsoleInit(Tcl_Interp *interp); +#endif +/* + * Forward declarations for procedures defined later in this file: + */ + +static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); +static void WishPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); + +#ifdef TK_TEST +extern int Tktest_Init(Tcl_Interp *interp); +#endif /* TK_TEST */ + +#ifdef TCL_TEST +extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + +static BOOL consoleRequired = TRUE; + + +/* + *---------------------------------------------------------------------- + * + * WinMain -- + * + * Main entry point from Windows. + * + * Results: + * Returns false if initialization fails, otherwise it never + * returns. + * + * Side effects: + * Just about anything, since from here we call arbitrary Tcl code. + * + *---------------------------------------------------------------------- + */ + +int APIENTRY +WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) + HINSTANCE hInstance; + HINSTANCE hPrevInstance; + LPSTR lpszCmdLine; + int nCmdShow; +{ + char **argv; + int argc; +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 + char buffer[MAX_PATH+1]; + char *p; +#endif + Tcl_SetPanicProc(WishPanic); + + /* + * Set up the default locale to be standard "C" locale so parsing + * is performed correctly. + */ + + setlocale(LC_ALL, "C"); +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION>1 + setargv(&argc, &argv); +#endif + /* + * Increase the application queue size from default value of 8. + * At the default value, cross application SendMessage of WM_KILLFOCUS + * will fail because the handler will not be able to do a PostMessage! + * This is only needed for Windows 3.x, since NT dynamically expands + * the queue. + */ + + SetMessageQueue(64); + + /* + * Create the console channels and install them as the standard + * channels. All I/O will be discarded until Tk_CreateConsoleWindow is + * called to attach the console to a text widget. + */ +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 + TkConsoleCreate(); + + setargv(&argc, &argv); + + /* + * Replace argv[0] with full pathname of executable, and forward + * slashes substituted for backslashes. + */ + + GetModuleFileName(NULL, buffer, sizeof(buffer)); + argv[0] = buffer; + for (p = buffer; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } +#endif + consoleRequired = TRUE; + + Tk_Main(argc, argv, Tcl_AppInit); + return 1; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in the interp's result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + goto error; + } + if (Tk_Init(interp) == TCL_ERROR) { + goto error; + } + Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); + + /* + if (Xotcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "XOTcl", Xotcl_Init, 0); + */ + if (Tcl_PkgRequire(interp, "XOTcl", XOTCLVERSION, 1) == NULL) { + return TCL_ERROR; + } + + /* + * This is xotclsh, so import all xotcl commands by + * default into the global namespace. + */ + if (Tcl_Import(interp, Tcl_GetGlobalNamespace(interp), + "::xotcl::*", /* allowOverwrite */ 1) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Initialize the console only if we are running as an interactive + * application. + */ +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<2 + if (TkConsoleInit(interp) == TCL_ERROR) { + goto error; + } +#else + if (consoleRequired) { + if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) { + goto error; + } + } +#endif + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); + if (TclObjTest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif /* TCL_TEST */ + +#ifdef TK_TEST + if (Tktest_Init(interp) == TCL_ERROR) { + goto error; + } + Tcl_StaticPackage(interp, "Tktest", Tktest_Init, + (Tcl_PackageInitProc *) NULL); +#endif /* TK_TEST */ + + Tcl_SetVar(interp, "tcl_rcFileName", "~/wishrc.tcl", TCL_GLOBAL_ONLY); + return TCL_OK; + +error: + WishPanic(Tcl_GetStringResult(interp)); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * WishPanic -- + * + * Display a message and exit. + * + * Results: + * None. + * + * Side effects: + * Exits the program. + * + *---------------------------------------------------------------------- + */ + +void +WishPanic TCL_VARARGS_DEF(CONST char *,arg1) +{ + va_list argList; + char buf[1024]; + CONST char *format; + + format = TCL_VARARGS_START(CONST char *,arg1,argList); + vsprintf(buf, format, argList); + + MessageBeep(MB_ICONEXCLAMATION); + MessageBox(NULL, buf, "Fatal Error in Wish", + MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); +#ifdef _MSC_VER + DebugBreak(); +#endif + ExitProcess(1); +} +/* + *------------------------------------------------------------------------- + * + * setargv -- + * + * Parse the Windows command line string into argc/argv. Done here + * because we don't trust the builtin argument parser in crt0. + * Windows applications are responsible for breaking their command + * line into arguments. + * + * 2N backslashes + quote -> N backslashes + begin quoted string + * 2N + 1 backslashes + quote -> literal + * N backslashes + non-quote -> literal + * quote + quote in a quoted string -> single quote + * quote + quote not in quoted string -> empty string + * quote -> begin quoted string + * + * Results: + * Fills argcPtr with the number of arguments and argvPtr with the + * array of arguments. + * + * Side effects: + * Memory allocated. + * + *-------------------------------------------------------------------------- + */ + +static void +setargv(argcPtr, argvPtr) + int *argcPtr; /* Filled with number of argument strings. */ + char ***argvPtr; /* Filled with argument strings (malloc'd). */ +{ + char *cmdLine, *p, *arg, *argSpace; + char **argv; + int argc, size, inquote, copy, slashes; + + cmdLine = GetCommandLine(); /* INTL: BUG */ + + /* + * Precompute an overly pessimistic guess at the number of arguments + * in the command line by counting non-space spans. + */ + + size = 2; + for (p = cmdLine; *p != '\0'; p++) { + if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + size++; + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + p++; + } + if (*p == '\0') { + break; + } + } + } + argSpace = (char *) Tcl_Alloc( + (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); + argv = (char **) argSpace; + argSpace += size * sizeof(char *); + size--; + + p = cmdLine; + for (argc = 0; argc < size; argc++) { + argv[argc] = arg = argSpace; + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + p++; + } + if (*p == '\0') { + break; + } + + inquote = 0; + slashes = 0; + while (1) { + copy = 1; + while (*p == '\\') { + slashes++; + p++; + } + if (*p == '"') { + if ((slashes & 1) == 0) { + copy = 0; + if ((inquote) && (p[1] == '"')) { + p++; + copy = 1; + } else { + inquote = !inquote; + } + } + slashes >>= 1; + } + + while (slashes) { + *arg = '\\'; + arg++; + slashes--; + } + + if ((*p == '\0') + || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ + break; + } + if (copy != 0) { + *arg = *p; + arg++; + } + p++; + } + *arg = '\0'; + argSpace = arg + 1; + } + argv[argc] = NULL; + + *argcPtr = argc; + *argvPtr = argv; +} + + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * Main entry point from the console. + * + * Results: + * None: Tk_Main never returns here, so this procedure never + * returns either. + * + * Side effects: + * Whatever the applications does. + * + *---------------------------------------------------------------------- + */ + +int main(int argc, char **argv) +{ + Tcl_SetPanicProc(WishPanic); + + /* + * Set up the default locale to be standard "C" locale so parsing + * is performed correctly. + */ + + setlocale(LC_ALL, "C"); + /* + * Increase the application queue size from default value of 8. + * At the default value, cross application SendMessage of WM_KILLFOCUS + * will fail because the handler will not be able to do a PostMessage! + * This is only needed for Windows 3.x, since NT dynamically expands + * the queue. + */ + + SetMessageQueue(64); + + /* + * Create the console channels and install them as the standard + * channels. All I/O will be discarded until Tk_CreateConsoleWindow is + * called to attach the console to a text widget. + */ + + consoleRequired = FALSE; + + Tk_Main(argc, argv, Tcl_AppInit); + return 0; +} + Index: xotcl.m4 =================================================================== diff -u -N -raf4326a00a0f2d0b2f1e0369af71637f48c2d56a -r0e8b567e2a1808c514f6340430920ad4d59953bc --- xotcl.m4 (.../xotcl.m4) (revision af4326a00a0f2d0b2f1e0369af71637f48c2d56a) +++ xotcl.m4 (.../xotcl.m4) (revision 0e8b567e2a1808c514f6340430920ad4d59953bc) @@ -10,9 +10,9 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------------------ -# SC_PATH_XOTCLCONFIG -- +# SC_PATH_NSFCONFIG -- # -# Locate the xotclConfig.sh file and perform a sanity check on +# Locate the nsfConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: @@ -25,10 +25,10 @@ # # Defines the following vars: # NX_BIN_DIR Full path to the directory containing -# the xotclConfig.sh file +# the nsfConfig.sh file #------------------------------------------------------------------------ -AC_DEFUN(SC_PATH_XOTCLCONFIG, [ +AC_DEFUN(SC_PATH_NSFCONFIG, [ # # Ok, lets find the tcl configuration # First, look for one uninstalled. @@ -37,21 +37,21 @@ if test x"${no_xotcl}" = x ; then # we reset no_xotcl in case something fails here no_xotcl=true - AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (xotclConfig.sh)], with_xotclconfig=${withval}) + AC_ARG_WITH(xotcl, [ --with-xotcl directory containing xotcl configuration (nsfConfig.sh)], with_nsfconfig=${withval}) AC_MSG_CHECKING([for XOTcl configuration]) - AC_CACHE_VAL(ac_cv_c_xotclconfig,[ + AC_CACHE_VAL(ac_cv_c_nsfconfig,[ # First check to see if --with-xotcl was specified. - if test x"${with_xotclconfig}" != x ; then - if test -f "${with_xotclconfig}/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd ${with_xotclconfig}; pwd)` + if test x"${with_nsfconfig}" != x ; then + if test -f "${with_nsfconfig}/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd ${with_nsfconfig}; pwd)` else - AC_MSG_ERROR([${with_xotclconfig} directory doesn't contain xotclConfig.sh]) + AC_MSG_ERROR([${with_nsfconfig} directory doesn't contain nsfConfig.sh]) fi fi # then check for a private Tcl installation - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in \ ${srcdir}/../xotcl \ `ls -dr ${srcdir}/../xotcl-* 2>/dev/null` \ @@ -63,40 +63,40 @@ `ls -dr ${srcdir}/../../../../xotcl-* 2>/dev/null` \ ${srcdir}/../../../../../xotcl \ `ls -dr ${srcdir}/../../../../../xotcl-* 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi # check in a few common install locations - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then for i in `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` ; do - if test -f "$i/xotclConfig.sh" ; then - ac_cv_c_xotclconfig=`(cd $i; pwd)` + if test -f "$i/nsfConfig.sh" ; then + ac_cv_c_nsfconfig=`(cd $i; pwd)` break fi done fi ]) - if test x"${ac_cv_c_xotclconfig}" = x ; then + if test x"${ac_cv_c_nsfconfig}" = x ; then NX_BIN_DIR="# no XOTcl configs found" AC_MSG_WARN(Can't find XOTcl configuration definitions) exit 0 else no_xotcl= - NX_BIN_DIR=${ac_cv_c_xotclconfig} - AC_MSG_RESULT(found $NX_BIN_DIR/xotclConfig.sh) + NX_BIN_DIR=${ac_cv_c_nsfconfig} + AC_MSG_RESULT(found $NX_BIN_DIR/nsfConfig.sh) fi fi ]) #------------------------------------------------------------------------ -# SC_LOAD_XOTCLCONFIG -- +# SC_LOAD_NSFCONFIG -- # # Load the tclConfig.sh file # @@ -111,12 +111,12 @@ # #------------------------------------------------------------------------ -AC_DEFUN(SC_LOAD_XOTCLCONFIG, [ - AC_MSG_CHECKING([for existence of $NX_BIN_DIR/xotclConfig.sh]) +AC_DEFUN(SC_LOAD_NSFCONFIG, [ + AC_MSG_CHECKING([for existence of $NX_BIN_DIR/nsfConfig.sh]) - if test -f "$NX_BIN_DIR/xotclConfig.sh" ; then + if test -f "$NX_BIN_DIR/nsfConfig.sh" ; then AC_MSG_RESULT([loading]) - . $NX_BIN_DIR/xotclConfig.sh + . $NX_BIN_DIR/nsfConfig.sh else AC_MSG_RESULT([file not found]) fi Index: xotclConfig.sh.in =================================================================== diff -u -N --- xotclConfig.sh.in (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ xotclConfig.sh.in (revision 0) @@ -1,69 +0,0 @@ -# xotclConfig.sh -- -# -# This shell script (for sh) is generated automatically by XOTcl's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for XOTcl extensions so that they don't have to figure this all -# out for themselves. This file does not duplicate information -# already provided by tclConfig.sh, so you may need to use that -# file in addition to this one. -# -# The information in this file is specific to a single platform. - -# XOTcl's version number. -XOTCL_VERSION='@XOTCL_VERSION@' -XOTCL_MAJOR_VERSION='@XOTCL_MAJOR_VERSION@' -XOTCL_MINOR_VERSION='@XOTCL_MINOR_VERSION@' -XOTCL_RELEASE_LEVEL='@XOTCL_RELEASE_LEVEL@' - -# String to pass to compiles to pick up includes during build -# (i.e., assuming nothing has been installed) -XOTCL_BUILD_INCLUDE_DIR='@XOTCL_BUILD_INCLUDE_DIR@' -XOTCL_BUILD_INCLUDE_SPEC="-I${XOTCL_BUILD_INCLUDE_DIR}" - -# String to pass to compiles to pick up the XOTcl includes from their -# installed directory. -XOTCL_INCLUDE_DIR="@pkgincludedir@" -XOTCL_INCLUDE_SPEC="-I$XOTCL_INCLUDE_DIR" - -# The name of the XOTcl library (may be either a .a file or a shared library): -XOTCL_LIB_FILE=@PKG_LIB_FILE@ - -# String to pass to linker to pick up the XOTcl library from its -# build directory. -XOTCL_BUILD_LIB_SPEC='@XOTCL_BUILD_LIB_SPEC@' - -# String to pass to linker to pick up the XOTcl library from its -# installed directory. -XOTCL_LIB_SPEC='@XOTCL_LIB_SPEC@' - -# The name of the XOTcl stub library (a .a file): -# XOTCL_STUB_LIB_FILE=@PKG_STUB_LIB_FILE@ - -# String to pass to linker to pick up the XOTcl stub library from its -# build directory. -XOTCL_BUILD_STUB_LIB_SPEC='@XOTCL_BUILD_STUB_LIB_SPEC@' - -# String to pass to linker to pick up the XOTcl stub library from its -# installed directory. -XOTCL_STUB_LIB_SPEC='@XOTCL_STUB_LIB_SPEC@' - -# Name of the xotcl stub library with full path in build and install directory -XOTCL_BUILD_STUB_LIB_PATH='@XOTCL_BUILD_STUB_LIB_PATH@' -XOTCL_STUB_LIB_PATH='@XOTCL_STUB_LIB_PATH@' - -# Location of the top-level source directories from which XOTcl -# was built. This is the directory that contains generic, unix, etc. -# If XOTcl was compiled in a different place than the directory -# containing the source files, this points to the location of the sources, -# not the location where XOTcl was compiled. -XOTCL_SRC_DIR='@XOTCL_SRC_DIR@' - -# shared and unshared library suffix -XOTCL_SHARED_LIB_SUFFIX=@SHARED_LIB_SUFFIX@ -XOTCL_UNSHARED_LIB_SUFFIX=@UNSHARED_LIB_SUFFIX@ - -# the shell in whose installation dirs the xotcl package is installed -XOTCL_COMPATIBLE_TCLSH=@XOTCL_COMPATIBLE_TCLSH@ -