/*
* nsf.c --
*
* Basic Machinery of the Next Scripting Framework, a Tcl-based framework
* for supporting language-oriented programming. For details, see
* https://next-scripting.org/.
*
* Copyright (C) 1999-2022 Gustaf Neumann (a) (b)
* Copyright (C) 1999-2007 Uwe Zdun (a) (b)
* Copyright (C) 2007-2008 Martin Matuska (b)
* Copyright (C) 2010-2019 Stefan Sobernig (b)
*
*
* (a) University of Essen
* Specification of Software Systems
* Altendorferstrasse 97-101
* D-45143 Essen, Germany
*
* (b) Vienna University of Economics and Business
* Institute of Information Systems and New Media
* A-1020, Welthandelsplatz 1
* Vienna, Austria
*
* This work is licensed under the MIT License
* https://www.opensource.org/licenses/MIT
*
* Copyright:
*
* Permission is hereby granted, free of charge, to any person obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense,
* and/or sell copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
* DEALINGS IN THE SOFTWARE.
*
*
* 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 NSF_FORWARD_WITH_ONERROR 1
#define NSF_C 1
#include "nsfInt.h"
#include "nsfAccessInt.h"
#ifdef COMPILE_NSF_STUBS
# if defined(PRE86)
EXTERN NsfStubs nsfStubs;
# else
MODULE_SCOPE const NsfStubs nsfStubs;
# endif
#endif
#ifdef USE_TCL_STUBS
# define Nsf_ExprObjCmd(clientData, interp, objc, objv) \
NsfCallCommand(interp, NSF_EXPR, objc, objv)
#else
# define Nsf_ExprObjCmd(clientData, interp, objc, objv) \
Tcl_ExprObjCmd(clientData, interp, objc, objv)
#endif
/*
* Call Stack specific definitions
*/
typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel;
typedef struct callFrameContext {
Tcl_CallFrame *framePtr;
Tcl_CallFrame *varFramePtr;
bool frameSaved;
} callFrameContext;
/* #define COLON_CMD_STATS 1 */
typedef struct {
void *context;
Tcl_Command cmd;
NsfClass *class;
unsigned int methodEpoch;
unsigned int flags;
#if defined(COLON_CMD_STATS)
size_t hits;
size_t invalidates;
size_t requiredRefetches;
Tcl_Obj *obj;
#endif
} NsfColonCmdContext;
typedef struct NsfProcContext {
ClientData oldDeleteData;
Tcl_CmdDeleteProc *oldDeleteProc;
NsfParamDefs *paramDefs;
long *colonLocalVarCache;
unsigned int checkAlwaysFlag;
Tcl_Namespace *execNsPtr;
Tcl_Obj *returnsObj;
} NsfProcContext;
/*
* TclCmdClientdata is an incomplete type containing the common
* field(s) of ForwardCmdClientData, AliasCmdClientData and
* SetterCmdClientData used for filling in at run time the actual
* object.
*/
typedef struct TclCmdClientData {
NsfObject *object;
} TclCmdClientData;
typedef struct SetterCmdClientData {
NsfObject *object;
Nsf_Param *paramsPtr;
} SetterCmdClientData;
typedef struct ForwardCmdClientData {
NsfObject *object;
Tcl_Obj *cmdName;
TCL_OBJCMDPROC_T *objProc;
ClientData clientData;
bool passthrough;
bool needobjmap;
bool verbose;
bool hasNonposArgs;
Tcl_Obj *args;
TCL_OBJC_T nr_args;
int frame;
#if defined(NSF_FORWARD_WITH_ONERROR)
Tcl_Obj *onerror;
#endif
Tcl_Obj *prefix;
Tcl_Obj *subcommands;
TCL_SIZE_T nr_subcommands;
} ForwardCmdClientData;
typedef struct AliasCmdClientData {
NsfObject *object;
Tcl_Obj *cmdName;
TCL_OBJCMDPROC_T *objProc;
ClientData clientData;
NsfClass *class;
Tcl_Interp *interp;
Tcl_Command aliasedCmd;
Tcl_Command aliasCmd;
} AliasCmdClientData;
/*
* When NSF_MEM_COUNT is set, we want to trace as well the mem-count frees
* associated with the interp. Therefore, we need in this case a special
* client data structure.
*/
#ifdef NSF_MEM_COUNT
typedef struct NsfNamespaceClientData {
NsfObject *object;
Tcl_Namespace *nsPtr;
Tcl_Interp *interp;
} NsfNamespaceClientData;
#endif
/*
* Argv parsing specific definitions
*/
#define PARSE_CONTEXT_PREALLOC 20
typedef struct {
ClientData *clientData; /* 4 members pointer to the actual parse context data */
Tcl_Obj **objv;
Tcl_Obj **full_objv; /* contains method as well */
unsigned int *flags;
ClientData clientData_static[PARSE_CONTEXT_PREALLOC]; /* 3 preallocated parse context data */
Tcl_Obj *objv_static[PARSE_CONTEXT_PREALLOC+1];
unsigned int flags_static[PARSE_CONTEXT_PREALLOC+1];
unsigned int status;
TCL_OBJC_T lastObjc; /* points to the first "unprocessed" argument */
TCL_OBJC_T objc;
NsfObject *object;
bool varArgs; /* does the parameter end with some kind of "args" */
} ParseContext;
static Nsf_TypeConverter ConvertToNothing, ConvertViaCmd, ConvertToObjpattern;
static const char *autonamePrefix = "::nsf::__#";
static const size_t autonamePrefixLength = 10u;
static const char * nsfClassesPrefix = "::nsf::classes";
static const size_t nsfClassesPrefixLength = 14u;
/*
* Tcl_Obj Types for Next Scripting Objects
*/
static Tcl_ObjType CONST86
*Nsf_OT_byteCodeType = NULL,
*Nsf_OT_tclCmdNameType = NULL,
*Nsf_OT_listType = NULL,
*Nsf_OT_doubleType = NULL,
*Nsf_OT_intType = NULL,
*Nsf_OT_parsedVarNameType = NULL,
*Nsf_OT_byteArrayType = NULL,
*Nsf_OT_properByteArrayType = NULL,
*Nsf_OT_bignumType = NULL;
/*
* Function prototypes
*/
/*
* Prototypes for method definitions
*/
static TCL_OBJCMDPROC_T NsfForwardMethod;
static TCL_OBJCMDPROC_T NsfObjscopedMethod;
static TCL_OBJCMDPROC_T NsfSetterMethod;
static TCL_OBJCMDPROC_T NsfProcAliasMethod;
static TCL_OBJCMDPROC_T NsfAsmProc;
TCL_OBJCMDPROC_T NsfProcStub;
/*
* Prototypes for interpreter life-cyle
*/
EXTERN Tcl_LibraryInitProc Nsf_SafeInit;
EXTERN Tcl_LibraryInitProc Nsf_Init;
static Tcl_ExitProc Nsf_ExitProc;
static Tcl_ExitProc ExitHandler;
#if defined(TCL_THREADS)
static Tcl_ExitProc Nsf_ThreadExitProc;
#endif
/*
* Prototypes for methods called directly when CallDirectly() returns NULL
*/
static int NsfCAllocMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj)
nonnull(1) nonnull(2);
static int NsfCAllocMethod_(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr)
nonnull(1) nonnull(2) nonnull(3);
static int NsfCCreateMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static int NsfOCleanupMethod(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static int NsfOConfigureMethod(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[], Tcl_Obj *objv0)
nonnull(1) nonnull(2) nonnull(4) nonnull(5);
static int NsfODestroyMethod(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static int MethodDispatch(
Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Command cmd, NsfObject *object, NsfClass *class,
const char *methodName, unsigned short frameType, unsigned int flags
) nonnull(1) nonnull(3) nonnull(4) nonnull(5) nonnull(7);
static int DispatchDefaultMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *obj, unsigned int flags)
nonnull(1) nonnull(2) nonnull(3);
static int DispatchDestroyMethod(Tcl_Interp *interp, NsfObject *object, unsigned int flags)
nonnull(1) nonnull(2);
static int DispatchUnknownMethod(
Tcl_Interp *interp, NsfObject *object,
TCL_OBJC_T objc, Tcl_Obj *const objv[], Tcl_Obj *callInfoObj,
Tcl_Obj *methodObj, unsigned int flags
) nonnull(1) nonnull(2) nonnull(4) nonnull(6);
NSF_INLINE static int ObjectDispatch(
ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc,
Tcl_Obj *const objv[], unsigned int flags
) nonnull(1) nonnull(2) nonnull(4);
NSF_INLINE static int ObjectDispatchFinalize(
Tcl_Interp *interp, NsfCallStackContent *cscPtr,
int result /*, const char *string , const char *methodName*/
) nonnull(1) nonnull(2);
/*
* Prototypes for object life-cycle management
*/
static int RecreateObject(Tcl_Interp *interp, NsfClass *class, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static void FinalObjectDeletion(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
#if defined(DO_CLEANUP)
static void FreeAllNsfObjectsAndClasses(Tcl_Interp *interp, NsfCmdList **instances)
nonnull(1) nonnull(2);
#endif
static void CallStackDestroyObject(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void PrimitiveCDestroy(ClientData clientData)
nonnull(1);
static void PrimitiveODestroy(ClientData clientData)
nonnull(1);
static void PrimitiveDestroy(ClientData clientData)
nonnull(1);
static int VolatileMethod(Tcl_Interp *interp, NsfObject *object, bool shallow)
nonnull(1) nonnull(2);
/*
* Prototypes for object and command lookup
*/
static NsfObject *GetObjectFromString(Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2);
static NsfClass *GetClassFromString(Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2);
static int GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, NsfClass **classPtr, bool withUnknown)
nonnull(1) nonnull(2) nonnull(3);
static void GetAllInstances(Tcl_Interp *interp, NsfCmdList **instances, NsfClass *startClass)
nonnull(1) nonnull(2) nonnull(3);
NSF_INLINE static Tcl_Command FindMethod(
const Tcl_Namespace *nsPtr,
const char *methodName
) nonnull(1) nonnull(2);
NSF_INLINE static NsfClasses *PrecedenceOrder(
NsfClass *class
) nonnull(1);
/*
* Prototypes for namespace specific calls
*/
static Tcl_Obj *NameInNamespaceObj(const char *name, Tcl_Namespace *nsPtr)
nonnull(1) nonnull(2);
static Tcl_Namespace *CallingNameSpace(Tcl_Interp *interp)
nonnull(1) returns_nonnull;
NSF_INLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2);
static Tcl_Namespace *NSGetFreshNamespace(Tcl_Interp *interp, NsfObject *object, const char *name)
nonnull(1) nonnull(2) nonnull(3);
static Tcl_Namespace *RequireObjNamespace(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static int NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *methodName)
nonnull(1) nonnull(2) nonnull(3);
static void NSNamespaceDeleteProc(ClientData clientData)
nonnull(1);
static void NSNamespacePreserve(Tcl_Namespace *nsPtr)
nonnull(1);
static void NSNamespaceRelease(Tcl_Namespace *nsPtr)
nonnull(1);
/*
* Prototypes for filters and mixins
*/
static void FilterComputeDefined(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void MixinComputeDefined(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
NSF_INLINE static void GuardAdd(NsfCmdList *guardList, Tcl_Obj *guardObj)
nonnull(1) nonnull(2);
static int GuardCall(NsfObject *object, Tcl_Interp *interp,
Tcl_Obj *guardObj, NsfCallStackContent *cscPtr)
nonnull(1) nonnull(2) nonnull(3);
static void GuardDel(NsfCmdList *guardList)
nonnull(1);
/*
* Prototypes for forwarders
*/
static void ForwardCmdDeleteProc(ClientData clientData)
nonnull(1);
static int ForwardProcessOptions(
Tcl_Interp *interp, Tcl_Obj *nameObj,
Tcl_Obj *withDefault, int withEarlybinding,
Tcl_Obj *withOnerror, Tcl_Obj *withMethodprefix,
int withFrame, bool withVerbose,
Tcl_Obj *target, TCL_OBJC_T objc, Tcl_Obj * const objv[],
ForwardCmdClientData **tcdPtr
) nonnull(1) nonnull(2) nonnull(11);
/*
* Properties of objects and classes
*/
static bool IsRootClass(
const NsfClass *class
) nonnull(1) NSF_pure;
static bool IsRootMetaClass(
const NsfClass *class
) nonnull(1) NSF_pure;
static bool IsBaseClass(
const NsfObject *object
) nonnull(1) NSF_pure;
static bool IsMetaClass(
Tcl_Interp *interp, NsfClass *class, bool withMixins
) nonnull(1) nonnull(2);
static bool IsSubType(
NsfClass *subClass, const NsfClass *class
) nonnull(1) nonnull(2);
static NsfClass *DefaultSuperClass(
Tcl_Interp *interp, const NsfClass *class, const NsfClass *metaClass, bool isMeta
) nonnull(1) nonnull(2) nonnull(3);
/*
* Prototypes for call stack specific calls
*/
NSF_INLINE static void CscInit_(
NsfCallStackContent *cscPtr,
NsfObject *object,
NsfClass *class,
const Tcl_Command cmd,
unsigned short frameType,
unsigned int flags
) nonnull(1) nonnull(2);
NSF_INLINE static void CscFinish_(Tcl_Interp *interp, NsfCallStackContent *cscPtr)
nonnull(1) nonnull(2);
NSF_INLINE static void CallStackDoDestroy(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void NsfShowStack(Tcl_Interp *interp)
nonnull(1);
/*
* Prototypes for parameter and argument management
*/
static int NsfParameterCacheClassInvalidateCmd(Tcl_Interp *interp, NsfClass *class)
nonnull(1) nonnull(2);
static int ProcessMethodArguments(
ParseContext *pcPtr,
Tcl_Interp *interp,
NsfObject *object,
unsigned int processFlags,
NsfParamDefs *paramDefs,
Tcl_Obj *methodNameObj,
TCL_OBJC_T objc, Tcl_Obj *const objv[]
) nonnull(1) nonnull(2) nonnull(5) nonnull(6) nonnull(8);
static int ParameterCheck(
Tcl_Interp *interp, Tcl_Obj *paramObjPtr, Tcl_Obj *valueObj,
const char *argNamePrefix,
unsigned int doCheckArguments,
bool isNamed,
bool doConfigureParameter,
Nsf_Param **paramPtrPtr,
const char *qualifier
) nonnull(1) nonnull(2) nonnull(3);
static void ParamDefsRefCountIncr(NsfParamDefs *paramDefs)
nonnull(1);
static void ParamDefsRefCountDecr(
NsfParamDefs *paramDefs
) nonnull(1);
static void ParsedParamFree(
NsfParsedParam *parsedParamPtr
) nonnull(1);
NSF_INLINE static NsfParamDefs *ParamDefsGet(
const Tcl_Command cmdPtr,
unsigned int *checkAlwaysFlagPtr,
Tcl_Namespace **execNsPtrPtr
) nonnull(1);
NSF_INLINE static NsfProcContext *ProcContextGet(
const Tcl_Command cmdPtr
) nonnull(1) NSF_pure;
static NsfProcContext *ProcContextRequire(
Tcl_Command cmd
) nonnull(1);
static int ArgumentParse(
Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
NsfObject *object,
Tcl_Obj *procNameObj,
const Nsf_Param *paramPtr,
TCL_OBJC_T nrParams,
int serial,
unsigned int processFlags,
ParseContext *pcPtr
) nonnull(1) nonnull(5) nonnull(6) nonnull(10);
static int ArgumentCheck(
Tcl_Interp *interp, Tcl_Obj *objPtr, const struct Nsf_Param *pPtr,
unsigned int doCheckArguments,
unsigned int *flags, ClientData *clientData, Tcl_Obj **outObjPtr
) nonnull(1) nonnull(2) nonnull(3) nonnull(5) nonnull(6) nonnull(7);
static int GetMatchObject(
Tcl_Interp *interp, Tcl_Obj *patternObj, Tcl_Obj *origObj,
NsfObject **matchObjectPtr, const char **patternPtr
) nonnull(1) nonnull(4) nonnull(5);
static void NsfProcDeleteProc(ClientData clientData)
nonnull(1);
static int NsfParameterCacheObjectInvalidateCmd(
Tcl_Interp *interp, NsfObject *object
) nonnull(1) nonnull(2);
static int GetObjectParameterDefinition(
Tcl_Interp *interp, Tcl_Obj *procNameObj,
NsfObject *object, NsfClass *class,
NsfParsedParam *parsedParamPtr
) nonnull(1) nonnull(2) nonnull(5);
typedef Tcl_Obj *(NsfFormatFunction)(
Tcl_Interp *interp, const Nsf_Param *paramsPtr,
NsfObject *contextObject, const char *pattern
);
static Tcl_Obj *NsfParamDefsVirtualFormat(
Tcl_Interp *interp, const Nsf_Param *pPtr,
NsfObject *contextObject, const char *pattern,
NsfFormatFunction formatFunction
) nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static bool NsfParamDefsAppendVirtual(
Tcl_Interp *interp, Tcl_Obj *listObj,
const Nsf_Param *paramsPtr,
NsfObject *contextObject,
const char *pattern,
NsfFormatFunction formatFunction
) nonnull(1) nonnull(2) nonnull(3) nonnull(6);
/*
* Prototypes for methods.
*/
static const char *MethodName(Tcl_Obj *methodObj)
nonnull(1) returns_nonnull;
/*
* Prototypes for alias management.
*/
static int AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object)
nonnull(1) nonnull(2) nonnull(3);
static Tcl_Obj *AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName,
bool withPer_object, bool leaveError)
nonnull(1) nonnull(2) nonnull(3);
static bool AliasDeleteObjectReference(Tcl_Interp *interp, Tcl_Command cmd)
nonnull(1) nonnull(2);
static int AliasRefetch(Tcl_Interp *interp, NsfObject *object, const char *methodName,
AliasCmdClientData *tcd)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
NSF_INLINE static Tcl_Command AliasDereference(Tcl_Interp *interp, NsfObject *object,
const char *methodName, Tcl_Command cmd)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
/*
* Prototypes for (class) list handling
*/
static NsfClasses ** NsfClassListAdd(NsfClasses **firstPtrPtr, NsfClass *class, ClientData clientData)
nonnull(1) returns_nonnull;
/*
* Misc prototypes
*/
static int SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj, unsigned int flags)
nonnull(1) nonnull(2) nonnull(3);
static int UnsetInstVar(Tcl_Interp *interp, int withNocomplain, NsfObject *object, const char *name)
nonnull(1) nonnull(3) nonnull(4);
static int NextSearchAndInvoke(
Tcl_Interp *interp,
const char *methodName, TCL_OBJC_T objc, Tcl_Obj *const objv[],
NsfCallStackContent *cscPtr, bool freeArgumentVector
) nonnull(1) nonnull(2) nonnull(5);
static void CmdListFree(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct)
nonnull(1);
static void NsfCommandPreserve(Tcl_Command cmd)
nonnull(1);
static void NsfCommandRelease(Tcl_Command cmd)
nonnull(1);
static Tcl_Command GetOriginalCommand(Tcl_Command cmd)
nonnull(1) returns_nonnull;
EXTERN void NsfDStringArgv(Tcl_DString *dsPtr, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(3);
static NsfObjectOpt *NsfRequireObjectOpt(NsfObject *object)
nonnull(1) returns_nonnull;
static int ObjectSystemsCheckSystemMethod(
Tcl_Interp *interp, const char *methodName,
const NsfObject *object, unsigned int flags
) nonnull(1) nonnull(2) nonnull(3);
#ifdef DO_CLEANUP
static void DeleteNsfProcs(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
nonnull(1);
#endif
#if defined(NSF_WITH_ASSERTIONS)
static void AssertionRemoveProc(NsfAssertionStore *aStore, const char *name)
nonnull(1) nonnull(2);
#endif
#ifdef DO_FULL_CLEANUP
static void DeleteProcsAndVars(Tcl_Interp *interp, Tcl_Namespace *nsPtr, bool withKeepvars)
nonnull(1) nonnull(2);
#endif
/*
*----------------------------------------------------------------------
*
* NsfDListInit --
*
* Function similar to Tcl_DStringInit, but works on (void*)
* elements instead of chars.
*
* In general, the NsfDList* operations work on static data as long
* the space is sufficient, and doubles in size afterwards. In the
* worst case, half of the data is unused, but that is the same
* size of overhead like for a single linked list.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
NsfDListInit(NsfDList *dlPtr) {
dlPtr->data = &dlPtr->static_data[0];
dlPtr->avail = nr_elements(dlPtr->static_data);
dlPtr->size = 0u;
}
/*
*----------------------------------------------------------------------
*
* NsfDListAppend --
*
* Function similar to Tcl_DStringAppend, but works on (void*)
* elements instead of chars.
*
* Results:
* None.
*
* Side effects:
* Potentially allocating/reallocating memory.
*
*----------------------------------------------------------------------
*/
static void
NsfDListAppend(NsfDList *dlPtr, void *element) {
if (dlPtr->avail < 1) {
size_t requiredSize = dlPtr->size * 2u;
if (dlPtr->data != &dlPtr->static_data[0]) {
dlPtr->data = (void **)ckrealloc((char *)dlPtr->data, sizeof(dlPtr->data[0]) * requiredSize);
} else {
dlPtr->data = (void **)ckalloc(sizeof(dlPtr->data[0]) * requiredSize);
memcpy(dlPtr->data, &dlPtr->static_data[0], dlPtr->size * sizeof(dlPtr->data[0]));
}
dlPtr->avail = requiredSize - dlPtr->size;
}
dlPtr->avail --;
dlPtr->data[dlPtr->size] = element;
dlPtr->size ++;
}
/*
*----------------------------------------------------------------------
*
* NsfDListFree --
*
* Functions similar to Tcl_DStringFree, but but works on (void*)
* elements instead of chars.
*
* Results:
* None.
*
* Side effects:
* Potentially freeing memory.
*
*----------------------------------------------------------------------
*/
#ifdef DO_CLEANUP
static void
NsfDListFree(NsfDList *dlPtr) {
if (dlPtr->data != &dlPtr->static_data[0]) {
ckfree((char*)dlPtr->data);
}
NsfDListInit(dlPtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* NsfErrorContext --
*
* Print the current errorCode and errorInfo to stderr. This
* should be used as the last resort, when e.g. logging fails
*
* Results:
* None.
*
* Side effects:
* Output to stderr
*
*----------------------------------------------------------------------
*/
static void NsfErrorContext(
Tcl_Interp *interp, const char *context
) nonnull(1) nonnull(2);
static void
NsfErrorContext(
Tcl_Interp *interp, const char *context
) {
Tcl_DString ds, *dsPtr = &ds;
nonnull_assert(interp != NULL);
nonnull_assert(context != NULL);
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, "puts stderr \"Error in ", TCL_INDEX_NONE);
Tcl_DStringAppend(dsPtr, context, TCL_INDEX_NONE);
Tcl_DStringAppend(dsPtr, ":\n$::errorCode $::errorInfo\"", TCL_INDEX_NONE);
Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0);
Tcl_DStringFree(dsPtr);
}
#if 0
static char *
NsfErrorInfo(
Tcl_Interp *interp
) {
Tcl_Obj *valueObj;
nonnull_assert(interp != NULL);
valueObj = Tcl_GetVar2Ex(interp, "::errorInfo", NULL, TCL_GLOBAL_ONLY);
if (valueObj != NULL) {
return ObjStr(valueObj);
}
return NULL;
}
#endif
/*
*----------------------------------------------------------------------
*
* NsfDStringEval --
*
* Evaluate the provided Tcl_DString as a Tcl command and output
* the error stack in case of a failure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Output to stderr possible.
*
*----------------------------------------------------------------------
*/
int
NsfDStringEval(
Tcl_Interp *interp, Tcl_DString *dsPtr, const char *context,
unsigned int traceEvalFlags
) {
Tcl_InterpState state = NULL;
NsfRuntimeState *rst;
int result, prevDoProfile;
unsigned int prevPreventRecursionFlags;
nonnull_assert(interp != NULL);
nonnull_assert(dsPtr != NULL);
nonnull_assert(context != NULL);
rst = RUNTIME_STATE(interp);
if ((traceEvalFlags & NSF_EVAL_PREVENT_RECURSION) != 0u) {
/*
* We do not want to debug the debug statements, since this would
* cause an infinite recursion. Check whether we allow execution of
* the eval call.
*/
if ((rst->preventRecursionFlags & traceEvalFlags) != 0) {
/*
* Recursive case, do NOT execute the cmd and return silently.
*/
return TCL_OK;
}
prevPreventRecursionFlags = rst->preventRecursionFlags;
rst->preventRecursionFlags |= traceEvalFlags;
} else {
prevPreventRecursionFlags = 0u;
}
if ((traceEvalFlags & NSF_EVAL_NOPROFILE) && rst->doProfile == 1) {
/*
* Profiling should be deactivated for the eval.
*/
prevDoProfile = 1;
rst->doProfile = 0;
} else {
prevDoProfile = 0;
}
if ((traceEvalFlags & NSF_EVAL_SAVE) != 0u) {
state = Tcl_SaveInterpState(interp, TCL_OK);
}
result = Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0);
if (unlikely(result == TCL_ERROR)) {
NsfErrorContext(interp, context);
}
if ((traceEvalFlags & NSF_EVAL_SAVE) != 0u) {
Tcl_RestoreInterpState(interp, state);
}
if ((traceEvalFlags & NSF_EVAL_PREVENT_RECURSION) != 0u) {
rst->preventRecursionFlags = prevPreventRecursionFlags;
}
if (prevDoProfile == 1) {
rst->doProfile = 1;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* NsfLog --
*
* Produce a formatted warning by calling an external function
* ::nsf::log. It is defined static to allow for inlining.
*
* Results:
* None.
*
* Side effects:
* Output of the warning.
*
*----------------------------------------------------------------------
*/
void
NsfLog(
Tcl_Interp *interp, int requiredLevel, const char *fmt, ...
) {
nonnull_assert(interp != NULL);
nonnull_assert(fmt != NULL);
if (requiredLevel >= RUNTIME_STATE(interp)->logSeverity) {
int destroyRound = RUNTIME_STATE(interp)->exitHandlerDestroyRound;
Tcl_DString cmdString, ds;
const char *level;
va_list ap;
switch (requiredLevel) {
case NSF_LOG_DEBUG: level = "Debug"; break;
case NSF_LOG_NOTICE: level = "Notice"; break;
default: level = "Warning"; break;
}
Tcl_DStringInit(&ds);
va_start(ap, fmt);
NsfDStringVPrintf(&ds, fmt, ap);
va_end(ap);
Tcl_DStringInit(&cmdString);
Tcl_DStringAppendElement(&cmdString, "::nsf::log");
Tcl_DStringAppendElement(&cmdString, level);
Tcl_DStringAppendElement(&cmdString, Tcl_DStringValue(&ds));
if (destroyRound != NSF_EXITHANDLER_ON_PHYSICAL_DESTROY) {
NsfDStringEval(interp, &cmdString, "log command", (NSF_EVAL_LOG|NSF_EVAL_NOPROFILE));
} else {
/*
* On physical destroy, we can't rely on NsfDStringEval() working
* properly.
*/
fprintf(stderr, "%s", cmdString.string);
}
Tcl_DStringFree(&cmdString);
Tcl_DStringFree(&ds);
}
}
/*
*----------------------------------------------------------------------
*
* NsfDeprecatedCmd --
*
* Provide a warning about a deprecated command or method. The
* message is produced via calling the external Tcl function
* ::nsf::deprecated. In case, profiling is turned on, it is
* deactivated temporarily. Saving the interp result should not be
* an issue, since the command is called before the body of the
* command is executed.
*
* Results:
* None.
*
* Side effects:
* Output of the warning.
*
*----------------------------------------------------------------------
*/
void
NsfDeprecatedCmd(
Tcl_Interp *interp, const char *what, const char *oldCmd, const char *newCmd
) {
Tcl_DString ds, *dsPtr = &ds;
nonnull_assert(interp != NULL);
nonnull_assert(newCmd != NULL);
nonnull_assert(what != NULL);
nonnull_assert(oldCmd != NULL);
Tcl_DStringInit(dsPtr);
Tcl_DStringAppendElement(dsPtr, "::nsf::deprecated");
Tcl_DStringAppendElement(dsPtr, what);
Tcl_DStringAppendElement(dsPtr, oldCmd);
Tcl_DStringAppendElement(dsPtr, newCmd);
NsfDStringEval(interp, dsPtr, "deprecated command", (NSF_EVAL_DEPRECATED|NSF_EVAL_NOPROFILE));
Tcl_DStringFree(dsPtr);
}
/***********************************************************************
* argv parsing
***********************************************************************/
/*
*----------------------------------------------------------------------
*
* ParseContextInit --
*
* Initialize a ParseContext with default values and allocate
* memory if needed. Every ParseContext has to be initialized
* before usage and has to be freed with ParseContextRelease().
*
* Results:
* None.
*
* Side effects:
* Allocate potentially memory.
*
*----------------------------------------------------------------------
*/
static void ParseContextInit(
ParseContext *pcPtr, TCL_OBJC_T objc, NsfObject *object, Tcl_Obj *procName
) nonnull(1) nonnull(4);
static void
ParseContextInit(
ParseContext *pcPtr, TCL_OBJC_T objc, NsfObject *object, Tcl_Obj *procName
) {
nonnull_assert(pcPtr != NULL);
nonnull_assert(procName != NULL);
if (likely(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((int)sizeof(Tcl_Obj *) * ((unsigned)objc+1u));
pcPtr->flags = (unsigned *)ckalloc((unsigned)sizeof(int) * ((unsigned)objc+1u));
MEM_COUNT_ALLOC("pcPtr.objv", pcPtr->full_objv);
pcPtr->clientData = (ClientData *)ckalloc((unsigned)sizeof(ClientData) * (unsigned)objc);
MEM_COUNT_ALLOC("pcPtr.clientData", pcPtr->clientData);
/*fprintf(stderr, "ParseContextMalloc %d objc, %p %p\n", objc, pcPtr->full_objv, pcPtr->clientData);*/
memset(pcPtr->full_objv, 0, sizeof(Tcl_Obj *) * (size_t)(objc+1));
memset(pcPtr->flags, 0, sizeof(int) * (size_t)(objc+1));
memset(pcPtr->clientData, 0, sizeof(ClientData) * (size_t)objc);
pcPtr->status = NSF_PC_STATUS_FREE_OBJV|NSF_PC_STATUS_FREE_CD;
pcPtr->varArgs = NSF_FALSE;
pcPtr->objc = 0;
}
pcPtr->objv = &pcPtr->full_objv[1];
pcPtr->full_objv[0] = procName;
pcPtr->object = object;
}
/*
*----------------------------------------------------------------------
*
* ParseContextExtendObjv --
*
* Extend Tcl_Obj array at run time, when more elements are
* needed. This function is called to extend an already
* initialized ParseContext.
*
* Results:
* None.
*
* Side effects:
* Allocate potentially memory.
*
*----------------------------------------------------------------------
*/
static void ParseContextExtendObjv(
ParseContext *pcPtr, unsigned from, unsigned elts, Tcl_Obj *const source[]
) nonnull(1) nonnull(4);
static void
ParseContextExtendObjv(
ParseContext *pcPtr, unsigned from, unsigned elts, Tcl_Obj *const source[]
) {
unsigned requiredSize = from + elts + 1;
nonnull_assert(pcPtr != NULL);
nonnull_assert(source != NULL);
/*NsfPrintObjv("BEFORE: ", pcPtr->objc, pcPtr->full_objv);*/
if (unlikely(requiredSize >= PARSE_CONTEXT_PREALLOC)) {
if (pcPtr->objv == &pcPtr->objv_static[1]) {
/*
* Realloc from preallocated memory
*/
pcPtr->full_objv = (Tcl_Obj **)ckalloc((int)sizeof(Tcl_Obj *) * requiredSize);
pcPtr->flags = (unsigned *)ckalloc((int)sizeof(int) * requiredSize);
MEM_COUNT_ALLOC("pcPtr.objv", pcPtr->full_objv);
memcpy(pcPtr->full_objv, &pcPtr->objv_static[0], sizeof(Tcl_Obj *) * PARSE_CONTEXT_PREALLOC);
memcpy(pcPtr->flags, &pcPtr->flags_static[0], sizeof(int) * PARSE_CONTEXT_PREALLOC);
/* fprintf(stderr, "ParseContextExtendObjv: extend %p alloc %d new objv=%p pcPtr %p\n",
pcPtr, requiredSize, pcPtr->full_objv, pcPtr);*/
pcPtr->status |= NSF_PC_STATUS_FREE_OBJV;
} else {
/*
* Realloc from mallocated memory
*/
pcPtr->full_objv = (Tcl_Obj **)ckrealloc((char *)pcPtr->full_objv, (unsigned)sizeof(Tcl_Obj *) * requiredSize);
pcPtr->flags = (unsigned *)ckrealloc((char *)pcPtr->flags, (unsigned)sizeof(int) * requiredSize);
/*fprintf(stderr, "ParseContextExtendObjv: extend %p realloc %d new objv=%p pcPtr %p\n",
pcPtr, requiredSize, pcPtr->full_objv, pcPtr);*/
}
pcPtr->objv = &pcPtr->full_objv[1];
}
memcpy(pcPtr->objv + from, source, sizeof(Tcl_Obj *) * (size_t)elts);
memset(pcPtr->flags + from, 0, sizeof(int) * (size_t)elts);
pcPtr->objc = pcPtr->objc + (TCL_OBJC_T)elts;
/*NsfPrintObjv("AFTER: ", pcPtr->objc, pcPtr->full_objv);*/
}
/*
*----------------------------------------------------------------------
*
* ParseContextRelease --
*
* Release (and potentially free) the content of a
* ParseContext. This function is the counterpart of
* ParseContextInit(),
*
* Results:
* None.
*
* Side effects:
* Free potentially memory.
*
*----------------------------------------------------------------------
*/
static void ParseContextRelease(ParseContext *pcPtr)
nonnull(1);
static void
ParseContextRelease(ParseContext *pcPtr) {
unsigned int status;
nonnull_assert(pcPtr != NULL);
status = pcPtr->status;
/*fprintf(stderr, "ParseContextRelease %p status %.6x %d elements\n",
pcPtr, status, pcPtr->objc);*/
#if defined(NSF_DEVELOPMENT_TEST)
{
/*
* Perform a general consistency check: although the contents of the parse
* context are at release time sometimes only partially initialized, the
* following holds true for ensuring correct release of Tcl_Objs:
*
* 1) if one of the objv-flags has NSF_PC_MUST_DECR set,
* then the status flag NSF_PC_STATUS_MUST_DECR has to
* be set as well.
*
* 2) if objc > 0 then for all objv entries having a flag
* different from 0 must have a
* TCL_OBJ in the vector.
*
* 3) for preallocated objvs, all elements of the objv
* after the argument vector must be 0 or
* NSF_PC_IS_DEFAULT (sanity check)
*/
/*
* (1) make sure that the status correctly reflects MUST_DECR.
*/
int i;
if (status == 0u || (status & NSF_PC_STATUS_MUST_DECR) == 0u) {
for (i = 0; i < pcPtr->objc - 1; i++) {
assert((pcPtr->flags[i] & NSF_PC_MUST_DECR) == 0);
}
}
/*
* (2) make sure, Tcl_Objs are set when needed for reclaiming memory.
*/
if (pcPtr->objc > 0) {
/*fprintf(stderr, "%s ", ObjStr(pcPtr->full_objv[0]));*/
for (i = 0; i < pcPtr->objc; i++) {
if (pcPtr->flags[i] != 0u) {
assert(pcPtr->objv[i]);
/*fprintf(stderr, "[%d]%s %.6x ", i, ObjStr(pcPtr->objv[i]), pcPtr->flags[i]);*/
}
}
}
/*
* (3) All later flags must be empty or DEFAULT.
*/
if (pcPtr->full_objv == &pcPtr->objv_static[0] && pcPtr->objc > 0) {
for (i = pcPtr->objc; i < PARSE_CONTEXT_PREALLOC; i++) {
assert(pcPtr->flags[i] == 0u || pcPtr->flags[i] == NSF_PC_IS_DEFAULT);
}
}
}
#endif
if (unlikely(status != 0u)) {
if ((status & NSF_PC_STATUS_MUST_DECR) != 0u) {
TCL_OBJC_T i;
/*fprintf(stderr, "ParseContextRelease %p loop from 0 to %d\n", pcPtr, pcPtr->objc-1);*/
for (i = 0; i < pcPtr->objc; i++) {
/*fprintf(stderr, "ParseContextRelease %p check [%d] obj %p flags %.6x & %p\n",
pcPtr, i, pcPtr->objv[i],
pcPtr->flags[i], &(pcPtr->flags[i]));*/
if ((pcPtr->flags[i] & NSF_PC_MUST_DECR) != 0u) {
assert(pcPtr->objv[i]);
assert(pcPtr->objv[i]->refCount > 0);
/*fprintf(stderr, "... decr ref count on %p\n", pcPtr->objv[i]);*/
DECR_REF_COUNT2("valueObj", pcPtr->objv[i]);
}
}
}
/*
* Objv can be separately extended; also flags are extend when this
* happens.
*/
if (unlikely((status & NSF_PC_STATUS_FREE_OBJV) != 0u)) {
/*fprintf(stderr, "ParseContextRelease %p free %p %p\n",
pcPtr, pcPtr->full_objv, pcPtr->clientData);*/
MEM_COUNT_FREE("pcPtr.objv", pcPtr->full_objv);
ckfree((char *)pcPtr->full_objv);
ckfree((char *)pcPtr->flags);
}
/*
* If the parameter definition was extended at creation time also
* clientData is extended.
*/
if ((status & NSF_PC_STATUS_FREE_CD) != 0u) {
/*fprintf(stderr, "free client-data for %p\n", pcPtr);*/
MEM_COUNT_FREE("pcPtr.clientData", pcPtr->clientData);
ckfree((char *)pcPtr->clientData);
}
}
}
/*
*----------------------------------------------------------------------
*
* CallMethod --
*
* Call a Next Scripting method. The provided "clientData" has to
* contain the object, on which the method is to be dispatched,
* "methodDobj" denotes the method, "objc" (which has to be >=2)
* and "objv" denotes the argument vector.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* potentially via the called method.
*
*----------------------------------------------------------------------
*/
/*
* call a Next Scripting method
*/
static int
CallMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *methodObj,
TCL_OBJC_T objc, Tcl_Obj *const objv[], unsigned int flags)
nonnull(1) nonnull(2) nonnull(3);
static int
CallMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *methodObj,
TCL_OBJC_T objc, Tcl_Obj *const objv[], unsigned int flags) {
NsfObject *object;
int result;
ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(methodObj != NULL);
assert(objc > 1);
object = (NsfObject *) clientData;
tov[0] = object->cmdName;
tov[1] = methodObj;
if (likely(objc > 2)) {
memcpy(tov+2, objv, sizeof(Tcl_Obj *) * ((size_t)objc - 2u));
}
/*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; i < objc-2; i++) {
fprintf(stderr, "%s ", ObjStr(objv[i]));} fprintf(stderr, "\n");}*/
result = ObjectDispatch(clientData, interp, objc, tov, flags);
FREE_ON_STACK(Tcl_Obj*, tov);
return result;
}
/*
*----------------------------------------------------------------------
*
* NsfCallMethodWithArgs --
*
* Call method (passed in methodObj) on the object, with the often
* provided arg1 and the optional remaining args (passed vis objv).
* This way, we save the memcpy in case no argument or a single
* argument are provided (common cases).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Called method might side effect.
*
*----------------------------------------------------------------------
*/
int NsfCallMethodWithArgs(Tcl_Interp *interp, Nsf_Object *object, Tcl_Obj *methodObj,
Tcl_Obj *arg1, TCL_OBJC_T givenObjc, Tcl_Obj *const objv[], unsigned int flags)
nonnull(1) nonnull(2) nonnull(3);
int
NsfCallMethodWithArgs(Tcl_Interp *interp, Nsf_Object *object, Tcl_Obj *methodObj,
Tcl_Obj *arg1, TCL_OBJC_T givenObjc, Tcl_Obj *const objv[], unsigned int flags) {
TCL_OBJC_T objc = givenObjc + 2;
int result;
ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
assert(ISOBJ_(methodObj));
assert(objc > 1);
tov[0] = object->cmdName;
tov[1] = methodObj;
if (objc > 2) {
tov[2] = arg1;
}
if (objc > 3) {
memcpy(tov+3, objv, sizeof(Tcl_Obj *) * ((size_t)objc - 3u));
}
/*fprintf(stderr, "%%%% CallMethodWithArgs cmdName=%s, method=%s, arg1 %s objc=%d\n",
ObjStr(tov[0]), ObjStr(tov[1]), (objc > 2) ? ObjStr(tov[2]) : "", objc);*/
result = ObjectDispatch(object, interp, objc, tov, flags);
FREE_ON_STACK(Tcl_Obj*, tov);
return result;
}
/*
* Support for variable hash tables
*/
static NSF_INLINE Var *VarHashCreateVar(TclVarHashTable *tablePtr, const Tcl_Obj *key, int *newPtr)
nonnull(1) nonnull(2);
static NSF_INLINE Var *
VarHashCreateVar(TclVarHashTable *tablePtr, const Tcl_Obj *key, int *newPtr) {
Var *varPtr;
const Tcl_HashEntry *hPtr;
nonnull_assert(tablePtr != NULL);
nonnull_assert(key != NULL);
hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
(char *) key, newPtr);
if (likely(hPtr != NULL)) {
varPtr = TclVarHashGetValue(hPtr);
} else {
varPtr = NULL;
}
return varPtr;
}
static NSF_INLINE TclVarHashTable *
VarHashTableCreate(void) {
TclVarHashTable *varTablePtr = (TclVarHashTable *) ckalloc((int)sizeof(TclVarHashTable));
TclInitVarHashTable(varTablePtr, NULL);
return varTablePtr;
}
#include "nsfCmdPtr.c"
#include "nsfStack.c"
/***********************************************************************
* Value added replacements of Tcl functions
***********************************************************************/
/*
*----------------------------------------------------------------------
* Nsf_NextHashEntry --
*
* Function very similar to Tcl_NextHashEntry. If during the
* iteration of hash entries some of these entries are removed,
* Tcl_NextHashEntry() can lead to a valid looking but invalid
* hPtr, when the next entry was already deleted. This seem to
* occur only, when there are more than 12 hash entries in the
* table (multiple buckets). Therefore, we use numEntries to check
* whether it is sensible to return a hash entry. We can trigger
* refetch of the hSrchPtr, when the number of expected entries
* differs from the numbers of the actual entries.
*
* Results:
* Hash Entry or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry * Nsf_NextHashEntry(Tcl_HashTable *tablePtr, TCL_SIZE_T expected, Tcl_HashSearch *hSrchPtr)
nonnull(1) nonnull(3);
static Tcl_HashEntry *
Nsf_NextHashEntry(Tcl_HashTable *tablePtr, TCL_SIZE_T expected, Tcl_HashSearch *hSrchPtr) {
Tcl_HashEntry *result;
nonnull_assert(tablePtr != NULL);
nonnull_assert(hSrchPtr != NULL);
/*fprintf(stderr, "Nsf_NextHashEntry %p expected %d numEntries %d\n",
tablePtr, expected, tablePtr->numEntries);*/
if (tablePtr->numEntries < 1) {
result = NULL;
} else if (tablePtr->numEntries != expected) {
result = Tcl_FirstHashEntry(tablePtr, hSrchPtr);
} else {
result = Tcl_NextHashEntry(hSrchPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfCommandPreserve --
*
* Increment Tcl's command refCount
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
NsfCommandPreserve(Tcl_Command cmd) {
nonnull_assert(cmd != NULL);
Tcl_Command_refCount(cmd)++;
MEM_COUNT_ALLOC("command.refCount", cmd);
}
/*
*----------------------------------------------------------------------
* NsfCommandRelease --
*
* Decrement Tcl command refCount and free it if necessary.
*
* Results:
* None.
*
* Side effects:
* Free potentially memory
*
*----------------------------------------------------------------------
*/
static void
NsfCommandRelease(Tcl_Command cmd) {
nonnull_assert(cmd != NULL);
/*fprintf(stderr, "NsfCommandRelease %p\n", cmd);*/
MEM_COUNT_FREE("command.refCount", cmd);
TclCleanupCommandMacro((Command *)cmd);
}
/***********************************************************************
* EXTERN callable routines for the preliminary C interface
***********************************************************************/
Nsf_Object * NsfGetSelfObj(const Tcl_Interp *interp)
nonnull(1) NSF_pure;
Nsf_Object * NsfGetObject(Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2);
Nsf_Class * NsfGetClass(Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2);
Nsf_Class * NsfIsClass(Tcl_Interp *interp, ClientData clientData)
nonnull(1) nonnull(2) NSF_pure;
void NsfRequireObjNamespace(Tcl_Interp *interp, Nsf_Object *object)
nonnull(1) nonnull(2);
Tcl_Obj * Nsf_ObjSetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
Tcl_Obj *valueObj, unsigned int flags)
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
Tcl_Obj * Nsf_ObjGetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, unsigned int flags)
nonnull(1) nonnull(2) nonnull(3);
int NsfCreate(Tcl_Interp *interp, Nsf_Class *class, Tcl_Obj *nameObj, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
int NsfDeleteObject(Tcl_Interp *interp, Nsf_Object *object)
nonnull(1) nonnull(2);
int NsfRemoveObjectMethod(Tcl_Interp *interp, Nsf_Object *object, const char *methodName)
nonnull(1) nonnull(2) nonnull(3);
int NsfRemoveClassMethod(Tcl_Interp *interp, Nsf_Class *class, const char *methodName)
nonnull(1) nonnull(2) nonnull(3);
int Nsf_UnsetVar2(Nsf_Object *object, Tcl_Interp *interp,
const char *name1, const char *name2, unsigned int flags)
nonnull(1) nonnull(2) nonnull(4);
void NsfSetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object, ClientData data)
nonnull(1) nonnull(2);
ClientData NsfGetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object)
nonnull(1) nonnull(2) NSF_pure;
void NsfSetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class, ClientData data)
nonnull(1) nonnull(2);
ClientData NsfGetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class)
nonnull(1) nonnull(2) NSF_pure;
Nsf_Object *
NsfGetSelfObj(const Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
return (Nsf_Object *) GetSelfObj(interp);
}
Nsf_Object *
NsfGetObject(Tcl_Interp *interp, const char *name) {
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
return (Nsf_Object *) GetObjectFromString(interp, name);
}
Nsf_Class *
NsfGetClass(Tcl_Interp *interp, const char *name) {
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
return (Nsf_Class *)GetClassFromString(interp, name);
}
Nsf_Class *
NsfIsClass(Tcl_Interp *UNUSED(interp), ClientData clientData) {
nonnull_assert(clientData != NULL);
if (NsfObjectIsClass((NsfObject *)clientData)) {
return (Nsf_Class *) clientData;
}
return NULL;
}
void
NsfRequireObjNamespace(Tcl_Interp *interp, Nsf_Object *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
RequireObjNamespace(interp, (NsfObject *) object);
}
const char *
NsfMethodName(Tcl_Obj *methodObj) {
nonnull_assert(methodObj != NULL);
return MethodName(methodObj);
}
Tcl_Obj *
Nsf_ObjSetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
Tcl_Obj *valueObj, unsigned int flags) {
Tcl_Obj *result;
CallFrame frame, *framePtr = &frame;
nonnull_assert(object != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(name1 != NULL);
nonnull_assert(valueObj != NULL);
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, (NsfObject *)object, framePtr);
#pragma GCC diagnostic pop
if (((NsfObject *)object)->nsPtr != NULL) {
flags |= TCL_NAMESPACE_ONLY;
}
result = Tcl_ObjSetVar2(interp, name1, name2, valueObj, (int)flags);
Nsf_PopFrameObj(interp, framePtr);
return result;
}
Tcl_Obj *
Nsf_ObjGetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
unsigned int flags) {
Tcl_Obj *result;
CallFrame frame, *framePtr = &frame;
nonnull_assert(object != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(name1 != NULL);
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, (NsfObject *)object, framePtr);
#pragma GCC diagnostic pop
if (((NsfObject *)object)->nsPtr != NULL) {
flags |= TCL_NAMESPACE_ONLY;
}
result = Tcl_ObjGetVar2(interp, name1, name2, (int)flags);
Nsf_PopFrameObj(interp, framePtr);
return result;
}
int
Nsf_UnsetVar2(Nsf_Object *object, Tcl_Interp *interp,
const char *name1, const char *name2, unsigned int flags) {
CallFrame frame, *framePtr = &frame;
NsfObject *o;
int result;
nonnull_assert(object != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(name1 != NULL);
nonnull_assert(name2 != NULL);
o = (NsfObject *) object;
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, o, framePtr);
#pragma GCC diagnostic pop
if (o->nsPtr != NULL) {
flags |= TCL_NAMESPACE_ONLY;
}
result = Tcl_UnsetVar2(interp, name1, name2, (int)flags);
Nsf_PopFrameObj(interp, framePtr);
return result;
}
int
NsfCreate(Tcl_Interp *interp, Nsf_Class *class, Tcl_Obj *nameObj,
TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
NsfClass *cl = (NsfClass *) class;
int result;
ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(objv != NULL);
INCR_REF_COUNT2("nameObj", nameObj);
tov[0] = NULL;
tov[1] = nameObj;
if (objc > 0) {
memcpy(tov+2, objv, sizeof(Tcl_Obj *) * (size_t)objc);
}
result = NsfCCreateMethod(interp, cl, nameObj, objc+2, tov);
FREE_ON_STACK(Tcl_Obj*, tov);
DECR_REF_COUNT2("nameObj", nameObj);
return result;
}
int
NsfDeleteObject(Tcl_Interp *interp, Nsf_Object *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return DispatchDestroyMethod(interp, (NsfObject *)object, 0u);
}
int
NsfRemoveObjectMethod(Tcl_Interp *interp, Nsf_Object *object, const char *methodName) {
NsfObject *currentObject;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
currentObject = (NsfObject *) object;
/*fprintf(stderr, "... NsfRemoveObjectMethod %s %s\n", ObjectName(currentObject), methodName);*/
NsfObjectMethodEpochIncr("NsfRemoveObjectMethod");
AliasDelete(interp, currentObject->cmdName, methodName, NSF_TRUE);
#if defined(NSF_WITH_ASSERTIONS)
if (currentObject->opt != NULL && currentObject->opt->assertions != NULL) {
AssertionRemoveProc(currentObject->opt->assertions, methodName);
}
#endif
if (currentObject->nsPtr != NULL) {
int rc = NSDeleteCmd(interp, currentObject->nsPtr, methodName);
if (rc < 0) {
return NsfPrintError(interp, "%s: cannot delete object specific method '%s'",
ObjectName_(currentObject), methodName);
}
}
return TCL_OK;
}
int
NsfRemoveClassMethod(Tcl_Interp *interp, Nsf_Class *class, const char *methodName) {
const NsfClass *c;
int rc;
#if defined(NSF_WITH_ASSERTIONS)
NsfClassOpt *opt;
#endif
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(methodName != NULL);
c = (NsfClass *)class;
/*fprintf(stderr, "... NsfRemoveClassMethod %s %s\n", ClassName(class), methodName);*/
NsfInstanceMethodEpochIncr("NsfRemoveClassMethod");
AliasDelete(interp, class->object.cmdName, methodName, NSF_FALSE);
#if defined(NSF_WITH_ASSERTIONS)
opt = c->opt;
if (opt != NULL && opt->assertions != NULL) {
AssertionRemoveProc(opt->assertions, methodName);
}
#endif
rc = NSDeleteCmd(interp, c->nsPtr, methodName);
if (rc < 0) {
return NsfPrintError(interp, "%s: cannot delete method '%s'", ClassName_(c), methodName);
}
return TCL_OK;
}
/*
* obj/cl ClientData setter/getter
*/
void
NsfSetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object, ClientData data) {
nonnull_assert(object != NULL);
nonnull_assert(data != NULL);
NsfRequireObjectOpt((NsfObject *) object) -> clientData = data;
}
ClientData
NsfGetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object) {
NsfObject *object_;
nonnull_assert(object != NULL);
object_ = (NsfObject *) object;
return (object_->opt != NULL) ? object_->opt->clientData : NULL;
}
void
NsfSetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class, ClientData data) {
nonnull_assert(class != NULL);
NsfRequireClassOpt((NsfClass *)class) -> clientData = data;
}
ClientData
NsfGetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class) {
NsfClass *c;
c = (NsfClass *) class;
return (c->opt != NULL) ? c->opt->clientData : NULL;
}
/***********************************************************************
* Utility functions
***********************************************************************/
#if defined(NSFOBJ_TRACE)
void ObjTrace(const char *string, NsfObject *object)
nonnull(1) nonnull(2);
void
ObjTrace(const char *string, NsfObject *object) {
nonnull_assert(string != NULL);
nonnull_assert(object != NULL);
fprintf(stderr, "--- %s Tcl %p %s (%d %p) nsf %p (%d) %s \n", string,
(void *)object->cmdName, ObjTypeStr(object->cmdName),
object->cmdName->refCount, object->cmdName->internalRep.twoPtrValue.ptr1,
(void *)object, object->refCount, ObjectName(object));
}
#else
# define ObjTrace(a, b)
#endif
/*
*----------------------------------------------------------------------
* NSTail --
*
* Return the namespace tail of a name.
*
* Results:
* String.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char * NSTail(const char *string)
nonnull(1) NSF_pure;
static const char *
NSTail(const char *string) {
register const char *p;
nonnull_assert(string != NULL);
p = string + strlen(string);
while (p > string) {
if (unlikely(*p == ':' && *(p-1) == ':')) {
return p+1;
}
p--;
}
return string;
}
/*
*----------------------------------------------------------------------
* IsClassNsName --
*
* Check whether the provided string starts with the prefix of the
* classes namespace.
*
* Results:
* A Boolean value..
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static bool IsClassNsName(const char *string, const char **cont)
nonnull(1);
NSF_INLINE static bool
IsClassNsName(const char *string, const char **cont) {
nonnull_assert(string != NULL);
if (*string == ':' && strncmp(string, nsfClassesPrefix, nsfClassesPrefixLength) == 0) {
if (cont != NULL) {
*cont = string + nsfClassesPrefixLength;
}
return NSF_TRUE;
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* GetObjectFromNsName --
*
* Get object or class from a fully qualified cmd name, such as
* e.g. ::nsf::classes::X
*
* Results:
* NsfObject and *fromClasses
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static NsfObject * GetObjectFromNsName(Tcl_Interp *interp, const char *string, bool *fromClassNS)
nonnull(1) nonnull(2) nonnull(3);
NSF_INLINE static NsfObject *
GetObjectFromNsName(Tcl_Interp *interp, const char *string, bool *fromClassNS) {
const char *className;
nonnull_assert(interp != NULL);
nonnull_assert(string != NULL);
nonnull_assert(fromClassNS != NULL);
if (IsClassNsName(string, &className)) {
*fromClassNS = NSF_TRUE;
return (NsfObject *)GetClassFromString(interp, className);
} else {
*fromClassNS = NSF_FALSE;
return GetObjectFromString(interp, string);
}
}
/*
*----------------------------------------------------------------------
* DStringAppendQualName --
*
* Append to initialized DString the name of the namespace followed
* by a simple name (methodName, cmdName).
*
* Results:
* String pointing to DString value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *DStringAppendQualName(Tcl_DString *dsPtr, const Tcl_Namespace *nsPtr, const char *name)
nonnull(1) nonnull(2) nonnull(3);
static char *
DStringAppendQualName(Tcl_DString *dsPtr, const Tcl_Namespace *nsPtr, const char *name) {
TCL_SIZE_T oldLength;
nonnull_assert(dsPtr != NULL);
nonnull_assert(nsPtr != NULL);
nonnull_assert(name != NULL);
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringAppend(dsPtr, nsPtr->fullName, TCL_INDEX_NONE);
if (Tcl_DStringLength(dsPtr) > (oldLength + 2)) {
Tcl_DStringAppend(dsPtr, "::", 2);
}
Tcl_DStringAppend(dsPtr, name, TCL_INDEX_NONE);
return Tcl_DStringValue(dsPtr);
}
/*
*----------------------------------------------------------------------
* NsfCleanupObject --
*
* Delete an object physically (performing ckfree()) when its refCount
* reaches 0
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
void
NsfCleanupObject_(NsfObject *object) {
nonnull_assert(object != NULL);
NsfObjectRefCountDecr(object);
/*fprintf(stderr, "NsfCleanupObject obj refCount of %p after decr %d id %p interp %p flags %.6x\n",
object, object->refCount, object->id, object->teardown, object->flags);*/
if (unlikely(object->refCount <= 0)) {
/*fprintf(stderr, "NsfCleanupObject %p ref-count %d\n", object, object->refCount);*/
assert(object->refCount == 0);
assert((object->flags & NSF_DELETED) != 0u);
/*
* During FinalObjectDeletion(), object->teardown is NULL, we cannot access
* the object and class names anymore.
*/
if (object->teardown && NSF_DTRACE_OBJECT_FREE_ENABLED()) {
NSF_DTRACE_OBJECT_FREE(ObjectName(object), ClassName(object->cl));
}
MEM_COUNT_FREE("NsfObject/NsfClass", object);
#if defined(NSFOBJ_TRACE)
fprintf(stderr, "CKFREE Object %p refCount=%d\n", (void *)object, object->refCount);
#endif
#if !defined(NDEBUG)
memset(object, 0, sizeof(NsfObject));
#endif
ckfree((char *) object);
}
}
/*
* Tcl_Obj functions for objects
*/
/*
*----------------------------------------------------------------------
* TclObjIsNsfObject --
*
* Check whether the provided Tcl_Obj is bound to an NSF object. If
* so, return the NsfObject in the third argument.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool TclObjIsNsfObject(
Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr
) nonnull(1) nonnull(2) nonnull(3);
static bool
TclObjIsNsfObject(Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr) {
Tcl_ObjType CONST86 *cmdType;
bool result = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(objectPtr != NULL);
cmdType = objPtr->typePtr;
if (cmdType == Nsf_OT_tclCmdNameType) {
const Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr);
if (likely(cmd != NULL)) {
NsfObject *object = NsfGetObjectFromCmdPtr(cmd);
if (object != NULL) {
*objectPtr = object;
result = NSF_TRUE;
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
* GetObjectFromObj --
*
* Lookup a Next Scripting object from the given objPtr, preferably
* from an object of type "cmdName". On success the NsfObject is
* returned in the third argument. The objPtr might be converted by
* this function.
*
* Results:
* True or false,
*
* Side effects:
* object type of objPtr might be changed
*
*----------------------------------------------------------------------
*/
static int GetObjectFromObj(
Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr
) nonnull(1) nonnull(2) nonnull(3);
static int
GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr) {
NsfObject *object;
const char *string;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(objectPtr != NULL);
/*fprintf(stderr, "GetObjectFromObj obj %p %s is of type %s\n",
objPtr, ObjStr(objPtr), ObjTypeStr(objPtr));*/
/*
* Use the standard Tcl_GetCommandFromObj() which might convert the objPtr
* to type cmdName.
*/
cmd = Tcl_GetCommandFromObj(interp, objPtr);
/*fprintf(stderr, "GetObjectFromObj obj %p %s (type %p) => cmd=%p (refCount %ld)\n",
(void*)objPtr, ObjStr(objPtr), (void*)objPtr->typePtr,
(void*)cmd, (cmd != NULL) ? Tcl_Command_refCount(cmd) : TCL_INDEX_NONE);*/
if (cmd != NULL) {
NsfObject *cmdObject;
/*
* Tcl returned us a command. At least in Tcl 8.7, we cannot trust that
* the returned cmd is still valid. Unfortunately, we can't check more
* details here, since "struct ResolvedCmdName" is defined locally in
* generic/tclObj.c. For cmd epochs>0 we take the conservative approach
* not to trust in internal representation and fetch the cmd new.
*/
cmdObject = NsfGetObjectFromCmdPtr(cmd);
/*fprintf(stderr, "GetObjectFromObj obj %s, cmdObject %p objProc %p NsfObjDispatch %p\n",
ObjStr(objPtr), (void*)cmdObject, (void*)TCL_COMMAND_OBJPROC(cmd), (void*)NsfObjDispatch); */
if (likely(cmdObject != NULL)) {
*objectPtr = cmdObject;
return TCL_OK;
}
}
/*fprintf(stderr, "GetObjectFromObj convertFromAny for %s type %p %s\n",
ObjStr(objPtr), (void*)objPtr->typePtr, ObjTypeStr(objPtr));*/
/*
* 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)) {
object = NULL;
} else {
Tcl_Obj *tmpName = NameInNamespaceObj(string, CallingNameSpace(interp));
const char *nsString = ObjStr(tmpName);
INCR_REF_COUNT(tmpName);
object = GetObjectFromString(interp, nsString);
/*fprintf(stderr, " RETRY, string '%s' returned %p\n", nsString, (void*)object);*/
DECR_REF_COUNT(tmpName);
}
if (likely(object != NULL)) {
*objectPtr = object;
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
* NsfCallObjectUnknownHandler --
*
* Call ::nsf::object::unknown; this function is typically called,
* when an unknown object or class is passed as an argument.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Called handler might side effect.
*
*----------------------------------------------------------------------
*/
static int NsfCallObjectUnknownHandler(
Tcl_Interp *interp, Tcl_Obj *nameObj
) nonnull(1) nonnull(2);
static int
NsfCallObjectUnknownHandler(Tcl_Interp *interp, Tcl_Obj *nameObj) {
int result;
Tcl_Obj *ov[3];
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
/*fprintf(stderr, "try ::nsf::object::unknown for '%s'\n", ObjStr(nameObj));*/
ov[0] = NsfGlobalObjs[NSF_OBJECT_UNKNOWN_HANDLER];
ov[1] = nameObj;
INCR_REF_COUNT(ov[1]);
result = Tcl_EvalObjv(interp, 2, ov, 0);
DECR_REF_COUNT(ov[1]);
return result;
}
#if defined(NSF_EXPERIMENTAL)
static int NsfCallArgumentUnknownHandler(
Tcl_Interp *interp,
Tcl_Obj *methodObj,
Tcl_Obj *argumentObj,
NsfObject *object
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
NsfCallArgumentUnknownHandler(
Tcl_Interp *interp,
Tcl_Obj *methodObj,
Tcl_Obj *argumentObj,
NsfObject *object
) {
Tcl_Obj *ov[4];
int result;
TCL_OBJC_T oc = 3;
nonnull_assert(interp != NULL);
nonnull_assert(methodObj != NULL);
nonnull_assert(argumentObj != NULL);
nonnull_assert(object != NULL);
/*fprintf(stderr, "try ::nsf::argument::unknown for '%s'\n", ObjStr(nameObj));*/
ov[0] = NsfGlobalObjs[NSF_ARGUMENT_UNKNOWN_HANDLER];
ov[1] = methodObj;
ov[2] = argumentObj;
if (object != NULL) {
ov[3] = object->cmdName;
oc ++;
}
INCR_REF_COUNT(ov[1]);
result = Tcl_EvalObjv(interp, oc, ov, 0);
DECR_REF_COUNT(ov[1]);
return result;
}
#endif
/*
*----------------------------------------------------------------------
* GetClassFromObj --
*
* Lookup a Next Scripting class from the given objPtr. If the
* class could not be directly converted and withUnknown is true,
* the function calls the unknown function (::nsf::object::unknown)
* to fetch the class on demand and retries the conversion. On
* success the NsfClass is returned in the third argument. The
* objPtr might be converted by this function.
*
* Results:
* True or false,
*
* Side effects:
* object type of objPtr might be changed
*
*----------------------------------------------------------------------
*/
static int
GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr,
NsfClass **classPtr, bool withUnknown) {
NsfObject *object;
NsfClass *class;
const char *objName;
Tcl_Command cmd;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(classPtr != NULL);
objName = ObjStr(objPtr);
cmd = Tcl_GetCommandFromObj(interp, objPtr);
/*fprintf(stderr, "GetClassFromObj %p %s unknown %d cmd %p\n", objPtr, objName, withUnknown, cmd);*/
if (likely(cmd != NULL)) {
class = NsfGetClassFromCmdPtr(cmd);
if (class == NULL) {
/*
* We have a cmd, but no class; namespace-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, *qualifiedObjName;
Tcl_Obj *nameObj = objPtr;
Tcl_Obj **alias_ov;
TCL_OBJC_T alias_oc = 0;
if (!isAbsolutePath(objName)) {
nameObj = NameInNamespaceObj(objName, CallingNameSpace(interp));
qualifiedObjName = ObjStr(nameObj);
INCR_REF_COUNT(nameObj);
} else {
qualifiedObjName = objName;
}
result = Tcl_GetAliasObj(interp, qualifiedObjName,
&alias_interp, &alias_cmd_name, &alias_oc, &alias_ov);
Tcl_ResetResult(interp);
/*
* We only want interp-aliases with 0 args
*/
if (likely(result == TCL_OK) && likely(alias_oc == 0)) {
cmd = NSFindCommand(interp, alias_cmd_name);
/*fprintf(stderr, "..... alias arg 0 '%s' cmd %p\n", alias_cmd_name, cmd);*/
if (cmd != NULL) {
class = NsfGetClassFromCmdPtr(cmd);
}
}
/*fprintf(stderr, "..... final cmd %p, class %p\n", cmd , class);*/
if (nameObj != objPtr) {
DECR_REF_COUNT(nameObj);
}
}
if (likely(class != NULL)) {
*classPtr = class;
return TCL_OK;
}
}
result = GetObjectFromObj(interp, objPtr, &object);
if (likely(result == TCL_OK)) {
class = NsfObjectToClass(object);
if (likely(class != NULL)) {
*classPtr = class;
return TCL_OK;
} else {
/*
* Flag, that we could not convert so far.
*/
result = TCL_ERROR;
}
}
if (withUnknown) {
/*fprintf(stderr, "**** withUnknown 1 obj %s is shared %d\n", ObjStr(objPtr), Tcl_IsShared(objPtr));*/
INCR_REF_COUNT(objPtr);
result = NsfCallObjectUnknownHandler(interp, isAbsolutePath(objName) ? objPtr :
NameInNamespaceObj(objName, CallingNameSpace(interp)));
if (likely(result == TCL_OK)) {
/*
* Retry, but now, the last argument (withUnknown) has to be FALSE
*/
result = GetClassFromObj(interp, objPtr, classPtr, NSF_FALSE);
}
DECR_REF_COUNT(objPtr);
/*fprintf(stderr, "... ::nsf::object::unknown for '%s',
result %d cl %p\n", objName, result, cl);*/
}
return result;
}
/*
* Version of GetClassFromObj() with external symbol
*/
int
NsfGetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
NsfClass **classPtr, bool withUnknown) {
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(classPtr != NULL);
return GetClassFromObj(interp, objPtr, classPtr, withUnknown);
}
/*
*----------------------------------------------------------------------
* IsObjectOfType --
*
* Check whether the provided NsfObject is of a certain type. The
* arguments "what" and "objPtr" are just used for the error
* messages. "objPtr" is the value from which the object was
* converted from.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int IsObjectOfType(
Tcl_Interp *interp, NsfObject *object, const char *what, Tcl_Obj *objPtr,
const Nsf_Param *pPtr
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
static int
IsObjectOfType(
Tcl_Interp *interp, NsfObject *object, const char *what, Tcl_Obj *objPtr,
const Nsf_Param *pPtr
) {
NsfClass *class;
int result = TCL_ERROR;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(what != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
if (unlikely((pPtr->flags & NSF_ARG_BASECLASS) != 0u)
&& !IsBaseClass(object)
) {
what = "baseclass";
} else if (unlikely((pPtr->flags & NSF_ARG_METACLASS) != 0u)
&& !IsMetaClass(interp, (NsfClass *)object, NSF_TRUE)
) {
what = "metaclass";
} else if (likely(pPtr->converterArg == NULL)) {
result = TCL_OK;
} else if (likely((GetClassFromObj(interp, pPtr->converterArg, &class, NSF_FALSE) == TCL_OK))
&& IsSubType(object->cl, class)
) {
result = TCL_OK;
}
if (result == TCL_ERROR) {
Tcl_DString ds, *dsPtr = &ds;
DSTRING_INIT(dsPtr);
Tcl_DStringAppend(dsPtr, what, TCL_INDEX_NONE);
if (pPtr->converterArg != NULL) {
Tcl_DStringAppend(dsPtr, " of type ", 9);
Tcl_DStringAppend(dsPtr, ObjStr(pPtr->converterArg), TCL_INDEX_NONE);
}
NsfObjErrType(interp, NULL, objPtr, Tcl_DStringValue(dsPtr), (Nsf_Param *)pPtr);
DSTRING_FREE(dsPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* NameInNamespaceObj --
*
* Create a fully qualified name in the provided namespace or in
* the current namespace in form of a Tcl_Obj (with 0 refCount);
*
* Results:
* Tcl_Obj containing fully qualified name
*
* Side effects:
* Allocates fresh copies of list elements
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
NameInNamespaceObj(const char *name, Tcl_Namespace *nsPtr) {
Tcl_Obj *objPtr;
Tcl_DString ds, *dsPtr = &ds;
nonnull_assert(name != NULL);
nonnull_assert(nsPtr != NULL);
/*fprintf(stderr, "NameInNamespaceObj %s (%p, %s) ", name, nsPtr, nsPtr->fullName);*/
DSTRING_INIT(dsPtr);
DStringAppendQualName(dsPtr, nsPtr, name);
objPtr = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
/*fprintf(stderr, "returns %s\n", ObjStr(objPtr));*/
DSTRING_FREE(dsPtr);
return objPtr;
}
/*
*----------------------------------------------------------------------
* NewTclCommand --
*
* Given a provided prefix in dsPtr, make it a name of a command
* that does not exist. This function is used by the *new command,
* when "anonymous" objects are created
*
* Results:
* dsPtr will be complete to represent a new (unused) name of a command.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void NewTclCommand(Tcl_Interp *interp, Tcl_DString *dsPtr)
nonnull(1) nonnull(2);
void
NewTclCommand(Tcl_Interp *interp, Tcl_DString *dsPtr) {
TCL_SIZE_T prefixLength;
NsfStringIncrStruct *iss;
nonnull_assert(interp != NULL);
nonnull_assert(dsPtr != NULL);
prefixLength = dsPtr->length;
iss = &RUNTIME_STATE(interp)->iss;
while (1) {
(void)NsfStringIncr(iss);
Tcl_DStringAppend(dsPtr, iss->start, (TCL_SIZE_T)iss->length);
if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, TCL_GLOBAL_ONLY)) {
break;
}
/*
* In case the symbol existed already, reset prefix to the
* original length.
*/
Tcl_DStringSetLength(dsPtr, prefixLength);
}
}
/*
*----------------------------------------------------------------------
* NsfReverseClasses --
*
* Reverse class list. Caller is responsible for freeing data.
*
* Results:
* Pointer to start of the reversed list
*
* Side effects:
* Allocates fresh copies of list elements
*
*----------------------------------------------------------------------
*/
static NsfClasses *NsfReverseClasses(NsfClasses *sl)
nonnull(1) returns_nonnull;
static NsfClasses *
NsfReverseClasses(NsfClasses *sl) {
NsfClasses *firstPtr = NULL;
nonnull_assert(sl != NULL);
do {
NsfClasses *element = NEW(NsfClasses);
element->cl = sl->cl;
element->clientData = sl->clientData;
element->nextPtr = firstPtr;
firstPtr = element;
sl = sl->nextPtr;
} while (likely(sl != NULL));
return firstPtr;
}
/*
*----------------------------------------------------------------------
* NsfClassListFree --
*
* Frees all elements of the provided class list.
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
static void NsfClassListFree(NsfClasses *classList)
nonnull(1);
static void
NsfClassListFree(NsfClasses *classList) {
NsfClasses *nextPtr;
nonnull_assert(classList != NULL);
do {
nextPtr = classList->nextPtr;
FREE(NsfClasses, classList);
classList = nextPtr;
} while (likely(classList != NULL));
}
/*
*----------------------------------------------------------------------
* NsfClassListAdd --
*
* Add class list entry to the specified list. In case the initial
* list is empty, *firstPtrPtr is updated as well.
*
* Results:
* Returns address of next-pointer.
*
* Side effects:
* New list element is allocated.
*
*----------------------------------------------------------------------
*/
static NsfClasses **
NsfClassListAdd(NsfClasses **firstPtrPtr, NsfClass *class, ClientData clientData) {
NsfClasses *classListPtr, *element = NEW(NsfClasses);
nonnull_assert(firstPtrPtr != NULL);
element->cl = class;
element->clientData = clientData;
element->nextPtr = NULL;
classListPtr = *firstPtrPtr;
if (classListPtr != NULL) {
while (classListPtr->nextPtr != NULL) {
classListPtr = classListPtr->nextPtr;
}
classListPtr->nextPtr = element;
} else {
*firstPtrPtr = element;
}
return &(element->nextPtr);
}
/*
*----------------------------------------------------------------------
* NsfClassListAddNoDup --
*
* Add class list entry to the specified list without
* duplicates. In case the initial list is empty, *firstPtrPtr is
* updated as well.
*
* Results:
* Returns address of next pointer.
*
* Side effects:
* New list element is allocated.
*
*----------------------------------------------------------------------
*/
static NsfClasses **NsfClassListAddNoDup(NsfClasses **firstPtrPtr, NsfClass *class,
ClientData clientData)
nonnull(1) nonnull(2);
static NsfClasses **
NsfClassListAddNoDup(NsfClasses **firstPtrPtr, NsfClass *class, ClientData clientData) {
NsfClasses *clPtr, **nextPtr;
nonnull_assert(firstPtrPtr != NULL);
nonnull_assert(class != NULL);
clPtr = *firstPtrPtr;
if (clPtr != NULL) {
while ((clPtr->nextPtr != NULL) && (clPtr->cl != class)) {
clPtr = clPtr->nextPtr;
}
nextPtr = &clPtr->nextPtr;
} else {
nextPtr = firstPtrPtr;
}
if (*nextPtr == NULL) {
NsfClasses *element = NEW(NsfClasses);
element->cl = class;
element->clientData = clientData;
element->nextPtr = NULL;
*nextPtr = element;
}
return nextPtr;
}
/*
*----------------------------------------------------------------------
* NsfClassListFind --
*
* Find an element in the class list and return it if found.
*
* Results:
* Found element or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClasses *NsfClassListFind(NsfClasses *clPtr, const NsfClass *class)
nonnull(2) NSF_pure;
static NsfClasses *
NsfClassListFind(NsfClasses *clPtr, const NsfClass *class) {
nonnull_assert(class != NULL);
for (; clPtr != NULL; clPtr = clPtr->nextPtr) {
if (clPtr->cl == class) {
break;
}
}
return clPtr;
}
#if defined(NSF_CLASSLIST_PRINT)
/* debugging purposes only */
/*
*----------------------------------------------------------------------
* NsfClassListStats --
*
* Print some statistics about generated Class List structures for
* debugging purpose.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void NsfClassListStats(const char *title, NsfClasses *classList)
nonnull(1);
static void
NsfClassListStats(const char *title, NsfClasses *classListPtr) {
NsfClass *class;
int count = 0;
nonnull_assert(title != NULL);
class = (classListPtr != NULL) ? classListPtr->cl : NULL;
for (; classListPtr != NULL; classListPtr = classListPtr->nextPtr) {
count++;
}
fprintf(stderr, "%s class list starting with %s has %d elements\n",
title, (class != NULL) ? ClassName(class) : "none", count);
}
static void NsfClassListPrint(const char *title, const NsfClasses *clsList)
nonnull(1);
static void
NsfClassListPrint(const char *title, const NsfClasses *clsList) {
nonnull_assert(title != NULL);
fprintf(stderr, "%s", title);
/* fprintf(stderr, " %p:", clsList); */
while (clsList != NULL) {
/* fprintf(stderr, " %p", clsList->cl); */
fprintf(stderr, " %p", (void *)clsList);
fprintf(stderr, " %s", ClassName(clsList->cl));
clsList = clsList->nextPtr;
}
fprintf(stderr, "\n");
}
#endif
/*
*----------------------------------------------------------------------
* NsfClassListUnlink --
*
* Return removed item with matching key form nsfClasses.
* Key is void to allow not only class pointers as keys.
*
* Results:
* unlinked element or NULL.
* In case the first element is unlinked, *firstPtrPtr
* is updated.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClasses *NsfClassListUnlink(NsfClasses **firstPtrPtr, const void *key)
nonnull(1) nonnull(2);
static NsfClasses *
NsfClassListUnlink(NsfClasses **firstPtrPtr, const void *key) {
NsfClasses *entryPtr;
nonnull_assert(firstPtrPtr != NULL);
nonnull_assert(key != NULL);
if (*firstPtrPtr != NULL) {
NsfClasses *prevPtr = NULL;
/*
* List is nonempty.
*/
for (entryPtr = *firstPtrPtr;
entryPtr != NULL;
prevPtr = entryPtr, entryPtr = entryPtr->nextPtr
) {
if ((void *)entryPtr->cl == key) {
/*
* Found entry.
*/
if (prevPtr != NULL) {
/*
* Later item.
*/
prevPtr->nextPtr = entryPtr->nextPtr;
} else {
/*
* First item.
*/
*firstPtrPtr = entryPtr->nextPtr;
}
entryPtr->nextPtr = NULL;
break;
}
}
} else {
entryPtr = NULL;
}
return entryPtr;
}
/*
* Functions for computing Precedence Order
*/
/*
*----------------------------------------------------------------------
* TopoSortSub --
*
* Performs a topological sort of the subclass hierarchy of a given
* class. The resulting list contains no duplicates or cycles and
* is returned in the class member "order". During computation, it
* colors the processed nodes in WHITE, GRAY or BLACK.
*
* Results:
* Boolean values indicating whether a cycle was detected
* (NSF_FALSE) or not (NSF_TRUE); and, therefore, whether the sort
* failed (NSF_FALSE) or succeeded (NSF_TRUE).
*
* Side effects:
* Allocates class list.
*
*----------------------------------------------------------------------
*/
enum colors { WHITE, GRAY, BLACK };
static bool TopoSortSub(NsfClass *class, NsfClass *baseClass, bool withMixinOfs)
nonnull(1) nonnull(2);
static bool
TopoSortSub(NsfClass *class, NsfClass *baseClass, bool withMixinOfs) {
NsfClasses *sl, *pl;
bool isAcyclic = NSF_TRUE;
nonnull_assert(class != NULL);
nonnull_assert(baseClass != NULL);
sl = class->sub;
/*
* Be 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. Meaning of colors:
*
* WHITE ... not processed
* GRAY ... in work
* BLACK ... done
*/
class->color = GRAY;
for (; sl != NULL; sl = sl->nextPtr) {
NsfClass *sc = sl->cl;
if (sc->color == GRAY ||
unlikely(sc->color == WHITE
&& !TopoSortSub(sc, baseClass, withMixinOfs))
) {
isAcyclic = NSF_FALSE;
break;
}
}
if (isAcyclic && withMixinOfs) {
NsfCmdList *classMixins = ((class->opt != NULL) ? class->opt->isClassMixinOf : NULL);
for (; classMixins != NULL; classMixins = classMixins->nextPtr) {
NsfClass *sc = NsfGetClassFromCmdPtr(classMixins->cmdPtr);
if (likely(sc != NULL)
&& unlikely(sc->color == WHITE &&
!TopoSortSub(sc, baseClass, withMixinOfs))) {
NsfLog(sc->object.teardown, NSF_LOG_WARN,
"cycle in the mixin graph list detected for class %s",
ClassName_(sc));
}
}
}
class->color = BLACK;
pl = NEW(NsfClasses);
pl->cl = class;
pl->nextPtr = baseClass->order;
baseClass->order = pl;
if (unlikely(class == baseClass)) {
register const NsfClasses *pc;
for (pc = class->order; pc != NULL; pc = pc->nextPtr) {
pc->cl->color = WHITE;
}
assert(isAcyclic && baseClass->order != NULL);
}
return isAcyclic;
}
/*
*----------------------------------------------------------------------
* MustBeBefore --
*
* Check the partial ordering of classes based on precedence list
* in the form of prior ordering from the topological sort. We
* compare here orderings based the class hierarchies with single
* inheritance and prior solved multiple inheritance orderings. The
* test is true, if b must be before a.
*
* Results:
* Boolean value indicating success.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool MustBeBefore(const NsfClass *aClass, const NsfClass *bClass, const NsfClasses *superClasses)
nonnull(1) nonnull(2) nonnull(3) NSF_pure;
static bool
MustBeBefore(const NsfClass *aClass, const NsfClass *bClass, const NsfClasses *superClasses) {
bool success;
nonnull_assert(aClass != NULL);
nonnull_assert(bClass != NULL);
nonnull_assert(superClasses != NULL);
assert(bClass->order != NULL);
/*
* Check whether "x" is in the precedence order of "y". E.g.
*
* x c1 object
* y c2 x object
*
* If so then "y" must be before "x" to preserve the precedence order based on
* single inheritance (monotonicity).
*/
success = (NsfClassListFind(bClass->order, aClass) != NULL);
/*
* When the partital ordering can't be decided based on the local order
* test, we take the specified multiple inheritance ordering in superClasses
* (e.g. coming from -superclass {x y}) which is not taken account by the
* class hierarchy.
*/
if (!success) {
const NsfClasses *sl;
bool found = NSF_FALSE;
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "--> check %s before %s?\n", ClassName(bClass), ClassName(aClass));
NsfClassListPrint("superClasses", superClasses);
#endif
for (sl = superClasses; sl != NULL; sl = sl->nextPtr) {
if (sl->cl == bClass) {
found = NSF_TRUE;
} else if (found && sl->cl == aClass) {
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "%s in inheritanceList before %s therefore a < b\n",
ClassName(bClass), ClassName(aClass));
#endif
success = NSF_TRUE;
break;
}
}
}
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "compare a: %s %p b: %s %p -> %d\n",
ClassName(aClass), (void *)aClass->order,
ClassName(bClass), (void *)bClass->order, (int)success);
NsfClassListPrint("\ta", aClass->order);
NsfClassListPrint("\tb", bClass->order);
#endif
return success;
}
/*
*----------------------------------------------------------------------
* ValidClassListTail --
*
* Debug function to assure that the provided class lists are
* valid. The tail of the class list must be a base class of the
* current object system.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#if defined(NSF_DEVELOPMENT_TEST)
static void
ValidClassListTail(const char *what, NsfClasses *classListPtr) {
NsfClasses *sl, *tail;
for (sl = classListPtr, tail = NULL; sl != NULL; sl = sl->nextPtr) {
tail = sl;
}
if (tail != NULL) {
/* fprintf(stderr, "check tail what %s %p\n", what, ClassName(tail->cl), tail->nextPtr);*/
assert(IsBaseClass(&tail->cl->object));
assert(tail->nextPtr == NULL);
}
}
#else
# define ValidClassListTail(what, classListPtr)
#endif
/*
*----------------------------------------------------------------------
* MergeInheritanceLists --
*
* Merge the PrecedenceOrders of class cl. This function is called,
* when cl is defined with multiple inheritance. The precedence
* orders of the specified classes are merged in an order
* preserving manner to achieve monotonicity.
*
* Results:
* precedence order.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClasses *MergeInheritanceLists(NsfClasses *pl, NsfClass *class)
nonnull(1) nonnull(2) returns_nonnull;
static NsfClasses *
MergeInheritanceLists(NsfClasses *pl, NsfClass *class) {
NsfClasses *sl, *baseList, **plNext, *superClasses,
*deletionList = NULL;
nonnull_assert(pl != NULL);
nonnull_assert(class != NULL);
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "=== MergeInheritanceLists working on %s\n", ClassName(class));
#endif
/*
* The available multiple inheritance list is in reversed order so we have
* to reverse it to obtain the specified superClasses in the provided order.
*/
superClasses = NsfReverseClasses(class->super);
/*
* We distinguish between a
*
* - baseList (which might be later a result of partial merges), and a
* - mergeList, which is merged order-preserving into the baseList.
*
* The first baseList is the precedence list of the first element of the
* specified superClasses.
*/
baseList = superClasses->cl->order;
assert(baseList != NULL);
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "=== baseList from %s = %p\n", ClassName(superClasses->cl), (void *)baseList);
NsfClassListPrint("baseList", baseList);
#endif
/*
* The first element of the result list of the merge operation is the first
* element of the baseList.
*/
plNext = NsfClassListAdd(&pl, baseList->cl, NULL);
/*
* For every element but the first (which is already in baseList), we have to
* perform the merge operation. For n elements in superClasses, the merge
* operation is performed n-1 times.
*/
sl = superClasses->nextPtr;
assert(superClasses->nextPtr != NULL);
do {
NsfClasses *mergeList = sl->cl->order, *baseListCurrent;
#if defined(NSF_LINEARIZER_TRACE)
NsfClassListPrint("mergeList", mergeList);
#endif
/*
* Merge mergeList into baseList. We start with the 2nd (later probably
* nth) entry of the baseList
*/
baseListCurrent = baseList->nextPtr;
assert(baseListCurrent != NULL);
while (mergeList != NULL) {
NsfClass *addClass;
ValidClassListTail("baseList", baseList);
ValidClassListTail("mergeList", mergeList);
assert(baseListCurrent != NULL);
/* NsfClassListPrint("baseListCurrent", baseListCurrent); */
if (mergeList->cl == baseListCurrent->cl) {
/*
* The first element of mergeList and the current baseList element are
* identical. The element is in the result, keep the element in the
* result, advance in both lists.
*/
/* fprintf(stderr, "\t\tadvance both\n"); */
addClass = mergeList->cl;
baseListCurrent = baseListCurrent->nextPtr;
mergeList = mergeList->nextPtr;
} else if (MustBeBefore(baseListCurrent->cl, mergeList->cl, superClasses)) {
/*
* Check whether current element of mergeList must be before the current
* element of baseList. If so, insert current mergelist element before
* baseListCurrent,
*/
addClass = mergeList->cl;
mergeList = mergeList->nextPtr;
/* fprintf(stderr, "\t\tadd from mergeList %s\n", ClassName(addClass)); */
} else {
/*
* Two cases above do not apply, add from baseList and advance
* baseList pointer.
*/
addClass = baseListCurrent->cl;
baseListCurrent = baseListCurrent->nextPtr;
/* fprintf(stderr, "\t\tadd from baselist %s\n", ClassName(addClass)); */
}
if (addClass != NULL) {
/*
* We have to add an element to the precedence list. When the class to
* be added is already in the result list (which might happen just in
* crippled cases) then delete it. In the final step it will be added
* again to the end.
*/
NsfClasses *deletedElement = NsfClassListUnlink(&pl, addClass);
if (deletedElement != NULL) {
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "\t\t%s is redundant (in resultList)\n", ClassName(addClass));
#endif
/*
* When plNext points to the nextPtr of the deleted element, search
* the list from the begin
*/
if (plNext == &(deletedElement->nextPtr)) {
plNext = &pl;
}
NsfClassListFree(deletedElement);
}
/*
* Add the new element.
*/
plNext = NsfClassListAdd(plNext, addClass, NULL);
}
#if defined(NSF_LINEARIZER_TRACE)
NsfClassListPrint("pl:", pl);
#endif
}
/*
* mergeList is processed, we have a final precedence list in pl. In case
* are at then of superClasses, we are done. Otherwise, use the resulting
* pl as next baseList and continue with the next mergeList from
* superClasses.
*/
#if defined(NSF_LINEARIZER_TRACE)
NsfClassListPrint("plFinal:", pl);
#endif
if (sl->nextPtr != NULL) {
/*
* We are not at the end, use pl as new base list.
*/
baseList = pl;
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "=== setting new baseList\n");
NsfClassListPrint("new baseList", baseList);
#endif
/*
* Add old pl to deletion list; these entries are deleted once merging
* is finished.
*/
NsfClassListAdd(&deletionList, NULL, pl);
/*
* Create a fresh pl for the next iteration.
*/
pl = NULL;
plNext = NsfClassListAdd(&pl, class, NULL);
}
/*
* Get next element from the list.
*/
sl = sl->nextPtr;
} while (sl != NULL);
for (sl = deletionList; sl != NULL; sl = sl->nextPtr) {
/* fprintf(stderr, "delete from deletion list %p client data %p\n", sl, sl->clientData); */
NsfClassListFree(sl->clientData);
}
if (deletionList != NULL) {
NsfClassListFree(deletionList);
}
NsfClassListFree(superClasses);
return pl;
}
#if defined(NSF_DEVELOPMENT_TEST)
static void AssertOrderIsWhite(NsfClasses *order) {
register NsfClasses *pc;
for (pc = order; pc != NULL; pc = pc->nextPtr) {
assert(pc->cl->color == WHITE);
}
}
#else
# define AssertOrderIsWhite(arg)
#endif
/*
*----------------------------------------------------------------------
* TopoSortSuper --
*
* Compute the precedence order for baseClass based on the
* superclasses. If the order is computable, update base class and
* return NSF_TRUE. Otherwise return NSF_FALSE.
*
* Results:
* Boolean value indicating success.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool TopoSortSuper(NsfClass *class, NsfClass *baseClass)
nonnull(1) nonnull(2);
static bool
TopoSortSuper(NsfClass *class, NsfClass *baseClass) {
NsfClasses *pl, *sl;
nonnull_assert(class != NULL);
nonnull_assert(baseClass != NULL);
/*
* Be careful to reset the color of unreported classes to
* white in the caller on all exits to WHITE.
*
* WHITE ... not processed
* GRAY ... in work
* BLACK ... done
*/
class->color = GRAY;
for (sl = class->super; likely(sl != NULL); sl = sl->nextPtr) {
NsfClass *sc = sl->cl;
if (sc->color == GRAY) {
class->color = WHITE;
return NSF_FALSE;
}
if (unlikely(sc->color == WHITE && !TopoSortSuper(sc, baseClass))) {
class->color = WHITE;
return NSF_FALSE;
}
}
/*
* Create a new precedence list containing cl.
*/
pl = NEW(NsfClasses);
pl->cl = class;
pl->nextPtr = NULL;
/*
* If we have multiple inheritance we merge the precomputed inheritance
* orders of the involved classes in the provided order.
*/
if (likely(class->super != NULL) && unlikely(class->super->nextPtr != NULL)) {
pl = MergeInheritanceLists(pl, class);
if (baseClass->order != NULL) {
NsfClassListFree(baseClass->order);
/*
* baseClass->order is reset below.
*/
}
} else {
/*
* Add baseClass order to the end of the precedence list.
*/
assert(pl->nextPtr == NULL);
pl->nextPtr = baseClass->order;
}
class->color = BLACK;
/*
* Set baseClass order to the newly computed list (the result of this
* function).
*/
baseClass->order = pl;
return NSF_TRUE;
}
/*
*----------------------------------------------------------------------
* PrecedenceOrder --
*
* Return a class list containing the transitive list of
* superclasses starting with (and containing) the provided
* class. The superclass list is cached in cl->order and has to be
* invalidated by FlushPrecedences() in case the order changes. The
* caller does not have to free the returned class list (like for
* TransitiveSubClasses);
*
* Results:
* Class list, NULL on error
*
* Side effects:
* Updating cl->order.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static NsfClasses *
PrecedenceOrder(NsfClass *class) {
register const NsfClasses *sl;
bool success, haveMultipleInheritance;
nonnull_assert(class != NULL);
/*
* Check, of the superclass order is already cached.
*/
if (likely(class->order != NULL)) {
return class->order;
}
/*
* For multiple inheritance (more than one superclass), make sure that
* required precedence orders are precomputed. But first check whether we
* have to do this rather expensive operation now, or we can do it
* lazily. We can't do this in MergeInheritanceLists() within
* TopoSortSuper(), since there the class node coloring might be half done.
*/
haveMultipleInheritance = NSF_FALSE;
for (sl = class->super; sl != NULL; sl = sl->cl->super) {
if (sl != NULL && sl->nextPtr != NULL) {
haveMultipleInheritance = NSF_TRUE;
break;
}
}
if (unlikely(haveMultipleInheritance)) {
/*
* In the class hierarchy is somewhere a place with multiple
* inheritance. All precedence orders of superclasses must be computed,
* otherwise merging of sublists will not work.
*/
for (sl = class->super; sl != NULL; sl = sl->nextPtr) {
const NsfClasses *pl;
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "====== PrecedenceOrder multiple inheritance: check %s %p \n",
ClassName(sl->cl), (void *)sl->cl->order);
#endif
if (unlikely(sl->cl->order == NULL) && likely(class != sl->cl)) {
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "====== PrecedenceOrder multiple inheritance computes required order for %s \n",
ClassName(sl->cl));
#endif
PrecedenceOrder(sl->cl);
#if defined(NSF_LINEARIZER_TRACE)
NsfClassListPrint("====== PrecedenceOrder multiple inheritance:", sl->cl->order);
#endif
}
for (pl = sl->cl->order; pl != NULL; pl = pl->nextPtr) {
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "====== PrecedenceOrder multiple inheritance: %s %p\n",
ClassName(pl->cl), (void *)pl->cl->order);
#endif
if (pl->cl->order == NULL) {
#if defined(NSF_LINEARIZER_TRACE)
fprintf(stderr, "========== recurse\n");
#endif
PrecedenceOrder(pl->cl);
}
}
}
}
success = TopoSortSuper(class, class);
/*
* Reset the color of all nodes.
*/
for (sl = class->order; sl != NULL; sl = sl->nextPtr) {
sl->cl->color = WHITE;
}
/*
* If computation is successful, return cl->order.
* Otherwise clear cl->order if necessary.
*/
if (likely(success)) {
AssertOrderIsWhite(class->order);
/*
* TopoSortSuper succeeded, the cl-order is already set.
*/
} else if (class->order != NULL) {
/*
* TopoSortSuper failed, but there is a computed cl->order. Flush it.
*/
NsfClassListFree(class->order);
class->order = NULL;
} else {
/*
* TopoSortSuper failed, but there is no computed cl->order. Nothing to
* do.
*/
}
#if defined(NSF_LINEARIZER_TRACE)
NsfClassListPrint("!!! PrecedenceOrder computed", class->order);
#endif
return class->order;
}
/*
*----------------------------------------------------------------------
* GetSubClasses --
*
* Return a class list containing the transitive or dependent
* subclasses starting with (and containing) the provided
* class. The caller has to free the returned class list.
*
* Results:
* Class list, at least with one element (i.e., the provided class).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static NsfClasses *
GetSubClasses(NsfClass *class, bool withMixinOfs)
nonnull(1) returns_nonnull;
#define TransitiveSubClasses(class) \
GetSubClasses((class), NSF_FALSE)
#define DependentSubClasses(class) \
GetSubClasses((class), NSF_TRUE)
NSF_INLINE static NsfClasses *
GetSubClasses(NsfClass *class, bool withMixinOfs) {
NsfClasses *order, *savedOrder;
nonnull_assert(class != NULL);
/*
* Since TopoSort() places its result in cl->order, we have to save the old
* cl->order, perform the computation, and restore the old order.
*/
savedOrder = class->order;
class->order = NULL;
(void)TopoSortSub(class, class, withMixinOfs);
order = class->order;
assert(order != NULL);
AssertOrderIsWhite(order);
class->order = savedOrder;
return order;
}
/*
*----------------------------------------------------------------------
* FlushPrecedences --
*
* This function iterations over the provided class list and
* flushes (and frees) the superclass caches in cl->order for every
* element.
*
* Results:
* None.
*
* Side effects:
* Freeing class lists cached in cl->order.
*
*----------------------------------------------------------------------
*/
static void FlushPrecedences(const NsfClasses *subClasses)
nonnull(1);
static void
FlushPrecedences(const NsfClasses *subClasses) {
nonnull_assert(subClasses != NULL);
do {
if (subClasses->cl->order != NULL) {
NsfClassListFree(subClasses->cl->order);
}
subClasses->cl->order = NULL;
subClasses = subClasses->nextPtr;
} while (subClasses != NULL);
}
/*
*----------------------------------------------------------------------
* AddInstance --
*
* Add an instance to a class.
*
* Results:
* None.
*
* Side effects:
* Add entry to children hash-table.
*
*----------------------------------------------------------------------
*/
static void AddInstance(NsfObject *object, NsfClass *class)
nonnull(1) nonnull(2);
static void
AddInstance(NsfObject *object, NsfClass *class) {
int isNewItem;
nonnull_assert(object != NULL);
nonnull_assert(class != NULL);
object->cl = class;
(void) Tcl_CreateHashEntry(&class->instances, (char *)object, &isNewItem);
/*if (newItem == 0) {
fprintf(stderr, "instance %p %s was already an instance of %p %s\n",
(void *)object, ObjectName(object), (void *)cl, ClassName(class));
}*/
assert(isNewItem != 0);
}
/*
*----------------------------------------------------------------------
* RemoveInstance --
*
* Remove an instance from a class. The function checks, whether
* the entry is actually still an instance before it deletes it.
*
* Results:
* None.
*
* Side effects:
* Entry deleted from instances hash-table
*
*----------------------------------------------------------------------
*/
static void RemoveInstance(const NsfObject *object, NsfClass *class)
nonnull(1) nonnull(2);
static void
RemoveInstance(const NsfObject *object, NsfClass *class) {
nonnull_assert(object != NULL);
nonnull_assert(class != NULL);
/*
* If we are during a delete, which should not happen under normal
* operations, prevent an abort due to a deleted hash table.
*/
if (unlikely(class->object.flags & NSF_DURING_DELETE) != 0u) {
NsfLog(class->object.teardown, NSF_LOG_WARN,
"The class %s, from which an instance is to be removed, is currently under deletion",
ObjStr((class)->object.cmdName));
} else {
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&class->instances, (char *)object, NULL);
/*if (hPtr == NULL) {
fprintf(stderr, "instance %s is not an instance of %s\n", ObjectName(object), ClassName(class));
}*/
assert(hPtr != NULL);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
* superclass/subclass list maintenance
*/
static void AddSuper1(NsfClass *class, NsfClasses **sl)
nonnull(1) nonnull(2);
static void AddSuper(NsfClass *class, NsfClass *superClass)
nonnull(1);
static bool RemoveSuper1(NsfClass *class, NsfClasses **sl)
nonnull(1) nonnull(2);
static bool RemoveSuper(NsfClass *class, NsfClass *superClass)
nonnull(1) nonnull(2);
static void
AddSuper1(NsfClass *class, NsfClasses **sl) {
NsfClasses *sc = NEW(NsfClasses);
nonnull_assert(class != NULL);
nonnull_assert(sl != NULL);
sc->cl = class;
sc->nextPtr = *sl;
*sl = sc;
}
static void
AddSuper(NsfClass *class, NsfClass *superClass) {
nonnull_assert(class != NULL);
if (superClass != NULL) {
/*
* keep corresponding sub in step with super
*/
AddSuper1(superClass, &class->super);
AddSuper1(class, &superClass->sub);
}
}
static bool
RemoveSuper1(NsfClass *class, NsfClasses **sl) {
NsfClasses *l;
bool result;
nonnull_assert(class != NULL);
nonnull_assert(sl != NULL);
l = *sl;
if (l == NULL) {
result = NSF_FALSE;
} else if (l->cl == class) {
*sl = l->nextPtr;
FREE(NsfClasses, l);
result = NSF_TRUE;
} else {
while ((l->nextPtr != NULL) && (l->nextPtr->cl != class)) {
l = l->nextPtr;
}
if (l->nextPtr != NULL) {
NsfClasses *n = l->nextPtr->nextPtr;
FREE(NsfClasses, l->nextPtr);
l->nextPtr = n;
result = NSF_TRUE;
} else {
result = NSF_FALSE;
}
}
return result;
}
static bool
RemoveSuper(NsfClass *class, NsfClass *superClass) {
bool sp, sb;
nonnull_assert(class != NULL);
nonnull_assert(superClass != NULL);
/*
* Keep corresponding sub in step with super
*/
sp = RemoveSuper1(superClass, &class->super);
sb = RemoveSuper1(class, &superClass->sub);
return sp && sb;
}
/*
* methods lookup
*/
/*
*----------------------------------------------------------------------
* GetEnsembleObjectFromName --
*
* Get an ensemble object from a method name. If the method name
* is fully qualified, just use a Tcl lookup, otherwise get it from
* the provided namespace.
*
* Results:
* Ensemble object or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfObject *GetEnsembleObjectFromName(
Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *nameObj,
Tcl_Command *cmdPtr, bool *fromClassNS
) nonnull(1) nonnull(3) nonnull(4) nonnull(5);
static NsfObject *
GetEnsembleObjectFromName(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *nameObj,
Tcl_Command *cmdPtr, bool *fromClassNS) {
Tcl_Command cmd;
const char *nameString;
NsfObject *result;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(cmdPtr != NULL);
nonnull_assert(fromClassNS != NULL);
nameString = ObjStr(nameObj);
if (*nameString == ':') {
cmd = Tcl_GetCommandFromObj(interp, nameObj);
*fromClassNS = IsClassNsName(nameString, NULL);
} else {
cmd = (nsPtr != NULL) ? FindMethod(nsPtr, nameString) : NULL;
}
if (cmd != NULL) {
*cmdPtr = cmd;
result = NsfGetObjectFromCmdPtr(GetOriginalCommand(cmd));
} else {
result = NULL;
}
return result;
}
/*
*----------------------------------------------------------------------
* GetRegObject --
*
* Try to get the object, on which the method was registered from a
* fully qualified method handle.
*
* Results:
* NsfObject * or NULL on failure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfObject *GetRegObject(Tcl_Interp *interp, Tcl_Command cmd, const char *methodName,
const char **methodName1, bool *fromClassNS)
nonnull(1) nonnull(3) nonnull(5) nonnull(2);
static NsfObject *
GetRegObject(Tcl_Interp *interp, Tcl_Command cmd, const char *methodName,
const char **methodName1, bool *fromClassNS) {
NsfObject *regObject;
const char *procName;
size_t objNameLength;
nonnull_assert(interp != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(methodName != NULL);
assert(*methodName == ':');
nonnull_assert(fromClassNS != NULL);
nonnull_assert(cmd != NULL);
procName = Tcl_GetCommandName(interp, cmd);
objNameLength = strlen(methodName) - strlen(procName) - 2;
if (objNameLength > 0) {
Tcl_DString ds, *dsPtr = &ds;
/*
* Obtain parent name.
*/
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, methodName, (TCL_SIZE_T)objNameLength);
regObject = GetObjectFromNsName(interp, Tcl_DStringValue(dsPtr), fromClassNS);
if (regObject != NULL && methodName1 != NULL) {
*methodName1 = procName;
}
Tcl_DStringFree(dsPtr);
} else {
regObject = NULL;
}
/*fprintf(stderr, "GetRegObject cmd %p methodName '%s' => %p\n", (void *)cmd, methodName, (void *)regObject);*/
return regObject;
}
/*
*----------------------------------------------------------------------
* ResolveMethodName --
*
* Resolve a method name relative to a provided namespace.
* The method name can be
* a) a fully qualified name
* b) a list of method name and subcommands
* c) a simple name
*
* Results:
* Tcl_Command or NULL on failure
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Command ResolveMethodName(
Tcl_Interp *interp,
Tcl_Namespace *nsPtr,
Tcl_Obj *methodObj,
Tcl_DString *methodNameDs,
NsfObject **regObject,
NsfObject **defObject,
const char **methodName1, bool *fromClassNS
) nonnull(1) nonnull(3) nonnull(8);
static Tcl_Command
ResolveMethodName(
Tcl_Interp *interp,
Tcl_Namespace *nsPtr,
Tcl_Obj *methodObj,
Tcl_DString *methodNameDs,
NsfObject **regObject,
NsfObject **defObject,
const char **methodName1,
bool *fromClassNS
) {
const char *methodName;
NsfObject *referencedObject;
bool containsSpace, tailContainsSpace;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(methodObj != NULL);
nonnull_assert(fromClassNS != NULL);
methodName = ObjStr(methodObj);
/*fprintf(stderr, "methodName '%s' comp %d type %s\n",
methodName, strchr(methodName, ' ')>0, ObjTypeStr(methodObj));*/
if (methodObj->typePtr == Nsf_OT_listType) {
TCL_SIZE_T length;
Tcl_ListObjLength(interp, methodObj, &length);
containsSpace = (length > 1);
} else if (methodObj->typePtr == Nsf_OT_tclCmdNameType) {
containsSpace = NSF_FALSE;
} else {
containsSpace = NsfHasTclSpace(methodName);
}
if (containsSpace) {
tailContainsSpace = NsfHasTclSpace(NSTail(methodName));
} else {
tailContainsSpace = NSF_FALSE;
}
/*fprintf(stderr, "<%s> containsSpace %d tailContainsSpace %d\n", methodName, containsSpace, tailContainsSpace);*/
#if !defined(NDEBUG)
if (containsSpace) {
assert(NsfHasTclSpace(methodName));
} else {
assert(!tailContainsSpace);
}
#endif
if (tailContainsSpace) {
const char *firstElementString;
const Tcl_Namespace *parentNsPtr;
const NsfObject *ensembleObject;
Tcl_Obj *methodHandleObj, **ov;
TCL_SIZE_T oc, i;
/*
* When the methodName is required, we have to provide a methodNameDS as
* well.
*/
assert(methodName1 == NULL || methodNameDs != NULL);
/*fprintf(stderr, "name '%s' contains space \n", methodName);*/
if (likely(Tcl_ListObjGetElements(interp, methodObj, &oc, &ov) != TCL_OK)
|| ((referencedObject = GetEnsembleObjectFromName(interp, nsPtr, ov[0],
&cmd, fromClassNS)) == NULL)
) {
if (methodName1 != NULL) {
*methodName1 = NULL;
}
if (regObject != NULL) {
*regObject = NULL;
}
if (defObject != NULL) {
*defObject = NULL;
}
return NULL;
}
/*
* We have an ensemble object. First, figure out, on which
* object/class the ensemble object was registered. We determine
* the regObject on the first element of the list. If we can't,
* then the current object is the regObject.
*/
firstElementString = ObjStr(ov[0]);
if (*firstElementString == ':') {
NsfObject *registrationObject;
registrationObject = GetRegObject(interp, cmd, firstElementString, methodName1, fromClassNS);
if (regObject != NULL) {
*regObject = registrationObject;
}
} else {
if (regObject != NULL) {
*regObject = NULL;
}
}
/*fprintf(stderr, "... regObject object '%s' reg %p, fromClassNS %d\n",
ObjectName(referencedObject), (void *)*regObject, *fromClassNS);*/
/*
* Build a fresh methodHandleObj to held method name and names of
* subcmds.
*/
methodHandleObj = Tcl_DuplicateObj(referencedObject->cmdName);
INCR_REF_COUNT(methodHandleObj);
if (methodNameDs != NULL) {
Tcl_DStringAppend(methodNameDs, Tcl_GetCommandName(interp, cmd), TCL_INDEX_NONE);
}
parentNsPtr = NULL;
/*
* Iterate over the objects and append to the methodNameDs and methodHandleObj
*/
for (i = 1; i < oc; i++) {
cmd = Tcl_GetCommandFromObj(interp, methodHandleObj);
ensembleObject = (cmd != NULL) ? NsfGetObjectFromCmdPtr(cmd) : NULL;
if (ensembleObject == NULL) {
DECR_REF_COUNT(methodHandleObj);
if (methodName1 != NULL) {
*methodName1 = NULL;
}
if (regObject != NULL) {
*regObject = NULL;
}
if (defObject != NULL) {
*defObject = NULL;
}
return NULL;
}
if (parentNsPtr != NULL
&& (Tcl_Command_nsPtr(ensembleObject->id) != parentNsPtr)) {
/* fprintf(stderr, "*** parent change saved parent %p %s computed parent %p %s\n",
(void *)parentNsPtr, parentNsPtr->fullName,
Tcl_Command_nsPtr(ensembleObject->id),
Tcl_Command_nsPtr(ensembleObject->id)->fullName);*/
DECR_REF_COUNT(methodHandleObj);
methodHandleObj = Tcl_DuplicateObj(ensembleObject->cmdName);
}
parentNsPtr = ensembleObject->nsPtr;
Tcl_AppendLimitedToObj(methodHandleObj, "::", 2, INT_MAX, NULL);
Tcl_AppendLimitedToObj(methodHandleObj, ObjStr(ov[i]), TCL_INDEX_NONE, INT_MAX, NULL);
if (methodNameDs != NULL) {
Tcl_DStringAppendElement(methodNameDs, ObjStr(ov[i]));
}
}
/*
* cmd contains now the parent-obj, on which the method was
* defined. Get from this cmd the defObj.
*/
if (defObject != NULL) {
*defObject = NsfGetObjectFromCmdPtr(cmd);
}
/*fprintf(stderr, "... handle '%s' last cmd %p defObject %p\n",
ObjStr(methodHandleObj), (void *)cmd, *defObject);*/
/*
* Obtain the command from the method handle and report back the
* final methodName,
*/
cmd = Tcl_GetCommandFromObj(interp, methodHandleObj);
if (methodNameDs != NULL && methodName1 != NULL) {
*methodName1 = Tcl_DStringValue(methodNameDs);
}
/*fprintf(stderr, "... methodname1 '%s' cmd %p\n", Tcl_DStringValue(methodNameDs), (void *)cmd);*/
DECR_REF_COUNT(methodHandleObj);
} else if (*methodName == ':') {
cmd = Tcl_GetCommandFromObj(interp, methodObj);
if (likely(cmd != NULL)) {
referencedObject = GetRegObject(interp, cmd, methodName, methodName1, fromClassNS);
if (regObject != NULL) {
*regObject = referencedObject;
}
if (defObject != NULL) {
*defObject = referencedObject;
}
if (methodName1 && *methodName1 == NULL) {
/*
* The return value for the method name is required and was not
* computed by GetRegObject()
*/
*methodName1 = Tcl_GetCommandName(interp, cmd);
}
} else {
/*
* The cmd was not registered on an object or class, but we
* still report back the cmd (might be e.g. a primitive cmd).
*/
if (regObject != NULL) {
*regObject = NULL;
}
if (defObject != NULL) {
*defObject = NULL;
}
}
} else {
if (methodName1 != NULL) {
*methodName1 = methodName;
}
cmd = (nsPtr != NULL) ? FindMethod(nsPtr, methodName) : NULL;
if (regObject != NULL) {
*regObject = NULL;
}
if (defObject != NULL) {
*defObject = NULL;
}
}
return cmd;
}
/*
*----------------------------------------------------------------------
* CmdIsProc --
*
* Check, whether the cmd is interpreted
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static bool CmdIsProc(const Tcl_Command cmd)
nonnull(1) NSF_pure;
NSF_INLINE static bool
CmdIsProc(const Tcl_Command cmd) {
/*
* In 8.6: TclIsProc((Command *)cmd) is not equivalent to the definition
* below.
*/
nonnull_assert(cmd != NULL);
return (TCL_COMMAND_OBJPROC(cmd) == (TCL_OBJCMDPROC_T*)TclObjInterpProc);
}
/*
*----------------------------------------------------------------------
* CmdIsNsfObject --
*
* Check whether the provided cmd refers to an NsfObject or Class.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static bool CmdIsNsfObject(Tcl_Command cmd)
nonnull(1) NSF_pure;
NSF_INLINE static bool
CmdIsNsfObject(Tcl_Command cmd) {
nonnull_assert(cmd != NULL);
return (TCL_OBJCMDPROC_T*)Tcl_Command_objProc(cmd) == NsfObjDispatch;
}
/*
*----------------------------------------------------------------------
* GetTclProcFromCommand --
*
* Check whether cmd refers to a Tcl proc, and if so, return the
* proc definition.
*
* Results:
* The found proc of cmd or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Proc *GetTclProcFromCommand(const Tcl_Command cmd)
nonnull(1) NSF_pure;
static Proc *
GetTclProcFromCommand(const Tcl_Command cmd) {
Tcl_ObjCmdProc *proc;
Proc *result;
nonnull_assert(cmd != NULL);
proc = Tcl_Command_objProc(cmd);
if (proc == TclObjInterpProc) {
result = (Proc *)Tcl_Command_objClientData(cmd);
} else {
result = NULL;
}
return result;
}
/*
*----------------------------------------------------------------------
* FindMethod --
*
* Lookup the cmd for methodName in a namespace.
*
* Results:
* The found cmd of the method or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static Tcl_Command
FindMethod(
const Tcl_Namespace *nsPtr,
const char *methodName
) {
register const Tcl_HashEntry *entryPtr;
Tcl_Command result;
nonnull_assert(nsPtr != NULL);
nonnull_assert(methodName != NULL);
if ((entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(nsPtr), methodName, NULL))) {
result = (Tcl_Command) Tcl_GetHashValue(entryPtr);
} else {
result = NULL;
}
return result;
}
/*
*----------------------------------------------------------------------
* FindProcMethod --
*
* Lookup the proc for methodName in a namespace.
*
* Results:
* The found proc of the method or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Proc * FindProcMethod(const Tcl_Namespace *nsPtr, const char *methodName)
nonnull(1) nonnull(2);
static Proc *
FindProcMethod(const Tcl_Namespace *nsPtr, const char *methodName) {
Tcl_Command cmd;
nonnull_assert(nsPtr != NULL);
nonnull_assert(methodName != NULL);
cmd = FindMethod(nsPtr, methodName);
return (cmd != NULL) ? GetTclProcFromCommand(cmd) : NULL;
}
/*
*----------------------------------------------------------------------
* SearchPLMethod, SearchPLMethod0 --
*
* Search a method along a provided class list. The methodName
* must be simple (must not contain space). While SearchPLMethod()
* allows one to specify a flag for filtering the command,
* SearchPLMethod0() is a lightly optimized function without the
* filtering option.
*
* Results:
* The found class defining the method or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass * SearchPLMethod(
register const NsfClasses *pl, const char *methodName,
Tcl_Command *cmdPtr, unsigned int flags
) nonnull(1) nonnull(2) nonnull(3);
static NsfClass * SearchPLMethod0(
register const NsfClasses *pl, const char *methodName,
Tcl_Command *cmdPtr
) nonnull(1) nonnull(2) nonnull(3);
static NsfClass *
SearchPLMethod0(
register const NsfClasses *pl, const char *methodName, Tcl_Command *cmdPtr
) {
nonnull_assert(pl != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmdPtr != NULL);
/*
* Search the precedence list (class hierarchy).
*/
do {
register const Tcl_HashEntry *entryPtr =
Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(pl->cl->nsPtr), methodName, NULL);
if (entryPtr != NULL) {
*cmdPtr = (Tcl_Command) Tcl_GetHashValue(entryPtr);
return pl->cl;
}
pl = pl->nextPtr;
} while (pl != NULL);
return NULL;
}
static NsfClass *
SearchPLMethod(
register const NsfClasses *pl, const char *methodName,
Tcl_Command *cmdPtr, unsigned int flags
) {
nonnull_assert(pl != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmdPtr != NULL);
/*
* Search the precedence list (class hierarchy).
*/
do {
register const Tcl_HashEntry *entryPtr =
Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(pl->cl->nsPtr), methodName, NULL);
if (entryPtr != NULL) {
Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
if (likely(((unsigned int)Tcl_Command_flags(cmd) & flags) == 0u)) {
*cmdPtr = cmd;
return pl->cl;
}
}
pl = pl->nextPtr;
} while (pl != NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
* SearchCMethod --
*
* Search a method along the superclass hierarchy of the provided
* class. The methodObj must be simple (must not contain
* space). The method has the interface for internal calls during
* interpretation, while SearchSimpleCMethod() has the interface
* with more overhead for introspection.
*
* Results:
* The found class defining the method or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass * SearchCMethod(NsfClass *class, const char *methodName, Tcl_Command *cmdPtr)
nonnull(1) nonnull(2) nonnull(3);
static NsfClass *
SearchCMethod(NsfClass *class, const char *methodName, Tcl_Command *cmdPtr) {
nonnull_assert(methodName != NULL);
nonnull_assert(cmdPtr != NULL);
nonnull_assert(class != NULL);
return SearchPLMethod0(PrecedenceOrder(class), methodName, cmdPtr);
}
/*
*----------------------------------------------------------------------
* SearchSimpleCMethod --
*
* Search a method along the superclass hierarchy of the provided
* class. The methodObj must be simple (must not contain
* space). The method has the same interface as
* SearchComplexCMethod().
*
* Results:
* The found class defining the method or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass * SearchSimpleCMethod(Tcl_Interp *UNUSED(interp),
NsfClass *class, Tcl_Obj *methodObj,
Tcl_Command *cmdPtr)
nonnull(2) nonnull(3) nonnull(4);
static NsfClass *
SearchSimpleCMethod(
Tcl_Interp *UNUSED(interp), NsfClass *class,
Tcl_Obj *methodObj, Tcl_Command *cmdPtr
) {
nonnull_assert(class != NULL);
nonnull_assert(methodObj != NULL);
nonnull_assert(cmdPtr != NULL);
return SearchPLMethod0(PrecedenceOrder(class), ObjStr(methodObj), cmdPtr);
}
/*
*----------------------------------------------------------------------
* SearchComplexCMethod --
*
* Search a method along the superclass hierarchy of the provided
* class. The methodObj can refer to an ensemble object (can
* contain space). The method has the same interface as
* SearchSimpleCMethod().
*
* Results:
* The found class defining the method or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass * SearchComplexCMethod(Tcl_Interp *interp, NsfClass *class,
Tcl_Obj *methodObj, Tcl_Command *cmdPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static NsfClass *
SearchComplexCMethod(Tcl_Interp *interp, NsfClass *class,
Tcl_Obj *methodObj, Tcl_Command *cmdPtr) {
NsfClasses *pl;
bool fromClassNS = NSF_TRUE;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(methodObj != NULL);
nonnull_assert(cmdPtr != NULL);
for (pl = PrecedenceOrder(class); pl != NULL; pl = pl->nextPtr) {
Tcl_Command cmd = ResolveMethodName(interp, pl->cl->nsPtr, methodObj,
NULL, NULL, NULL, NULL, &fromClassNS);
if (cmd != NULL) {
*cmdPtr = cmd;
return pl->cl;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
* ObjectFindMethod --
*
* Find a method for a given object in the precedence path. The
* provided methodObj might be an ensemble object. This function
* tries to optimize access by calling different implementations
* for simple and ensemble method names.
*
* Results:
* Tcl command.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Command ObjectFindMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *methodObj, NsfClass **classPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static Tcl_Command
ObjectFindMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *methodObj, NsfClass **classPtr) {
Tcl_Command cmd = NULL;
NsfClass *(*lookupFunction)(Tcl_Interp *interp, NsfClass *class,
Tcl_Obj *methodObj, Tcl_Command *cmdPtr);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodObj != NULL);
nonnull_assert(classPtr != NULL);
if (NsfHasTclSpace(ObjStr(methodObj))) {
lookupFunction = SearchComplexCMethod;
} else {
lookupFunction = SearchSimpleCMethod;
}
if (unlikely(object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
}
if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
NsfCmdList *mixinList;
for (mixinList = object->mixinOrder; mixinList; mixinList = mixinList->nextPtr) {
NsfClass *mixin = NsfGetClassFromCmdPtr(mixinList->cmdPtr);
if ((mixin != NULL)
&& (*classPtr = (*lookupFunction)(interp, mixin, methodObj, &cmd))) {
if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CLASS_ONLY_METHOD) != 0u
&& !NsfObjectIsClass(object)
) {
cmd = NULL;
continue;
}
break;
}
}
}
if ((cmd == NULL) && (object->nsPtr != NULL)) {
bool fromClassNS = NSF_FALSE;
cmd = ResolveMethodName(interp, object->nsPtr, methodObj,
NULL, NULL, NULL, NULL, &fromClassNS);
}
if (cmd == NULL && object->cl != NULL) {
*classPtr = (*lookupFunction)(interp, object->cl, methodObj, &cmd);
}
return cmd;
}
/*
*----------------------------------------------------------------------
* GetObjectSystem --
*
* Return the object system for which the object was defined
*
* Results:
* Object system pointer
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfObjectSystem * GetObjectSystem(const NsfObject *object)
nonnull(1) NSF_pure;
static NsfObjectSystem *
GetObjectSystem(const NsfObject *object) {
nonnull_assert(object != NULL);
if (NsfObjectIsClass(object)) {
return ((NsfClass *)object)->osPtr;
}
assert(object->cl != NULL);
return object->cl->osPtr;
}
/*
*----------------------------------------------------------------------
* 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, NsfObjectSystem *osPtr)
nonnull(1) nonnull(2);
static void
ObjectSystemFree(Tcl_Interp *interp, NsfObjectSystem *osPtr) {
int idx;
nonnull_assert(interp != NULL);
nonnull_assert(osPtr != NULL);
for (idx = 0; idx <= NSF_s_set_idx; idx++) {
if (osPtr->methods[idx]) {
DECR_REF_COUNT(osPtr->methods[idx]);
osPtr->methodNames[idx] = NULL;
}
if (osPtr->handles[idx]) {
DECR_REF_COUNT(osPtr->handles[idx]);
}
}
if (osPtr->rootMetaClass != NULL && osPtr->rootClass != NULL) {
RemoveSuper(osPtr->rootMetaClass, osPtr->rootClass);
RemoveInstance((NsfObject *)osPtr->rootMetaClass, osPtr->rootMetaClass);
RemoveInstance((NsfObject *)osPtr->rootClass, osPtr->rootMetaClass);
FinalObjectDeletion(interp, &osPtr->rootClass->object);
FinalObjectDeletion(interp, &osPtr->rootMetaClass->object);
}
FREE(NsfObjectSystem, 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, NsfObjectSystem *osPtr)
nonnull(1) nonnull(2);
static void
ObjectSystemAdd(Tcl_Interp *interp, NsfObjectSystem *osPtr) {
nonnull_assert(interp != NULL);
nonnull_assert(osPtr != NULL);
osPtr->nextPtr = RUNTIME_STATE(interp)->objectSystems;
RUNTIME_STATE(interp)->objectSystems = osPtr;
}
/*
*----------------------------------------------------------------------
* ObjectSystemsCleanup --
*
* Delete all objects from all defined object systems. This method
* is to be called when a Next Scripting process or thread exists.
*
* Results:
* None.
*
* Side effects:
* All commands and objects are deleted, memory is freed.
*
*----------------------------------------------------------------------
*/
static int ObjectSystemsCleanup(Tcl_Interp *interp, bool withKeepvars)
nonnull(1);
static int
ObjectSystemsCleanup(Tcl_Interp *interp, bool withKeepvars) {
NsfCmdList *instances = NULL, *entryPtr;
NsfObjectSystem *osPtr;
nonnull_assert(interp != NULL);
/*
* 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.
*/
/*
* Collect all instances from all object systems
*/
for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
GetAllInstances(interp, &instances, osPtr->rootClass);
}
/***** SOFT DESTROY *****/
RUNTIME_STATE(interp)->exitHandlerDestroyRound = NSF_EXITHANDLER_ON_SOFT_DESTROY;
/*fprintf(stderr, "===CALL destroy on OBJECTS\n");*/
for (entryPtr = instances; entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
NsfObject *object = (NsfObject *)entryPtr->clorobj;
/*fprintf(stderr, "key = %s %p %d flags %.6x\n",
ObjectName(object), (void *)object, object && !NsfObjectIsClass(object), object->flags);*/
if (object != NULL
&& !NsfObjectIsClass(object)
&& ((object->flags & NSF_DESTROY_CALLED) == 0u)
) {
DispatchDestroyMethod(interp, object, 0u);
}
}
/*fprintf(stderr, "===CALL destroy on CLASSES\n");*/
for (entryPtr = instances; entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
const NsfClass *class = entryPtr->clorobj;
if (class != NULL
&& ((class->object.flags & NSF_DESTROY_CALLED) == 0u)
) {
DispatchDestroyMethod(interp, (NsfObject *)class, 0u);
}
}
/*
* Now turn off filters, all destroy callbacks are done.
*/
RUNTIME_STATE(interp)->doFilters = 0;
(void)Tcl_RemoveInterpResolvers(interp, "nsf");
#ifdef DO_CLEANUP
FreeAllNsfObjectsAndClasses(interp, &instances);
# ifdef DO_FULL_CLEANUP
DeleteProcsAndVars(interp, Tcl_GetGlobalNamespace(interp), withKeepvars);
# endif
#endif
(void)withKeepvars; /* make sure, the variable is not reported as unused */
#ifdef DO_CLEANUP
{
NsfObjectSystem *nPtr;
/*
* Free all objects systems with their root-classes.
*/
for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = nPtr) {
nPtr = osPtr->nextPtr;
ObjectSystemFree(interp, osPtr);
}
}
/*
* Finally, free all nsfprocs.
*/
DeleteNsfProcs(interp, NULL);
#endif
CmdListFree(&instances, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* CallDirectly --
*
* Determine when it is possible/necessary to call a method
* implementation directly or via method dispatch.
*
* Results:
* NSF_TRUE is returned when command should be invoked directly,
* NSF_FALSE otherwise.
*
* Side effects:
* methodObjPtr is set with the Tcl_Obj of the name of the method,
* if there is one defined.
*
*----------------------------------------------------------------------
*/
static bool CallDirectly(Tcl_Interp *interp, NsfObject *object, int methodIdx, Tcl_Obj **methodObjPtr)
nonnull(1) nonnull(2) nonnull(4);
static bool
CallDirectly(Tcl_Interp *interp, NsfObject *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
*/
NsfObjectSystem *osPtr = GetObjectSystem(object);
bool callDirectly = NSF_TRUE;
Tcl_Obj *methodObj;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodObjPtr != NULL);
methodObj = osPtr->methods[methodIdx];
/*fprintf(stderr, "OS of %s is %s, method %s methodObj %p osPtr %p defined %.8x %.8x overloaded %.8x %.8x flags %.8x\n",
ObjectName(object), ObjectName(&osPtr->rootClass->object),
Nsf_SystemMethodOpts[methodIdx]+1, (void *)methodObj,
(void *)osPtr,
osPtr->definedMethods, osPtr->definedMethods & (1 << methodIdx),
osPtr->overloadedMethods, osPtr->overloadedMethods & (1 << methodIdx),
1 << methodIdx );*/
if (methodObj != NULL) {
unsigned int flag = 1u << methodIdx;
if ((osPtr->overloadedMethods & flag) != 0u) {
/*
* The method is overloaded, we must dispatch.
*/
/*fprintf(stderr, "overloaded\n");*/
callDirectly = NSF_FALSE;
} else if ((osPtr->definedMethods & flag) == 0u) {
/*
* The method is not defined, we must call directly.
*/
/*fprintf(stderr, "Warning: CallDirectly object %s idx %s not defined\n",
ObjectName(object), Nsf_SystemMethodOpts[methodIdx]+1);*/
} else {
#if defined(DISPATCH_ALWAYS_DEFINED_METHODS)
callDirectly = NSF_FALSE;
#else
if ((object->flags & NSF_FILTER_ORDER_VALID) == 0u) {
FilterComputeDefined(interp, object);
}
/*fprintf(stderr, "CallDirectly object %s idx %s object flags %.6x %.6x \n",
ObjectName(object), Nsf_SystemMethodOpts[methodIdx]+1,
(object->flags & NSF_FILTER_ORDER_DEFINED_AND_VALID),
NSF_FILTER_ORDER_DEFINED_AND_VALID);*/
if ((object->flags & NSF_FILTER_ORDER_DEFINED_AND_VALID) == NSF_FILTER_ORDER_DEFINED_AND_VALID) {
/*fprintf(stderr, "CallDirectly object %s idx %s has filter \n",
ObjectName(object), Nsf_SystemMethodOpts[methodIdx]+1);*/
callDirectly = NSF_FALSE;
}
#endif
}
}
/*fprintf(stderr, "CallDirectly object %s idx %d returns %s => %d\n",
ObjectName(object), methodIdx, (methodObj != NULL) ? ObjStr(methodObj) : "(null)", callDirectly);*/
/*
* Teturn the methodObj in every case.
*/
*methodObjPtr = methodObj;
return callDirectly;
}
/*
*----------------------------------------------------------------------
* NsfMethodObj --
*
* Return the methodObj for a given method index.
*
* Results:
* Returns Tcl_Obj* or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
NsfMethodObj(const NsfObject *object, int methodIdx) {
NsfObjectSystem *osPtr = GetObjectSystem(object);
nonnull_assert(object != NULL);
/*
fprintf(stderr, "NsfMethodObj object %s os %p idx %d %s methodObj %p\n",
ObjectName(object), (void *)osPtr, methodIdx,
Nsf_SystemMethodOpts[methodIdx]+1,
osPtr->methods[methodIdx]);
*/
return osPtr->methods[methodIdx];
}
/*
* Conditional memory allocations of optional storage
*/
/*
*----------------------------------------------------------------------
* NsfRequireObjectOpt --
*
* Makes sure that the provided object has the optional data member
* set.
*
* Results:
* Optional data for the object.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfObjectOpt *
NsfRequireObjectOpt(NsfObject *object) {
nonnull_assert(object != NULL);
if (object->opt == NULL) {
object->opt = NEW(NsfObjectOpt);
memset(object->opt, 0, sizeof(NsfObjectOpt));
}
return object->opt;
}
/*
*----------------------------------------------------------------------
* NsfRequireClassOpt --
*
* Makes sure that the provided class has the optional data member
* set.
*
* Results:
* Optional data for the class.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NsfClassOpt *
NsfRequireClassOpt(NsfClass *class) {
nonnull_assert(class != NULL);
if (class->opt == NULL) {
class->opt = NEW(NsfClassOpt);
memset(class->opt, 0, sizeof(NsfClassOpt));
if ((class->object.flags & NSF_IS_CLASS) != 0u) {
class->opt->id = class->object.id; /* probably a temporary solution */
}
}
return class->opt;
}
/*
*----------------------------------------------------------------------
* MakeObjNamespace --
*
* Creates for the object a namespace, if it does not exist.
* already.
*
* Results:
* None.
*
* Side effects:
* Might create a namespace.
*
*----------------------------------------------------------------------
*/
static void MakeObjNamespace(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void
MakeObjNamespace(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
#ifdef NAMESPACE_TRACE
fprintf(stderr, "+++ MakeObjNamespace for %s\n", ObjectName(object));
#endif
if (object->nsPtr == NULL) {
Tcl_Namespace *nsPtr;
nsPtr = object->nsPtr = NSGetFreshNamespace(interp, object,
ObjStr(object->cmdName));
assert(nsPtr != NULL);
/*
* Copy all obj variables to the newly created namespace
*/
if (object->varTablePtr != NULL) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
TclVarHashTable *varTablePtr = Tcl_Namespace_varTablePtr(nsPtr);
Tcl_HashTable *varHashTablePtr = TclVarHashTablePtr(varTablePtr);
Tcl_HashTable *objHashTablePtr = TclVarHashTablePtr(object->varTablePtr);
*varHashTablePtr = *objHashTablePtr; /* copy the table */
if (objHashTablePtr->buckets == objHashTablePtr->staticBuckets) {
varHashTablePtr->buckets = varHashTablePtr->staticBuckets;
}
for (hPtr = Tcl_FirstHashEntry(varHashTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
hPtr->tablePtr = varHashTablePtr;
}
CallStackReplaceVarTableReferences(interp, object->varTablePtr,
(TclVarHashTable *)varHashTablePtr);
ckfree((char *) object->varTablePtr);
object->varTablePtr = NULL;
}
}
}
/*
*----------------------------------------------------------------------
* CompiledLocalsLookup --
*
* Lookup variable from the compiled locals. The function performs
* a linear search in an unsorted list maintained by Tcl. This
* function is just used for the rather deprecated "instvar"
* method.
*
* Results:
* Returns Tcl_Var (or NULL, when lookup is not successful).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Var CompiledLocalsLookup(CallFrame *varFramePtr, const char *varName)
nonnull(1) nonnull(2);
static Tcl_Var
CompiledLocalsLookup(CallFrame *varFramePtr, const char *varName) {
TCL_SIZE_T localCt;
nonnull_assert(varFramePtr != NULL);
nonnull_assert(varName != NULL);
localCt = varFramePtr->numCompiledLocals;
if (localCt > 0) {
Tcl_Obj **varNameObjPtr;
TCL_SIZE_T i, nameLength;
varNameObjPtr = &varFramePtr->localCachePtr->varName0;
nameLength = (TCL_SIZE_T)strlen(varName);
/* fprintf(stderr, "=== compiled local search #local vars %d for <%s> flags %.8x\n",
localCt, varName, varFramePtr->isProcCallFrame);
*/
for (i = 0 ; i < localCt ; i++, varNameObjPtr++) {
Tcl_Obj *varNameObj = *varNameObjPtr;
TCL_SIZE_T len;
if (likely(varNameObj != NULL)) {
const char *localName = Tcl_GetStringFromObj(varNameObj, &len);
/* fprintf(stderr, ".. [%d] varNameObj %p %p <%s>\n",
i, (void *)varNameObj, (void *)varNameObj->typePtr, localName);
*/
if (unlikely(varName[0] == localName[0]
&& varName[1] == localName[1]
&& (TCL_SIZE_T)len == nameLength
&& memcmp(varName, localName, (size_t)len) == 0)) {
return (Tcl_Var) &varFramePtr->compiledLocals[i];
}
}
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
* CompiledColonLocalsLookupBuildCache --
*
* Helper function for CompiledColonLocalsLookup(): build up a
* sorted cache consisting only of colon prefixed variables, such
* that e.g. non-successful lookup can be performed in O(n/2). In
* comparison to CompiledLocalsLookup() this function is about a
* factor of 4 faster.
*
* Results:
* Returns Tcl_Var (or NULL, when lookup is not successful).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Var CompiledColonLocalsLookupBuildCache(CallFrame *varFramePtr,
const char *varName,
TCL_SIZE_T nameLength,
Tcl_Obj **localNames,
NsfProcContext *ctxPtr)
nonnull(1) nonnull(2) nonnull(4) nonnull(5);
static Tcl_Var
CompiledColonLocalsLookupBuildCache(CallFrame *varFramePtr, const char *varName,
TCL_SIZE_T nameLength, Tcl_Obj **localNames,
NsfProcContext *ctxPtr) {
int nrColonVars = 0, j;
TCL_SIZE_T localCt, i;
Tcl_Var result;
Tcl_Obj **varNameObjPtr;
nonnull_assert(varFramePtr != NULL);
nonnull_assert(varName != NULL);
nonnull_assert(localNames != NULL);
nonnull_assert(ctxPtr != NULL);
assert(ctxPtr->colonLocalVarCache == NULL);
assert(varFramePtr->localCachePtr != NULL);
localCt = varFramePtr->numCompiledLocals;
varNameObjPtr = &varFramePtr->localCachePtr->varName0;
/*
* Count colonVars
*/
for (i = 0; i < localCt; i++, varNameObjPtr++) {
Tcl_Obj *varNameObj = *varNameObjPtr;
if (varNameObj != NULL) {
const char *localName = TclGetString(varNameObj);
if (localName[0] == ':') {
nrColonVars ++;
}
}
}
/*fprintf(stderr, ".. build cache #local vars %d for <%s> flags %.8x ctxPtr %p colonvars %d\n",
localCt, varName, varFramePtr->isProcCallFrame,
(void *)ctxPtr, nrColonVars
);*/
/*
* Allocate colonLocalVarCache in the proper size (keep space for a
* terminating element).
*/
ctxPtr->colonLocalVarCache = NEW_ARRAY(long, nrColonVars+1);
varNameObjPtr = &varFramePtr->localCachePtr->varName0;
/*
* Fill colonLocalVarCache; since we have to go through the whole list, we
* might find and return the variable.
*/
j = 0;
result = NULL;
for (i = 0; i < localCt ; i++, varNameObjPtr++) {
Tcl_Obj *varNameObj = *varNameObjPtr;
if (varNameObj != NULL) {
TCL_SIZE_T len;
const char *localName = Tcl_GetStringFromObj(varNameObj, &len);
if (localName[0] == ':') {
int k;
Tcl_Var var = (Tcl_Var) &varFramePtr->compiledLocals[i];
if (varName[1] == localName[1]
&& len == nameLength
&& memcmp(varName, localName, (size_t)len) == 0) {
result = var;
}
/* fprintf(stderr, ".. insert %s (%d) on pos %d; check j %d entries \n", localName, i, j, j); */
for (k = 0; k < j; k++) {
int cmp;
long idx;
const char *cachedName;
idx = ctxPtr->colonLocalVarCache[k];
cachedName = Tcl_GetStringFromObj(localNames[idx], &len);
cmp = strcmp(localName, cachedName);
/* fprintf(stderr, "... [%d] cmp newVarName <%s> (%d) with cachendName <%s> (%d) => %d\n",
k, localName, i, cachedName, idx, cmp);
*/
if (cmp < 0) {
int ii;
/*
* Make space on position k for inserting the new element. We
* might uses memmove() instead.
*/
for (ii = j; ii > k; ii--) {
ctxPtr->colonLocalVarCache[ii] = ctxPtr->colonLocalVarCache[ii - 1];
}
break;
}
}
ctxPtr->colonLocalVarCache[k] = (long)i;
j++;
if (j == nrColonVars) {
break;
}
}
}
}
/*
* Terminate list of indices with -1
*/
ctxPtr->colonLocalVarCache[j] = -1;
/* fprintf(stderr, ".. search #local vars %d varName <%s> colonvars %d found %p\n",
localCt, varName, nrColonVars, (void*)result);
*/
return result;
}
/*
*----------------------------------------------------------------------
* CompiledColonLocalsLookup --
*
* Lookup single colon prefixed variables from the compiled
* locals. This function uses a cache consisting of colon prefixed
* variables to speed up variable access.
*
* Results:
* Returns Tcl_Var (or NULL, when lookup is not successful)
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Var CompiledColonLocalsLookup(CallFrame *varFramePtr, const char *varName)
nonnull(1) nonnull(2);
static Tcl_Var
CompiledColonLocalsLookup(CallFrame *varFramePtr, const char *varName) {
Tcl_Var result;
nonnull_assert(varFramePtr != NULL);
nonnull_assert(varName != NULL);
if (varFramePtr->numCompiledLocals == 0) {
result = NULL;
} else {
Tcl_Obj **localNames;
TCL_SIZE_T nameLength;
Tcl_Command cmd;
NsfProcContext *ctxPtr;
/*
* Get the string table of the compiled locals and the length of the
* variable to search for faster access into local variables.
*/
localNames = &varFramePtr->localCachePtr->varName0;
nameLength = (TCL_SIZE_T)strlen(varName);
cmd = (Tcl_Command )varFramePtr->procPtr->cmdPtr;
ctxPtr = ProcContextRequire(cmd);
/*
* Check whether we have already a sorted cache (colonLocalVarCache). If not,
* build the cache and check in the same step for the wanted variable.
*/
if (unlikely(ctxPtr->colonLocalVarCache == NULL)) {
result = CompiledColonLocalsLookupBuildCache(varFramePtr, varName, nameLength, localNames, ctxPtr);
} else {
long i, j;
/*
* We have a colonLocalVarCache.
*
* Search the colonVarCache, which is alphabetically sorted to allow e.g.
* termination after O(n/2) on failures.
*/
result = NULL;
for (i = 0, j = ctxPtr->colonLocalVarCache[0];
j > -1;
++i, j = ctxPtr->colonLocalVarCache[i]) {
TCL_SIZE_T len;
const char *localName;
localName = Tcl_GetStringFromObj(localNames[j], &len);
/* fprintf(stderr, ".. [%d] varNameObj %p <%s> vs <%s>\n",
j, (void *)varNameObj, localName, varName); */
/*
* The first char of colon varName is always a colon, so we do not need to
* compare.
*/
if (varName[1] < localName[1]) {
break;
} else if (varName[1] == localName[1]) {
int cmp;
/*
* Even when the first character is identical, we call compare() only
* when the lengths are equal.
*/
if (len != nameLength) {
continue;
}
cmp = strcmp(varName, localName);
if (cmp == 0) {
result = (Tcl_Var) &varFramePtr->compiledLocals[j];
break;
} else if (cmp < 0) {
/*
* We are past the place, where the variable should be, so give up.
*/
break;
}
}
}
#if 0
if (result != NULL) {
fprintf(stderr, "... <%s> found -> [%d] %p\n", varName, j, (void *)result);
}
#endif
}
}
return result;
}
/*
*----------------------------------------------------------------------
* GetVarAndNameFromHash --
*
* Convenience function to obtain variable and name from
* a variable hash entry.
*
* Results:
* Results are passed back in argument 2 and 3
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void GetVarAndNameFromHash(const Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj)
nonnull(1) nonnull(2) nonnull(3);
static void
GetVarAndNameFromHash(const Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) {
nonnull_assert(hPtr != NULL);
nonnull_assert(val != NULL);
nonnull_assert(varNameObj != NULL);
*val = TclVarHashGetValue(hPtr);
*varNameObj = TclVarHashGetKey(*val);
}
/*********************************************************
*
* Variable resolvers
*
*********************************************************/
#define FOR_COLON_RESOLVER(ptr) (*(ptr) == ':' && *((ptr)+1) != ':')
/*
*----------------------------------------------------------------------
* MethodName --
*
* Return the methodName from a Tcl_Obj, strips potentially the
* colon prefix
*
* Results:
* method name
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char *
MethodName(Tcl_Obj *methodObj) {
const char *methodName;
nonnull_assert(methodObj != NULL);
methodName = ObjStr(methodObj);
if (FOR_COLON_RESOLVER(methodName)) {
methodName ++;
}
return methodName;
}
/*
*----------------------------------------------------------------------
* NsfMethodNamePath --
*
* Compute the full method name for error messages containing the
* ensemble root.
*
* Results:
* Tcl_Obj of reference count 0, caller has to take care for
* refcounting.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
NsfMethodNamePath(Tcl_Interp *interp,
Tcl_CallFrame *framePtr,
const char *methodName) {
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(methodName != NULL);
if (framePtr != NULL) {
resultObj = CallStackMethodPath(interp, framePtr);
} else {
resultObj = Tcl_NewListObj(0, NULL);
}
Tcl_ListObjAppendElement(interp, resultObj,
Tcl_NewStringObj(methodName, TCL_INDEX_NONE));
return resultObj;
}
/*
*----------------------------------------------------------------------
* NsColonVarResolver --
*
* Namespace resolver for namespace specific variable lookup.
* colon prefix
*
* Results:
* method name
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int NsColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
int flags, Tcl_Var *varPtr)
nonnull(1) nonnull(2) nonnull(5);
static int
NsColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
int flags, Tcl_Var *varPtr) {
Tcl_CallFrame *varFramePtr;
TclVarHashTable *varTablePtr;
NsfObject *object;
int new;
unsigned int frameFlags;
Tcl_Obj *key;
#if defined(NSF_DEVELOPMENT)
nonnull_assert(interp != NULL);
nonnull_assert(varName != NULL);
nonnull_assert(varPtr != NULL);
#endif
#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
*/
if (unlikely((flags & TCL_GLOBAL_ONLY) != 0u)) {
/*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 != NULL);
frameFlags = (unsigned int)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) != 0u) {
#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, (void *)varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr));*/
return TCL_CONTINUE;
}
/*
* FRAME_IS_NSF_CMETHOD has always FRAME_IS_PROC set, so it is
* handled already above
*/
assert((frameFlags & FRAME_IS_NSF_CMETHOD) == 0u);
if ((frameFlags & FRAME_IS_NSF_OBJECT) == 0u) {
/*
* Case 3: we are not in a Next Scripting frame, so proceed as well
*/
return TCL_CONTINUE;
} else {
/*
* Case 4: we are in a Next Scripting object frame
*/
if (*varName == ':') {
if (*(varName+1) != ':') {
/*
* Case 4a: The variable name starts with a single ":". Skip
* the char, but stay in the resolver.
*/
varName ++;
} else {
/*
* Case 4b: Names starting with "::" are not for us
*/
return TCL_CONTINUE;
}
} else if (NSTail(varName) != varName) {
/*
* Case 4c: Names containing "::" are not for us
*/
return TCL_CONTINUE;
}
/*
* Since we know that we are here always in an object frame, we
* can blindly get the object from the client data .
*/
object = (NsfObject *)Tcl_CallFrame_clientData(varFramePtr);
}
/*
* We have an object and create the variable if not found
*/
assert(object != NULL);
varTablePtr = (object->nsPtr != NULL) ? Tcl_Namespace_varTablePtr(object->nsPtr) : object->varTablePtr;
assert(varTablePtr != NULL);
/*
* Does the variable exist in the object's namespace?
*/
key = Tcl_NewStringObj(varName, TCL_INDEX_NONE);
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), (void *)*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.
*/
const Var *newVar = VarHashCreateVar(varTablePtr, key, &new);
*varPtr = (Tcl_Var)newVar;
}
DECR_REF_COUNT(key);
return likely(*varPtr != NULL) ? TCL_OK : TCL_ERROR;
}
/*********************************************************
*
* Begin of compiled var resolver
*
*********************************************************/
typedef struct NsfResolvedVarInfo {
Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */
NsfObject *lastObject;
Tcl_Var var;
Tcl_Obj *nameObj;
} NsfResolvedVarInfo;
/*
*----------------------------------------------------------------------
* HashVarFree --
*
* Free hashed variables based on refCount.
*
* Results:
* None.
*
* Side effects:
* Changed refCount or freed variable.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static void
HashVarFree(Tcl_Var var) {
if (unlikely(VarHashRefCount(var) < 2)) {
/*fprintf(stderr, "#### free %p\n", (void *)var);*/
ckfree((char *) var);
} else {
VarHashRefCount(var)--;
}
}
/*
*----------------------------------------------------------------------
* CompiledColonVarFetch --
*
* This function is the actual variable resolution handler for a
* colon-prefixed (":/varName/") found in a compiled script
* registered by the compiling var resolver (see
* InterpCompiledColonVarResolver()). When initializing a call
* frame, this handler is called, crawls the object's var table
* (creating a variable, if needed), and returns a Var
* structure. Based on this, a link variable ":/varName/" pointing
* to this object variable (i.e., "varName") is created and is
* stored in the compiled locals array of the call frame. Beware
* that these link variables interact with the family of
* link-creating commands ([variable], [global], [upvar]) by being
* subject to "retargeting" upon name conflicts (see
* tests/varresolutiontest.tcl for some examples).
*
* 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)
nonnull(1) nonnull(2);
static Tcl_Var
CompiledColonVarFetch(Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr) {
NsfResolvedVarInfo *resVarInfo;
NsfCallStackContent *cscPtr;
NsfObject *object;
Tcl_Var var;
nonnull_assert(interp != NULL);
nonnull_assert(vinfoPtr != NULL);
resVarInfo = (NsfResolvedVarInfo *)vinfoPtr;
var = resVarInfo->var;
#if defined(VAR_RESOLVER_TRACE)
{
unsigned int flags = (var != NULL) ? (unsigned int)((Var *)var)->flags : 0u;
fprintf(stderr, "CompiledColonVarFetch var '%s' var %p flags = %.4x dead? %.4x\n",
ObjStr(resVarInfo->nameObj), (void *)var, flags, flags & VAR_DEAD_HASH);
}
#endif
cscPtr = CallStackGetTopFrame0(interp);
if (likely(cscPtr != NULL)) {
object = cscPtr->self;
} else {
object = NULL;
}
/*
* We cache lookups based on nsf objects; we have to care about
* cases, where the instance variables are in some delete states.
*
*/
if ((var != NULL)
&& ((object == resVarInfo->lastObject))
&& (((((Var *)var)->flags) & VAR_DEAD_HASH) == 0u)) {
/*
* The variable is valid.
*/
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, ".... cached var '%s' var %p flags = %.4x\n",
ObjStr(resVarInfo->nameObj), (void *)var, ((Var *)var)->flags);
#endif
/*
* return var;
*/
} else if (unlikely(object == NULL)) {
var = NULL;
} else {
TclVarHashTable *varTablePtr;
int new;
if (var != NULL) {
/*
* The variable is not valid anymore. Clean it up.
*/
HashVarFree(var);
}
if (object->nsPtr != NULL) {
varTablePtr = Tcl_Namespace_varTablePtr(object->nsPtr);
} else if (object->varTablePtr != NULL) {
varTablePtr = object->varTablePtr;
} else {
/*
* In most situations, we have a varTablePtr through the clauses
* above. However, if someone redefines e.g. the method "configure" or
* "objectparameter", we might find an object with a still empty
* varTable, since these are lazy initiated.
*/
varTablePtr = object->varTablePtr = VarHashTableCreate();
}
assert(varTablePtr != NULL);
resVarInfo->lastObject = object;
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "Fetch var %s in object %s\n", TclGetString(resVarInfo->nameObj), ObjectName(object));
#endif
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)
{
const Var *v = (Var *)(resVarInfo->var);
fprintf(stderr, ".... looked up existing var %s var %p flags = %.6x undefined %d\n",
ObjStr(resVarInfo->nameObj),
(void *)v, v->flags,
TclIsVarUndefined(v));
}
#endif
}
return var;
}
/*
*----------------------------------------------------------------------
* CompiledColonVarFree --
*
* DeleteProc of the compiled variable handler.
*
* Results:
* None.
*
* Side effects:
* Free compiled variable structure and variable.
*
*----------------------------------------------------------------------
*/
static void CompiledColonVarFree(Tcl_ResolvedVarInfo *vInfoPtr)
nonnull(1);
static void
CompiledColonVarFree(Tcl_ResolvedVarInfo *vInfoPtr) {
NsfResolvedVarInfo *resVarInfo;
nonnull_assert(vInfoPtr != NULL);
resVarInfo = (NsfResolvedVarInfo *)vInfoPtr;
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "CompiledColonVarFree %p for variable '%s'\n",
(void *)resVarInfo, ObjStr(resVarInfo->nameObj));
#endif
DECR_REF_COUNT(resVarInfo->nameObj);
if (resVarInfo->var != NULL) {
HashVarFree(resVarInfo->var);
}
FREE(NsfResolvedVarInfo, vInfoPtr);
}
/*
*----------------------------------------------------------------------
* InterpCompiledColonVarResolver --
*
* For colon-prefixed (":/varName/") variables, we provide our own
* var resolver for compiling scripts and evaluating compiled
* scripts (e.g., proc bodies). At the time of first compilation
* (or re-compilation), this resolver is processed (see
* tclProc.c:InitResolvedLocals()). It registers two handlers for a
* given, colon-prefixed variable found in the script: the actual
* variable fetcher and a variable cleanup handler. The variable
* fetcher is executed whenever a Tcl call frame is initialized and
* the array of compiled locals is constructed (see also
* InitResolvedLocals()).
*
* The Tcl var resolver protocol dictates that per-namespace
* compiling var resolvers take precedence over this per-interp
* compiling var resolver. That is, per-namespace resolvers are
* processed first and can effectively out-rule per-interp
* resolvers by signaling TCL_OK or TCL_BREAK.
*
* Results:
* TCL_OK or TCL_CONTINUE (according to Tcl's var resolver protocol)
*
* Side effects:
* Registers per-variable resolution and cleanup handlers.
*
*----------------------------------------------------------------------
*/
static int InterpCompiledColonVarResolver(Tcl_Interp *interp, const char *name, TCL_SIZE_T length,
Tcl_Namespace *UNUSED(context), Tcl_ResolvedVarInfo **rPtr)
nonnull(1) nonnull(2) nonnull(5);
static int
InterpCompiledColonVarResolver(Tcl_Interp *interp,
const char *name, TCL_SIZE_T length, Tcl_Namespace *UNUSED(context),
Tcl_ResolvedVarInfo **rPtr) {
/*
* The variable handler is registered, when we have an active Next
* Scripting object and the variable starts with the appropriate
* prefix. Note that getting the "self" object is a weak protection against
* handling of wrong vars
*/
NsfObject *object;
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
nonnull_assert(rPtr != NULL);
object = GetSelfObj(interp);
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "compiled var resolver for %s, obj %p\n", name, (void *)object);
#endif
if (likely(object != NULL) && FOR_COLON_RESOLVER(name)) {
NsfResolvedVarInfo *resVarInfo = NEW(NsfResolvedVarInfo);
resVarInfo->vInfo.fetchProc = CompiledColonVarFetch;
resVarInfo->vInfo.deleteProc = CompiledColonVarFree; /* if NULL, Tcl does a ckfree on proc clean up */
resVarInfo->lastObject = NULL;
resVarInfo->var = NULL;
resVarInfo->nameObj = Tcl_NewStringObj(name+1, (TCL_SIZE_T)length-1);
INCR_REF_COUNT(resVarInfo->nameObj);
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "... resVarInfo %p nameObj %p '%s' obj %p %s\n",
(void *)resVarInfo, (void *)resVarInfo->nameObj, ObjStr(resVarInfo->nameObj),
(void *)object, ObjectName(object));
#endif
*rPtr = (Tcl_ResolvedVarInfo *)resVarInfo;
return TCL_OK;
}
return TCL_CONTINUE;
}
/*
*----------------------------------------------------------------------
* InterpGetFrameAndFlags --
*
* Return for the provided interp the flags of the frame (returned
* as result) and the actual varFrame (returned in the second
* argument). In case, the top-level frame is a LAMBDA frame, skip
* it.
*
* Results:
* Frame flags, varFrame.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static int InterpGetFrameAndFlags(Tcl_Interp *interp, CallFrame **framePtr)
nonnull(1) nonnull(2);
NSF_INLINE static int
InterpGetFrameAndFlags(Tcl_Interp *interp, CallFrame **framePtr) {
int frameFlags;
nonnull_assert(interp != NULL);
nonnull_assert(framePtr != NULL);
*framePtr = Tcl_Interp_varFramePtr(interp);
frameFlags = Tcl_CallFrame_isProcCallFrame(*framePtr);
/*
* If the resolver is called from a lambda frame, use always the parent frame
*/
if ((frameFlags & FRAME_IS_LAMBDA) != 0u) {
*framePtr = (CallFrame *)Tcl_CallFrame_callerPtr(*framePtr);
frameFlags = Tcl_CallFrame_isProcCallFrame(*framePtr);
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "InterpColonVarResolver skip lambda frame flags %.6x\n",
Tcl_CallFrame_isProcCallFrame(*framePtr));
#endif
}
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "... final frame flags %.6x\n", frameFlags);
#endif
return frameFlags;
}
/*
*----------------------------------------------------------------------
* InterpColonVarResolver --
*
* For accessing object (instance) variables using the colon-prefix
* notation (":/varName/"), we provide our own var resolvers. This
* function is the non-compiling var resolver; its services are
* requested in two situations: a) when evaluating non-compiled
* statements, b) when executing slow-path bytecode instructions,
* with "slow path" referring to bytecode instructions not making
* use of the compiled locals array (and, e.g., reverting to
* TclObjLookupVar*() calls).
*
* The Tcl variable resolver protocol dictates that per-namespace,
* non-compiling var resolvers take precedence over this per-interp
* non-compiling var resolver. That is, per-namespace resolvers are
* processed first and can effectively out-rule per-interp
* resolvers by signaling TCL_OK or TCL_BREAK. See
* e.g. TclLookupSimpleVar().
*
* Results:
* TCL_OK or TCL_CONTINUE (according to 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 *UNUSED(nsPtr),
int flags, Tcl_Var *varPtr)
nonnull(1) nonnull(2) nonnull(5);
static int
InterpColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
int flags, Tcl_Var *varPtr) {
int new;
unsigned int frameFlags;
CallFrame *varFramePtr;
TclVarHashTable *varTablePtr;
NsfObject *object;
Tcl_Obj *keyObj;
Tcl_Var var;
nonnull_assert(interp != NULL);
nonnull_assert(varName != NULL);
nonnull_assert(varPtr != NULL);
if (!FOR_COLON_RESOLVER(varName) || (flags & (TCL_NAMESPACE_ONLY)) != 0u) {
/*
* Ordinary names (not starting with our prefix) and namespace only
* lookups are not for us. We cannot filter for TCL_GLOBAL_ONLY, since
* "vwait :varName" is called with this flag.
*/
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "InterpColonVarResolver '%s' flags %.6x not for us\n",
varName, flags);
#endif
return TCL_CONTINUE;
}
frameFlags = (unsigned int)InterpGetFrameAndFlags(interp, &varFramePtr);
if (likely((frameFlags & FRAME_IS_NSF_METHOD) != 0u)) {
/* varPtr = CompiledLocalsLookup(varFramePtr, varName);
fprintf(stderr, "CompiledLocalsLookup for %p %s returned %p\n",
(void *)varFramePtr, varName, (void *)*varPtr);
*/
if ((*varPtr = CompiledColonLocalsLookup(varFramePtr, varName))) {
/*
* This section is reached under notable circumstances and represents a
* point of interaction between our resolvers for non-compiled (i.e.,
* InterpColonVarResolver()) and compiled script execution (i.e.,
* InterpCompiledColonVarResolver()).
*
* Expect this branch to be hit iff...
*
* 1. ... InterpCompiledColonVarResolver() is called from within the Tcl
* bytecode interpreter when executing a bytecode-compiled script on a
* *slow path* (i.e., involving a TclObjLookupVarEx() call)
*
* 2. ... the act of variable resolution (i.e., TclObjLookupVarEx()) has
* not been restricted to an effective namespace (TCL_NAMESPACE_ONLY)
*
* 3. ..., resulting from the fact of participating in a bytecode
* interpretation, CompiledColonVarFetch() stored a link variable
* (pointing to the actual/real object variable, whether defined or not)
* under the given varName value into the current call frame's array of
* compiled locals (when initializing the call frame; see
* tclProc.c:InitResolvedLocals()).
*/
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, ".... found local %s varPtr %p flags %.6x\n",
varName, (void *)*varPtr, flags);
#endif
/*
* By looking up the compiled-local directly and signaling TCL_OK, we
* optimize a little by avoiding further lookups down the Tcl var
* resolution infrastructure. Note that signaling TCL_CONTINUE would
* work too, however, it would involve extra resolution overhead.
*/
return TCL_OK;
}
object = ((NsfCallStackContent *)varFramePtr->clientData)->self;
} else if ((frameFlags & FRAME_IS_NSF_CMETHOD) != 0u) {
object = ((NsfCallStackContent *)varFramePtr->clientData)->self;
} else if ((frameFlags & FRAME_IS_NSF_OBJECT) != 0u) {
object = (NsfObject *)(varFramePtr->clientData);
} else {
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, ".... not found %s\n", varName);
#endif
return TCL_CONTINUE;
}
/*
* Trim the varName for the colon prefix (":").
*/
varName ++;
/*
* We have an object and create the variable if not found
*/
assert(object != NULL);
if (unlikely(object->nsPtr != NULL)) {
varTablePtr = Tcl_Namespace_varTablePtr(object->nsPtr);
} else if (likely(object->varTablePtr != NULL)) {
varTablePtr = object->varTablePtr;
} else {
/*
* In most situations, we have a varTablePtr through the clauses
* above. However, if someone redefines e.g. the method "configure" or
* "objectparameter", we might find an object with a still empty
* varTable, since these are lazy initiated.
*/
varTablePtr = object->varTablePtr = VarHashTableCreate();
}
assert(varTablePtr != NULL);
/*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTablePtr %p\n",
varName, (void *)object, (void *)object->nsPtr, (void *)varTablePtr);*/
keyObj = Tcl_NewStringObj(varName, TCL_INDEX_NONE);
INCR_REF_COUNT(keyObj);
var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, NULL);
if (likely(var != NULL)) {
#if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, ".... found in hash-table %s %p flags %.6x ns %p\n",
varName, (void *)var, ((Var *)var)->flags, (void *)object->nsPtr);
#endif
/*
* Make coverage analysis easier.
*/
assert(1);
} 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 hash-table %p\n", (void *)var, varName, (void *)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 Next
* Scripting specific prefix and we are on a Next Scripting 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 *UNUSED(nsPtr),
unsigned int flags, Tcl_Command *cmdPtr)
nonnull(1) nonnull(2) nonnull(5);
static int
InterpColonCmdResolver(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *UNUSED(nsPtr),
unsigned int flags, Tcl_Command *cmdPtr) {
CallFrame *varFramePtr;
unsigned int frameFlags;
nonnull_assert(interp != NULL);
nonnull_assert(cmdName != NULL);
nonnull_assert(cmdPtr != NULL);
/* fprintf(stderr, "InterpColonCmdResolver %s flags %.6x\n", cmdName, flags); */
if (likely((*cmdName == ':' && *(cmdName + 1) == ':') || (flags & TCL_GLOBAL_ONLY) != 0u)) {
/* fully qualified names and global lookups are not for us */
/*fprintf(stderr, "... not for us %s flags %.6x\n", cmdName, flags);*/
return TCL_CONTINUE;
}
frameFlags = (unsigned int)InterpGetFrameAndFlags(interp, &varFramePtr);
/*
* The resolver is called as well, when a body of a method is
* compiled. In these situations, Tcl stacks a non-proc frame, that
* we have to skip. In order to safely identify such situations, we
* stuff into the call flags of the proc frame during the
* compilation step NSF_CSC_CALL_IS_COMPILE.
*/
if ((frameFlags == 0u) && (Tcl_CallFrame_callerPtr(varFramePtr) != NULL)) {
ClientData clientData;
varFramePtr = (CallFrame *)Tcl_CallFrame_callerPtr(varFramePtr);
frameFlags = (unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr);
clientData = varFramePtr->clientData;
if ( (frameFlags != 0u)
&& (clientData != NULL)
&& ((((NsfCallStackContent *)clientData)->flags & NSF_CSC_CALL_IS_COMPILE) == 0u)
) {
frameFlags = 0u;
} else {
#if defined(CMD_RESOLVER_TRACE)
fprintf(stderr, "InterpColonCmdResolver got parent frame cmdName %s flags %.6x, frame flags %.6x\n",
cmdName, flags, Tcl_CallFrame_isProcCallFrame(varFramePtr));
#endif
}
}
#if defined(CMD_RESOLVER_TRACE)
fprintf(stderr, "InterpColonCmdResolver cmdName %s flags %.6x, frame flags %.6x\n",
cmdName, flags, frameFlags);
#endif
if ((frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_OBJECT|FRAME_IS_NSF_CMETHOD)) != 0u) {
if (*cmdName == ':') {
#if defined(CMD_RESOLVER_TRACE)
fprintf(stderr, " ... call colonCmd for %s\n", cmdName);
#endif
/*
* We have a cmd starting with ':', we are in an NSF frame, so
* forward to the colonCmd.
*/
*cmdPtr = RUNTIME_STATE(interp)->colonCmd;
return TCL_OK;
} else {
#if defined(NSF_WITH_OS_RESOLVER)
/*
* Experimental Object-System specific resolver: If an un-prefixed
* method name is found in a body of a method, we try to perform a
* lookup for this method in the namespace of the object system for the
* current object. If this lookup is not successful the standard lookups
* are performed. The object-system specific resolver allows one to use
* the "right" (un-prefixed) "self" or "next" calls without namespace
* imports.
*/
NsfObject *object;
NsfObjectSystem *osPtr;
if ((frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) {
const NsfCallStackContent *cscPtr = (NsfCallStackContent *)varFramePtr->clientData;
assert(cscPtr != NULL);
object = cscPtr->self;
} else if ((frameFlags & (FRAME_IS_NSF_OBJECT)) != 0u) {
object = (NsfObject *)(varFramePtr->clientData);
} else {
object = NULL;
}
if (object != NULL) {
Tcl_HashEntry *entryPtr;
Tcl_HashTable *cmdTablePtr;
Tcl_Command cmd;
osPtr = GetObjectSystem(object);
cmd = osPtr->rootClass->object.id;
cmdTablePtr = Tcl_Namespace_cmdTablePtr(((Command *)cmd)->nsPtr);
entryPtr = Tcl_CreateHashEntry(cmdTablePtr, cmdName, NULL);
/*fprintf(stderr, "InterpColonCmdResolver OS specific resolver tried to lookup %s for os %s in ns %s\n",
cmdName, ClassName(osPtr->rootClass), ((Command *)cmd)->nsPtr->fullName);*/
if (entryPtr != NULL) {
/*fprintf(stderr, "InterpColonCmdResolver OS specific resolver found %s::%s frameFlags %.6x\n",
((Command *)cmd)->nsPtr->fullName, cmdName, frameFlags);*/
*cmdPtr = Tcl_GetHashValue(entryPtr);
return TCL_OK;
}
}
#endif
}
}
#if defined(CMD_RESOLVER_TRACE)
fprintf(stderr, " ... not found %s\n", cmdName);
NsfShowStack(interp);
#endif
return TCL_CONTINUE;
}
/*********************************************************
*
* End of cmd resolver
*
*********************************************************/
/*
*----------------------------------------------------------------------
* NsfNamespaceInit --
*
* Initialize a provided namespace by setting its resolvers and
* namespace path
*
* Results:
* None.
*
* Side effects:
* Change behavior of NSF resolving.
*
*----------------------------------------------------------------------
*/
static void NsfNamespaceInit(Tcl_Namespace *nsPtr)
nonnull(1);
static void
NsfNamespaceInit(Tcl_Namespace *nsPtr) {
nonnull_assert(nsPtr != NULL);
/*
* 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(nsPtr,
(Tcl_ResolveCmdProc *)NULL,
NsColonVarResolver,
(Tcl_ResolveCompiledVarProc *)NULL);
#if defined(NSF_WITH_INHERIT_NAMESPACES)
/*
* In case there is a namespace path set for the parent namespace,
* apply this as well to the object namespace to avoid surprises
* with "namespace path nx".
*/
{ Namespace *parentNsPtr = Tcl_Namespace_parentPtr(nsPtr);
int pathLength = Tcl_Namespace_commandPathLength(parentNsPtr);
if (pathLength > 0) {
Namespace **pathArray = (Namespace **)ckalloc((int)sizeof(Namespace *) * pathLength);
NamespacePathEntry *tmpPathArray = Tcl_Namespace_commandPathArray(parentNsPtr);
int i;
for (i = 0; i < pathLength; i++) {
pathArray[i] = tmpPathArray[i].nsPtr;
}
TclSetNsPath((Namespace *)nsPtr, pathLength, (Tcl_Namespace **)pathArray);
ckfree((char *)pathArray);
}
}
#endif
}
static NsfObject *NSNamespaceClientDataObject(ClientData clientData) nonnull(1) NSF_pure;
static NsfObject *
NSNamespaceClientDataObject(ClientData clientData) {
#ifdef NSF_MEM_COUNT
NsfNamespaceClientData *nsClientData = (NsfNamespaceClientData *)clientData;
nonnull_assert(clientData != NULL);
/*fprintf(stderr, "NSNamespaceDeleteProc cd %p\n", (void *)clientData);
fprintf(stderr, "... nsPtr %p name '%s'\n", (void *)nsClientData->nsPtr, nsClientData->nsPtr->fullName);*/
return nsClientData->object;
#else
nonnull_assert(clientData != NULL);
return (NsfObject *) clientData;
#endif
}
/*
*----------------------------------------------------------------------
* SlotContainerCmdResolver --
*
* This is a specialized cmd resolver for slotcontainer. The
* command resolver should be registered for a namespace and avoids
* the lookup of childobjs for unqualified calls. This way, it is
* e.g. possible to call in a slot-obj a method [list], even in
* cases, where a property "list" is defined.
*
* Results:
* Either TCL_CONTINUE or TCL_OK.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int SlotContainerCmdResolver(Tcl_Interp *interp, const char *cmdName,
Tcl_Namespace *nsPtr, unsigned int flags, Tcl_Command *cmdPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static int
SlotContainerCmdResolver(Tcl_Interp *interp, const char *cmdName,
Tcl_Namespace *nsPtr, unsigned int flags, Tcl_Command *cmdPtr) {
nonnull_assert(cmdName != NULL);
nonnull_assert(nsPtr != NULL);
nonnull_assert(cmdPtr != NULL);
if (*cmdName == ':' || ((flags & TCL_GLOBAL_ONLY) != 0u)) {
/*
* Colon names (InterpColonCmdResolver) and global lookups are not for us.
*/
return TCL_CONTINUE;
}
/*fprintf(stderr, "SlotContainerCmdResolver called with %s ns %s ourNs %d clientData %p\n",
cmdName, nsPtr->fullName, nsPtr->deleteProc == NSNamespaceDeleteProc,
(void *)nsPtr->clientData);*/
/*
* Check whether this already a namespace handled by NSF
*/
if (nsPtr->deleteProc == NSNamespaceDeleteProc && nsPtr->clientData) {
NsfObject *parentObject = NSNamespaceClientDataObject(nsPtr->clientData);
/*fprintf(stderr, "SlotContainerCmdResolver parentObject %p %s\n",
(void *)parentObject, ObjectName(parentObject));*/
/*
* Make global lookups when the parent is a slotcontainer
*/
/* parentObject = (NsfObject *) GetObjectFromString(interp, nsPtr->fullName);*/
if ((parentObject->flags & NSF_IS_SLOT_CONTAINER) != 0u) {
Tcl_Command cmd = Tcl_FindCommand(interp, cmdName, NULL, TCL_GLOBAL_ONLY);
if (likely(cmd != NULL)) {
*cmdPtr = cmd;
return TCL_OK;
}
}
}
return TCL_CONTINUE;
}
/*
*----------------------------------------------------------------------
* RequireObjNamespace --
*
* Obtain for an object a namespace if necessary and initialize it.
* In this function, variables existing outside of the namespace
* get copied over to the fresh namespace.
*
* Results:
* Tcl_Namespace
*
* Side effects:
* Allocate potentially a Tcl_Namespace
*
*----------------------------------------------------------------------
*/
static Tcl_Namespace *
RequireObjNamespace(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (object->nsPtr == NULL) {
MakeObjNamespace(interp, object);
NsfNamespaceInit(object->nsPtr);
}
assert(object->nsPtr != NULL);
return object->nsPtr;
}
/*
* Namespace related commands
*/
/*
*----------------------------------------------------------------------
* NSNamespacePreserve --
*
* Increment namespace refCount
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
NSNamespacePreserve(Tcl_Namespace *nsPtr) {
nonnull_assert(nsPtr != NULL);
MEM_COUNT_ALLOC("NSNamespace", nsPtr);
Tcl_Namespace_refCount(nsPtr)++;
}
/*
*----------------------------------------------------------------------
* NSNamespaceRelease --
*
* Decrement namespace's "refCount" and free namespace if
* necessary.
*
* Results:
* None.
*
* Side effects:
* Free potentially memory.
*
*----------------------------------------------------------------------
*/
static void
NSNamespaceRelease(Tcl_Namespace *nsPtr) {
nonnull_assert(nsPtr != NULL);
MEM_COUNT_FREE("NSNamespace", nsPtr);
Tcl_Namespace_refCount(nsPtr)--;
if (unlikely(Tcl_Namespace_refCount(nsPtr) == 0 && (Tcl_Namespace_flags(nsPtr) & NS_DEAD))) {
/*
* The namespace "refCount" has reached 0, we have to free
* it. Unfortunately, NamespaceFree() is not exported.
*/
/*fprintf(stderr, "HAVE TO FREE namespace %p\n", (void *)nsPtr); */
/*NamespaceFree(nsPtr);*/
ckfree(nsPtr->fullName);
ckfree(nsPtr->name);
ckfree((char *)nsPtr);
}
}
/*
*----------------------------------------------------------------------
* NSDeleteCmd --
*
* Delete the Tcl command for the provided methodName located in
* the provided namespace.
*
* Results:
* Tcl result or -1, if no such method exists int.
*
* Side effects:
* Command is deleted.
*
*----------------------------------------------------------------------
*/
static int
NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *methodName) {
Tcl_Command token;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
nonnull_assert(methodName != NULL);
if ((token = FindMethod(nsPtr, methodName))) {
return Tcl_DeleteCommandFromToken(interp, token);
}
return -1;
}
/*
*----------------------------------------------------------------------
* NSDeleteChild --
*
* Delete a child of an object in cases, when the parent object is
* deleted. It is designed to delete either objects or classes to
* be a little bit more graceful on destructors. Not perfect yet.
*
* Results:
* Boolean value indicating success.
*
* Side effects:
* Might destroy an object.
*
*----------------------------------------------------------------------
*/
static bool NSDeleteChild(Tcl_Interp *interp, Tcl_Command cmd, bool deleteObjectsOnly)
nonnull(1) nonnull(2);
static bool
NSDeleteChild(Tcl_Interp *interp, Tcl_Command cmd, bool deleteObjectsOnly) {
bool deleted;
nonnull_assert(cmd != NULL);
nonnull_assert(interp != NULL);
/*fprintf(stderr, "NSDeleteChildren child %p flags %.6x epoch %d\n",
(void *)cmd, Tcl_Command_flags(cmd), Tcl_Command_cmdEpoch(cmd));*/
/*
* In some situations (e.g. small buckets, less than 12 entries), we
* get from the cmd-table already deleted cmds; we had previously an
* assert(Tcl_Command_cmdEpoch(cmd) == 0);
* which will fail in such cases.
*/
if (Tcl_Command_cmdEpoch(cmd) != 0) {
deleted = NSF_FALSE;
} else {
NsfObject *object = NsfGetObjectFromCmdPtr(cmd);
/*fprintf(stderr, "NSDeleteChildren child %p (%s) epoch %d\n",
(void *)cmd, Tcl_GetCommandName(interp, cmd), Tcl_Command_cmdEpoch(cmd));*/
if (object == NULL) {
/*
* This is just a plain Tcl command; let Tcl handle the
* deletion.
*/
deleted = NSF_FALSE;
} else if (object->id == cmd) {
/*
* delete here just true children
*/
if (deleteObjectsOnly && NsfObjectIsClass(object)) {
deleted = NSF_FALSE;
} else if (RUNTIME_STATE(interp)->exitHandlerDestroyRound
== NSF_EXITHANDLER_ON_PHYSICAL_DESTROY) {
/*
* in the exit handler physical destroy --> directly call destroy
*/
PrimitiveDestroy(object);
deleted = NSF_TRUE;
} else {
if (object->teardown && ((object->flags & NSF_DESTROY_CALLED) == 0u)) {
int result;
NsfObjectRefCountIncr(object);
result = DispatchDestroyMethod(interp, object, 0u);
if (unlikely(result != TCL_OK) && object->teardown != NULL) {
/*
* The destroy method failed. However, we have to remove
* the command anyway, since its parent is currently being
* deleted.
*/
/*fprintf(stderr, "==== NSDeleteChild DispatchDestroyMethod FAILED object %p (cmd %p) id %p teardown %p flags %.6x\n",
(void *)object, (void *)cmd, (void *)object->id, (void *)object->teardown, object->flags);*/
NsfLog(interp, NSF_LOG_NOTICE, "Destroy failed for object %s %p %.6x, perform low-level deletion",
(object->flags & NSF_DURING_DELETE) == NSF_DURING_DELETE ? "deleted-object" : ObjectName_(object),
(void*)object, object->flags);
CallStackDestroyObject(interp, object);
}
NsfCleanupObject(object, "NSDeleteChild");
deleted = NSF_TRUE;
} else {
deleted = NSF_FALSE;
}
}
} else {
/*fprintf(stderr, "NSDeleteChild remove alias %p %s\n", (void*)object, Tcl_GetCommandName(interp, cmd));*/
deleted = AliasDeleteObjectReference(interp, cmd);
}
}
return deleted;
}
/*
*----------------------------------------------------------------------
* NSDeleteChildren --
*
* Delete the child objects of a namespace.
*
* Results:
* None.
*
* Side effects:
* Might destroy child objects.
*
*----------------------------------------------------------------------
*/
static void NSDeleteChildren(Tcl_Interp *interp, const Tcl_Namespace *nsPtr)
nonnull(1) nonnull(2);
static void
NSDeleteChildren(Tcl_Interp *interp, const Tcl_Namespace *nsPtr) {
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
TCL_SIZE_T expected;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
#ifdef OBJDELETION_TRACE
fprintf(stderr, "NSDeleteChildren %p %s activationCount %d\n",
(void *)nsPtr, nsPtr->fullName, Tcl_Namespace_activationCount(nsPtr));
#endif
/*
* First, get rid of namespace imported objects; don't delete the
* object, but the reference.
*/
Tcl_ForgetImport(interp, (Tcl_Namespace*)nsPtr, "*"); /* don't destroy namespace imported objects */
#if defined(OBJDELETION_TRACE)
/*
* Deletion is always tricky. Show, what elements should be deleted
* in this loop. The actually deleted elements might be actually
* less, if a deletion of one item triggers the destroy of another
* item.
*/
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
fprintf(stderr, "will destroy %p %s\n", (void *)cmd, Tcl_GetCommandName(interp, cmd));
}
#endif
/*
* Second, delete the objects.
*/
/*
* A destroy of one element of the hash-table can trigger the
* destroy of another item of the same table. Therefore, we use
* Nsf_NextHashEntry(), which handles this case.
*/
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
hPtr != NULL;
hPtr = Nsf_NextHashEntry(cmdTablePtr, expected, &hSrch)) {
/*Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
fprintf(stderr, "NSDeleteChild %p table %p numEntries before %d\n",
cmd, hPtr->tablePtr, cmdTablePtr->numEntries );*/
expected = (NSDeleteChild(interp, (Tcl_Command)Tcl_GetHashValue(hPtr), NSF_TRUE)
? cmdTablePtr->numEntries - 1
: cmdTablePtr->numEntries);
}
/*
* Finally, delete the classes.
*/
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
hPtr != NULL;
hPtr = Nsf_NextHashEntry(cmdTablePtr, expected, &hSrch)) {
expected = (NSDeleteChild(interp, (Tcl_Command)Tcl_GetHashValue(hPtr), NSF_FALSE)
? cmdTablePtr->numEntries - 1
: cmdTablePtr->numEntries);
}
}
/*
*----------------------------------------------------------------------
* UnsetTracedVars --
*
* This is a helper function which, as a first pass, attempts to
* unset traced object variables before TclDeleteVars() performs a
* second pass. This two-pass deletion of object variables is
* necessary because an unset trace might bring back the object
* variable currently being deleted. A single pass risks leaking
* so-revived Var structures. TclDeleteVars() requires variables
* under deletion to be untraced.
*
* As Tcl does not provide access to the necessary lower-level Var
* API to extensions (ideally: TclDeleteNamespaceVars or
* TclPtrUnsetVar), we resort to a mix of navigating the variable
* table and calling high-level unset operations (UnsetInstVar).
*
* With the fix to ticket
* https://core.tcl-lang.org/tcl/info/4dbdd9af144dbdd9af14, Tcl
* itself provides for two deletion passes for namespace variables
* (see TclDeleteNamespaceVars).
*
* Results:
* None.
*
* Side effects:
* Triggers the unset traces, if any.
*
*----------------------------------------------------------------------
*/
static void UnsetTracedVars(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void
UnsetTracedVars(
Tcl_Interp *interp, /* Interpreter to which object belongs. */
NsfObject *object) /* Object to which variables belong. */
{
Tcl_HashSearch search;
TclVarHashTable *varTablePtr;
Interp *iPtr = (Interp *)interp;
varTablePtr = (object->nsPtr != NULL) ?
Tcl_Namespace_varTablePtr(object->nsPtr) :
object->varTablePtr;
if (varTablePtr != NULL) {
Tcl_HashEntry *entryPtr;
for (entryPtr = Tcl_FirstHashEntry((Tcl_HashTable *)varTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Obj *nameObj;
Var *varPtr;
GetVarAndNameFromHash(entryPtr, &varPtr, &nameObj);
if ((varPtr->flags & VAR_TRACED_UNSET) != 0u /* TclIsVarTraced(varPtr) */) {
VarHashRefCount(varPtr)++;
(void)UnsetInstVar(interp, 1 /* no error msg */, object, ObjStr(nameObj));
/*
* The variable might have been brought back by an unset trace, plus
* newly created unset traces; deactivate *all* traces on revived
* vars.
*/
if (TclIsVarTraced(varPtr)) {
Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (const char *)varPtr);
VarTrace *tracePtr = Tcl_GetHashValue(tPtr);
ActiveVarTrace *activePtr;
while (tracePtr != NULL) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
}
Tcl_DeleteHashEntry(tPtr);
varPtr->flags &= ~VAR_ALL_TRACES;
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
VarHashRefCount(varPtr)--;
}
}
}
}
/*
*----------------------------------------------------------------------
* NSCleanupNamespace --
*
* Cleans up an object or class namespace by deleting 1) its
* variables, 2) resetting the var table, and 3) deleting
* user-defined namespace procs.
*
* For namespaces holding variables with possible unset traces,
* make sure that UnsetTracedVars is called just before
* NSCleanupNamespace().
*
* Results:
* None.
*
* Side effects:
* Re-initializes the variable table of the cleaned-up namespace
* (TclInitVarHashTable).
*
*----------------------------------------------------------------------
*/
static void NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
nonnull(1) nonnull(2);
static void
NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) {
TclVarHashTable *varTablePtr;
Tcl_HashTable *cmdTablePtr;
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
varTablePtr = Tcl_Namespace_varTablePtr(nsPtr);
cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
#ifdef OBJDELETION_TRACE
fprintf(stderr, "NSCleanupNamespace %p flags %.6x\n", (void *)nsPtr, Tcl_Namespace_flags(nsPtr));
fprintf(stderr, "NSCleanupNamespace %p %.6x varTablePtr %p\n", (void *)nsPtr,
((Namespace *)nsPtr)->flags, (void *)varTablePtr);
#endif
/*
* Delete all variables and initialize var table again (TclDeleteVars frees
* the var table). Any unset-traced variable has been deleted before
* (UnsetTracedVars).
*/
TclDeleteVars((Interp *)interp, varTablePtr);
TclInitVarHashTable(varTablePtr, (Namespace *)nsPtr);
/*
* Delete all user-defined procs in the namespace
*/
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(hPtr);
if (CmdIsNsfObject(cmd)) {
/*
* Sub-objects should not be deleted here to preserve children
* deletion order. Just delete aliases.
*/
AliasDeleteObjectReference(interp, cmd);
continue;
}
/*fprintf(stderr, "NSCleanupNamespace calls DeleteCommandFromToken for %p flags %.6x\n",
cmd, ((Command *)cmd)->flags);
fprintf(stderr, " cmd = %s\n", Tcl_GetCommandName(interp, cmd));
fprintf(stderr, " nsPtr = %p\n", ((Command *)cmd)->nsPtr);
fprintf(stderr, " epoch = %d\n", Tcl_Command_cmdEpoch(cmd));
fprintf(stderr, " refCount = %d\n", Tcl_Command_refCount(cmd));
fprintf(stderr, " flags %.6x\n", ((Namespace *)((Command *)cmd)->nsPtr)->flags);*/
Tcl_DeleteCommandFromToken(interp, cmd);
}
}
static void
NSNamespaceDeleteProc(ClientData clientData) {
NsfObject *object;
nonnull_assert(clientData != NULL);
object = NSNamespaceClientDataObject(clientData);
assert(object != NULL);
#ifdef NSF_MEM_COUNT
ckfree((char *)clientData);
#endif
/*fprintf(stderr, "namespace delete-proc obj=%p ns=%p\n",
clientData, (object != NULL) ? object->nsPtr : NULL);*/
MEM_COUNT_FREE("NSNamespace", object->nsPtr);
object->nsPtr = NULL;
}
void Nsf_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
nonnull(1) nonnull(2);
void
Nsf_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) {
#if defined(NSF_DEVELOPMENT_TEST)
int activationCount = 0;
Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp);
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
/*fprintf(stderr, "Nsf_DeleteNamespace %p ", nsPtr);*/
while (f != NULL) {
if (f->nsPtr == nsPtr) {
activationCount++;
}
f = Tcl_CallFrame_callerPtr(f);
}
if (Tcl_Namespace_activationCount(nsPtr) != activationCount) {
fprintf(stderr, "WE HAVE TO FIX ACTIVATIONCOUNT\n");
Tcl_Namespace_activationCount(nsPtr) = activationCount;
}
assert(Tcl_Namespace_activationCount(nsPtr) == activationCount);
/*fprintf(stderr, "to %d. \n", ((Namespace *)nsPtr)->activationCount);*/
#else
(void)interp;
#endif
if (Tcl_Namespace_deleteProc(nsPtr)) {
/*fprintf(stderr, "calling deteteNamespace %s\n", nsPtr->fullName);*/
Tcl_DeleteNamespace(nsPtr);
}
}
/*
*----------------------------------------------------------------------
* NSValidObjectName --
*
* Check the provided colons in an object name. If the name is
* valid, the function NSF_TRUE.
*
* Results:
* Returns boolean value indicating success.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static bool NSValidObjectName(const char *name, size_t l)
nonnull(1) NSF_pure;
NSF_INLINE static bool
NSValidObjectName(const char *name, size_t l) {
register const char *n;
bool result = NSF_TRUE;
nonnull_assert(name != NULL);
n = name;
if (*n == '\0') {
result = NSF_FALSE; /* empty name */
} else {
/*
* Compute size if not given.
*/
if (l == 0) {
l = strlen(n);
}
/*
* Check string
*/
if (*(n+l-1) == ':') {
result = NSF_FALSE; /* name ends with : */
} else if (*n == ':' && *(n+1) != ':') {
result = NSF_FALSE; /* name begins with single : */
} else {
for (; *n != '\0'; n++) {
if (*n == ':' && *(n+1) == ':' && *(n+2) == ':') {
result = NSF_FALSE; /* more than 2 colons in series in a name */
break;
}
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
* NSGetFreshNamespace --
*
* Create an object namespace, provide a deleteProc (avoid
* interference between object and namespace deletion order) and
* keep the object as client data.
*
* Results:
* Tcl_Namespace
*
* Side effects:
* Might allocate a namespace.
*
*----------------------------------------------------------------------
*/
static Tcl_Namespace*
NSGetFreshNamespace(Tcl_Interp *interp, NsfObject *object, const char *name) {
Namespace *dummy1Ptr, *dummy2Ptr, *nsPtr;
const char *dummy;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(name != NULL);
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS|TCL_CREATE_NS_IF_UNKNOWN,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if (nsPtr->deleteProc != NSNamespaceDeleteProc) {
/*
* Avoid hijacking a namespace with different client data
*/
if (nsPtr->deleteProc || nsPtr->clientData) {
Tcl_Panic("Namespace '%s' exists already with delProc 0x%" PRIxPTR " and clientData %p; "
"Can only convert a plain Tcl namespace into an NSF namespace, my delete proc 0x%" PRIxPTR,
name, (unsigned long)PTR2UINT(nsPtr->deleteProc),
nsPtr->clientData, (unsigned long)PTR2UINT(NSNamespaceDeleteProc));
}
{
#ifdef NSF_MEM_COUNT
NsfNamespaceClientData *nsClientData = (NsfNamespaceClientData *)ckalloc((int)sizeof(NsfNamespaceClientData));
nsClientData->object = object;
nsClientData->nsPtr = (Tcl_Namespace *)nsPtr;
nsPtr->clientData = nsClientData;
/*fprintf(stderr, "Adding NsfNamespaceClientData nsPtr %p cd %p name '%s'\n",
nsPtr, nsClientData, nsPtr->fullName);*/
#else
nsPtr->clientData = object;
#endif
nsPtr->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc;
}
MEM_COUNT_ALLOC("NSNamespace", nsPtr);
} else {
fprintf(stderr, "NSGetFreshNamespace: reusing namespace %p %s\n", (void *)nsPtr, nsPtr->fullName);
}
return (Tcl_Namespace *)nsPtr;
}
/*
*----------------------------------------------------------------------
* NSRequireParentObject --
*
* Try to require a parent object (e.g. during ttrace). This function
* tries to load a parent object via ::nsf::object::unknown.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Might create an object.
*
*----------------------------------------------------------------------
*/
static int NSRequireParentObject(Tcl_Interp *interp, const char *parentName)
nonnull(1) nonnull(2);
static int
NSRequireParentObject(Tcl_Interp *interp, const char *parentName) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(parentName != NULL);
result = NsfCallObjectUnknownHandler(interp, Tcl_NewStringObj(parentName, TCL_INDEX_NONE));
if (likely(result == TCL_OK)) {
NsfObject *parentObj = (NsfObject *)GetObjectFromString(interp, parentName);
if (parentObj != NULL) {
RequireObjNamespace(interp, parentObj);
}
result = (Tcl_FindNamespace(interp, parentName,
(Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != NULL
? TCL_OK: TCL_ERROR);
}
return result;
}
/*
*----------------------------------------------------------------------
* NSCheckNamespace --
*
* Check whether a namespace with the given name exists. If not,
* make sure that a potential parent object has already required a
* namespace. If there is no parent namespace yet, try to create a
* parent object via __unknown.
*
* If the provided parentNsPtr is not NULL, we know, that (a) the
* provided name was relative and simple (contains no ":"
* characters) and that (b) this namespace was used to build a
* fully qualified name. In these cases, the parentNsPtr points
* already to the parentName, containing potentially a parent
* Object. In all other cases, the parent name is either obtained
* from the full namespace, or from string operations working on
* the provided name.
*
* Results:
* Tcl_Namespace for the provided name.
*
* Side effects:
* Might create parent objects.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static Tcl_Namespace *NSCheckNamespace(
Tcl_Interp *interp, const char *nameString, Tcl_Namespace *parentNsPtr1
) nonnull(1) nonnull(2);
NSF_INLINE static Tcl_Namespace *
NSCheckNamespace(
Tcl_Interp *interp, const char *nameString, Tcl_Namespace *parentNsPtr1
) {
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr, *parentNsPtr = (Namespace *)parentNsPtr1;
const char *parentName, *dummy;
Tcl_DString ds, *dsPtr = &ds;
nonnull_assert(interp != NULL);
nonnull_assert(nameString != NULL);
/*fprintf(stderr, "NSCheckNamespace %s parentNsPtr %p\n", nameString, parentNsPtr);*/
/*
* Check whether there is an already a namespace for the full name. The
* namespace will be only in rare cases, but we have to make this check in
* every case. If there is a full namespace, we can use it to determine the
* parent name.
*/
TclGetNamespaceForQualName(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
/*fprintf(stderr,
"before create calls TclGetNamespaceForQualName with %s => %p (%s) %p %s %p %s %p %s\n",
nameString, nsPtr, (nsPtr != NULL) ? nsPtr->fullName : "",
dummy1Ptr, (dummy1Ptr != NULL) ? dummy1Ptr->fullName : "",
parentNsPtr, (parentNsPtr != NULL) ? parentNsPtr->fullName : "",
dummy, (dummy != NULL) ? dummy : "");*/
/*
* If there is a parentNs provided (or obtained from the full
* namespace), we can determine the parent name from it. Otherwise,
* we have to perform the string operations.
*/
if (parentNsPtr == NULL && nsPtr != NULL) {
parentNsPtr = Tcl_Namespace_parentPtr(nsPtr);
}
if (parentNsPtr != NULL) {
parentName = parentNsPtr->fullName;
if (*(parentName + 2) == '\0') {
parentName = NULL;
}
/*fprintf(stderr, "NSCheckNamespace parentNs %s parentName of '%s' => '%s'\n",
parentNsPtr->fullName, nameString, parentName);*/
} else {
TCL_SIZE_T parentNameLength;
const char *n = nameString + strlen(nameString);
/*
* search for last '::'
*/
while ((*n != ':' || *(n-1) != ':') && n-1 > nameString) {
n--;
}
if (*n == ':' && n > nameString && *(n-1) == ':') {
n--;
}
parentNameLength = (TCL_SIZE_T)(n - nameString);
if (parentNameLength > 0) {
DSTRING_INIT(dsPtr);
Tcl_DStringAppend(dsPtr, nameString, parentNameLength);
parentName = Tcl_DStringValue(dsPtr);
DSTRING_FREE(dsPtr);
} else {
parentName = NULL;
}
}
if (parentName != NULL) {
NsfObject *parentObj;
parentObj = (NsfObject *) GetObjectFromString(interp, parentName);
/*fprintf(stderr, "parentName %s parentObj %p\n", parentName, parentObj);*/
if (parentObj != NULL) {
RequireObjNamespace(interp, parentObj);
} else if (nsPtr == NULL && parentNsPtr == NULL) {
TclGetNamespaceForQualName(interp, parentName, NULL,
TCL_GLOBAL_ONLY|TCL_FIND_ONLY_NS,
&parentNsPtr, &dummy1Ptr,
&dummy2Ptr, &dummy);
if (parentNsPtr == NULL) {
/*fprintf(stderr, "===== calling NSRequireParentObject %s", parentName);*/
NSRequireParentObject(interp, parentName);
}
}
}
return (Tcl_Namespace *)nsPtr;
}
/*
*----------------------------------------------------------------------
* NSFindCommand --
*
* Find the "real" command belonging e.g. to a Next Scripting class
* or object. Do not return cmds produced by Tcl_Import, but the
* "real" cmd to which they point.
*
* Results:
* Tcl_Command or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2);
NSF_INLINE static Tcl_Command
NSFindCommand(Tcl_Interp *interp, const char *name) {
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
assert(*name == ':' && *(name + 1) == ':');
cmd = Tcl_FindCommand(interp, name, NULL, TCL_GLOBAL_ONLY);
if (likely(cmd != NULL)) {
Tcl_Command importedCmd = TclGetOriginalCommand(cmd);
if (unlikely(importedCmd != NULL)) {
cmd = importedCmd;
}
}
return cmd;
}
#if defined(NSF_DEVELOPMENT_TEST)
/*
*----------------------------------------------------------------------
* ReverseLookupCmdFromCmdTable --
*
* Allows for looking up objects in command tables (e.g., namespace
* cmd tables, the interp's hidden cmd table) based on their
* command pointer (rather than their command name).
*
* Results:
* Boolean result indicating success
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool ReverseLookupCmdFromCmdTable(
const Tcl_Command searchCmdPtr,
Tcl_HashTable *cmdTablePtr
) nonnull(1) nonnull(2);
static bool
ReverseLookupCmdFromCmdTable(
const Tcl_Command searchCmdPtr,
Tcl_HashTable *cmdTablePtr
) {
Tcl_HashSearch search;
const Tcl_HashEntry *hPtr;
bool result = NSF_FALSE;
nonnull_assert(searchCmdPtr != NULL);
nonnull_assert(cmdTablePtr != NULL);
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_Command needleCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr);
if (needleCmdPtr == searchCmdPtr) {
result = NSF_TRUE;
break;
}
}
return result;
}
/*
*----------------------------------------------------------------------
* GetHiddenObjectFromCmd --
*
* Obtains a hidden object for a specified cmd. The function uses a
* reverse lookup of *hidden* object structures based on their
* commands. This helper is needed for handling hidden and
* re-exposed objects during the shutdown and the cleanup of object
* systems.
*
* Results:
* NsfObject* or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfObject *GetHiddenObjectFromCmd(
Tcl_Interp *interp, const Tcl_Command cmdPtr
) nonnull(1);
static NsfObject *
GetHiddenObjectFromCmd(
Tcl_Interp *interp, const Tcl_Command cmdPtr
) {
Interp *iPtr = (Interp *) interp;
NsfObject *screenedObject;
nonnull_assert(cmdPtr != NULL);
/*
* We can provide a shortcut, knowing that a) exposed cmds have an epoch
* counter > 0, and b) the commands originating namespace must be the global
* one. See also Tcl_HideCommand() and Tcl_ExposeCommand().
*/
if (Tcl_Command_cmdEpoch(cmdPtr) == 0 ||
((Command *)cmdPtr)->nsPtr != iPtr->globalNsPtr) {
screenedObject = NULL;
} else {
bool found;
/*
* Reverse lookup object in the interp's hidden command table. We start
* off with the hidden cmds as we suspect their number being smaller than
* the re-exposed ones, living in the global namespace
*/
found = ReverseLookupCmdFromCmdTable(cmdPtr, iPtr->hiddenCmdTablePtr);
if (!found) {
/*
* Reverse lookup object in the interp's global command table. Most likely
* needed due to hiding + exposing on a different name.
*/
found = ReverseLookupCmdFromCmdTable(cmdPtr, &iPtr->globalNsPtr->cmdTable);
}
screenedObject = found ? NsfGetObjectFromCmdPtr(cmdPtr) : NULL;
#if !defined(NDEBUG)
if (screenedObject != NULL) {
NsfLog(interp, NSF_LOG_NOTICE, "screened object %s found: object %p (%s) cmd %p",
Tcl_GetCommandName(interp, cmdPtr), (void *)screenedObject,
ObjectName(screenedObject), (void *)cmdPtr);
}
#endif
}
return screenedObject;
}
#endif
/*
*----------------------------------------------------------------------
* GetObjectFromString --
*
* Lookup an object from a given string. The function performs a
* command lookup (every object is a command) and checks, if the
* command is bound to an NSF object.
*
* Results:
* NsfObject* or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfObject *
GetObjectFromString(Tcl_Interp *interp, const char *name) {
register Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
/*fprintf(stderr, "GetObjectFromString name = '%s'\n", name);*/
cmd = NSFindCommand(interp, name);
if (likely(cmd != NULL && CmdIsNsfObject(cmd))) {
/*fprintf(stderr, "GetObjectFromString %s => %p\n", name, Tcl_Command_objClientData(cmd));*/
return (NsfObject *)Tcl_Command_objClientData(cmd);
}
/*fprintf(stderr, "GetObjectFromString %s => NULL\n", name);*/
return NULL;
}
/*
*----------------------------------------------------------------------
* GetClassFromString --
*
* Lookup a class from a given string. The function performs an
* object lookup and checks, if the object is a class.
*
* Results:
* NsfClass* or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass *
GetClassFromString(Tcl_Interp *interp, const char *name) {
NsfObject *object = GetObjectFromString(interp, name);
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
return (object != NULL && NsfObjectIsClass(object)) ? (NsfClass *)object : NULL;
}
/*
*----------------------------------------------------------------------
* CanRedefineCmd --
*
* This function tests, whether a method (provided as a string) is
* allowed to be redefined in a provided namespace.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int CanRedefineCmd(
Tcl_Interp *interp,
const Tcl_Namespace *nsPtr,
const NsfObject *object,
const char *methodName,
unsigned int flags
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
CanRedefineCmd(
Tcl_Interp *interp,
const Tcl_Namespace *nsPtr,
const NsfObject *object,
const char *methodName,
unsigned int flags
) {
int result;
bool ok;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
cmd = FindMethod(nsPtr, methodName);
if (cmd != NULL) {
if ( NsfGetObjectFromCmdPtr(cmd) != NULL) {
/*
* Don't allow overwriting of an object with a method.
*/
return NsfPrintError(interp,
"refuse to overwrite child object with method %s; delete/rename it before overwriting",
methodName);
}
ok = (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_REDEFINE_PROTECTED_METHOD) == 0u);
} else {
ok = NSF_TRUE;
}
if (likely(ok)) {
result = TCL_OK;
} else {
/*
* We could test, whether we are bootstrapping the "right" object
* system, and allow only overwrites for the current bootstrap
* object system, but this seems necessary by now.
*/
Tcl_Obj *bootstrapObj = Tcl_GetVar2Ex(interp, "::nsf::bootstrap", NULL, TCL_GLOBAL_ONLY);
if (bootstrapObj == NULL) {
result = NsfPrintError(interp, "refuse to overwrite protected method '%s'; "
"derive e.g. a subclass!", methodName, ObjectName_(object));
} else {
result = TCL_OK;
}
}
if (likely(result == TCL_OK)) {
result = ObjectSystemsCheckSystemMethod(interp, methodName, object, flags);
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfAddObjectMethod --
*
* Externally callable function to register an object level method
* for the provided object.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Newly created Tcl command.
*
*----------------------------------------------------------------------
*/
int NsfAddObjectMethod(
Tcl_Interp *interp, Nsf_Object *object, const char *methodName,
TCL_OBJCMDPROC_T *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
unsigned int flags
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
NsfAddObjectMethod(
Tcl_Interp *interp, Nsf_Object *object, const char *methodName,
TCL_OBJCMDPROC_T *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
unsigned int flags
) {
NsfObject *currentObject;
Tcl_DString newCmdName, *dsPtr = &newCmdName;
const Tcl_Namespace *ns;
Tcl_Command newCmd;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(proc != NULL);
currentObject = (NsfObject *)object;
ns = RequireObjNamespace(interp, currentObject);
/*
* Check whether we are allowed to redefine the method
*/
result = CanRedefineCmd(interp, currentObject->nsPtr, currentObject, (char *)methodName, flags);
if (unlikely(result != TCL_OK)) {
return result;
}
NsfObjectMethodEpochIncr("NsfAddObjectMethod");
/*
* Delete an alias definition, if it exists.
*/
AliasDelete(interp, currentObject->cmdName, methodName, NSF_TRUE);
Tcl_DStringInit(dsPtr);
DStringAppendQualName(dsPtr, ns, methodName);
newCmd = TCL_CREATEOBJCOMMAND(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp);
if (flags != 0u) {
((Command *) newCmd)->flags |= (int)flags;
}
Tcl_DStringFree(dsPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* NsfAddClassMethod --
*
* Externally callable function to register a class level method
* for the provided class.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Newly created Tcl command.
*
*----------------------------------------------------------------------
*/
int NsfAddClassMethod(
Tcl_Interp *interp, Nsf_Class *class, const char *methodName,
TCL_OBJCMDPROC_T *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
unsigned int flags
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
NsfAddClassMethod(
Tcl_Interp *interp, Nsf_Class *class, const char *methodName,
TCL_OBJCMDPROC_T *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
unsigned int flags
) {
Tcl_DString newCmdName, *dsPtr = &newCmdName;
Tcl_Command newCmd;
NsfClass *c;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(proc != NULL);
c = (NsfClass *)class;
assert(c->nsPtr != NULL);
/*
* Check whether we are allowed to redefine the method.
*/
result = CanRedefineCmd(interp, c->nsPtr, &c->object, (char *)methodName, flags);
if (unlikely(result != TCL_OK)) {
return result;
}
NsfInstanceMethodEpochIncr("NsfAddClassMethod");
/*
* Delete the alias definition, if it exists already.
*/
AliasDelete(interp, class->object.cmdName, methodName, NSF_FALSE);
Tcl_DStringInit(dsPtr);
DStringAppendQualName(dsPtr, c->nsPtr, methodName);
newCmd = TCL_CREATEOBJCOMMAND(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp);
if (flags != 0) {
((Command *) newCmd)->flags |= (int)flags;
}
Tcl_DStringFree(dsPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* AutonameIncr --
*
* Returns a Tcl_Obj containing an autonamed (interpreter unique)
* value.
*
* Results:
* Tcl Obj.
*
* Side effects:
* Maintains counters in global Tcl arrays.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *AutonameIncr(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfObject *object,
int isInstanceOpt, int doResetOpt)
nonnull(1) nonnull(2) nonnull(3);
static Tcl_Obj *
AutonameIncr(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfObject *object,
int isInstanceOpt, int doResetOpt) {
Tcl_Obj *valueObj, *resultObj;
CallFrame frame, *framePtr = &frame;
int flogs = TCL_LEAVE_ERR_MSG;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(object != NULL);
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
if (object->nsPtr != NULL) {
flogs |= TCL_NAMESPACE_ONLY;
}
valueObj = Tcl_ObjGetVar2(interp, NsfGlobalObjs[NSF_AUTONAMES], nameObj, flogs);
if (valueObj != NULL) {
long autoname_counter;
/*
* The autoname counter can overflow, but this should cause no
* troubles.
*/
Tcl_GetLongFromObj(interp, valueObj, &autoname_counter);
autoname_counter++;
if (Tcl_IsShared(valueObj)) {
valueObj = Tcl_DuplicateObj(valueObj);
}
Tcl_SetLongObj(valueObj, autoname_counter);
resultObj = Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_AUTONAMES], nameObj,
valueObj, flogs);
if (unlikely(resultObj == NULL)) {
return NULL;
}
} else {
resultObj = NsfGlobalObjs[NSF_EMPTY];
}
if (doResetOpt == 1) {
if (valueObj != NULL) {
/*
* We have such a variable. The reset operation has to unset it.
*/
Tcl_UnsetVar2(interp, NsfGlobalStrings[NSF_AUTONAMES], ObjStr(nameObj), flogs);
}
resultObj = NsfGlobalObjs[NSF_EMPTY];
INCR_REF_COUNT2("autoname", resultObj);
} else {
bool mustCopy = NSF_TRUE, format = NSF_FALSE;
const char *c;
if (valueObj == NULL) {
valueObj = Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_AUTONAMES],
nameObj, NsfGlobalObjs[NSF_ONE], flogs);
}
if (isInstanceOpt == 1) {
char firstChar;
const char *nextChars = ObjStr(nameObj);
firstChar = *(nextChars ++);
if (CHARTYPE(upper, firstChar) != 0) {
char buffer[1];
buffer[0] = (char)tolower((int)firstChar);
resultObj = Tcl_NewStringObj(buffer, 1);
INCR_REF_COUNT2("autoname", resultObj);
Tcl_AppendLimitedToObj(resultObj, nextChars, TCL_INDEX_NONE, INT_MAX, NULL);
mustCopy = NSF_FALSE;
}
}
if (mustCopy) {
resultObj = Tcl_DuplicateObj(nameObj);
INCR_REF_COUNT2("autoname", resultObj);
/*
fprintf(stderr, "*** copy %p %s = %p\n", name, ObjStr(name), resultObj);
*/
}
/*
* If there is a "%" in the autoname, use Tcl_FormatObjCmd to let the
* autoname string be formatted, like Tcl "format" command, with the
* value. E.g.: autoname a%06d --> a000000, a000001, a000002, ...
*/
for (c = ObjStr(resultObj); *c != '\0'; c++) {
if (*c == '%') {
if (*(c+1) != '%') {
format = NSF_TRUE;
break;
} else {
/*
* When name contains "%%" format and then append autoname, e.g.
* autoname a%% --> a%1, a%2, ...
*/
c++;
}
}
}
if (format) {
Tcl_Obj *savedResultObj, *ov[3];
savedResultObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(savedResultObj);
ov[0] = NULL;
ov[1] = resultObj;
ov[2] = valueObj;
if (NsfCallCommand(interp, NSF_FORMAT, 3, ov) != TCL_OK) {
Nsf_PopFrameObj(interp, framePtr);
DECR_REF_COUNT(savedResultObj);
return NULL;
}
DECR_REF_COUNT(resultObj);
resultObj = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
INCR_REF_COUNT2("autoname", resultObj);
Tcl_SetObjResult(interp, savedResultObj);
DECR_REF_COUNT(savedResultObj);
} else {
const char *valueString = Tcl_GetString(valueObj);
Tcl_AppendLimitedToObj(resultObj, valueString, valueObj->length, INT_MAX, NULL);
}
}
Nsf_PopFrameObj(interp, framePtr);
assert((doResetOpt == 1 && resultObj->refCount>=1) || (resultObj->refCount == 1));
return resultObj;
}
/*
* Next Scripting CallStack functions
*/
/*
*----------------------------------------------------------------------
* CallStackDoDestroy --
*
* Deletion of objects has to take care on the callstack,
* e.g. whether an object is active on the callstack or not. The
* objects can only be deleted physically, when these are not
* activate anymore. This logic is implemented by
* CallStackDestroyObject() and CallStackDoDestroy(), where the
* latter is responsible for the final deletion.
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static void CallStackDoDestroy(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
NSF_INLINE static void
CallStackDoDestroy(Tcl_Interp *interp, NsfObject *object) {
Tcl_Command oid;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*fprintf(stderr, "CallStackDoDestroy %p flags %.6x\n", object, object->flags);*/
PRINTOBJ("CallStackDoDestroy", object);
/*
* Don't do anything, if a recursive DURING_DELETE is for some
* reason active.
*/
if (unlikely((object->flags & NSF_DURING_DELETE) != 0u)) {
return;
}
/*fprintf(stderr, "CallStackDoDestroy %p flags %.6x activation %d object->refCount %d cmd %p \n",
object, object->flags, object->activationCount, object->refCount, object->id);*/
object->flags |= NSF_DURING_DELETE;
oid = object->id;
/*
* The oid might be freed already, we can't even use
* TclIsCommandDeleted(oid)
*/
if (object->teardown != NULL && oid != NULL) {
/*
* PrimitiveDestroy() has to be called 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().
*/
NsfObjectRefCountIncr(object);
PrimitiveDestroy(object);
if /*(object->teardown == NULL)*/ ((object->flags & NSF_TCL_DELETE) == 0u) {
Tcl_Obj *savedResultObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(savedResultObj);
assert(object->teardown == NULL);
/*fprintf(stderr, " before DeleteCommandFromToken %p object flags %.6x\n", (void *)oid, object->flags);*/
/*fprintf(stderr, "cmd dealloc %p refCount %d dodestroy \n", (void *)oid, Tcl_Command_refCount(oid));*/
Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */
/*fprintf(stderr, " after DeleteCommandFromToken %p %.6x\n", (void *)oid, ((Command *)oid)->flags);*/
Tcl_SetObjResult(interp, savedResultObj);
DECR_REF_COUNT(savedResultObj);
}
NsfCleanupObject(object, "CallStackDoDestroy");
}
}
/*
*----------------------------------------------------------------------
* CallStackDestroyObject --
*
* See comments of CallStackDoDestroy() for the overall logic. The
* function CallStackDestroyObject() checks, if an object is active
* on the call stack (via the activation count). It deletes only
* inactive objects via CallStackDoDestroy().
*
* Results:
* None.
*
* Side effects:
* Might frees memory.
*
*----------------------------------------------------------------------
*/
static void
CallStackDestroyObject(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
#ifdef OBJDELETION_TRACE
fprintf(stderr, "CallStackDestroyObject %p %s activationcount %d flags %.6x\n",
(void *)object, ObjectName(object), object->activationCount, object->flags);
#endif
if ((object->flags & NSF_DESTROY_CALLED) == 0u) {
int activationCount = object->activationCount;
/*
* If the destroy method was not called yet, do it now.
*/
#ifdef OBJDELETION_TRACE
fprintf(stderr, " CallStackDestroyObject has to DispatchDestroyMethod %p activationCount %d\n",
(void *)object, activationCount);
#endif
DispatchDestroyMethod(interp, object, 0u);
if (activationCount == 0) {
/*
* We assume, the object is now freed. If the object 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 call-stack anymore
* we have to destroy it directly, because CscFinish won't
* find the object destroy.
*/
if (object->activationCount == 0) {
CallStackDoDestroy(interp, object);
} else {
/*
* To preserve the deletion order, call delete children now such that
* child destructors are called before parent destructors.
*/
if ((object->teardown != NULL) && (object->nsPtr != NULL)) {
/*fprintf(stderr, " CallStackDestroyObject calls NSDeleteChildren\n");*/
NSDeleteChildren(interp, object->nsPtr);
}
}
/*fprintf(stderr, " CallStackDestroyObject %p DONE\n", object);*/
}
/*
* cmd list handling
*/
/*
*----------------------------------------------------------------------
* CmdListAdd --
*
* Add an entry to a cmdlist. Optionally, the function checks for
* duplicates (does not insert a duplicate) or it allows one to add new
* entries to the end of the list.
*
* Results:
* The newly inserted command list item or a found item (never null).
*
* Side effects:
* Added List entry.
*
*----------------------------------------------------------------------
*/
static NsfCmdList *CmdListAdd(
NsfCmdList **cList, const Tcl_Command cmd, NsfClass *clorobj,
bool noDuplicates, bool atEnd
) nonnull(1) nonnull(2) returns_nonnull;
static NsfCmdList *
CmdListAdd(
NsfCmdList **cList, const Tcl_Command cmd, NsfClass *clorobj,
bool noDuplicates, bool atEnd
) {
NsfCmdList *l, *nextPtr, *new;
nonnull_assert(cmd != NULL);
nonnull_assert(cList != NULL);
if (unlikely(atEnd)) {
l = *cList;
nextPtr = NULL;
} else {
l = NULL;
nextPtr = *cList;
}
/*
* Check for duplicates, if necessary.
*/
if (unlikely(noDuplicates)) {
NsfCmdList *h = l, **end = NULL;
while (h != NULL) {
if (h->cmdPtr == cmd) {
return h;
}
end = &(h->nextPtr);
h = h->nextPtr;
}
if (end != NULL) {
/*
* 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 NsfCmdList "new" to the end of the
* list.
*/
new = NEW(NsfCmdList);
new->cmdPtr = cmd;
NsfCommandPreserve(new->cmdPtr);
new->clientData = NULL;
new->clorobj = clorobj;
new->nextPtr = nextPtr;
if (unlikely(l != NULL)) {
/*
* append new element at the end
*/
while (l->nextPtr != NULL) {
l = l->nextPtr;
}
l->nextPtr = new;
} else {
/*
* prepend new element
*/
*cList = new;
}
return new;
}
/*
*----------------------------------------------------------------------
* CmdListAddSorted --
*
* Add an entry to a cmdlist without duplicates. The order of the
* entries is not supposed to be relevant. This function maintains
* a sorted list to reduce cost to n/2. Can be improved be using
* better data structures of needed.
*
* Results:
* The newly inserted command list item or a found item.
*
* Side effects:
* Added list entry.
*
*----------------------------------------------------------------------
*/
static NsfCmdList *CmdListAddSorted(NsfCmdList **cList, Tcl_Command cmd, NsfClass *clorobj)
nonnull(1) nonnull(2) returns_nonnull;
static NsfCmdList *
CmdListAddSorted(NsfCmdList **cList, Tcl_Command cmd, NsfClass *clorobj) {
NsfCmdList *prev, *new, *h;
nonnull_assert(cmd != NULL);
nonnull_assert(cList != NULL);
for (h = *cList, prev = NULL; h != NULL; prev = h, h = h->nextPtr) {
if (h->cmdPtr == cmd) {
return h;
} else if (h->cmdPtr > cmd) {
break;
}
}
new = NEW(NsfCmdList);
new->cmdPtr = cmd;
NsfCommandPreserve(new->cmdPtr);
new->clientData = NULL;
new->clorobj = clorobj;
new->nextPtr = h;
if (prev != NULL) {
prev->nextPtr = new;
} else {
*cList = new;
}
return new;
}
static void CmdListReplaceCmd(NsfCmdList *replace, Tcl_Command cmd, NsfClass *clorobj)
nonnull(1) nonnull(3);
static void
CmdListReplaceCmd(NsfCmdList *replace, Tcl_Command cmd, NsfClass *clorobj) {
Tcl_Command del;
nonnull_assert(replace != NULL);
nonnull_assert(clorobj != NULL);
del = replace->cmdPtr;
replace->cmdPtr = cmd;
replace->clorobj = clorobj;
NsfCommandPreserve(cmd);
NsfCommandRelease(del);
}
#if defined(NSF_DEBUGGING)
/** for debug purposes only */
static void CmdListPrint(Tcl_Interp *interp, const char *title, NsfCmdList *cmdList)
nonnull(1) nonnull(3);
static void
CmdListPrint(Tcl_Interp *interp, const char *title, NsfCmdList *cmdList) {
nonnull_assert(interp != NULL);
nonnull_assert(cmdList != NULL);
if (title != NULL) {
fprintf(stderr, "%s %p:\n", title, cmdList);
}
while (cmdList != NULL) {
fprintf(stderr, " CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n",
cmdList,
cmdList->cmdPtr, (interp != NULL) ? Tcl_GetCommandName(interp, cmdList->cmdPtr) : "",
cmdList->clorobj,
cmdList->clientData);
cmdList = cmdList->nextPtr;
}
}
#endif
/*
* physically delete an entry 'del'
*/
static void CmdListDeleteCmdListEntry(NsfCmdList *del, NsfFreeCmdListClientData *freeFct)
nonnull(1);
static void
CmdListDeleteCmdListEntry(NsfCmdList *del, NsfFreeCmdListClientData *freeFct) {
nonnull_assert(del != NULL);
if (unlikely(freeFct != NULL)) {
(*freeFct)(del);
}
NsfCommandRelease(del->cmdPtr);
FREE(NsfCmdList, del);
}
/*
* remove a command 'delCL' from a command list, but do not
* free it ... returns the removed NsfCmdList*
*/
static NsfCmdList *CmdListRemoveFromList(NsfCmdList **cmdList, NsfCmdList *delCL)
nonnull(1) nonnull(2);
static NsfCmdList *
CmdListRemoveFromList(NsfCmdList **cmdList, NsfCmdList *delCL) {
register NsfCmdList *c;
NsfCmdList *del = NULL;
nonnull_assert(cmdList != NULL);
nonnull_assert(delCL != NULL);
c = *cmdList;
if (likely(c != NULL)) {
if (c == delCL) {
*cmdList = c->nextPtr;
del = c;
} else {
while ((c->nextPtr != NULL) && (c->nextPtr != delCL)) {
c = c->nextPtr;
}
if (c->nextPtr == delCL) {
del = delCL;
c->nextPtr = delCL->nextPtr;
}
}
}
return del;
}
/*
*----------------------------------------------------------------------
* CmdListRemoveDeleted --
*
* Remove all command pointers from a command list which are marked
* "deleted". The condition for deletion is the presence of the flag
* CMD_DYING (previously, CMD_IS_DELETED), with the flag bit being set by
* Tcl_DeleteCommandFromToken().
*
* Results:
* The cmd list filtered for non-deleted commands
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void CmdListRemoveDeleted(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct)
nonnull(1) nonnull(2);
static void
CmdListRemoveDeleted(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct) {
NsfCmdList *f, *del;
nonnull_assert(cmdList != NULL);
nonnull_assert(freeFct != NULL);
f = *cmdList;
while (f != NULL) {
/*
* HIDDEN OBJECTS: For supporting hidden mixins, we cannot rely on the
* cmdEpoch as indicator of the deletion status of a cmd because the epoch
* counters of hidden and re-exposed commands are bumped. Despite of this,
* their object structures remain valid. We resort to the use of the
* per-cmd flag CMD_DYING (previously, CMD_IS_DELETED), set upon
* processing a command in Tcl_DeleteCommandFromToken().
*/
if (TclIsCommandDeleted(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(
NsfCmdList **cmdList, const NsfClass *clorobj,
NsfFreeCmdListClientData *freeFct
) nonnull(1) nonnull(2) nonnull(3);
static void
CmdListRemoveContextClassFromList(
NsfCmdList **cmdList, const NsfClass *clorobj,
NsfFreeCmdListClientData *freeFct
) {
NsfCmdList *c, *del = NULL;
nonnull_assert(cmdList != NULL);
nonnull_assert(clorobj != NULL);
nonnull_assert(freeFct != NULL);
/*
CmdListRemoveDeleted(cmdList, freeFct);
*/
c = *cmdList;
while (c != NULL && c->clorobj == clorobj) {
del = c;
*cmdList = c->nextPtr;
CmdListDeleteCmdListEntry(del, freeFct);
c = *cmdList;
}
while (c != NULL) {
if (c->clorobj == clorobj) {
del = c;
c = *cmdList;
while ((c->nextPtr != NULL) && (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
CmdListFree(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct) {
nonnull_assert(cmdList != NULL);
while (*cmdList != NULL) {
NsfCmdList *del = *cmdList;
*cmdList = (*cmdList)->nextPtr;
CmdListDeleteCmdListEntry(del, freeFct);
}
}
/*
* simple list search proc to search a list of cmds
* for a command ptr
*/
static NsfCmdList * CmdListFindCmdInList(const Tcl_Command cmd, NsfCmdList *l)
nonnull(2) nonnull(1) NSF_pure;
static NsfCmdList *
CmdListFindCmdInList(const Tcl_Command cmd, NsfCmdList *l) {
register NsfCmdList *h;
nonnull_assert(cmd != NULL);
nonnull_assert(l != NULL);
for (h = l; h != NULL; h = h->nextPtr) {
if (h->cmdPtr == cmd) {
return h;
}
}
return NULL;
}
/*
* simple list search proc to search a list of cmds
* for a simple Name
*/
static NsfCmdList * CmdListFindNameInList(Tcl_Interp *interp, const char *name, NsfCmdList *cmdList)
nonnull(1) nonnull(2) nonnull(3);
static NsfCmdList *
CmdListFindNameInList(Tcl_Interp *interp, const char *name, NsfCmdList *cmdList) {
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
nonnull_assert(cmdList != NULL);
do {
const char *cmdName = Tcl_GetCommandName(interp, cmdList->cmdPtr);
if (cmdName[0] == name[0] && strcmp(cmdName, name) == 0) {
return cmdList;
}
cmdList = cmdList->nextPtr;
} while (cmdList != NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
* CheckConditionInScope --
*
* Check a given condition in the current call-frame's scope. It is
* the responsibility of the caller to push the intended call-frame.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int CheckConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition)
nonnull(1) nonnull(2);
static int
CheckConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition) {
int result, success;
Tcl_Obj *ov[2] = {NULL, condition};
nonnull_assert(interp != NULL);
nonnull_assert(condition != NULL);
INCR_REF_COUNT(condition);
result = Nsf_ExprObjCmd(NULL, interp, 2, ov);
DECR_REF_COUNT(condition);
if (likely(result == TCL_OK)) {
result = Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), &success);
if (result == TCL_OK && success == 0) {
result = NSF_CHECK_FAILED;
}
}
return result;
}
/*
* Generic Obj-List handling functions.
*/
/*
*----------------------------------------------------------------------
* TclObjListFreeList --
*
* Free the elements of the obj list.
*
* Results:
* None.
*
* Side effects:
* free memory.
*
*----------------------------------------------------------------------
*/
static void TclObjListFreeList(NsfTclObjList *list)
nonnull(1);
static void
TclObjListFreeList(NsfTclObjList *list) {
nonnull_assert(list != NULL);
do {
NsfTclObjList *del = list;
list = list->nextPtr;
DECR_REF_COUNT2("listContent", del->content);
if (del->payload != NULL) {
DECR_REF_COUNT2("listPayload", del->payload);
}
FREE(NsfTclObjList, del);
} while (list != NULL);
}
/*
*----------------------------------------------------------------------
* TclObjListNewElement --
*
* Add a new element to the obj list with an optional value (stored
* in payload).
*
* Results:
* None.
*
* Side effects:
* allocate memory.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj * TclObjListNewElement(NsfTclObjList **list, Tcl_Obj *obj, Tcl_Obj *valueObj)
nonnull(1) nonnull(2) returns_nonnull;
static Tcl_Obj *
TclObjListNewElement(NsfTclObjList **list, Tcl_Obj *obj, Tcl_Obj *valueObj) {
NsfTclObjList *elt = NEW(NsfTclObjList);
nonnull_assert(list != NULL);
nonnull_assert(obj != NULL);
INCR_REF_COUNT2("listContent", obj);
elt->content = obj;
elt->payload = valueObj;
if (valueObj != NULL) {
INCR_REF_COUNT2("listPayload", valueObj);
}
elt->nextPtr = *list;
*list = elt;
return obj;
}
/*
*----------------------------------------------------------------------
* TclObjListAdd --
*
* Add an NsfTclObjList element to the obj list indexed by a key
* into a sorted list of elements. Duplicates are appended to the
* payload elements.
*
* Results:
* None.
*
* Side effects:
* Add element to the obj-list.
*
*----------------------------------------------------------------------
*/
static void TclObjListAdd(Tcl_Interp *interp, NsfTclObjList **list, Tcl_Obj *key, Tcl_Obj *value)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static void
TclObjListAdd(Tcl_Interp *interp, NsfTclObjList **list, Tcl_Obj *key, Tcl_Obj *value) {
NsfTclObjList *elt, **prevPtr;
const char *keyString;
nonnull_assert(interp != NULL);
nonnull_assert(list != NULL);
nonnull_assert(key != NULL);
nonnull_assert(value != NULL);
keyString = ObjStr(key);
for (elt = *list, prevPtr = list; elt != NULL; prevPtr = &elt->nextPtr, elt = elt->nextPtr) {
const char *eltString = ObjStr(elt->content);
if (key == elt->content || strcmp(keyString, eltString) == 0) {
/*
* Found the element, append to it
*/
/* fprintf(stderr, "TclObjListAdd: insert %s/%s equal, append to %s\n",
keyString, ObjStr(value), ObjStr(elt->payload));*/
Tcl_ListObjAppendElement(interp, elt->payload, value);
return;
}
if (strcmp(keyString, eltString) < 0) {
/*
* Element not found, insert new before as a new entry.
*/
/*fprintf(stderr, "TclObjListAdd: insert %s/%s before %s isshared %d\n",
keyString, ObjStr(value), eltString, Tcl_IsShared(key));*/
TclObjListNewElement(prevPtr, key, Tcl_IsShared(value) ? Tcl_DuplicateObj(value) : value);
return;
}
}
/*
* Element not found, insert new as last entry.
*/
/* fprintf(stderr, "TclObjListAdd: insert last %s value %s\n", keyString, ObjStr(value)); */
TclObjListNewElement(prevPtr, key, Tcl_NewListObj(1, &value));
return;
}
/*
*----------------------------------------------------------------------
* AddObjToTclList --
*
* Add a Tcl_Obj to a potential not-existing Tcl list, which is
* created on demand.
*
* Results:
* None.
*
* Side effects:
* Add Tcl_Obj to the Tcl list, potentially creating list.
*
*----------------------------------------------------------------------
*/
static void
AddObjToTclList(
Tcl_Interp *interp,
Tcl_Obj **listObjPtr,
Tcl_Obj *obj
) nonnull(2) nonnull(3);
static void
AddObjToTclList(
Tcl_Interp *interp,
Tcl_Obj **listObjPtr,
Tcl_Obj *obj
) {
nonnull_assert(listObjPtr != NULL);
nonnull_assert(obj != NULL);
if (*listObjPtr == NULL) {
*listObjPtr = Tcl_NewListObj(1, &obj);
INCR_REF_COUNT2("AddObjToTclList", *listObjPtr);
} else {
Tcl_ListObjAppendElement(interp, *listObjPtr, obj);
}
}
#if defined(NSF_WITH_ASSERTIONS)
/*********************************************************************
* Assertions
**********************************************************************/
static NsfTclObjList * AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj)
nonnull(1);
static NsfTclObjList *
AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj) {
Tcl_Obj **ov;
TCL_SIZE_T oc;
NsfTclObjList *last = NULL;
nonnull_assert(interp != NULL);
if (aObj != NULL && Tcl_ListObjGetElements(interp, aObj, &oc, &ov) == TCL_OK) {
if (oc > 0) {
ptrdiff_t i;
for (i = (ptrdiff_t)oc - 1; i >= 0; i--) {
TclObjListNewElement(&last, ov[i], NULL);
}
}
}
return last;
}
static Tcl_Obj *AssertionList(Tcl_Interp *interp, NsfTclObjList *alist)
nonnull(1);
static Tcl_Obj *
AssertionList(Tcl_Interp *interp, NsfTclObjList *alist) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
nonnull_assert(interp != NULL);
for (; alist != NULL; alist = alist->nextPtr) {
Tcl_ListObjAppendElement(interp, listObj, alist->content);
}
return listObj;
}
static int AssertionListCheckOption(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static int
AssertionListCheckOption(Tcl_Interp *interp, NsfObject *object) {
NsfObjectOpt *opt;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
opt = object->opt;
if (opt == NULL) {
return TCL_OK;
}
resultObj = Tcl_GetObjResult(interp);
if (opt->checkoptions & CHECK_OBJINVAR) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("object-invar", TCL_INDEX_NONE));
}
if (opt->checkoptions & CHECK_CLINVAR) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("class-invar", TCL_INDEX_NONE));
}
if (opt->checkoptions & CHECK_PRE) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("pre", TCL_INDEX_NONE));
}
if (opt->checkoptions & CHECK_POST) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("post", TCL_INDEX_NONE));
}
return TCL_OK;
}
static NsfProcAssertion *AssertionFindProcs(NsfAssertionStore *aStore, const char *name)
nonnull(1) nonnull(2);
static NsfProcAssertion *
AssertionFindProcs(NsfAssertionStore *aStore, const char *name) {
const Tcl_HashEntry *hPtr;
nonnull_assert(aStore != NULL);
nonnull_assert(name != NULL);
hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL);
if (hPtr == NULL) {
return NULL;
}
return (NsfProcAssertion *) Tcl_GetHashValue(hPtr);
}
static void AssertionRemoveProc(NsfAssertionStore *aStore, const char *name)
nonnull(1) nonnull(2);
static void
AssertionRemoveProc(NsfAssertionStore *aStore, const char *name) {
Tcl_HashEntry *hPtr;
nonnull_assert(aStore != NULL);
nonnull_assert(name != NULL);
hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL);
if (hPtr != NULL) {
NsfProcAssertion *procAss = (NsfProcAssertion *) Tcl_GetHashValue(hPtr);
if (procAss->pre != NULL) {
TclObjListFreeList(procAss->pre);
}
if (procAss->post != NULL) {
TclObjListFreeList(procAss->post);
}
FREE(NsfProcAssertion, procAss);
Tcl_DeleteHashEntry(hPtr);
}
}
static void AssertionAddProc(Tcl_Interp *interp, const char *name, NsfAssertionStore *aStore,
Tcl_Obj *pre, Tcl_Obj *post)
nonnull(1) nonnull(2) nonnull(3);
static void
AssertionAddProc(Tcl_Interp *interp, const char *name, NsfAssertionStore *aStore,
Tcl_Obj *pre, Tcl_Obj *post) {
int isNew = 0;
Tcl_HashEntry *hPtr;
NsfProcAssertion *procs = NEW(NsfProcAssertion);
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
nonnull_assert(aStore != NULL);
AssertionRemoveProc(aStore, name);
procs->pre = AssertionNewList(interp, pre);
procs->post = AssertionNewList(interp, post);
hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &isNew);
if (isNew != 0) {
Tcl_SetHashValue(hPtr, procs);
}
}
static NsfAssertionStore *AssertionCreateStore(void) returns_nonnull;
static NsfAssertionStore *
AssertionCreateStore(void) {
NsfAssertionStore *aStore = NEW(NsfAssertionStore);
aStore->invariants = NULL;
Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS);
MEM_COUNT_ALLOC("Tcl_InitHashTable", &aStore->procs);
return aStore;
}
static void AssertionRemoveStore(NsfAssertionStore *aStore)
nonnull(1);
static void
AssertionRemoveStore(NsfAssertionStore *aStore) {
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
nonnull_assert(aStore != NULL);
for (hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch);
hPtr != NULL;
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);
if (aStore->invariants != NULL) {
TclObjListFreeList(aStore->invariants);
}
FREE(NsfAssertionStore, aStore);
}
static int AssertionCheckList(Tcl_Interp *interp, NsfObject *object,
NsfTclObjList *alist, const char *methodName)
nonnull(1) nonnull(2) nonnull(4);
static int
AssertionCheckList(Tcl_Interp *interp, NsfObject *object,
NsfTclObjList *alist, const char *methodName) {
NsfTclObjList *checkFailed = NULL;
Tcl_Obj *savedResultObj;
CheckOptions savedCheckoptions;
int acResult = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
/*
* No obj->opt -> checkoption == CHECK_NONE
*/
if (object->opt == NULL) {
return TCL_OK;
}
/*
* Do not check assertion modifying methods, otherwise we cannot react in
* catch on a run time assertion check failure
*/
#if 1
/*
* TODO: the following check operations is XOTcl1 legacy and is not
* generic. It should be replaced by another method-property. 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
savedResultObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(savedResultObj);
Tcl_ResetResult(interp);
while (alist != NULL) {
/*
* 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 == 0) {
CallFrame frame, *framePtr = &frame;
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, (NsfObject *)object, framePtr);
#pragma GCC diagnostic pop
/*
* Don't check assertions during the condition check.
*/
savedCheckoptions = object->opt->checkoptions;
object->opt->checkoptions = CHECK_NONE;
/* fprintf(stderr, "Checking Assertion %s ", assStr); */
/*
* Now check the condition in the pushed call-frame's scope.
*/
acResult = CheckConditionInScope(interp, alist->content);
if (acResult != TCL_OK) {
checkFailed = alist;
}
object->opt->checkoptions = savedCheckoptions;
/* fprintf(stderr, "...%s\n", (checkFailed != 0) ? "failed" : "ok"); */
Nsf_PopFrameObj(interp, framePtr);
}
if (checkFailed != 0) {
break;
}
alist = alist->nextPtr;
}
if (unlikely(checkFailed != 0)) {
DECR_REF_COUNT(savedResultObj);
if (acResult == TCL_ERROR) {
Tcl_Obj *sr = Tcl_GetObjResult(interp);
INCR_REF_COUNT(sr);
NsfPrintError(interp, "error in Assertion: {%s} in proc '%s'\n%s",
ObjStr(checkFailed->content), methodName, ObjStr(sr));
DECR_REF_COUNT(sr);
return TCL_ERROR;
}
return NsfPrintError(interp, "assertion failed check: {%s} in proc '%s'",
ObjStr(checkFailed->content), methodName);
}
Tcl_SetObjResult(interp, savedResultObj);
DECR_REF_COUNT(savedResultObj);
return TCL_OK;
}
static int AssertionCheckInvars(Tcl_Interp *interp, NsfObject *object,
const char *methodName,
CheckOptions checkoptions)
nonnull(1) nonnull(2) nonnull(3);
static int
AssertionCheckInvars(Tcl_Interp *interp, NsfObject *object,
const char *methodName,
CheckOptions checkoptions) {
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
if (checkoptions & CHECK_OBJINVAR && object->opt->assertions) {
result = AssertionCheckList(interp, object, object->opt->assertions->invariants,
methodName);
}
if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) {
NsfClasses *clPtr;
clPtr = PrecedenceOrder(object->cl);
while ((clPtr != NULL) && (result != TCL_ERROR)) {
NsfAssertionStore *aStore = (clPtr->cl->opt != NULL) ? clPtr->cl->opt->assertions : NULL;
if (aStore != NULL) {
result = AssertionCheckList(interp, object, aStore->invariants, methodName);
}
clPtr = clPtr->nextPtr;
}
}
return result;
}
static int AssertionCheck(Tcl_Interp *interp, NsfObject *object, NsfClass *class,
const char *method, CheckOptions checkOption)
nonnull(1) nonnull(2) nonnull(4);
static int
AssertionCheck(Tcl_Interp *interp, NsfObject *object, NsfClass *class,
const char *method, CheckOptions checkOption) {
int result = TCL_OK;
NsfAssertionStore *aStore;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(method != NULL);
assert(object->opt != NULL);
if (class != NULL) {
aStore = (class->opt != NULL) ? class->opt->assertions : NULL;
} else {
aStore = (object->opt != NULL) ? object->opt->assertions : NULL;
}
if ((aStore != NULL)
&& (checkOption & object->opt->checkoptions)
) {
NsfProcAssertion *procs = AssertionFindProcs(aStore, method);
if (procs != NULL) {
switch (checkOption) {
case CHECK_PRE:
result = AssertionCheckList(interp, object, procs->pre, method);
break;
case CHECK_POST:
result = AssertionCheckList(interp, object, procs->post, method);
break;
case CHECK_ALL: ;NSF_FALL_THROUGH; /* fall through */
case CHECK_NONE: ;NSF_FALL_THROUGH; /* fall through */
case CHECK_CLINVAR: ;NSF_FALL_THROUGH; /* fall through */
case CHECK_OBJINVAR: ;NSF_FALL_THROUGH; /* fall through */
case CHECK_INVAR:
break;
}
}
if (likely(result != TCL_ERROR)) {
result = AssertionCheckInvars(interp, object, method, object->opt->checkoptions);
}
}
return result;
}
static int AssertionSetCheckOptions(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arg)
nonnull(1) nonnull(2) nonnull(3);
static int
AssertionSetCheckOptions(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arg) {
NsfObjectOpt *opt;
TCL_SIZE_T ocArgs;
Tcl_Obj **ovArgs;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(arg != NULL);
opt = NsfRequireObjectOpt(object);
opt->checkoptions = CHECK_NONE;
if (Tcl_ListObjGetElements(interp, arg, &ocArgs, &ovArgs) == TCL_OK
&& ocArgs > 0) {
TCL_SIZE_T i;
for (i = 0; i < ocArgs; i++) {
const char *option = ObjStr(ovArgs[i]);
if (option != NULL) {
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 NsfPrintError(interp, "unknown check option in command '%s' check %s, ",
"valid: all pre post object-invar class-invar",
ObjectName_(object), ObjStr(arg));
}
return TCL_OK;
}
static void AssertionSetInvariants(Tcl_Interp *interp, NsfAssertionStore **assertions, Tcl_Obj *arg)
nonnull(1) nonnull(2) nonnull(3);
static void
AssertionSetInvariants(Tcl_Interp *interp, NsfAssertionStore **assertions, Tcl_Obj *arg) {
nonnull_assert(interp != NULL);
nonnull_assert(assertions != NULL);
nonnull_assert(arg != NULL);
if (*assertions != NULL) {
TclObjListFreeList((*assertions)->invariants);
} else {
*assertions = AssertionCreateStore();
}
(*assertions)->invariants = AssertionNewList(interp, arg);
}
#endif /* NSF_WITH_ASSERTIONS */
/***********************************************************************
* Mixin support
***********************************************************************/
/*
* push a mixin stack information on this object
*/
static void MixinStackPush(NsfObject *object)
nonnull(1);
static void
MixinStackPush(NsfObject *object) {
register NsfMixinStack *h = NEW(NsfMixinStack);
nonnull_assert(object != NULL);
h->currentCmdPtr = NULL;
h->nextPtr = object->mixinStack;
object->mixinStack = h;
/*fprintf(stderr, "MixinStackPush %p %s\n", object, ObjectName(object));*/
}
/*
* Pop a mixin stack information on this object.
*/
static void MixinStackPop(NsfObject *object)
nonnull(1);
static void
MixinStackPop(NsfObject *object) {
register const NsfMixinStack *h;
nonnull_assert(object != NULL);
/*fprintf(stderr, "MixinStackPop %p %s\n", object, ObjectName(object));*/
h = object->mixinStack;
object->mixinStack = h->nextPtr;
FREE(NsfMixinStack, h);
}
/*
* Appends NsfClasses (containing the mixin-classes and their
* superclasses) to 'mixinClasses' list from a given mixinList.
*/
static void MixinComputeOrderFullList(
Tcl_Interp *interp, NsfCmdList **mixinList,
NsfClasses **mixinClasses,
NsfClasses **checkList, int level
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static void
MixinComputeOrderFullList(
Tcl_Interp *interp, NsfCmdList **mixinList,
NsfClasses **mixinClasses,
NsfClasses **checkList, int level
) {
NsfCmdList *m;
NsfClasses *pl, **clPtr = mixinClasses;
nonnull_assert(interp != NULL);
nonnull_assert(mixinList != NULL);
nonnull_assert(mixinClasses != NULL);
nonnull_assert(checkList != NULL);
CmdListRemoveDeleted(mixinList, GuardDel);
for (m = *mixinList; m != NULL; m = m->nextPtr) {
NsfClass *mixinClass = NsfGetClassFromCmdPtr(m->cmdPtr);
if (mixinClass != NULL) {
for (pl = PrecedenceOrder(mixinClass); pl != NULL; pl = pl->nextPtr) {
if (!IsRootClass(pl->cl)) {
NsfClassOpt *opt = pl->cl->opt;
/* fprintf(stderr, "find %p %s in checklist 1 %p\n",
pl->cl, ClassName(pl->cl), *checkList);*/
if (*checkList != NULL && (NsfClassListFind(*checkList, pl->cl) != NULL)) {
/*fprintf(stderr, "+++ never add %s\n", ClassName(pl->cl));*/
} else {
if (opt != NULL && opt->classMixins != NULL) {
/*
* Compute transitively the (class) mixin-classes of this
* added class.
*/
NsfClassListAdd(checkList, pl->cl, NULL);
/*fprintf(stderr, "+++ transitive %s\n", ClassName(pl->cl));*/
MixinComputeOrderFullList(interp, &opt->classMixins, mixinClasses,
checkList, level+1);
}
/*fprintf(stderr, "+++ add to mixinClasses %p path: %s clPtr %p\n",
mixinClasses, ClassName(pl->cl), clPtr);*/
clPtr = NsfClassListAddNoDup(clPtr, pl->cl, m->clientData);
}
}
}
}
}
if (level == 0 && *checkList) {
NsfClassListFree(*checkList);
*checkList = NULL;
}
}
/*
*----------------------------------------------------------------------
* MixinResetOrder --
*
* Free the mixin order of the provided object if it exists.
*
* Results:
* None.
*
* Side effects:
* Frees potentially the mixinOrder list.
*
*----------------------------------------------------------------------
*/
static void MixinResetOrder(NsfObject *object)
nonnull(1);
static void
MixinResetOrder(NsfObject *object) {
nonnull_assert(object != NULL);
CmdListFree(&object->mixinOrder, NULL /*GuardDel*/);
object->mixinOrder = NULL;
}
/*
*----------------------------------------------------------------------
* NsfClassListAddPerClassMixins --
*
* Append the class mixins to the provided list. CheckList is used
* to eliminate potential duplicates.
*
* Results:
* None.
*
* Side effects:
* Appends potentially elements to classListPtr and checkList.
*
*----------------------------------------------------------------------
*/
static void NsfClassListAddPerClassMixins(Tcl_Interp *interp, NsfClass *class,
NsfClasses **classListPtr, NsfClasses **checkList)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static void
NsfClassListAddPerClassMixins(Tcl_Interp *interp, NsfClass *class,
NsfClasses **classListPtr, NsfClasses **checkList) {
NsfClasses *pl;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(classListPtr != NULL);
nonnull_assert(checkList != NULL);
for (pl = PrecedenceOrder(class); pl != NULL; pl = pl->nextPtr) {
NsfClassOpt *clopt = pl->cl->opt;
if (clopt != NULL && clopt->classMixins) {
MixinComputeOrderFullList(interp, &clopt->classMixins,
classListPtr, checkList, 1);
}
}
}
/*
*----------------------------------------------------------------------
* MixinComputeOrder --
*
* Compute a duplicate-free linearized order of per-object and
* per-class mixins and the class inheritance. The precedence rule
* is that the last occurrence makes it into the final list.
*
* Results:
* None.
*
* Side effects:
* object->mixinOrder is updated.
*
*----------------------------------------------------------------------
*/
static void MixinComputeOrder(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void
MixinComputeOrder(Tcl_Interp *interp, NsfObject *object) {
NsfClasses *fullList, *checkList = NULL, *mixinClasses = NULL, *clPtr;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (object->mixinOrder != NULL) {
MixinResetOrder(object);
}
/*
* Append per-obj mixins.
*/
if (object->opt != NULL) {
NsfCmdList *m;
MixinComputeOrderFullList(interp, &object->opt->objMixins, &mixinClasses,
&checkList, 1);
/*
* Add per-object mixins to checkList to avoid these classes in the
* class mixins.
*
* TODO: we could add this already in MixinComputeOrderFullList() if we
* provide an additional flag.
*/
for (m = object->opt->objMixins; m != NULL; m = m->nextPtr) {
NsfClass *mixinClass = NsfGetClassFromCmdPtr(m->cmdPtr);
if (mixinClass != NULL) {
NsfClassListAddNoDup(&checkList, mixinClass, NULL);
}
}
}
/*fprintf(stderr, "%s ", ObjectName(object));
NsfClassListPrint("MixinComputeOrder poms", mixinClasses);
NsfClassListPrint("MixinComputeOrder poms checkList", checkList);*/
/*
* Append per-class mixins.
*/
NsfClassListAddPerClassMixins(interp, object->cl, &mixinClasses, &checkList);
/*fprintf(stderr, "%s ", ObjectName(object));
NsfClassListPrint("MixinComputeOrder poms+pcms", mixinClasses);
CmdListPrint(interp, "mixinOrder", object->mixinOrder);*/
if (checkList != NULL) {
NsfClassListFree(checkList);
}
fullList = mixinClasses;
/*
* Don't add duplicates or classes of the precedence order to the resulting
* list.
*/
for (clPtr = mixinClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
const NsfClass *class = clPtr->cl;
NsfClasses *checker;
/*fprintf(stderr, "--- Work on %s\n", ClassName(cl));
CmdListPrint(interp, "mixinOrder", object->mixinOrder);*/
checker = NsfClassListFind(clPtr->nextPtr, class);
/*
* If checker is set, it is a duplicate and ignored.
*/
if (checker == NULL) {
/*
* Check object->cl hierarchy
*/
checker = NsfClassListFind(PrecedenceOrder(object->cl), class);
/*
* 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.
*/
NsfCmdList *new;
/*fprintf(stderr, "--- adding to mixinOrder %s to cmdlist %p of object %s\n",
ClassName(class), object->mixinOrder, ObjectName(object));*/
new = CmdListAdd(&object->mixinOrder, class->object.id, NULL,
/*noDuplicates*/ NSF_FALSE, NSF_TRUE);
/*CmdListPrint(interp, "mixinOrder", object->mixinOrder);*/
/*
* We require the first matching guard of the full list in the new
* client data
*/
checker = NsfClassListFind(fullList, class);
if (checker != NULL) {
new->clientData = checker->clientData;
}
}
}
/*
* ... and free the memory of the full list.
*/
if (fullList != NULL) {
NsfClassListFree(fullList);
}
/*CmdListPrint(interp, "mixin order\n", obj->mixinOrder);*/
}
/*
*----------------------------------------------------------------------
* MixinAdd --
*
* Add a mixinreg (mixin-class with a potential guard) provided as
* a Tcl_Obj* to 'mixinList' by appending it to the provided
* cmdList.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Potentially allocating cmd list elements added to the mixinList.
*
*----------------------------------------------------------------------
*/
static int MixinAdd(Tcl_Interp *interp, NsfCmdList **mixinList, Tcl_Obj *nameObj)
nonnull(1) nonnull(2) nonnull(3);
static int
MixinAdd(Tcl_Interp *interp, NsfCmdList **mixinList, Tcl_Obj *nameObj) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(mixinList != NULL);
nonnull_assert(nameObj != NULL);
/*fprintf(stderr, "MixinAdd gets obj %p type %p %s\n",
nameObj, nameObj->typePtr, ObjTypeStr(nameObj));*/
/*
* When the provided nameObj is of type NsfMixinregObjType, the nsf specific
* converter was called already; otherwise call the converter here.
*/
if (nameObj->typePtr != &NsfMixinregObjType
&& Tcl_ConvertToType(interp, nameObj, &NsfMixinregObjType) != TCL_OK
) {
result = TCL_ERROR;
} else {
Tcl_Obj *guardObj = NULL;
NsfClass *mixinCl = NULL;
result = NsfMixinregGet(interp, nameObj, &mixinCl, &guardObj);
if (result == TCL_OK) {
NsfCmdList *new;
assert(mixinCl != NULL);
assert(!TclIsCommandDeleted(mixinCl->object.id));
new = CmdListAdd(mixinList, mixinCl->object.id, NULL,
/*noDuplicates*/ NSF_TRUE, NSF_TRUE);
if (guardObj != NULL) {
GuardAdd(new, guardObj);
} else if (new->clientData != NULL) {
GuardDel(new);
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
* AppendMatchingElement --
*
* Call AppendElement to the resultObj for values matching the specified
* pattern.
*
* Results:
* None.
*
* Side effects:
* Appends element to the result object
*
*----------------------------------------------------------------------
*/
static void AppendMatchingElement(
Tcl_Interp *interp, Tcl_Obj *resultObj, Tcl_Obj *nameObj, const char *pattern
) nonnull(1) nonnull(2) nonnull(3);
static void
AppendMatchingElement(
Tcl_Interp *interp, Tcl_Obj *resultObj, Tcl_Obj *nameObj, const char *pattern
) {
nonnull_assert(interp != NULL);
nonnull_assert(resultObj != NULL);
nonnull_assert(nameObj != NULL);
if (pattern == NULL || Tcl_StringMatch( ObjStr(nameObj), pattern)) {
Tcl_ListObjAppendElement(interp, resultObj, nameObj);
}
}
/*
*----------------------------------------------------------------------
* AppendMatchingElementsFromCmdList --
*
* Apply AppendMatchingElement() to all elements of the passed
* Cmdlist
*
* Results:
* NSF_TRUE iff a matching object was provided and it was found;
* NSF_FALSE otherwise
*
* Side effects:
* Appends elements to the result
*
*----------------------------------------------------------------------
*/
static bool AppendMatchingElementsFromCmdList(
Tcl_Interp *interp, const NsfCmdList *cmdList,
Tcl_Obj *resultObj,
const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3);
static bool
AppendMatchingElementsFromCmdList(
Tcl_Interp *interp, const NsfCmdList *cmdList,
Tcl_Obj *resultObj,
const char *pattern, NsfObject *matchObject
) {
int success = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(cmdList != NULL);
nonnull_assert(resultObj != NULL);
do {
NsfObject *object = NsfGetObjectFromCmdPtr(cmdList->cmdPtr);
if (object != NULL) {
if (matchObject == object) {
return NSF_TRUE;
} else {
AppendMatchingElement(interp, resultObj, object->cmdName, pattern);
}
}
cmdList = cmdList->nextPtr;
} while (cmdList != NULL);
return success;
}
/*
*----------------------------------------------------------------------
* AppendMatchingElementsFromClasses --
*
* Apply AppendMatchingElement() to all elements of the passed
* class list
*
* Results:
* NSF_TRUE iff a matching object was provided and it was found;
* NSF_FALSE otherwise
*
* Side effects:
* Appends elements to the result
*
*----------------------------------------------------------------------
*/
static bool AppendMatchingElementsFromClasses(
Tcl_Interp *interp, const NsfClasses *cls,
const char *pattern, NsfObject *matchObject
) nonnull(1);
static bool
AppendMatchingElementsFromClasses(
Tcl_Interp *interp, const NsfClasses *cls,
const char *pattern, NsfObject *matchObject
) {
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
resultObj = Tcl_GetObjResult(interp);
for ( ; cls != NULL; cls = cls->nextPtr) {
NsfObject *object = (NsfObject *)cls->cl;
if (object != NULL) {
if (matchObject != NULL && object == matchObject) {
/*
* We have a matchObject and it is identical to obj,
* just return true and don't continue search
*/
return NSF_TRUE;
} else {
AppendMatchingElement(interp, resultObj, object->cmdName, pattern);
}
}
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* GetAllInstances --
*
* Get all instances of a class recursively into an initialized
* String key hash-table.
*
* Results:
* None.
*
* Side effects:
* Passed hash-table contains instances.
*
*----------------------------------------------------------------------
*/
static void
GetAllInstances(Tcl_Interp *interp, NsfCmdList **instances, NsfClass *startClass) {
NsfClasses *clPtr, *subClasses;
nonnull_assert(interp != NULL);
nonnull_assert(instances != NULL);
nonnull_assert(startClass != NULL);
subClasses = TransitiveSubClasses(startClass);
for (clPtr = subClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
Tcl_HashTable *tablePtr = &clPtr->cl->instances;
Tcl_HashSearch search;
const Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
NsfObject *inst = (NsfObject *)Tcl_GetHashKey(tablePtr, hPtr);
Command *cmdPtr;
assert(inst != NULL);
if (unlikely((inst->flags & NSF_TCL_DELETE) != 0u)) {
NsfLog(interp, NSF_LOG_NOTICE, "Object %s is apparently deleted", ObjectName(inst));
continue;
}
cmdPtr = (Command *)inst->id;
assert(cmdPtr != NULL);
if (unlikely((cmdPtr->nsPtr->flags & NS_DYING) != 0u)) {
NsfLog(interp, NSF_LOG_WARN, "Namespace of %s is apparently deleted", ObjectName_(inst));
continue;
}
#if defined(NSF_DEVELOPMENT_TEST)
{
/*
* Make sure, we can still lookup the object; the object has to be still
* alive.
*/
NsfObject *object = GetObjectFromString(interp, ObjectName(inst));
/*
* HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is
* needed because objects can be hidden or re-exposed under a different
* name which is not reported back to the object system by the [interp
* hide|expose] mechanism. However, we still want to process hidden and
* re-exposed objects during cleanup like ordinary, exposed ones.
*/
if (unlikely(object == NULL)) {
object = GetHiddenObjectFromCmd(interp, inst->id);
}
assert(object != NULL);
}
#endif
/*fprintf (stderr, " -- %p flags %.6x activation %d %s id %p id->flags %.6x "
"nsPtr->flags %.6x (instance of %s)\n",
inst, inst->flags, inst->activationCount,
ObjectName(inst), inst->id, cmdPtr->flags, (cmdPtr->nsPtr != NULL) ? cmdPtr->nsPtr->flags : 0,
ClassName(clPtr->cl));*/
CmdListAdd(instances, inst->id, (NsfClass *)inst,
NSF_FALSE, NSF_FALSE);
}
}
if (subClasses != NULL) {
NsfClassListFree(subClasses);
}
}
/*
*----------------------------------------------------------------------
* AddToResultSet --
*
* Helper function to add classes to the result set (implemented as
* a hash-table), flagging test for matchObject as result.
*
* Results:
* NSF_TRUE iff a matching object was provided and it was found;
* NSF_FALSE otherwise
*
* Side effects:
* Appends optionally element to the result object.
*
*----------------------------------------------------------------------
*/
static bool AddToResultSet(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfObject *object, int *isNewPtr,
bool appendResult, const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
static bool
AddToResultSet(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfObject *object, int *isNewPtr,
bool appendResult, const char *pattern, NsfObject *matchObject
) {
nonnull_assert(interp != NULL);
nonnull_assert(destTablePtr != NULL);
nonnull_assert(resultSet != NULL);
nonnull_assert(object != NULL);
nonnull_assert(isNewPtr != NULL);
Tcl_CreateHashEntry(destTablePtr, (char *)object, isNewPtr);
if (*isNewPtr != 0) {
if (matchObject != NULL && matchObject == object) {
return NSF_TRUE;
}
if (appendResult) {
AppendMatchingElement(interp, resultSet, object->cmdName, pattern);
}
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* AddToResultSetWithGuards --
*
* Helper function to add classes with guards to the result set
* (implemented as a hash-table, full version as a Tcl list),
* flagging test for matchObject as result.
*
* Results:
* NSF_TRUE iff a matching object was provided and it was found;
* NSF_FALSE otherwise
*
* Side effects:
* Appends optionally element to the result object
*
*----------------------------------------------------------------------
*/
static bool AddToResultSetWithGuards(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfClass *class,
ClientData clientData, int *isNewPtr, bool appendResult,
const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(6) nonnull(5);
static bool
AddToResultSetWithGuards(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfClass *class,
ClientData clientData, int *isNewPtr, bool appendResult,
const char *pattern, NsfObject *matchObject
) {
bool result;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(destTablePtr != NULL);
nonnull_assert(class != NULL);
nonnull_assert(resultSet != NULL);
nonnull_assert(isNewPtr != NULL);
Tcl_CreateHashEntry(destTablePtr, (char *)class, isNewPtr);
if (*isNewPtr != 0 && appendResult) {
if (pattern == NULL || Tcl_StringMatch(ClassName_(class), pattern)) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
Tcl_Obj *g = (Tcl_Obj *)clientData;
INCR_REF_COUNT(listObj);
Tcl_ListObjAppendElement(interp, listObj, class->object.cmdName);
Tcl_ListObjAppendElement(interp, listObj, NsfGlobalObjs[NSF_GUARD_OPTION]);
Tcl_ListObjAppendElement(interp, listObj, g);
Tcl_ListObjAppendElement(interp, resultSet, listObj);
DECR_REF_COUNT(listObj);
}
result = (matchObject != NULL && matchObject == (NsfObject *)class);
} else {
result = NSF_FALSE;
}
return result;
}
/*
*----------------------------------------------------------------------
* GetAllObjectMixinsOf --
*
* Computes a set of classes, into which this class was mixed in
* via per object mixin. The function gets recursively all per
* object mixins from a class and its subclasses/isClassMixinOf
* and adds it into an initialized object ptr hash-table
* (TCL_ONE_WORD_KEYS).
*
* Results:
* Boolean value indicating when done.
*
* Side effects:
* The set of classes is returned in the provided hash-table.
*
*----------------------------------------------------------------------
*/
static bool GetAllObjectMixinsOf(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfClass *startClass, bool isMixin,
bool appendResult, const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static bool
GetAllObjectMixinsOf(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfClass *startClass, bool isMixin,
bool appendResult, const char *pattern, NsfObject *matchObject
) {
int isNew = 0;
NsfClasses *sc;
bool done = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(destTablePtr != NULL);
nonnull_assert(resultSet != NULL);
nonnull_assert(startClass != NULL);
/*fprintf(stderr, "startClass = %s, opt %p, isMixin %d, pattern '%s', matchObject %p\n",
ClassName(startClass), startClass->opt, isMixin, pattern, matchObject);*/
/*
* check all subclasses of startCl for mixins
*/
for (sc = startClass->sub; sc != NULL; sc = sc->nextPtr) {
done = GetAllObjectMixinsOf(interp, destTablePtr, resultSet,
sc->cl, isMixin, appendResult,
pattern, matchObject);
if (done) {
return done;
}
}
/*fprintf(stderr, "check subclasses of %s done\n", ClassName(startClass));*/
if (startClass->opt != NULL) {
NsfCmdList *m;
/*
* Check whether startCl has associated per-class mixins.
*/
for (m = startClass->opt->isClassMixinOf; m != NULL; m = m->nextPtr) {
NsfClass *class;
/*
* There should be no deleted commands in the list.
*/
assert(!TclIsCommandDeleted(m->cmdPtr));
class = NsfGetClassFromCmdPtr(m->cmdPtr);
assert(class != NULL);
/*fprintf(stderr, "check %s mixinof %s\n", ClassName(class), ClassName((startClass)));*/
done = GetAllObjectMixinsOf(interp, destTablePtr, resultSet,
class, isMixin, appendResult,
pattern, matchObject);
/* fprintf(stderr, "check %s mixinof %s done\n",
ClassName(class), ClassName(startClass));*/
if (done) {
return done;
}
}
/*
* Check whether startCl has associated per-object mixins.
*/
for (m = startClass->opt->isObjectMixinOf; m != NULL; m = m->nextPtr) {
NsfObject *object;
/*
* There should not be deleted commands in the list.
*/
assert(!TclIsCommandDeleted(m->cmdPtr));
object = NsfGetObjectFromCmdPtr(m->cmdPtr);
assert(object != NULL);
done = AddToResultSet(interp, destTablePtr, resultSet,
object, &isNew, appendResult,
pattern, matchObject);
if (done) {
return done;
}
}
}
return done;
}
/*
*----------------------------------------------------------------------
* AddClassListEntriesToMixinsOfSet --
*
* Helper function of GetAllClassMixinsOf(). Iterate over the
* provided class list (mixinOfs) and add every entry to the result
* set. If the entry is new, GetAllClassMixinsOf() is called
* recursively.
*
* Results:
* Boolean value indicating when done.
*
* Side effects:
* The set of classes is returned in the provided hash-table.
*
*----------------------------------------------------------------------
*/
static bool
AddClassListEntriesToMixinsOfSet(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfCmdList *mixinOfs,
bool appendResult,
const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static bool GetAllClassMixinsOf(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, NsfClass *startClass,
bool isPCM, bool appendResult,
const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static bool
AddClassListEntriesToMixinsOfSet(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, const NsfCmdList *mixinOfs,
bool appendResult,
const char *pattern, NsfObject *matchObject
) {
const NsfCmdList *m;
nonnull_assert(interp != NULL);
nonnull_assert(destTablePtr != NULL);
nonnull_assert(resultSet != NULL);
nonnull_assert(mixinOfs != NULL);
for (m = mixinOfs; m != NULL; m = m->nextPtr) {
NsfClass *class;
int isNew;
bool done;
/*
* We must not have deleted commands in the list
*/
assert(!TclIsCommandDeleted(m->cmdPtr));
class = NsfGetClassFromCmdPtr(m->cmdPtr);
assert(class != NULL);
done = AddToResultSet(interp, destTablePtr, resultSet,
&class->object, &isNew,
appendResult, pattern, matchObject);
if (done) {
return done;
}
if (isNew != 0) {
done = GetAllClassMixinsOf(interp, destTablePtr, resultSet, class,
NSF_TRUE, appendResult, pattern, matchObject);
if (done) {
return done;
}
}
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* GetAllClassMixinsOf --
*
* Computes a set of classes, into which this class was mixed in
* via as a class mixin. The function gets recursively all per
* class mixins from a class and its subclasses and adds it
* into an initialized object ptr hash-table (TCL_ONE_WORD_KEYS)
*
* Results:
* Boolean value indicating when done.
*
* Side effects:
* The set of classes is returned in the provided hash-table
*
*----------------------------------------------------------------------
*/
static bool
GetAllClassMixinsOf(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultSet, NsfClass *startClass,
bool isPCM, bool appendResult,
const char *pattern, NsfObject *matchObject
) {
NsfClasses *sc;
int isNew = 0;
bool done = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(destTablePtr != NULL);
nonnull_assert(resultSet != NULL);
nonnull_assert(startClass != NULL);
/*fprintf(stderr, "GetAllClassMixinsOf startClass = %p %s, opt %p, isPCM %d\n",
startClass, ClassName(startClass), startClass->opt, isPCM);*/
/*
* If the startClass is a per class mixin, add it to the result set
*/
if (isPCM) {
done = AddToResultSet(interp, destTablePtr, resultSet,
&startClass->object, &isNew,
appendResult, pattern, matchObject);
if (done) {
return done;
}
/*
* check all subclasses of startClass for mixins
*/
for (sc = startClass->sub; sc != NULL; sc = sc->nextPtr) {
#if !defined(NDEBUG)
if (sc->cl == startClass) {
/*
* Sanity check: it seems that we can create via
* __default_superclass a class which has itself as subclass!
*/
fprintf(stderr, "... STRANGE %p is subclass of %p %s, sub %p\n",
(void *)sc->cl, (void *)startClass, ClassName_(startClass),
(void *)startClass->sub);
continue;
}
#endif
assert(sc->cl != startClass);
done = GetAllClassMixinsOf(interp, destTablePtr, resultSet,
sc->cl, isPCM,
appendResult, pattern, matchObject);
if (done) {
return done;
}
}
}
/*
* Check whether "startClass" has a subclass which is a per-class mixin of some other
* class(es)
*/
{
NsfClasses *subClasses = TransitiveSubClasses(startClass), *subClass;
for (subClass = subClasses; subClass; subClass = subClass->nextPtr) {
const NsfClass *subSubClass = subClass->cl;
/*fprintf(stderr, "... check subclass = %p %s, opt %p, isPCM %d\n",
subSubClass, ClassName(subSubClass), subSubClass->opt, isPCM);*/
if (subSubClass->opt != NULL && subSubClass->opt->isClassMixinOf) {
done = AddClassListEntriesToMixinsOfSet(interp, destTablePtr, resultSet,
subSubClass->opt->isClassMixinOf,
appendResult, pattern, matchObject);
if (done) {
goto subclassExit;
}
}
}
subclassExit:
if (subClasses != NULL) {
NsfClassListFree(subClasses);
}
if (done) {
return done;
}
}
/*
* Check whether "startClass" is a per-class mixin of some other classes.
*/
if (startClass->opt != NULL && startClass->opt->isClassMixinOf) {
done = AddClassListEntriesToMixinsOfSet(interp, destTablePtr, resultSet,
startClass->opt->isClassMixinOf,
appendResult, pattern, matchObject);
}
return done;
}
/*
*----------------------------------------------------------------------
* GetAllClassMixins --
*
* Computes a set class-mixins of a given class and handles
* transitive cases. The classes are added it into an initialized
* object ptr hash-table (TCL_ONE_WORD_KEYS)
*
* Results:
* Boolean value indicating when done.
*
* Side effects:
* The set of classes is returned in the provided hash-table
*
*----------------------------------------------------------------------
*/
static bool GetAllClassMixins(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultObj, const NsfClass *startClass,
bool withGuards, const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static bool
GetAllClassMixins(
Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
Tcl_Obj *resultObj, const NsfClass *startClass,
bool withGuards, const char *pattern, NsfObject *matchObject
) {
int isNew = 0;
NsfClass *class;
NsfClasses *sc;
bool done = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(destTablePtr != NULL);
nonnull_assert(resultObj != NULL);
nonnull_assert(startClass != NULL);
/*
* check this class for class mixins.
*/
if (startClass->opt != NULL) {
NsfCmdList *m;
for (m = startClass->opt->classMixins; m != NULL; m = m->nextPtr) {
/*
* Make sure, there are no deleted commands in the list.
*/
assert(!TclIsCommandDeleted(m->cmdPtr));
class = NsfGetClassFromCmdPtr(m->cmdPtr);
assert(class != NULL);
/* fprintf(stderr, "class mixin found: %s\n", ClassName(class)); */
if (withGuards && (m->clientData)) {
/* fprintf(stderr, "AddToResultSetWithGuards: %s\n", ClassName(class)); */
done = AddToResultSetWithGuards(interp, destTablePtr, resultObj,
class, m->clientData, &isNew,
NSF_TRUE, pattern, matchObject);
} else {
/* fprintf(stderr, "AddToResultSet: %s\n", ClassName(class)); */
done = AddToResultSet(interp, destTablePtr, resultObj,
&class->object, &isNew,
NSF_TRUE, pattern, matchObject);
}
if (done) {
return done;
}
if (isNew != 0) {
/* fprintf(stderr, "class mixin GetAllClassMixins for: %s (%s)\n",
ClassName(class), ClassName(startClass)); */
done = GetAllClassMixins(interp, destTablePtr, resultObj,
class, withGuards,
pattern, matchObject);
if (done) {
return done;
}
}
}
}
/*
* Check all superClasses of startCl for class mixins.
*/
for (sc = startClass->super; sc != NULL; sc = sc->nextPtr) {
/* fprintf(stderr, "Superclass GetAllClassMixins for %s (%s)\n",
ClassName(sc->cl), ClassName(startClass)); */
done = GetAllClassMixins(interp, destTablePtr, resultObj,
sc->cl, withGuards,
pattern, matchObject);
if (done) {
return done;
}
}
return done;
}
/*
*----------------------------------------------------------------------
* RemoveFromClassMixinsOf --
*
* Remove the class (provided as a cmd) from all isClassMixinOf
* definitions from the provided classes (provided as cmdlist).
*
* Results:
* None.
*
* Side effects:
* Deletes potentially some entries in the isClassMixinOf lists.
*
*----------------------------------------------------------------------
*/
static void RemoveFromClassMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList)
nonnull(1) nonnull(2);
static void
RemoveFromClassMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList) {
nonnull_assert(cmd != NULL);
nonnull_assert(cmdList != NULL);
do {
const NsfClass *class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
NsfClassOpt *nclopt = (class != NULL) ? class->opt : NULL;
if (nclopt != NULL) {
NsfCmdList *del = CmdListFindCmdInList(cmd, nclopt->isClassMixinOf);
if (del != NULL) {
/* fprintf(stderr, "Removing class %s from isClassMixinOf of class %s\n",
ClassName(cl), ObjStr(NsfGetClassFromCmdPtr(cmdList->cmdPtr)->object.cmdName)); */
del = CmdListRemoveFromList(&nclopt->isClassMixinOf, del);
CmdListDeleteCmdListEntry(del, GuardDel);
}
}
cmdList = cmdList->nextPtr;
} while (cmdList != NULL);
}
/*
*----------------------------------------------------------------------
* RemoveFromObjectMixinsOf --
*
* Remove the class (provided as a cmd) from all isObjectMixinOf
* definitions from the provided classes (provided as cmdList).
*
* Results:
* None.
*
* Side effects:
* Deletes potentially some entries in the isObjectMixinOf lists.
*
*----------------------------------------------------------------------
*/
static void RemoveFromObjectMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList)
nonnull(1) nonnull(2);
static void
RemoveFromObjectMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList) {
nonnull_assert(cmd != NULL);
nonnull_assert(cmdList != NULL);
do {
const NsfClass *class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
NsfClassOpt *clopt = (class != NULL) ? class->opt : NULL;
if (clopt != NULL) {
NsfCmdList *del = CmdListFindCmdInList(cmd, clopt->isObjectMixinOf);
if (del != NULL) {
/* fprintf(stderr, "Removing object %s from isObjectMixinOf of Class %s\n",
ObjectName(object), ObjStr(NsfGetClassFromCmdPtr(cmdList->cmdPtr)->object.cmdName)); */
del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del);
CmdListDeleteCmdListEntry(del, GuardDel);
}
} /* else fprintf(stderr, "CleanupDestroyObject %s: NULL pointer in mixins!\n", ObjectName(object)); */
cmdList = cmdList->nextPtr;
} while(likely(cmdList != NULL));
}
/*
*----------------------------------------------------------------------
* RemoveFromClassmixins --
*
* Remove the class (provided as a cmd) from all class mixins lists
* from the provided classes (provided as cmdList).
*
* Results:
* None.
*
* Side effects:
* Deletes potentially some entries in the class mixins lists.
*
*----------------------------------------------------------------------
*/
static void RemoveFromClassmixins(Tcl_Command cmd, NsfCmdList *cmdList)
nonnull(1) nonnull(2);
static void
RemoveFromClassmixins(Tcl_Command cmd, NsfCmdList *cmdList) {
nonnull_assert(cmd != NULL);
nonnull_assert(cmdList != NULL);
do {
NsfClass *class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
NsfClassOpt *clopt = (class != NULL) ? class->opt : NULL;
if (clopt != NULL) {
NsfCmdList *del = CmdListFindCmdInList(cmd, clopt->classMixins);
if (del != NULL) {
/* fprintf(stderr, "Removing class %s from mixins of object %s\n",
ClassName(class), ObjStr(NsfGetObjectFromCmdPtr(cmdList->cmdPtr)->cmdName)); */
del = CmdListRemoveFromList(&clopt->classMixins, del);
CmdListDeleteCmdListEntry(del, GuardDel);
if (class->object.mixinOrder != NULL) {
MixinResetOrder(&class->object);
}
}
}
cmdList = cmdList->nextPtr;
} while (likely(cmdList != NULL));
}
/*
*----------------------------------------------------------------------
* RemoveFromObjectMixins --
*
* Remove the class (provided as a cmd) from all object mixin lists
* from the provided classes (provided as cmdList).
*
* Results:
* None.
*
* Side effects:
* Deletes potentially some entries in the object mixins lists.
*
*----------------------------------------------------------------------
*/
static void RemoveFromObjectMixins(Tcl_Command cmd, NsfCmdList *cmdList)
nonnull(1) nonnull(2);
static void
RemoveFromObjectMixins(Tcl_Command cmd, NsfCmdList *cmdList) {
nonnull_assert(cmd != NULL);
nonnull_assert(cmdList != NULL);
do {
NsfObject *object = NsfGetObjectFromCmdPtr(cmdList->cmdPtr);
NsfObjectOpt *objopt = (object != 0) ? object->opt : NULL;
if (objopt != NULL) {
NsfCmdList *del = CmdListFindCmdInList(cmd, objopt->objMixins);
if (del != NULL) {
/* fprintf(stderr, "Removing class %s from mixins of object %s\n",
ClassName(del->clorobj), ObjStr(NsfGetObjectFromCmdPtr(cmdList->cmdPtr)->cmdName)); */
del = CmdListRemoveFromList(&objopt->objMixins, del);
CmdListDeleteCmdListEntry(del, GuardDel);
if (object->mixinOrder != NULL) {
MixinResetOrder(object);
}
}
}
cmdList = cmdList->nextPtr;
} while (likely(cmdList != NULL));
}
/*
*----------------------------------------------------------------------
* ResetOrderOfObjectsUsingThisClassAsObjectMixin --
*
* Reset the per-object mixin order for all objects having this
* class as per-object mixin.
*
* Results:
* None.
*
* Side effects:
* Deletes potentially the mixin list for the objects.
*
*----------------------------------------------------------------------
*/
static void ResetOrderOfObjectsUsingThisClassAsObjectMixin(const NsfClass *class)
nonnull(1);
static void
ResetOrderOfObjectsUsingThisClassAsObjectMixin(const NsfClass *class) {
/*fprintf(stderr, "ResetOrderOfObjectsUsingThisClassAsObjectMixin %s - %p\n",
ClassName(class), class->opt);*/
nonnull_assert(class != NULL);
if (class->opt != NULL) {
const NsfCmdList *ml;
for (ml = class->opt->isObjectMixinOf; ml != NULL; ml = ml->nextPtr) {
NsfObject *object = NsfGetObjectFromCmdPtr(ml->cmdPtr);
if (object != NULL) {
if (object->mixinOrder != NULL) {
MixinResetOrder(object);
}
object->flags &= ~NSF_MIXIN_ORDER_VALID;
}
}
}
}
/*
*----------------------------------------------------------------------
* MixinInvalidateObjOrders --
*
* Reset mixin order for all instances of the class and the
* instances of its dependent subclasses. This function is
* typically called, when the class hierarchy or the class
* mixins have changed and invalidate mixin entries in all
* dependent instances.
*
* Results:
* None.
*
* Side effects:
* Deletes potentially the mixin list for the objects and classes.
*
*----------------------------------------------------------------------
*/
static void MixinInvalidateObjOrders(NsfClasses *subClasses)
nonnull(1);
static void
MixinInvalidateObjOrders(NsfClasses *subClasses) {
nonnull_assert(subClasses != NULL);
/*
* Iterate over the subclass hierarchy.
*/
do {
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
Tcl_HashTable *instanceTablePtr;
/*
* Reset mixin order for all objects having this class as per object mixin
*/
ResetOrderOfObjectsUsingThisClassAsObjectMixin(subClasses->cl);
if (subClasses->cl->parsedParamPtr != NULL) {
ParsedParamFree(subClasses->cl->parsedParamPtr);
subClasses->cl->parsedParamPtr = NULL;
}
instanceTablePtr = &subClasses->cl->instances;
for (hPtr = Tcl_FirstHashEntry(instanceTablePtr, &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
NsfObject *object = (NsfObject *)Tcl_GetHashKey(instanceTablePtr, hPtr);
assert(object != NULL);
if (likely((object->flags & NSF_DURING_DELETE) == 0u)
&& ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u)
) {
MixinResetOrder(object);
object->flags &= ~NSF_MIXIN_ORDER_VALID;
}
}
subClasses = subClasses->nextPtr;
} while (subClasses != NULL);
}
/*
*----------------------------------------------------------------------
* MixinComputeDefined --
*
* This function computes the mixin order for the provided object
* and adjusts the mixin flags accordingly. The mixin order is
* either
*
* DEFINED (there are mixins on the instance),
* NONE (there are no mixins for the instance),
* or INVALID (a class restructuring has occurred.
* It is not clear whether mixins are defined or not).
*
* If the mixin order is INVALID, MixinComputeDefined can be used
* to compute the order and set the instance to DEFINED or NONE.
*
* Results:
* None.
*
* Side effects:
* Might alter the mixin order.
*
*----------------------------------------------------------------------
*/
static void
MixinComputeDefined(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
MixinComputeOrder(interp, object);
object->flags |= NSF_MIXIN_ORDER_VALID;
if (object->mixinOrder != NULL) {
object->flags |= NSF_MIXIN_ORDER_DEFINED;
} else {
object->flags &= ~NSF_MIXIN_ORDER_DEFINED;
}
}
/*
*----------------------------------------------------------------------
* ComputePrecedenceList --
*
* Returns the precedence list for the provided object. The
* precedence list can optionally include the mixins and the
* root-class. If pattern is provided, this is used as well for
* filtering. The caller has to free the resulting list via
* NsfClassListFree();
*
* Results:
* Precedence list in form of a class list, potentially NULL due to
* filtering.
*
* Side effects:
* Allocated class list.
*
*----------------------------------------------------------------------
*/
static NsfClasses *ComputePrecedenceList(Tcl_Interp *interp, NsfObject *object,
const char *pattern,
bool withMixins, bool withRootClass)
nonnull(1) nonnull(2);
static NsfClasses *
ComputePrecedenceList(Tcl_Interp *interp, NsfObject *object,
const char *pattern,
bool withMixins, bool withRootClass) {
NsfClasses *precedenceList = NULL, *pcl, **npl = &precedenceList;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (withMixins) {
if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
}
if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
NsfCmdList *ml;
for (ml = object->mixinOrder; ml; ml = ml->nextPtr) {
NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
if ((pattern != NULL)
&& (mixin != NULL)
&& !Tcl_StringMatch(ClassName(mixin), pattern)) {
continue;
}
npl = NsfClassListAdd(npl, mixin, NULL);
}
}
}
pcl = PrecedenceOrder(object->cl);
for (; pcl != NULL; pcl = pcl->nextPtr) {
if (!withRootClass && IsRootClass(pcl->cl)) {
continue;
}
if (pattern != NULL && !Tcl_StringMatch(ClassName(pcl->cl), pattern)) {
continue;
}
npl = NsfClassListAdd(npl, pcl->cl, NULL);
}
return precedenceList;
}
/*
*----------------------------------------------------------------------
* SeekCurrent --
*
* Walk through the command list until the provided command is
* reached. return the next entry. If the provided cmd is NULL,
* then return the first entry.
*
* Results:
* Command list pointer or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfCmdList *SeekCurrent(const Tcl_Command cmd, register NsfCmdList *cmdListPtr)
nonnull(2) NSF_pure;
static NsfCmdList *
SeekCurrent(const Tcl_Command cmd, register NsfCmdList *cmdListPtr) {
nonnull_assert(cmdListPtr != NULL);
if (cmd != NULL) {
do {
if (cmdListPtr->cmdPtr == cmd) {
return cmdListPtr->nextPtr;
}
cmdListPtr = cmdListPtr->nextPtr;
} while likely(cmdListPtr != NULL);
return NULL;
}
return cmdListPtr;
}
/*
*----------------------------------------------------------------------
* CanInvokeMixinMethod --
*
* Check, whether the provided cmd is allowed to be dispatch in a
* mixin.
*
* Results:
* A standard Tcl result or NSF_CHECK_FAILED in case, search should
* continue.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int CanInvokeMixinMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd, NsfCmdList *cmdList)
nonnull(1) nonnull(2) nonnull(4);
static int
CanInvokeMixinMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd, NsfCmdList *cmdList) {
int result = TCL_OK;
unsigned int cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(cmdList != NULL);
if ((cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u ||
((cmdFlags & NSF_CMD_CLASS_ONLY_METHOD) != 0u && !NsfObjectIsClass(object))) {
/*
* The command is not applicable for objects (i.e. might crash,
* since it expects a class record); therefore, skip it
*/
return NSF_CHECK_FAILED;
}
if ((cmdList->clientData != NULL) && !RUNTIME_STATE(interp)->guardCount) {
/*fprintf(stderr, "guard call\n");*/
result = GuardCall(object, interp, (Tcl_Obj *)cmdList->clientData, NULL);
}
return result;
}
/*
*----------------------------------------------------------------------
* MixinSearchProc --
*
* Search for a method name in the mixin list of the provided
* object. Depending on the state of the mixin stack, the search
* starts at the beginning or at the last dispatched, shadowed
* method on the mixin path.
*
* Results:
* A standard Tcl result.
* Returns as well always cmd (maybe NULL) in cmdPtr.
* Returns on success as well the class and the currentCmdPointer
* for continuation in next.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int MixinSearchProc(
Tcl_Interp *interp, NsfObject *object,
const char *methodName,
NsfClass **classPtr, Tcl_Command *currentCmdPtr, Tcl_Command *cmdPtr
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6);
static int
MixinSearchProc(
Tcl_Interp *interp, NsfObject *object,
const char *methodName,
NsfClass **classPtr, Tcl_Command *currentCmdPtr, Tcl_Command *cmdPtr
) {
Tcl_Command cmd = NULL;
NsfCmdList *cmdList;
NsfClass *class = NULL;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(classPtr != NULL);
nonnull_assert(currentCmdPtr != NULL);
nonnull_assert(cmdPtr != NULL);
assert(object->mixinStack != NULL);
/*
* Ensure that the mixin order is valid.
*/
assert((object->flags & NSF_MIXIN_ORDER_VALID) != 0u);
if (object->mixinOrder == NULL) {
return TCL_OK;
}
cmdList = SeekCurrent(object->mixinStack->currentCmdPtr, object->mixinOrder);
RUNTIME_STATE(interp)->currentMixinCmdPtr = (cmdList != NULL) ? cmdList->cmdPtr : NULL;
/*fprintf(stderr, "searching for '%s' in %p\n", methodName, cmdList);
CmdListPrint(interp, "MixinSearch CL = \n", cmdList);*/
if (unlikely((*classPtr != NULL) && (*cmdPtr != NULL))) {
Tcl_Command lastCmdPtr = NULL;
/*fprintf(stderr, "... new branch\n");*/
for (; cmdList != NULL; cmdList = cmdList->nextPtr) {
NsfClass *class1;
/*
* Ignore deleted commands
*/
if (TclIsCommandDeleted(cmdList->cmdPtr)) {
continue;
}
class1 = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
assert(class1 != NULL);
lastCmdPtr = cmdList->cmdPtr;
if (class1 == *classPtr) {
/*
* The wanted class was found. Check guards and permissions to
* determine whether we can invoke this method.
*/
result = CanInvokeMixinMethod(interp, object, *cmdPtr, cmdList);
if (likely(result == TCL_OK)) {
class = class1;
} else if (result == NSF_CHECK_FAILED) {
result = TCL_OK;
}
/*
* No matter, what the result is, stop the search through the mixin
* classes here.
*/
break;
}
}
if (class != NULL) {
assert(cmdList != NULL);
/*
* On success: return class and cmdList->cmdPtr;
*/
*currentCmdPtr = cmdList->cmdPtr;
/*fprintf(stderr, "... mixinsearch success returns %p (class %s)\n", cmd, ClassName(class));*/
} else {
/*
* We did not find the absolute entry in the mixins. Set the
* currentCmdPtr (on the mixin stack) to the last entry to flag, that
* the mixin list should not started again on a next.
*/
*cmdPtr = NULL;
*currentCmdPtr = lastCmdPtr;
/*fprintf(stderr, "... mixinsearch success failure %p (class %s)\n", cmd, ClassName(class));*/
}
return result;
} else {
for (; cmdList; cmdList = cmdList->nextPtr) {
/*
* Ignore deleted commands
*/
if (TclIsCommandDeleted(cmdList->cmdPtr)) {
continue;
}
class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
assert(class != NULL);
/*
fprintf(stderr, "+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n",
ObjectName(object), methodName, cmdList,
cmdList->cmdPtr, cmdList->clientData);
*/
cmd = FindMethod(class->nsPtr, methodName);
if (cmd == NULL) {
continue;
}
result = CanInvokeMixinMethod(interp, object, cmd, cmdList);
if (unlikely(result == TCL_ERROR)) {
return result;
} else if (result == NSF_CHECK_FAILED) {
result = TCL_OK;
cmd = NULL;
continue;
}
/*
* cmd was found and is applicable. We return class and cmdPtr.
*/
*classPtr = class;
*currentCmdPtr = cmdList->cmdPtr;
/*fprintf(stderr, "mixinsearch returns %p (cl %s)\n", cmd, ClassName(class));*/
break;
}
}
*cmdPtr = cmd;
return result;
}
/*
* info option for mixins and class mixins
*/
static int MixinInfo(
Tcl_Interp *interp, const NsfCmdList *m, const char *pattern,
bool withGuards, const NsfObject *matchObject
) nonnull(1);
static int
MixinInfo(
Tcl_Interp *interp, const NsfCmdList *m, const char *pattern,
bool withGuards, const NsfObject *matchObject
) {
Tcl_Obj *list = Tcl_NewListObj(0, NULL);
nonnull_assert(interp != NULL);
/*fprintf(stderr, " mixin info m=%p, pattern %s, matchObject %p\n",
m, pattern, matchObject);*/
while (m != NULL) {
const NsfClass *mixinClass = NsfGetClassFromCmdPtr(m->cmdPtr);
/* fprintf(stderr, " mixin info m=%p, next=%p, pattern %s, matchObject %p\n",
m, m->next, pattern, matchObject);*/
if (mixinClass != NULL &&
(pattern == NULL
|| (matchObject != NULL && &(mixinClass->object) == matchObject)
|| (matchObject == NULL && Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern)))) {
if (withGuards && (m->clientData != NULL)) {
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, NsfGlobalObjs[NSF_GUARD_OPTION]);
Tcl_ListObjAppendElement(interp, l, g);
Tcl_ListObjAppendElement(interp, list, l);
} else {
Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName);
}
if (matchObject != NULL) {
break;
}
}
m = m->nextPtr;
}
Tcl_SetObjResult(interp, list);
return TCL_OK;
}
/*
* info option for mixinofs and isClassMixinOf
*/
static Tcl_Command MixinSearchMethodByName(NsfCmdList *mixinList, const char *name, NsfClass **classPtr)
nonnull(1) nonnull(2) nonnull(3);
static Tcl_Command
MixinSearchMethodByName(NsfCmdList *mixinList, const char *name, NsfClass **classPtr) {
Tcl_Command cmd;
nonnull_assert(mixinList != NULL);
nonnull_assert(name != NULL);
nonnull_assert(classPtr != NULL);
do {
NsfClass *foundClass = NsfGetClassFromCmdPtr(mixinList->cmdPtr);
if ((foundClass != NULL) && SearchCMethod(foundClass, name, &cmd)) {
*classPtr = foundClass;
return cmd;
}
mixinList = mixinList->nextPtr;
} while (mixinList != NULL);
return NULL;
}
/*
* Filter-Commands
*/
/*
* The search method implements filter search order for object and
* class filter: 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, metaclass
*/
static Tcl_Command FilterSearch(const char *name, NsfObject *startingObject,
NsfClass *startingClass, NsfClass **classPtr)
nonnull(1) nonnull(4);
static Tcl_Command
FilterSearch(const char *name, NsfObject *startingObject,
NsfClass *startingClass, NsfClass **classPtr) {
Tcl_Command cmd = NULL;
nonnull_assert(name != NULL);
nonnull_assert(classPtr != NULL);
if (startingObject != NULL) {
NsfObjectOpt *opt = startingObject->opt;
/*
* The object-specific filter can also be defined on the object's
* class, its hierarchy, or the respective class mixins; 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 != NULL
&& opt->objMixins != NULL
&& (cmd = MixinSearchMethodByName(opt->objMixins, name, classPtr))
) {
return cmd;
}
}
/*
* Search for class filters on class mixins
*/
if (startingClass != NULL) {
NsfClassOpt *opt = startingClass->opt;
if (opt != NULL && opt->classMixins != NULL) {
if ((cmd = MixinSearchMethodByName(opt->classMixins, name, classPtr))) {
return cmd;
}
}
}
/*
* Search for object procs that are used as filters
*/
if ((startingObject != NULL) && (startingObject->nsPtr != NULL)) {
/*fprintf(stderr, "search filter %s as proc \n", name);*/
if ((cmd = FindMethod(startingObject->nsPtr, name))) {
*classPtr = (NsfClass *)startingObject;
return cmd;
}
}
/*
* Ok, no filter on obj or mixins -> search class
*/
if (startingClass != NULL) {
*classPtr = SearchCMethod(startingClass, name, &cmd);
if (*classPtr == NULL) {
/*
* If no filter is found yet -> search the metaclass
*/
*classPtr = SearchCMethod(startingClass->object.cl, name, &cmd);
}
}
return cmd;
}
/*
* Filter Guards
*/
/*
*----------------------------------------------------------------------
* GuardCheck --
*
* Check, a filter guard.
*
* Results:
* A standard Tcl result or NSF_CHECK_FAILED in case, search should
* continue.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObj)
nonnull(1) nonnull(2);
static int
GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObj) {
NsfRuntimeState *rst;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(guardObj != NULL);
/*
* 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 TCL_OK
*/
/*fprintf(stderr, "checking guard **%s**\n", ObjStr(guardObj));*/
rst = RUNTIME_STATE(interp);
rst->guardCount++;
result = CheckConditionInScope(interp, guardObj);
rst->guardCount--;
/*fprintf(stderr, "checking guard **%s** returned rc=%d\n", ObjStr(guardObj), result);*/
if (likely(result == TCL_OK)) {
/* fprintf(stderr, " +++ OK\n"); */
} else if (unlikely(result == TCL_ERROR)) {
Tcl_Obj *sr = Tcl_GetObjResult(interp);
INCR_REF_COUNT(sr);
NsfPrintError(interp, "Guard error: '%s'\n%s", ObjStr(guardObj), ObjStr(sr));
DECR_REF_COUNT(sr);
} else {
/*
fprintf(stderr, " +++ FAILED\n");
*/
result = NSF_CHECK_FAILED;
}
return result;
}
/*
static void
GuardPrint(Tcl_Interp *interp, ClientData clientData) {
Tcl_Obj *guardObj = (Tcl_Obj *) clientData;
fprintf(stderr, " +++ \n");
if (guardObj != NULL) {
fprintf(stderr, " * %s \n", ObjStr(guardObj));
}
fprintf(stderr, " +++ \n");
}
*/
static void
GuardDel(NsfCmdList *guardList) {
nonnull_assert(guardList != NULL);
/*fprintf(stderr, "GuardDel %p clientData = %p\n",
guardList, (guardList != NULL) ? guardList->clientData : NULL);*/
if (guardList->clientData != NULL) {
DECR_REF_COUNT2("guardObj", (Tcl_Obj *)guardList->clientData);
guardList->clientData = NULL;
}
}
NSF_INLINE static void
GuardAdd(NsfCmdList *guardList, Tcl_Obj *guardObj) {
nonnull_assert(guardList != NULL);
nonnull_assert(guardObj != NULL);
GuardDel(guardList);
if (strlen(ObjStr(guardObj)) > 0) {
INCR_REF_COUNT2("guardObj", guardObj);
guardList->clientData = guardObj;
/*fprintf(stderr, "guard added to %p cmdPtr=%p, clientData= %p\n",
guardList, guardList->cmdPtr, guardList->clientData);
*/
}
}
static int
GuardCall(NsfObject *object, Tcl_Interp *interp, Tcl_Obj *guardObj, NsfCallStackContent *cscPtr) {
int result = TCL_OK;
Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */
CallFrame frame, *framePtr = &frame;
nonnull_assert(object != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(guardObj != NULL);
INCR_REF_COUNT(res);
/*
* For the guard push a fake call-frame on the Tcl stack so that
* e.g. a "self calledproc" and other methods in the guard behave
* like in the proc.
*/
if (cscPtr != NULL) {
Nsf_PushFrameCsc(interp, cscPtr, framePtr);
} else {
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
}
result = GuardCheck(interp, guardObj);
if (cscPtr != NULL) {
Nsf_PopFrameCsc(interp, framePtr);
} else {
Nsf_PopFrameObj(interp, framePtr);
}
if (result != TCL_ERROR) {
Tcl_SetObjResult(interp, res); /* restore the result */
}
DECR_REF_COUNT(res);
return result;
}
/*
*----------------------------------------------------------------------
* GuardAddFromDefinitionList --
*
* Add a guard to the specified destination list (first arg) from a
* list of definitions (last arg). If the provided cmd is found in
* the list of definitions, it is added to the destination list if
* it has non-null client data.
*
* Results:
* Returns Boolean value depending on whether the cmd is part of the
* definition list.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool GuardAddFromDefinitionList(NsfCmdList *dest, Tcl_Command interceptorCmd,
NsfCmdList *interceptorDefList)
nonnull(1) nonnull(2) nonnull(3);
static bool
GuardAddFromDefinitionList(NsfCmdList *dest, Tcl_Command interceptorCmd,
NsfCmdList *interceptorDefList) {
NsfCmdList *h;
nonnull_assert(interceptorCmd != NULL);
nonnull_assert(dest != NULL);
nonnull_assert(interceptorDefList != NULL);
h = CmdListFindCmdInList(interceptorCmd, interceptorDefList);
if (h != NULL) {
if (h->clientData != NULL) {
GuardAdd(dest, (Tcl_Obj *) h->clientData);
}
return NSF_TRUE;
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* GuardAddInheritedGuards --
*
* Add an inherited guards to the provided destination list.
*
* Results:
* None.
*
* Side effects:
* Updates potentially destination list
*
*----------------------------------------------------------------------
*/
static void GuardAddInheritedGuards(Tcl_Interp *interp, NsfCmdList *dest,
NsfObject *object, Tcl_Command filterCmd)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static void
GuardAddInheritedGuards(Tcl_Interp *interp, NsfCmdList *dest,
NsfObject *object, Tcl_Command filterCmd) {
NsfClasses *pl;
bool guardAdded = NSF_FALSE;
NsfObjectOpt *opt;
nonnull_assert(filterCmd != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(dest != NULL);
nonnull_assert(object != NULL);
/*
* Search guards for class filters registered on mixins.
*/
if (((object->flags & NSF_MIXIN_ORDER_VALID)) == 0u) {
MixinComputeDefined(interp, object);
}
if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
NsfCmdList *ml;
for (ml = object->mixinOrder; ml != NULL && !guardAdded; ml = ml->nextPtr) {
NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
if (mixin != NULL && mixin->opt != NULL && mixin->opt->classFilters != NULL) {
guardAdded = GuardAddFromDefinitionList(dest, filterCmd, mixin->opt->classFilters);
}
}
}
/*
* Search per-object filters.
*/
opt = object->opt;
if (!guardAdded && (opt != NULL) && (opt->objFilters != NULL)) {
guardAdded = GuardAddFromDefinitionList(dest, filterCmd, opt->objFilters);
}
if (!guardAdded) {
/*
* Search per-class filters.
*/
for (pl = PrecedenceOrder(object->cl); !guardAdded && (pl != NULL); pl = pl->nextPtr) {
NsfClassOpt *clopt = pl->cl->opt;
if (clopt != NULL && clopt->classFilters != NULL) {
guardAdded = GuardAddFromDefinitionList(dest, filterCmd, clopt->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) {
NsfCmdList *registeredFilter =
CmdListFindNameInList(interp, (char *) Tcl_GetCommandName(interp, filterCmd),
object->filterOrder);
if (registeredFilter && registeredFilter->clientData) {
GuardAdd(dest, (Tcl_Obj *) registeredFilter->clientData);
}
}
}
}
/*
*----------------------------------------------------------------------
* GuardList --
*
* Set interp result to a named guard in the provided
* guardList. The variable "guardList" might be NULL.
*
* Results:
* Sets the interpreter's result object.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int GuardList(Tcl_Interp *interp, NsfCmdList *guardList, const char *interceptorName)
nonnull(1) nonnull(3);
static int
GuardList(Tcl_Interp *interp, NsfCmdList *guardList, const char *interceptorName) {
nonnull_assert(interp != NULL);
nonnull_assert(interceptorName != NULL);
if (guardList != NULL) {
/*
* Try to find simple name first.
*/
NsfCmdList *h = CmdListFindNameInList(interp, interceptorName, guardList);
if (h == NULL) {
/*
* Maybe it is a qualified name.
*/
Tcl_Command cmd = NSFindCommand(interp, interceptorName);
if (cmd != NULL) {
h = CmdListFindCmdInList(cmd, guardList);
}
}
if (h != NULL) {
Tcl_ResetResult(interp);
if (h->clientData != NULL) {
Tcl_Obj *g = (Tcl_Obj *) h->clientData;
Tcl_SetObjResult(interp, g);
}
return TCL_OK;
}
}
return NsfPrintError(interp, "info guard: can't find filter/mixin %s", interceptorName);
}
/*
*----------------------------------------------------------------------
* FilterAddActive --
*
* Add a method name to the set of methods, which were used as filters in
* the current interp.
*
* TODO: let the set shrink, when filters are removed.
*
* Results:
* None.
*
* Side effects:
* Adding or updating of a hash entry
*
*----------------------------------------------------------------------
*/
static void FilterAddActive(Tcl_Interp *interp, const char *methodName)
nonnull(1) nonnull(2);
static void
FilterAddActive(Tcl_Interp *interp, const char *methodName) {
Tcl_HashEntry *hPtr;
int newItem;
nonnull_assert(interp != NULL);
nonnull_assert(methodName != NULL);
hPtr = Tcl_CreateHashEntry(&RUNTIME_STATE(interp)->activeFilterTablePtr, methodName, &newItem);
if (newItem != 0) {
Tcl_SetHashValue(hPtr, INT2PTR(1));
} else {
long count = PTR2INT(Tcl_GetHashValue(hPtr));
Tcl_SetHashValue(hPtr, INT2PTR(count+1));
}
}
/*
*----------------------------------------------------------------------
* FilterIsActive --
*
* Check, whether a method name is in the set of methods, which
* were used as filters in the current interp.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool FilterIsActive(Tcl_Interp *interp, const char *methodName)
nonnull(1) nonnull(2);
static bool
FilterIsActive(Tcl_Interp *interp, const char *methodName) {
const Tcl_HashEntry *hPtr;
nonnull_assert(interp != NULL);
nonnull_assert(methodName != NULL);
hPtr = Tcl_CreateHashEntry(&RUNTIME_STATE(interp)->activeFilterTablePtr, methodName, NULL);
return (hPtr != NULL);
}
/*
*----------------------------------------------------------------------
* FiltersDefined --
*
* Return the number of defined distinct names of filters.
*
* Results:
* Positive number.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static TCL_SIZE_T FiltersDefined(Tcl_Interp *interp)
nonnull(1) NSF_pure;
static TCL_SIZE_T
FiltersDefined(Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
return Tcl_HashSize(&RUNTIME_STATE(interp)->activeFilterTablePtr);
}
/*
*----------------------------------------------------------------------
* FilterAdd --
*
* Append a filter command to the 'filterList' of an obj/class
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object in error cases.
*
*----------------------------------------------------------------------
*/
static int FilterAdd(Tcl_Interp *interp, NsfCmdList **filterList, Tcl_Obj *filterregObj,
NsfObject *startingObject, NsfClass *startingClass)
nonnull(1) nonnull(2) nonnull(3);
static int
FilterAdd(Tcl_Interp *interp, NsfCmdList **filterList, Tcl_Obj *filterregObj,
NsfObject *startingObject, NsfClass *startingClass) {
Tcl_Obj *filterObj = NULL;
Tcl_Obj *guardObj = NULL;
Tcl_Command cmd = NULL;
NsfClass *class = NULL;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(filterList != NULL);
nonnull_assert(filterregObj != NULL);
/*
* When the provided nameObj is of type NsfFilterregObjType, the nsf specific
* converter was called already; otherwise call the converter here.
*/
if (filterregObj->typePtr != &NsfFilterregObjType) {
/*fprintf(stderr, "FilterAdd: convert %s in FilterAdd\n", ObjStr(filterregObj));*/
if (Tcl_ConvertToType(interp, filterregObj, &NsfFilterregObjType) != TCL_OK) {
result = TCL_ERROR;
}
} else {
/*fprintf(stderr, "FilterAdd: %s already converted\n", ObjStr(filterregObj));*/
}
if (result == TCL_OK) {
result = NsfFilterregGet(interp, filterregObj, &filterObj, &guardObj);
if (result == TCL_OK) {
const char *filterName = ObjStr(filterObj);
cmd = FilterSearch(filterName, startingObject, startingClass, &class);
if (cmd == NULL) {
if (startingObject != NULL) {
result = NsfPrintError(interp, "object filter: can't find filterproc '%s' on %s ",
filterName, ObjectName(startingObject));
} else {
result = NsfPrintError(interp, "class filter: can't find filterproc '%s' on %s ",
filterName, ClassName(startingClass));
}
assert(result == TCL_ERROR);
}
}
}
if (result == TCL_OK) {
NsfCmdList *new;
/*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(nameObj), class);*/
new = CmdListAdd(filterList, cmd, class,
/*noDuplicates*/ NSF_TRUE, NSF_TRUE);
FilterAddActive(interp, ObjStr(filterObj));
if (guardObj != NULL) {
GuardAdd(new, guardObj);
} else if (new->clientData != NULL) {
GuardDel(new);
}
}
return result;
}
/*
*----------------------------------------------------------------------
* FilterResetOrder --
*
* Reset the filter order cached in obj->filterOrder
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void FilterResetOrder(NsfObject *object)
nonnull(1);
static void
FilterResetOrder(NsfObject *object) {
nonnull_assert(object != NULL);
CmdListFree(&object->filterOrder, GuardDel);
object->filterOrder = NULL;
}
/*
*----------------------------------------------------------------------
* FilterSearchAgain --
*
* 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.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void FilterSearchAgain(Tcl_Interp *interp, NsfCmdList **filters,
NsfObject *startingObject, NsfClass *startingClass)
nonnull(1) nonnull(2);
static void
FilterSearchAgain(Tcl_Interp *interp, NsfCmdList **filters,
NsfObject *startingObject, NsfClass *startingClass) {
NsfCmdList *cmdList;
nonnull_assert(interp != NULL);
nonnull_assert(filters != NULL);
CmdListRemoveDeleted(filters, GuardDel);
cmdList = *filters;
while (cmdList != NULL) {
NsfCmdList *del = NULL;
NsfClass *class = NULL;
const char *simpleName = Tcl_GetCommandName(interp, cmdList->cmdPtr);
Tcl_Command cmd = FilterSearch(simpleName, startingObject, startingClass,
&class);
if (cmd == NULL) {
del = CmdListRemoveFromList(filters, cmdList);
/*
* The actual deletion via CmdListDeleteCmdListEntry is deferred to the
* end of the loop block, otherwise for del == cmdList, we risk running
* into an invalid pointer access.
*/
} else if (cmd != cmdList->cmdPtr) {
CmdListReplaceCmd(cmdList, cmd, class);
}
cmdList = cmdList->nextPtr;
if (del != NULL) {
CmdListDeleteCmdListEntry(del, GuardDel);
}
}
}
/*
*----------------------------------------------------------------------
* FilterInvalidateObjOrders --
*
* Invalidate filter entries in all dependent instances. This will
* be e.g. necessary, when the class hierarchy or the class filters
* have changed.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void FilterInvalidateObjOrders(Tcl_Interp *interp, NsfClasses *subClasses)
nonnull(1) nonnull(2);
static void
FilterInvalidateObjOrders(Tcl_Interp *interp, NsfClasses *subClasses) {
nonnull_assert(interp != NULL);
nonnull_assert(subClasses != NULL);
do {
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
assert(subClasses->cl);
hPtr = Tcl_FirstHashEntry(&subClasses->cl->instances, &hSrch);
/*
* Recalculate the commands of all class-filter registrations.
*/
if (subClasses->cl->opt != NULL) {
FilterSearchAgain(interp, &subClasses->cl->opt->classFilters, NULL, subClasses->cl);
}
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
NsfObject *object = (NsfObject *)Tcl_GetHashKey(&subClasses->cl->instances, hPtr);
FilterResetOrder(object);
object->flags &= ~NSF_FILTER_ORDER_VALID;
/*
* Recalculate the commands of all object filter registrations.
*/
if (object->opt != NULL) {
FilterSearchAgain(interp, &object->opt->objFilters, object, NULL);
}
}
subClasses = subClasses->nextPtr;
} while (likely(subClasses != NULL));
}
/*
*----------------------------------------------------------------------
* FilterRemoveDependentFilterCmds --
*
*
* Remove all filters from all subclasses that refer to
* "removeClass". This function is e.g. used to remove filters
* defined in superclass list from a dependent class.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/*
*/
static void FilterRemoveDependentFilterCmds(NsfClass *removeClass, NsfClasses *subClasses)
nonnull(1) nonnull(2);
static void
FilterRemoveDependentFilterCmds(NsfClass *removeClass, NsfClasses *subClasses) {
nonnull_assert(removeClass != NULL);
nonnull_assert(subClasses != NULL);
/*fprintf(stderr, "FilterRemoveDependentFilterCmds removeClass %p %s\n",
removeClass, ObjStr(removeClass->object.cmdName));*/
do {
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
NsfClassOpt *opt;
assert(subClasses->cl);
hPtr = Tcl_FirstHashEntry(&subClasses->cl->instances, &hSrch);
opt = subClasses->cl->opt;
if (opt != NULL) {
CmdListRemoveContextClassFromList(&opt->classFilters, removeClass, GuardDel);
}
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
NsfObject *object = (NsfObject *) Tcl_GetHashKey(&subClasses->cl->instances, hPtr);
if (object->opt != NULL) {
CmdListRemoveContextClassFromList(&object->opt->objFilters, removeClass, GuardDel);
}
}
subClasses = subClasses->nextPtr;
} while (subClasses != NULL);
}
/*
*----------------------------------------------------------------------
* MethodHandleObj --
*
* Builds a methodHandle from a method name. We assume, the
* methodName is not fully qualified (i.e. it must not start with a
* colon).
*
* Results:
* fresh Tcl_Obj
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj * MethodHandleObj(NsfObject *object, int withPer_object, const char *methodName)
nonnull(1) nonnull(3) returns_nonnull;
static Tcl_Obj *
MethodHandleObj(NsfObject *object, int withPer_object, const char *methodName) {
Tcl_Obj *resultObj;
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
assert(*methodName != ':');
if (withPer_object == 1) {
resultObj = Tcl_NewStringObj("", 0);
} else {
resultObj = Tcl_NewStringObj(nsfClassesPrefix, (int)nsfClassesPrefixLength);
}
Tcl_AppendObjToObj(resultObj, object->cmdName);
Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL);
return resultObj;
}
/*
*----------------------------------------------------------------------
* FilterInfo --
*
* Set the interp results with a Tcl list containing the content of
* the filter list. The options withGuards and withMethodHandles
* can be used for different output structures
*
* Results:
* Standard Tcl results
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int FilterInfo(Tcl_Interp *interp, NsfCmdList *f, const char *pattern,
bool withGuards, bool withMethodHandles)
nonnull(1);
static int
FilterInfo(Tcl_Interp *interp, NsfCmdList *f, const char *pattern,
bool withGuards, bool withMethodHandles) {
Tcl_Obj *list = Tcl_NewListObj(0, NULL);
nonnull_assert(interp != NULL);
/*
* Guard lists should only have unqualified filter lists when "withGuards"
* is activated. "withMethodHandles" has no effect when "withGuards" is
* specified.
*/
if (withGuards) {
withMethodHandles = NSF_FALSE;
}
while (f != NULL) {
const char *simpleName = Tcl_GetCommandName(interp, f->cmdPtr);
if (pattern == NULL || Tcl_StringMatch(simpleName, pattern)) {
if (withGuards && (f->clientData != NULL)) {
Tcl_Obj *innerList = Tcl_NewListObj(0, NULL);
Tcl_Obj *g = (Tcl_Obj *) f->clientData;
Tcl_ListObjAppendElement(interp, innerList,
Tcl_NewStringObj(simpleName, TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, innerList, NsfGlobalObjs[NSF_GUARD_OPTION]);
Tcl_ListObjAppendElement(interp, innerList, g);
Tcl_ListObjAppendElement(interp, list, innerList);
} else {
if (withMethodHandles) {
NsfClass *filterClass = f->clorobj;
Tcl_ListObjAppendElement(interp, list,
MethodHandleObj((NsfObject *)filterClass,
!NsfObjectIsClass(&filterClass->object), simpleName));
} else {
Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, TCL_INDEX_NONE));
}
}
}
f = f->nextPtr;
}
Tcl_SetObjResult(interp, list);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* FilterComputeOrderFullList --
*
* Compute a fresh list of filters and append it to the filterList.
*
* Results:
* None.
*
* Side effects:
* Updating filterList
*
*----------------------------------------------------------------------
*/
static void FilterComputeOrderFullList(
Tcl_Interp *interp, NsfCmdList **filters,
NsfCmdList **filterList
) nonnull(1) nonnull(2) nonnull(3);
static void
FilterComputeOrderFullList(
Tcl_Interp *interp, NsfCmdList **filters,
NsfCmdList **filterList
) {
const NsfCmdList *f ;
const NsfClasses *pl;
NsfClass *filterClass;
nonnull_assert(interp != NULL);
nonnull_assert(filters != NULL);
nonnull_assert(filterList != NULL);
/*
* Ensure that no epoched command is in the filters list.
*/
CmdListRemoveDeleted(filters, GuardDel);
for (f = *filters; f != NULL; f = f->nextPtr) {
const char *simpleName = Tcl_GetCommandName(interp, f->cmdPtr);
filterClass = f->clorobj;
CmdListAdd(filterList, f->cmdPtr, filterClass,
/*noDuplicates*/ NSF_FALSE, NSF_TRUE);
if (filterClass != NULL && !NsfObjectIsClass(&filterClass->object)) {
/*
* Get the class from the object for per-object filter.
*/
filterClass = ((NsfObject *)filterClass)->cl;
}
/*
* If we have a filter class -> search up the inheritance hierarchy.
*/
if (filterClass != NULL) {
pl = PrecedenceOrder(filterClass);
if (pl != NULL && pl->nextPtr != NULL) {
/*
* Don't search on the start class again.
*/
pl = pl->nextPtr;
/*
* Now go up the hierarchy.
*/
for(; pl != NULL; pl = pl->nextPtr) {
Tcl_Command pi = FindMethod(pl->cl->nsPtr, simpleName);
if (pi != NULL) {
CmdListAdd(filterList, pi, pl->cl,
/*noDuplicates*/ NSF_FALSE, NSF_TRUE);
/*
fprintf(stderr, " %s::%s, ", ClassName(pl->cl), simpleName);
*/
}
}
}
}
}
/*CmdListPrint(interp, "FilterComputeOrderFullList....\n", *filterList);*/
}
/*
*----------------------------------------------------------------------
* FilterComputeOrder --
*
* 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 precedence rule is that the last
* occurrence makes it into the final list (object->filterOrder).
*
* Results:
* None.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static void FilterComputeOrder(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static void
FilterComputeOrder(Tcl_Interp *interp, NsfObject *object) {
NsfCmdList *filterList = NULL, *next, *checker, *newList;
NsfClasses *pl;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (object->filterOrder != NULL) {
FilterResetOrder(object);
}
/*
fprintf(stderr, " List: ", ObjectName(object));
*/
/*
* Append class filters registered for mixins.
*/
if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
}
if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
NsfCmdList *ml;
for (ml = object->mixinOrder; ml != NULL; ml = ml->nextPtr) {
NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
if (mixin != NULL && mixin->opt != NULL && mixin->opt->classFilters != NULL) {
FilterComputeOrderFullList(interp, &mixin->opt->classFilters, &filterList);
}
}
}
/*
* Append per-obj filters.
*/
if (object->opt != NULL) {
FilterComputeOrderFullList(interp, &object->opt->objFilters, &filterList);
}
/*
* Append per-class filters.
*/
for (pl = PrecedenceOrder(object->cl); pl != NULL; pl = pl->nextPtr) {
NsfClassOpt *clopt = pl->cl->opt;
if (clopt != NULL && clopt->classFilters != NULL) {
FilterComputeOrderFullList(interp, &clopt->classFilters, &filterList);
}
}
/*
* Use no duplicates & no classes of the precedence order
* on the resulting list.
*/
while (filterList != NULL) {
/*
* Search for filterList->cmdPtr
*/
for (checker = next = filterList->nextPtr; checker != NULL; checker = checker->nextPtr) {
if (checker->cmdPtr == filterList->cmdPtr) {
break;
}
}
if (checker == NULL) {
/*
* filterList->cmdPtr was found
*/
newList = CmdListAdd(&object->filterOrder, filterList->cmdPtr, filterList->clorobj,
/*noDuplicates*/ NSF_FALSE, NSF_TRUE);
GuardAddInheritedGuards(interp, newList, object, filterList->cmdPtr);
/*
GuardPrint(interp, newList->clientData);
*/
}
CmdListDeleteCmdListEntry(filterList, GuardDel);
filterList = next;
}
}
/*
*----------------------------------------------------------------------
* FilterComputeDefined --
*
* Compute the state of the filter order. The filter order is either
*
* DEFINED (there are filter on the instance),
* NONE (there are no filter for the instance),
* or INVALID (a class restructuring has occurred, 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.
*
* Results:
* None.
*
* Side effects:
* Updating object-flags
*
*----------------------------------------------------------------------
*/
static void
FilterComputeDefined(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
FilterComputeOrder(interp, object);
object->flags |= NSF_FILTER_ORDER_VALID;
if (object->filterOrder != NULL) {
object->flags |= NSF_FILTER_ORDER_DEFINED;
} else {
object->flags &= ~NSF_FILTER_ORDER_DEFINED;
}
}
/*
*----------------------------------------------------------------------
* FilterStackPush --
*
* Push a filter stack information on this object and initialize it with
* calledProc.
*
* Results:
* None.
*
* Side effects:
* Updating object->filterStack
*
*----------------------------------------------------------------------
*/
static void FilterStackPush(NsfObject *object, Tcl_Obj *calledProc)
nonnull(1) nonnull(2);
static void
FilterStackPush(NsfObject *object, Tcl_Obj *calledProc) {
register NsfFilterStack *h = NEW(NsfFilterStack);
nonnull_assert(object != NULL);
nonnull_assert(calledProc != NULL);
h->currentCmdPtr = NULL;
h->calledProc = calledProc;
INCR_REF_COUNT(h->calledProc);
h->nextPtr = object->filterStack;
object->filterStack = h;
}
/*
*----------------------------------------------------------------------
* FilterStackPush --
*
* Pop filter stack information from the specified object
*
* Results:
* None.
*
* Side effects:
* Free filter stack info
*
*----------------------------------------------------------------------
*/
static void FilterStackPop(NsfObject *object)
nonnull(1);
static void
FilterStackPop(NsfObject *object) {
register NsfFilterStack *h;
nonnull_assert(object != NULL);
h = object->filterStack;
object->filterStack = h->nextPtr;
/*
* Free stack entry.
*/
DECR_REF_COUNT(h->calledProc);
FREE(NsfFilterStack, h);
}
/*
*----------------------------------------------------------------------
* FilterFindReg --
*
* Search through the filter list on obj and class hierarchy for
* registration of a cmdPtr as filter
*
* Results:
* Returns a Tcl list with the filter registration, like:
* " filter , " filter ,
* or an empty list, if not registered
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj * FilterFindReg(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd)
nonnull(1) nonnull(2) nonnull(3) returns_nonnull;
static Tcl_Obj *
FilterFindReg(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd) {
Tcl_Obj *list = Tcl_NewListObj(0, NULL);
NsfClasses *pl;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(cmd != NULL);
/*
* Search per-object filters.
*/
if (object->opt != NULL
&& object->opt->objFilters != NULL
&& CmdListFindCmdInList(cmd, object->opt->objFilters)) {
Tcl_ListObjAppendElement(interp, list, object->cmdName);
Tcl_ListObjAppendElement(interp, list, NsfGlobalObjs[NSF_OBJECT]);
Tcl_ListObjAppendElement(interp, list, NsfGlobalObjs[NSF_FILTER]);
Tcl_ListObjAppendElement(interp, list,
Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), TCL_INDEX_NONE));
return list;
}
/*
* Search per-class filters.
*/
for (pl = PrecedenceOrder(object->cl); pl != NULL; pl = pl->nextPtr) {
NsfClassOpt *opt = pl->cl->opt;
if (opt != NULL && opt->classFilters != NULL) {
if (CmdListFindCmdInList(cmd, opt->classFilters)) {
Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName);
Tcl_ListObjAppendElement(interp, list, NsfGlobalObjs[NSF_FILTER]);
Tcl_ListObjAppendElement(interp, list,
Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), TCL_INDEX_NONE));
return list;
}
}
}
return list;
}
/*
*----------------------------------------------------------------------
* FilterSearchProc --
*
* FilterSearchProc seeks the current filter and the relevant calling
* information (class and currentCmd). The function assumes to be called
* with an existing filterStack.
*
* Results:
* Tcl_Command or NULL
*
* Side effects:
* Updates *currentCmd and **cl
*
*----------------------------------------------------------------------
*/
/*
*/
static Tcl_Command FilterSearchProc(Tcl_Interp *interp, NsfObject *object,
Tcl_Command *currentCmd, NsfClass **classPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static Tcl_Command
FilterSearchProc(Tcl_Interp *interp, NsfObject *object,
Tcl_Command *currentCmd, NsfClass **classPtr) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(currentCmd != NULL);
nonnull_assert(classPtr != NULL);
assert(object->filterStack != NULL);
/*
* Ensure that the filter order is not invalid, otherwise compute order
* FilterComputeDefined(interp, object);
*/
assert(object->flags & NSF_FILTER_ORDER_VALID);
if (object->filterOrder != NULL) {
NsfCmdList *cmdList;
*currentCmd = NULL;
cmdList = SeekCurrent(object->filterStack->currentCmdPtr, object->filterOrder);
while (cmdList != NULL) {
/*fprintf(stderr, "FilterSearchProc found %s\n",
Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr));*/
if (Tcl_Command_cmdEpoch(cmdList->cmdPtr) != 0) {
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, ee found it
*/
if (cmdList->clorobj && !NsfObjectIsClass(&cmdList->clorobj->object)) {
*classPtr = NULL;
} else {
*classPtr = 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;
}
/*
*----------------------------------------------------------------------
* SuperclassAdd --
*
* Add a list of superClasses (specified in the argument vector) to
* the specified class. On the first call, the class has no previous
* superClasses.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Rearranging the class relations, flushing previous precedence
* orders.
*
*----------------------------------------------------------------------
*/
static int SuperclassAdd(Tcl_Interp *interp, NsfClass *class, TCL_OBJC_T oc, Tcl_Obj **ov, Tcl_Obj *arg)
nonnull(1) nonnull(2) nonnull(4) nonnull(5);
static int
SuperclassAdd(Tcl_Interp *interp, NsfClass *class, TCL_OBJC_T oc, Tcl_Obj **ov, Tcl_Obj *arg) {
NsfClasses *superClasses, *subClasses, *osl = NULL;
NsfObjectSystem *osPtr;
NsfClass **classPtr;
TCL_OBJC_T i, j;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(ov != NULL);
nonnull_assert(arg != NULL);
superClasses = PrecedenceOrder(class);
subClasses = DependentSubClasses(class);
/*
* 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 (superClasses != NULL) {
superClasses = superClasses->nextPtr;
}
for (; superClasses; superClasses = superClasses->nextPtr) {
FilterRemoveDependentFilterCmds(superClasses->cl, subClasses);
}
/*
* Invalidate all interceptors' orders of instances of this and of all
* depended classes.
*/
MixinInvalidateObjOrders(subClasses);
if (FiltersDefined(interp) > 0) {
FilterInvalidateObjOrders(interp, subClasses);
}
/*
* Build an array of superClasses from the argument vector.
*/
classPtr = NEW_ARRAY(NsfClass*, oc);
for (i = 0; i < oc; i++) {
if (GetClassFromObj(interp, ov[i], &classPtr[i], NSF_TRUE) != TCL_OK) {
FREE(NsfClass**, classPtr);
NsfClassListFree(subClasses);
return NsfObjErrType(interp, "superclass", arg, "a list of classes", NULL);
}
}
/*
* Check that superClasses don't precede their classes.
*/
for (i = 0; i < oc; i++) {
for (j = i+1; j < oc; j++) {
NsfClasses *dl = PrecedenceOrder(classPtr[j]);
dl = NsfClassListFind(dl, classPtr[i]);
if (dl != NULL) {
FREE(NsfClass**, classPtr);
NsfClassListFree(subClasses);
return NsfObjErrType(interp, "superclass", arg, "classes in dependence order", NULL);
}
}
}
/*
* Ensure that the current class and new superClasses are from the
* same object system.
*/
osPtr = GetObjectSystem(&class->object);
for (i = 0; i < oc; i++) {
if (osPtr != GetObjectSystem(&classPtr[i]->object)) {
NsfPrintError(interp, "class \"%s\" has a different object system as class \"%s\"",
ClassName_(class), ClassName(classPtr[i]));
NsfClassListFree(subClasses);
FREE(NsfClass**, classPtr);
return TCL_ERROR;
}
}
while (class->super != NULL) {
/*
* Build a backup of the old superclass list in case we need to revert.
*/
NsfClass *superClass = class->super->cl;
NsfClasses *l = osl;
osl = NEW(NsfClasses);
osl->cl = superClass;
osl->nextPtr = l;
(void)RemoveSuper(class, class->super->cl);
}
for (i = 0; i < oc; i++) {
AddSuper(class, classPtr[i]);
}
FlushPrecedences(subClasses);
NsfClassListFree(subClasses);
FREE(NsfClass**, classPtr);
if (unlikely(!PrecedenceOrder(class))) {
NsfClasses *l;
/*
* There is a cycle in the superclass graph, we have to revert and return
* an error.
*/
while (class->super != NULL) {
(void)RemoveSuper(class, class->super->cl);
}
for (l = osl; l != NULL; l = l->nextPtr) {
AddSuper(class, l->cl);
}
if (osl != NULL) {
NsfClassListFree(osl);
}
return NsfObjErrType(interp, "superclass", arg, "a cycle-free graph", NULL);
}
if (osl != NULL) {
NsfClassListFree(osl);
}
assert(class->super != NULL);
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* CheckVarName --
*
* Check, whether the provided name is free of namespace markup.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int CheckVarName(Tcl_Interp *interp, const char *varNameString)
nonnull(1) nonnull(2);
static int
CheckVarName(Tcl_Interp *interp, const char *varNameString) {
nonnull_assert(interp != NULL);
nonnull_assert(varNameString != NULL);
/*
* We want to have a plain variable name, since we do not want to
* get interferences with namespace resolver and such. In a first
* attempt, we disallowed occurrences 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 NsfPrintError(interp, "variable name \"%s\" must not contain "
"namespace separator or colon prefix",
varNameString);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* VarExists --
*
* Check, whether the named variable exists on the specified object.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool VarExists(
Tcl_Interp *interp, NsfObject *object,
const char *name1, const char *name2, unsigned int flags
) nonnull(1) nonnull(2) nonnull(3);
static bool
VarExists(
Tcl_Interp *interp, NsfObject *object,
const char *name1, const char *name2,
unsigned int flags
) {
CallFrame frame, *framePtr = &frame;
const Var *varPtr;
Var *arrayPtr;
bool result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(name1 != NULL);
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, (NsfObject *)object, framePtr);
#pragma GCC diagnostic pop
if ((flags & NSF_VAR_TRIGGER_TRACE) != 0u) {
varPtr = TclVarTraceExists(interp, name1);
} else {
varPtr = TclLookupVar(interp, name1, name2, 0, "access",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
}
/*
fprintf(stderr, "VarExists %s varPtr %p flags %.4x isundef %d\n",
name1,
varPtr,
flags, (varPtr != NULL) ? TclIsVarUndefined(varPtr) : NULL);
*/
result = ((varPtr != NULL) && ((flags & NSF_VAR_REQUIRE_DEFINED) == 0u || !TclIsVarUndefined(varPtr)));
if (result && ((flags & NSF_VAR_ISARRAY) != 0u) && !TclIsVarArray(varPtr)) {
result = NSF_FALSE;
}
Nsf_PopFrameObj(interp, framePtr);
return result;
}
#if defined(WITH_TCL_COMPILE)
# include
#endif
/*
*----------------------------------------------------------------------
* MakeProcError --
*
* Function called internally from Tcl in case the definition of
* the proc failed.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
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;
TCL_SIZE_T nameLen, limit = 60;
const char *procName;
/*fprintf(stderr, "MakeProcError %p type %p refCount %d\n",
procNameObj, procNameObj->typePtr, procNameObj->refCount);*/
procName = Tcl_GetString(procNameObj);
nameLen = procNameObj->length;
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp,
Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %lu)",
(int)((overflow != 0) ? limit : nameLen), procName,
((overflow != 0) ? "..." : ""),
(unsigned long)Tcl_GetErrorLine(interp)));
}
/*
*----------------------------------------------------------------------
* ByteCompiled --
*
* Function to determine whether a proc is already byte compiled or
* not.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ByteCompiled(
Tcl_Interp *interp, unsigned int *flagsPtr,
Proc *procPtr, Namespace *nsPtr, const char *procName
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
static int
ByteCompiled(
Tcl_Interp *interp, unsigned int *flagsPtr,
Proc *procPtr, Namespace *nsPtr, const char *procName
) {
Tcl_Obj *bodyObj;
nonnull_assert(interp != NULL);
nonnull_assert(flagsPtr != NULL);
nonnull_assert(procPtr != NULL);
nonnull_assert(procName != NULL);
nonnull_assert(nsPtr != NULL);
bodyObj = procPtr->bodyPtr;
if (likely(bodyObj->typePtr == Nsf_OT_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 = bodyObj->internalRep.otherValuePtr;
if (unlikely(((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch))) {
# if defined(VAR_RESOLVER_TRACE)
fprintf(stderr, "ByteCompiled bytecode not valid proc %p cmd %p method %s\n",
(void *)procPtr, (void *)procPtr->cmdPtr,
Tcl_GetCommandName(interp, (Tcl_Command)procPtr->cmdPtr));
fprintf(stderr, " %d %d %d %d\n",
((Interp *) *codePtr->interpHandle != iPtr),
(codePtr->compileEpoch != iPtr->compileEpoch),
(codePtr->nsPtr != nsPtr),
(codePtr->nsEpoch != nsPtr->resolverEpoch));
{
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
fprintf(stderr, "... local %p '%s' resolveInfo %p deleteProc %p\n",
(void *)localPtr, localPtr->name, (void *)localPtr->resolveInfo,
(localPtr->resolveInfo != NULL) ? (void *)localPtr->resolveInfo->deleteProc : NULL);
}
}
# endif
/* dummy statement for coverage analysis */
assert(1);
goto doCompilation;
}
#endif
return TCL_OK;
} else {
int result;
Namespace *definitionNsPtr;
#if defined(HAVE_TCL_COMPILE_H)
doCompilation:
#endif
*flagsPtr |= NSF_CSC_CALL_IS_COMPILE;
/*fprintf(stderr, "compiling '%s' with ns %s\n", procName, nsPtr->name);*/
/*
* Tcl's bytecode compiler (TclCompileScript & friends) will access the
* proc command's namespace as resolution context for command lookups
* (Tcl_FindCommand) when compiling the proc. We, therefore, have to patch
* the proc command for the compilation step to point to the execution
* namespace; and restore the definition namespace on leaving.
*/
definitionNsPtr = procPtr->cmdPtr->nsPtr;
procPtr->cmdPtr->nsPtr = nsPtr;
result = TclProcCompileProc(interp, procPtr, bodyObj,
(Namespace *) nsPtr, "body of proc",
procName);
procPtr->cmdPtr->nsPtr = definitionNsPtr;
/*fprintf(stderr, "compiling '%s' with ns %s DONE\n", procName, nsPtr->name);*/
*flagsPtr &= ~NSF_CSC_CALL_IS_COMPILE;
return result;
}
}
/*
*----------------------------------------------------------------------
* PushProcCallFrame --
*
* Set up and push a new call frame for the procedure invocation.
* call-frame. The proc is passed via clientData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* compiles body conditionally
*
*----------------------------------------------------------------------
*/
static int PushProcCallFrame(
Proc *procPtr, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Namespace *execNsPtr,
NsfCallStackContent *cscPtr
) nonnull(1) nonnull(2) nonnull(4) nonnull(6);
static int
PushProcCallFrame(
Proc *procPtr, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Namespace *execNsPtr,
NsfCallStackContent *cscPtr
) {
Tcl_CallFrame *framePtr;
int result;
nonnull_assert(procPtr != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(cscPtr != NULL);
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute either in the provided execNs or 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 when the command is renamed from one namespace to another.
*/
if (execNsPtr == NULL) {
execNsPtr = (Tcl_Namespace *) procPtr->cmdPtr->nsPtr;
}
/*
* TODO: We could use Tcl_PushCallFrame(), if we would allocate the
* Tcl stack frame earlier.
*/
result = TclPushStackFrame(interp, (Tcl_CallFrame **)&framePtr,
execNsPtr,
(FRAME_IS_PROC|FRAME_IS_NSF_METHOD));
if (likely(result == TCL_OK)) {
Tcl_CallFrame_objc(framePtr) = (TCL_SIZE_T)objc;
Tcl_CallFrame_objv(framePtr) = objv;
Tcl_CallFrame_procPtr(framePtr) = procPtr;
Tcl_CallFrame_clientData(framePtr) = cscPtr;
/*fprintf(stderr, "Stack Frame %p procPtr %p compiledLocals %p firstLocal %p\n",
(void *)framePtr, (void *)procPtr, (void *)Tcl_CallFrame_compiledLocals(framePtr),
(void *)procPtr->firstLocalPtr);*/
result = ByteCompiled(interp, &cscPtr->flags, procPtr, (Namespace *)execNsPtr, ObjStr(objv[0]));
}
return result;
}
#include "nsfAPI.h"
/*
*----------------------------------------------------------------------
* ObjectSystemsCheckSystemMethod --
*
* Mark the specified method as (potentially) 'overloaded' in all object
* systems and declare it 'defined' in the specified object system.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Updates the object system structure(s).
*
*----------------------------------------------------------------------
*/
static int
ObjectSystemsCheckSystemMethod(
Tcl_Interp *interp, const char *methodName, const NsfObject *object, unsigned int flags
) {
NsfObjectSystem *osPtr, *defOsPtr;
char firstChar;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
firstChar = *methodName;
defOsPtr = GetObjectSystem(object);
for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
int i, isRootClassMethod;
unsigned int flag = 0u;
NsfObject *defObject;
const char **methodStrings = osPtr->methodNames;
for (i = 0; i <= NSF_s_set_idx; i++) {
const char *methodString = *methodStrings ++;
if (likely(methodString != NULL)
&& unlikely(*methodString == firstChar)
&& strcmp(methodName, methodString) == 0) {
flag = 1u << i;
break;
}
}
if (flag == 0u) {
continue;
}
isRootClassMethod = *(Nsf_SystemMethodOpts[i]+1) == 'o';
defObject = (isRootClassMethod == 1)
? &osPtr->rootClass->object
: &osPtr->rootMetaClass->object;
if (osPtr->handles[i] && osPtr->protected[i]) {
if (defObject == object && (flags & NSF_CMD_REDEFINE_PROTECTED_METHOD) == 0u) {
return NsfPrintError(interp, "refuse to overwrite protected method %s on %s",
methodName, ObjectName(defObject));
}
}
if ((osPtr->definedMethods & flag) != 0u) {
/*
* If for some reason base methods become redefined (e.g. in a reload),
* do not count them as overloads.
*/
if ((isRootClassMethod == 1
&& object == &defOsPtr->rootClass->object)
|| (isRootClassMethod == 0
&& object == &defOsPtr->rootMetaClass->object)
) {
/*fprintf(stderr, "+++ %s %.6x NOT overloading %s.%s %s (is root %d, is meta %d)\n",
ClassName(defOsPtr->rootClass),
osPtr->overloadedMethods, ObjectName(object), methodName, Nsf_SystemMethodOpts[i],
object == &defOsPtr->rootClass->object,
object == &defOsPtr->rootMetaClass->object);*/
} else {
osPtr->overloadedMethods |= flag;
/*fprintf(stderr, "+++ %s %.6x overloading %s.%s %s (is root %d, is meta %d)\n",
ClassName(defOsPtr->rootClass),
osPtr->overloadedMethods, ObjectName(object), methodName, Nsf_SystemMethodOpts[i],
object == &defOsPtr->rootClass->object,
object == &defOsPtr->rootMetaClass->object);*/
}
}
if ((osPtr == defOsPtr)
&& ((osPtr->definedMethods & flag) == 0u)
) {
/*
* Mark the method as defined.
*/
osPtr->definedMethods |= flag;
/*fprintf(stderr, "+++ %s %.6x defining %s.%s %s osPtr %p defined %.8x flag %.8x handle %p\n",
ClassName(defOsPtr->rootClass), osPtr->definedMethods, ObjectName(object),
methodName, Nsf_SystemMethodOpts[i], (void *)osPtr, osPtr->definedMethods, flag,
(void *)osPtr->handles[i]);*/
/*
* If there is a method handle provided for this system method, register
* it as a fallback; unless the method is to be defined at the root
* class.
*/
if (osPtr->handles[i]) {
if (defObject != object) {
int result;
NsfLog(interp, NSF_LOG_DEBUG, "Define automatically alias %s for %s",
ObjStr(osPtr->handles[i]), Nsf_SystemMethodOpts[i]);
result = NsfMethodAliasCmd(interp, defObject, 0, methodName, 0,
ProtectionRedefine_protectedIdx, osPtr->handles[i]);
if (unlikely(result != TCL_OK)) {
/*
* Alias definition failed.
*/
NsfLog(interp, NSF_LOG_WARN, "Could not define alias %s for %s",
ObjStr(osPtr->handles[i]), Nsf_SystemMethodOpts[i]);
return TCL_ERROR;
} else {
/*
* Alias definition succeeded.
*/
Tcl_Obj *methodObj = Tcl_GetObjResult(interp);
Tcl_Command cmd = Tcl_GetCommandFromObj(interp, methodObj);
/*
* Since the defObject is not equal to the overloaded method, the
* definition above is effectively an overload of the alias.
*/
osPtr->overloadedMethods |= flag;
/*
* Set method protection.
*/
if (cmd != NULL) {
Tcl_Command_flags(cmd) |= NSF_CMD_CALL_PROTECTED_METHOD;
if (osPtr->protected[i]) {
Tcl_Command_flags(cmd) |= NSF_CMD_REDEFINE_PROTECTED_METHOD;
}
}
Tcl_ResetResult(interp);
}
}
}
}
}
return TCL_OK;
}
/*----------------------------------------------------------------------
* ParamsNew --
*
* Allocate an array of Nsf_Param structures
*
* Results:
* Pointer to allocated memory
*
* Side effects:
* Allocation of memory.
*
*----------------------------------------------------------------------
*/
static Nsf_Param *
ParamsNew(size_t nr) {
Nsf_Param *paramsPtr = NEW_ARRAY(Nsf_Param, nr+1);
memset(paramsPtr, 0, sizeof(Nsf_Param) * (nr+1));
return paramsPtr;
}
/*----------------------------------------------------------------------
* ParamFree --
*
* Deallocate the contents of a single Nsf_Param*
*
* Results:
* None.
*
* Side effects:
* Free the parameter definition.
*
*----------------------------------------------------------------------
*/
static void ParamFree(Nsf_Param *paramPtr)
nonnull(1);
static void
ParamFree(Nsf_Param *paramPtr) {
nonnull_assert(paramPtr != NULL);
/*fprintf(stderr, "ParamFree %p\n", (void *)paramPtr);*/
if (paramPtr->name != NULL) {STRING_FREE("paramPtr->name", paramPtr->name);}
if (paramPtr->nameObj != NULL) {DECR_REF_COUNT(paramPtr->nameObj);}
if (paramPtr->defaultValue != NULL) {DECR_REF_COUNT(paramPtr->defaultValue);}
if (paramPtr->converterName != NULL) {DECR_REF_COUNT2("converterNameObj", paramPtr->converterName);}
if (paramPtr->converterArg != NULL) {DECR_REF_COUNT(paramPtr->converterArg);}
if (paramPtr->paramObj != NULL) {DECR_REF_COUNT(paramPtr->paramObj);}
if (paramPtr->slotObj != NULL) {DECR_REF_COUNT(paramPtr->slotObj);}
if (paramPtr->method != NULL) {DECR_REF_COUNT(paramPtr->method);}
}
/*----------------------------------------------------------------------
* ParamsFree --
*
* Deallocate a block of multiple Nsf_Param*
*
* Results:
* None.
*
* Side effects:
* Free the parameter definition.
*
*----------------------------------------------------------------------
*/
static void ParamsFree(Nsf_Param *paramsPtr)
nonnull(1);
static void
ParamsFree(Nsf_Param *paramsPtr) {
Nsf_Param *paramPtr;
nonnull_assert(paramsPtr != NULL);
/*fprintf(stderr, "ParamsFree %p\n", (void *)paramsPtr);*/
for (paramPtr = paramsPtr; paramPtr->name != NULL; paramPtr++) {
ParamFree(paramPtr);
}
FREE(Nsf_Param*, paramsPtr);
}
/*----------------------------------------------------------------------
* ParamDefsGet --
*
* Obtain parameter definitions for a cmdPtr; Optionally, this command
* returns as well a flag for ProcessMethodArguments to indicate if the
* parameter have to checked always.
*
* Results:
* Parameter definitions or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static NsfParamDefs *
ParamDefsGet(
const Tcl_Command cmdPtr,
unsigned int *checkAlwaysFlagPtr,
Tcl_Namespace **execNsPtrPtr
) {
NsfParamDefs *result;
nonnull_assert(cmdPtr != NULL);
if (likely(Tcl_Command_deleteProc(cmdPtr) == NsfProcDeleteProc)) {
NsfProcContext *ctx = (NsfProcContext *)Tcl_Command_deleteData(cmdPtr);
if (checkAlwaysFlagPtr != NULL) {
*checkAlwaysFlagPtr = ctx->checkAlwaysFlag;
}
if (execNsPtrPtr != NULL) {
*execNsPtrPtr = ctx->execNsPtr;
}
result = ctx->paramDefs;
} else {
result = NULL;
}
return result;
}
/*----------------------------------------------------------------------
* ParamDefsGetReturns --
*
* Obtain the "returns" value from NsfProcContext.
*
* Results:
* Tcl_Obj or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static Tcl_Obj *ParamDefsGetReturns(
const Tcl_Command cmdPtr
) nonnull(1) NSF_pure;
NSF_INLINE static Tcl_Obj *
ParamDefsGetReturns(const Tcl_Command cmdPtr) {
const NsfProcContext *pCtx;
Tcl_Obj *resultObj;
nonnull_assert(cmdPtr != NULL);
pCtx = ProcContextGet(cmdPtr);
if (pCtx != NULL) {
resultObj = pCtx->returnsObj;
} else {
resultObj = NULL;
}
return resultObj;
}
/*----------------------------------------------------------------------
* ParamDefsSetReturns --
*
* Set the "returns" value in an NsfProcContext. If the member is already
* in use, release the old value first.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static void ParamDefsSetReturns(
Tcl_Command cmdPtr, Tcl_Obj *returnsObj
) nonnull(1);
NSF_INLINE static void
ParamDefsSetReturns(Tcl_Command cmd, Tcl_Obj *returnsObj) {
NsfProcContext *pCtx;
const char *valueString;
nonnull_assert(cmd != NULL);
pCtx = ProcContextRequire(cmd);
valueString = returnsObj != NULL ? Tcl_GetString(returnsObj) : NULL;
if (pCtx->returnsObj != NULL) {
DECR_REF_COUNT2("returnsObj", pCtx->returnsObj);
}
if (valueString == NULL || *valueString == '\0') {
/*
* Set returnsObj to NULL
*/
pCtx->returnsObj = NULL;
} else {
pCtx->returnsObj = returnsObj;
INCR_REF_COUNT2("returnsObj", pCtx->returnsObj);
}
}
/*----------------------------------------------------------------------
* NsfParamDefsNonposLookup --
*
* Process a list of ParamDefs look for a non-pos args. If there is no exact
* match, look for an abbreviated match having at least
* NSF_ABBREV_MIN_CHARS leading chars which are identical.
*
* Results:
* Standard Tcl result; might set paramPtrPtr;
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int NsfParamDefsNonposLookup(
Tcl_Interp *interp, const char *nameString,
const Nsf_Param *paramsPtr, const Nsf_Param **paramPtrPtr
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
NsfParamDefsNonposLookup(
Tcl_Interp *interp, const char *nameString,
const Nsf_Param *paramsPtr, const Nsf_Param **paramPtrPtr
) {
const Nsf_Param *paramPtr;
char ch1;
size_t length;
nonnull_assert(interp != NULL);
nonnull_assert(nameString != NULL);
nonnull_assert(paramsPtr != NULL);
nonnull_assert(paramPtrPtr != NULL);
/*
* The provided paramsPtr must point to a block starting with a non-pos arg.
*/
assert(paramsPtr->name != NULL);
assert(*paramsPtr->name == '-');
/*
* The provided nameString starts as well with a leading dash.
*/
assert(*nameString == '-');
ch1 = nameString[2];
for (paramPtr = paramsPtr; likely(paramPtr->name != NULL) && *paramPtr->name == '-'; paramPtr++) {
if (unlikely((paramPtr->flags & NSF_ARG_NOCONFIG) != 0u)) {
continue;
}
if (ch1 == paramPtr->name[2]
&& strcmp(nameString, paramPtr->name) == 0) {
*paramPtrPtr = paramPtr;
return TCL_OK;
}
}
length = strlen(nameString);
if (length >= NSF_ABBREV_MIN_CHARS) {
for (paramPtr = paramsPtr; likely(paramPtr->name != NULL) && *paramPtr->name == '-'; paramPtr++) {
if (unlikely((paramPtr->flags & NSF_ARG_NOCONFIG) != 0u)) {
continue;
}
if (ch1 == paramPtr->name[2]
&& strncmp(nameString, paramPtr->name, length) == 0) {
const Nsf_Param *pPtr;
/* fprintf(stderr, "... <%s> is an abbrev of <%s>\n", nameString, paramPtr->name); */
/*
* Check whether the abbreviation is unique.
*/
for (pPtr = paramPtr + 1; likely(pPtr->name != NULL) && *pPtr->name == '-'; pPtr++) {
if (unlikely((pPtr->flags & NSF_ARG_NOCONFIG) != 0u)) {
continue;
}
if (ch1 == pPtr->name[2]
&& strncmp(nameString, pPtr->name, length) == 0) {
/*
* The abbreviation is not unique
*/
*paramPtrPtr = NULL;
return NsfPrintError(interp, "the provided argument %s is an abbreviation for %s and %s",
nameString, paramPtr->name, pPtr->name);
}
}
/*
* The abbreviation is unique
*/
*paramPtrPtr = paramPtr;
return TCL_OK;
}
}
}
*paramPtrPtr = NULL;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* CGetParamLookup --
*
* Obtain the parameter definition for a Tcl_Obj starting with a "-". It
* can return an error, when the specified parameter is ambiguous.
*
* Results:
* A standard Tcl result, on success paramPtr in last argument
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CGetParamLookup(
Tcl_Interp *interp,
Tcl_Obj *nameObj,
NsfParamDefs *paramDefs,
const Nsf_Param **paramPtrPtr
) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
CGetParamLookup(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfParamDefs *paramDefs, const Nsf_Param **paramPtrPtr)
{
const char *nameString;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(paramDefs != NULL);
nonnull_assert(paramPtrPtr != NULL);
/*
* Does provided value start with a dash?
*/
nameString = ObjStr(nameObj);
if (unlikely(*nameString != '-')) {
result = NsfPrintError(interp,
"cget: parameter must start with a '-': %s",
nameString);
} else {
NsfFlag *flagPtr = nameObj->internalRep.twoPtrValue.ptr1;
if ((nameObj->typePtr == &NsfFlagObjType)
&& (flagPtr->signature == paramDefs->paramsPtr)
&& (flagPtr->serial == paramDefs->serial)
) {
*paramPtrPtr = flagPtr->paramPtr;
} else {
Nsf_Param *paramPtr;
/*
* Skip leading parameters from the definition, which are no non-pos args
* (very unlikely).
*/
for (paramPtr = paramDefs->paramsPtr;
(paramPtr->name != NULL) && (*paramPtr->name != '-');
paramPtr++) {
;
}
/*
* Perform the lookup from the group starting with paramPtr.
*/
result = NsfParamDefsNonposLookup(interp, nameString, paramPtr, paramPtrPtr);
if (unlikely(result == TCL_OK)) {
/*
* Set the flag value. Probably, we should prohibit conversion on some
* types.
*/
NsfFlagObjSet(interp, nameObj, paramDefs->paramsPtr, paramDefs->serial,
*paramPtrPtr, NULL, 0u);
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfProcDeleteProc --
*
* FreeProc for procs with associated parameter definitions.
*
* Results:
* None.
*
* Side effects:
* Freeing memory.
*
*----------------------------------------------------------------------
*/
static void
NsfProcDeleteProc(
ClientData clientData
) {
const NsfProcContext *ctxPtr;
nonnull_assert(clientData != NULL);
ctxPtr = (NsfProcContext *)clientData;
if (ctxPtr->oldDeleteProc != NULL) {
(*ctxPtr->oldDeleteProc)(ctxPtr->oldDeleteData);
}
if (ctxPtr->paramDefs != NULL) {
/*fprintf(stderr, "free ParamDefs %p\n", (void*)ctxPtr->paramDefs);*/
ParamDefsRefCountDecr(ctxPtr->paramDefs);
}
if (ctxPtr->colonLocalVarCache != NULL) {
/*fprintf(stderr, "free colonLocalVarCache %p\n", (void*)ctxPtr->colonLocalVarCache);*/
FREE(int*, ctxPtr->colonLocalVarCache);
}
if (ctxPtr->returnsObj != NULL) {
DECR_REF_COUNT2("returnsObj", ctxPtr->returnsObj);
}
if (ctxPtr->execNsPtr != NULL) {
/*
* Balances increment in ParamDefsStore.
*/
NSNamespaceRelease(ctxPtr->execNsPtr);
}
/*fprintf(stderr, "free %p\n", (void *)ctxPtr);*/
FREE(NsfProcContext, ctxPtr);
}
/*
*----------------------------------------------------------------------
* ProcContextRequire --
*
* Obtain an NsfProcContext for the given cmd. Create a new one, if it does
* not exist, or return the existing one.
*
* Results:
* NsfProcContext *
*
* Side effects:
* Might allocate memory
*
*----------------------------------------------------------------------
*/
static NsfProcContext *
ProcContextRequire(
Tcl_Command cmd
) {
NsfProcContext *ctxPtr;
Command *cmdPtr;
nonnull_assert(cmd != NULL);
cmdPtr = (Command *)cmd;
if (cmdPtr->deleteProc != NsfProcDeleteProc) {
ctxPtr = NEW(NsfProcContext);
/*fprintf(stderr, "ParamDefsStore %p replace deleteProc %p by %p\n",
(void *)paramDefs, (void *)cmdPtr->deleteProc, (void *)NsfProcDeleteProc);*/
ctxPtr->oldDeleteData = (Proc *)cmdPtr->deleteData;
ctxPtr->oldDeleteProc = cmdPtr->deleteProc;
cmdPtr->deleteProc = NsfProcDeleteProc;
cmdPtr->deleteData = ctxPtr;
ctxPtr->paramDefs = NULL;
ctxPtr->checkAlwaysFlag = 0;
ctxPtr->execNsPtr = NULL;
ctxPtr->colonLocalVarCache = NULL;
ctxPtr->returnsObj = NULL;
} else {
ctxPtr = (NsfProcContext *)Tcl_Command_deleteData(cmdPtr);
}
return ctxPtr;
}
/*
*----------------------------------------------------------------------
* ProcContextGet --
*
* Obtain an NsfProcContext for the given cmd when it is defined.
*
* Results:
* NsfProcContext * or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static NsfProcContext *
ProcContextGet(
const Tcl_Command cmdPtr
) {
NsfProcContext *result;
nonnull_assert(cmdPtr != NULL);
if (likely(Tcl_Command_deleteProc(cmdPtr) == NsfProcDeleteProc)) {
result = (NsfProcContext *)Tcl_Command_deleteData(cmdPtr);
} else {
result = NULL;
}
return result;
}
/*
*----------------------------------------------------------------------
* ParamDefsStore --
*
* Store the provided parameter definitions in the provided
* command. It stores a new deleteProc which will call the original
* delete proc automatically.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void ParamDefsStore(
Tcl_Command cmd,
NsfParamDefs *paramDefs,
unsigned int checkAlwaysFlag,
Tcl_Namespace *execNsPtr
) nonnull(1);
static void
ParamDefsStore(
Tcl_Command cmd,
NsfParamDefs *paramDefs,
unsigned int checkAlwaysFlag,
Tcl_Namespace *execNsPtr
) {
NsfProcContext *ctxPtr;
nonnull_assert(cmd != NULL);
ctxPtr = ProcContextRequire(cmd);
/*
* We assume, that this never called for overwriting paramDefs
*/
assert(ctxPtr->paramDefs == NULL);
/* fprintf(stderr, "ParamDefsStore paramDefs %p called: NS %s\n",
(void *)paramDefs, execNsPtr ? execNsPtr->fullName : "na");*/
ctxPtr->paramDefs = paramDefs;
ctxPtr->checkAlwaysFlag = checkAlwaysFlag;
ctxPtr->execNsPtr = execNsPtr;
if (ctxPtr->execNsPtr != NULL) {
/*
* Balanced by decrement in NsfProcDeleteProc.
*/
NSNamespacePreserve(ctxPtr->execNsPtr);
}
}
/*
*----------------------------------------------------------------------
* ParamDefsNew --
*
* Allocate a new paramDefs structure and initialize it with zeros. The
* allocated structure should be freed with ParamDefsFree().
*
* Results:
* pointer to paramDefs structure
*
* Side effects:
* Allocating memory
*
*----------------------------------------------------------------------
*/
static NsfParamDefs *
ParamDefsNew(void) {
NsfParamDefs *paramDefs;
static NsfMutex serialMutex = 0;
static int serial = 0;
paramDefs = NEW(NsfParamDefs);
memset(paramDefs, 0, sizeof(NsfParamDefs));
/*
* We could keep the serial as well in thread local storage.
*/
NsfMutexLock(&serialMutex);
paramDefs->serial = serial++;
NsfMutexUnlock(&serialMutex);
/*fprintf(stderr, "ParamDefsNew %p\n", (void *)paramDefs);*/
return paramDefs;
}
/*
*----------------------------------------------------------------------
* ParamDefsFree --
*
* Free the parameter definitions. Since the parameter definitions are
* ref-counted, this function should be just called via
* ParamDefsRefCountDecr.
*
* Results:
* None.
*
* Side effects:
* Free the parameter definitions.
*
*----------------------------------------------------------------------
*/
static void ParamDefsFree(NsfParamDefs *paramDefs)
nonnull(1);
static void
ParamDefsFree(NsfParamDefs *paramDefs) {
/* fprintf(stderr, "ParamDefsFree %p \n",
(void *)paramDefs, paramDefs);*/
nonnull_assert(paramDefs != NULL);
if (paramDefs->paramsPtr != NULL) {
ParamsFree(paramDefs->paramsPtr);
}
FREE(NsfParamDefs, paramDefs);
}
/*
*----------------------------------------------------------------------
* ParamDefsRefCountIncr --
* ParamDefsRefCountDecr --
*
* Perform book keeping on the parameter definitions. RefCounting is
* necessary, since it might be possible that during the processing of the
* e.g. object parameters, these might be redefined (when an object
* parameter calls a method, redefining the structures).
* ParamDefsRefCountDecr() is responsible for actually freeing the
* structure.
*
* Results:
* None.
*
* Side effects:
* No direct.
*
*----------------------------------------------------------------------
*/
static void
ParamDefsRefCountIncr(NsfParamDefs *paramDefs) {
nonnull_assert(paramDefs != NULL);
paramDefs->refCount ++;
}
static void
ParamDefsRefCountDecr(NsfParamDefs *paramDefs) {
nonnull_assert(paramDefs != NULL);
paramDefs->refCount --;
if (paramDefs->refCount < 1) {
ParamDefsFree(paramDefs);
}
}
/*
*----------------------------------------------------------------------
* ParamDefsFormatOption --
*
* Append a parameter option to the nameStringObj representing the
* syntax of the parameter definition.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void ParamDefsFormatOption(
Tcl_Obj *nameStringObj, const char *option, TCL_SIZE_T optionLength,
int *colonWritten, int *firstOption
) nonnull(1) nonnull(2) nonnull(4) nonnull(5);
static void
ParamDefsFormatOption(
Tcl_Obj *nameStringObj, const char *option, TCL_SIZE_T optionLength,
int *colonWritten, int *firstOption
) {
nonnull_assert(nameStringObj != NULL);
nonnull_assert(option != NULL);
nonnull_assert(colonWritten != NULL);
nonnull_assert(firstOption != NULL);
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, (TCL_SIZE_T)optionLength, INT_MAX, NULL);
}
/*
*----------------------------------------------------------------------
* ParamDefsFormat --
*
* Produce a Tcl_Obj representing a single parameter in the syntax
* of the parameter definition.
*
* Results:
* Tcl_Obj
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *ParamDefsFormat(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) nonnull(1) nonnull(2) returns_nonnull;
static int ParamsDefMatchPattern(const Nsf_Param *paramsPtr, const char *pattern) {
if (paramsPtr->nameObj != NULL) {
return Tcl_StringMatch(ObjStr(paramsPtr->nameObj), pattern);
} else {
return Tcl_StringMatch(paramsPtr->name, pattern);
}
}
static Tcl_Obj *
ParamDefsFormat(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) {
int first, colonWritten;
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL), *innerListObj, *nameStringObj;
nonnull_assert(interp != NULL);
nonnull_assert(paramsPtr != NULL);
INCR_REF_COUNT2("paramDefsObj", listObj);
for (; likely(paramsPtr->name != NULL); paramsPtr++) {
if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
continue;
}
if (paramsPtr->paramObj != NULL) {
if (pattern != NULL && !ParamsDefMatchPattern(paramsPtr, pattern)) {
continue;
}
innerListObj = paramsPtr->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 "nsfParam"
*/
int isNonpos = *paramsPtr->name == '-';
int outputRequired = (isNonpos && ((paramsPtr->flags & NSF_ARG_REQUIRED) != 0u));
int outputOptional = (!isNonpos && ((paramsPtr->flags & NSF_ARG_REQUIRED) == 0u)
&& !paramsPtr->defaultValue &&
paramsPtr->converter != ConvertToNothing);
first = 1;
colonWritten = 0;
if (NsfParamDefsAppendVirtual(interp, listObj, paramsPtr, contextObject, pattern, ParamDefsFormat)) {
continue;
}
if (pattern != NULL && !ParamsDefMatchPattern(paramsPtr, pattern)) {
continue;
}
nameStringObj = Tcl_NewStringObj(paramsPtr->name, TCL_INDEX_NONE);
if (paramsPtr->type != NULL) {
ParamDefsFormatOption(nameStringObj, paramsPtr->type, TCL_INDEX_NONE, &colonWritten, &first);
} else if (isNonpos && paramsPtr->nrArgs == 0) {
ParamDefsFormatOption(nameStringObj, "switch", 6, &colonWritten, &first);
}
if (outputRequired != 0) {
ParamDefsFormatOption(nameStringObj, "required", 8, &colonWritten, &first);
} else if (outputOptional != 0) {
ParamDefsFormatOption(nameStringObj, "optional", 8, &colonWritten, &first);
}
if ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT) != 0u) {
char buffer[30];
size_t len = 12;
memcpy(buffer, "substdefault", (size_t)len);
if ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_ALL) != 0u) {
memcpy(buffer + len + 1, "=0b", 3u);
len += 4;
buffer[len] = ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_VARIABLES) != 0u) ? '1' : '0';
len ++;
buffer[len] = ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_COMMANDS) != 0u) ? '1' : '0';
len ++;
buffer[len] = ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_BACKSLASHES) != 0u) ? '1' : '0';
len ++;
} else {
len ++;
}
buffer[len] = '\0';
ParamDefsFormatOption(nameStringObj, buffer, (TCL_SIZE_T)len, &colonWritten, &first);
}
if ((paramsPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u || (paramsPtr->flags & NSF_ARG_MULTIVALUED) != 0u) {
char option[10] = "....";
option[0] = ((paramsPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u) ? '0' : '1';
option[3] = ((paramsPtr->flags & NSF_ARG_MULTIVALUED) != 0u) ? '*' : '1';
ParamDefsFormatOption(nameStringObj, option, 4, &colonWritten, &first);
}
if ((paramsPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) {
ParamDefsFormatOption(nameStringObj, "convert", 7, &colonWritten, &first);
}
if ((paramsPtr->flags & NSF_ARG_INITCMD) != 0u) {
ParamDefsFormatOption(nameStringObj, "initcmd", 7, &colonWritten, &first);
} else if ((paramsPtr->flags & NSF_ARG_CMD) != 0u) {
ParamDefsFormatOption(nameStringObj, "cmd", 3, &colonWritten, &first);
} else if ((paramsPtr->flags & NSF_ARG_ALIAS) != 0u) {
ParamDefsFormatOption(nameStringObj, "alias", 5, &colonWritten, &first);
} else if ((paramsPtr->flags & NSF_ARG_FORWARD) != 0u) {
ParamDefsFormatOption(nameStringObj, "forward", 7, &colonWritten, &first);
} else if ((paramsPtr->flags & NSF_ARG_NOARG) != 0u) {
ParamDefsFormatOption(nameStringObj, "noarg", 5, &colonWritten, &first);
} else if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
ParamDefsFormatOption(nameStringObj, "noconfig", 8, &colonWritten, &first);
}
innerListObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, innerListObj, nameStringObj);
if (paramsPtr->defaultValue != NULL) {
Tcl_ListObjAppendElement(interp, innerListObj, paramsPtr->defaultValue);
}
}
Tcl_ListObjAppendElement(interp, listObj, innerListObj);
}
return listObj;
}
/*
*----------------------------------------------------------------------
* ParamDefsList --
*
* Produce a Tcl_ListObj containing the list of the parameters
* based on a parameter structure.
*
* Results:
* Tcl_Obj
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *ParamDefsList(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) nonnull(1) nonnull(2) returns_nonnull;
static Tcl_Obj *
ParamDefsList(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
nonnull_assert(interp != NULL);
nonnull_assert(paramsPtr != NULL);
INCR_REF_COUNT2("paramDefsObj", listObj);
for (; likely(paramsPtr->name != NULL); paramsPtr++) {
if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
continue;
}
if (NsfParamDefsAppendVirtual(interp, listObj, paramsPtr, contextObject, pattern, ParamDefsList)) {
continue;
}
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(paramsPtr->name, TCL_INDEX_NONE));
}
return listObj;
}
/*
*----------------------------------------------------------------------
* ParamDefsNames --
*
* Produce a Tcl_ListObj containing the names of the parameters
* based on a parameter structure.
*
* Results:
* Tcl_Obj
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj * ParamDefsNames(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) nonnull(1) nonnull(2) returns_nonnull;
static Tcl_Obj *
ParamDefsNames(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
nonnull_assert(interp != NULL);
nonnull_assert(paramsPtr != NULL);
INCR_REF_COUNT2("paramDefsObj", listObj);
for (; likely(paramsPtr->name != NULL); paramsPtr++) {
const char* paramName;
if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
continue;
}
if (NsfParamDefsAppendVirtual(interp, listObj, paramsPtr, contextObject, pattern, ParamDefsNames)) {
continue;
}
paramName = *paramsPtr->name == '-' ? paramsPtr->name+1 : paramsPtr->name;
if (pattern != NULL && !Tcl_StringMatch(paramName, pattern)) {
continue;
}
Tcl_ListObjAppendElement(interp, listObj, (paramsPtr->nameObj != NULL) ?
paramsPtr->nameObj : Tcl_NewStringObj(paramsPtr->name, TCL_INDEX_NONE));
}
return listObj;
}
/*
*----------------------------------------------------------------------
* ParamGetType --
*
* Obtain the type of a single parameter and return it as a string.
*
* Results:
* Type of the parameter in form of a string
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char *ParamGetType(Nsf_Param const *paramPtr)
nonnull(1) returns_nonnull;
static const char *
ParamGetType(Nsf_Param const *paramPtr) {
const char *result = "value";
nonnull_assert(paramPtr != NULL);
if (paramPtr->type != NULL) {
if (paramPtr->converter == ConvertViaCmd) {
result = paramPtr->type + 5;
} else if (paramPtr->converter == Nsf_ConvertToClass &&
((paramPtr->flags & (NSF_ARG_BASECLASS|NSF_ARG_METACLASS)) != 0u) ) {
if ((paramPtr->flags & NSF_ARG_BASECLASS) != 0u) {
result = "baseclass";
} else {
result = "metaclass";
}
} else if (strcmp(paramPtr->type, "stringtype") == 0) {
if (paramPtr->converterArg != NULL) {
result = ObjStr(paramPtr->converterArg);
}
} else {
result = paramPtr->type;
}
}
return result;
}
/*
*----------------------------------------------------------------------
* ParamGetDomain --
*
* Obtain the domain of a single parameter and return it as a
* string. The domain is an approximate type used in the parameter
* syntax.
*
* Results:
* Domain of the parameter in form of a string
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char * ParamGetDomain(Nsf_Param const *paramPtr)
nonnull(1) returns_nonnull;
static const char *
ParamGetDomain(Nsf_Param const *paramPtr) {
const char *result;
nonnull_assert(paramPtr != NULL);
if ((paramPtr->flags & NSF_ARG_IS_ENUMERATION) != 0u) {
return Nsf_EnumerationTypeGetDomain(paramPtr->converter);
} else {
result = ParamGetType(paramPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfParamDefsSyntaxOne --
*
* Appends the formatted parameter (provided as 2nd argument) to the
* content of the first argument.
*
* Results:
* None.
*
* Side effects:
* Appending to first argument.
*
*----------------------------------------------------------------------
*/
static void NsfParamDefsSyntaxOne(Tcl_Obj *argStringObj, const Nsf_Param *pPtr)
nonnull(1) nonnull(2);
static void
NsfParamDefsSyntaxOne(Tcl_Obj *argStringObj, const Nsf_Param *pPtr) {
nonnull_assert(argStringObj != NULL);
nonnull_assert(pPtr != NULL);
if (pPtr->nrArgs > 0 && *pPtr->name == '-') {
Tcl_AppendLimitedToObj(argStringObj, pPtr->name, TCL_INDEX_NONE, INT_MAX, NULL);
Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
if ((pPtr->flags & NSF_ARG_IS_ENUMERATION) != 0u) {
Tcl_AppendLimitedToObj(argStringObj, ParamGetDomain(pPtr), TCL_INDEX_NONE, INT_MAX, NULL);
if ((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u) {
Tcl_AppendLimitedToObj(argStringObj, " ...", 4, INT_MAX, NULL);
}
} else {
Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
Tcl_AppendLimitedToObj(argStringObj, ParamGetDomain(pPtr), TCL_INDEX_NONE, INT_MAX, NULL);
if ((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u) {
Tcl_AppendLimitedToObj(argStringObj, " ...", 4, INT_MAX, NULL);
}
Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
}
} else if (*pPtr->name != '-') {
Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
Tcl_AppendLimitedToObj(argStringObj, pPtr->name, TCL_INDEX_NONE, INT_MAX, NULL);
Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
} else {
Tcl_AppendLimitedToObj(argStringObj, pPtr->name, TCL_INDEX_NONE, INT_MAX, NULL);
}
}
/*
* NsfParamDefsVirtualFormat --
*
* This function is called, when we know we can resolve a virtual argument
* against the context object. In such cases, obtain the resolved parsed
* params and call the formatter.
*
* Results:
* Standard Tcl result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
NsfParamDefsVirtualFormat(
Tcl_Interp *interp, const Nsf_Param *pPtr,
NsfObject *contextObject, const char *pattern,
NsfFormatFunction formatFunction
) {
NsfParsedParam parsedParam;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(contextObject != NULL);
nonnull_assert(formatFunction != NULL);
assert(pPtr->type != NULL);
parsedParam.paramDefs = NULL;
if (strcmp(pPtr->type, "virtualobjectargs") == 0) {
result = GetObjectParameterDefinition(interp, NsfGlobalObjs[NSF_EMPTY], contextObject, NULL, &parsedParam);
} else if (NsfObjectIsClass(contextObject)) {
result = GetObjectParameterDefinition(interp, NsfGlobalObjs[NSF_EMPTY], NULL, (NsfClass *)contextObject, &parsedParam);
} else {
NsfLog(interp, NSF_LOG_WARN, "virtual args: provided context is not a class <%s>", ObjectName_(contextObject));
result = TCL_ERROR;
}
if (result == TCL_OK && parsedParam.paramDefs != NULL) {
return (*formatFunction)(interp, parsedParam.paramDefs->paramsPtr, contextObject, pattern);
}
return NULL;
}
/*
*----------------------------------------------------------------------
* NsfParamDefsAppendVirtual --
*
* Check for the given paramsPtr whether this is a virtual parameter and if
* possible, resolve it and append the formatted content to the Tcl_Obj.
*
* Results:
* Boolean value for success
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool
NsfParamDefsAppendVirtual(
Tcl_Interp *interp, Tcl_Obj *listObj,
const Nsf_Param *paramsPtr, NsfObject *contextObject,
const char *pattern, NsfFormatFunction formatFunction
) {
nonnull_assert(interp != NULL);
nonnull_assert(listObj != NULL);
nonnull_assert(paramsPtr != NULL);
nonnull_assert(formatFunction != NULL);
assert(paramsPtr->name != NULL);
if (paramsPtr->converter == ConvertToNothing && strcmp(paramsPtr->name, "args") == 0) {
if ((contextObject != NULL)
&& (paramsPtr->type != NULL)
&& strncmp(paramsPtr->type, "virtual", 7) == 0
) {
Tcl_Obj *formattedObj = NsfParamDefsVirtualFormat(interp, paramsPtr, contextObject, pattern, formatFunction);
if (formattedObj != NULL) {
Tcl_ListObjAppendList(interp, listObj, formattedObj);
DECR_REF_COUNT2("paramDefsObj", formattedObj);
return NSF_TRUE;
}
}
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* NsfParamDefsSyntax --
*
* Return the parameter definitions of a sequence of parameters in
* the form of the "parametersyntax", inspired by the Tcl manual
* pages.
*
* Results:
* Tcl_Obj containing the parameter syntax
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *NsfParamDefsSyntax(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) nonnull(1) nonnull(2) returns_nonnull;
Tcl_Obj *
NsfParamDefsSyntax(
Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
) {
Tcl_Obj *argStringObj = Tcl_NewObj();
const Nsf_Param *pPtr;
int needSpace = 0;
nonnull_assert(interp != NULL);
nonnull_assert(paramsPtr != NULL);
INCR_REF_COUNT2("paramDefsObj", argStringObj);
for (pPtr = paramsPtr; pPtr->name != NULL; pPtr++) {
if ((pPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
/*
* Don't output non-configurable parameters
*/
continue;
}
if (pPtr != paramsPtr) {
/*
* Don't output non-consuming parameters (i.e. positional, and no args)
*/
if (*pPtr->name != '-' && pPtr->nrArgs == 0) {
continue;
}
}
if (pPtr->converter == ConvertToNothing && strcmp(pPtr->name, "args") == 0) {
int argsResolved = 0;
if ((contextObject != NULL)
&& (pPtr->type != NULL)
&& strncmp(pPtr->type, "virtual", 7) == 0
) {
Tcl_Obj *formattedObj = NsfParamDefsVirtualFormat(interp, pPtr, contextObject,
pattern, NsfParamDefsSyntax);
if (formattedObj != NULL) {
argsResolved = 1;
if (needSpace != 0) {
Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
}
Tcl_AppendObjToObj(argStringObj, formattedObj);
DECR_REF_COUNT2("paramDefsObj", formattedObj);
}
}
if (argsResolved == 0) {
if (pattern != NULL && !ParamsDefMatchPattern(pPtr, pattern)) {
continue;
}
if (needSpace != 0) {
Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
}
Tcl_AppendLimitedToObj(argStringObj, "?/arg .../?", 11, INT_MAX, NULL);
}
} else if ((pPtr->flags & NSF_ARG_REQUIRED) != 0u) {
if (pattern != NULL && !ParamsDefMatchPattern(pPtr, pattern)) {
continue;
}
if (needSpace != 0) {
Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
}
if ((pPtr->flags & NSF_ARG_IS_ENUMERATION) != 0u) {
Tcl_AppendLimitedToObj(argStringObj, Nsf_EnumerationTypeGetDomain(pPtr->converter),
TCL_INDEX_NONE, INT_MAX, NULL);
} else {
NsfParamDefsSyntaxOne(argStringObj, pPtr);
}
} else {
if (pattern != NULL && !ParamsDefMatchPattern(pPtr, pattern)) {
continue;
}
if (needSpace != 0) {
Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
}
Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL);
NsfParamDefsSyntaxOne(argStringObj, pPtr);
Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL);
}
needSpace = 1;
}
/*
* Caller has to decrement.
*/
return argStringObj;
}
/*
*----------------------------------------------------------------------
* ParsedParamFree --
*
* Free the provided information of the parsed parameters.
*
* Results:
* None.
*
* Side effects:
* Freed Memory.
*
*----------------------------------------------------------------------
*/
static void
ParsedParamFree(NsfParsedParam *parsedParamPtr) {
nonnull_assert(parsedParamPtr != NULL);
/*fprintf(stderr, "ParsedParamFree %p, npargs %p\n",
(void *)parsedParamPtr, (void *)parsedParamPtr->paramDefs);*/
if (parsedParamPtr->paramDefs != NULL) {
ParamDefsRefCountDecr(parsedParamPtr->paramDefs);
}
FREE(NsfParsedParam, parsedParamPtr);
}
/*
* method dispatch
*/
/*
*----------------------------------------------------------------------
* ProcMethodDispatchFinalize --
*
* Finalization function for ProcMethodDispatch which executes
* scripted methods. Essentially it handles post-assertions and
* frees per-invocation memory. The function was developed for NRE
* enabled Tcl versions but is used in the same way for non-NRE
* enabled versions.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int ProcMethodDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result)
nonnull(1) nonnull(2);
static int
ProcMethodDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result) {
ParseContext *pcPtr;
/*const char *methodName = data[2];*/
#if defined(NSF_WITH_ASSERTIONS) || defined(NRE)
NsfCallStackContent *cscPtr;
#endif
#if defined(NSF_WITH_ASSERTIONS)
NsfObject *object;
NsfObjectOpt *opt;
#endif
nonnull_assert(data != NULL);
nonnull_assert(interp != NULL);
pcPtr = data[0];
#if defined(NSF_WITH_ASSERTIONS) || defined(NRE)
cscPtr = data[1];
assert(cscPtr != NULL);
#endif
#if defined(NSF_WITH_ASSERTIONS)
object = cscPtr->self;
opt = object->opt;
#endif
/*fprintf(stderr, "ProcMethodDispatchFinalize %s %s flags %.6x isNRE %d pcPtr %p result %d\n",
ObjectName(object), methodName,
cscPtr->flags, (cscPtr->flags & NSF_CSC_CALL_IS_NRE), (void *)pcPtr, result);*/
#if defined(NSF_WITH_ASSERTIONS)
if (unlikely(opt != NULL && object->teardown != NULL && (opt->checkoptions & CHECK_POST))
&& likely(result == TCL_OK)) {
int rc = AssertionCheck(interp, object, cscPtr->cl, data[2], CHECK_POST);
if (rc != TCL_OK) {
result = rc;
}
}
#endif
#if defined(NRE)
if (likely((cscPtr->flags & NSF_CSC_CALL_IS_NRE) != 0u)) {
if (likely(pcPtr != NULL)) {
ParseContextRelease(pcPtr);
NsfTclStackFree(interp, pcPtr, "release parse context");
}
result = ObjectDispatchFinalize(interp, cscPtr, result /*, "NRE" , methodName*/);
CscFinish(interp, cscPtr, result, "scripted finalize");
}
#else
if (unlikely(pcPtr != NULL)) {
ParseContextRelease(pcPtr);
}
#endif
return result;
}
/*
*----------------------------------------------------------------------
* ProcDispatchFinalize --
*
* Finalization function for nsf::proc. Simplified version of
* ProcMethodDispatchFinalize().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int ProcDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result)
nonnull(1) nonnull(2);
static int
ProcDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result) {
ParseContext *pcPtr;
Tcl_Time *ttPtr;
Tcl_Command wrapperCmd;
nonnull_assert(data != NULL);
nonnull_assert(interp != NULL);
/*const char *methodName = data[0];
fprintf(stderr, "ProcDispatchFinalize of method %s\n", methodName);*/
pcPtr = data[1];
ttPtr = data[2];
assert(pcPtr != NULL);
/*
* Hacking alert: We have just 4 data arguments in Tcl_NRAddCallback for the
* finalize context. Since we do not want to allocate/manage additional
* structures for finalize data, and the pcPtr->object member is unused for
* nsfProcs, we reuse the pcPtr->object member for the wrapperCmd.
*/
wrapperCmd = (Tcl_Command)pcPtr->object;
if ((result == TCL_OK) && (Tcl_Command_cmdEpoch(wrapperCmd) == 0)) {
Tcl_Obj *returnsObj = ParamDefsGetReturns(wrapperCmd);
if (returnsObj != NULL) {
Tcl_Obj *valueObj = Tcl_GetObjResult(interp);
NsfRuntimeState *rst = RUNTIME_STATE(interp);
Tcl_IncrRefCount(returnsObj);
result = ParameterCheck(interp, returnsObj, valueObj, "return-value:",
rst->doCheckResults, NSF_FALSE, NSF_FALSE, NULL,
NULL);
Tcl_DecrRefCount(returnsObj);
}
}
if (ttPtr != NULL) {
const char *methodName = data[0];
unsigned int cmdFlags = (unsigned int)PTR2UINT(data[3]);
#if defined(NSF_PROFILE)
NsfRuntimeState *rst = RUNTIME_STATE(interp);
#endif
/*fprintf(stderr, "ProcDispatchFinalize methodName %s flags %.6lx\n",
methodName, (cmdFlags & NSF_CMD_DEBUG_METHOD));*/
if ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u) {
NsfProfileDebugExit(interp, NULL, NULL, methodName, ttPtr->sec, ttPtr->usec);
}
#if defined(NSF_PROFILE)
if (rst->doProfile != 0) {
NsfProfileRecordProcData(interp, methodName, ttPtr->sec, ttPtr->usec);
}
#endif
ckfree((char *)ttPtr);
}
ParseContextRelease(pcPtr);
NsfTclStackFree(interp, pcPtr, "nsf::proc dispatch finalize release parse context");
return result;
}
/*
*----------------------------------------------------------------------
* ProcMethodDispatch --
*
* Invoke a scripted method (with assertion checking and filters).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int ProcMethodDispatch(
ClientData cp, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
const char *methodName, NsfObject *object, NsfClass *class, Tcl_Command cmdPtr,
NsfCallStackContent *cscPtr
) nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6) nonnull(8) nonnull(9);
static int
ProcMethodDispatch(
ClientData cp, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
const char *methodName, NsfObject *object, NsfClass *class, Tcl_Command cmdPtr,
NsfCallStackContent *cscPtr
) {
NsfParamDefs *paramDefs;
int result;
bool releasePc = NSF_FALSE;
Tcl_Namespace *execNsPtr = NULL;
unsigned int checkAlwaysFlag = 0u;
#if defined(NSF_WITH_ASSERTIONS)
NsfObjectOpt *opt;
#endif
#if defined(NRE)
ParseContext *pcPtr = NULL;
#else
ParseContext pc, *pcPtr = &pc;
#endif
nonnull_assert(cp != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmdPtr != NULL);
nonnull_assert(cscPtr != NULL);
nonnull_assert(object != NULL);
assert(object->teardown != NULL);
#if defined(NRE)
/*fprintf(stderr, "ProcMethodDispatch cmd %s\n", Tcl_GetCommandName(interp, cmdPtr));*/
assert((cscPtr->flags & NSF_CSC_CALL_IS_NRE) != 0u);
#endif
/*
* If this is a filter, check whether its guard applies,
* if not: just step forward to the next filter
*/
if (unlikely(cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER)) {
NsfCmdList *cmdList;
/*
* Seek cmd in obj's filterOrder.
*/
assert((object->flags & NSF_FILTER_ORDER_VALID) != 0u);
/* otherwise: FilterComputeDefined(interp, object);*/
for (cmdList = object->filterOrder;
(cmdList != NULL) && (cmdList->cmdPtr != cmdPtr);
cmdList = cmdList->nextPtr) {
;
}
if (cmdList != NULL) {
/*
* A filter was found, check whether it has a guard.
*/
if (cmdList->clientData != NULL) {
result = GuardCall(object, interp, cmdList->clientData, cscPtr);
} else {
result = TCL_OK;
}
if (unlikely(result != TCL_OK)) {
/*fprintf(stderr, "Filter GuardCall in invokeProc returned %d\n", result);*/
if (likely(result != TCL_ERROR)) {
/*
* The guard failed (but no error), and we call "next".
* Since we may not be in a method with already provided
* arguments, we call next with the actual arguments and
* perform no argument substitution.
*
* The call stack content is not jet pushed to the Tcl
* stack, we pass it already to search-and-invoke.
*/
cscPtr->flags |= NSF_CSC_CALL_IS_GUARD;
/*fprintf(stderr, "... guard fail calling nextmethod for '%s' cscPtr %p\n", methodName, (void *)cscPtr);*/
result = NextSearchAndInvoke(interp, methodName, objc, objv, cscPtr, NSF_FALSE);
/*fprintf(stderr, "... guard fail nextmethod for '%s' result %d\n", methodName, result);*/
cscPtr->flags &= ~ NSF_CSC_CALL_IS_GUARD;
}
/*
* Next might have succeeded or not, but we are done. In the
* NRE-case, we need a CscFinish for all return codes.
*/
#if defined(NRE)
CscFinish(interp, cscPtr, result, "guard failed");
#endif
return result;
}
}
}
#if defined(NSF_WITH_ASSERTIONS)
opt = object->opt;
if (unlikely(opt != NULL && (opt->checkoptions & CHECK_PRE)) &&
(result = AssertionCheck(interp, object, class, methodName, CHECK_PRE)) == TCL_ERROR) {
goto prep_done;
}
#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, &checkAlwaysFlag, &execNsPtr);
if (paramDefs != NULL && paramDefs->paramsPtr != NULL) {
#if defined(NRE)
pcPtr = (ParseContext *) NsfTclStackAlloc(interp, sizeof(ParseContext), "parse context");
#endif
result = ProcessMethodArguments(pcPtr, interp, object,
checkAlwaysFlag|NSF_ARGPARSE_METHOD_PUSH|NSF_ARGPARSE_FORCE_REQUIRED,
paramDefs, objv[0], objc, objv);
cscPtr->objc = objc;
cscPtr->objv = (Tcl_Obj **)objv;
if (likely(result == TCL_OK)) {
releasePc = NSF_TRUE;
result = PushProcCallFrame(cp, interp, pcPtr->objc+1, pcPtr->full_objv, execNsPtr, cscPtr);
} else {
/*
* some error occurred
*/
#if defined(NRE)
ParseContextRelease(pcPtr);
NsfTclStackFree(interp, pcPtr, "parse context (proc prep failed)");
pcPtr = NULL;
#else
ParseContextRelease(pcPtr);
#endif
}
} else {
/*if (execNsPtr == NULL) {
fprintf(stderr, "PushProcCallFrame for %s without method arguments and empty execNsPtr %p\n",
methodName, (void*)execNsPtr);
}*/
result = PushProcCallFrame(cp, interp, objc, objv, execNsPtr, cscPtr);
}
/*
* The stack frame is pushed, we could do something here before
* running the byte code of the body.
*/
/* We could consider to run here ARG_METHOD or ARG_INITCMD
if (likely(result == TCL_OK)) {
}
*/
#if defined(NSF_WITH_ASSERTIONS)
prep_done:
#endif
if (likely(result == TCL_OK)) {
#if defined(NRE)
/*fprintf(stderr, "CALL TclNRInterpProcCore %s method '%s'\n",
ObjectName(object), ObjStr(objv[0]));*/
Tcl_NRAddCallback(interp, ProcMethodDispatchFinalize,
(releasePc ? pcPtr : NULL),
cscPtr,
(ClientData)methodName,
NULL);
cscPtr->flags |= NSF_CSC_CALL_IS_NRE;
result = TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
#else
ClientData data[3] = {
(releasePc ? pcPtr : NULL),
cscPtr,
(ClientData)methodName
};
result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
result = ProcMethodDispatchFinalize(data, interp, result);
#endif
} else /* result != OK */ {
#if defined(NRE)
CscFinish(interp, cscPtr, result, "nre, prep failed");
#endif
}
return result;
}
/*
*----------------------------------------------------------------------
* CmdMethodDispatch --
*
* Invoke a method implemented as a cmd. Essentially it stacks
* optionally a frame, calls the method, pops the frame and runs
* invariants.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling cmd
*
*----------------------------------------------------------------------
*/
static int CmdMethodDispatch(
ClientData cp, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
NsfObject *object, Tcl_Command cmd, NsfCallStackContent *cscPtr
) nonnull(2) nonnull(4) nonnull(5) nonnull(6);
static int
CmdMethodDispatch(
ClientData cp, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
NsfObject *object, Tcl_Command cmd, NsfCallStackContent *cscPtr
) {
CallFrame frame, *framePtr = &frame;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(object != NULL);
assert(object->teardown != NULL);
#if defined(NRE)
assert(!cscPtr || (cscPtr->flags & NSF_CSC_CALL_IS_NRE) == 0u);
#endif
if (cscPtr != NULL) {
/*
* We have a call-stack content, but the requested dispatch will not store
* the call-stack content in a corresponding call-frame on its own. To get,
* for example, self-introspection working for the requested dispatch, we
* introduce a CMETHOD frame.
*/
/*fprintf(stderr, "Nsf_PushFrameCsc %s %s\n", ObjectName(object), Tcl_GetCommandName(interp, cmd));*/
Nsf_PushFrameCsc(interp, cscPtr, framePtr);
result = TCL_NRCALLOBJPROC(interp, TCL_COMMAND_OBJPROC(cmd), cp, (TCL_SIZE_T)objc, objv);
Nsf_PopFrameCsc(interp, framePtr);
} else {
result = TCL_NRCALLOBJPROC(interp, TCL_COMMAND_OBJPROC(cmd), cp, (TCL_SIZE_T)objc, objv);
}
#if defined(NSF_WITH_ASSERTIONS)
if (unlikely(object->opt != NULL) && likely(result == TCL_OK)) {
CheckOptions co = object->opt->checkoptions;
if ((co & CHECK_INVAR)) {
int rc = AssertionCheckInvars(interp, object, Tcl_GetCommandName(interp, cmd), co);
if (rc != TCL_OK) {
result = rc;
}
}
}
#endif
/*
* Reference counting in the calling ObjectDispatch() makes sure
* that obj->opt is still accessible even after "dealloc"
*/
return result;
}
/*
*----------------------------------------------------------------------
* ObjectCmdMethodDispatch --
*
* Invoke a method implemented as an object. The referenced object is used
* as a source for methods to be executed. Essentially this is currently
* primarily used to implement the dispatch of ensemble objects.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling cmd
*
*----------------------------------------------------------------------
*/
static int ObjectCmdMethodDispatch(
NsfObject *invokedObject, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
const char *methodName, NsfObject *callerSelf, NsfCallStackContent *cscPtr
) nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6) nonnull(7);
static int
ObjectCmdMethodDispatch(
NsfObject *invokedObject, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
const char *methodName, NsfObject *callerSelf, NsfCallStackContent *cscPtr
) {
CallFrame frame, *framePtr = &frame;
Tcl_Command cmd, subMethodCmd;
const char *subMethodName;
NsfObject *actualSelf;
NsfClass *actualClass;
int result;
nonnull_assert(invokedObject != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(callerSelf != NULL);
nonnull_assert(cscPtr != NULL);
cmd = cscPtr->cmdPtr;
/*fprintf(stderr, "ObjectCmdMethodDispatch %p %s\n", (void *)cmd, Tcl_GetCommandName(interp, cmd));*/
/*fprintf(stderr, "ObjectCmdMethodDispatch method %s invokedObject %p %s callerSelf %p %s\n",
methodName, (void *)invokedObject, ObjectName(invokedObject),
(void *)callerSelf, ObjectName(callerSelf));*/
if (unlikely((invokedObject->flags & NSF_DELETED) != 0u)) {
/*
* When we try to invoke a deleted object, the cmd (alias) is
* automatically removed. Note that the cmd might be still referenced
* in various entries in the call-stack. The reference counting on
* these elements takes care that the cmdPtr is deleted on a pop
* operation (although we do a Tcl_DeleteCommandFromToken() below.
*/
/*fprintf(stderr, "methodName %s found DELETED object with cmd %p my cscPtr %p\n",
methodName, (void *)cmd, (void *)cscPtr);*/
Tcl_DeleteCommandFromToken(interp, cmd);
if (cscPtr->cl != NULL) {
NsfInstanceMethodEpochIncr("DeleteObjectAlias");
} else {
NsfObjectMethodEpochIncr("DeleteObjectAlias");
}
NsfCleanupObject(invokedObject, "alias-delete1");
return NsfPrintError(interp, "trying to dispatch deleted object via method '%s'",
methodName);
}
/*
* Check whether the object cmd was called without a reference to a
* method. If so, perform the standard dispatch of default methods.
*/
if (unlikely(objc < 2)) {
if ((invokedObject->flags & NSF_PER_OBJECT_DISPATCH) != 0u) {
cscPtr->flags |= NSF_CSC_CALL_IS_ENSEMBLE;
}
Nsf_PushFrameCsc(interp, cscPtr, framePtr);
result = DispatchDefaultMethod(interp, invokedObject, objv[0], NSF_CSC_IMMEDIATE);
Nsf_PopFrameCsc(interp, framePtr);
return result;
}
/*
* Check whether we want NSF_KEEP_CALLER_SELF. The setting of this flag
* determines the values of actualSelf and actualClass.
*/
if ((invokedObject->flags & NSF_KEEP_CALLER_SELF) != 0u) {
actualSelf = callerSelf;
actualClass = cscPtr->cl;
} else {
actualSelf = invokedObject;
actualClass = NULL;
}
subMethodName = ObjStr(objv[1]);
if ((invokedObject->flags & NSF_PER_OBJECT_DISPATCH) == 0u) {
/*fprintf(stderr, "invokedObject %p %s methodName %s: no perobjectdispatch\n",
(void*)invokedObject, ObjectName(invokedObject), methodName);*/
#if 0
/*
* We should have either an approach
* - to obtain from an object to methodname the cmd, and
* call e.g. MethodDispatch(), or pass a fully qualified
* method name, or
* - to pass the actualSelf and invokedObject both
* to MethodDispatch/MethodDispatch
* TODO: maybe remove NSF_CM_KEEP_CALLER_SELF when done.
*/
result = MethodDispatch(interp, nobjc+1, nobjv-1, cmd, object,
NULL /*NsfClass *cl*/,
Tcl_GetCommandName(interp, cmd),
NSF_CSC_TYPE_PLAIN, flags);
#endif
#if 1
/*
* Simple and brutal.
*/
if (likely(invokedObject->nsPtr != NULL)) {
subMethodCmd = FindMethod(invokedObject->nsPtr, subMethodName);
} else {
subMethodCmd = NULL;
}
if (subMethodCmd == NULL) {
/*
* no -system handling.
*/
actualClass = SearchPLMethod(invokedObject->cl->order, subMethodName, &subMethodCmd,
NSF_CMD_CALL_PRIVATE_METHOD);
}
if (likely(subMethodCmd != NULL)) {
cscPtr->objc = objc;
cscPtr->objv = objv;
Nsf_PushFrameCsc(interp, cscPtr, framePtr);
result = MethodDispatch(interp, objc-1, objv+1,
subMethodCmd, actualSelf, actualClass, subMethodName,
cscPtr->frameType|NSF_CSC_TYPE_ENSEMBLE,
(cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE);
Nsf_PopFrameCsc(interp, framePtr);
return result;
}
/*fprintf(stderr, "... objv[0] %s cmd %p %s csc %p\n",
ObjStr(objv[0]), (void *)subMethodCmd, subMethodName, (void *)cscPtr); */
#endif
return ObjectDispatch(actualSelf, interp, objc, objv, NSF_CM_KEEP_CALLER_SELF);
}
/*
* NSF_PER_OBJECT_DISPATCH is set
*/
if (likely(invokedObject->nsPtr != NULL)) {
subMethodCmd = FindMethod(invokedObject->nsPtr, subMethodName);
} else {
subMethodCmd = NULL;
}
#if 1
if (subMethodCmd != NULL) {
unsigned int cmdFlags = (unsigned int)Tcl_Command_flags(subMethodCmd);
if ((cscPtr->flags & (NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0u &&
(cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u) {
subMethodCmd = NULL;
} else if (unlikely((cmdFlags & NSF_CMD_CALL_PROTECTED_METHOD) != 0u)) {
const NsfObject *lastSelf;
Tcl_CallFrame *framePtr0;
bool withinEnsemble = ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u);
if (withinEnsemble) {
Tcl_CallFrame *framePtr1;
/* Alternatively: (void)NsfCallStackFindLastInvocation(interp, 0, &framePtr1); */
(void)CallStackGetTopFrame(interp, &framePtr0);
(void)CallStackFindEnsembleCsc(framePtr0, &framePtr1);
/* NsfShowStack(interp);
fprintf(stderr, "framePtr %p\n", (void *)framePtr1);*/
if (framePtr1 != NULL) {
lastSelf = GetSelfObj2(interp, framePtr1);
} else {
lastSelf = NULL;
}
} else {
lastSelf = GetSelfObj(interp);
}
/* fprintf(stderr, "'%s (%s) == %s == %s? for %s\n", lastSelf != NULL ? ObjectName(lastSelf): "n/a",
ObjectName(GetSelfObj(interp)), ObjectName(actualSelf), ObjectName(invokedObject), subMethodName); */
if (actualSelf != lastSelf) {
const char *path;
Tcl_Obj *pathObj = NULL;
if (withinEnsemble) {
pathObj = NsfMethodNamePath(interp, framePtr0, methodName);
INCR_REF_COUNT(pathObj);
path = ObjStr(pathObj);
} else {
path = methodName;
}
NsfLog(interp, NSF_LOG_WARN, "'%s %s %s' fails since method %s.%s %s is protected",
ObjectName(actualSelf), path, subMethodName, (actualClass != NULL) ?
ClassName(actualClass) : ObjectName(actualSelf), path, subMethodName);
subMethodCmd = NULL;
if (pathObj != NULL) {
DECR_REF_COUNT(pathObj);
}
}
}
}
#endif
/*
* Make sure that the current call is marked as an ensemble call, both
* for dispatching to the default-method and for dispatching the method
* interface of the given object. Otherwise, current introspection
* specific to sub-methods fails (e.g., a [current method-path] in the
* default-method).
*/
cscPtr->flags |= NSF_CSC_CALL_IS_ENSEMBLE;
/* fprintf(stderr, "ensemble dispatch cp %s %s objc %d\n",
ObjectName((NsfObject*)cp), methodName, objc);*/
cscPtr->objc = objc;
cscPtr->objv = objv;
Nsf_PushFrameCsc(interp, cscPtr, framePtr);
/*fprintf(stderr, "... objv[0] %s cmd %p %s csc %p\n",
ObjStr(objv[0]), (void *)subMethodCmd, subMethodName, (void *)cscPtr); */
if (likely(subMethodCmd != NULL)) {
/*
* In order to allow [next] to be called in an ensemble method,
* an extra call-frame is needed. This CSC frame is typed as
* NSF_CSC_TYPE_ENSEMBLE. Note that the associated call is flagged
* additionally (NSF_CSC_CALL_IS_ENSEMBLE; see above) to be able
* to identify ensemble-specific frames during [next] execution.
*
* The dispatch requires NSF_CSC_IMMEDIATE to be set, ensuring
* that scripted methods are executed before the ensemble ends. If
* they were executed later, they would find their parent frame
* (CMETHOD) being popped from the stack already.
*/
/*fprintf(stderr, ".... ensemble dispatch object %s self %s pass %s\n",
ObjectName(invokedObject), ObjectName(actualSelf), (actualSelf->flags & NSF_KEEP_CALLER_SELF) ? "callerSelf" : "invokedObject");
fprintf(stderr, ".... ensemble dispatch on %s.%s objflags %.8x cscPtr %p base flags %.6x flags %.6x cl %s\n",
ObjectName(actualSelf), subMethodName, actualSelf->flags,
(void *)cscPtr, (0xFF & cscPtr->flags), (cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE,
(actualClass != NULL) ? ClassName(actualClass) : "NONE");*/
result = MethodDispatch(interp, objc-1, objv+1,
subMethodCmd, actualSelf, actualClass, subMethodName,
cscPtr->frameType|NSF_CSC_TYPE_ENSEMBLE,
(cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE);
/*if (unlikely(result != TCL_OK)) {
fprintf(stderr, "ERROR: cmd %p %s subMethodName %s -- %s -- %s\n",
(void *)subMethodCmd, Tcl_GetCommandName(interp, subMethodCmd), subMethodName,
Tcl_GetCommandName(interp, cscPtr->cmdPtr), ObjStr(Tcl_GetObjResult(interp)));
}*/
} else {
/*
* The method to be called was not part of this ensemble. Call
* next to try to call such methods along the next path.
*/
Tcl_CallFrame *framePtr1;
NsfCallStackContent *cscPtr1 = CallStackGetTopFrame(interp, &framePtr1);
/*fprintf(stderr, "call next instead of unknown %s.%s \n",
ObjectName(cscPtr->self), methodName);*/
assert(cscPtr1 != NULL);
if ((cscPtr1->frameType & NSF_CSC_TYPE_ENSEMBLE)) {
/*
* We are in an ensemble method. The next works here not on the
* actual methodName + frame, but on the ensemble above it. We
* locate the appropriate call-stack content and continue next on
* that.
*/
cscPtr1 = CallStackFindEnsembleCsc(framePtr1, &framePtr1);
assert(cscPtr1 != NULL);
}
/*
* We mark in the flags that we are in an ensemble but failed so far to
* resolve the cmd. Now we try to resolve the unknown subcmd via next and
* we record this in the flags. The method name for next might be
* colon-prefixed. In these cases, we have to skip the single colon with
* the MethodName() function.
*/
cscPtr1->flags |= NSF_CM_ENSEMBLE_UNKNOWN;
/*fprintf(stderr, "==> trying to find <%s> in ensemble <%s> via next\n",
subMethodName, MethodName(cscPtr1->objv[0]));*/
result = NextSearchAndInvoke(interp, MethodName(cscPtr1->objv[0]),
cscPtr1->objc, cscPtr1->objv, cscPtr1, NSF_FALSE);
/*fprintf(stderr, "==> next %s.%s subMethodName %s (obj %s) cscPtr %p (flags %.8x)) cscPtr1 %p (flags %.8x) result %d unknown %d\n",
ObjectName(callerSelf), methodName, subMethodName, ObjectName(invokedObject),
(void*)cscPtr, cscPtr->flags, (void*)cscPtr1, (cscPtr1 != NULL) ? cscPtr1->flags : 0,
result, RUNTIME_STATE(interp)->unknown);*/
if (RUNTIME_STATE(interp)->unknown) {
Tcl_Obj *callInfoObj = Tcl_NewListObj(1, &callerSelf->cmdName);
Tcl_CallFrame *varFramePtr, *tclFramePtr = CallStackGetTclFrame(interp, (Tcl_CallFrame *)framePtr, 1);
TCL_SIZE_T pathLength, pathLength0 = 0;
TCL_SIZE_T unknownIndex;
Tcl_Obj *pathObj = NsfMethodNamePath(interp, tclFramePtr, MethodName(objv[0]));
bool getPath = NSF_TRUE;
INCR_REF_COUNT(pathObj);
/*
* The "next" call could not resolve the unknown subcommand. At this
* point, potentially serval different ensembles were tried, which can
* be found on the stack.
*
* Example1: call: foo a b d
* mixin: foo a b c
* object: foo a x
*
* We want to return the longest, most precise prefix (here "foo a b")
* and flag "d" as unknown (here the mixin frame). Another (inferior)
* solution would be to report "foo a" as know prefix and "b d" as
* unknown (when the error is generated from the point of view of the
* object method frame).
*
* In the general case, we traverse the stack for all ensembles and pick
* the longest known ensemble for reporting. This path is passed to the
* unknown-handler of the ensemble.
*/
Tcl_ListObjLength(interp, pathObj, &pathLength0);
pathLength = pathLength0;
for (varFramePtr = (Tcl_CallFrame *)framePtr; likely(varFramePtr != NULL);
varFramePtr = Tcl_CallFrame_callerVarPtr(varFramePtr)) {
const NsfCallStackContent *stackCscPtr;
/*
* If we reach a non-nsf frame, or it is not an ensemble, we are done.
*/
stackCscPtr =
(((unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) ?
((NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr)) : NULL;
if (stackCscPtr == NULL || (stackCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0u) {
break;
}
/*
* Every ensemble block starts with a frame of
* NSF_CSC_TYPE_ENSEMBLE. If we find one, then we compute a new
* path in the next iteration.
*/
if ((stackCscPtr->frameType & (NSF_CSC_TYPE_ENSEMBLE)) == 0) {
/*
* Get method path the next round.
*/
getPath = NSF_TRUE;
} else if (getPath) {
TCL_SIZE_T pathLength1;
Tcl_Obj *pathObj1 = CallStackMethodPath(interp, varFramePtr);
INCR_REF_COUNT(pathObj1);
getPath = NSF_FALSE;
Tcl_ListObjLength(interp, pathObj1, &pathLength1);
if (pathLength1 > pathLength) {
if (pathObj != NULL) {
DECR_REF_COUNT(pathObj);
}
pathObj = pathObj1;
pathLength = pathLength1;
} else {
DECR_REF_COUNT(pathObj1);
}
}
}
unknownIndex = pathLength <= pathLength0 ? 1 : 1 + (TCL_SIZE_T)(pathLength - pathLength0);
assert((TCL_SIZE_T)objc > unknownIndex);
INCR_REF_COUNT(callInfoObj);
Tcl_ListObjAppendList(interp, callInfoObj, pathObj);
Tcl_ListObjAppendElement(interp, callInfoObj, objv[unknownIndex]);
/* fprintf(stderr, "DispatchUnknownMethod is called with callinfo <%s> (callerSelf <%s>, methodName '%s', methodPath '%s')\n",
ObjStr(callInfoObj), ObjStr(callerSelf->cmdName), MethodName(objv[0]),
ObjStr(callInfoObj)); */
result = DispatchUnknownMethod(interp, invokedObject, objc-1, objv+1, callInfoObj,
objv[1], NSF_CM_NO_OBJECT_METHOD|NSF_CSC_IMMEDIATE);
DECR_REF_COUNT(callInfoObj);
DECR_REF_COUNT(pathObj);
}
}
Nsf_PopFrameCsc(interp, framePtr);
return result;
}
#if !defined(NSF_ASSEMBLE)
static int NsfAsmProc(ClientData UNUSED(clientData), Tcl_Interp *UNUSED(interp),
TCL_OBJC_T UNUSED(ojbc), Tcl_Obj *const UNUSED(objv[])) {
return TCL_OK;
}
#endif
/*
*----------------------------------------------------------------------
* CheckCStack --
*
* Monitor the growth of the C Stack when complied with
* NSF_STACKCHECK.
*
* Results:
* None.
*
* Side effects:
* update of rst->bottomOfStack
*
*----------------------------------------------------------------------
*/
#if defined(NSF_STACKCHECK) && defined(PRE86)
NSF_INLINE static void CheckCStack(Tcl_Interp *interp, const char *prefix, const char *fullMethodName)
nonnull(1) nonnull(2) nonnull(3);
NSF_INLINE static void
CheckCStack(Tcl_Interp *interp, const char *prefix, const char *fullMethodName) {
int somevar;
NsfRuntimeState *rst = RUNTIME_STATE(interp);
nonnull_assert(interp != NULL);
nonnull_assert(prefix != NULL);
nonnull_assert(fullMethodName != NULL);
if (rst->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
# if TCL_STACK_GROWS_UP
if ((void *)&somevar < rst->bottomOfStack) {
NsfLog(interp, NSF_LOG_WARN, "Stack adjust bottom %ld - %s %s",
(void *)&somevar - rst->bottomOfStack, prefix, fullMethodName);
rst->bottomOfStack = (void *)&somevar;
} else if ((void *)&somevar > rst->maxStack) {
NsfLog(interp, NSF_LOG_WARN, "Stack adjust top %ld - %s %s",
(void *)&somevar - rst->bottomOfStack, prefix, fullMethodName);
rst->maxStack = (void *)&somevar;
}
# else
if ((void *)&somevar > rst->bottomOfStack) {
NsfLog(interp, NSF_LOG_WARN, "Stack adjust bottom %ld - %s %s",
rst->bottomOfStack - (void *)&somevar, prefix, fullMethodName);
rst->bottomOfStack = (void *)&somevar;
} else if ((void *)&somevar < rst->maxStack) {
NsfLog(interp, NSF_LOG_WARN, "Stack adjust top %ld - %s %s",
rst->bottomOfStack - (void *)&somevar, prefix, fullMethodName);
rst->maxStack = (void *)&somevar;
}
# endif
}
}
#else
# define CheckCStack(interp, prefix, methodName)
#endif
/*
*----------------------------------------------------------------------
* MethodDispatchCsc --
*
* Dispatch a method (scripted or cmd) with an already allocated
* call stack content. The method calls either ProcMethodDispatch()
* (for scripted methods) or CmdMethodDispatch() (otherwise).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling methods
*
*----------------------------------------------------------------------
*/
static int MethodDispatchCsc(
ClientData clientData, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Command cmd,
NsfCallStackContent *cscPtr,
const char *methodName,
bool *validCscPtr
) nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8);
static int
MethodDispatchCsc(
ClientData clientData, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Command cmd,
NsfCallStackContent *cscPtr,
const char *methodName,
bool *validCscPtr
) {
NsfObject *object;
ClientData cp;
TCL_OBJCMDPROC_T *proc;
NsfCallStackContent *cscPtr1;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(cscPtr != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(validCscPtr != NULL);
cp = Tcl_Command_objClientData(cmd);
proc = (TCL_OBJCMDPROC_T*)Tcl_Command_objProc(cmd);
object = cscPtr->self;
/*
* Provide DTrace with calling info
*/
if (NSF_DTRACE_METHOD_ENTRY_ENABLED()) {
NSF_DTRACE_METHOD_ENTRY(ObjectName(object), (cscPtr->cl != NULL) ? ClassName(cscPtr->cl) : ObjectName(object),
(char *)methodName,
objc-1, (Tcl_Obj **)objv+1);
}
if (unlikely(((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_DEPRECATED_METHOD) != 0u)) {
NsfProfileDeprecatedCall(interp, object, cscPtr->cl, methodName, "");
}
if (unlikely(((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_DEBUG_METHOD) != 0u)) {
NsfProfileDebugCall(interp, object, cscPtr->cl, methodName, objc-1, (Tcl_Obj **)objv+1);
}
/*fprintf(stderr, "MethodDispatch method '%s' cmd %p %s clientData %p cp=%p objc=%d cscPtr %p csc->flags %.6x \n",
methodName, (void *)cmd, Tcl_GetCommandName(interp, cmd), (void *)clientData,
(void *)cp, objc, cscPtr, cscPtr->flags);*/
/*fprintf(stderr, "MethodDispatch method '%s' cmd %p cp=%p objc=%d cscPtr %p csc->flags %.6x "
"obj->flags %.6x teardown %p\n",
methodName, (void *)cmd, (void *)cp, objc, (void *)cscPtr, cscPtr->flags,
object->flags, object->teardown);*/
assert(object->teardown != NULL);
/*
* The default assumption is that the CscPtr is valid after this function
* finishes.
*/
if (likely((Tcl_ObjCmdProc*)proc == TclObjInterpProc)) {
int result;
#if defined(NRE)
NRE_callback *rootPtr = TOP_CB(interp);
int isImmediate = (cscPtr->flags & NSF_CSC_IMMEDIATE);
# if defined(NRE_CALLBACK_TRACE)
NsfClass *class = cscPtr->cl;
# endif
#endif
/*
* The cmd is a scripted method
*/
//assert(((Proc *)cp)->refCount > 0);
result = ProcMethodDispatch(cp, interp, objc, objv, methodName,
object, cscPtr->cl, cmd, cscPtr);
#if defined(NRE)
/*
* In the NRE case, there is no trust in the cscPtr anymore, it might be already gone.
*/
*validCscPtr = NSF_FALSE;
if (unlikely(isImmediate)) {
# if defined(NRE_CALLBACK_TRACE)
fprintf(stderr, ".... manual run callbacks rootPtr = %p, result %d methodName %s.%s\n",
(void *)rootPtr, result, ClassName(class), methodName);
# endif
result = NsfNRRunCallbacks(interp, result, rootPtr);
} else {
# if defined(NRE_CALLBACK_TRACE)
fprintf(stderr, ".... don't run callbacks rootPtr = %p, result %d methodName %s.%s\n",
(void *)rootPtr, result, ClassName(class), methodName);
# endif
}
#endif
/*
* scripted method done
*/
return result;
} else if (proc == NsfObjDispatch) {
assert(cp != NULL);
return ObjectCmdMethodDispatch((NsfObject *)cp, interp, objc, objv,
methodName, object, cscPtr);
} else if (cp != NULL) {
cscPtr1 = cscPtr;
/*fprintf(stderr, "cscPtr %p cmd %p %s want to stack cmd %p %s cp %p no-leaf %d force frame %d\n",
(void *)cscPtr, (void *)cmd, Tcl_GetCommandName(interp, cmd),
(void *)cmd, Tcl_GetCommandName(interp, cmd),
(void *)cp,
(Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD),
(cscPtr->flags & NSF_CSC_FORCE_FRAME));*/
/*
* The cmd has client data, we check for required updates in this
* structure.
*/
if (proc == NsfForwardMethod ||
proc == NsfObjscopedMethod ||
proc == NsfSetterMethod ||
proc == NsfAsmProc
) {
TclCmdClientData *tcd = (TclCmdClientData *)cp;
assert(tcd != NULL);
tcd->object = object;
assert(!CmdIsProc(cmd));
} else if (cp == (ClientData)NSF_CMD_NONLEAF_METHOD) {
cp = clientData;
assert(!CmdIsProc(cmd));
}
#if !defined(NDEBUG)
else if (proc == NsfProcAliasMethod) {
/*
* This should never happen!
*/
Tcl_Panic("Alias invoked in unexpected way");
}
#endif
} else if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD) != 0u
|| ((cscPtr->flags & NSF_CSC_FORCE_FRAME) != 0u)) {
/*
* Technically, we would not need a frame to execute the cmd, but maybe,
* the user wants it (to be able to call next, or the keep proc-level
* variables. The clientData cp is in such cases typically NULL.
*/
/*fprintf(stderr, "FORCE_FRAME\n");*/
cscPtr1 = cscPtr;
} else {
/*
* There is no need to pass a frame. Use the original clientData.
*/
cscPtr1 = NULL;
}
if (cscPtr1 != NULL) {
/*
* Call with a stack frame.
*/
/*fprintf(stderr, "cmdMethodDispatch %s.%s, cscPtr %p objflags %.6x\n",
ObjectName(object), methodName, (void *)cscPtr, object->flags); */
return CmdMethodDispatch(cp, interp, objc, objv, object, cmd, cscPtr1);
} else {
/*
* Call without a stack frame.
*/
CscListAdd(interp, cscPtr);
/*fprintf(stderr, "cmdMethodDispatch %p %s.%s, nothing stacked, objflags %.6x\n",
cmd, ObjectName(object), methodName, object->flags); */
return CmdMethodDispatch(clientData, interp, objc, objv, object, cmd, NULL);
}
}
/*
*----------------------------------------------------------------------
* MethodDispatch --
*
* Convenience wrapper for MethodDispatchCsc(). It allocates a call
* stack content and invokes MethodDispatchCsc.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling methods
*
*----------------------------------------------------------------------
*/
static int
MethodDispatch(Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Command cmd, NsfObject *object, NsfClass *class,
const char *methodName, unsigned short frameType, unsigned int flags) {
NsfCallStackContent csc, *cscPtr;
bool isValidCsc = NSF_TRUE;
Tcl_Command resolvedCmd;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
assert(object->teardown != NULL);
CheckCStack(interp, "method", methodName);
/*fprintf(stderr, "MethodDispatch method '%s.%s' objc %d flags %.6x\n",
ObjectName(object), methodName, objc, flags); */
resolvedCmd = AliasDereference(interp, object, methodName, cmd);
if (unlikely(resolvedCmd == NULL)) {
return TCL_ERROR;
}
/*
* cscAlloc uses for resolvedCmd for allocating the call stack content and
* sets the IS_NRE flag based on it. We use the original cmd in the
* call-stack content structure for introspection.
*/
cscPtr = CscAlloc(interp, &csc, resolvedCmd);
/*
* We would not need CscInit when cp (clientData) == NULL &&
* !(Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD) TODO: We could
* pass cmd == NULL, but is this worth it?
*/
CscInit(cscPtr, object, class, cmd, frameType, flags, methodName);
result = MethodDispatchCsc(object, interp, objc, objv,
resolvedCmd, cscPtr, methodName, &isValidCsc);
#if defined(NRE)
if (isValidCsc) {
CscListRemove(interp, cscPtr, NULL);
CscFinish(interp, cscPtr, result, "csc cleanup");
}
#else
CscListRemove(interp, cscPtr, NULL);
CscFinish(interp, cscPtr, result, "csc cleanup");
#endif
return result;
}
/*
*----------------------------------------------------------------------
* ObjectDispatchFinalize --
*
* Finalization function for ObjectDispatch() which performs method
* lookup and call all kind of methods. The function runs after
* ObjectDispatch() and calls the unknown handler if necessary and
* resets the filter and mixin stacks.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe side effects by the cmd called by ParameterCheck()
* or DispatchUnknownMethod()
*
*----------------------------------------------------------------------
*/
NSF_INLINE static int ObjectDispatchFinalize(Tcl_Interp *interp, NsfCallStackContent *cscPtr,
int result /*, char *msg, const char *methodName*/)
nonnull(1) nonnull(2);
NSF_INLINE static int
ObjectDispatchFinalize(Tcl_Interp *interp, NsfCallStackContent *cscPtr,
int result /*, char *msg, const char *methodName*/) {
const NsfRuntimeState *rst;
NsfObject *object;
unsigned int flags;
nonnull_assert(interp != NULL);
nonnull_assert(cscPtr != NULL);
object = cscPtr->self;
assert(object != NULL);
assert(object->id != NULL);
flags = cscPtr->flags;
rst = RUNTIME_STATE(interp);
/*fprintf(stderr, "ObjectDispatchFinalize %p %s flags %.6x (result %d) frame %.6x unk %d m %s\n",
(void*)cscPtr, ObjectName(object), flags,
result, cscPtr->frameType, RUNTIME_STATE(interp)->unknown,
(cscPtr->cmdPtr != NULL) ? Tcl_GetCommandName(interp, cscPtr->cmdPtr) : "");*/
/*
* Check the return value if wanted
*/
if (likely((result == TCL_OK)
&& (cscPtr->cmdPtr != NULL)
&& (Tcl_Command_cmdEpoch(cscPtr->cmdPtr) == 0))) {
Tcl_Obj *returnsObj = ParamDefsGetReturns(cscPtr->cmdPtr);
if (returnsObj != NULL) {
NsfObject *ctxObject = (cscPtr->cl != NULL) ? (NsfObject *)cscPtr->cl : object;
Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(ctxObject->id);
Tcl_Obj *valueObj = Tcl_GetObjResult(interp);
result = ParameterCheck(interp, returnsObj, valueObj, "return-value:",
rst->doCheckResults, NSF_FALSE, NSF_FALSE, NULL,
nsPtr != NULL ? nsPtr->fullName : NULL);
}
} else {
/*fprintf(stderr, "We have no cmdPtr in cscPtr %p %s", cscPtr, ObjectName(object));
fprintf(stderr, "... cannot check return values!\n");*/
}
/*
* On success (no error occurred) check for unknown cases.
*/
if (likely(result == TCL_OK)) {
/*
* When triggered via filter, we might have cases with NRE, where the
* filter is called from a filter, leading to an unknown cscPtr->objv);
* however, there is no need to dispatch in such a case the unknown method.
*/
if (unlikely(((flags & NSF_CSC_METHOD_IS_UNKNOWN) != 0u)
|| ((cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) && rst->unknown && (cscPtr->objv != NULL))
)) {
result = DispatchUnknownMethod(interp, object,
cscPtr->objc, cscPtr->objv, NULL, cscPtr->objv[0],
(cscPtr->flags & NSF_CSC_CALL_NO_UNKNOWN)|NSF_CSC_IMMEDIATE);
}
}
/*
* Resetting mixin and filter stacks
*/
if (unlikely((flags & NSF_CSC_MIXIN_STACK_PUSHED) && object->mixinStack != NULL) != 0u) {
/* fprintf(stderr, "MixinStackPop %s.%s %p %s\n",
ObjectName(object), methodName, object->mixinStack, msg);*/
MixinStackPop(object);
}
if (unlikely((flags & NSF_CSC_FILTER_STACK_PUSHED) && object->filterStack) != 0u) {
/* fprintf(stderr, "FilterStackPop %s.%s %p %s\n",
ObjectName(object), methodName, object->filterStack, msg);*/
FilterStackPop(object);
}
return result;
}
/*#define INHERIT_CLASS_METHODS 1*/
#if defined(INHERIT_CLASS_METHODS)
static Tcl_Command NsfFindClassMethod(Tcl_Interp *interp, NsfClass *class, const char *methodName)
nonnull(1) nonnull(2) nonnull(3);
static Tcl_Command
NsfFindClassMethod(Tcl_Interp *interp, NsfClass *class, const char *methodName) {
Tcl_Command cmd;
NsfClasses *p;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(methodName != NULL);
/*fprintf(stderr, "NsfFindClassMethod %s %s\n", ClassName(class), methodName);*/
for(p = PrecedenceOrder(class); p != NULL; p = p->nextPtr) {
NsfClass *currentClass = p->cl;
Tcl_Namespace *nsPtr = currentClass->object.nsPtr;
/*fprintf(stderr, "1 check for obj ns in class %s => %p\n",
ClassName(currentClass), nsPtr);*/
if (nsPtr != NULL) {
cmd = FindMethod(nsPtr, methodName);
/*fprintf(stderr, "1 lookup for method %s in class %s => %p\n",
methodName, ClassName(currentClass), cmd);*/
if (cmd != NULL) {
return cmd;
}
}
}
return NULL;
}
#endif
/*
*----------------------------------------------------------------------
* CmdObjProcName --
*
* Try to find a symbolic name for the objCmdProc of a Tcl_command.
*
* Results:
* String name, potentially "other"
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char *CmdObjProcName(
Tcl_Command cmd
) nonnull(1) NSF_pure;
static const char *
CmdObjProcName(
Tcl_Command cmd
) {
const char *result;
TCL_OBJCMDPROC_T *proc;
nonnull_assert(cmd != NULL);
proc = (TCL_OBJCMDPROC_T*)Tcl_Command_objProc(cmd);
if (CmdIsNsfObject(cmd)) {
result = "object";
} else if (CmdIsProc(cmd)) {
result = "proc";
} else if (proc == NsfForwardMethod) {
result = "forward";
} else if (proc == NsfProcAliasMethod) {
result = "alias";
} else if (proc == NsfODestroyMethodStub) {
result = "destroy";
} else if (proc == NsfCCreateMethodStub) {
result = "create";
} else if (proc == NsfCNewMethodStub) {
result = "new";
} else if (proc == NsfOConfigureMethodStub) {
result = "configure";
} else if (proc == NsfOVolatileMethodStub) {
result = "volatile";
} else if (proc == NsfOVolatile1MethodStub) {
result = "volatile";
} else if (proc == NsfOAutonameMethodStub) {
result = "autoname";
} else if (proc == NsfOUplevelMethodStub) {
result = "uplevel";
} else if (proc == NsfOUpvarMethodStub) {
result = "upvar";
} else if (proc == NsfObjscopedMethod) {
result = "objscoped";
} else if (proc == NsfProcStub) {
result = "nsfproc";
} else if (proc == NsfSetterMethod) {
result = "setter";
} else if (proc == NsfAsmProc) {
result = "asm";
} else if (proc == (TCL_OBJCMDPROC_T*)TclObjInterpProc) {
result = "alt proc";
#if 0
} else if (proc == (TCL_OBJCMDPROC_T*)Tcl_ApplyObjCmd) {
result = "apply";
} else if (proc == (TCL_OBJCMDPROC_T*)Tcl_EvalObjCmd) {
result = "eval";
#endif
} else {
result = "unknown";
}
return result;
}
/*
*----------------------------------------------------------------------
* ColonCmdCacheSet --
*
* Fill out an ColonCmdCacheSet entry
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static void
ColonCmdCacheSet(
NsfColonCmdContext *ccCtxPtr,
NsfClass *currentClass,
unsigned int methodEpoch,
Tcl_Command cmd,
NsfClass *class,
unsigned int flags
) {
ccCtxPtr->context = currentClass;
ccCtxPtr->methodEpoch = methodEpoch;
ccCtxPtr->cmd = cmd;
ccCtxPtr->class = class;
ccCtxPtr->flags = flags;
}
#if defined(COLON_CMD_STATS)
static void ColonCmdCacheNew(NsfColonCmdContext *ccCtxPtr, Tcl_Obj *obj) {
ccCtxPtr->hits = 0u;
ccCtxPtr->invalidates = 0u;
ccCtxPtr->requiredRefetches = 0u;
ccCtxPtr->obj = obj;
INCR_REF_COUNT(obj);
}
static void ColonCmdCacheInvalidate(NsfColonCmdContext *ccCtxPtr) {
ccCtxPtr->invalidates ++;
}
static void ColonCmdCacheRequiredRefetch(NsfColonCmdContext *ccCtxPtr) {
ccCtxPtr->requiredRefetches ++;
}
static void ColonCmdCacheHit(NsfColonCmdContext *ccCtxPtr) {
ccCtxPtr->hits ++;
}
#else
#define ColonCmdCacheNew(ccCtxPtr, obj)
#define ColonCmdCacheInvalidate(ccCtxPtr)
#define ColonCmdCacheRequiredRefetch(ccCtxPtr)
#define ColonCmdCacheHit(ccCtxPtr)
#endif
#ifdef DO_CLEANUP
/*
*----------------------------------------------------------------------
* NsfColonCmdContextFree --
*
* FreeProc for NsfColonCmdContext
*
* Results:
* None.
*
* Side effects:
* Freeing memory.
*
*----------------------------------------------------------------------
*/
static void
NsfColonCmdContextFree(void *clientData) {
#if defined(COLON_CMD_STATS)
NsfColonCmdContext *ccCtxPtr = clientData;
fprintf(stderr, "### free colonCmdContext for %s: hits %lu invalidates %lu required-refetches %lu\n",
ObjStr(ccCtxPtr->obj), (unsigned long)ccCtxPtr->hits,
(unsigned long)ccCtxPtr->invalidates, (unsigned long)ccCtxPtr->requiredRefetches);
DECR_REF_COUNT(ccCtxPtr->obj);
#endif
FREE(NsfColonCmdContext, clientData);
}
#endif
/*
*----------------------------------------------------------------------
* CacheCmd --
*
* Cache a Tcl_Command element in a Tcl_Obj, using either the NSF
* specific object types, or the colon cmd cache for Tcl cmd types.
*
* Results:
* None.
*
* Side effects:
* Add cache entry
*
*----------------------------------------------------------------------
*/
static void
CacheCmd(
Tcl_Interp *interp,
Tcl_Command cmd,
Tcl_Obj *methodObj,
const Tcl_ObjType *nsfObjTypePtr,
void *context,
unsigned int methodEpoch,
NsfClass *class,
unsigned int flags,
bool isColonCmd
) {
const Tcl_ObjType *methodObjTypePtr = methodObj->typePtr;
if (((methodObjTypePtr != Nsf_OT_tclCmdNameType))
&& (methodObjTypePtr != Nsf_OT_parsedVarNameType)
) {
/*fprintf(stderr, "==== SET OBJ TYPE for %s.%s to NsfInstanceMethodObjType cmd %p\n",
ObjectName(object), calledName, (void*)cmd);*/
NsfMethodObjSet(interp, methodObj, nsfObjTypePtr,
context, methodEpoch, cmd, class, flags);
} else if (isColonCmd && (methodObj->refCount > 1)) {
/*
* When the refCount <= 1, the object is a temporary object, for which
* caching is not useful. We could also cache the following types, but the
* benefit is not clear.
*
* (methodObjTypePtr != Nsf_OT_tclCmdNameType)
* || (TCL_COMMAND_OBJPROC(cmd) == NsfProcAliasMethod)
*
*/
NsfColonCmdContext *ccCtxPtr = methodObj->internalRep.twoPtrValue.ptr2;
if (ccCtxPtr != NULL) {
/*
* We had already a ccCtxPtr, so the value was invalidated before.
*/
ColonCmdCacheInvalidate(ccCtxPtr);
if (ccCtxPtr->cmd != cmd) {
/*
* The cached cmd differs from actual one, so this was a required
* refetch operation, where the invalidation was truly necessary.
*/
ColonCmdCacheRequiredRefetch(ccCtxPtr);
}
ColonCmdCacheSet(ccCtxPtr, context, methodEpoch, cmd, class, flags);
} else {
NsfRuntimeState *rst = RUNTIME_STATE(interp);
/*fprintf(stderr, "======== new entry for %p %s type %s refCount %d ccCtxPtr %p flags %.6x context %s\n",
(void*)methodObj, ObjStr(methodObj), ObjTypeStr(methodObj),
methodObj->refCount, (void*)ccCtxPtr, flags, ObjectName((NsfObject*)context));*/
/*
* Create an NsfColonCmdContext and supply it with data (primarily the
* cmd, the other data is for validation).
*/
ccCtxPtr = NEW(NsfColonCmdContext);
ColonCmdCacheNew(ccCtxPtr, methodObj);
ColonCmdCacheSet(ccCtxPtr, context, methodEpoch, cmd, class, flags);
/*
* Save the NsfColonCmdContext in the proc context for memory management
* and as well for reuse in twoPtrValue.ptr2.
*/
/* rst->freeListPtr = NsfListCons(ccCtxPtr, rst->freeListPtr); */
NsfDListAppend(&rst->freeDList, ccCtxPtr);
methodObj->internalRep.twoPtrValue.ptr2 = ccCtxPtr;
/*fprintf(stderr, "==== ptr2 of %s empty, is set %p for obj %p %p %s target proc ctx %p ccCtx %p\n",
ObjStr(methodObj),
(void*)cmd, (void*)object, (void*)methodObj, ObjStr(methodObj),
(void*)pCtxPtr, (void*)pCtxPtr->freeListObj);*/
}
} else {
/*
* We found a command, but we do not cache it...
*/
/* fprintf(stderr, "... found cmd '%s' type of methodObj '%s' type %s, procType %s but we do not cache\n",
Tcl_GetCommandName(NULL, cmd), ObjStr(methodObj),
methodObjTypePtr ? methodObjTypePtr->name : "NONE",
CmdObjProcName(cmd));*/
}
}
/*
*----------------------------------------------------------------------
* ObjectDispatch --
*
* This function performs the method lookup and call all kind of
* methods. It checks, whether a filter or mixin has to be
* applied. In these cases, the effective method lookup is
* performed by "next".
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe side effects by the cmd called by ParameterCheck()
* or DispatchUnknownMethod()
*
*----------------------------------------------------------------------
*/
NSF_INLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
unsigned int flags)
nonnull(1) nonnull(2) nonnull(4);
NSF_INLINE static int
ObjectDispatch(
ClientData clientData,
Tcl_Interp *interp,
TCL_OBJC_T objc,
Tcl_Obj *const objv[],
unsigned int flags
) {
int result = TCL_OK, shift;
bool isValidCsc = NSF_TRUE;
unsigned int objflags, nsfObjectMethodEpoch;
unsigned short frameType = NSF_CSC_TYPE_PLAIN;
register NsfObject *object;
const char *methodName, *calledName;
NsfObject *calledObject;
NsfClass *class = NULL;
Tcl_Obj *cmdName, *methodObj;
const Tcl_ObjType *methodObjTypePtr;
NsfColonCmdContext *ccCtxPtr;
const NsfRuntimeState *rst;
NsfCallStackContent csc, *cscPtr = NULL;
Tcl_Command cmd = NULL;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
object = (NsfObject *)clientData;
cmdName = object->cmdName;
rst = RUNTIME_STATE(interp);
nsfObjectMethodEpoch = rst->objectMethodEpoch;
/*
* None of the higher copy-flags must be passed
*/
assert((flags & (NSF_CSC_COPY_FLAGS & 0x000FFF000U)) == 0u);
/*
* Do we have to shift the argument vector?
*/
if (unlikely((flags & NSF_CM_NO_SHIFT) != 0u)) {
shift = 0;
methodObj = objv[0];
methodName = MethodName(methodObj);
calledName = ObjStr(methodObj);;
} else {
assert(objc > 1);
shift = 1;
methodObj = objv[1];
methodName = ObjStr(methodObj);
calledName = methodName;
if (unlikely(FOR_COLON_RESOLVER(methodName))) {
return NsfPrintError(interp, "%s: method name '%s' must not start with a colon",
ObjectName_(object), methodName);
}
}
methodObjTypePtr = methodObj->typePtr;
if (methodObjTypePtr == Nsf_OT_tclCmdNameType) {
ccCtxPtr = methodObj->internalRep.twoPtrValue.ptr2;
} else {
ccCtxPtr = NULL;
}
#if 0
/*
* This code block is purely for debugging erroneous behavior with broken
* cached Tcl Command, where the command itself looks perfectly fine, but
* the procPtr behind this contains invalid data. This seems to happen only
* for scripted commands. In such cases, we do not trust the data obtained
* from the Tcl_Obj.
*/
if (ccCtxPtr != NULL
&& ccCtxPtr->context == object
&& ccCtxPtr->methodEpoch == nsfObjectMethodEpoch
&& ccCtxPtr->flags == flags
&& ccCtxPtr->cmd != NULL
&& CmdIsProc(ccCtxPtr->cmd)) {
/* fprintf(stderr, "cached scripted call %s (object %s class %s) cmd %p (proc %p) cmdName %s \n",
methodName, ObjectName(object), ClassName(object->cl), ccCtxPtr->cmd, Tcl_Command_objClientData(ccCtxPtr->cmd), Tcl_GetCommandName(interp, ccCtxPtr->cmd));*/
Proc *procPtr = Tcl_Command_objClientData(ccCtxPtr->cmd);
if ((Tcl_Interp *)procPtr->iPtr != interp
|| procPtr->bodyPtr == NULL
|| procPtr->refCount < 1
#ifdef PRE9
|| procPtr->numArgs < 0
|| procPtr->numCompiledLocals < 0
#endif
|| procPtr->numArgs > 10000
|| procPtr->numCompiledLocals > 10000
) {
fprintf(stderr, "################### do NOT trust cached procPtr %p of %s "
"(object %s class %s) bodyPtr %p "
"iPtr %p interp %p refCount %lu numArgs %lu numCompiledLocals %lu\n",
(void*)procPtr, methodName,
ObjectName(object), ClassName(object->cl),
(void*)procPtr->bodyPtr, (void*)procPtr->iPtr, (void*)interp,
(unsigned long)procPtr->refCount,
(unsigned long)procPtr->numArgs,
(unsigned long)procPtr->numCompiledLocals);
ccCtxPtr = NULL;
}
}
#endif
assert(object->teardown != NULL);
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "method %p/%d '%s' type %p <%s>\n",
(void*)methodObj, methodObj->refCount, methodName, (void*)methodObjTypePtr,
(methodObjTypePtr != NULL) ? methodObjTypePtr->name : "");
#endif
/*fprintf(stderr, "==== ObjectDispatch obj = %s objc = %d 0=%s methodName=%s method-obj-type %s cmd %p shift %d\n",
(object != NULL) ? ObjectName(object) : NULL,
objc, objv[0] ? ObjStr(objv[0]) : NULL,
methodName, methodObjTypePtr ? methodObjTypePtr->name : "NONE",
(void*)cmd, shift);*/
objflags = object->flags; /* avoid stalling */
/*
* Make sure, cmdName and obj survive this method until the end of
* this function.
*/
INCR_REF_COUNT(cmdName);
NsfObjectRefCountIncr(object);
/*fprintf(stderr, "obj refCount of %p after incr %d (ObjectDispatch) %s\n",
object, object->refCount, methodName);*/
if (unlikely((objflags & NSF_FILTER_ORDER_VALID) == 0u)) {
FilterComputeDefined(interp, object);
objflags = object->flags;
}
if (unlikely((objflags & NSF_MIXIN_ORDER_VALID) == 0u)) {
MixinComputeDefined(interp, object);
objflags = object->flags;
}
/*
* Only start new filter chain, if
* (a) filters are defined and
* (b) the top-level csc entry is not a filter on self
*/
/*fprintf(stderr, "call %s, objflags %.6x, defined and valid %.6x doFilters %d guard count %d\n",
methodName, objflags, NSF_FILTER_ORDER_DEFINED_AND_VALID,
rst->doFilters, rst->guardCount);*/
assert((flags & (NSF_CSC_MIXIN_STACK_PUSHED|NSF_CSC_FILTER_STACK_PUSHED)) == 0u);
if (unlikely((objflags & NSF_FILTER_ORDER_DEFINED_AND_VALID) == NSF_FILTER_ORDER_DEFINED_AND_VALID)) {
if (rst->doFilters && !rst->guardCount) {
const NsfCallStackContent *cscPtr1 = CallStackGetTopFrame0(interp);
if ((cscPtr1 == NULL)
|| (object != cscPtr1->self)
|| (cscPtr1->frameType != NSF_CSC_TYPE_ACTIVE_FILTER)
) {
FilterStackPush(object, methodObj);
flags |= NSF_CSC_FILTER_STACK_PUSHED;
cmd = FilterSearchProc(interp, object, &object->filterStack->currentCmdPtr, &class);
if (cmd != NULL) {
/*fprintf(stderr, "*** filterSearchProc returned cmd %p\n", (void*)cmd);*/
frameType = NSF_CSC_TYPE_ACTIVE_FILTER;
methodName = (char *)Tcl_GetCommandName(interp, cmd);
flags |= NSF_CM_IGNORE_PERMISSIONS;
}
}
}
}
if (unlikely(cmd == NULL && ((flags & NSF_CM_LOCAL_METHOD) != 0u))) {
/*
* We require a local method. If the local method is found, we set always
* the cmd and sometimes the class (if it is a class specific method).
*/
const NsfCallStackContent *cscPtr1 = CallStackGetTopFrame0(interp);
if (unlikely(cscPtr1 == NULL)) {
return NsfPrintError(interp, "flag '-local' only allowed when called from a method body");
}
if (cscPtr1->cl != NULL) {
cmd = FindMethod(cscPtr1->cl->nsPtr, methodName);
if (cmd != NULL) {
class = cscPtr1->cl;
}
} else if (object->nsPtr != NULL) {
cmd = FindMethod(object->nsPtr, methodName);
}
/*fprintf(stderr, "ObjectDispatch NSF_CM_LOCAL_METHOD obj %s methodName %s => cl %p %s cmd %p \n",
(object != NULL) ? ObjectName(object) : NULL,
methodName, (void*)class, (class != NULL) ? ClassName(class) : "NONE", (void*)cmd);*/
} else if (unlikely(*methodName == ':')) {
NsfObject *regObject;
bool fromClassNS = NSF_FALSE;
/*
* We have fully qualified name provided. Determine the class and/or
* object on which the method was registered.
*/
INCR_REF_COUNT(methodObj);
cmd = ResolveMethodName(interp, NULL, methodObj,
NULL, ®Object, NULL, NULL, &fromClassNS);
DECR_REF_COUNT(methodObj);
if (likely(cmd != NULL)) {
if (CmdIsNsfObject(cmd)) {
/*
* Don't allow for calling objects as methods via fully qualified
* names. Otherwise, in line [2] below, ::State (or any children of
* it, e.g., ::Slot::child) is interpreted as a method candidate. As a
* result, dispatch chaining occurs with ::State or ::State::child
* being the receiver (instead of Class) of the method call
* "-parameter". In such a dispatch chaining, the method "unknown"
* won't be called on Class (in the XOTcl tradition), effectively
* bypassing any unknown-based indirection mechanism (e.g., XOTcl's short-cutting
* of object/class creations).
*
* [1] Class ::State; Class ::State::child
* [2] Class ::State -parameter x; Class ::State::child -parameter x
*/
NsfLog(interp, NSF_LOG_NOTICE,
"Don't invoke object %s this way. Register object via alias ...",
methodName);
cmd = NULL;
} else {
if (regObject != NULL) {
if (NsfObjectIsClass(regObject)) {
class = (NsfClass *)regObject;
}
}
/* fprintf(stderr, "fully qualified lookup of %s returned %p\n", ObjStr(methodObj), cmd); */
/*
* Ignore permissions for fully qualified method names.
*/
flags |= NSF_CM_IGNORE_PERMISSIONS;
}
/*fprintf(stderr, "ObjectDispatch fully qualified obj %s methodName %s => cl %p cmd %p \n",
(object != NULL) ? ObjectName(object) : NULL,
methodName, (void*)cl, (void*)cmd);*/
}
}
/*fprintf(stderr, "MixinStackPush check for %p %s.%s objflags %.6x == %d\n",
object, ObjectName(object), methodName, objflags & NSF_MIXIN_ORDER_DEFINED_AND_VALID,
(objflags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) == NSF_MIXIN_ORDER_DEFINED_AND_VALID);*/
/*
* Check whether a mixed in method has to be called. This is necessary, even when
* cmd is already determined.
*/
if (unlikely((objflags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) == NSF_MIXIN_ORDER_DEFINED_AND_VALID
&& (flags & (NSF_CM_SYSTEM_METHOD|NSF_CM_INTRINSIC_METHOD)) == 0u
&& ((flags & NSF_CM_LOCAL_METHOD) == 0u || class != NULL))
) {
/*
* The current logic allocates first an entry on the per-object
* stack and searches then for a mixin. This could be improved by
* allocating a stack entry just when a mixin is found. The same
* holds for the filters above, but there, the hit-rate is much
* larger.
*/
MixinStackPush(object);
flags |= NSF_CSC_MIXIN_STACK_PUSHED;
if (frameType != NSF_CSC_TYPE_ACTIVE_FILTER) {
Tcl_Command cmd1 = cmd;
/*
* The entry is just searched and pushed on the stack when we
* have no filter; in the filter case, the search happens in
* next.
*/
result = MixinSearchProc(interp, object, methodName, &class,
&object->mixinStack->currentCmdPtr, &cmd1);
if (unlikely(result != TCL_OK)) {
/*fprintf(stderr, "mixinsearch returned an error for %p %s.%s\n",
object, ObjectName(object), methodName);*/
isValidCsc = NSF_FALSE;
goto exit_object_dispatch;
}
if (cmd1 != NULL) {
frameType = NSF_CSC_TYPE_ACTIVE_MIXIN;
cmd = cmd1;
}
}
}
/*fprintf(stderr, "ObjectDispatch ordinary lookup %s.%s cmd %p\n",
ObjectName(object), ObjStr(methodObj), (void*)cmd);*/
/*
* If no fully qualified method name/filter/mixin was found then perform
* ordinary method lookup. First, try to resolve the method name as a
* per-object method.
*/
if (likely(cmd == NULL)) {
NsfMethodContext *mcPtr = methodObj->internalRep.twoPtrValue.ptr1;
if (methodObjTypePtr == &NsfObjectMethodObjType
&& mcPtr->context == object
&& mcPtr->methodEpoch == nsfObjectMethodEpoch
&& mcPtr->flags == flags
) {
cmd = mcPtr->cmd;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... use internal rep method %p %s cmd %p (objProc %p) cl %p %s\n",
(void*)methodObj, ObjStr(methodObj),
(void*)cmd, (cmd != NULL) ? (void*)((Command *)cmd)->objProc : 0,
(void*)class, (class != NULL) ? ClassName(class) : ObjectName(object));
#endif
assert((cmd != NULL) ? ((Command *)cmd)->objProc != NULL : 1);
} else if (methodObjTypePtr == Nsf_OT_tclCmdNameType
&& ccCtxPtr != NULL
&& ccCtxPtr->context == object
&& ccCtxPtr->methodEpoch == nsfObjectMethodEpoch
&& ccCtxPtr->flags == flags
) {
cmd = ccCtxPtr->cmd;
class = ccCtxPtr ->class;
ColonCmdCacheHit(ccCtxPtr);
} else {
/*
* Check whether the call can be resolved against an object-specific method.
*/
if (unlikely((object->nsPtr != NULL)
&& (flags & (NSF_CM_NO_OBJECT_METHOD|NSF_CM_SYSTEM_METHOD)) == 0u)) {
cmd = FindMethod(object->nsPtr, methodName);
/*fprintf(stderr, "ObjectDispatch lookup for per-object method in obj %p method %s nsPtr %p"
" => %p objProc %p\n",
(void*)object, methodName, (void*)object->nsPtr, (void*)cmd,
(cmd != NULL) ? (void*)((Command *)cmd)->objProc : NULL);*/
if (cmd != NULL) {
/*
* Reject resolved cmd when
* a) trying to call a private method without the local flag or ignore permissions, or
* b) trying to call an object with no method interface
*/
if (((flags & (NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0u
&& ((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD) != 0u)
) {
cmd = NULL;
} else {
CacheCmd(interp,
cmd, methodObj, &NsfObjectMethodObjType,
object, nsfObjectMethodEpoch, NULL, flags,
(*calledName == ':'));
}
}
}
}
#if defined(INHERIT_CLASS_METHODS)
/*
* This is not optimized yet, since current class might be checked twice,
* but easier to maintain.
*/
if ((flags & NSF_CM_NO_OBJECT_METHOD) == 0u && cmd == NULL && NsfObjectIsClass(object)) {
cmd = NsfFindClassMethod(interp, (NsfClass *)object, methodName);
}
#endif
if (likely(cmd == NULL)) {
/*
* Check whether the call can be resolved against an instance method.
*/
NsfClass *currentClass = object->cl;
NsfMethodContext *mcPtr0 = methodObj->internalRep.twoPtrValue.ptr1;
unsigned int nsfInstanceMethodEpoch = rst->instanceMethodEpoch;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... method %p/%d '%s' type %p %s type? %d context? %d nsfMethodEpoch %d => %d\n",
(void*)methodObj, methodObj->refCount, ObjStr(methodObj),
(void*)methodObjTypePtr, (methodObjTypePtr != NULL) ? methodObjTypePtr->name : "NONE",
methodObjTypePtr == &NsfInstanceMethodObjType,
methodObjTypePtr == &NsfInstanceMethodObjType ? mcPtr0->context == currentClass : 0,
methodObjTypePtr == &NsfInstanceMethodObjType ? mcPtr0->methodEpoch : 0,
nsfInstanceMethodEpoch );
#endif
if (methodObjTypePtr == &NsfInstanceMethodObjType
&& mcPtr0->context == currentClass
&& mcPtr0->methodEpoch == nsfInstanceMethodEpoch
&& mcPtr0->flags == flags
) {
cmd = mcPtr0->cmd;
class = mcPtr0->cl;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... use internal rep method %p %s cmd %p (objProc %p) cl %p %s\n",
(void*)methodObj, ObjStr(methodObj),
(void*)cmd, (cmd != NULL) ? (void*)((Command *)cmd)->objProc : NULL,
(void*)class, (class != NULL) ? ClassName(class) : ObjectName(object));
#endif
assert((cmd != NULL) ? ((Command *)cmd)->objProc != NULL : 1);
} else if (methodObjTypePtr == Nsf_OT_tclCmdNameType
&& ccCtxPtr != NULL
&& ccCtxPtr->context == currentClass
&& ccCtxPtr->methodEpoch == nsfInstanceMethodEpoch
&& ccCtxPtr->flags == flags
) {
cmd = ccCtxPtr->cmd;
class = ccCtxPtr ->class;
ColonCmdCacheHit(ccCtxPtr);
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... use internal rep ptr2 method %p %s cmd %p (objProc %p) cl %p %s\n",
(void*)methodObj, ObjStr(methodObj),
(void*)cmd, (cmd != NULL) ? (void*)((Command *)cmd)->objProc : NULL,
(void*)class, (class != NULL) ? ClassName(class) : ObjectName(object));
#endif
} else {
/*
* We could call PrecedenceOrder(currentClass) to recompute
* currentClass->order on demand, but by construction this is already
* set here.
*/
assert(currentClass->order);
if (unlikely((flags & NSF_CM_SYSTEM_METHOD) != 0u)) {
NsfClasses *classListPtr = currentClass->order;
/*
* Skip entries until the (first) base class.
*/
do {
if (IsBaseClass(&classListPtr->cl->object)) {
break;
}
classListPtr = classListPtr->nextPtr;
} while (classListPtr->nextPtr != NULL);
class = SearchPLMethod(classListPtr, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD);
} else {
class = SearchPLMethod(currentClass->order, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD);
}
/*fprintf(stderr, "... check type of methodObj %s type %s check %d\n",
calledName, methodObjTypePtr ? methodObjTypePtr->name : "NONE",
(((methodObjTypePtr != Nsf_OT_tclCmdNameType) || *calledName == ':')
&& methodObjTypePtr != Nsf_OT_parsedVarNameType
&& likely(cmd != NULL) )
);*/
if (likely(cmd != NULL)) {
CacheCmd(interp,
cmd, methodObj, &NsfInstanceMethodObjType,
currentClass, nsfInstanceMethodEpoch, class, flags,
(*calledName == ':'));
}
}
}
}
calledObject = object;
/*
* If we have a command, check the permissions, unless
* NSF_CM_IGNORE_PERMISSIONS is set. Note that NSF_CM_IGNORE_PERMISSIONS is
* set currently for fully qualified cmd names and in nsf::object::dispatch.
*/
if (likely((cmd != NULL) && (flags & NSF_CM_IGNORE_PERMISSIONS) == 0u)) {
const unsigned int cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
#if !defined(NDEBUG)
if (unlikely(((cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u)
&& ((flags & NSF_CM_LOCAL_METHOD) == 0u))
) {
/*
* Private methods can be only called with the "-local" flag. All cases
* handling private methods should be covered above (e.g. by setting
* NSF_CM_IGNORE_PERMISSIONS, or by filtering private methods in method
* search. So, this branch should never by executed.
*/
Tcl_Panic("Unexpected handling of private method; most likely a caching bug");
cmd = NULL;
} else
#endif
if (unlikely((cmdFlags & NSF_CMD_CALL_PROTECTED_METHOD) != 0u)) {
const NsfObject *lastSelf = GetSelfObj(interp);
/*
* Protected methods can be called, when calling object == called object.
*/
if (unlikely(object != lastSelf)) {
NsfLog(interp, NSF_LOG_WARN, "'%s %s' fails since method %s.%s is protected",
ObjectName(object), methodName,
(class != NULL) ? ClassName(class) : ObjectName(object),
methodName);
/*
* Reset cmd, since it is still unknown.
*/
cmd = NULL;
}
}
}
assert(result == TCL_OK);
if (likely(cmd != NULL)) {
/*
* We found the method to dispatch.
*/
const Tcl_Command resolvedCmd = AliasDereference(interp, object, methodName, cmd);
if (unlikely(resolvedCmd == NULL)) {
isValidCsc = NSF_FALSE;
goto exit_object_dispatch;
}
/*
* cscAlloc uses resolvedCmd for allocating the call stack content and
* sets the IS_NRE flag based on it. We use the original cmd in the
* call-stack content structure for introspection.
*/
cscPtr = CscAlloc(interp, &csc, resolvedCmd);
CscInit(cscPtr, calledObject, class, cmd, frameType, flags, methodName);
if (unlikely(cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER)) {
/*
* Run filters is not NRE enabled.
*/
cscPtr->flags |= NSF_CSC_IMMEDIATE;
/*
* Setting cscPtr->objc and cscPtr->objv is needed for invoking UNKNOWN
* from ProcMethodDispatchFinalize()
*/
cscPtr->objc = objc - (TCL_OBJC_T)shift;
cscPtr->objv = objv + shift;
}
/* fprintf(stderr, "MethodDispatchCsc %s.%s %p flags %.6x cscPtr %p method-obj-type %s\n",
ObjectName(object), methodName, (void*)object->mixinStack, cscPtr->flags,
(void*)cscPtr, methodObj->typePtr ? methodObj->typePtr->name : "NONE");*/
result = MethodDispatchCsc(clientData, interp, objc - (TCL_OBJC_T)shift, objv + shift,
resolvedCmd, cscPtr, methodName, &isValidCsc);
/* fprintf(stderr, "MethodDispatchCsc %s.%s %p flags %.6x cscPtr %p method-obj-type %s DONE\n",
ObjectName(object), methodName, (void*)object->mixinStack, cscPtr->flags,
(void*)cscPtr, methodObj->typePtr ? methodObj->typePtr->name : "NONE"); */
if (unlikely(result == TCL_ERROR)) {
/*fprintf(stderr, "Call ErrInProc cl = %p, cmd %p, methodName %s flags %.6x\n",
class, (class != NULL) ? class->object.id : NULL, methodName, (class != NULL) ? class->object.flags : 0);*/
result = NsfErrInProc(interp, cmdName,
(class != NULL && class->object.teardown) ? class->object.cmdName : NULL,
methodName);
}
} else {
/*
* The method to be dispatched is unknown
*/
cscPtr = CscAlloc(interp, &csc, cmd);
CscInit(cscPtr, object, class, cmd, frameType, flags, methodName);
cscPtr->flags |= NSF_CSC_METHOD_IS_UNKNOWN;
if ((flags & NSF_CM_NO_UNKNOWN) != 0u) {
cscPtr->flags |= NSF_CSC_CALL_NO_UNKNOWN;
}
cscPtr->objc = objc - (TCL_OBJC_T)shift;
cscPtr->objv = objv + shift;
}
exit_object_dispatch:
if (likely(isValidCsc)) {
/*
* In every situation, we have a cscPtr containing all context information
*/
assert(cscPtr != NULL);
result = ObjectDispatchFinalize(interp, cscPtr, result /*, "immediate" , methodName*/);
CscListRemove(interp, cscPtr, NULL);
CscFinish(interp, cscPtr, result, "non-scripted finalize");
}
/*fprintf(stderr, "ObjectDispatch %s.%s returns %d\n",
ObjectName(object), methodName, result);*/
NsfCleanupObject(object, "ObjectDispatch");
/*fprintf(stderr, "ObjectDispatch call NsfCleanupObject %p DONE\n", object);*/
DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */
return result;
}
/*
*----------------------------------------------------------------------
* DispatchDefaultMethod --
*
* Dispatch the default method (when object is called without arguments)
* in case the object system has it defined.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int
DispatchDefaultMethod(Tcl_Interp *interp, NsfObject *object,
Tcl_Obj *obj, unsigned int flags) {
int result;
Tcl_Obj *methodObj;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(obj != NULL);
if (CallDirectly(interp, object, NSF_o_defaultmethod_idx, &methodObj)) {
Tcl_SetObjResult(interp, object->cmdName);
result = TCL_OK;
} else {
Tcl_Obj *tov[2];
tov[0] = obj;
tov[1] = methodObj;
result = ObjectDispatch(object, interp, 2, tov,
flags|NSF_CM_NO_UNKNOWN|NSF_CM_IGNORE_PERMISSIONS);
}
return result;
}
/*
*----------------------------------------------------------------------
* DispatchDestroyMethod --
*
* Dispatch the method "destroy" in case the object system has it
* defined. During the final cleanup of the object system, the
* destroy is called separately from deallocation. Normally,
* Object.destroy() calls dealloc, which is responsible for the
* physical deallocation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int
DispatchDestroyMethod(Tcl_Interp *interp, NsfObject *object, unsigned int flags) {
int result;
NsfRuntimeState *rst;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
rst = RUNTIME_STATE(interp);
if (unlikely(rst == NULL)) {
/*
* There is no run time state in this interpreter.
*/
if ((Tcl_Interp_flags(interp) & DELETED)) {
/*
* The interpreter is already deleted, just ignore this call.
*/
result = TCL_OK;
} else {
/*
* In all other cases we expect a run time state. If this is violated,
* something substantial must be wrong, so panic.
*/
Tcl_Panic("Runtime state is lost");
result = TCL_OK;
}
} else {
/*
* Don't call destroy after exit handler started physical
* destruction, or when it was called already before
*/
if (rst->exitHandlerDestroyRound == NSF_EXITHANDLER_ON_PHYSICAL_DESTROY
|| (object->flags & NSF_DESTROY_CALLED) != 0u
) {
result = TCL_OK;
} else {
Tcl_Obj *methodObj;
/*
* We can call destroy.
*/
/*fprintf(stderr, " DispatchDestroyMethod obj %p flags %.6x active %d\n",
object, object->flags, object->activationCount); */
PRINTOBJ("DispatchDestroyMethod", object);
/*
* Flag that destroy was called and invoke the method.
*/
object->flags |= NSF_DESTROY_CALLED;
if (CallDirectly(interp, object, NSF_o_destroy_idx, &methodObj)) {
NSF_PROFILE_TIME_DATA;
NSF_PROFILE_CALL(interp, object, Nsf_SystemMethodOpts[NSF_o_destroy_idx]);
result = NsfODestroyMethod(interp, object);
NSF_PROFILE_EXIT(interp, object, Nsf_SystemMethodOpts[NSF_o_destroy_idx]);
} else {
result = CallMethod(object, interp, methodObj, 2, NULL,
NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE|flags);
}
if (unlikely(result != TCL_OK)) {
/*
* The object might be already gone here, since we have no stack frame.
* Therefore, we can't even use nsf::current object safely.
*/
NsfErrorContext(interp, "method destroy");
if (++rst->errorCount > 20) {
Tcl_Panic("too many destroy errors occurred. Endless loop?");
}
} else if (rst->errorCount > 0) {
rst->errorCount--;
}
#ifdef OBJDELETION_TRACE
fprintf(stderr, "DispatchDestroyMethod for %p exit\n", (void *)object);
#endif
}
}
return result;
}
/*
*----------------------------------------------------------------------
* DispatchInitMethod --
*
in case the object system has it
* defined and it was not already called on the object,
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int DispatchInitMethod(Tcl_Interp *interp, NsfObject *object,
TCL_OBJC_T objc, Tcl_Obj *const objv[], unsigned int flags)
nonnull(1) nonnull(2);
static int
DispatchInitMethod(Tcl_Interp *interp, NsfObject *object,
TCL_OBJC_T objc, Tcl_Obj *const objv[], unsigned int flags) {
int result;
Tcl_Obj *methodObj;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*
* check, whether init was called already
*/
if ((object->flags & (NSF_INIT_CALLED|NSF_DESTROY_CALLED)) == 0u) {
/*
* Flag the call to "init" before the dispatch, such that a call to
* "configure" within init does not clear the already set instance
* variables.
*/
object->flags |= NSF_INIT_CALLED;
if (CallDirectly(interp, object, NSF_o_init_idx, &methodObj)) {
/*fprintf(stderr, "%s init directly\n", ObjectName(object));*/
/*
* Actually, nothing to do.
*/
result = TCL_OK;
} else {
result = CallMethod(object, interp, methodObj, objc+2, objv,
flags|NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
}
} else {
result = TCL_OK;
}
return result;
}
/*
*----------------------------------------------------------------------
* DispatchUnknownMethod --
*
* Dispatch the method "unknown" in case the object system has it
* defined and the application program contains an unknown handler.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* There might be indirect effects by calling Tcl code; also,
* the interp's unknown-state is reset.
*
*----------------------------------------------------------------------
*/
static int
DispatchUnknownMethod(Tcl_Interp *interp, NsfObject *object,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Obj *callInfoObj, Tcl_Obj *methodObj, unsigned int flags) {
int result;
Tcl_Obj *unknownObj;
const char *methodName;
NsfRuntimeState *rst;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(methodObj != NULL);
rst = RUNTIME_STATE(interp);
methodName = MethodName(methodObj);
unknownObj = NsfMethodObj(object, NSF_o_unknown_idx);
/*fprintf(stderr, "compare unknownObj %p with methodObj %p '%s' %p %p %s -- %s\n",
unknownObj, methodObj, ObjStr(methodObj), callInfoObj,
(callInfoObj != NULL) ? objv[1] : NULL,
(callInfoObj != NULL) ? ObjStr(objv[1]) : NULL,
methodName);*/
if ((unknownObj != NULL)
&& (methodObj != unknownObj)
&& (flags & NSF_CSC_CALL_NO_UNKNOWN) == 0u
) {
/*
* Back off and try unknown.
*/
bool mustCopy = (*(ObjStr(methodObj)) == ':');
ALLOC_ON_STACK(Tcl_Obj*, objc+3, tov);
if (callInfoObj == NULL) {
callInfoObj = (mustCopy ? Tcl_NewStringObj(methodName, TCL_INDEX_NONE) : methodObj);
}
INCR_REF_COUNT(callInfoObj);
/*fprintf(stderr, "calling unknown for %s %s, flags=%.6x,%.6x/%.6x isClass=%d %p %s objc %d\n",
ObjectName(object), ObjStr(methodObj), flags, NSF_CM_NO_UNKNOWN, NSF_CSC_CALL_NO_UNKNOWN,
NsfObjectIsClass(object), object, ObjectName(object), objc);*/
tov[0] = object->cmdName;
tov[1] = unknownObj;
tov[2] = callInfoObj;
if (objc > 1) {
memcpy(tov + 3, objv + 1, sizeof(Tcl_Obj *) * ((size_t)objc - 1u));
}
flags &= ~NSF_CM_NO_SHIFT;
/*fprintf(stderr, "call unknown via dispatch mustCopy %d delegator %p method %s (%s)\n",
mustCopy, delegator, ObjStr(tov[offset]), ObjStr(methodObj));*/
result = ObjectDispatch(object, interp, objc+2, tov,
flags|NSF_CM_NO_UNKNOWN|NSF_CM_IGNORE_PERMISSIONS);
DECR_REF_COUNT(callInfoObj);
FREE_ON_STACK(Tcl_Obj*, tov);
} else {
Tcl_Obj *tailMethodObj = NULL;
/*
* No unknown called. This is the built-in unknown handler.
*/
if (objc > 1 && ((*methodName) == '-' || (unknownObj && objv[0] == unknownObj))) {
TCL_SIZE_T length;
tailMethodObj = objv[1];
if ((((object->flags & NSF_KEEP_CALLER_SELF) != 0u) ||
((object->flags & NSF_PER_OBJECT_DISPATCH) != 0u)) &&
Tcl_ListObjLength(interp, objv[1], &length) == TCL_OK) {
if (length > 1) {
Tcl_ListObjIndex(interp, objv[1], (TCL_SIZE_T)length - 1, &tailMethodObj);
}
}
}
result = NsfPrintError(interp, "%s: unable to dispatch method '%s'",
ObjectName_(object),
(tailMethodObj != NULL) ? MethodName(tailMethodObj) : methodName);
}
/*
* Reset interp state, unknown has been fired.
*/
rst->unknown = 0;
return result;
}
/*
*----------------------------------------------------------------------
* NsfObjDispatch --
*
* This function is called on every object dispatch (when an object
* is invoked). It calls either the passed method, or dispatches
* some default method.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe side effects by the cmd called by ParameterCheck()
* or DispatchUnknownMethod()
*
*----------------------------------------------------------------------
*/
#if defined(NRE)
TCL_OBJCMDPROC_T NsfObjDispatchNRE;
int
NsfObjDispatch(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
return TCL_NRCALLOBJPROC(interp, NsfObjDispatchNRE, clientData, (TCL_SIZE_T)objc, objv);
}
int NsfObjDispatchNRE(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(4);
int
NsfObjDispatchNRE(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
#else
EXTERN int
NsfObjDispatch(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
#endif
{
int result;
#ifdef STACK_TRACE
NsfStackDump(interp);
#endif
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
if (likely(objc > 1)) {
/*
* Normal dispatch; we must not use NSF_CSC_IMMEDIATE here,
* otherwise coroutines won't work.
*/
result = ObjectDispatch(clientData, interp, objc, objv, 0u);
} else {
result = DispatchDefaultMethod(interp, (NsfObject *)clientData, objv[0], NSF_CSC_IMMEDIATE);
}
return result;
}
/*
* Proc-Creation
*/
/*
*----------------------------------------------------------------------
* AddPrefixToBody --
*
* Create a fresh TclObj* containing the body with a potential prefix.
* The caller has to decrement the ref-count on this Tcl_Obj*.
*
* Results:
* Tcl_Obj
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj * AddPrefixToBody(Tcl_Obj *body, bool useParamDefs, NsfParsedParam *paramPtr)
nonnull(1) nonnull(3);
static Tcl_Obj *
AddPrefixToBody(Tcl_Obj *body, bool useParamDefs, NsfParsedParam *paramPtr) {
Tcl_Obj *resultBody = Tcl_NewObj();
nonnull_assert(body != NULL);
nonnull_assert(paramPtr != NULL);
INCR_REF_COUNT2("resultBody", resultBody);
if (useParamDefs && paramPtr->possibleUnknowns > 0) {
Tcl_AppendStringsToObj(resultBody, "::nsf::__unset_unknown_args\n", (char *) NULL);
}
Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL);
return resultBody;
}
/*
*----------------------------------------------------------------------
* NoMetaChars --
*
* Check, of the provided string contains meta characters
* (i.e. "*", "?", or "[")
*
* Results:
* Boolean value
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static bool NoMetaChars(const char *pattern)
nonnull(1) NSF_pure;
NSF_INLINE static bool
NoMetaChars(const char *pattern) {
register char c;
bool result = NSF_TRUE;
nonnull_assert(pattern != NULL);
for (c = *pattern; c; c = *++pattern) {
if (c == '*' || c == '?' || c == '[') {
result = NSF_FALSE;
break;
}
}
return result;
}
/***********************************************************************
* Nsf_TypeConverter
***********************************************************************/
/*
*----------------------------------------------------------------------
* Nsf_ConvertToString --
*
* Minimal Nsf_TypeConverter setting the client data (passed to C
* functions) to the ObjStr of the object.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToString(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(2) nonnull(4);
int
Nsf_ConvertToString(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
nonnull_assert(objPtr != NULL);
nonnull_assert(clientData != NULL);
*clientData = (char *)ObjStr(objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* ConvertToNothing --
*
* Minimalistic Nsf_TypeConverter, even setting the client data (passed to
* C functions).
*
* Results:
* Tcl result code, **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ConvertToNothing(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
ClientData *UNUSED(clientData), Tcl_Obj **outObjPtr)
nonnull(2) nonnull(5) NSF_pure;
static int
ConvertToNothing(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
ClientData *UNUSED(clientData), Tcl_Obj **outObjPtr) {
nonnull_assert(objPtr != NULL);
nonnull_assert(outObjPtr != NULL);
assert(*outObjPtr == objPtr);
*outObjPtr = objPtr;
return TCL_OK;
}
#ifdef NSF_WITH_TCL_OBJ_TYPES_AS_CONVERTER
int Nsf_ConvertToTclObjType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
int
Nsf_ConvertToTclObjType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr) {
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
if (unlikely(pPtr->converterArg != NULL)) {
const Tcl_ObjType *tclObjType = pPtr->converterArg->internalRep.twoPtrValue.ptr1;
if (tclObjType != NULL) {
result = Tcl_ConvertToType(interp, objPtr, tclObjType);
if (result != TCL_OK) {
Tcl_ResetResult(interp);
result = NsfObjErrType(interp, NULL, objPtr, tclObjType->name, (Nsf_Param *)pPtr);
}
}
}
*outObjPtr = objPtr;
/*
nsf::proc foo {a:ns:mem_unit} {return $a}
nsf::proc bar {a:ns:mem_unit} {return [expr {$a + 1}]}
foo 1kB
foo xxx
bar 1kB
*/
return result;
}
#endif
/*
*----------------------------------------------------------------------
* Nsf_ConvertToTclobj --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* passed Tcl_Obj. Optionally this converter checks if the Tcl_Obj has
* permissible content via the Tcl "string is" checkers.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
enum stringTypeIdx {StringTypeAlnum, StringTypeAlpha, StringTypeAscii, StringTypeBoolean, StringTypeControl,
StringTypeDigit, StringTypeDouble, StringTypeFalse, StringTypeGraph, StringTypeInteger,
StringTypeLower, StringTypePrint, StringTypePunct, StringTypeSpace, StringTypeTrue,
StringTypeUpper, StringTypeWideinteger, StringTypeWordchar, StringTypeXdigit };
static const char *stringTypeOpts[] = {"alnum", "alpha", "ascii", "boolean", "control",
"digit", "double", "false", "graph", "integer",
"lower", "print", "punct", "space", "true",
"upper", "wideinteger", "wordchar", "xdigit",
NULL};
int Nsf_ConvertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
int
Nsf_ConvertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
if (unlikely(pPtr->converterArg != NULL)) {
/*
* Using "string is ..." as value checker.
*/
Tcl_Obj *objv[4], *resultObj;
/* fprintf(stderr, "ConvertToTclobj %s (must be %s)\n", ObjStr(objPtr), ObjStr(pPtr->converterArg));*/
resultObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultObj);
objv[0] = NULL;
objv[1] = pPtr->converterArg;
objv[2] = NsfGlobalObjs[NSF_OPTION_STRICT];
objv[3] = objPtr;
result = NsfCallCommand(interp, NSF_STRING_IS, 4, objv);
if (likely(result == TCL_OK)) {
int success;
Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &success);
if (success == 1) {
*clientData = objPtr;
/*
* Restore the original result, which was clobbered by the "string is"
* command. Restoring is necessary in cases, where this function is
* used as result value function of a method.
*/
Tcl_SetObjResult(interp, resultObj);
} else {
Tcl_ResetResult(interp);
result = NsfObjErrType(interp, NULL, objPtr, ObjStr(pPtr->converterArg), (Nsf_Param *)pPtr);
}
}
Tcl_DecrRefCount(resultObj);
} else {
result = TCL_OK;
#if defined(NSF_WITH_VALUE_WARNINGS)
if (RUNTIME_STATE(interp)->logSeverity == NSF_LOG_DEBUG) {
const char *value = ObjStr(objPtr);
if (unlikely(*value == '-'
&& (pPtr->flags & NSF_ARG_CHECK_NONPOS) != 0u
&& CHARTYPE(alpha, (*(value+1))) != 0
&& strchr(value+1, ' ') == NULL)
) {
/*
* In order to flag a warning, we set the error message and
* return TCL_CONTINUE
*/
(void)NsfPrintError(interp, "value '%s' of parameter '%s' could be a non-positional argument",
value, pPtr->name);
result = TCL_CONTINUE;
}
}
#endif
*clientData = objPtr;
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToBoolean --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* internal representation of a boolean. This converter checks the passed
* value via Tcl_GetBooleanFromObj().
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
int
Nsf_ConvertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result, boolVal;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
result = Tcl_GetBooleanFromObj(interp, objPtr, &boolVal);
if (likely(result == TCL_OK)) {
*clientData = (ClientData)INT2PTR(boolVal);
} else {
Tcl_ResetResult(interp);
NsfObjErrType(interp, NULL, objPtr, "boolean", pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToInt32 --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* internal representation of an integer. This converter checks the passed
* value via Tcl_GetIntFromObj().
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToInt32(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
Nsf_ConvertToInt32(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result, i;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
result = Tcl_GetIntFromObj(interp, objPtr, &i);
if (likely(result == TCL_OK)) {
*clientData = (ClientData)INT2PTR(i);
} else {
Tcl_ResetResult(interp);
NsfObjErrType(interp, NULL, objPtr, "int32", (Nsf_Param *)pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToInteger --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* Tcl_Obj containing the bignum value. This converter checks the passed
* value via Tcl_GetBignumFromObj().
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#if TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
/*
* Starting with Tcl 8.7a4 and TIP 538, NSF might end up built against Tcl
* linking against a system-wide/ external libtommath, rather than with an
* embedded libtommath. In both cases, even the embedded one, Tcl does not
* ship tommat.h anymore. This leaves NSF without the necessary build-time
* definitions for mp_int and mp_clear (see below). For the time being, we
* rely on a hot fix by the TIP 538 author, providing compat definitions when
* setting the TCL_NO_TOMMATH_H macro before including tclTomMath.h.
*
* See https://core.tcl-lang.org/tcl/tktview?name=4663e0636f (also for other
* mid-term options)
*/
//#define TCL_NO_TOMMATH_H 1
# ifndef MP_INT_DECLARED
typedef size_t mp_int[4];
# endif
#else
# include
#endif
int Nsf_ConvertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
int
Nsf_ConvertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
/*
* Short-cut common cases to avoid conversion to bignums, since
* Tcl_GetBignumFromObj returns a value, which has to be freed.
*/
if (objPtr->typePtr == Nsf_OT_intType || objPtr->typePtr == Nsf_OT_bignumType) {
/*
* We know already that the value is an int
*/
result = TCL_OK;
} else if ((objPtr->typePtr == NULL && objPtr->length < 1) || (objPtr->typePtr == Nsf_OT_doubleType)) {
/*
* We know that the value is not an integer
*/
result = TCL_ERROR;
} else {
long longValue;
Tcl_WideInt wideIntValue;
mp_int bignumValue;
/*
* We have to figure out, whether the value is an int. We perform this
* test via Tcl_GetBignumFromObj(), which tries to keep the type small if
* possible (e.g. it might return type "int" or "float" when appropriate.
*/
/*if (objPtr->typePtr != NULL) {
fprintf(stderr, "### type is on call %p %s value %s \n",
(void*)objPtr->typePtr, ObjTypeStr(objPtr), ObjStr(objPtr));
}*/
if ((result = Tcl_GetLongFromObj(interp, objPtr, &longValue)) == TCL_OK) {
} else if ((result = Tcl_GetWideIntFromObj(interp, objPtr, &wideIntValue)) == TCL_OK) {
} else if ((result = Tcl_GetBignumFromObj(interp, objPtr, &bignumValue)) == TCL_OK) {
Tcl_Obj *bigNumObj = Tcl_NewBignumObj(&bignumValue);
Tcl_DecrRefCount(bigNumObj);
/* fprintf(stderr, "### IS BIG %s\n", objPtr->typePtr->name); */
}
}
if (likely(result == TCL_OK)) {
*clientData = (ClientData)objPtr;
} else {
Tcl_ResetResult(interp);
NsfObjErrType(interp, NULL, objPtr, "integer", (Nsf_Param *)pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToSwitch --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* internal representation of an Boolean. This converter simply calls
* Tcl_ConvertToBoolean(). The distinction between "switch" and boolean is
* made on the semantics of which arguments/defaults are passed to the real
* converter.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
int
Nsf_ConvertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr) {
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
nonnull_assert(outObjPtr != NULL);
return Nsf_ConvertToBoolean(interp, objPtr, pPtr, clientData, outObjPtr);
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToObject --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* internal representation of an object. This converter checks the passed
* value via IsObjectOfType().
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
Nsf_ConvertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
if (likely(GetObjectFromObj(interp, objPtr, (NsfObject **)clientData) == TCL_OK)) {
result = IsObjectOfType(interp, (NsfObject *)*clientData, "object", objPtr, pPtr);
} else {
result = NsfObjErrType(interp, NULL, objPtr, "object", (Nsf_Param *)pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToClass --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* internal representation of a class. This converter checks the passed
* value via IsObjectOfType().
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
Nsf_ConvertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
bool withUnknown;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
withUnknown = (RUNTIME_STATE(interp)->doClassConverterOmitUnknown == 0);
if (likely(GetClassFromObj(interp, objPtr, (NsfClass **)clientData, withUnknown) == TCL_OK)) {
result = IsObjectOfType(interp, (NsfObject *)*clientData, "class", objPtr, pPtr);
} else {
result = NsfObjErrType(interp, NULL, objPtr, "class", (Nsf_Param *)pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToFilterreg --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* Tcl_Obj. This nsf type converter checks the passed value via the
* NsfFilterregObjType tcl_obj converter, which provides an internal
* representation for the client function.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToFilterreg(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
Nsf_ConvertToFilterreg(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
result = Tcl_ConvertToType(interp, objPtr, &NsfFilterregObjType);
if (likely(result == TCL_OK)) {
*clientData = objPtr;
} else {
result = NsfObjErrType(interp, NULL, objPtr, "filterreg", (Nsf_Param *)pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToMixinreg --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* Tcl_Obj. This nsf type converter checks the passed value via the
* NsfMixinregObjType tcl_obj converter, which provides an internal
* representation for the client function.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToMixinreg(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
Nsf_ConvertToMixinreg(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
result = Tcl_ConvertToType(interp, objPtr, &NsfMixinregObjType);
if (likely(result == TCL_OK)) {
*clientData = objPtr;
} else {
result = NsfObjErrType(interp, NULL, objPtr, "mixinreg", (Nsf_Param *)pPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* Nsf_ConvertToParameter --
*
* Nsf_TypeConverter setting the client data (passed to C functions) to the
* Tcl_Obj. This nsf type converter checks if the provided value could be a
* valid parameter spec (i.e. start with no ":", is not an unnamed spec
* "-:int"). This converter performs just a rough syntactic check.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Nsf_ConvertToParameter(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
int
Nsf_ConvertToParameter(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
const char *value;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
value = ObjStr(objPtr);
/*fprintf(stderr, "convert to parameter '%s' t '%s'\n", value, pPtr->type);*/
if (*value == ':' || (*value == '-' && *(value + 1) == ':')) {
result = NsfPrintError(interp, "leading colon in '%s' not allowed in parameter specification '%s'",
ObjStr(objPtr), pPtr->name);
} else {
*clientData = (char *)ObjStr(objPtr);
result = TCL_OK;
}
return result;
}
/*
*----------------------------------------------------------------------
* ConvertViaCmd --
*
* Nsf_TypeConverter calling a used-defined checking/conversion
* function. It sets the client data (passed to C functions) to the
* Tcl_Obj.
*
* Results:
* Tcl result code, *clientData and **outObjPtr
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ConvertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
static int
ConvertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr) {
Tcl_Obj *ov[5], *savedResult;
NsfObject *object;
TCL_OBJC_T oc;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
nonnull_assert(outObjPtr != NULL);
/*
* 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-overwriting just harms for result-converters, but saving is
* always semantically correct.
*/
if (unlikely((pPtr->flags & NSF_ARG_IS_CONVERTER) == 0u)) {
savedResult = Tcl_GetObjResult(interp); /* save the result */
INCR_REF_COUNT(savedResult);
} else {
savedResult = NULL;
}
ov[0] = (pPtr->slotObj != NULL) ? pPtr->slotObj : NsfGlobalObjs[NSF_METHOD_PARAMETER_SLOT_OBJ];
ov[1] = pPtr->converterName;
ov[2] = pPtr->nameObj;
ov[3] = objPtr;
oc = 4;
if (pPtr->converterArg != NULL) {
ov[4] = pPtr->converterArg;
oc++;
}
/*fprintf(stderr, "ConvertViaCmd call converter %s (refCount %d) on %s paramPtr %p arg %p oc %d\n",
ObjStr(pPtr->converterName), pPtr->converterName->refCount, ObjStr(ov[0]),
pPtr, pPtr->converterArg, oc);*/
INCR_REF_COUNT(ov[1]);
INCR_REF_COUNT(ov[2]);
/* result = Tcl_EvalObjv(interp, oc, ov, 0); */
result = GetObjectFromObj(interp, ov[0], &object);
if(likely(result == TCL_OK)) {
result = ObjectDispatch(object, interp, oc, ov, NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
}
DECR_REF_COUNT(ov[1]);
DECR_REF_COUNT(ov[2]);
/*
* Per default, the input arg is the output arg.
*/
assert(*outObjPtr == objPtr);
if (likely(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 & NSF_ARG_IS_CONVERTER);*/
if ((pPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) {
Tcl_Obj *resultObj;
/*
* If we want to convert, the resulting obj is the result of the
* converter. The increment of the refCount is necessary e.g. for
*
* return [expr {$value + 1}]
*
* The conversion is just needed, when resultObj differs from the actual
* value in the output vector. Otherwise the conversion and the value
* increment happened already before (and is already recorded in the
* parse context).
*/
resultObj = Tcl_GetObjResult(interp);
if (*outObjPtr != resultObj) {
INCR_REF_COUNT2("valueObj", resultObj);
*outObjPtr = resultObj;
}
/*fprintf(stderr, "**** NSF_ARG_IS_CONVERTER %p\n", *outObjPtr);*/
}
*clientData = (ClientData) *outObjPtr;
if (savedResult != NULL) {
/*fprintf(stderr, "restore savedResult %p\n", savedResult);*/
Tcl_SetObjResult(interp, savedResult); /* restore the result */
}
}
if (savedResult != NULL) {
DECR_REF_COUNT(savedResult);
}
return result;
}
/*
*----------------------------------------------------------------------
* ConvertToObjpattern --
*
* This function obtains a Tcl_Obj *, which contains the pattern if a Next
* Scripting Object. When this pattern contains no meta characters, we
* check whether the object exists. If it exists, the Tcl_Obj is converted to
* the cmd-type. If it does not exit, the function using this pattern will
* fail. If the pattern contains meta characters, we prepend to the pattern
* "::" if necessary to avoid errors, if one specifies a pattern object
* without the prefix. In this case, the patternObj is of plain type.
* The resulting patternObj has always the refCount incremented, which has
* to be decremented by the caller.x
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Incremented refCount for the patternObj.
*
*----------------------------------------------------------------------
*/
static int ConvertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
ClientData *clientData, Tcl_Obj **outObjPtr)
nonnull(1) nonnull(2) nonnull(4) nonnull(5);
static int
ConvertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
ClientData *clientData, Tcl_Obj **outObjPtr) {
Tcl_Obj *patternObj;
const char *pattern;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(clientData != NULL);
nonnull_assert(outObjPtr != NULL);
patternObj = objPtr;
pattern = ObjStr(objPtr);
if (NoMetaChars(pattern)) {
/*
* We have no meta characters, we try to check for an existing object
*/
NsfObject *object = NULL;
if (GetObjectFromObj(interp, objPtr, &object) == TCL_OK && object != NULL) {
patternObj = object->cmdName;
}
} else {
/*
* We have a pattern and meta characters, we might have
* to prefix it to ovoid obvious 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, TCL_INDEX_NONE, INT_MAX, NULL);
}
}
if (patternObj != NULL) {
INCR_REF_COUNT2("patternObj", patternObj);
}
*clientData = (ClientData)patternObj;
/* The following assert does not hold here, since we
have a direct call to the converter
assert(*outObjPtr == objPtr); */
*outObjPtr = objPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* ParamCheckObj --
*
* This function returns a fresh Tcl_Obj in the form of a method name for a
* checker method.
*
* Results:
* Tcl_Obj
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *ParamCheckObj(const char *start, size_t len)
nonnull(1) returns_nonnull;
static Tcl_Obj *
ParamCheckObj(const char *start, size_t len) {
Tcl_Obj *checker = Tcl_NewStringObj("type=", 5);
nonnull_assert(start != NULL);
Tcl_AppendLimitedToObj(checker, start, (TCL_SIZE_T)len, INT_MAX, NULL);
return checker;
}
/*
*----------------------------------------------------------------------
* ParamOptionSetConverter --
*
* Fill in the fields int to the specified paramPtr structure
* checker method and perform sanity checking.
*
* Results:
* Standard result code
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ParamOptionSetConverter(Tcl_Interp *interp, Nsf_Param *paramPtr,
const char *typeName, Nsf_TypeConverter *converter)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
ParamOptionSetConverter(Tcl_Interp *interp, Nsf_Param *paramPtr,
const char *typeName, Nsf_TypeConverter *converter) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(paramPtr != NULL);
nonnull_assert(typeName != NULL);
nonnull_assert(converter != NULL);
if (paramPtr->converter != NULL) {
result = NsfPrintError(interp, "refuse to redefine parameter type of '%s' from type '%s' to type '%s'",
paramPtr->name, paramPtr->type, typeName);
} else {
paramPtr->converter = converter;
paramPtr->nrArgs = 1;
paramPtr->type = typeName;
result = TCL_OK;
}
return result;
}
/*
*----------------------------------------------------------------------
* Unescape --
*
* Unescape double commas in the provided Tcl_Obj.
*
* Results:
* None.
*
* Side effects:
* Potentially shortened string content
*
*----------------------------------------------------------------------
*/
static void Unescape(Tcl_Obj *objPtr)
nonnull(1);
static void
Unescape(Tcl_Obj *objPtr) {
TCL_SIZE_T i, j, l;
char *string;
nonnull_assert(objPtr != NULL);
l = Tcl_GetCharLength(objPtr);
string = ObjStr(objPtr);
for (i = 0; i < l; i++) {
if (string[i] == ',' && string[i+1] == ',') {
for (j = i+1; j < l; j++) {
string[j] = string[j+1];
}
l--;
i++;
}
}
Tcl_SetObjLength(objPtr, l);
}
/*
*----------------------------------------------------------------------
* ParamOptionParse --
*
* Parse a single parameter option of a parameter. The parameter option
* string is passed in as second argument, the sizes start and remainder
* flag the offsets in the string follow. As a result, the fields of the
* parameter structure are updated.
*
* Results:
* Tcl result code, updated fields in the Nsf_Param structure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ParamOptionParse(Tcl_Interp *interp, const char *argString,
size_t start, size_t optionLength,
unsigned int disallowedOptions, Nsf_Param *paramPtr,
bool unescape, const char *qualifier)
nonnull(1) nonnull(2) nonnull(6);
static int
ParamOptionParse(Tcl_Interp *interp, const char *argString,
size_t start, size_t optionLength,
unsigned int disallowedOptions, Nsf_Param *paramPtr,
bool unescape, const char *qualifier) {
const char *dotdot, *option;
char firstChar;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(argString != NULL);
nonnull_assert(paramPtr != NULL);
option = argString + start;
firstChar = *option;
/*fprintf(stderr, "ParamOptionParse name %s, option '%s' (%ld) disallowed %.6x\n",
paramPtr->name, option, start, disallowedOptions);*/
/*
* Allow user to abbreviate "required", "optional" and "int" to 3 chars.
*/
if (firstChar == 'r' && optionLength <= 8 && strncmp(option, "required", NsfMax(3, optionLength)) == 0) {
paramPtr->flags |= NSF_ARG_REQUIRED;
} else if (firstChar == 'o' && optionLength <= 8 && strncmp(option, "optional", NsfMax(3, optionLength)) == 0) {
paramPtr->flags &= ~NSF_ARG_REQUIRED;
} else if (firstChar == 's'
&& optionLength == 12
&& strncmp(option, "substdefault", 12) == 0
) {
int substDefaultFlags = 0;
char trailingChar = *(option+12);
if (trailingChar == '=') {
if ((Tcl_GetInt(interp, option + 13, &substDefaultFlags) != TCL_OK)
|| (substDefaultFlags < 0) || (substDefaultFlags > 7)) {
return NsfPrintError(interp,
"parameter option 'substdefault=' must be a value between 0b000 and 0b111: %s",
option);
}
} else if (trailingChar == '\0' || trailingChar == ',') {
substDefaultFlags = 7;
} else {
return NsfPrintError(interp, "unexpected character %c (%d) after 'substdefault'", trailingChar, trailingChar);
}
paramPtr->flags |= NSF_ARG_SUBST_DEFAULT;
paramPtr->flags |= ((unsigned int)substDefaultFlags << 28);
} else if (firstChar == 'c' && optionLength == 7 && strncmp(option, "convert", 7) == 0) {
paramPtr->flags |= NSF_ARG_IS_CONVERTER;
} else if (firstChar == 'i' && optionLength == 7 && strncmp(option, "initcmd", 7) == 0) {
if (unlikely((paramPtr->flags & (NSF_ARG_CMD|NSF_ARG_ALIAS|NSF_ARG_FORWARD)) != 0u)) {
return NsfPrintError(interp, "parameter option 'initcmd' not valid in this option combination");
}
paramPtr->flags |= NSF_ARG_INITCMD;
} else if (firstChar == 'c' && optionLength == 3 && strncmp(option, "cmd", 3) == 0) {
if (unlikely((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_ALIAS|NSF_ARG_FORWARD)) != 0u)) {
return NsfPrintError(interp, "parameter option 'cmd' not valid in this option combination");
}
paramPtr->flags |= NSF_ARG_CMD;
} else if (firstChar == 'a' && optionLength == 5 && strncmp(option, "alias", 5) == 0) {
if (unlikely((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_CMD|NSF_ARG_FORWARD)) != 0u)) {
return NsfPrintError(interp, "parameter option 'alias' not valid in this option combination");
}
paramPtr->flags |= NSF_ARG_ALIAS;
} else if (firstChar == 'f' && optionLength == 7 && strncmp(option, "forward", 7) == 0) {
if (unlikely((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_CMD|NSF_ARG_ALIAS)) != 0u)) {
return NsfPrintError(interp, "parameter option 'forward' not valid in this option combination");
}
paramPtr->flags |= NSF_ARG_FORWARD;
} else if (firstChar == 's' && optionLength == 7 && strncmp(option, "slotset", 7) == 0) {
if (unlikely(paramPtr->slotObj == NULL)) {
return NsfPrintError(interp, "parameter option 'slotset' must follow 'slot='");
}
paramPtr->flags |= NSF_ARG_SLOTSET;
} else if (firstChar == 's' && optionLength == 14 && strncmp(option, "slotinitialize", 14) == 0) {
if (unlikely(paramPtr->slotObj == NULL)) {
return NsfPrintError(interp, "parameter option 'slotinit' must follow 'slot='");
}
paramPtr->flags |= NSF_ARG_SLOTINITIALIZE;
} else if ((dotdot = strnstr(option, "..", optionLength-1))) {
/*
* Check lower bound.
*/
if (*option == '0') {
paramPtr->flags |= NSF_ARG_ALLOW_EMPTY;
} else if (unlikely(*option != '1')) {
return NsfPrintError(interp, "lower bound of multiplicity in %s not supported", argString);
}
/*
* Check upper bound.
*/
option = dotdot + 2;
if (*option == '*' || *option == 'n') {
if (unlikely((paramPtr->flags & (NSF_ARG_SWITCH)) != 0u)) {
return NsfPrintError(interp,
"upper bound of multiplicity of '%c' not allowed for \"switch\"\n", *option);
}
paramPtr->flags |= NSF_ARG_MULTIVALUED;
} else if (*option != '1') {
return NsfPrintError(interp, "upper bound of multiplicity in %s not supported", argString);
}
} else if (firstChar == 'n' && optionLength == 5 && strncmp(option, "noarg", 5) == 0) {
if ((paramPtr->flags & NSF_ARG_ALIAS) == 0u) {
return NsfPrintError(interp, "parameter option \"noarg\" only allowed for parameter type \"alias\"");
}
paramPtr->flags |= NSF_ARG_NOARG;
paramPtr->nrArgs = 0;
} else if (firstChar == 'n' && optionLength == 11 && strncmp(option, "nodashalnum", 11) == 0) {
if (*paramPtr->name == '-') {
return NsfPrintError(interp, "parameter option 'nodashalnum' only allowed for positional parameters");
}
paramPtr->flags |= NSF_ARG_NODASHALNUM;
} else if (firstChar == 'n' && optionLength == 8 && strncmp(option, "noconfig", 8) == 0) {
if (disallowedOptions != NSF_DISALLOWED_ARG_OBJECT_PARAMETER) {
return NsfPrintError(interp, "parameter option 'noconfig' only allowed for object parameters");
}
paramPtr->flags |= NSF_ARG_NOCONFIG;
} else if (firstChar == 'a' && optionLength == 4 && strncmp(option, "args", 4) == 0) {
if ((paramPtr->flags & NSF_ARG_ALIAS) == 0u) {
return NsfPrintError(interp, "parameter option \"args\" only allowed for parameter type \"alias\"");
}
result = ParamOptionSetConverter(interp, paramPtr, "args", ConvertToNothing);
} else if (firstChar == 'a' && optionLength >= 4 && strncmp(option, "arg=", 4) == 0) {
if (paramPtr->converter != ConvertViaCmd) {
return NsfPrintError(interp,
"parameter option 'arg=' only allowed for user-defined converter");
}
if (paramPtr->converterArg != NULL) {
DECR_REF_COUNT(paramPtr->converterArg);
}
paramPtr->converterArg = Tcl_NewStringObj(option + 4, (TCL_SIZE_T)optionLength - 4);
/*
* In case, we know that we have to unescape double commas, do it here...
*/
if (unlikely(unescape)) {
Unescape(paramPtr->converterArg);
}
INCR_REF_COUNT(paramPtr->converterArg);
} else if (firstChar == 's' && optionLength == 6 && strncmp(option, "switch", 6) == 0) {
if (*paramPtr->name != '-') {
return NsfPrintError(interp,
"invalid parameter type \"switch\" for argument \"%s\"; "
"type \"switch\" only allowed for non-positional arguments",
paramPtr->name);
} else if ((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) != 0u) {
return NsfPrintError(interp, "parameter invocation types cannot be used with option 'switch'");
}
result = ParamOptionSetConverter(interp, paramPtr, "switch", Nsf_ConvertToSwitch);
paramPtr->flags |= NSF_ARG_SWITCH;
paramPtr->nrArgs = 0;
assert(paramPtr->defaultValue == NULL);
paramPtr->defaultValue = Tcl_NewBooleanObj(0);
INCR_REF_COUNT(paramPtr->defaultValue);
} else if (firstChar == 'i' && optionLength <= 7 && strncmp(option, "integer", NsfMax(3, optionLength)) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "integer", Nsf_ConvertToInteger);
} else if (firstChar == 'i' && optionLength == 5 && strncmp(option, "int32", 5) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "int32", Nsf_ConvertToInt32);
} else if (firstChar == 'b' && optionLength == 7 && strncmp(option, "boolean", 7) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "boolean", Nsf_ConvertToBoolean);
} else if (firstChar == 'o' && optionLength == 6 && strncmp(option, "object", 6) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "object", Nsf_ConvertToObject);
} else if (firstChar == 'c' && optionLength == 5 && strncmp(option, "class", 5) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "class", Nsf_ConvertToClass);
} else if (firstChar == 'm' && optionLength == 9 && strncmp(option, "metaclass", 9) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "class", Nsf_ConvertToClass);
paramPtr->flags |= NSF_ARG_METACLASS;
} else if (firstChar == 'b' && optionLength == 9 && strncmp(option, "baseclass", 9) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "class", Nsf_ConvertToClass);
paramPtr->flags |= NSF_ARG_BASECLASS;
} else if (firstChar == 'm' && optionLength == 8 && strncmp(option, "mixinreg", 8) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "mixinreg", Nsf_ConvertToMixinreg);
} else if (firstChar == 'f' && optionLength == 9 && strncmp(option, "filterreg", 9) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "filterreg", Nsf_ConvertToFilterreg);
} else if (firstChar == 'p' && optionLength == 9 && strncmp(option, "parameter", 9) == 0) {
result = ParamOptionSetConverter(interp, paramPtr, "parameter", Nsf_ConvertToParameter);
} else if (firstChar == 't' && optionLength >= 6 && strncmp(option, "type=", 5) == 0) {
const char* typeValue = option + 5;
TCL_SIZE_T typeValueLength = (TCL_SIZE_T)optionLength - 5;
if (paramPtr->converter != Nsf_ConvertToObject
&& paramPtr->converter != Nsf_ConvertToClass ) {
return NsfPrintError(interp, "parameter option 'type=' only allowed for parameter types 'object' and 'class'");
}
if (paramPtr->converterArg != NULL) {
DECR_REF_COUNT(paramPtr->converterArg);
}
if (qualifier != NULL && !isAbsolutePath(typeValue) &&
isAbsolutePath(qualifier)) {
Tcl_DString ds, *dsPtr = &ds;
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, qualifier, TCL_INDEX_NONE);
if (Tcl_DStringLength(dsPtr) > 2) {
Tcl_DStringAppend(dsPtr, "::", 2);
}
Tcl_DStringAppend(dsPtr, typeValue, typeValueLength);
paramPtr->converterArg = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
Tcl_DStringFree(dsPtr);
} else {
paramPtr->converterArg = Tcl_NewStringObj(typeValue, typeValueLength);
}
if (unlikely(unescape)) {
Unescape(paramPtr->converterArg);
}
INCR_REF_COUNT(paramPtr->converterArg);
} else if (firstChar == 's' && optionLength >= 6 && strncmp(option, "slot=", 5) == 0) {
if (paramPtr->slotObj != NULL) {
DECR_REF_COUNT(paramPtr->slotObj);
}
paramPtr->slotObj = Tcl_NewStringObj(option + 5, (TCL_SIZE_T)optionLength - 5);
if (unlikely(unescape)) {
Unescape(paramPtr->slotObj);
}
INCR_REF_COUNT(paramPtr->slotObj);
} else if (firstChar == 'm' && optionLength >= 6 && strncmp(option, "method=", 7) == 0) {
if ((paramPtr->flags & (NSF_ARG_ALIAS|NSF_ARG_FORWARD|NSF_ARG_SLOTSET)) == 0u) {
return NsfPrintError(interp, "parameter option 'method=' only allowed for parameter "
"types 'alias', 'forward' and 'slotset'");
}
if (paramPtr->method != NULL) {
DECR_REF_COUNT(paramPtr->method);
}
paramPtr->method = Tcl_NewStringObj(option + 7, (TCL_SIZE_T)optionLength - 7);
if (unlikely(unescape)) {
Unescape(paramPtr->method);
}
INCR_REF_COUNT(paramPtr->method);
} else if ((firstChar == 'v') &&
((strncmp(option, "virtualobjectargs", 17) == 0) ||
(strncmp(option, "virtualclassargs", 16) == 0))) {
result = ParamOptionSetConverter(interp, paramPtr, option, ConvertToNothing);
} else {
Tcl_DString ds, *dsPtr = &ds;
#ifdef NSF_WITH_TCL_OBJ_TYPES_AS_CONVERTER
const Tcl_ObjType *tclObjType;
#endif
if (option[0] == '\0') {
NsfLog(interp, NSF_LOG_WARN, "empty parameter option ignored");
return TCL_OK;
}
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, option, (TCL_SIZE_T)optionLength);
if (unlikely(paramPtr->converter != NULL)) {
NsfPrintError(interp, "parameter option '%s' unknown for parameter type '%s'",
Tcl_DStringValue(dsPtr), paramPtr->type);
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
}
/*fprintf(stderr, "HAVE TYPE converter for <%s> ?\n", option);*/
if (Nsf_PointerTypeLookup(Tcl_DStringValue(dsPtr))) {
/*
* Check whether the option refers to a pointer converter.
*/
ParamOptionSetConverter(interp, paramPtr, Tcl_DStringValue(dsPtr), Nsf_ConvertToPointer);
Tcl_DStringFree(dsPtr);
#ifdef NSF_WITH_TCL_OBJ_TYPES_AS_CONVERTER
} else if ((tclObjType = Tcl_GetObjType(option)) != NULL) {
/*fprintf(stderr, "SET TYPE converter for <%s>\n", option);*/
result = ParamOptionSetConverter(interp, paramPtr, Tcl_DStringValue(dsPtr), Nsf_ConvertToTclObjType);
if (paramPtr->converterArg != NULL) {
DECR_REF_COUNT(paramPtr->converterArg);
}
paramPtr->converterArg = Tcl_NewObj();
paramPtr->converterArg->internalRep.twoPtrValue.ptr1 = (void *)tclObjType;
INCR_REF_COUNT(paramPtr->converterArg);
#endif
} else {
int i, found = -1;
/*
* The option is still unknown, check the Tcl string-is checkers
*/
Tcl_DStringFree(dsPtr);
for (i = 0; stringTypeOpts[i]; i++) {
/*
* Do not allow abbreviations, so the additional strlen() checks
* for a full match.
*/
if (strncmp(option, stringTypeOpts[i], optionLength) == 0
&& strlen(stringTypeOpts[i]) == optionLength) {
found = i;
break;
}
}
if (found > -1) {
/*
* Converter is stringType.
*/
result = ParamOptionSetConverter(interp, paramPtr, "stringtype", Nsf_ConvertToTclobj);
if (paramPtr->converterArg != NULL) {
DECR_REF_COUNT(paramPtr->converterArg);
}
paramPtr->converterArg = Tcl_NewStringObj(stringTypeOpts[i], TCL_INDEX_NONE);
INCR_REF_COUNT(paramPtr->converterArg);
} else {
/*
* The parameter option is still unknown. We assume that the parameter
* option identifies a user-defined argument checker, implemented as a
* method.
*/
if (paramPtr->converterName != NULL) {
DECR_REF_COUNT2("converterNameObj", paramPtr->converterName);
}
paramPtr->converterName = ParamCheckObj(option, optionLength);
INCR_REF_COUNT2("converterNameObj", paramPtr->converterName);
result = ParamOptionSetConverter(interp, paramPtr, ObjStr(paramPtr->converterName), ConvertViaCmd);
}
}
}
if ((paramPtr->flags & disallowedOptions) != 0u) {
return NsfPrintError(interp, "parameter option '%s' not allowed", option);
}
if (unlikely(((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) != 0u)
&& ((paramPtr->flags & NSF_ARG_NOCONFIG)) != 0u)) {
return NsfPrintError(interp, "parameter option 'noconfig' cannot used together with this type of object parameter");
}
return result;
}
/*
*----------------------------------------------------------------------
* ParamDefinitionParse --
*
* Parse a single parameter definition with a possible default provided in
* the form of a Tcl_Obj.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ParamDefinitionParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *arg,
unsigned int disallowedFlags,
Nsf_Param *paramPtr, int *possibleUnknowns,
TCL_SIZE_T *plainParams,
int *nrNonposArgs, const char *qualifier)
nonnull(1) nonnull(3) nonnull(5) nonnull(6) nonnull(7) nonnull(8);
static int
ParamDefinitionParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *arg, unsigned int disallowedFlags,
Nsf_Param *paramPtr, int *possibleUnknowns,
TCL_SIZE_T *plainParams,
int *nrNonposArgs, const char *qualifier) {
const char *argString, *argName;
int result, isNonposArgument, parensCount;
TCL_SIZE_T npac;
size_t length, j;
Tcl_Obj **npav;
nonnull_assert(interp != NULL);
nonnull_assert(arg != NULL);
nonnull_assert(paramPtr != NULL);
nonnull_assert(possibleUnknowns != NULL);
nonnull_assert(plainParams != NULL);
nonnull_assert(nrNonposArgs != NULL);
paramPtr->paramObj = arg;
INCR_REF_COUNT(paramPtr->paramObj);
result = Tcl_ListObjGetElements(interp, paramPtr->paramObj, &npac, &npav);
if (unlikely(result != TCL_OK || npac < 1 || npac > 2)) {
if (procNameObj != NULL) {
result = NsfPrintError(interp,
"wrong # of elements in parameter definition "
"of method '%s'. "
"Should be a list of 1 or 2 elements, but got: '$s'",
ObjStr(procNameObj), ObjStr(paramPtr->paramObj));
} else {
result = NsfPrintError(interp,
"wrong # of elements in parameter definition. "
"Should be a list of 1 or 2 elements, but got: '%s'",
ObjStr(paramPtr->paramObj));
}
DECR_REF_COUNT(paramPtr->paramObj);
return result;
}
argString = ObjStr(npav[0]);
length = strlen(argString);
/*
For whatever reason, the snippet above seems to be faster than:
argString = Tcl_GetStringFromObj(npav[0], &result);
length = (size_t) result;
*/
/*
* Per default parameter have exactly one argument; types without arguments
* (like "switch") have to set their nrArgs explicitly.
*/
paramPtr->nrArgs = 1;
isNonposArgument = *argString == '-';
if (isNonposArgument != 0) {
argName = argString+1;
(*nrNonposArgs) ++;
} else {
argName = argString;
paramPtr->flags |= NSF_ARG_REQUIRED; /* positional arguments are required unless we have a default */
}
/*fprintf(stderr, "... parsing '%s', name '%s' argString '%s' \n",
ObjStr(arg), argName, argString);*/
/*
* Find the first ':' outside of parens; the name of the parameter might be
* in array syntax, the array index might contain ":", "," etc.
*/
parensCount = 0;
for (j = 0; j < length; j++) {
if (parensCount > 0 && argString[j] == ')') {
parensCount --;
continue;
}
if (argString[j] == '(') {
parensCount ++;
continue;
}
if (parensCount == 0 && argString[j] == ':') {
break;
}
}
if (argString[j] == ':') {
/*
* We found a ':'
*/
size_t l, start, end;
bool unescape = NSF_FALSE;
/*
* Get parameter name
*/
STRING_NEW(paramPtr->name, argString, j);
paramPtr->nameObj = Tcl_NewStringObj(argName, (isNonposArgument != 0) ? (TCL_SIZE_T)j-1 : (TCL_SIZE_T)j);
INCR_REF_COUNT(paramPtr->nameObj);
/*
* Skip space at begin
*/
for (start = j+1; start 0 && CHARTYPE(space, argString[end-1]) != 0; end--) {
;
}
result = ParamOptionParse(interp, argString, start, end-start, disallowedFlags, paramPtr, unescape,
qualifier);
unescape = NSF_FALSE;
if (unlikely(result != TCL_OK)) {
goto param_error;
}
l++;
/*
* Skip space from begin.
*/
for (start = l; start 0 && CHARTYPE(space, argString[end-1]) != 0; end--) {
;
}
/*
* process last option
*/
if (end-start > 0) {
result = ParamOptionParse(interp, argString, start, end-start, disallowedFlags, paramPtr, unescape,
qualifier);
if (unlikely(result != TCL_OK)) {
goto param_error;
}
}
} else {
/*
* No ':', the whole arg is the name, we have no options
*/
STRING_NEW(paramPtr->name, argString, length);
if (isNonposArgument != 0) {
paramPtr->nameObj = Tcl_NewStringObj(argName, (TCL_SIZE_T)length-1);
} else {
(*plainParams) ++;
paramPtr->nameObj = Tcl_NewStringObj(argName, (TCL_SIZE_T)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 & NSF_ARG_HAS_DEFAULT) != 0u) {
NsfPrintError(interp, "parameter specification for \"%s\" is not allowed to have default \"%s\"",
argString, ObjStr(npav[1]));
goto param_error;
}
/*
* If we have for some reason already a default value, free it
*/
if (paramPtr->defaultValue != NULL) {
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 &= ~NSF_ARG_REQUIRED;
} else if ((paramPtr->flags & NSF_ARG_SUBST_DEFAULT) != 0u) {
NsfPrintError(interp,
"parameter option substdefault specified for parameter \"%s\""
" without default value", paramPtr->name);
goto param_error;
}
/*
* Postprocessing the parameter options
*/
if (paramPtr->converter == NULL) {
/*
* If no converter is set, use the default converter
*/
paramPtr->converter = Nsf_ConvertToTclobj;
} else if (
paramPtr->converter == ConvertToNothing
&& (paramPtr->flags & (NSF_ARG_ALLOW_EMPTY|NSF_ARG_MULTIVALUED)) != 0u
) {
NsfPrintError(interp,
"multiplicity settings for variable argument parameter \"%s\" not allowed",
paramPtr->name);
goto param_error;
}
/*
* Check for application specific value checkers and converters
*/
/*fprintf(stderr, "parameter %s: slotObj %p viaCmd? %d\n",
paramPtr->name, paramPtr->slotObj, paramPtr->converter == ConvertViaCmd);*/
if ((paramPtr->slotObj || paramPtr->converter == ConvertViaCmd) && paramPtr->type) {
const char *converterNameString;
Tcl_Obj *converterNameObj, *slotObj;
NsfObject *paramObject;
Tcl_Command cmd;
NsfClass *paramClass = NULL;
slotObj = (paramPtr->slotObj != NULL) ? paramPtr->slotObj : NsfGlobalObjs[NSF_METHOD_PARAMETER_SLOT_OBJ];
result = GetObjectFromObj(interp, slotObj, ¶mObject);
if (unlikely(result != TCL_OK)) {
NsfPrintError(interp, "non-existing slot object \"%s\"", ObjStr(slotObj));
goto param_error;
}
if (paramPtr->converterName == NULL) {
converterNameObj = ParamCheckObj(paramPtr->type, strlen(paramPtr->type));
INCR_REF_COUNT2("converterNameObj", converterNameObj);
} else {
converterNameObj = paramPtr->converterName;
}
converterNameString = ObjStr(converterNameObj);
cmd = ObjectFindMethod(interp, paramObject, converterNameObj, ¶mClass);
/*fprintf(stderr, "locating %s on %s returns %p (%s)\n",
ObjStr(converterNameObj), ObjectName(paramObject), cmd, ClassName(paramClass));*/
if (cmd == NULL) {
if (paramPtr->converter == ConvertViaCmd) {
NsfLog(interp, NSF_LOG_WARN, "Could not find value checker %s defined on %s",
converterNameString, ObjectName(paramObject));
paramPtr->flags |= NSF_ARG_CURRENTLY_UNKNOWN;
/* TODO: for the time being, we do not return an error here */
}
} else if (paramPtr->converter != ConvertViaCmd &&
paramPtr->slotObj &&
strcmp(ObjStr(paramPtr->slotObj),
NsfGlobalStrings[NSF_METHOD_PARAMETER_SLOT_OBJ]) != 0) {
NsfLog(interp, NSF_LOG_WARN, "Checker method %s defined on %s shadows built-in converter",
converterNameString, ObjectName(paramObject));
if (paramPtr->converterName == NULL) {
paramPtr->converterName = converterNameObj;
paramPtr->converter = NULL;
result = ParamOptionSetConverter(interp, paramPtr, converterNameString, ConvertViaCmd);
if (unlikely(result != TCL_OK)) {
if (converterNameObj != paramPtr->converterName) {
DECR_REF_COUNT2("converterNameObj", converterNameObj);
}
goto param_error;
}
}
}
if (((paramPtr->flags & NSF_ARG_IS_CONVERTER) != 0u)
&& paramPtr->converter != ConvertViaCmd) {
NsfPrintError(interp, "option 'convert' only allowed for application-defined converters");
if (converterNameObj != paramPtr->converterName) {
DECR_REF_COUNT2("converterNameObj", converterNameObj);
}
goto param_error;
}
if (converterNameObj != paramPtr->converterName) {
DECR_REF_COUNT2("converterNameObj", converterNameObj);
}
}
/*
* If the argument has no arguments and it is positional, it can't be
* required.
*/
if (paramPtr->nrArgs == 0
&& *paramPtr->name != '-'
&& (paramPtr->flags & NSF_ARG_REQUIRED) != 0u
) {
paramPtr->flags &= ~NSF_ARG_REQUIRED;
}
/*
* If the argument is not required and no default value is specified, we
* have to handle in the client code (e.g. in the canonical arg handlers for
* scripted methods) the unknown value (e.g. don't set/unset a variable)
*/
if ((paramPtr->flags & NSF_ARG_REQUIRED) == 0u && paramPtr->defaultValue == NULL) {
(*possibleUnknowns)++;
}
return TCL_OK;
param_error:
ParamFree(paramPtr);
paramPtr->name = NULL;
#if !defined(NDEBUG)
/*
* Whenever we return a TCL_ERROR, we expect that the interp result contains
* an error message.
*/
{
const char *errStr = ObjStr(Tcl_GetObjResult(interp));
assert(*errStr != '\0');
}
#endif
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
* ParamDefsParse --
*
* Parse a list of parameters in the form of Tcl_Objs into a
* parsedParamPtr structure (last argument). The argument
* allowedOptions is used to flag, what parameter options are
* generally allowed (typically different for method and object
* parameters). Unless forceParamdefs is set, the parsed parameter
* structure is only returned when needed (i.e. when not all
* parameters are plain parameters).
*
* Results:
* A standard Tcl result, parsedParameter structure in last
* argument (allocated by the caller).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ParamDefsParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *paramSpecObjs,
unsigned int allowedOptions, bool forceParamdefs,
NsfParsedParam *parsedParamPtr, const char *qualifier)
nonnull(1) nonnull(3) nonnull(6);
static int
ParamDefsParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *paramSpecObjs,
unsigned int allowedOptions, bool forceParamdefs, NsfParsedParam *parsedParamPtr,
const char *qualifier) {
Tcl_Obj **argsv;
TCL_SIZE_T argsc;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(paramSpecObjs != NULL);
nonnull_assert(parsedParamPtr != NULL);
parsedParamPtr->paramDefs = NULL;
parsedParamPtr->possibleUnknowns = 0;
result = Tcl_ListObjGetElements(interp, paramSpecObjs, &argsc, &argsv);
if (unlikely(result != TCL_OK)) {
return NsfPrintError(interp, "cannot break down non-positional args: %s", ObjStr(paramSpecObjs));
}
if (argsc > 0) {
Nsf_Param *paramsPtr, *paramPtr, *lastParamPtr;
int possibleUnknowns = 0, nrNonposArgs = 0;
TCL_SIZE_T i, plainParams = 0;
NsfParamDefs *paramDefs;
paramPtr = paramsPtr = ParamsNew((size_t)argsc);
for (i = 0; i < argsc; i++, paramPtr++) {
result = ParamDefinitionParse(interp, procNameObj, argsv[i], allowedOptions,
paramPtr, &possibleUnknowns, &plainParams, &nrNonposArgs,
qualifier);
if (result == TCL_OK) {
if (paramPtr->converter == ConvertToNothing && i < argsc-1) {
result = NsfPrintError(interp,
"parameter option \"args\" invalid for parameter \"%s\"; only allowed for last parameter",
paramPtr->name);
}
/* fprintf(stderr, "qual %s\n", qualifier);
if (qualifier != NULL &&
(paramPtr->converter == Nsf_ConvertToObject ||
paramPtr->converter == Nsf_ConvertToClass) &&
paramPtr->converterArg != NULL) {
fprintf(stderr, "qual %s\n", qualifier);
const char *carg = ObjStr(paramPtr->converterArg);
if (*carg != ':') {
Tcl_Obj *qualifiedConverterArg = Tcl_NewStringObj(qualifier, TCL_INDEX_NONE);
Tcl_AppendToObj(qualifiedConverterArg, "::", 2);
Tcl_AppendObjToObj(qualifiedConverterArg, paramPtr->converterArg);
DECR_REF_COUNT(paramPtr->converterArg);
paramPtr->converterArg = qualifiedConverterArg;
INCR_REF_COUNT(qualifiedConverterArg);
fprintf(stderr, ">>> converterArg %s qualifier %s\n", ObjStr(paramPtr->converterArg), qualifier);
}
}*/
}
if (unlikely(result != TCL_OK)) {
ParamsFree(paramsPtr);
return result;
}
/*
* Every parameter must have at least a name set.
*/
assert(paramPtr->name);
}
#if defined(NSF_WITH_VALUE_WARNINGS)
if (nrNonposArgs > 0 && argsc > 1) {
for (i = 0; i < argsc; i++) {
(paramsPtr + i)->flags |= NSF_ARG_CHECK_NONPOS;
}
}
#endif
/*
* If all arguments are good old Tcl arguments, there is no need
* to use the parameter definition structure, unless we force it.
*/
if (plainParams == argsc && !forceParamdefs) {
ParamsFree(paramsPtr);
return TCL_OK;
}
/*fprintf(stderr, "we need param definition structure for {%s}, argsc %d plain %d\n",
ObjStr(paramSpecObjs), 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 &= ~NSF_ARG_REQUIRED;
}
paramDefs = ParamDefsNew();
paramDefs->paramsPtr = paramsPtr;
paramDefs->nrParams = (TCL_OBJC_T)(paramPtr - paramsPtr);
/*fprintf(stderr, "method %s serial %d paramDefs %p ifsize %ld, possible unknowns = %d,\n",
ObjStr(procNameObj), paramDefs->serial,
paramDefs, paramPtr-paramsPtr, possibleUnknowns);*/
parsedParamPtr->paramDefs = paramDefs;
parsedParamPtr->possibleUnknowns = possibleUnknowns;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* ParameterMethodForwardDispatch --
*
* Dispatch a forwarding method provided via parameter definition.
*
* The current implementation performs for every object
* parameter forward the full cycle of
*
* (a) splitting the spec,
* (b) convert it to the client data structure,
* (c) invoke forward,
* (d) free client data structure
*
* In the future, it should convert to the client data
* structure just once and free it with the disposal of the
* parameter. This could be achieved
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The called function might side-effect.
*
*----------------------------------------------------------------------
*/
static int ParameterMethodForwardDispatch(Tcl_Interp *interp, NsfObject *object,
const Nsf_Param *paramPtr, Tcl_Obj *newValue,
NsfCallStackContent *cscPtr)
nonnull(1) nonnull(2) nonnull(3);
static int
ParameterMethodForwardDispatch(Tcl_Interp *interp, NsfObject *object,
const Nsf_Param *paramPtr, Tcl_Obj *newValue,
NsfCallStackContent *cscPtr) {
Tcl_Obj **nobjv, *ov[3], *methodObj, *forwardSpec;
ForwardCmdClientData *tcd = NULL;
TCL_OBJC_T oc;
TCL_SIZE_T nobjc;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(paramPtr != NULL);
assert((paramPtr->flags & NSF_ARG_FORWARD) != 0u);
forwardSpec = (paramPtr->method != NULL) ? paramPtr->method : NULL; /* different default? */
if (forwardSpec == NULL) {
return NsfPrintError(interp, "forward: no spec available\n");
}
result = Tcl_ListObjGetElements(interp, forwardSpec, &nobjc, &nobjv);
if (unlikely(result != TCL_OK)) {
return result;
}
methodObj = paramPtr->nameObj;
result = ForwardProcessOptions(interp, methodObj,
NULL /*withDefault*/,
0 /*withEarlybinding*/,
NULL /*withOnerror*/,
NULL /*withMethodprefix*/,
0 /*withFrame*/,
NSF_FALSE /*withVerbose*/,
nobjv[0], (TCL_OBJC_T)(nobjc-1), nobjv+1, &tcd);
if (unlikely(result != TCL_OK)) {
if (tcd != NULL) {
ForwardCmdDeleteProc(tcd);
}
return result;
}
/*fprintf(stderr, "parameter %s forward spec <%s> After Options obj %s method %s\n",
ObjStr(paramPtr->nameObj), ObjStr(forwardSpec),
ObjectName(object), ObjStr(methodObj));*/
tcd->object = object;
oc = 1;
ov[0] = methodObj;
if (paramPtr->nrArgs == 1 && newValue) {
ov[oc] = newValue;
oc ++;
}
/*
* Mark the intermittent CSC frame as INACTIVE, so that, e.g.,
* call-stack traversals seeking active frames ignore it.
*/
if (cscPtr != NULL) {
cscPtr->frameType = NSF_CSC_TYPE_INACTIVE;
}
result = NsfForwardMethod(tcd, interp, oc, ov);
ForwardCmdDeleteProc(tcd);
return result;
}
/*
*----------------------------------------------------------------------
* ParameterMethodDispatch --
*
* Dispatch a method provided via parameter definition. The function checks
* the parameter definition, builds an argument list for the function call
* and invokes finally the configured cmd. This function is typically
* called from configure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The called function might side-effect.
*
*----------------------------------------------------------------------
*/
static int ParameterMethodDispatch(
Tcl_Interp *interp, NsfObject *object,
Nsf_Param *paramPtr, Tcl_Obj *newValue,
CallFrame *uplevelVarFramePtr,
const char *initString,
Tcl_Obj **nextObjPtr,
TCL_OBJC_T nrRemainingArgs
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(6) nonnull(7);
static int
ParameterMethodDispatch(
Tcl_Interp *interp, NsfObject *object,
Nsf_Param *paramPtr, Tcl_Obj *newValue,
CallFrame *uplevelVarFramePtr,
const char *initString,
Tcl_Obj **nextObjPtr,
TCL_OBJC_T nrRemainingArgs
) {
CallFrame *varFramePtr;
NsfCallStackContent csc, *cscPtr = &csc;
CallFrame frame2, *framePtr2 = &frame2;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(paramPtr != NULL);
nonnull_assert(newValue != NULL);
nonnull_assert(initString != NULL);
nonnull_assert(nextObjPtr != NULL);
#if 0
{int TCL_OBJC_T;
fprintf(stderr, "ParameterMethodDispatch %s flags %06x nrRemainingArgs %d ",
paramPtr->name, paramPtr->flags, nrRemainingArgs);
for(i = 0; i < nrRemainingArgs; i++) {
fprintf(stderr, " [%d]=%p %s,", i, &nextObjPtr[i], ObjStr(nextObjPtr[i]));
}
fprintf(stderr, "\n");
}
#endif
/*
* The current call-frame of configure uses an obj-frame, 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 a proc body.
* So we push yet another call-frame without providing the
* var-frame.
*
* The new frame will have the namespace of the caller to avoid
* the current obj-frame. Nsf_PushFrameCsc() will establish a
* CMETHOD frame.
*/
varFramePtr = Tcl_Interp_varFramePtr(interp);
Tcl_Interp_varFramePtr(interp) = varFramePtr->callerVarPtr;
cscPtr->flags = 0;
CscInit(cscPtr, object, object->cl /*cl*/, NULL /*cmd*/,
NSF_CSC_TYPE_PLAIN, 0, NsfGlobalStrings[NSF_CONFIGURE]);
Nsf_PushFrameCsc(interp, cscPtr, framePtr2);
if ((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_CMD)) != 0u) {
/* cscPtr->cmdPtr = NSFindCommand(interp, "::eval"); */
result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT);
} else if ((paramPtr->flags & NSF_ARG_ALIAS) != 0u) {
Tcl_Obj *methodObj, **ovPtr, *ov0;
static Tcl_Obj *constantObj = NULL;
const char *methodString;
TCL_SIZE_T oc = 0;
/*
* Restore the variable frame context as found at the original call
* site of configure(). Note that we do not have to revert this
* context change when leaving this configure() context because a
* surrounding [uplevel] will correct the call-stack context for us ...
*/
if (uplevelVarFramePtr != NULL) {
Tcl_Interp_varFramePtr(interp) = uplevelVarFramePtr;
}
/*
* Mark the intermittent CSC frame as INACTIVE, so that, e.g.,
* call-stack traversals seeking active frames ignore it.
*/
cscPtr->frameType = NSF_CSC_TYPE_INACTIVE;
/*
* If parameter option "method=" was given, use it as method name
*/
methodObj = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
methodString = ObjStr(methodObj);
/*fprintf(stderr, "ALIAS %s, nrargs %d converter %p ConvertToNothing %d oc %d\n",
paramPtr->name, paramPtr->nrArgs, paramPtr->converter,
paramPtr->converter == ConvertToNothing,
oc);*/
if (paramPtr->converter == ConvertToNothing) {
/*
* We are using the varargs interface; pass all remaining args into
* the called method.
*/
if (newValue == paramPtr->defaultValue) {
/*
* Use the default.
*/
if (Tcl_ListObjGetElements(interp, paramPtr->defaultValue, &oc, &ovPtr) != TCL_OK) {
goto method_arg_done;
}
ov0 = *ovPtr;
ovPtr ++;
} else {
/*
* Use actual args.
*/
ov0 = *nextObjPtr;
/*fprintf(stderr, "ALIAS use actual args oc %d ov0 <%s> nextObjPtr %p %p\n",
nrRemainingArgs, ObjStr(ov0), nextObjPtr, nextObjPtr+1);*/
ovPtr = nextObjPtr+1;
oc = (TCL_SIZE_T)nrRemainingArgs;
}
} else {
/*
* A simple alias, receives no arg (when noarg was specified) or a
* single argument (which might be the default value).
*/
TCL_SIZE_T moc = 1;
Tcl_Obj **movPtr = NULL;
ov0 = NULL;
ovPtr = &constantObj;
if (Tcl_ListObjGetElements(interp, methodObj, &moc, &movPtr) == TCL_OK) {
if (moc != 2) {
oc = 0;
if (unlikely(moc > 2)) {
NsfLog(interp, NSF_LOG_WARN, "max 2 words are currently allowed in methodName <%s>", methodString);
}
} else {
oc = 1;
methodObj = movPtr[0];
ov0 = movPtr[1];
}
}
if (paramPtr->nrArgs == 1) {
oc++;
if (oc == 1) {
ov0 = newValue;
} else {
ovPtr = &newValue;
}
}
}
/*
* Check whether we have an object parameter alias for the constructor.
* Since we require the object system for the current object to determine
* its object system configuration, we can't do this at parameter compile
* time.
*/
if (*initString == *methodString && strcmp(initString, methodString) == 0) {
result = DispatchInitMethod(interp, object, (TCL_OBJC_T)oc, &ov0, 0u);
} else {
/*fprintf(stderr, "... call alias %s with methodObj %s.%s oc %d, nrArgs %d '%s'\n",
paramPtr->name, ObjectName(object), ObjStr(methodObj), oc,
paramPtr->nrArgs, ObjStr(newValue));*/
#if !defined(NDEBUG)
if (oc > 2) {
assert(ovPtr != NULL);
assert(ovPtr != &constantObj);
assert(ISOBJ(ovPtr[oc-2]));
}
#endif
Tcl_ResetResult(interp);
result = NsfCallMethodWithArgs(interp, (Nsf_Object*)object, methodObj,
ov0, (TCL_OBJC_T)oc, ovPtr,
NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
}
} else {
/*
* must be NSF_ARG_FORWARD
*/
assert((paramPtr->flags & NSF_ARG_FORWARD) != 0u);
result = ParameterMethodForwardDispatch(interp, object,
paramPtr, newValue, cscPtr);
}
method_arg_done:
/*
* Pop previously stacked frame for eval context and set the
* varFramePtr to the previous value.
*/
Nsf_PopFrameCsc(interp, framePtr2);
CscListRemove(interp, cscPtr, NULL);
CscFinish(interp, cscPtr, result, "converter object frame");
Tcl_Interp_varFramePtr(interp) = varFramePtr;
/* fprintf(stderr, "NsfOConfigureMethod_ attribute %s evaluated %s => (%d)\n",
ObjStr(paramPtr->nameObj), ObjStr(newValue), result);*/
if (likely(result == TCL_OK)) {
if ((paramPtr->flags & NSF_ARG_CMD) != 0u
&& RUNTIME_STATE(interp)->doKeepcmds
) {
Tcl_Obj *resultObj;
resultObj = Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_ARRAY_CMD], paramPtr->nameObj, newValue, TCL_LEAVE_ERR_MSG);
if (unlikely(resultObj == NULL)) {
result = TCL_ERROR;
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
* MakeProc --
*
* Define a scripted function via the ObjCmd "proc".
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Defined function or exception.
*
*----------------------------------------------------------------------
*/
static int MakeProc(Tcl_Namespace *nsPtr, NsfAssertionStore *aStore, Tcl_Interp *interp,
Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition,
Tcl_Obj *postcondition, NsfObject *defObject, NsfObject *regObject,
int withPer_object, int withInner_namespace, unsigned int checkAlwaysFlag
) nonnull(1) nonnull(3) nonnull(4) nonnull(5) nonnull(6) nonnull(9);
static int
MakeProc(
Tcl_Namespace *nsPtr, NsfAssertionStore *aStore, Tcl_Interp *interp,
Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition,
Tcl_Obj *postcondition, NsfObject *defObject, NsfObject *regObject,
int withPer_object, int withInner_namespace, unsigned int checkAlwaysFlag
) {
const char *methodName;
NsfParsedParam parsedParam;
Tcl_Obj *ov[4], *fullyQualifiedNameObj;
int result;
nonnull_assert(nsPtr != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(args != NULL);
nonnull_assert(body != NULL);
nonnull_assert(defObject != NULL);
methodName = ObjStr(nameObj);
/*
* Tcl (at least in newer versions) will raise an error in cases, where
* the methodName starts with a colon.
*/
if (regObject == NULL) {
regObject = defObject;
}
/*
* Check whether we are allowed to redefine the method.
*/
result = CanRedefineCmd(interp, nsPtr, defObject, methodName, 0u);
if (likely(result == TCL_OK)) {
/*
* Yes, we can! ...so obtain the method parameter definition.
*/
Tcl_Namespace *nsPtr1 = Tcl_Command_nsPtr(defObject->id);
result = ParamDefsParse(interp, nameObj, args,
NSF_DISALLOWED_ARG_METHOD_PARAMETER, NSF_FALSE,
&parsedParam,
nsPtr1 != NULL ? nsPtr1->fullName : NULL);
} else {
/*
* Strictly speaking, the following assignment is not necessary. However,
* it avoids a false positive from facbook infer.
*/
parsedParam.paramDefs = NULL;
}
if (unlikely(result != TCL_OK)) {
return result;
}
if (isAbsolutePath(methodName)) {
fullyQualifiedNameObj = nameObj;
} else {
fullyQualifiedNameObj = NameInNamespaceObj(methodName, nsPtr);
INCR_REF_COUNT2("fullyQualifiedName", fullyQualifiedNameObj);
}
ov[0] = NULL;
ov[1] = fullyQualifiedNameObj;
if (parsedParam.paramDefs != NULL) {
Nsf_Param *pPtr;
Tcl_Obj *argList = Tcl_NewListObj(0, NULL);
for (pPtr = parsedParam.paramDefs->paramsPtr; pPtr->name != NULL; pPtr++) {
if (*pPtr->name == '-') {
Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name+1, TCL_INDEX_NONE));
} else {
Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name, TCL_INDEX_NONE));
}
}
ov[2] = argList;
INCR_REF_COUNT(ov[2]);
/*fprintf(stderr, "final arglist = <%s>\n", ObjStr(argList)); */
ov[3] = AddPrefixToBody(body, NSF_TRUE, &parsedParam);
} else { /* no parameter handling needed */
ov[2] = args;
ov[3] = AddPrefixToBody(body, NSF_FALSE, &parsedParam);
}
/*
* Check whether the cmd exists already in the namespace. If so, delete it
* from there.
*/
{
Tcl_Command cmdPtr = FindMethod(nsPtr, methodName);
if (cmdPtr != NULL) {
Tcl_DeleteCommandFromToken(interp, cmdPtr);
}
}
/*
* Create the method in the provided namespace.
*/
result = Tcl_ProcObjCmd(NULL, interp, 4, ov);
if (likely(result == TCL_OK)) {
/*
* Retrieve the newly defined proc
*/
Proc *procPtr = FindProcMethod(nsPtr, methodName);
if (procPtr != NULL) {
Namespace *execNsPtr;
if (withInner_namespace == 1) {
/*
* Set the execution namespace to the registration object (e.g. same
* as the class).
*/
if (regObject->nsPtr == NULL) {
MakeObjNamespace(interp, regObject);
}
/*fprintf(stderr, "obj %s\n", ObjectName(defObject));
fprintf(stderr, "ns %p defObject->ns %p\n", nsPtr, defObject->nsPtr);
fprintf(stderr, "ns %s defObject->ns %s\n", nsPtr->fullName, defObject->nsPtr->fullName);
fprintf(stderr, "old %s\n", procPtr->cmdPtr->nsPtr->fullName);*/
execNsPtr = (Namespace *)regObject->nsPtr;
} else {
/*
* Set the execution namespace of the method to the same namespace the
* cmd of the defObject has.
*/
execNsPtr = ((Command *)regObject->id)->nsPtr;
}
ParamDefsStore((Tcl_Command)procPtr->cmdPtr, parsedParam.paramDefs, checkAlwaysFlag,
(Tcl_Namespace *)execNsPtr);
Tcl_SetObjResult(interp, MethodHandleObj(defObject, withPer_object, methodName));
result = TCL_OK;
} else {
result = TCL_ERROR;
NsfLog(interp, NSF_LOG_WARN,
"cannot retrieve newly defined method %s from namespace %s",
methodName, nsPtr->fullName);
if (*methodName == ':') {
NsfPrintError(interp, "can't create procedure \"%s\" in non-global namespace"
" with name starting with \":\"",
methodName);
} else {
NsfPrintError(interp, "can't create procedure \"%s\" in non-global namespace",
methodName);
}
}
}
#if defined(NSF_WITH_ASSERTIONS)
if (result == TCL_OK && aStore != NULL /* (precondition || postcondition)*/) {
AssertionAddProc(interp, methodName, aStore, precondition, postcondition);
}
#endif
if (parsedParam.paramDefs != NULL) {
DECR_REF_COUNT(ov[2]);
}
DECR_REF_COUNT2("resultBody", ov[3]);
if (fullyQualifiedNameObj != nameObj) {
DECR_REF_COUNT2("fullyQualifiedName", fullyQualifiedNameObj);
}
return result;
}
/*
*----------------------------------------------------------------------
* MakeMethod --
*
* Define a scripted method to be defined on defObject and registered on
* regObject (if specified). This function handles as well assertions.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Defined method or exception.
*
*----------------------------------------------------------------------
*/
static int MakeMethod(Tcl_Interp *interp, NsfObject *defObject, NsfObject *regObject,
NsfClass *class, Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body,
Tcl_Obj *precondition, Tcl_Obj *postcondition,
int withInner_namespace, unsigned int checkAlwaysFlag)
nonnull(1) nonnull(2) nonnull(5) nonnull(6) nonnull(7);
static int
MakeMethod(Tcl_Interp *interp, NsfObject *defObject, NsfObject *regObject,
NsfClass *class, Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body,
Tcl_Obj *precondition, Tcl_Obj *postcondition,
int withInner_namespace, unsigned int checkAlwaysFlag) {
const char *argsStr, *bodyStr, *nameStr;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(defObject != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(args != NULL);
nonnull_assert(body != NULL);
nameStr = ObjStr(nameObj);
if (*nameStr == '\0' || NsfHasTclSpace(nameStr)) {
return NsfPrintError(interp, "invalid method name '%s'", nameStr);
}
if (precondition != NULL && postcondition == NULL) {
return NsfPrintError(interp, "%s method '%s'; when specifying a precondition (%s)"
" a postcondition must be specified as well",
ClassName(class), nameStr, ObjStr(precondition));
}
argsStr = ObjStr(args);
bodyStr = ObjStr(body);
if (*argsStr == 0 && *bodyStr == 0) {
/*
* Both, args and body are empty strings. This means we should delete the
* method.
*/
if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
/*
* Don't delete methods via scripting during shutdown
*/
result = (class != NULL) ?
NsfRemoveClassMethod(interp, (Nsf_Class *)class, nameStr) :
NsfRemoveObjectMethod(interp, (Nsf_Object *)defObject, nameStr);
} else {
/* fprintf(stderr, "don't delete method %s during shutdown\n", nameStr); */
result = TCL_OK;
}
} else {
#if defined(NSF_WITH_ASSERTIONS)
NsfAssertionStore *aStore = NULL;
if (precondition != NULL || postcondition != NULL) {
if (class != NULL) {
NsfClassOpt *opt = NsfRequireClassOpt(class);
if (opt->assertions == NULL) {
opt->assertions = AssertionCreateStore();
}
aStore = opt->assertions;
} else {
NsfObjectOpt *opt = NsfRequireObjectOpt(defObject);
if (opt->assertions == NULL) {
opt->assertions = AssertionCreateStore();
}
aStore = opt->assertions;
}
}
result = MakeProc((class != NULL) ? class->nsPtr : defObject->nsPtr, aStore,
interp, nameObj, args, body, precondition, postcondition,
defObject, regObject, class == NULL, withInner_namespace,
checkAlwaysFlag);
#else
if (precondition != NULL) {
NsfLog(interp, NSF_LOG_WARN, "Precondition %s provided, but not compiled with assertion enabled",
ObjStr(precondition));
} else if (postcondition != NULL) {
NsfLog(interp, NSF_LOG_WARN, "Postcondition %s provided, but not compiled with assertion enabled",
ObjStr(postcondition));
}
result = MakeProc((class != NULL) ? class->nsPtr : defObject->nsPtr, NULL,
interp, nameObj, args, body, NULL, NULL,
defObject, regObject, class == NULL, withInner_namespace,
checkAlwaysFlag);
#endif
}
if (class != NULL) {
NsfInstanceMethodEpochIncr("MakeMethod");
/*
* Could be a filter or filter inheritance ... update filter orders.
*/
if (FilterIsActive(interp, nameStr)) {
NsfClasses *subClasses = TransitiveSubClasses(class);
if (subClasses != NULL) {
FilterInvalidateObjOrders(interp, subClasses);
NsfClassListFree(subClasses);
}
}
} else {
NsfObjectMethodEpochIncr("MakeMethod");
/*
* Could be a filter => recompute filter order.
*/
FilterComputeDefined(interp, defObject);
}
return result;
}
/**************************************************************************
* Begin Definition of nsf::proc (Tcl Procs with Parameter handling)
**************************************************************************/
/*
*----------------------------------------------------------------------
* NsfProcStubDeleteProc --
*
* Tcl_CmdDeleteProc for NsfProcStubs. Is called, whenever a
* NsfProcStub is deleted and frees the associated client data.
*
* Results:
* None.
*
* Side effects:
* Frees client-data
*
*----------------------------------------------------------------------
*/
static void
NsfProcStubDeleteProc(ClientData clientData) {
NsfProcClientData *tcd = clientData;
/* fprintf(stderr, "NsfProcStubDeleteProc received %p\n", clientData);
fprintf(stderr, "... procName %s paramDefs %p\n", ObjStr(tcd->procName), tcd->paramDefs);*/
DECR_REF_COUNT2("procNameObj", tcd->procName);
if (tcd->cmd != NULL) {
Tcl_DeleteCommandFromToken(tcd->interp, tcd->cmd);
NsfCommandRelease(tcd->cmd);
}
/* tcd->paramDefs is freed by NsfProcDeleteProc() */
FREE(NsfProcClientData, tcd);
}
/*
*----------------------------------------------------------------------
* InvokeShadowedProc --
*
* Call the proc specified in objc/objv; procNameObj should be used
* for error messages.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int InvokeShadowedProc(Tcl_Interp *interp, Tcl_Obj *procNameObj,
Tcl_Command cmd, ParseContext *pcPtr,
struct Tcl_Time *trtPtr, unsigned int cmdFlags,
Tcl_Namespace *execNsPtr)
nonnull(1) nonnull(2) nonnull(4) nonnull(3) nonnull(4) nonnull(5);
static int
InvokeShadowedProc(Tcl_Interp *interp, Tcl_Obj *procNameObj,
Tcl_Command cmd, ParseContext *pcPtr,
struct Tcl_Time *trtPtr, unsigned int cmdFlags,
Tcl_Namespace *execNsPtr) {
Tcl_Obj *const *objv;
TCL_OBJC_T objc;
int result, includeTiming;
const char *fullMethodName;
Tcl_CallFrame *framePtr;
Proc *procPtr;
Tcl_Time *ttPtr;
nonnull_assert(interp != NULL);
nonnull_assert(procNameObj != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(pcPtr != NULL);
nonnull_assert(trtPtr != NULL);
objv = pcPtr->full_objv;
objc = pcPtr->objc+1;
fullMethodName = ObjStr(procNameObj);
CheckCStack(interp, "nsfProc", fullMethodName);
/* fprintf(stderr, "=== InvokeShadowedProc %s objc %d cmd %p\n", fullMethodName, objc, (void*)cmd); */
/*
* The code below is derived from the scripted method dispatch and just
* slightly adapted to remove object dependencies.
*/
procPtr = (Proc *)Tcl_Command_objClientData(cmd);
result = TclPushStackFrame(interp, &framePtr,
execNsPtr /* procPtr->cmdPtr->nsPtr */,
(FRAME_IS_PROC));
if (likely(result == TCL_OK)) {
unsigned int dummy = 0;
result = ByteCompiled(interp, &dummy, procPtr, (Namespace *)execNsPtr,
fullMethodName);
}
if (unlikely(result != TCL_OK)) {
/*
* The error message is assumed to be provided by the called cmd
*/
return result;
}
includeTiming = ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u);
#if defined(NSF_PROFILE)
if (includeTiming == 0) {
NsfRuntimeState *rst = RUNTIME_STATE(interp);
/*fprintf(stderr, "InvokeShadowedProc %s cmdFlags %.6lx\n", fullMethodName, cmdFlags);*/
includeTiming = rst->doProfile;
}
#endif
Tcl_CallFrame_objc(framePtr) = (TCL_SIZE_T)objc;
Tcl_CallFrame_objv(framePtr) = objv;
Tcl_CallFrame_procPtr(framePtr) = procPtr;
if (includeTiming) {
ttPtr = (Tcl_Time *) ckalloc(sizeof(Tcl_Time));
memcpy(ttPtr, trtPtr, sizeof(Tcl_Time));
} else {
ttPtr = NULL;
}
#if defined(NRE)
/* fprintf(stderr, "CALL TclNRInterpProcCore proc '%s' %s nameObj %p %s\n",
ObjStr(objv[0]), fullMethodName, procNameObj, ObjStr(procNameObj)); */
Tcl_NRAddCallback(interp, ProcDispatchFinalize,
(ClientData)fullMethodName,
pcPtr,
(ClientData)ttPtr,
(ClientData)UINT2PTR(cmdFlags)
);
result = TclNRInterpProcCore(interp, procNameObj, 1, &MakeProcError);
#else
{
ClientData data[4] = {
(ClientData)fullMethodName,
pcPtr,
(ClientData)ttPtr,
(ClientData)UINT2PTR(cmdFlags)
};
result = TclObjInterpProcCore(interp, procNameObj, 1, &MakeProcError);
result = ProcDispatchFinalize(data, interp, result);
}
#endif
return result;
}
/*
*----------------------------------------------------------------------
* NsfProcStub --
*
* TCL_OBJCMDPROC_T implementing Proc Stubs. This function processes
* the argument list in accordance with the parameter definitions
* and calls in case of success the shadowed proc.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
NsfProcStub(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
NsfProcClientData *tcd;
int result;
ParseContext *pcPtr;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
tcd = clientData;
assert(tcd->cmd != NULL);
/*fprintf(stderr, "NsfProcStub %s is called, tcd %p, paramDefs %p\n", ObjStr(objv[0]), tcd, tcd ? tcd->paramDefs : NULL);*/
if (!TclIsCommandDeleted(tcd->cmd) || Tcl_Command_cmdEpoch(tcd->cmd) != 0) {
/*
* It seems as if the (cached) command was deleted (e.g., rename), or
* someone messed around with the shadowed proc.
*
* We must refetch the command ...
*/
Tcl_Command newCmdPtr = Tcl_GetCommandFromObj(interp, tcd->procName);
if (unlikely(newCmdPtr == NULL)) {
return NsfPrintError(interp, "cannot lookup command '%s'",
ObjStr(tcd->procName));
} else if (unlikely(!CmdIsProc(newCmdPtr))) {
return NsfPrintError(interp, "command '%s' is not a proc",
ObjStr(tcd->procName));
}
/*
* ... and update the refCounts and cmd in ClientData
*/
NsfCommandRelease(tcd->cmd);
tcd->cmd = newCmdPtr;
NsfCommandPreserve(tcd->cmd);
}
pcPtr = (ParseContext *) NsfTclStackAlloc(interp, sizeof(ParseContext),
"parse context");
if (likely(tcd->paramDefs != NULL && tcd->paramDefs->paramsPtr)) {
/*
* We have a parameter definition, parse the provided objv against the
* parameter definition.
*/
result = ProcessMethodArguments(pcPtr, interp, NULL,
(((tcd->flags & NSF_PROC_FLAG_CHECK_ALWAYS) != 0u) ?
NSF_ARGPARSE_CHECK : 0u)
|NSF_ARGPARSE_FORCE_REQUIRED,
tcd->paramDefs, objv[0],
objc, objv);
} else {
/*
* In case we have no parameter definition (e.g. no arguments, or no
* arguments), just pass the objv along.
*/
pcPtr->full_objv = (Tcl_Obj**)objv;
pcPtr->objc = objc-1;
pcPtr->status = 0;
result = TCL_OK;
}
/*
* Check whether the argument parsing was ok.
*/
if (likely(result == TCL_OK)) {
Tcl_Command cmd = tcd->wrapperCmd;
unsigned int cmdFlags;
struct Tcl_Time trt;
assert(cmd != NULL);
cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
#if defined(NSF_PROFILE)
Tcl_GetTime(&trt);
if (RUNTIME_STATE(interp)->doTrace) {
NsfProfileTraceCallAppend(interp, ObjStr(objv[0]));
}
if ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u) {
NsfProfileDebugCall(interp, NULL, NULL, ObjStr(objv[0]), objc-1, (Tcl_Obj **)objv+1);
}
#else
if ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u) {
Tcl_GetTime(&trt);
NsfProfileDebugCall(interp, NULL, NULL, ObjStr(objv[0]), objc-1, (Tcl_Obj **)objv+1);
} else {
trt.sec = 0;
trt.usec = 0;
}
#endif
if ((cmdFlags & NSF_CMD_DEPRECATED_METHOD) != 0u) {
NsfDeprecatedCmd(interp, "proc", ObjStr(objv[0]), "");
}
/*
* Hacking alert: We have just 4 data arguments in Tcl_NRAddCallback for the
* finalize context. Since we do not want to allocate/manage additional
* structures for finalize data, and the pcPtr->object member is unused for
* nsfProcs, we reuse the pcPtr->object member for the wrapperCmd.
*/
pcPtr->object = (NsfObject *)tcd->wrapperCmd;
result = InvokeShadowedProc(interp, tcd->procName, tcd->cmd, pcPtr, &trt,
cmdFlags, Tcl_Command_nsPtr(cmd));
} else {
/*
* Result is already set to TCL_ERROR, the error message should be already
* provided.
*/
ParseContextRelease(pcPtr);
NsfTclStackFree(interp, pcPtr, "release parse context");
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfProcAdd --
*
* Add a command for implementing a Tcl proc with next scripting
* parameter handling.
*
* For the time being, this function adds two things, (a) a Tcl cmd
* functioning as a stub for the argument processing (in accordance
* with the parameter definitions) and (b) the shadowed Tcl proc
* with a mutated name.
*
* TODO: the current 1 cmd + 1 proc implementation is not robust
* against renaming and partial deletions (deletion of the
* stub).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Adding one Tcl command and one Tcl proc
*
*----------------------------------------------------------------------
*/
static int NsfProcAdd(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr,
const char *procName, Tcl_Obj *returnsObj, Tcl_Obj *body,
int with_ad, int with_checkAlways, int with_Debug, int with_Deprecated)
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static int
NsfProcAdd(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr,
const char *procName, Tcl_Obj *returnsObj, Tcl_Obj *body,
int with_ad, int with_checkAlways, int with_Debug, int with_Deprecated) {
NsfParamDefs *paramDefs;
NsfProcClientData *tcd;
Tcl_Namespace *cmdNsPtr;
Tcl_Obj *argList, *procNameObj, *ov[4];
Tcl_DString ds, *dsPtr = &ds;
int result;
unsigned int checkAlwaysFlag;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(parsedParamPtr != NULL);
nonnull_assert(procName != NULL);
nonnull_assert(body != NULL);
Tcl_DStringInit(dsPtr);
/*
* Create a fully qualified procName
*/
if (*procName != ':') {
DStringAppendQualName(dsPtr, Tcl_GetCurrentNamespace(interp), procName);
procName = Tcl_DStringValue(dsPtr);
}
/*
* Create first the ProcStub to obtain later its namespace, which is
* needed as the inner namespace of the shadowed proc.
*/
tcd = NEW(NsfProcClientData);
cmd = TCL_CREATEOBJCOMMAND(interp, procName, NsfProcStub,
tcd, NsfProcStubDeleteProc);
if (unlikely(cmd == NULL)) {
/*
* For some reason, the command could not be created. Let us hope,
* we have a useful error message.
*/
Tcl_DStringFree(dsPtr);
FREE(NsfProcClientData, tcd);
return TCL_ERROR;
}
checkAlwaysFlag = (with_checkAlways != 0) ? NSF_ARGPARSE_CHECK : 0u;
cmdNsPtr = Tcl_Command_nsPtr(cmd);
/*
* Storing param definitions is not needed for running the proc, since the
* stub receives parameters + flag via client data... but it is needed for
* introspection.
*
* TODO: For now, we provide no means to set the execNsPtr via interface.
*/
paramDefs = parsedParamPtr->paramDefs;
ParamDefsStore(cmd, paramDefs, checkAlwaysFlag, NULL);
if (returnsObj != NULL) {
ParamDefsSetReturns(cmd, returnsObj);
}
/*fprintf(stderr, "NsfProcAdd procName '%s' define cmd '%s' %p in namespace %s\n",
procName, Tcl_GetCommandName(interp, cmd), cmd, cmdNsPtr->fullName);*/
/*
* Let us create the shadowed Tcl proc, which is stored under
* ::nsf::procs::*. First build the fully qualified name procNameObj.
*/
Tcl_DStringSetLength(dsPtr, 0);
Tcl_DStringAppend(dsPtr, "::nsf::procs", TCL_INDEX_NONE);
DStringAppendQualName(dsPtr, cmdNsPtr, Tcl_GetCommandName(interp, cmd));
procNameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
Tcl_DStringLength(dsPtr));
INCR_REF_COUNT2("procNameObj", procNameObj); /* will be freed, when NsfProcStub is deleted */
/*
* Make sure to create the target namespace under "::nsf::procs::", if
* it does not exist.
*/
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
const char *dummy;
/*
* Create the target namespace, if it does not exist.
*/
TclGetNamespaceForQualName(interp, ObjStr(procNameObj), NULL, TCL_CREATE_NS_IF_UNKNOWN,
&nsPtr, &dummy1Ptr,
&dummy2Ptr, &dummy);
}
/*
* Create the client data, which links the stub cmd with the proc.
*/
tcd->procName = procNameObj;
tcd->paramDefs = paramDefs;
tcd->flags = (checkAlwaysFlag != 0u ? NSF_PROC_FLAG_CHECK_ALWAYS : 0u) | (with_ad != 0 ? NSF_PROC_FLAG_AD : 0u);
tcd->cmd = NULL;
tcd->wrapperCmd = cmd; /* TODO should we preserve? */
tcd->interp = interp; /* For deleting the shadowed proc */
/*fprintf(stderr, "NsfProcAdd %s tcd %p paramdefs %p\n",
ObjStr(procNameObj), tcd, tcd->paramDefs);*/
/*
* Build an argument list for the shadowed proc.
*/
argList = Tcl_NewListObj(0, NULL);
INCR_REF_COUNT(argList);
if (paramDefs != NULL) {
Nsf_Param *paramPtr;
for (paramPtr = paramDefs->paramsPtr; paramPtr->name != NULL; paramPtr++) {
if (*paramPtr->name == '-') {
Tcl_Obj *varNameObj = Tcl_NewStringObj(paramPtr->name+1, TCL_INDEX_NONE);
/*
* If we have the -ad (for ars digita) flag set, we provide the
* OpenACS semantics. This is (a) to use the name "boolean" for
* a switch and (b) to name the automatic variable with the
* prefix "_p".
*/
if (with_ad && paramPtr->converter == Nsf_ConvertToBoolean && paramPtr->nrArgs == 1) {
/*fprintf(stderr, "... ad handling: proc %s param %s type %s nrargs %d default %p\n",
procName, paramPtr->name, paramPtr->type, paramPtr->nrArgs, paramPtr->defaultValue);*/
paramPtr->nrArgs = 0;
/*paramPtr->converter = Nsf_ConvertToSwitch;*/
Tcl_AppendToObj(varNameObj, "_p", 2);
if (paramPtr->defaultValue == NULL) {
paramPtr->defaultValue = Tcl_NewBooleanObj(0);
INCR_REF_COUNT(paramPtr->defaultValue);
}
}
Tcl_ListObjAppendElement(interp, argList, varNameObj);
} else {
Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(paramPtr->name, TCL_INDEX_NONE));
}
}
}
ov[0] = NULL;
ov[1] = procNameObj;
ov[2] = argList;
ov[3] = AddPrefixToBody(body, NSF_TRUE, parsedParamPtr);
/*fprintf(stderr, "NsfProcAdd define proc %s arglist '%s'\n",
ObjStr(ov[1]), ObjStr(ov[2])); */
result = Tcl_ProcObjCmd(0, interp, 4, ov);
DECR_REF_COUNT(argList);
DECR_REF_COUNT2("resultBody", ov[3]);
if (likely(result == TCL_OK)) {
/*
* The shadowed proc was created successfully. Retrieve the defined proc
* and set its namespace to the namespace of the stub cmd.
*/
Tcl_Command procCmd = Tcl_GetCommandFromObj(interp, procNameObj);
assert(procCmd != NULL);
tcd->cmd = procCmd;
NsfCommandPreserve(tcd->cmd);
if (with_Debug) {
Tcl_Command_flags(cmd) |= NSF_CMD_DEBUG_METHOD;
}
if (with_Deprecated) {
Tcl_Command_flags(cmd) |= NSF_CMD_DEPRECATED_METHOD;
}
} else {
/*
* We could not define the shadowed proc. In this case, cleanup by
* removing the stub cmd.
*/
Tcl_DeleteCommandFromToken(interp, cmd);
}
Tcl_DStringFree(dsPtr);
return result;
}
/*
*----------------------------------------------------------------------
* ProcessMethodArguments --
*
* Process the arguments provided to a method call. It parses the argument
* vector objv, disallows certain parameter types and updates the parse
* context.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Updates parameter context
*
*----------------------------------------------------------------------
*/
static int
ProcessMethodArguments(ParseContext *pcPtr, Tcl_Interp *interp,
NsfObject *object, unsigned int processFlags, NsfParamDefs *paramDefs,
Tcl_Obj *methodNameObj, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result;
CallFrame frame, *framePtr = &frame;
nonnull_assert(pcPtr != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(paramDefs != NULL);
nonnull_assert(methodNameObj != NULL);
nonnull_assert(objv != NULL);
if (object != NULL && (processFlags & NSF_ARGPARSE_METHOD_PUSH) != 0u ) {
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
}
#if 0
{int i;
fprintf(stderr, "ProcessMethodArguments before ArgumentParse %s (flags %.6x objc %d): ", ObjStr(methodNameObj), processFlags, objc);
for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
fprintf(stderr, "\n");
Tcl_Obj *listObj = ParamDefsList(interp, paramDefs->paramsPtr, NULL, NULL);
fprintf(stderr, "... got params <%s>\n", ObjStr(listObj));
}
#endif
result = ArgumentParse(interp, objc, objv, object, methodNameObj,
paramDefs->paramsPtr, paramDefs->nrParams, paramDefs->serial,
processFlags|RUNTIME_STATE(interp)->doCheckArguments,
pcPtr);
#if 0
{
int i, fromArg, toArg;
fprintf(stderr, "ProcessMethodArguments after ArgumentParse %s pcPtr->objc %d result %d\n",
ObjStr(methodNameObj), pcPtr->objc, result);
if (result == TCL_OK) {
if ((processFlags & NSF_ARGPARSE_START_ZERO) != 0u) {
fromArg = 0;
toArg = pcPtr->objc;
} else {
fromArg = 1;
toArg = pcPtr->objc;
}
for (i = fromArg; i < toArg; i++) {
fprintf(stderr, "... pcPtr %p [%d] obj %p refCount %d (%s) flags %.6x & %p\n",
(void*)pcPtr, i,
pcPtr->objv[i] ? (void*)pcPtr->objv[i] : NULL,
pcPtr->objv[i] ? pcPtr->objv[i]->refCount : -1,
pcPtr->objv[i] ? ObjStr(pcPtr->objv[i]) : "(null)", pcPtr->flags[i],
(void*)&(pcPtr->flags[i]));
}
}
}
#endif
if (object != NULL && ((processFlags & NSF_ARGPARSE_METHOD_PUSH) != 0u)) {
Nsf_PopFrameObj(interp, framePtr);
}
/*
* 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).
*/
if (unlikely(result != TCL_OK)) {
return result;
}
if (pcPtr->varArgs) {
/*
* The last argument was "args".
*/
TCL_OBJC_T 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". The array 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.
*/
/*NsfPrintObjv("actual: ", objc, objv);*/
ParseContextExtendObjv(pcPtr, (unsigned)paramDefs->nrParams, (unsigned)elts-1u, objv + 1u + 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;
}
/**************************************************************************
* End Definition of nsf::proc (Tcl Procs with Parameter handling)
**************************************************************************/
/*
*----------------------------------------------------------------------
* ForwardCmdDeleteProc --
*
* This Tcl_CmdDeleteProc is called, when a forward method is deleted
*
* Results:
* None.
*
* Side effects:
* Frees client data of the setter command.
*
*----------------------------------------------------------------------
*/
static void
ForwardCmdDeleteProc(ClientData clientData) {
ForwardCmdClientData *tcd;
nonnull_assert(clientData != NULL);
tcd = (ForwardCmdClientData *)clientData;
if (tcd->cmdName != NULL) {DECR_REF_COUNT(tcd->cmdName);}
if (tcd->subcommands != NULL) {DECR_REF_COUNT(tcd->subcommands);}
#if defined(NSF_FORWARD_WITH_ONERROR)
if (tcd->onerror != NULL) {DECR_REF_COUNT(tcd->onerror);}
#endif
if (tcd->prefix != NULL) {DECR_REF_COUNT(tcd->prefix);}
if (tcd->args != NULL) {DECR_REF_COUNT(tcd->args);}
FREE(ForwardCmdClientData, tcd);
}
/*
*----------------------------------------------------------------------
* SetterCmdDeleteProc --
*
* This Tcl_CmdDeleteProc is called, when a setter method is deleted
*
* Results:
* None.
*
* Side effects:
* Frees client data of the setter command.
*
*----------------------------------------------------------------------
*/
static void SetterCmdDeleteProc(ClientData clientData)
nonnull(1);
static void
SetterCmdDeleteProc(ClientData clientData) {
SetterCmdClientData *setterClientData;
nonnull_assert(clientData != NULL);
setterClientData = (SetterCmdClientData *)clientData;
if (setterClientData->paramsPtr != NULL) {
ParamsFree(setterClientData->paramsPtr);
}
FREE(SetterCmdClientData, setterClientData);
}
/*
*----------------------------------------------------------------------
* AliasCmdDeleteProc --
*
* This Tcl_CmdDeleteProc is called, when an alias method is deleted
*
* Results:
* None.
*
* Side effects:
* Frees client data of the setter command.
*
*----------------------------------------------------------------------
*/
static void AliasCmdDeleteProc(ClientData clientData)
nonnull(1);
static void
AliasCmdDeleteProc(ClientData clientData) {
AliasCmdClientData *tcd;
nonnull_assert(clientData != 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.
*/
tcd = (AliasCmdClientData *)clientData;
if ((tcd->interp != NULL)
&& (((Interp *)(tcd->interp))->globalNsPtr != NULL)
&& RUNTIME_STATE(tcd->interp)->exitHandlerDestroyRound != NSF_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 aliasedCmd %p\n", tcd->aliasedCmd);*/
if (tcd->cmdName != NULL) {
DECR_REF_COUNT(tcd->cmdName);
}
if (tcd->aliasedCmd != NULL) {
#if defined(WITH_IMPORT_REFS)
ImportRef *refPtr, *prevPtr = NULL;
Command *aliasedCmd = (Command *)(tcd->aliasedCmd);
/*fprintf(stderr, "AliasCmdDeleteProc aliasedCmd %p epoch %d refCount %d\n",
aliasedCmd, Tcl_Command_cmdEpoch(tcd->aliasedCmd), aliasedCmd->refCount);*/
/*
* 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 != NULL; 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;
}
#endif
NsfCommandRelease(tcd->aliasedCmd);
}
FREE(AliasCmdClientData, tcd);
}
/*
*----------------------------------------------------------------------
* GetMatchObject --
*
* Helper method used by nsfAPI.h and the info methods to check whether the
* Tcl_Obj patternObj was provided and can be looked up. If this is the
* case, wild card matching etc. does not have to be performed, but just
* the properties of the object have to be tested.
*
* Results:
* 0 or 1 or -1, potentially the matchObject (when 0 is returned)
* 0: we have wild-card characters, iterate to get matches
* 1: we have an existing object
* -1: we no wild-card characters and a non-existing object
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetMatchObject(Tcl_Interp *interp, Tcl_Obj *patternObj, Tcl_Obj *origObj,
NsfObject **matchObjectPtr, const char **patternPtr) {
nonnull_assert(interp != NULL);
nonnull_assert(matchObjectPtr != NULL);
nonnull_assert(patternPtr != NULL);
if (patternObj != NULL) {
*patternPtr = ObjStr(patternObj);
if (TclObjIsNsfObject(interp, patternObj, matchObjectPtr)) {
return 1;
}
if (patternObj == origObj && **patternPtr != ':') {
return -1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
* ForwardProcessOptions --
*
* Process the options provided by the forward method and turn these into
* the ForwardCmdClientData structure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Allocated and initialized ForwardCmdClientData
*
*----------------------------------------------------------------------
*/
static int
ForwardProcessOptions(Tcl_Interp *interp, Tcl_Obj *nameObj,
Tcl_Obj *withDefault,
int withEarlybinding,
Tcl_Obj *withOnerror,
Tcl_Obj *withMethodprefix,
int withFrame,
bool withVerbose,
Tcl_Obj *target, TCL_OBJC_T objc, Tcl_Obj * const objv[],
ForwardCmdClientData **tcdPtr) {
ForwardCmdClientData *tcd;
TCL_OBJC_T i;
int result = 0;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(objv != NULL);
tcd = NEW(ForwardCmdClientData);
memset(tcd, 0, sizeof(ForwardCmdClientData));
if (withDefault != 0) {
Tcl_DString ds, *dsPtr = &ds;
DSTRING_INIT(dsPtr);
Tcl_DStringAppend(dsPtr, "%1 {", 4);
Tcl_DStringAppend(dsPtr, ObjStr(withDefault), TCL_INDEX_NONE);
Tcl_DStringAppend(dsPtr, "}", 1);
NsfDeprecatedCmd(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 != 0) {
tcd->prefix = withMethodprefix;
INCR_REF_COUNT(tcd->prefix);
}
#if defined(NSF_FORWARD_WITH_ONERROR)
if (withOnerror != 0) {
tcd->onerror = withOnerror;
INCR_REF_COUNT(tcd->onerror);
}
#endif
tcd->frame = withFrame;
tcd->verbose = withVerbose;
tcd->needobjmap = NSF_FALSE;
tcd->cmdName = target;
/*fprintf(stderr, "...forwardprocess objc %d, cmdName %p %s\n", objc, target, ObjStr(target));*/
for (i = 0; i < objc; i++) {
const char *element = ObjStr(objv[i]);
/*fprintf(stderr, "... [%d] forwardprocess element '%s'\n", i, element);*/
tcd->needobjmap = (tcd->needobjmap || (*element == '%' && *(element+1) == '@'));
tcd->hasNonposArgs = (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 == NULL) {
tcd->cmdName = nameObj;
}
/*fprintf(stderr, "+++ cmdName = %s, args = %s, # = %d\n",
ObjStr(tcd->cmdName), (tcd->args != NULL) ?ObjStr(tcd->args):"NULL", tcd->nr_args);*/
if (tcd->frame == FrameObjectIdx) {
/*
* When we evaluating objscope, and define ...
* o forward append -frame object 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(nameString, CallingNameSpace(interp));
/*fprintf(stderr, "+++ name %s not absolute, therefore, qualifying %s\n", nameString,
ObjStr(tcd->cmdName));*/
}
}
INCR_REF_COUNT(tcd->cmdName);
if (withEarlybinding != 0) {
Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName);
if (cmd == NULL) {
result = NsfPrintError(interp, "cannot lookup command '%s'", ObjStr(tcd->cmdName));
goto forward_process_options_exit;
}
if (CmdIsNsfObject(cmd) /* don't do direct invoke on nsf objects */
|| TCL_COMMAND_OBJPROC(cmd) == (TCL_OBJCMDPROC_T*)TclObjInterpProc /* don't do direct invoke on Tcl procs */
) {
/*
* Silently ignore earlybinding flag
*/
tcd->objProc = NULL;
} else {
tcd->objProc = TCL_COMMAND_OBJPROC(cmd);
tcd->clientData = Tcl_Command_objClientData(cmd);
}
}
tcd->passthrough = (tcd->args == NULL && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc);
forward_process_options_exit:
/*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/
if (likely(result == TCL_OK)) {
*tcdPtr = tcd;
} else {
ForwardCmdDeleteProc(tcd);
}
return result;
}
/*
*----------------------------------------------------------------------
* StripBodyPrefix --
*
* Strip the prefix of the body, which might have been added by nsf.
*
* Results:
* The string of the body without the prefix.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char * StripBodyPrefix(const char *body)
nonnull(1) NSF_pure;
static const char *
StripBodyPrefix(const char *body) {
nonnull_assert(body != NULL);
if (strncmp(body, "::nsf::__unset_unknown_args\n", 28) == 0) {
body += 28;
}
return body;
}
/*
*----------------------------------------------------------------------
* AddSlotObjects --
*
* Compute the slot objects (children of the slot container) for a provided
* object. The objects can be filtered via a pattern.
*
* Results:
* The function appends results to the provide listObj
*
* Side effects:
* Might add as well to the hash-table to avoid duplicates.
*
*----------------------------------------------------------------------
*/
static void AddSlotObjects(Tcl_Interp *interp, NsfObject *parent, const char *prefix,
Tcl_HashTable *slotTablePtr, NsfClass *typeClass,
const char *pattern, Tcl_Obj *listObj)
nonnull(1) nonnull(2) nonnull(3) nonnull(7);
static void
AddSlotObjects(Tcl_Interp *interp, NsfObject *parent, const char *prefix,
Tcl_HashTable *slotTablePtr,
NsfClass *typeClass, const char *pattern,
Tcl_Obj *listObj) {
NsfObject *slotContainerObject;
Tcl_DString ds, *dsPtr = &ds;
bool isFullQualPattern = ((pattern != NULL) && *pattern == ':' && *(pattern+1) == ':');
nonnull_assert(interp != NULL);
nonnull_assert(parent != NULL);
nonnull_assert(prefix != NULL);
nonnull_assert(listObj != NULL);
/*fprintf(stderr, "AddSlotObjects parent %s prefix %s type %p %s\n",
ObjectName(parent), prefix, type, (type != NULL) ? ClassName(type) : "");*/
DSTRING_INIT(dsPtr);
Tcl_DStringAppend(dsPtr, ObjectName_(parent), TCL_INDEX_NONE);
Tcl_DStringAppend(dsPtr, prefix, TCL_INDEX_NONE);
slotContainerObject = GetObjectFromString(interp, Tcl_DStringValue(dsPtr));
if (slotContainerObject != NULL && slotContainerObject->nsPtr
&& ((slotContainerObject->flags & NSF_IS_SLOT_CONTAINER) != 0u)) {
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(slotContainerObject->nsPtr);
Tcl_Command cmd;
hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
const char *key = Tcl_GetHashKey(cmdTablePtr, hPtr);
NsfObject *childObject;
if (slotTablePtr != NULL) {
int new;
/*
* Check whether we have and entry with this key already processed. We
* never want to report shadowed entries.
*/
Tcl_CreateHashEntry(slotTablePtr, key, &new);
if (new == 0) {
continue;
}
}
/*
* Obtain the childObject
*/
cmd = (Tcl_Command) Tcl_GetHashValue(hPtr);
childObject = NsfGetObjectFromCmdPtr(cmd);
/*
* Report just the already fully initialized slot objects, not the one
* being right now created.
*/
if (childObject == NULL || (childObject->flags & NSF_INIT_CALLED) == 0u) {
/* fprintf(stderr, "....... key %s unfinished\n", key);*/
continue;
}
/*
* Check the pattern.
*/
if (pattern != NULL) {
int isMatch;
/*
* If the pattern looks like fully qualified, we match against the
* fully qualified name.
*/
if (isFullQualPattern) {
isMatch = Tcl_StringMatch(ObjectName(childObject), pattern);
} else {
/*
* do we have a mangled name of a private property/variable?
*/
if (*key == '_' && *(key+1) == '_' && *(key+2) == '_' && *(key+3) == '_') {
Tcl_Obj *value = Nsf_ObjGetVar2((Nsf_Object *)childObject, interp,
NsfGlobalObjs[NSF_SETTERNAME], NULL, 0);
isMatch = (value != NULL) ? Tcl_StringMatch(ObjStr(value), pattern) : 0;
/*fprintf(stderr, "pattern <%s> isFullQualPattern %d child %s key %s %p <%s> match %d\n",
pattern, isFullQualPattern, ObjectName(childObject), key,
value, (value != NULL) ? ObjStr(value) : "", match);*/
} else {
isMatch = Tcl_StringMatch(key, pattern);
}
}
if (isMatch == 0) {
continue;
}
}
/*
* Check whether the entry is from the right type.
*/
if (typeClass != NULL && !IsSubType(childObject->cl, typeClass)) {
continue;
}
/*
* Add finally the entry to the returned list.
*/
Tcl_ListObjAppendElement(interp, listObj, childObject->cmdName);
}
}
DSTRING_FREE(dsPtr);
}
/*
*----------------------------------------------------------------------
* FindCalledClass --
*
* Find the called class of the called proc on the call-stack.
*
* Results:
* NsfClass * or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass *FindCalledClass(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static NsfClass *
FindCalledClass(Tcl_Interp *interp, NsfObject *object) {
NsfCallStackContent *cscPtr;
NsfClass *result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
cscPtr = CallStackGetTopFrame0(interp);
if (unlikely(cscPtr == NULL)) {
result = NULL;
} else {
if (cscPtr->frameType == NSF_CSC_TYPE_PLAIN) {
result = cscPtr->cl;
} else {
const char *methodName;
if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) {
methodName = MethodName(cscPtr->filterStackEntry->calledProc);
} else if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN && object->mixinStack != NULL) {
methodName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
} else {
methodName = NULL;
}
if (unlikely(methodName == NULL)) {
result = NULL;
} else if (object->nsPtr != NULL && FindMethod(object->nsPtr, methodName) != NULL) {
/*
* An object specific method was called.
*/
result = NULL;
} else {
Tcl_Command cmd;
result = SearchCMethod(object->cl, methodName, &cmd);
}
}
}
return result;
}
/*
* Next Primitive Handling
*/
/*
*----------------------------------------------------------------------
* NextSearchMethod --
*
* Determine the method to be called via "next". The function returns on
* success the found cmd and information like method name, was it from a
* mixin, filter, or was the end of the filter chain reached.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static int NextSearchMethod(
NsfObject *object, Tcl_Interp *interp, const NsfCallStackContent *cscPtr,
NsfClass **classPtr, const char **methodNamePtr, Tcl_Command *cmdPtr,
bool *isMixinEntry, bool *isFilterEntry,
bool *endOfFilterChain, Tcl_Command *currentCmdPtr
) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8) nonnull(9) nonnull(10);
NSF_INLINE static int
NextSearchMethod(
NsfObject *object, Tcl_Interp *interp, const NsfCallStackContent *cscPtr,
NsfClass **classPtr, const char **methodNamePtr, Tcl_Command *cmdPtr,
bool *isMixinEntry, bool *isFilterEntry,
bool *endOfFilterChain, Tcl_Command *currentCmdPtr
) {
bool endOfChain = NSF_FALSE;
unsigned int objflags;
nonnull_assert(object != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(cscPtr != NULL);
nonnull_assert(classPtr != NULL);
nonnull_assert(methodNamePtr != NULL);
nonnull_assert(cmdPtr != NULL);
nonnull_assert(isMixinEntry != NULL);
nonnull_assert(isFilterEntry != NULL);
nonnull_assert(endOfFilterChain != NULL);
nonnull_assert(currentCmdPtr != NULL);
/*fprintf(stderr, "NextSearchMethod for %s called with cl %p\n", *methodNamePtr, *classPtr);*/
/*
* Next in filters
*/
objflags = object->flags; /* avoid stalling */
if ((objflags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
objflags = object->flags; /* avoid stalling */
}
if ((objflags & NSF_FILTER_ORDER_VALID) != 0u
&& (object->filterStack != NULL)
&& object->filterStack->currentCmdPtr) {
*cmdPtr = FilterSearchProc(interp, object, currentCmdPtr, classPtr);
/*fprintf(stderr, "FilterSearchProc returned cmd %p\n", *cmdPtr);
NsfShowStack(interp);*/
if (*cmdPtr == NULL) {
if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) {
/*
* Reset the information to the values of method, classPtr
* to the values they had before calling the filters.
*/
*methodNamePtr = MethodName(object->filterStack->calledProc);
endOfChain = NSF_TRUE;
*endOfFilterChain = NSF_TRUE;
*classPtr = NULL;
/*fprintf(stderr, "EndOfChain resetting cl, new methodName '%s'\n", *methodNamePtr);*/
}
} else {
*methodNamePtr = (char *) Tcl_GetCommandName(interp, *cmdPtr);
*endOfFilterChain = NSF_FALSE;
*isFilterEntry = NSF_TRUE;
return TCL_OK;
}
}
/*
* Next in Mixins requires that we have already a mixinStack, and the
* current frame is not a plain frame.
*/
assert((objflags & NSF_MIXIN_ORDER_VALID) != 0u);
if ((object->mixinStack != NULL) && cscPtr->frameType) {
int result = MixinSearchProc(interp, object, *methodNamePtr,
classPtr, currentCmdPtr, cmdPtr);
/* fprintf(stderr, "next in mixins %s frameType %.6x\n", *methodNamePtr, cscPtr->frameType); */
if (unlikely(result != TCL_OK)) {
return result;
}
if (*cmdPtr == NULL) {
if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN) {
endOfChain = NSF_TRUE;
*classPtr = NULL;
}
} else {
*isMixinEntry = NSF_TRUE;
return TCL_OK;
}
}
/*fprintf(stderr, "nextsearch: object %s nsPtr %p endOfChain %d\n",
ObjectName(object), object->nsPtr, endOfChain);*/
/*
* Otherwise: normal method dispatch
*
* If we are already in the precedence ordering, then advance
* past our last point; otherwise (if classPtr == NULL) begin from the start.
*
* When a mixin or filter chain reached its end, we have to check for
* fully qualified method names and search the obj-specific methods as well.
*/
if (endOfChain) {
if (**methodNamePtr == ':') {
*cmdPtr = Tcl_FindCommand(interp, *methodNamePtr, NULL, TCL_GLOBAL_ONLY);
/* fprintf(stderr, "NEXT found absolute cmd %s => %p\n", *methodNamePtr, *cmdPtr); */
} else if (object->nsPtr != NULL) {
*cmdPtr = FindMethod(object->nsPtr, *methodNamePtr);
if ((*cmdPtr != NULL)
&& ((unsigned int)Tcl_Command_flags(*cmdPtr) & NSF_CMD_CALL_PRIVATE_METHOD) != 0u
) {
/*fprintf(stderr, "NEXT found private cmd %s => %p\n", *methodNamePtr, *cmdPtr);*/
*cmdPtr = NULL;
}
} else {
*cmdPtr = NULL;
}
} else {
*cmdPtr = NULL;
}
/*fprintf(stderr, "NEXT methodName %s *classPtr %p %s *cmd %p cscPtr->flags %.6x\n",
*methodNamePtr, *classPtr, ClassName((*classPtr)), *cmdPtr, cscPtr->flags); */
if (*cmdPtr == NULL) {
const NsfClasses *pl = PrecedenceOrder(object->cl);
const NsfClass *class = *classPtr;
if (class != NULL) {
/*
* Skip until actual class
*/
for ( ; pl != NULL; pl = pl->nextPtr) {
if (pl->cl == class) {
pl = pl->nextPtr;
break;
}
}
}
if (pl != NULL) {
/*
* Search for a further class method. When we are called from an active
* filter and the call had the "-local" flag set, then allow one to call
* private methods.
*/
*classPtr = SearchPLMethod(pl, *methodNamePtr, cmdPtr,
((cscPtr->flags & NSF_CM_LOCAL_METHOD) != 0u &&
(cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) != 0u)
? 0 : NSF_CMD_CALL_PRIVATE_METHOD);
} else {
*classPtr = NULL;
}
} else {
*classPtr = NULL;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* NextGetArguments --
*
* Obtain arguments for a method invoked via next either from the argument
* vector or from the stack (call stack content or Tcl stack). In case of
* ensemble calls the stack entries of the ensemble invocation are
* used. The function returns the arguments 4 to 8.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int NextGetArguments(
Tcl_Interp *interp, ptrdiff_t objc, Tcl_Obj *const objv[],
NsfCallStackContent **cscPtrPtr, const char **methodNamePtr,
TCL_OBJC_T *outObjc, Tcl_Obj ***outObjv, bool *freeArgumentVector
) nonnull(1) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8);
static int
NextGetArguments(
Tcl_Interp *interp, ptrdiff_t objc, Tcl_Obj *const objv[],
NsfCallStackContent **cscPtrPtr, const char **methodNamePtr,
TCL_OBJC_T *outObjc, Tcl_Obj ***outObjv, bool *freeArgumentVector
) {
Tcl_Obj **nobjv;
TCL_SIZE_T nobjc, oc;
bool inEnsemble;
Tcl_CallFrame *framePtr;
NsfCallStackContent *cscPtr;
nonnull_assert(interp != NULL);
nonnull_assert(cscPtrPtr != NULL);
nonnull_assert(methodNamePtr != NULL);
nonnull_assert(outObjc != NULL);
nonnull_assert(outObjv != NULL);
nonnull_assert(freeArgumentVector != NULL);
/*
* Initialize to zero to make sure, we only decrement when necessary.
*/
*freeArgumentVector = NSF_FALSE;
cscPtr = CallStackGetTopFrame(interp, &framePtr);
if (cscPtr == NULL) {
return NsfPrintError(interp, "next: can't find self");
}
if (cscPtr->cmdPtr == NULL) {
return NsfPrintError(interp, "next: no executing proc");
}
oc = Tcl_CallFrame_objc(framePtr);
if ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE)) {
/*
* We are in an ensemble method. The next works here not on the
* actual methodName + frame, but on the ensemble above it. We
* locate the appropriate call-stack content and continue next on
* that.
*/
cscPtr = CallStackFindEnsembleCsc(framePtr, &framePtr);
assert(cscPtr != NULL);
inEnsemble = NSF_TRUE;
*methodNamePtr = MethodName(cscPtr->objv[0]);
} else {
inEnsemble = NSF_FALSE;
*methodNamePtr = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
}
/*fprintf(stderr, "NextGetArguments oc %d objc %d inEnsemble %d objv %p\n",
oc, objc, inEnsemble, cscPtr->objv); */
if (objc > -1) {
size_t methodNameLength;
/*
* Arguments were provided. We have to construct an argument
* vector with the first argument(s) as the method name. In an
* ensemble, we have to insert the objs of the full ensemble name.
*/
if (inEnsemble) {
methodNameLength = 1 + (size_t)cscPtr->objc - (size_t)oc;
nobjc = (TCL_SIZE_T)objc + (TCL_SIZE_T)methodNameLength;
nobjv = (Tcl_Obj **)ckalloc((unsigned)sizeof(Tcl_Obj *) * (unsigned)nobjc);
MEM_COUNT_ALLOC("nextArgumentVector", nobjv);
/*
* Copy the ensemble pathname
*/
memcpy((char *)nobjv, cscPtr->objv, sizeof(Tcl_Obj *) * (size_t)methodNameLength);
} else {
methodNameLength = 1;
nobjc = (TCL_SIZE_T)objc + (TCL_SIZE_T)methodNameLength;
nobjv = (Tcl_Obj **)ckalloc((unsigned)sizeof(Tcl_Obj *) * (unsigned)nobjc);
MEM_COUNT_ALLOC("nextArgumentVector", nobjv);
/*
* Copy the method name
*/
if (cscPtr->objv != NULL) {
nobjv[0] = cscPtr->objv[0];
} else if (Tcl_CallFrame_objv(framePtr)) {
nobjv[0] = Tcl_CallFrame_objv(framePtr)[0];
}
}
if (objc > 0 && (objv != NULL || cscPtr->objv != NULL)) {
/*
* Copy the remaining argument vector
*/
memcpy(nobjv + methodNameLength, objv == NULL ? cscPtr->objv : objv, sizeof(Tcl_Obj *) * (size_t)objc);
}
INCR_REF_COUNT(nobjv[0]); /* we seem to need this here */
*freeArgumentVector = NSF_TRUE;
} else {
/*
* No arguments were provided
*/
if (cscPtr->objv != NULL) {
nobjv = (Tcl_Obj **)cscPtr->objv;
nobjc = (TCL_SIZE_T)cscPtr->objc;
} else {
nobjc = Tcl_CallFrame_objc(framePtr);
nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(framePtr);
}
}
*cscPtrPtr = cscPtr;
*outObjc = (TCL_OBJC_T)nobjc;
*outObjv = nobjv;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* NextInvokeFinalize --
*
* This finalize function is either called via NRE callback or
* directly (from NextSearchAndInvoke). It resets after a successful
* lookup and invocation the continuation context (filter flags etc)
* and cleans up optionally the argument vector (inverse operation
* of NextGetArguments).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* freeing memory
*
*----------------------------------------------------------------------
*/
NSF_INLINE static int NextInvokeFinalize(ClientData data[], Tcl_Interp *interp, int result)
nonnull(1) nonnull(2);
NSF_INLINE static int
NextInvokeFinalize(ClientData data[], Tcl_Interp *interp, int result) {
Tcl_Obj **nobjv;
NsfCallStackContent *cscPtr;
nonnull_assert(data != NULL);
nonnull_assert(interp != NULL);
nobjv = data[0];
cscPtr = data[1];
/*fprintf(stderr, "***** NextInvokeFinalize cscPtr %p flags %.6x is next %d result %d unk %d\n",
cscPtr, cscPtr->flags, cscPtr->flags & NSF_CSC_CALL_IS_NEXT, result,
RUNTIME_STATE(interp)->unknown);*/
if ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u) {
/* fprintf(stderr, "..... it was a successful next\n"); */
cscPtr->flags &= ~NSF_CSC_CALL_IS_NEXT;
if (cscPtr->frameType == NSF_CSC_TYPE_INACTIVE_FILTER) {
cscPtr->frameType = NSF_CSC_TYPE_ACTIVE_FILTER;
} else if (cscPtr->frameType == NSF_CSC_TYPE_INACTIVE_MIXIN) {
cscPtr->frameType = NSF_CSC_TYPE_ACTIVE_MIXIN;
}
}
if (nobjv != NULL) {
DECR_REF_COUNT(nobjv[0]);
MEM_COUNT_FREE("nextArgumentVector", nobjv);
ckfree((char *)nobjv);
}
if (result == TCL_ERROR && RUNTIME_STATE(interp)->unknown) {
/* fprintf(stderr, "don't report unknown error\n"); */
/*
* Don't report "unknown" errors via next.
*/
result = TCL_OK;
}
return result;
}
/*
*----------------------------------------------------------------------
* NextSearchAndInvoke --
*
* The function is called with a final argument vector and searches for a
* possibly shadowed method. If a target method is found, this dispatcher
* function updates the continuation context (filter flags etc.), invokes
* upon the target method, and performs a cleanup.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The invoked method might produce side effects. Also, the interp's unknown
* state may be modified.
*
*----------------------------------------------------------------------
*/
static int
NextSearchAndInvoke(
Tcl_Interp *interp, const char *methodName,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
NsfCallStackContent *cscPtr,
bool freeArgumentVector
) {
Tcl_Command cmd = NULL, currentCmd = NULL;
int result;
bool endOfFilterChain = NSF_FALSE,
isMixinEntry = NSF_FALSE,
isFilterEntry = NSF_FALSE;
NsfRuntimeState *rst;
NsfObject *object;
NsfClass *class;
nonnull_assert(interp != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cscPtr != NULL);
rst = RUNTIME_STATE(interp);
/*
* Search the next method & compute its method data
*/
class = cscPtr->cl;
object = cscPtr->self;
result = NextSearchMethod(object, interp, cscPtr, &class, &methodName, &cmd,
&isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd);
/*fprintf(stderr, "NEXT search on %s.%s cl %p cmd %p endOfFilterChain %d result %d IS OK %d\n",
ObjectName(object), methodName, (void*)class, (void*)cmd, endOfFilterChain,
result, (result == TCL_OK));*/
if (unlikely(result != TCL_OK)) {
goto next_search_and_invoke_cleanup;
}
#if 0
Tcl_ResetResult(interp); /* needed for bytecode support */
#endif
if (likely(cmd != NULL)
|| ( endOfFilterChain
&& (cscPtr->objv != NULL)
&& (cscPtr->flags & NSF_CSC_CALL_IS_GUARD) != 0u )
) {
unsigned short frameType = NSF_CSC_TYPE_PLAIN;
/*
* Change mixin state.
*/
if (object->mixinStack != NULL) {
if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN) {
cscPtr->frameType = NSF_CSC_TYPE_INACTIVE_MIXIN;
}
/*
* Otherwise move the command pointer forward.
*/
if (isMixinEntry) {
frameType = NSF_CSC_TYPE_ACTIVE_MIXIN;
object->mixinStack->currentCmdPtr = currentCmd;
}
}
/*
* Change filter state
*/
if (object->filterStack != NULL) {
if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) {
/*fprintf(stderr, "next changes filter state cmd %p\n", (void*)cmd);*/
cscPtr->frameType = NSF_CSC_TYPE_INACTIVE_FILTER;
}
/*
* Otherwise move the command pointer forward.
*/
if (isFilterEntry) {
/*fprintf(stderr, "next moves filter forward\n");*/
frameType = NSF_CSC_TYPE_ACTIVE_FILTER;
object->filterStack->currentCmdPtr = currentCmd;
}
}
if (cmd == NULL) {
/*
* The cmd was not found by NextSearchMethod(). In case of
* end-of-filterchain in a filter guard call, we have to call the "unknown"
* method, since otherwise we cannot flag unknown methods behind
* filters.
*/
result = DispatchUnknownMethod(interp, object,
cscPtr->objc, cscPtr->objv, NULL, cscPtr->objv[0],
(cscPtr->flags & NSF_CSC_CALL_NO_UNKNOWN)|NSF_CSC_IMMEDIATE);
goto next_search_and_invoke_cleanup;
}
/*
* Now actually call the "next" method.
*/
cscPtr->flags |= NSF_CSC_CALL_IS_NEXT;
rst->unknown = 0;
#if defined(NRE)
{ unsigned int flags;
/*
* Allow call only without immediate flag, when caller has NRE without
* immediate.
*/
flags = NsfImmediateFromCallerFlags(cscPtr->flags);
/*fprintf(stderr, "MethodDispatch in next flags %.6x NRE %d immediate %d next-flags %.6x\n",
cscPtr->flags,
(cscPtr->flags & NSF_CSC_CALL_IS_NRE) != 0,
(cscPtr->flags & NSF_CSC_IMMEDIATE) != 0,
flags);*/
if (flags == 0) {
/*
* The call is NRE-enabled. We register the callback and return
* here immediately. All other forms of this function have
* to call NextInvokeFinalize() manually on return.
*/
Tcl_NRAddCallback(interp, NextInvokeFinalize,
freeArgumentVector ? (ClientData)objv : NULL,
cscPtr, NULL, NULL);
return MethodDispatch(interp, objc, objv, cmd,
object, class, methodName, frameType, flags);
} else {
result = MethodDispatch(interp, objc, objv, cmd,
object, class, methodName, frameType, flags);
}
}
#else
/*fprintf(stderr, "NextSearchAndWinvoke calls cmd %p methodName %s cscPtr->flags %.8x\n",
cmd, methodName, cscPtr->flags);*/
result = MethodDispatch(interp, objc, objv, cmd,
object, class, methodName, frameType, cscPtr->flags);
#endif
} else if (likely(result == TCL_OK)) {
NsfCallStackContent *topCscPtr;
Tcl_CallFrame *varFramePtr = NULL;
int isLeafNext;
/*
* We could not find a cmd, yet the dispatch attempt did not result
* in an error. This means that we find ourselves in either of three
* situations at this point:
*
* 1) An explicit "next" cmd (NsfNextCmd()) at the end of a filter chain:
* Dispatch to unknown as there is no implementation for the requested
* call available.
*
* 2) An explicit "next" cmd from within a leaf sub-method (a "leaf
* next"): Remain silent, do not dispatch to unknown.
* 3) An implicit "next" triggered for unresolved sub-methods that might be
* resolved along the next path: Dispatch to unknown, the requested
* sub-cmd is not resolvable to a cmd.
*
* For the cases 1) and 3), set the interp's unknown flag signaling to
* higher levels (e.g., in MethodDispatchCsc(), in NsfNextCmd()) the need
* for dispatching to unknown.
*/
/* NsfShowStack(interp);*/
topCscPtr = CallStackGetTopFrame(interp, &varFramePtr);
if (topCscPtr == NULL) {
/*
* This might happen, when the end of the filter chain is reached and
* the method to be called is not found. Also, aside from filter chains,
* the ensemble method lookup requires an existing topCscPtr and would
* crash without it.
*/
/* fprintf(stderr, "no topCscPtr, unknown %d result %d\n", rst->unknown, result);*/
goto next_search_and_invoke_cleanup;
}
assert(varFramePtr != NULL);
/*
* Find the appropriate frame pointing to the start of the ensemble, in
* case we are in the middle of an ensemble.
*/
/*fprintf(stderr, "######## cscPtr %p topCscPtr %p\n", cscPtr, topCscPtr);*/
if ( cscPtr != topCscPtr
&& (cscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) != 0u
&& (topCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) != 0u) {
for (; varFramePtr != NULL; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) {
topCscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr);
assert(topCscPtr != NULL);
/*fprintf(stderr, "######## cscPtr %p topCscPtr %p topCscPtr->flags %8x\n",
cscPtr, topCscPtr, (topCscPtr != NULL) ? topCscPtr->flags : 0);*/
if ((topCscPtr->flags & NSF_CM_ENSEMBLE_UNKNOWN) != 0u) {
break;
}
}
if (varFramePtr != NULL) {
varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr);
if (((unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) {
topCscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr);
assert(topCscPtr != NULL);
}
}
}
/* case 2 */
isLeafNext = (cscPtr != topCscPtr)
&& (topCscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u
&& (topCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0u;
/*fprintf(stderr, "******** isleavenext %d based on %d && %d && %d <%s>\n",
isLeafNext,
(cscPtr != topCscPtr),
(topCscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u,
(topCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0u);*/
/*
* If we are in an ENSEMBLE_UNKNOWN we have to identify a special variant
* of case 2: When "next" is called from an ensemble method (e.g. from a
* method "i s") the call of "next" has to start over from "i" to search
* for the next method (the next "i s") of the shadowed methods. If there
* is none, we reach the ENSEMBLE_UNKNOWN state. But we reach the state
* not immediately after the "next" call, the other checks for handling
* this case fails, and we would run into the unknown handler, although
* being called from "next".
*
* Therefore, we check in the call-stack whether we are were called inside
* an ensemble setup on a path leading to an invocation of "next".
*
* Such a situation is e.g. (simplified stack view, then with flag names)
*
* varFrame flags lvl csc frameType flags
* 0x7ffeeb7b1698 040001 5 0x7ffeeb7b1870 0000 8000104 (::b.0x7fa756821490 i)
* 0x7fa75480eda0 020001 4 0x7fa75480ed40 0020 002100 (::b.0x7fa756821e10 s)
* 0x7ffeeb7b2028 040001 3 0x7ffeeb7b2370 0000 000005 (::b.0x7fa756821c10 i)
*
* topcsc 0x7ffeeb7b1870
* 0x7ffeeb7b1698 flags NSF_CSC_CALL_IS_ENSEMBLE|NSF_CSC_IMMEDIATE|NSF_CM_ENSEMBLE_UNKNOWN
* 0x7fa75480eda0 flags NSF_CSC_IMMEDIATE|NSF_CSC_CALL_IS_NRE frametype NSF_CSC_TYPE_ENSEMBLE
* 0x7ffeeb7b2028 flags NSF_CSC_CALL_IS_NEXT|NSF_CSC_CALL_IS_ENSEMBLE
*
*/
if (!isLeafNext && (topCscPtr->flags & NSF_CM_ENSEMBLE_UNKNOWN) != 0u) {
for (;;) {
varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr);
if (unlikely(varFramePtr == NULL)) {
break;
}
if (((unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr)
& (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) == 0) {
/*
* Parent frame is not an NSF frame.
*/
/*fprintf(stderr, "******** parent frame ptr is not an NSF frame %p\n", (void*)varFramePtr);*/
break;
}
topCscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr);
if ((topCscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) == 0u) {
/*
* Call stack content not of type ensemble.
*/
/*fprintf(stderr, "******** topCscPtr not type ensemble %p\n", (void*)topCscPtr);*/
break;
}
}
isLeafNext = (
(topCscPtr->flags & (NSF_CSC_CALL_IS_NEXT|NSF_CSC_CALL_IS_ENSEMBLE)) == (NSF_CSC_CALL_IS_NEXT|NSF_CSC_CALL_IS_ENSEMBLE) &&
(topCscPtr->flags & NSF_CM_ENSEMBLE_UNKNOWN) == 0u
);
/*fprintf(stderr, "******** alternate isleavenext %d based on topcscptr %p flags %.6x\n",
isLeafNext,
(void*)topCscPtr,
(topCscPtr != NULL ? topCscPtr->flags : 0));*/
}
rst->unknown =
/* case 1 */ endOfFilterChain ||
/* case 3 */ (!isLeafNext && ((cscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) != 0u));
/*NsfShowStack(interp);*/
/*fprintf(stderr, "******** setting unknown to %d isLeafNext %d topCscPtr %p endOfFilterChain %d\n",
rst->unknown, isLeafNext, (void *)topCscPtr, endOfFilterChain);*/
}
next_search_and_invoke_cleanup:
/*
* We come here, whenever the NRE callback is NOT registered
*/
{ClientData data[2] = {
freeArgumentVector ? (ClientData)objv : NULL,
cscPtr
};
return NextInvokeFinalize(data, interp, result);
}
}
/*
*----------------------------------------------------------------------
* NsfNextObjCmd --
*
* nsf::xotclnext is for backwards compatibility to the next
* implementation in XOTcl. It receives an argument vector which
* is used for the invocation. If no argument vector is provided,
* the argument vector of the last invocation is used. If the
* argument vector starts with "--noArgs", then no arguments are
* passed to the shadowed method.
*
* TODO: On the longer range, this function should go into an external
* library (e.g. XOTcl compatibility library)
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The invoked method might produce side effects
*
*----------------------------------------------------------------------
*/
static int
NsfNextObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(2) nonnull(4);
static int
NsfNextObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result;
TCL_OBJC_T nobjc = 0;
bool freeArgumentVector;
const char *methodName = NULL;
NsfCallStackContent *cscPtr;
Tcl_Obj **nobjv;
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
if (likely(objc < 2)) {
/*
* No arguments were provided.
*/
objc = 0;
} else {
/*
* In case "--noArgs" is used, remove the flag and provide an empty
* argument list.
*/
const char *arg1String = ObjStr(objv[1]);
if (*arg1String == '-' && !strcmp(arg1String, "--noArgs")) {
objc = 1;
}
}
result = NextGetArguments(interp, ((ptrdiff_t)objc)-1, &objv[1], &cscPtr, &methodName,
&nobjc, &nobjv, &freeArgumentVector);
if (likely(result == TCL_OK)) {
assert(nobjc > 0);
result = NextSearchAndInvoke(interp, methodName, nobjc, nobjv, cscPtr, freeArgumentVector);
}
return result;
}
/*
*----------------------------------------------------------------------
* FindNextMethod --
*
* This function is called via [current nextmethod] to resolve the
* method to be invoked by [next]. If there is a next method found
* on the precedence path, a method handle (Tcl_Obj) will be
* returned. The caller is responsible for managing the resulting
* Tcl_Obj, if any.
*
* Results:
* A Tcl_Obj; The result is NULL when no next method or called from
* outside of NSF.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *FindNextMethod(Tcl_Interp *interp, Tcl_CallFrame *framePtr)
nonnull(1) nonnull(2);
static Tcl_Obj *
FindNextMethod(Tcl_Interp *interp, Tcl_CallFrame *framePtr) {
Tcl_Obj *result;
NsfCallStackContent *cscPtr;
nonnull_assert(interp != NULL);
nonnull_assert(framePtr != NULL);
cscPtr = Tcl_CallFrame_clientData(framePtr);
if (unlikely(cscPtr == NULL)) {
result = NULL;
} else {
bool isEnsemble,
isMixinEntry = NSF_FALSE,
isFilterEntry = NSF_FALSE,
endOfFilterChain = NSF_FALSE;
Tcl_Command cmd = NULL, currentCmd = NULL;
const char *lookupMethodName, *methodName;
NsfClass *class;
NsfObject *object;
isEnsemble = ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u);
methodName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
if (isEnsemble) {
NsfCallStackContent *cscPtr1 = CallStackFindEnsembleCsc(framePtr, &framePtr);
lookupMethodName = MethodName(cscPtr1->objv[0]);
} else {
lookupMethodName = methodName;
}
class = cscPtr->cl;
object = cscPtr->self;
if (NextSearchMethod(object, interp, cscPtr,
&class, &lookupMethodName, &cmd, &isMixinEntry, &isFilterEntry,
&endOfFilterChain, ¤tCmd) == TCL_OK
&& cmd != NULL) {
Tcl_Obj *pathObj = NsfMethodNamePath(interp, framePtr, methodName);
INCR_REF_COUNT(pathObj);
methodName = isEnsemble ? ObjStr(pathObj) : lookupMethodName;
result = MethodHandleObj((class != NULL) ? (NsfObject *)class : object, (class == NULL), methodName);
DECR_REF_COUNT(pathObj);
} else {
result = NULL;
}
}
return result;
}
/*
*----------------------------------------------------------------------
* ComputeLevelObj --
*
* This function computes a fresh Tcl_Obj referring to the interp level. The
* caller has to care about freeing the returned Tcl_Obj.
*
* Results:
* Tcl_Obj *
*
* Side effects:
* Allocates a new Tcl_Obj
*
*----------------------------------------------------------------------
*/
static Tcl_Obj * ComputeLevelObj(Tcl_Interp *interp, CallStackLevel level)
nonnull(1) returns_nonnull;
static Tcl_Obj *
ComputeLevelObj(Tcl_Interp *interp, CallStackLevel level) {
Tcl_CallFrame *framePtr = NULL;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
switch (level) {
case CALLING_LEVEL: {
Tcl_CallFrame *callingFramePtr = NULL;
/*
* NsfCallStackFindCallingContext() sets always the framePtr, but
* initialize framePtr explicitly to silence static checkers, since
* ComputeLevelObj() is not performance critical.
*/
framePtr = NULL;
NsfCallStackFindCallingContext(interp, 1, &framePtr, &callingFramePtr);
if (framePtr == NULL) {
framePtr = callingFramePtr;
}
break;
}
case ACTIVE_LEVEL:
NsfCallStackFindActiveFrame(interp, 1, &framePtr);
break;
}
if (framePtr != NULL) {
/*
* The call was from an NSF frame, return absolute frame number.
*/
char buffer[LONG_AS_STRING];
int l;
buffer[0] = '#';
Nsf_ltoa(buffer+1, (long)Tcl_CallFrame_level(framePtr), &l);
resultObj = Tcl_NewStringObj(buffer, (TCL_SIZE_T)l+1);
} else {
/*
* If not called from an NSF frame, return #0 as default.
*
* TODO: With NsfCallStackFindCallingContext in place, this cannot (should
* not) be reachable. Need to check NsfCallStackFindActiveFrame. When in
* the "clear", provide for a warning here?
*
*/
resultObj = Tcl_NewStringObj("#0", 2);
}
return resultObj;
}
/*
int
NsfKObjCmd(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
if (objc < 2) {
return NsfPrintError(interp, "wrong # of args for K");
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
*/
/*
* object creation & destruction
*/
/*
*----------------------------------------------------------------------
* UnsetInAllNamespaces --
*
* Try to unset a variable, searching for the variable in all
* name-spaces. This function is used by volatile to unset the automatic
* variable used for the destroy trace.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Might unset variable
*
*----------------------------------------------------------------------
*/
static int UnsetInAllNamespaces(
Tcl_Interp *interp, const Tcl_Namespace *nsPtr, const char *name
) nonnull(1) nonnull(2) nonnull(3);
static int
UnsetInAllNamespaces(
Tcl_Interp *interp, const Tcl_Namespace *nsPtr, const char *name
) {
int rc = 0;
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
const Tcl_Var *varPtr;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
nonnull_assert(name != NULL);
/*fprintf(stderr, "### UnsetInAllNamespaces variable '%s', current namespace '%s'\n",
name, (nsPtr != NULL) ? nsPtr->fullName : "NULL");*/
entryPtr = Tcl_FirstHashEntry(Tcl_Namespace_childTablePtr(nsPtr), &search);
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 != NULL) {
Tcl_DString dFullname, *dsPtr = &dFullname;
int result;
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, "unset ", TCL_INDEX_NONE);
DStringAppendQualName(dsPtr, nsPtr, name);
result = Tcl_Eval(interp, Tcl_DStringValue(dsPtr));
/* fprintf(stderr, "fqName = '%s' unset => %d %d\n", Tcl_DStringValue(dsPtr), rc, TCL_OK);*/
if (likely(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 != NULL)) {
Tcl_Namespace *childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
/*fprintf(stderr, "child = %s\n", childNsPtr->fullName);*/
entryPtr = Tcl_NextHashEntry(&search);
rc |= UnsetInAllNamespaces(interp, childNsPtr, name);
}
return rc;
}
/*
*----------------------------------------------------------------------
* FreeUnsetTraceVariable --
*
* Unset trace variable.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Might unset variable
*
*----------------------------------------------------------------------
*/
static int FreeUnsetTraceVariable(Tcl_Interp *interp, const NsfObject *object)
nonnull(1) nonnull(2);
static int
FreeUnsetTraceVariable(Tcl_Interp *interp, const NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (object->opt != NULL && (object->opt->volatileVarName != NULL)) {
int result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, 0);
/*
* Somebody destroys a volatile object manually while the var-trace 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", object->opt->volatileVarName);*/
if (unlikely(result != TCL_OK)) {
result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY);
if (unlikely(result != TCL_OK)) {
Tcl_Namespace *nsPtr = 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);
/*
* Return always success, since an error during destroy does not
* help at all
*/
}
}
}
/*fprintf(stderr, "### FreeUnsetTraceVariable returns %d OK %d\n", result, TCL_OK);*/
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* NsfUnsetTrace --
*
* Function to be triggered whenever the trigger variable is
* deleted. Typically, this function deletes the associated object.
*
* Results:
* Result msg or null.
*
* Side effects:
* Might delete associated object.
*
*----------------------------------------------------------------------
*/
static const char *NsfUnsetTrace(
ClientData clientData, Tcl_Interp *interp,
const char *UNUSED(name), const char *UNUSED(name2), unsigned int UNUSED(flags)
) nonnull(1) nonnull(2);
static const char *
NsfUnsetTrace(
ClientData clientData, Tcl_Interp *interp,
const char *UNUSED(name), const char *UNUSED(name2), unsigned int UNUSED(flags)
) {
Tcl_Obj *objPtr = (Tcl_Obj *)clientData;
NsfObject *object;
const char *resultMsg = NULL;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
/*fprintf(stderr, "NsfUnsetTrace %s flags %.4x deleted %d\n", name, flags,
Tcl_InterpDeleted(interp));*/
if (Tcl_InterpDeleted(interp) == 0) {
if (GetObjectFromObj(interp, objPtr, &object) == TCL_OK) {
Tcl_Obj *savedResultObj = Tcl_GetObjResult(interp); /* save the result */
INCR_REF_COUNT(savedResultObj);
/*
* Clear variable, destroy is called from trace.
*/
if (object->opt != NULL && object->opt->volatileVarName) {
object->opt->volatileVarName = NULL;
}
if (DispatchDestroyMethod(interp, object, 0u) != TCL_OK) {
resultMsg = "Destroy for volatile object failed";
} else {
resultMsg = "No NSF Object passed";
}
Tcl_SetObjResult(interp, savedResultObj); /* restore the result */
DECR_REF_COUNT(savedResultObj);
}
} else {
/* fprintf(stderr, "omitting destroy\n"); */
}
DECR_REF_COUNT2("volatile", objPtr);
return resultMsg;
}
/*
*----------------------------------------------------------------------
* CleanupDestroyObject --
*
* Perform cleanup of object; after the function is executed, the object is
* in the same fresh state as after initialization.
*
* Results:
* None.
*
* Side effects:
* Possibly freeing memory.
*
*----------------------------------------------------------------------
*/
static void CleanupDestroyObject(Tcl_Interp *interp, NsfObject *object, bool softrecreate)
nonnull(1) nonnull(2);
static void
CleanupDestroyObject(Tcl_Interp *interp, NsfObject *object, bool softrecreate) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*fprintf(stderr, "CleanupDestroyObject obj %p softrecreate %d nsPtr %p\n",
object, softrecreate, object->nsPtr);*/
/*
* The object pointer is guaranteed to point to the same object, so it is
* not sufficient for methodObj validation. Therefore, for objects
* containing per-object methods, we increment the objectMethodEpoch.
*/
if (object->nsPtr != NULL) {
NsfObjectMethodEpochIncr("CleanupDestroyObject");
}
/*
* Remove the instance, but not for ::Class/::Object
*/
if (!IsBaseClass(object)) {
if (!softrecreate) {
RemoveInstance(object, object->cl);
}
}
/*
* Unset object variables with unset traces preemptively.
*/
UnsetTracedVars(interp, object);
if (object->nsPtr != NULL) {
NSCleanupNamespace(interp, object->nsPtr);
NSDeleteChildren(interp, object->nsPtr);
}
if (object->varTablePtr != NULL) {
/*
* Any unset-traced variable has been deleted before (UnsetTracedVars).
*/
TclDeleteVars(((Interp *)interp), object->varTablePtr);
ckfree((char *)object->varTablePtr);
/*FREE(obj->varTablePtr, obj->varTablePtr);*/
object->varTablePtr = 0;
}
if (object->opt != NULL) {
NsfObjectOpt *opt = object->opt;
#if defined(NSF_WITH_ASSERTIONS)
if (opt->assertions != NULL) {
AssertionRemoveStore(opt->assertions);
opt->assertions = NULL;
}
#endif
#if defined(PER_OBJECT_PARAMETER_CACHING)
if (object->opt->parsedParamPtr != NULL) {
NsfParameterCacheObjectInvalidateCmd(interp, object);
}
#endif
if (!softrecreate) {
/*
* Remove this object from all per object mixin lists and clear the
* mixin list.
*/
if (opt->objMixins != NULL) {
RemoveFromObjectMixinsOf(object->id, opt->objMixins);
}
CmdListFree(&opt->objMixins, GuardDel);
CmdListFree(&opt->objFilters, GuardDel);
FREE(NsfObjectOpt, opt);
object->opt = NULL;
}
}
object->flags &= ~NSF_MIXIN_ORDER_VALID;
if (object->mixinOrder != NULL) {
MixinResetOrder(object);
}
object->flags &= ~NSF_FILTER_ORDER_VALID;
if (object->filterOrder != NULL) {
FilterResetOrder(object);
}
}
/*
* obj initialization & namespace creation
*/
/*
*----------------------------------------------------------------------
* CleanupInitObject --
*
* Perform the initialization of an object in a virgin state.
* During bootstrap, cl might be NULL.
*
* Results:
* None.
*
* Side effects:
* Updating the object structure
*
*----------------------------------------------------------------------
*/
static void CleanupInitObject(
Tcl_Interp *interp, NsfObject *object,
NsfClass *class, Tcl_Namespace *nsPtr, bool softrecreate
) nonnull(1) nonnull(2);
static void
CleanupInitObject(
Tcl_Interp *interp, NsfObject *object,
NsfClass *class, Tcl_Namespace *nsPtr, bool softrecreate
) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
#ifdef OBJDELETION_TRACE
fprintf(stderr, "+++ CleanupInitObject\n");
#endif
object->teardown = interp;
object->nsPtr = nsPtr;
if (!softrecreate && class != NULL) {
AddInstance(object, class);
}
if ((object->flags & NSF_RECREATE) != 0u) {
object->opt = NULL;
object->varTablePtr = NULL;
object->mixinOrder = NULL;
object->filterOrder = NULL;
object->flags = 0;
}
/*
fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", (obj->cmdName != NULL) ? ObjectName(object) : "", object, object->cl);*/
}
/*
*----------------------------------------------------------------------
* PrimitiveDestroy --
*
* Dispatch either PrimitiveCDestroy or PrimitiveODestroy
* depending on whether the object is a class
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
PrimitiveDestroy(ClientData clientData) {
nonnull_assert(clientData != NULL);
if (NsfObjectIsClass((NsfObject *)clientData)) {
PrimitiveCDestroy(clientData);
} else {
PrimitiveODestroy(clientData);
}
}
/*
*----------------------------------------------------------------------
* TclDeletesObject --
*
* Function to be called, when Tcl deletes the command which has an
* object/class associated. This happens, when e.g. a namespace is deleted.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void TclDeletesObject(ClientData clientData)
nonnull(1);
static void
TclDeletesObject(ClientData clientData) {
NsfObject *object;
nonnull_assert(clientData != NULL);
object = (NsfObject *)clientData;
/*
* TODO: Actually, it seems like a good idea to flag a deletion from Tcl by
* setting object->id to NULL. However, we seem to have some dependencies
* avoiding this currently, so we use the flag.
*/
object->flags |= NSF_TCL_DELETE;
/*fprintf(stderr, "cmd dealloc %p TclDeletesObject (%d)\n",
object->id, Tcl_Command_refCount(object->id));*/
#ifdef OBJDELETION_TRACE
fprintf(stderr, "TclDeletesObject %p obj->id %p flags %.6x\n",
(void *)object, (void *)object->id, object->flags);
#endif
if (unlikely((object->flags & NSF_DURING_DELETE) == 0u)
&& (object->teardown != NULL)
) {
# ifdef OBJDELETION_TRACE
fprintf(stderr, "... %p %s\n", (void *)object, ObjectName(object));
# endif
CallStackDestroyObject(object->teardown, object);
}
}
/*
*----------------------------------------------------------------------
* PrimitiveODestroy --
*
* Delete an object with its namespace and associated data structures
* (mixin stack, filter stack). The physical deallocation is handled by
* NsfCleanupObject() which performs reference counting.
*
* Results:
* None.
*
* Side effects:
* Free object contents.
*
*----------------------------------------------------------------------
*/
static void
PrimitiveODestroy(ClientData clientData) {
NsfObject *object;
Tcl_Interp *interp;
nonnull_assert(clientData != NULL);
object = (NsfObject *)clientData;
assert(object->teardown != NULL);
/*fprintf(stderr, "****** PrimitiveODestroy %p cmd %p flags %.6x\n",
(void *)object, (void *)object->id, object->flags);*/
/*
* We assume, the object was not yet deleted, but destroy was called
* already.
*/
assert((object->flags & NSF_DELETED) == 0u);
assert((object->flags & NSF_DESTROY_CALLED) != 0u);
/*
* 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)) {
#ifdef OBJDELETION_TRACE
{Command *cmdPtr = (Command*)object->id;
fprintf(stderr, " physical delete of %p id=%p (cmd->refCount %d) destroyCalled=%d '%s'\n",
(void *)object, (void *)object->id, cmdPtr->refCount,
(object->flags & NSF_DESTROY_CALLED), ObjectName(object));
}
#endif
CleanupDestroyObject(interp, object, NSF_FALSE);
while (object->mixinStack != NULL) {
MixinStackPop(object);
}
while (object->filterStack != NULL) {
FilterStackPop(object);
}
/*
* Object is now mostly dead, but still allocated. However, since
* Nsf_DeleteNamespace might delegate to the parent (e.g. slots) we clear
* teardown after the deletion of the children.
*/
if (object->nsPtr != NULL) {
/*fprintf(stderr, "PrimitiveODestroy calls deleteNamespace for object %p nsPtr %p\n", (void*)object, object->nsPtr);*/
Nsf_DeleteNamespace(interp, object->nsPtr);
object->nsPtr = NULL;
}
object->teardown = NULL;
/*fprintf(stderr, " +++ OBJ/CLS free: %p %s\n", (void *)object, ObjectName(object));*/
object->flags |= NSF_DELETED;
ObjTrace("ODestroy", object);
DECR_REF_COUNT(object->cmdName);
NsfCleanupObject(object, "PrimitiveODestroy");
}
}
/*
*----------------------------------------------------------------------
* DoDealloc --
*
* Perform deallocation of an object/class. This function is called
* from the dealloc method and internally to get rid of an
* abject. It cares about volatile and frees/triggers free
* operation depending on the stack references.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* freed object or object is marked to be freed.
*
*----------------------------------------------------------------------
*/
static int DoDealloc(Tcl_Interp *interp, NsfObject *object)
nonnull(1) nonnull(2);
static int
DoDealloc(Tcl_Interp *interp, NsfObject *object) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*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 (unlikely(result == TCL_OK)) {
/*
* Latch, and call delete command if not already in progress.
*/
if (RUNTIME_STATE(interp)->exitHandlerDestroyRound !=
NSF_EXITHANDLER_ON_SOFT_DESTROY) {
CallStackDestroyObject(interp, object);
}
}
return result;
}
/*
*----------------------------------------------------------------------
* MarkUndestroyed --
*
* Mark an object as if destroy was not called. This function is e.g. used
* from recreate.
*
* Results:
* None.
*
* Side effects:
* Setting object flag.
*
*----------------------------------------------------------------------
*/
static void MarkUndestroyed(NsfObject *object)
nonnull(1);
static void
MarkUndestroyed(NsfObject *object) {
nonnull_assert(object != NULL);
object->flags &= ~NSF_DESTROY_CALLED;
}
/*
*----------------------------------------------------------------------
* PrimitiveOInit --
*
* Set/reset the object to a fresh, un-destroyed state
*
* Results:
* A standard Tcl result.
*
* Side effects:
* initializing object structure
*
*----------------------------------------------------------------------
*/
static void PrimitiveOInit(NsfObject *object, Tcl_Interp *interp, const char *name,
Tcl_Namespace *nsPtr, NsfClass *class)
nonnull(1) nonnull(2) nonnull(3);
static void
PrimitiveOInit(NsfObject *object, Tcl_Interp *interp, const char *name,
Tcl_Namespace *nsPtr, NsfClass *class) {
nonnull_assert(object != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
#ifdef OBJDELETION_TRACE
fprintf(stderr, "+++ PrimitiveOInit\n");
#endif
#ifdef NSFOBJ_TRACE
fprintf(stderr, "OINIT %s = %p\n", name, (void *)object);
#endif
NsfObjectRefCountIncr(object);
MarkUndestroyed(object);
/*
* There might be already a namespace with the provided name; if this is the
* case, use this namespace as object namespace. The preexisting namespace
* might contain Next Scripting 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.
*
* We can use here the provided nsPtr, except in cases, where this
* namespaces is being destroyed (e.g. recreate a new object from a
* different object system).
*/
if (nsPtr != NULL && (((Namespace *)nsPtr)->flags & NS_DYING) != 0u) {
Namespace *dummy1Ptr, *dummy2Ptr, *nsPtr1 = (Namespace *)nsPtr;
const char *dummy;
TclGetNamespaceForQualName(interp, name,
NULL, TCL_GLOBAL_ONLY|TCL_FIND_ONLY_NS,
&nsPtr1, &dummy1Ptr, &dummy2Ptr, &dummy);
nsPtr = (Tcl_Namespace *)nsPtr1;
/*fprintf(stderr, "PrimitiveOInit %p calls TclGetNamespaceForQualName with %s => %p given %p object->nsPtr %p\n",
object, name,
nsPtr, nsPtr, object->nsPtr);*/
}
if (nsPtr != NULL) {
NsfNamespaceInit(nsPtr);
}
/* fprintf(stderr, "PrimitiveOInit %p %s, ns %p\n", object, name, nsPtr); */
CleanupInitObject(interp, object, class, nsPtr, NSF_FALSE);
/*
* TODO: would be nice, if we could init object flags.
*/
/* object->flags = NSF_MIXIN_ORDER_VALID | NSF_FILTER_ORDER_VALID;*/
object->mixinStack = NULL;
object->filterStack = NULL;
}
/*
*----------------------------------------------------------------------
* PrimitiveOCreate --
*
* Allocate memory for an object, create the object name and the associated
* Tcl command and call the initialization functions.
*
* Results:
* NsfObject*
*
* Side effects:
* Allocating memory
*
*----------------------------------------------------------------------
*/
static NsfObject * PrimitiveOCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr, NsfClass *class)
nonnull(1) nonnull(2) nonnull(4) returns_nonnull;
static NsfObject *
PrimitiveOCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr, NsfClass *class) {
const char *nameString;
Tcl_Namespace *nsPtr;
NsfObject *object;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(class != NULL);
object = (NsfObject *)ckalloc((int)sizeof(NsfObject));
MEM_COUNT_ALLOC("NsfObject/NsfClass", object);
assert(object != NULL); /* ckalloc panics, if malloc fails */
memset(object, 0, sizeof(NsfObject));
nameString = ObjStr(nameObj);
assert(isAbsolutePath(nameString));
#if defined(NSFOBJ_TRACE)
fprintf(stderr, "CKALLOC Object %p %s\n", (void *)object, nameString);
#endif
#ifdef OBJDELETION_TRACE
fprintf(stderr, "+++ PrimitiveOCreate\n");
#endif
nsPtr = NSCheckNamespace(interp, nameString, parentNsPtr);
if (nsPtr != NULL) {
NSNamespacePreserve(nsPtr);
}
#if defined(NRE)
object->id = TCL_NRCREATECOMMAND(interp, nameString,
NsfObjDispatch,
NsfObjDispatchNRE,
object, TclDeletesObject);
#else
object->id = TCL_CREATEOBJCOMMAND(interp, nameString, NsfObjDispatch,
object, TclDeletesObject);
#endif
/*fprintf(stderr, "cmd alloc %p %d (%s)\n", object->id,
Tcl_Command_refCount(object->id), nameString);*/
PrimitiveOInit(object, interp, nameString, nsPtr, class);
if (nsPtr != NULL) {
NSNamespaceRelease(nsPtr);
}
object->cmdName = nameObj;
INCR_REF_COUNT(object->cmdName);
ObjTrace("PrimitiveOCreate", object);
return object;
}
/*
*----------------------------------------------------------------------
* DefaultSuperClass --
*
* Determine the default superclass of the class (specified as
* second argument) and metaclass (third argument). The function
* searches for the variable NSF_DEFAULTMETACLASS or
* NSF_DEFAULTSUPERCLASS and uses it if present.
*
* Results:
* Default superclass or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static NsfClass *
DefaultSuperClass(Tcl_Interp *interp, const NsfClass *class, const NsfClass *metaClass, bool isMeta) {
NsfClass *resultClass = NULL;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(metaClass != NULL);
/*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s, isMeta %d\n",
ClassName(class), ClassName(metaClass), isMeta );*/
resultObj = Nsf_ObjGetVar2((Nsf_Object *)metaClass, interp, (isMeta != 0) ?
NsfGlobalObjs[NSF_DEFAULTMETACLASS] :
NsfGlobalObjs[NSF_DEFAULTSUPERCLASS], NULL, 0);
if (resultObj != NULL) {
if (unlikely(GetClassFromObj(interp, resultObj, &resultClass, NSF_FALSE) != TCL_OK)) {
NsfPrintError(interp, "default superclass is not a class");
}
/*fprintf(stderr, "DefaultSuperClass for %s got from var %s => %s\n",
ClassName(class),
ObjStr((isMeta != 0) ? NsfGlobalObjs[NSF_DEFAULTMETACLASS] : NsfGlobalObjs[NSF_DEFAULTSUPERCLASS]),
ClassName(resultClass));*/
} else {
const NsfClasses *sc;
/*fprintf(stderr, "DefaultSuperClass for %s: search in superClasses starting with %p meta %d\n",
ClassName(class), cl->super, isMeta);*/
if (isMeta != 0) {
/*
* Is this already the root metaclass ?
*/
if (IsRootMetaClass(metaClass->object.cl)) {
return metaClass->object.cl;
}
}
/*
* Check superClasses of metaclass
*/
for (sc = metaClass->super; sc && sc->cl != class; sc = sc->nextPtr) {
/* fprintf(stderr, " ... check ismeta %d %s root mcl %d root cl %d\n",
isMeta, ClassName(sc->cl),
sc->cl->object.flags & NSF_IS_ROOT_META_CLASS,
sc->cl->object.flags & NSF_IS_ROOT_CLASS); */
if (isMeta != 0) {
if (IsRootMetaClass(sc->cl)) {
return sc->cl;
}
} else {
if (IsRootClass(sc->cl)) {
/* fprintf(stderr, "found root-class %p %s\n", sc->cl, ClassName(sc->cl)); */
return sc->cl;
}
}
resultClass = DefaultSuperClass(interp, class, sc->cl, isMeta);
if (resultClass != NULL) {
break;
}
}
}
return resultClass;
}
/*
*----------------------------------------------------------------------
* CleanupDestroyClass --
*
* Cleanup class in a destroy call. Remove filters, mixins, assertions,
* instances and remove finally class from class hierarchy. In the recreate
* case, it preserves the pointers from other class structures.
*
* Results:
* None.
*
* Side effects:
* Updated class structures.
*
*----------------------------------------------------------------------
*/
static void CleanupDestroyClass(Tcl_Interp *interp, NsfClass *class, bool softrecreate, bool recreate)
nonnull(1) nonnull(2);
static void
CleanupDestroyClass(Tcl_Interp *interp, NsfClass *class, bool softrecreate, bool recreate) {
NsfClassOpt *clopt;
NsfClass *baseClass = NULL;
NsfClasses *subClasses;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
PRINTOBJ("CleanupDestroyClass", (NsfObject *)class);
assert(softrecreate ? recreate : NSF_TRUE);
clopt = class->opt;
/*fprintf(stderr, "CleanupDestroyClass %p %s (ismeta=%d) softrecreate=%d, recreate=%d, %p\n",
class, ClassName(class), IsMetaClass(interp, cl, NSF_TRUE),
softrecreate, recreate, clopt);*/
subClasses = DependentSubClasses(class);
if (subClasses != NULL) {
/*
* 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(subClasses);
if (FiltersDefined(interp) > 0) {
FilterInvalidateObjOrders(interp, subClasses);
}
}
if (clopt != NULL) {
/*
* Remove this class from all isClassMixinOf lists and clear the
* class mixin list
*/
if (clopt->classMixins != NULL) {
RemoveFromClassMixinsOf(clopt->id, clopt->classMixins);
}
CmdListFree(&clopt->classMixins, GuardDel);
CmdListFree(&clopt->classFilters, GuardDel);
if (clopt->mixinRegObjs != NULL) {
NsfMixinregInvalidate(interp, clopt->mixinRegObjs);
DECR_REF_COUNT2("mixinRegObjs", clopt->mixinRegObjs);
clopt->mixinRegObjs = NULL;
}
if (!recreate) {
/*
* Remove this class from all mixin lists and clear the isObjectMixinOf list
*/
if (clopt->isObjectMixinOf != 0) {
RemoveFromObjectMixins(clopt->id, clopt->isObjectMixinOf);
}
CmdListFree(&clopt->isObjectMixinOf, GuardDel);
/*
* Remove this class from all class mixin lists and clear the
* isClassMixinOf list
*/
if (clopt->isClassMixinOf != 0) {
RemoveFromClassmixins(clopt->id, clopt->isClassMixinOf);
}
CmdListFree(&clopt->isClassMixinOf, GuardDel);
}
/*
* Remove dependent filters of this class from all subclasses
*/
if (subClasses != NULL) {
FilterRemoveDependentFilterCmds(class, subClasses);
}
#if defined(NSF_WITH_ASSERTIONS)
if (clopt->assertions != NULL) {
AssertionRemoveStore(clopt->assertions);
clopt->assertions = NULL;
}
#endif
#ifdef NSF_OBJECTDATA
NsfFreeObjectData(class);
#endif
}
NSCleanupNamespace(interp, class->nsPtr);
NSDeleteChildren(interp, class->nsPtr);
if (!softrecreate) {
/*
* Reclass all instances of the current class to the appropriate
* most general class ("baseClass"). The most general class of a
* metaclass is the root metaclass, the most general class of an
* object is the root-class. Instances of metaclasses can be only
* reset to the root metaclass (and not to the root base
* class).
*/
baseClass = DefaultSuperClass(interp, class, class->object.cl,
IsMetaClass(interp, class, NSF_TRUE));
/*
* We do not have to reclassing in case, cl is a root-class
*/
if (!IsRootClass(class)) {
Tcl_HashTable *instanceTablePtr = &class->instances;
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(instanceTablePtr, &hSrch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
NsfObject *inst = (NsfObject *)Tcl_GetHashKey(instanceTablePtr, 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 != NULL)
&& (inst != (NsfObject *)class)
&& likely((inst->flags & NSF_DURING_DELETE) == 0u) /*inst->id*/
) {
if (inst != &(baseClass->object)) {
AddInstance(inst, baseClass);
}
}
}
}
Tcl_DeleteHashTable(&class->instances);
MEM_COUNT_FREE("Tcl_InitHashTable", &class->instances);
}
if (clopt != NULL && !recreate) {
FREE(NsfClassOpt, clopt);
class->opt = NULL;
}
if (subClasses != NULL) {
/*
* 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.
*/
FlushPrecedences(subClasses);
NsfClassListFree(subClasses);
}
while (class->super != NULL) {
(void)RemoveSuper(class, class->super->cl);
}
if (!softrecreate) {
/*
* Flush all caches, unlink superClasses.
*/
while (class->sub != NULL) {
NsfClass *subClass = class->sub->cl;
(void)RemoveSuper(subClass, class);
/*
* If there are no more superclasses add the Object
* class as superClasses
* -> don't do that for Object itself!
*/
if (subClass->super == NULL && !IsRootClass(class)) {
/* fprintf(stderr, "subClass %p %s baseClass %p %s\n",
class, ClassName(class), baseClass, ClassName(baseClass)); */
AddSuper(subClass, baseClass);
}
}
}
}
/*
*----------------------------------------------------------------------
* CleanupInitClass --
*
* Basic initialization of a class, setting namespace, super- and
* subclasses, and setup optionally instances table.
*
* Results:
* None.
*
* Side effects:
* Makes a class structure usable.
*
*----------------------------------------------------------------------
*/
static void CleanupInitClass(
Tcl_Interp *interp, NsfClass *class, Tcl_Namespace *nsPtr,
bool softrecreate, bool recreate
) nonnull(1) nonnull(2) nonnull(3);
static void
CleanupInitClass(
Tcl_Interp *interp, NsfClass *class, Tcl_Namespace *nsPtr,
bool softrecreate, bool recreate
) {
NsfClass *defaultSuperclass;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(nsPtr != NULL);
assert((softrecreate) ? recreate : NSF_TRUE);
#ifdef OBJDELETION_TRACE
fprintf(stderr, "+++ CleanupInitClass\n");
#endif
/*
* Record, that cl is a class and set its namespace
*/
NsfObjectSetClass((NsfObject *)class);
class->nsPtr = nsPtr;
if (!softrecreate) {
/*
* Subclasses are preserved during recreate, superClasses not (since the
* creation statement defined the superclass, might be different the
* second time).
*/
class->sub = NULL;
}
class->super = NULL;
/*
* We can the default superclass from the metaclass, if this exists.
*/
if (class->object.cl != NULL) {
/*
* Look for a configured default superclass.
*/
defaultSuperclass = DefaultSuperClass(interp, class, class->object.cl, NSF_FALSE);
} else {
defaultSuperclass = NULL;
}
if (class != defaultSuperclass) {
AddSuper(class, defaultSuperclass);
}
class->color = WHITE;
class->order = NULL;
if (!softrecreate) {
Tcl_InitHashTable(&class->instances, TCL_ONE_WORD_KEYS);
MEM_COUNT_ALLOC("Tcl_InitHashTable", &class->instances);
}
if (!recreate) {
class->opt = NULL;
}
}
/*
*----------------------------------------------------------------------
* PrimitiveCDestroy --
*
* Delete a class with its namespace and associated data structures. The
* physical deallocation is handled by PrimitiveODestroy().
*
* Results:
* None.
*
* Side effects:
* Free object contents.
*
*----------------------------------------------------------------------
*/
static void
PrimitiveCDestroy(ClientData clientData) {
NsfClass *class;
nonnull_assert(clientData != NULL);
class = (NsfClass *)clientData;
PRINTOBJ("PrimitiveCDestroy", &class->object);
/*
* Check and latch against recurrent calls with obj->teardown
*/
if (class != NULL && class->object.teardown != NULL) {
Tcl_Interp *interp;
interp = class->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)) {
Tcl_Namespace *saved;
/*
* Call and latch user destroy with object->id if we haven't
*/
/*fprintf(stderr, "PrimitiveCDestroy %s flags %.6x\n", ObjectName(object), object->flags);*/
class->object.teardown = NULL;
CleanupDestroyClass(interp, class, NSF_FALSE, NSF_FALSE);
/*
* handoff the primitive teardown
*/
saved = class->nsPtr;
class->object.teardown = interp;
/*
* class object destroy + physical destroy
*/
PrimitiveODestroy(clientData);
/*fprintf(stderr, "primitive cdestroy calls delete namespace for obj %p, nsPtr %p flags %.6x\n",
cl, saved, ((Namespace *)saved)->flags);*/
Nsf_DeleteNamespace(interp, saved);
/*fprintf(stderr, "primitive cdestroy %p DONE\n", class);*/
}
}
return;
}
/*
*----------------------------------------------------------------------
* PrimitiveCInit --
*
* Set/reset a class to a fresh, un-destroyed state
*
* Results:
* A standard Tcl result.
*
* Side effects:
* initializing object structure
*
*----------------------------------------------------------------------
*/
static void PrimitiveCInit(NsfClass *class, Tcl_Interp *interp, const char *name)
nonnull(1) nonnull(2) nonnull(3);
static void
PrimitiveCInit(NsfClass *class, Tcl_Interp *interp, const char *name) {
Tcl_CallFrame frame, *framePtr = &frame;
nonnull_assert(class != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
/*
* Ensure that namespace is newly created during CleanupInitClass. Kill it,
* if it exists already
*/
if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr,
RUNTIME_STATE(interp)->NsfClassesNS, 0) == TCL_OK) {
Tcl_Namespace *nsPtr;
nsPtr = NSGetFreshNamespace(interp, &class->object, name);
Tcl_PopCallFrame(interp);
CleanupInitClass(interp, class, nsPtr, NSF_FALSE, NSF_FALSE);
}
return;
}
/*
*----------------------------------------------------------------------
* PrimitiveCCreate --
*
* Allocate memory for a class, initialize the class specific data
* structure (e.g. class namespace) and call PrimitiveOCreate() for the
* object specific initialization.
*
* Results:
* NsfClass*
*
* Side effects:
* Allocating memory
*
*----------------------------------------------------------------------
*/
static NsfClass *PrimitiveCCreate(
Tcl_Interp *interp, Tcl_Obj *nameObj,
Tcl_Namespace *parentNsPtr, NsfClass *metaClass
) nonnull(1) nonnull(2) returns_nonnull;
static NsfClass *
PrimitiveCCreate(
Tcl_Interp *interp, Tcl_Obj *nameObj,
Tcl_Namespace *parentNsPtr, NsfClass *metaClass
) {
Tcl_Namespace *nsPtr;
const char *nameString;
NsfObject *object;
NsfClass *class;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
class = (NsfClass *)ckalloc((int)sizeof(NsfClass));
nameString = ObjStr(nameObj);
object = (NsfObject *)class;
#if defined(NSFOBJ_TRACE)
fprintf(stderr, "CKALLOC Class %p %s\n", (void *)class, nameString);
#endif
memset(class, 0, sizeof(NsfClass));
MEM_COUNT_ALLOC("NsfObject/NsfClass", class);
/*
* Pass object system from metaclass.
*/
if (metaClass != NULL) {
class->osPtr = metaClass->osPtr;
}
assert(isAbsolutePath(nameString));
/*
fprintf(stderr, "Class alloc %p '%s'\n", cl, nameString);
*/
nsPtr = NSCheckNamespace(interp, nameString, parentNsPtr);
if (nsPtr != NULL) {
NSNamespacePreserve(nsPtr);
}
#if defined(NRE)
object->id = TCL_NRCREATECOMMAND(interp, nameString,
NsfObjDispatch,
NsfObjDispatchNRE,
class, TclDeletesObject);
#else
object->id = TCL_CREATEOBJCOMMAND(interp, nameString, NsfObjDispatch,
class, TclDeletesObject);
#endif
PrimitiveOInit(object, interp, nameString, nsPtr, metaClass);
if (nsPtr != NULL) {
NSNamespaceRelease(nsPtr);
}
object->cmdName = nameObj;
INCR_REF_COUNT(object->cmdName);
PrimitiveCInit(class, interp, nameString+2);
ObjTrace("PrimitiveCCreate", object);
return class;
}
/*
*----------------------------------------------------------------------
* ChangeClass --
*
* Change class of a Next Scripting object. This function takes
* care that one tries not to change an object into a class or vice
* versa. Changing metaclass to metaclass, or class to class, or
* object to object is fine, but upgrading/downgrading is not
* allowed.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Changes class of object if possible and updates instance relation.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static int ChangeClass(Tcl_Interp *interp, NsfObject *object, NsfClass *class)
nonnull(1) nonnull(2) nonnull(3);
NSF_INLINE static int
ChangeClass(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(class != NULL);
NsfInstanceMethodEpochIncr("ChangeClass");
/*fprintf(stderr, "changing %s to class %s ismeta %d\n",
ObjectName(object), ClassName(class),
IsMetaClass(interp, cl, NSF_TRUE));*/
if (class != object->cl) {
if (IsMetaClass(interp, class, NSF_TRUE)) {
/*
* Do not allow upgrading from a class to a metaclass (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, NSF_TRUE)) {
return NsfPrintError(interp, "cannot turn object into a class");
}
} else {
/*
* The target class is not a metaclass.
*/
/*fprintf(stderr, "target class %s not a metaclass, am i a class %d\n",
ClassName(class), NsfObjectIsClass(object) );*/
if (NsfObjectIsClass(object)) {
return NsfPrintError(interp, "cannot turn class into an object ");
}
}
RemoveInstance(object, object->cl);
AddInstance(object, class);
MixinComputeDefined(interp, object);
FilterComputeDefined(interp, object);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* DoObjInitialization --
*
* Perform the object initialization: first call "configure" and the
* constructor "init", if not called already from configure. The function
* will make sure that the called methods do not change the result passed
* into this function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Indirect effects by calling Tcl code
*
*----------------------------------------------------------------------
*/
static int DoObjInitialization(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(4);
static int
DoObjInitialization(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
Tcl_Obj *methodObj, *savedObjResult;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(objv != NULL);
assert(objc >= 0);
#if 0
{ int i;
fprintf(stderr, "DoObjInitialization objc %d: ", objc);
for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
fprintf(stderr, "\n");
}
#endif
/*
* Save the result we have so far to return it in case of success
*/
savedObjResult = Tcl_GetObjResult(interp);
INCR_REF_COUNT(savedObjResult);
/*
* clear INIT_CALLED flag
*/
object->flags &= ~NSF_INIT_CALLED;
/*
* Make sure, the object survives initialization; the cmd/initcmd might
* destroy it.
*/
NsfObjectRefCountIncr(object);
/*
* Call configure method
*/
if (CallDirectly(interp, object, NSF_o_configure_idx, &methodObj)) {
NSF_PROFILE_TIME_DATA;
if (methodObj == NULL) {
methodObj = NsfGlobalObjs[NSF_CONFIGURE];
}
assert(methodObj != NULL);
/*
* The methodObj is just used for error reporting.
*/
NSF_PROFILE_CALL(interp, object, ObjStr(methodObj));
result = NsfOConfigureMethod(interp, object, objc, objv, methodObj);
NSF_PROFILE_EXIT(interp, object, ObjStr(methodObj));
} else {
result = CallMethod(object, interp, methodObj, objc+2, objv, NSF_CSC_IMMEDIATE);
}
if (likely(result == TCL_OK)) {
/*
* Call constructor when needed
*/
if ((object->flags & (NSF_INIT_CALLED|NSF_DESTROY_CALLED)) == 0u) {
result = DispatchInitMethod(interp, object, 0, NULL, 0u);
}
if (likely(result == TCL_OK)) {
Tcl_SetObjResult(interp, savedObjResult);
}
} else {
/*
* Configure failed and might have left the object in a bogus state. To
* avoid strange errors, we delete the half-baked object.
*/
Tcl_Obj *errObj;
/*
* Preserve the outer error message, calls triggered by
* DispatchDestroyMethod() can cause the interp result to be reset
*/
errObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(errObj);
DispatchDestroyMethod(interp, (NsfObject *)object, 0u);
Tcl_SetObjResult(interp, errObj);
DECR_REF_COUNT(errObj);
}
NsfCleanupObject(object, "obj init");
DECR_REF_COUNT(savedObjResult);
return result;
}
/*
*----------------------------------------------------------------------
* IsRootMetaClass --
*
* Check, of the class has the root metaclass flag set.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool
IsRootMetaClass(const NsfClass *class) {
nonnull_assert(class != NULL);
return ((class->object.flags & NSF_IS_ROOT_META_CLASS) != 0u);
}
/*
*----------------------------------------------------------------------
* IsBaseClass --
*
* Check, whether the object is a base class.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool
IsBaseClass(const NsfObject *object) {
nonnull_assert(object != NULL);
return ((object->flags & (NSF_IS_ROOT_CLASS|NSF_IS_ROOT_META_CLASS)) != 0u);
}
/*
*----------------------------------------------------------------------
* IsRootClass --
*
* Check, whether the object is a root-class.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool
IsRootClass(const NsfClass *class) {
nonnull_assert(class != NULL);
return ((class->object.flags & (NSF_IS_ROOT_CLASS)) != 0u);
}
/*
*----------------------------------------------------------------------
* IsMetaClass --
*
* Check, whether the object is a metaclass. Optionally, mixins are
* checked as well.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool
IsMetaClass(Tcl_Interp *interp, NsfClass *class, bool withMixins) {
NsfClasses *pl;
bool result = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
/*
* Is the class the most general metaclass?
*/
if (IsRootMetaClass(class)) {
return NSF_TRUE;
}
/*
* Is the class a subclass of a metaclass?
*/
for (pl = PrecedenceOrder(class); pl != NULL; pl = pl->nextPtr) {
if (IsRootMetaClass(pl->cl)) {
return NSF_TRUE;
}
}
if (withMixins) {
NsfClasses *checkList = NULL, *mixinClasses = NULL, *mc;
/*
* Has the class metaclass mixed in?
*/
NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
for (mc = mixinClasses; mc != NULL; mc = mc->nextPtr) {
if (IsMetaClass(interp, mc->cl, NSF_FALSE)) {
result = NSF_TRUE;
break;
}
}
if (mixinClasses != NULL) {
NsfClassListFree(mixinClasses);
}
if (checkList != NULL) {
NsfClassListFree(checkList);
}
/*fprintf(stderr, "has MC returns %d, mixinClasses = %p\n",
result, mixinClasses);*/
}
return result;
}
/*
*----------------------------------------------------------------------
* IsSubType --
*
* Check, whether a class is a subclass of another class.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool
IsSubType(NsfClass *subClass, const NsfClass *class) {
bool result;
nonnull_assert(subClass != NULL);
nonnull_assert(class != NULL);
if (class != subClass) {
result = (NsfClassListFind(PrecedenceOrder(subClass), class) != NULL);
} else {
result = NSF_TRUE;
}
return result;
}
/*
*----------------------------------------------------------------------
* HasMixin --
*
* Check, whether the specified object the specified class as mixin.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool HasMixin(Tcl_Interp *interp, NsfObject *object, NsfClass *class)
nonnull(1) nonnull(2) nonnull(3);
static bool
HasMixin(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(class != NULL);
if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
}
if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
NsfCmdList *ml;
for (ml = object->mixinOrder; ml != NULL; ml = ml->nextPtr) {
NsfClass *mixinClass = NsfGetClassFromCmdPtr(ml->cmdPtr);
if (mixinClass == class) {
return NSF_TRUE;
}
}
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* ImportInstVarIntoCurrentScope --
*
* Import an instance variable into the current variable scope
* (e.g. function scope).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ImportInstVarIntoCurrentScope(Tcl_Interp *interp, const char *cmdName, NsfObject *object,
Tcl_Obj *varName, Tcl_Obj *newName)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
ImportInstVarIntoCurrentScope(Tcl_Interp *interp, const char *cmdName, NsfObject *object,
Tcl_Obj *varName, Tcl_Obj *newName) {
Var *otherPtr = NULL, *arrayPtr;
unsigned int flogs = TCL_LEAVE_ERR_MSG;
Tcl_CallFrame *varFramePtr;
CallFrame frame, *framePtr = &frame;
const char *varNameString;
nonnull_assert(interp != NULL);
nonnull_assert(cmdName != NULL);
nonnull_assert(object != NULL);
nonnull_assert(varName != NULL);
if (unlikely(CheckVarName(interp, ObjStr(varName)) != TCL_OK)) {
return TCL_ERROR;
}
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
if (object->nsPtr != NULL) {
flogs = flogs|TCL_NAMESPACE_ONLY;
}
otherPtr = TclObjLookupVar(interp, varName, NULL, (int)flogs, "define",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
Nsf_PopFrameObj(interp, framePtr);
if (unlikely(otherPtr == NULL)) {
return NsfPrintError(interp, "can't import variable %s into method scope: "
"can't find variable on %s",
ObjStr(varName), ObjectName_(object));
}
/*
* 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 != NULL) {
return NsfPrintError(interp, "can't make instance variable %s on %s: "
"Variable cannot be an element in an array; use e.g. an alias.",
ObjStr(varName), ObjectName_(object));
}
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 != NULL && (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_PROC)) {
Var *varPtr = (Var *)CompiledLocalsLookup((CallFrame *)varFramePtr, varNameString);
int new = 0;
if (varPtr == NULL) {
/*
* Look in frame's local var hash-table.
*/
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 ImportInstVarIntoCurrentScope\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 == 0) {
/*fprintf(stderr, "GetIntoScope create alias\n");*/
if (unlikely(varPtr == otherPtr)) {
return NsfPrintError(interp, "can't instvar to variable itself");
}
if (TclIsVarLink(varPtr)) {
/*
* We try to make the same instvar again ... this is ok
*/
Var *linkPtr = TclVarValue(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 (unlikely(TclIsVarUndefined(varPtr) == 0)) {
return NsfPrintError(interp, "varName '%s' exists already", varNameString);
} else if (unlikely(TclIsVarTraced(varPtr) != 0)) {
return NsfPrintError(interp, "varName '%s' has traces: can't use for instvar", varNameString);
}
}
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 NsfPrintError(interp, "%s cannot import variable '%s' into method scope; "
"not called from a method frame", cmdName, varNameString);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* SetInstVar --
*
* Set an instance variable of the specified object to the given value.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Set instance variable.
*
*----------------------------------------------------------------------
*/
static int
SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj, unsigned int flags) {
CallFrame frame, *framePtr = &frame;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(nameObj != NULL);
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
if ((flags & NSF_VAR_TRIGGER_TRACE) != 0u) {
int tclVarFlags;
/*
* The command should trigger traces, use therefore the high-level Tcl_Obj*
* interface.
*/
tclVarFlags = (object->nsPtr != NULL) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG;
if (likely(valueObj == NULL)) {
resultObj = Tcl_ObjGetVar2(interp, nameObj, NULL, tclVarFlags);
} else {
resultObj = Tcl_ObjSetVar2(interp, nameObj, NULL, valueObj, tclVarFlags);
}
} else {
/*
* The command should not trigger traces, use the low-level TclLookupVar()
* interface.
*/
Var *arrayPtr, *varPtr;
if (likely(valueObj == NULL)) {
varPtr = TclLookupVar(interp, ObjStr(nameObj), NULL, TCL_LEAVE_ERR_MSG, "access",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (likely(varPtr != NULL)) {
resultObj = varPtr->value.objPtr;
} else {
resultObj = NULL;
}
} else {
Tcl_Obj *oldValuePtr;
varPtr = TclLookupVar(interp, ObjStr(nameObj), NULL, TCL_LEAVE_ERR_MSG, "access",
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
oldValuePtr = varPtr->value.objPtr;
INCR_REF_COUNT2("SetInstVar", valueObj);
varPtr->value.objPtr = valueObj;
if (oldValuePtr != NULL) {
DECR_REF_COUNT2("SetInstVar", oldValuePtr);
}
resultObj = valueObj;
}
}
Nsf_PopFrameObj(interp, framePtr);
if (likely(resultObj != NULL)) {
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
* SetInstArray --
*
* Set an instance variable array of the specified object to the given
* value. This function performs essentially an "array set" or "array get"
* operation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Set instance variable.
*
*----------------------------------------------------------------------
*/
static int SetInstArray(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arrayNameObj, Tcl_Obj *valueObj)
nonnull(1) nonnull(2) nonnull(3);
static int
SetInstArray(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arrayNameObj, Tcl_Obj *valueObj) {
CallFrame frame, *framePtr = &frame;
int result;
Tcl_Obj *ov[4];
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(arrayNameObj != NULL);
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
ov[0] = NsfGlobalObjs[NSF_ARRAY];
ov[2] = arrayNameObj;
INCR_REF_COUNT(arrayNameObj);
if (valueObj == NULL) {
/*
* Perform an "array get"
*/
ov[1] = NsfGlobalObjs[NSF_GET];
result = Tcl_EvalObjv(interp, 3, ov, 0);
} else {
/*
* Perform an "array set"
*/
ov[1] = NsfGlobalObjs[NSF_SET];
ov[3] = valueObj;
INCR_REF_COUNT(valueObj);
result = Tcl_EvalObjv(interp, 4, ov, 0);
DECR_REF_COUNT(valueObj);
}
DECR_REF_COUNT(arrayNameObj);
Nsf_PopFrameObj(interp, framePtr);
return result;
}
/*
*----------------------------------------------------------------------
* UnsetInstVar --
*
* Unset an instance variable of the specified object.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Variable unset.
*
*----------------------------------------------------------------------
*/
static int
UnsetInstVar(Tcl_Interp *interp, int withNocomplain, NsfObject *object, const char *name) {
CallFrame frame, *framePtr = &frame;
unsigned int flags;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(name != NULL);
flags = (withNocomplain != 0) ? 0 : TCL_LEAVE_ERR_MSG;
if (object->nsPtr != NULL) {
flags |= TCL_NAMESPACE_ONLY;
}
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
result = Tcl_UnsetVar2(interp, name, NULL, (int)flags);
Nsf_PopFrameObj(interp, framePtr);
return (withNocomplain != 0) ? TCL_OK : result;
}
/*
*----------------------------------------------------------------------
* NsfSetterMethod --
*
* This TCL_OBJCMDPROC_T is called, when a setter method is invoked. A setter
* is a method that accesses/modifies a same-named instance variable. If
* the setter is called without arguments, it returns the values, if it is
* called with one argument, the argument is used as new value.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Can set an instance variable.
*
*----------------------------------------------------------------------
*/
static int NsfSetterMethod(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(4);
static int
NsfSetterMethod(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
SetterCmdClientData *cd;
NsfObject *object;
int result;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
cd = (SetterCmdClientData *)clientData;
object = cd->object;
if (objc > 2) {
Tcl_Obj *pathObj = NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 1),
NsfMethodName(objv[0]));
INCR_REF_COUNT(pathObj);
result = NsfObjWrongArgs(interp, "wrong # args", object->cmdName,
pathObj, "?value?");
DECR_REF_COUNT(pathObj);
} else if (object == NULL) {
result = NsfDispatchClientDataError(interp, clientData, "object", ObjStr(objv[0]));
} else {
Tcl_Obj *nameObj;
const char *nameString = ObjStr(objv[0]);
/*
* When the setter method is called with a leading colon, pass plain
* object to SetInstVar(), otherwise we might run into shimmering with
* tclCmds.
*/
if (FOR_COLON_RESOLVER(nameString)) {
nameString ++;
nameObj = Tcl_NewStringObj(nameString, TCL_INDEX_NONE);
INCR_REF_COUNT(nameObj);
} else {
nameObj = objv[0];
}
if (cd->paramsPtr != NULL && objc == 2) {
Tcl_Obj *outObjPtr;
unsigned flags = 0u;
ClientData checkedData;
result = ArgumentCheck(interp, objv[1], cd->paramsPtr,
RUNTIME_STATE(interp)->doCheckArguments,
&flags, &checkedData, &outObjPtr);
if (likely(result == TCL_OK)) {
result = SetInstVar(interp, object, nameObj, outObjPtr, NSF_VAR_TRIGGER_TRACE);
}
if ((flags & NSF_PC_MUST_DECR) != 0u) {
DECR_REF_COUNT2("valueObj", outObjPtr);
}
} else {
result = SetInstVar(interp, object, nameObj, objc == 2 ? objv[1] : NULL, NSF_VAR_TRIGGER_TRACE);
}
if (nameObj != objv[0]) {
DECR_REF_COUNT(nameObj);
}
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfForwardPrintError --
*
* Helper function to print either an error message directly to
* call the forwarder specific callback method specified in
* tcd->onerror. Background: ForwardArg() is called at run time to
* substitute the argument list. Catching such errors is not
* conveniently doable via catch, since it would be necessary to
* wrap every possible usage of a forwarder in a catch. Therefore,
* the callback function can be used to give a sensible error
* message appropriate for each context.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Potential side effects through the script.
*
*----------------------------------------------------------------------
*/
static int
NsfForwardPrintError(Tcl_Interp *interp, ForwardCmdClientData *tcd,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
const char *fmt, ...)
nonnull(1) nonnull(2) nonnull(5) NSF_attribute_format((printf,5,6));
static int
NsfForwardPrintError(Tcl_Interp *interp, ForwardCmdClientData *tcd,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
const char *fmt, ...) {
Tcl_DString ds;
va_list ap;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(tcd != NULL);
nonnull_assert(fmt != NULL);
Tcl_DStringInit(&ds);
va_start(ap, fmt);
NsfDStringVPrintf(&ds, fmt, ap);
va_end(ap);
//fprintf(stderr, "==== DEBUG AppVeyor: error msg<<%s>> (len %d)\n", ds.string, ds.length);
if (tcd->onerror != NULL) {
Tcl_Obj *script = Tcl_DuplicateObj(tcd->onerror);
Tcl_Obj *cmd;
if (tcd->object != NULL) {
cmd = Tcl_DuplicateObj(tcd->object->cmdName);
if (objc > 0) {
Tcl_Obj *methodObjPath = NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 1),
MethodName(objv[0]));
INCR_REF_COUNT(methodObjPath);
Tcl_ListObjAppendList(interp, cmd, methodObjPath);
DECR_REF_COUNT(methodObjPath);
if (objc > 1) {
Tcl_ListObjAppendElement(interp, cmd, Tcl_NewListObj((TCL_SIZE_T)objc-1, objv+1));
}
}
} else {
cmd = Tcl_NewListObj((TCL_SIZE_T)objc, objv);
}
Tcl_ListObjAppendElement(interp, script, cmd);
Tcl_ListObjAppendElement(interp, script,
Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds)));
INCR_REF_COUNT(script);
result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT);
DECR_REF_COUNT(script);
} else {
result = NsfPrintError(interp, "%s", Tcl_DStringValue(&ds));
}
Tcl_DStringFree(&ds);
return result;
}
/*
*----------------------------------------------------------------------
* ForwardArg --
*
* This function is a helper function of NsfForwardMethod() and
* processes a single entry (ForwardArgObj) of the forward
* spec. Essentially, it performs the percent substitution of the
* forward spec.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Updates the provided output arguments.
*
*----------------------------------------------------------------------
*/
static int ForwardArg(
Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Obj *forwardArgObj, ForwardCmdClientData *tcd, Tcl_Obj **out,
Tcl_Obj **freeListObjPtr, TCL_OBJC_T *inputArg, ptrdiff_t *mapvalue,
TCL_OBJC_T firstPosArg, TCL_OBJC_T *outputincr
) nonnull(1) nonnull(3) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8) nonnull(9) nonnull(11);
static int
ForwardArg(
Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[],
Tcl_Obj *forwardArgObj,
ForwardCmdClientData *tcd,
Tcl_Obj **out,
Tcl_Obj **freeListObjPtr,
TCL_OBJC_T *inputArg,
ptrdiff_t *mapvalue,
TCL_OBJC_T firstPosArg,
TCL_OBJC_T *outputincr
) {
const char *ForwardArgString, *p;
int result = TCL_OK;
TCL_OBJC_T totalargs;
char c;
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(forwardArgObj != NULL);
nonnull_assert(tcd != NULL);
nonnull_assert(out != NULL);
nonnull_assert(freeListObjPtr != NULL);
nonnull_assert(inputArg != NULL);
nonnull_assert(mapvalue != NULL);
nonnull_assert(outputincr != NULL);
assert(objc >= 1);
totalargs = objc + tcd->nr_args - 1;
/*
* Per default every ForwardArgString from the processed list corresponds to
* exactly one ForwardArgString in the computed final list.
*/
*outputincr = 1;
ForwardArgString = ObjStr(forwardArgObj);
p = ForwardArgString;
/* fprintf(stderr, "ForwardArg: processing '%s'\n", ForwardArgString);*/
c = *ForwardArgString;
if (c == '%' && *(ForwardArgString+1) == '@') {
char *remainder = NULL;
ptrdiff_t pos;
ForwardArgString += 2;
pos = (ptrdiff_t)strtol(ForwardArgString, &remainder, 0);
if (ForwardArgString == remainder && *ForwardArgString == 'e'
&& !strncmp(ForwardArgString, "end", 3)) {
pos = -1;
remainder += 3;
} else if (pos < 0) {
pos --;
}
if (ForwardArgString == remainder || labs(pos) > (ptrdiff_t)totalargs) {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: invalid index specified in argument %s",
ObjStr(forwardArgObj));
}
if (!remainder || *remainder != ' ') {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: invalid syntax in '%s'; use: %%@ ",
ObjStr(forwardArgObj));
}
ForwardArgString = remainder + 1;
/*
* In case we address from the end, we reduce further to distinguish from
* -1 (void)
*/
if (pos < 0) {
pos--;
}
/*fprintf(stderr, "remainder = '%s' pos = %ld\n", remainder, pos);*/
*mapvalue = pos;
c = *ForwardArgString;
}
if (c == '%') {
Tcl_Obj *listObj = NULL, **listElements = NULL;
TCL_OBJC_T nrArgs = objc-1, nrPosArgs = objc - firstPosArg;
TCL_SIZE_T nrElements = 0;
char c1, *firstActualArgument = nrArgs > 0 ? ObjStr(objv[1]) : NULL;
const char *c1Ptr;
assert(nrPosArgs >= 0);
assert(nrArgs >= 0);
c = *++ForwardArgString;
c1Ptr = ForwardArgString + 1;
c1 = *c1Ptr;
if (c == 's' && !strcmp(ForwardArgString, "self")) {
*out = tcd->object->cmdName;
} else if ((c == 'p' && !strcmp(ForwardArgString, "proc"))
|| (c == 'm' && !strcmp(ForwardArgString, "method"))
) {
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, TCL_INDEX_NONE);
} else {
*out = objv[0];
}
AddObjToTclList(interp, freeListObjPtr, *out);
} else if (c == '1' && (c1 == '\0' || NsfHasTclSpace(c1Ptr))) {
if (c1 != '\0') {
if (unlikely(Tcl_ListObjIndex(interp, forwardArgObj, 1, &listObj) != TCL_OK)) {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: %%1 must be followed by a valid list, given: '%s'",
ObjStr(forwardArgObj));
}
if (unlikely(Tcl_ListObjGetElements(interp, listObj, &nrElements, &listElements) != TCL_OK)) {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: %%1 contains invalid list '%s'",
ObjStr(listObj));
}
} else if (unlikely(tcd->subcommands != NULL)) {
/*
* This is a deprecated part, kept for backwards compatibility.
*/
if (Tcl_ListObjGetElements(interp, tcd->subcommands, &nrElements, &listElements) != TCL_OK) {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: %%1 contains invalid list '%s'",
ObjStr(tcd->subcommands));
}
} else {
assert((TCL_SIZE_T)nrElements <= (TCL_SIZE_T)nrPosArgs);
}
/*fprintf(stderr, "nrElements=%d, nra=%d firstPos %d objc %d\n",
nrElements, nrArgs, firstPosArg, objc);*/
if ((TCL_SIZE_T)nrElements > (TCL_SIZE_T)nrPosArgs) {
/*
* Insert default subcommand depending on number of arguments.
*/
assert(listElements != NULL);
/*fprintf(stderr, "inserting listElements[%d] '%s'\n", nrPosArgs,
ObjStr(listElements[nrPosArgs]));*/
*out = listElements[nrPosArgs];
} else if (objc <= 1) {
result = NsfForwardPrintError(interp, tcd, objc, objv,
"%%1 requires argument; should be \"%s arg ...\"",
ObjStr(objv[0]));
} else {
/*fprintf(stderr, "copying %%1: '%s'\n", ObjStr(objv[firstPosArg]));*/
*out = objv[firstPosArg];
*inputArg = firstPosArg+1;
}
} else if (c == '-') {
const char *firstElementString;
int insertRequired;
bool done = NSF_FALSE;
/*fprintf(stderr, "process flag '%s'\n", firstActualArgument);*/
if (Tcl_ListObjGetElements(interp, forwardArgObj, &nrElements, &listElements) != TCL_OK) {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: '%s' is not a valid list",
ForwardArgString);
}
if (nrElements < 1 || nrElements > 2) {
return NsfForwardPrintError(interp, tcd, objc, objv,
"forward: '%s': must contain 1 or 2 arguments",
ForwardArgString);
}
firstElementString = ObjStr(listElements[0]);
firstElementString++; /* we skip the dash */
if (firstActualArgument && *firstActualArgument == '-') {
TCL_OBJC_T i;
/*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 = NSF_TRUE;
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, TCL_INDEX_NONE);
*outputincr = 1;
AddObjToTclList(interp, freeListObjPtr, *out);
} 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, &listObj) != TCL_OK) {
result = NsfForwardPrintError(interp, tcd, objc, objv,
"forward: %%argclindex must by a valid list, given: '%s'",
ForwardArgString);
} else if (Tcl_ListObjGetElements(interp, listObj, &nrElements, &listElements) != TCL_OK) {
result = NsfForwardPrintError(interp, tcd, objc, objv,
"forward: %%argclindex contains invalid list '%s'",
ObjStr(listObj));
} else if ((TCL_SIZE_T)nrArgs >= (TCL_SIZE_T)nrElements) {
result = NsfForwardPrintError(interp, tcd, objc, objv,
"forward: not enough elements in specified list of ARGC argument %s",
ForwardArgString);
} else {
*out = listElements[nrArgs];
}
} else if (c == '%') {
Tcl_Obj *newarg = Tcl_NewStringObj(ForwardArgString, TCL_INDEX_NONE);
*out = newarg;
AddObjToTclList(interp, freeListObjPtr, *out);
} else {
/*
* Evaluate the given command.
*/
/*fprintf(stderr, "evaluating '%s'\n", ForwardArgString);*/
result = Tcl_EvalEx(interp, ForwardArgString, TCL_INDEX_NONE, 0);
if (likely(result == TCL_OK)) {
*out = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
AddObjToTclList(interp, freeListObjPtr, *out);
/*fprintf(stderr, "result = '%s'\n", ObjStr(*out));*/
}
}
} else {
if (likely(p == ForwardArgString)) {
*out = forwardArgObj;
} else {
Tcl_Obj *newarg = Tcl_NewStringObj(ForwardArgString, TCL_INDEX_NONE);
*out = newarg;
AddObjToTclList(interp, freeListObjPtr, *out);
}
}
return result;
}
/*
*----------------------------------------------------------------------
* CallForwarder --
*
* Invoke the method to which the forwarder points. This function
* receives the already transformed argument vector, calls the
* method and performs error handling.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe through the invoked command.
*
*----------------------------------------------------------------------
*/
static int CallForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(4);
static int
CallForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result;
NsfObject *object;
CallFrame frame, *framePtr = &frame;
nonnull_assert(tcd != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
object = tcd->object;
tcd->object = NULL;
if (unlikely(tcd->verbose)) {
Tcl_Obj *cmd = Tcl_NewListObj((TCL_SIZE_T)objc, objv);
NsfLog(interp, NSF_LOG_DEBUG, "forwarder calls '%s'", ObjStr(cmd));
DECR_REF_COUNT(cmd);
}
if (tcd->frame == FrameObjectIdx) {
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
}
if (tcd->objProc != NULL) {
/*fprintf(stderr, "CallForwarder Tcl_NRCallObjProc %p\n", tcd->clientData);*/
result = TCL_NRCALLOBJPROC(interp, tcd->objProc, tcd->clientData, (TCL_SIZE_T)objc, objv);
} else if (TclObjIsNsfObject(interp, tcd->cmdName, &object)) {
/*fprintf(stderr, "CallForwarder NsfObjDispatch object %s, objc=%d\n",
ObjStr(tcd->cmdName), objc);*/
if (likely(objc > 1)) {
result = ObjectDispatch(object, interp, objc, objv, NSF_CSC_IMMEDIATE);
} else {
result = DispatchDefaultMethod(interp, object, objv[0], NSF_CSC_IMMEDIATE);
}
} else {
/*fprintf(stderr, "CallForwarder: no nsf object %s [0] %s\n", ObjStr(tcd->cmdName), ObjStr(objv[0]));*/
result = Tcl_EvalObjv(interp, (TCL_SIZE_T)objc, objv, 0);
}
if (tcd->frame == FrameObjectIdx) {
Nsf_PopFrameObj(interp, framePtr);
}
#if defined(NSF_FORWARD_WITH_ONERROR)
if (unlikely(result == TCL_ERROR && tcd->onerror != NULL)) {
Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
const char *errorMsg = ObjStr(resultObj);
INCR_REF_COUNT(resultObj);
//fprintf(stderr, "==== DEBUG AppVeyor: calling NsfForwardPrintError with <<%s>> (len %lu)\n",
// errorMsg, (unsigned long)strlen(errorMsg));
result = NsfForwardPrintError(interp, tcd, objc, objv, "%s", errorMsg);
DECR_REF_COUNT(resultObj);
}
#endif
return result;
}
/*
*----------------------------------------------------------------------
* NsfForwardMethod --
*
* This TCL_OBJCMDPROC_T is called, when a forwarder is invoked. It
* performs argument substitution through ForwardArg() and calls
* finally the method, to which the call was forwarded via
* CallForwarder().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe through the invoked command.
*
*----------------------------------------------------------------------
*/
static int NsfForwardMethod(ClientData clientData, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(4);
static int
NsfForwardMethod(ClientData clientData, Tcl_Interp *interp,
TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData;
TCL_OBJC_T inputArg = 1;
int result;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
if (unlikely(!tcd || !tcd->object)) {
return NsfDispatchClientDataError(interp, tcd, "object",
objc > 0 ? ObjStr(objv[0]) : "forwarder");
}
/*
* First, we handle two short cuts for simple cases.
*/
if (tcd->passthrough) {
/*
* This is set for early binding. This means, that the cmd is already
* resolved, we have to care only for objscope.
*/
return CallForwarder(tcd, interp, objc, objv);
} else if (tcd->args == NULL && *(ObjStr(tcd->cmdName)) != '%') {
/*
* We have no args, therefore, we have only to replace the method name
* with the given cmd name.
*/
ALLOC_ON_STACK(Tcl_Obj*, objc, ov);
/*fprintf(stderr, "+++ forwardMethod must subst oc=%d <%s>\n",
objc, ObjStr(tcd->cmdName));*/
memcpy(ov, objv, sizeof(Tcl_Obj *) * (size_t)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;
TCL_OBJC_T outputArg = 0, firstPosArg=1, totalargs = objc + tcd->nr_args + 3, outputincr;
ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV);
{
ALLOC_ON_STACK(ptrdiff_t, totalargs, objvmap);
/*fprintf(stderr, "+++ forwardMethod standard case, allocated %d args, tcd->args %s\n",
totalargs, ObjStr(tcd->args));*/
ov = &OV[1];
if (tcd->needobjmap) {
memset(objvmap, -1, sizeof(ptrdiff_t) * (size_t)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 non-pos args, determine the first positional arg position
* for %1
*/
if (tcd->hasNonposArgs) {
TCL_OBJC_T j;
firstPosArg = objc;
for (j = outputArg; j < objc; j++) {
const char *arg = ObjStr(objv[j]);
if (*arg != '-') {
firstPosArg = j;
break;
}
}
}
if (tcd->args != NULL) {
Tcl_Obj **listElements;
TCL_SIZE_T nrElements;
TCL_OBJC_T j;
/*
* Copy argument list from the definitions.
*/
Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements);
for (j = 0; j < (TCL_OBJC_T)nrElements; j++, outputArg += outputincr) {
if ((result = ForwardArg(interp, objc, objv, listElements[j], tcd,
&ov[outputArg], &freeList, &inputArg,
&objvmap[outputArg],
firstPosArg, &outputincr)) != TCL_OK) {
goto exitforwardmethod;
}
}
}
/*fprintf(stderr, "objc=%d, tcd->nr_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 *) * ((size_t)objc - (size_t)inputArg));
} else {
/*fprintf(stderr, " nothing to copy, objc=%d, inputArg=%d\n", objc, inputArg);*/
}
if (tcd->needobjmap) {
/*
* The objmap can shuffle the argument list. We have to set the
* addressing relative from the end; -2 means last, -3 element before
* last, etc.
*/
TCL_OBJC_T j, max = objc + tcd->nr_args - inputArg;
for (j = 0; j < totalargs; j++) {
if (objvmap[j] < -1) {
/*fprintf(stderr, "must reduct, v=%d\n", objvmap[j]);*/
objvmap[j] = (ptrdiff_t)max + objvmap[j] + 2;
/*fprintf(stderr, "... new value=%d, max = %d\n", objvmap[j], max);*/
}
}
}
objc += outputArg - inputArg;
#if 0
for(j = 0; j < objc; j++) {
/*fprintf(stderr, " ov[%d]=%p, objc=%d\n", j, ov[j], objc);*/
fprintf(stderr, " o[%d]=%p %s (%d),", j, ov[j], ov[j] ? ObjStr(ov[j]) : "NADA", objvmap[j]);
}
fprintf(stderr, "\n");
#endif
if (tcd->needobjmap) {
ptrdiff_t j;
for (j = 0; j < (ptrdiff_t)totalargs; j++) {
Tcl_Obj *tmp;
ptrdiff_t pos = objvmap[j];
ptrdiff_t ii;
if (pos == -1 || pos == j) {
continue;
}
tmp = ov[j];
if (j > pos) {
for(ii = j; ii > pos; ii--) {
/*fprintf(stderr, "...moving right %d to %d\n", ii-1, ii);*/
ov[ii] = ov[ii-1];
objvmap[ii] = objvmap[ii-1];
}
} else {
for(ii = j; ii < pos; ii++) {
/*fprintf(stderr, "...moving left %d to %d\n", ii+1, ii);*/
ov[ii] = ov[ii+1];
objvmap[ii] = objvmap[ii+1];
}
}
/*fprintf(stderr, "...setting at %d -> %s\n", pos, ObjStr(tmp));*/
ov[pos] = tmp;
objvmap[pos] = -1;
}
}
/*
If a prefix is provided, it will be prepended to the 2nd argument. This
allows for avoiding name clashes if the 2nd argument denotes a
subcommand, for example.
Make sure that the prefix is only prepended, if a second argument is
actually available! Otherwise, the requested prefix has no effect.
*/
if (tcd->prefix && objc > 1) {
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; j < objc; j++) {
/*fprintf(stderr, " ov[%d]=%p, objc=%d\n", j, ov[j], objc);*/
fprintf(stderr, " ov[%d]=%p '%s' map=%d\n", j, ov[j], ov[j] ? ObjStr(ov[j]) : "NADA", objvmap[j]);
}
#endif
OV[0] = tcd->cmdName;
result = CallForwarder(tcd, interp, objc, ov);
if (tcd->prefix && objc > 1) {
DECR_REF_COUNT(ov[1]);
}
exitforwardmethod:
if (freeList != NULL) {
DECR_REF_COUNT2("AddObjToTclList", freeList);
}
FREE_ON_STACK(long, objvmap);
}
FREE_ON_STACK(Tcl_Obj*, OV);
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfProcAliasMethod --
*
* Since alias-resolving happens in dispatch, this TCL_OBJCMDPROC_T
* should never be called during normal operations. The only way to
* invoke this could happen via directly calling the handle.
*
* Results:
* Result is always TCL_ERROR (as returned by
* NsfDispatchClientDataError()).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int NsfProcAliasMethod(ClientData clientData,
Tcl_Interp *interp, TCL_OBJC_T UNUSED(ojbc),
Tcl_Obj *const UNUSED(objv[]))
nonnull(1) nonnull(2) nonnull(4);
static int
NsfProcAliasMethod(ClientData clientData,
Tcl_Interp *interp, TCL_OBJC_T UNUSED(ojbc),
Tcl_Obj *const UNUSED(objv[])) {
AliasCmdClientData *tcd;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
tcd = (AliasCmdClientData *)clientData;
return NsfDispatchClientDataError(interp, NULL, "object",
Tcl_GetCommandName(interp, tcd->aliasCmd));
}
/*
*----------------------------------------------------------------------
* NsfObjscopedMethod --
*
* This TCL_OBJCMDPROC_T is called, when an obj-scoped alias is
* invoked.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe through the invoked command.
*
*----------------------------------------------------------------------
*/
static int NsfObjscopedMethod(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(4);
static int
NsfObjscopedMethod(ClientData clientData, Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
AliasCmdClientData *tcd;
NsfObject *object;
CallFrame frame, *framePtr = &frame;
int result;
nonnull_assert(clientData != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
tcd = (AliasCmdClientData *)clientData;
/*fprintf(stderr, "objscopedMethod obj=%p %s, ptr=%p\n", object, ObjectName(object), tcd->objProc);*/
object = tcd->object;
tcd->object = NULL;
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
result = TCL_NRCALLOBJPROC(interp, tcd->objProc, tcd->clientData, (TCL_SIZE_T)objc, objv);
Nsf_PopFrameObj(interp, framePtr);
return result;
}
/*
*----------------------------------------------------------------------
* IsDashArg --
*
* Check, whether the provided argument (pointed to be the index
* isFirstArg) starts with a "-", or is a list starting with a
* "-". The method returns via **methodName the name of the dashed
* argument (without the dash).
*
* Results:
* Enum value dashArgType.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
typedef enum {NO_DASH, SCALAR_DASH, LIST_DASH} dashArgType;
static dashArgType IsDashArg(Tcl_Interp *interp, Tcl_Obj *obj, int isFirstArg, const char **methodName,
TCL_SIZE_T *objcPtr, Tcl_Obj **objvPtr[])
nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6);
static dashArgType
IsDashArg(Tcl_Interp *interp, Tcl_Obj *obj, int isFirstArg, const char **methodName,
TCL_SIZE_T *objcPtr, Tcl_Obj **objvPtr[]) {
const char *flag;
nonnull_assert(interp != NULL);
nonnull_assert(obj != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(objcPtr != NULL);
nonnull_assert(objvPtr != NULL);
if (obj->typePtr == Nsf_OT_listType) {
if (Tcl_ListObjGetElements(interp, obj, objcPtr, objvPtr) == TCL_OK && *objcPtr > 1) {
flag = ObjStr(*objvPtr[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' isFirstArg %d\n", flag, isFirstArg);*/
if ((*flag == '-') && CHARTYPE(alpha, *((flag)+1)) != 0) {
if (isFirstArg == 1) {
/*
* If the argument contains a space, try to split.
*/
const char *p = flag+1;
while (*p != '\0' && !NsfHasTclSpace(p)) p++;
if (NsfHasTclSpace(p)) {
if (Tcl_ListObjGetElements(interp, obj, objcPtr, objvPtr) == TCL_OK) {
*methodName = ObjStr(*objvPtr[0]);
if (**methodName == '-') {
(*methodName)++ ;
}
return LIST_DASH;
}
}
}
*methodName = flag+1;
*objcPtr = 1;
return SCALAR_DASH;
}
return NO_DASH;
}
/*
*----------------------------------------------------------------------
* CallConfigureMethod --
*
* Call a method identified by a string selector; or provide an
* error message. This dispatcher function records as well
* constructor (init) calls via this interface. The dispatcher is
* used in XOTcl's configure(), interpreting arguments with a
* leading dash as method dispatches. This behavior is now
* implemented in NsfOResidualargsMethod().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Maybe side effects from the called methods.
*
*----------------------------------------------------------------------
*/
static int CallConfigureMethod(Tcl_Interp *interp, NsfObject *object, const char *initString,
const char *methodName,
TCL_OBJC_T argc, Tcl_Obj *const argv[])
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static int
CallConfigureMethod(Tcl_Interp *interp, NsfObject *object, const char *initString,
const char *methodName,
TCL_OBJC_T argc, Tcl_Obj *const argv[]) {
int result;
Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, TCL_INDEX_NONE);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(initString != NULL);
nonnull_assert(methodName != NULL);
/*
* When configure gets "-init" passed, we call "init" and notice the fact it
* in the object's flags.
*/
if (*initString == *methodName && strcmp(methodName, initString) == 0) {
object->flags |= NSF_INIT_CALLED;
}
Tcl_ResetResult(interp);
INCR_REF_COUNT(methodObj);
result = CallMethod(object, interp, methodObj, argc, argv,
NSF_CM_NO_UNKNOWN|NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
DECR_REF_COUNT(methodObj);
/*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d %d\n",
methodName, argc+1, object, result, TCL_ERROR);*/
if (unlikely(result != TCL_OK)) {
Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */
INCR_REF_COUNT(res);
NsfPrintError(interp, "%s during '%s.%s'", ObjStr(res), ObjectName_(object), methodName);
DECR_REF_COUNT(res);
}
return result;
}
/*
* class method implementations
*/
/*
*----------------------------------------------------------------------
* IsRootNamespace --
*
* Check whether the provided namespace is the namespace of the base
* class of an object system.
*
* Results:
* Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool IsRootNamespace(const Tcl_Interp *interp, const Tcl_Namespace *nsPtr)
nonnull(1) nonnull(2) NSF_pure;
static bool
IsRootNamespace(const Tcl_Interp *interp, const Tcl_Namespace *nsPtr) {
const NsfObjectSystem *osPtr;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
const Tcl_Command cmd = osPtr->rootClass->object.id;
if ((Tcl_Namespace *)((Command *)cmd)->nsPtr == nsPtr) {
return NSF_TRUE;
}
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* CallingNameSpace --
*
* Find the last invocation outside the Next Scripting system
* namespaces. This function return the namespace of the caller but
* skips system-specific namespaces (e.g. the namespaces of the
* pre-defined slot handlers for mixin and class
* registration. etc.) If we would use such namespaces, we would
* resolve non-fully-qualified names against the root namespace).
*
* Results:
* Tcl_Namespace or NULL
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Namespace *
CallingNameSpace(Tcl_Interp *interp) {
Tcl_CallFrame *framePtr;
Tcl_Namespace *nsPtr = NULL;
nonnull_assert(interp != NULL);
/*NsfShowStack(interp);*/
framePtr = CallStackGetActiveProcFrame((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp));
/* framePtr = BeginOfCallChain(interp, GetSelfObj(interp));*/
for (; likely(framePtr != NULL); 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 == NULL) {
nsPtr = Tcl_GetGlobalNamespace(interp);
}
/*fprintf(stderr, " **** CallingNameSpace: returns %p %s framePtr %p\n",
nsPtr, (nsPtr != NULL) ? nsPtr->fullName:"(null)", framePtr);*/
return nsPtr;
}
/***********************************
* argument handling
***********************************/
static void ArgumentResetRefCounts(const struct Nsf_Param *pPtr, Tcl_Obj *valueObj)
nonnull(1) nonnull(2);
static void
ArgumentResetRefCounts(const struct Nsf_Param *pPtr, Tcl_Obj *valueObj) {
nonnull_assert(pPtr != NULL);
nonnull_assert(valueObj != NULL);
if ((pPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) {
DECR_REF_COUNT2("valueObj", valueObj);
}
}
/*
*----------------------------------------------------------------------
* ArgumentCheckHelper --
*
* Helper function for ArgumentCheck() called when argument
* checking leads to a different output element (non-pure
* checking).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ArgumentCheckHelper(Tcl_Interp *interp, Tcl_Obj *objPtr, const struct Nsf_Param *pPtr, unsigned int *flags,
ClientData *clientData, Tcl_Obj **outObjPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6);
static int
ArgumentCheckHelper(Tcl_Interp *interp,
Tcl_Obj *objPtr,
const struct Nsf_Param *pPtr,
unsigned int *flags,
ClientData *clientData,
Tcl_Obj **outObjPtr) {
int result;
TCL_SIZE_T objc, i;
Tcl_Obj **ov;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(flags != NULL);
nonnull_assert(clientData != NULL);
nonnull_assert(outObjPtr != NULL);
assert((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u);
assert((*flags & NSF_PC_MUST_DECR) != 0u);
result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov);
if (unlikely(result != TCL_OK)) {
return result;
}
*outObjPtr = Tcl_NewListObj(0, NULL);
INCR_REF_COUNT2("valueObj", *outObjPtr);
for (i = 0; i < objc; i++) {
Tcl_Obj *elementObjPtr = ov[i];
const char *valueString = ObjStr(elementObjPtr);
if ((pPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u && *valueString == '\0') {
result = Nsf_ConvertToString(interp, elementObjPtr, pPtr, clientData, &elementObjPtr);
} else {
result = (*pPtr->converter)(interp, elementObjPtr, pPtr, clientData, &elementObjPtr);
}
/*fprintf(stderr, "ArgumentCheckHelper convert %s result %d (%s)\n",
valueString, result, ObjStr(elementObjPtr));*/
if (result == TCL_OK || result == TCL_CONTINUE) {
Tcl_ListObjAppendElement(interp, *outObjPtr, elementObjPtr);
/*
* If the refCount of the valueObj was already incremented, we have to
* decrement it here, since we want the valueObj reclaimed when the list
* containing the valueObj is freed.
*/
ArgumentResetRefCounts(pPtr, elementObjPtr);
} else {
Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(resultObj);
NsfPrintError(interp, "invalid value in \"%s\": %s", ObjStr(objPtr), ObjStr(resultObj));
*flags &= ~NSF_PC_MUST_DECR;
*outObjPtr = objPtr;
DECR_REF_COUNT2("valueObj", *outObjPtr);
DECR_REF_COUNT(resultObj);
break;
}
}
return result;
}
/*
*----------------------------------------------------------------------
* ArgumentCheck --
*
* Check a single argument (2nd argument) against the parameter
* structure when argument checking is turned on (default).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, const struct Nsf_Param *pPtr,
unsigned int doCheckArguments,
unsigned int *flags, ClientData *clientData, Tcl_Obj **outObjPtr) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(flags != NULL);
nonnull_assert(clientData != NULL);
nonnull_assert(outObjPtr != NULL);
/*
* Default assumption: outObjPtr is not modified.
*/
*outObjPtr = objPtr;
/*
* Omit argument checking, provided that ...
* ... argument checking is turned off *and* no converter is specified, or
* ... the ruling parameter option is 'cmd'
* ... slotset is active
*/
if ((unlikely((doCheckArguments & NSF_ARGPARSE_CHECK) == 0u) && (pPtr->flags & (NSF_ARG_IS_CONVERTER)) == 0u) ||
((pPtr->flags & (NSF_ARG_CMD)) != 0u) ||
((pPtr->flags & (NSF_ARG_SLOTSET)) != 0u)) {
/* fprintf(stderr, "*** omit argument check for arg %s flags %.6x\n", pPtr->name, pPtr->flags); */
*clientData = ObjStr(objPtr);
return TCL_OK;
}
/*
* If the argument is multivalued, perform the check for every element
* of the list (pure checker), or we have to build a new list of
* values (in case, the converter alters the values).
*/
if (unlikely((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u)) {
TCL_SIZE_T objc, i;
Tcl_Obj **ov;
result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov);
if (unlikely(result != TCL_OK)) {
return result;
}
if (objc == 0 && ((pPtr->flags & NSF_ARG_ALLOW_EMPTY) == 0u)) {
return NsfPrintError(interp,
"invalid value for parameter '%s': list is not allowed to be empty",
pPtr->name);
}
/*
* In cases where necessary (the output element changed), switch to the
* helper function
*/
for (i = 0; i < objc; i++) {
Tcl_Obj *elementObjPtr = ov[i];
result = (*pPtr->converter)(interp, elementObjPtr, pPtr, clientData, &elementObjPtr);
if (likely(result == TCL_OK || result == TCL_CONTINUE)) {
if (ov[i] != elementObjPtr) {
/*fprintf(stderr, "ArgumentCheck: switch to output list construction for value %s\n",
ObjStr(elementObjPtr));*/
/*
* The elementObjPtr differs from the input Tcl_Obj, we switch to
* the version of this handler building an output list. But first,
* we have to reset the ref-counts from the first conversion.
*/
ArgumentResetRefCounts(pPtr, elementObjPtr);
*flags |= NSF_PC_MUST_DECR;
result = ArgumentCheckHelper(interp, objPtr, pPtr, flags, clientData, outObjPtr);
break;
}
} else {
Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(resultObj);
NsfPrintError(interp, "invalid value in \"%s\": %s", ObjStr(objPtr), ObjStr(resultObj));
DECR_REF_COUNT(resultObj);
break;
}
}
} else {
assert(objPtr == *outObjPtr);
if ((pPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u && *(ObjStr(objPtr)) == '\0') {
result = Nsf_ConvertToString(interp, objPtr, pPtr, clientData, outObjPtr);
} else {
result = (*pPtr->converter)(interp, objPtr, pPtr, clientData, outObjPtr);
}
/*fprintf(stderr, "ArgumentCheck param %s type %s is converter %d flags %.6x "
"outObj changed %d (%p %p) isok %d\n",
pPtr->name, pPtr->type, pPtr->flags & NSF_ARG_IS_CONVERTER, pPtr->flags,
objPtr != *outObjPtr, (void*)objPtr, (void*)*outObjPtr, result == TCL_OK);*/
if (unlikely((pPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) && objPtr != *outObjPtr) {
*flags |= NSF_PC_MUST_DECR;
} else {
/*
* If the output obj differs from the input obj, ensure we have
* MUST_DECR set.
*/
assert( (*flags & NSF_PC_MUST_DECR) != 0u || objPtr == *outObjPtr );
}
}
if (unlikely(result == TCL_CONTINUE)) {
*flags |= NSF_ARG_WARN;
result = TCL_OK;
}
return result;
}
/*
*----------------------------------------------------------------------
* ArgumentDefaults --
*
* Process the argument vector and set defaults in parse context if
* provided and necessary.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int ArgumentDefaults(ParseContext *pcPtr, Tcl_Interp *interp,
const Nsf_Param *ifd, TCL_OBJC_T nrParams, unsigned int processFlags)
nonnull(1) nonnull(2) nonnull(3);
static int
ArgumentDefaults(ParseContext *pcPtr, Tcl_Interp *interp,
const Nsf_Param *ifd, TCL_OBJC_T nrParams, unsigned int processFlags) {
const Nsf_Param *pPtr;
TCL_OBJC_T i;
nonnull_assert(pcPtr != NULL);
nonnull_assert(interp != NULL);
nonnull_assert(ifd != NULL);
for (pPtr = ifd, i = 0; i < nrParams; pPtr++, i++) {
/*fprintf(stderr, "ArgumentDefaults got for arg %s (req %d, nrArgs %d) %p => %p %p, default '%s' \n",
pPtr->name, pPtr->flags & NSF_ARG_REQUIRED, pPtr->nrArgs, pPtr,
pcPtr->clientData[i], pcPtr->objv[i],
(pPtr->defaultValue != NULL) ? ObjStr(pPtr->defaultValue) : "NONE");*/
if (pcPtr->objv[i] != NULL) {
/*
* We got an actual value, which was already checked by ArgumentParse().
* In case the value is a switch and NSF_PC_INVERT_DEFAULT is set, we
* take the default and invert the value in place.
*/
if (unlikely((pcPtr->flags[i] & NSF_PC_INVERT_DEFAULT) != 0u)) {
int boolVal;
assert(pPtr->defaultValue != NULL);
Tcl_GetBooleanFromObj(interp, pPtr->defaultValue, &boolVal);
pcPtr->objv[i] = Tcl_NewBooleanObj(boolVal == 0);
/*
* Perform bookkeeping to avoid that someone releases the new obj
* before we are done. The according DECR is performed by
* ParseContextRelease()
*/
INCR_REF_COUNT2("valueObj", pcPtr->objv[i]);
pcPtr->flags[i] |= NSF_PC_MUST_DECR;
pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
}
} else {
/*
* No valued was passed, check whether a default is available.
*/
if (pPtr->defaultValue != NULL) {
int mustDecrNewValue;
Tcl_Obj *newValue = pPtr->defaultValue;
ClientData checkedData;
/*
* We have a default value for the argument. Mark that this argument
* gets the default value.
*/
pcPtr->flags[i] |= NSF_PC_IS_DEFAULT;
/*
* Does the user want to substitute in the default value?
*/
if (unlikely((pPtr->flags & NSF_ARG_SUBST_DEFAULT) != 0u)) {
int tclOptions = 0;
Tcl_Obj *obj;
if ((pPtr->flags & NSF_ARG_SUBST_DEFAULT_VARIABLES) != 0u) {
tclOptions |= TCL_SUBST_VARIABLES;
}
if ((pPtr->flags & NSF_ARG_SUBST_DEFAULT_COMMANDS) != 0u) {
tclOptions |= TCL_SUBST_COMMANDS;
}
if ((pPtr->flags & NSF_ARG_SUBST_DEFAULT_BACKSLASHES) != 0u) {
tclOptions |= TCL_SUBST_BACKSLASHES;
}
/* fprintf(stderr, "SUBST tclOptions %.4x\n", tclOptions);*/
obj = Tcl_SubstObj(interp, newValue, tclOptions);
if (likely(obj != NULL)) {
newValue = obj;
} else {
pcPtr->flags[i] = 0u;
return TCL_ERROR;
}
/*
* The matching DECR is performed by ParseContextRelease().
*/
INCR_REF_COUNT2("valueObj", newValue);
/*fprintf(stderr, "SUBST_DEFAULT increments %p refCount %d\n",
newValue, newValue->refCount);*/
mustDecrNewValue = 1;
pcPtr->flags[i] |= NSF_PC_MUST_DECR;
pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
} 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 & NSF_ARG_INITCMD,
pPtr->type, pPtr->converter);*/
/*
* Check the default value if necessary
*/
if (pPtr->type != NULL || unlikely((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u)) {
unsigned int mustDecrList = 0;
if (unlikely((pPtr->flags & NSF_ARG_INITCMD) == 0u &&
ArgumentCheck(interp, newValue, pPtr,
RUNTIME_STATE(interp)->doCheckArguments,
&mustDecrList, &checkedData, &pcPtr->objv[i]) != TCL_OK)) {
if (mustDecrNewValue == 1) {
DECR_REF_COUNT2("valueObj", newValue);
pcPtr->flags[i] &= ~NSF_PC_MUST_DECR;
}
return TCL_ERROR;
}
if (unlikely(pcPtr->objv[i] != newValue)) {
/*
* The output Tcl_Obj differs from the input, so the Tcl_Obj was
* converted; in case we have set previously the flag
* NSF_PC_MUST_DECR on newValue, we decrement the refCount on
* newValue here and clear the flag.
*/
if (mustDecrNewValue == 1) {
DECR_REF_COUNT2("valueObj", newValue);
pcPtr->flags[i] &= ~NSF_PC_MUST_DECR;
}
/*
* The new output value itself might require a decrement, so set
* the flag here if required; this is just necessary for
* multivalued converted output.
*/
if (mustDecrList == 1) {
pcPtr->flags[i] |= NSF_PC_MUST_DECR;
pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
}
}
} else {
/*fprintf(stderr, "Param %s default %s type %s\n",
pPtr->name, ObjStr(pPtr->defaultValue), pPtr->type);*/
assert((pPtr->type != NULL) ? pPtr->defaultValue == NULL : 1);
}
} else if (unlikely((pPtr->flags & NSF_ARG_REQUIRED) != 0u)
&& ((processFlags & NSF_ARGPARSE_FORCE_REQUIRED) != 0u)) {
Tcl_Obj *paramDefsObj = NsfParamDefsSyntax(interp, ifd, pcPtr->object, NULL);
Tcl_Obj *methodPathObj = NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 1),
MethodName(pcPtr->full_objv[0]));
INCR_REF_COUNT2("methodPathObj", methodPathObj);
NsfPrintError(interp, "required argument '%s' is missing, should be:\n %s%s%s %s",
(pPtr->nameObj != NULL) ? ObjStr(pPtr->nameObj) : pPtr->name,
(pcPtr->object != NULL) ? ObjectName(pcPtr->object) : "", (pcPtr->object != NULL) ? " " : "",
ObjStr(methodPathObj),
ObjStr(paramDefsObj));
DECR_REF_COUNT2("paramDefsObj", paramDefsObj);
DECR_REF_COUNT2("methodPathObj", methodPathObj);
return TCL_ERROR;
} else {
/*
* Use as dummy default value an arbitrary symbol, which must
* not be returned to the Tcl level level; this value is unset
* later typically by NsfUnsetUnknownArgsCmd().
*/
pcPtr->objv[i] = NsfGlobalObjs[NSF___UNKNOWN__];
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* ArgumentParse --
*
* Parse the argument vector based on the parameter definitions.
* The parsed argument vector is returned in a normalized order
* in the parse context.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Nsf_ArgumentParse(
Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
Nsf_Object *object, Tcl_Obj *procNameObj,
const Nsf_Param *paramPtr, TCL_OBJC_T nrParams, int serial,
unsigned int processFlags, Nsf_ParseContext *pcPtr
) {
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(procNameObj != NULL);
nonnull_assert(pcPtr != NULL);
return ArgumentParse(interp, objc, objv, (NsfObject *)object, procNameObj,
paramPtr, nrParams, serial, processFlags,
(ParseContext *)pcPtr);
}
/*
*----------------------------------------------------------------------
* NextParam --
*
* Advance in the parameter definitions and return the next parameter.
*
* Results:
* Next parameter.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const Nsf_Param * NextParam(Nsf_Param const *paramPtr, const Nsf_Param *lastParamPtr)
nonnull(1) nonnull(2) returns_nonnull NSF_pure;
static const Nsf_Param *
NextParam(Nsf_Param const *paramPtr, const Nsf_Param *lastParamPtr) {
nonnull_assert(paramPtr != NULL);
nonnull_assert(lastParamPtr != NULL);
for (; (++paramPtr <= lastParamPtr) && (*paramPtr->name == '-'); );
return paramPtr;
}
/*
*----------------------------------------------------------------------
* ArgumentParse --
*
* Parse the provided list of argument against the given definition. The
* result is returned in the parse context structure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#define SkipNonposParamDefs(cPtr) \
for (; (++(cPtr) <= lastParamPtr) && (*(cPtr)->name == '-'); )
static int
ArgumentParse(
Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[],
NsfObject *object, Tcl_Obj *procNameObj,
const Nsf_Param *paramPtr, TCL_OBJC_T nrParams, int serial,
unsigned int processFlags, ParseContext *pcPtr
) {
TCL_OBJC_T o, fromArg;
bool dashdash = NSF_FALSE;
long j;
const Nsf_Param *currentParamPtr;
const Nsf_Param *lastParamPtr;
nonnull_assert(interp != NULL);
nonnull_assert(procNameObj != NULL);
nonnull_assert(paramPtr != NULL);
nonnull_assert(pcPtr != NULL);
if ((processFlags & NSF_ARGPARSE_START_ZERO) != 0u) {
fromArg = 0;
} else {
fromArg = 1;
}
ParseContextInit(pcPtr, nrParams, object, procNameObj);
#if defined(PARSE_TRACE)
{ const Nsf_Param *pPtr;
fprintf(stderr, "PARAMETER ");
for (o = 0, pPtr = paramPtr; pPtr->name != NULL; o++, pPtr++) {
fprintf(stderr, "[%d]%s (nrargs %d %s) ", o,
pPtr->name, pPtr->nrArgs,
(pPtr->flags & NSF_ARG_REQUIRED) != 0u ? "req" : "opt");
}
fprintf(stderr, "\n");
fprintf(stderr, "BEGIN (%d) [0]%s ", objc, ObjStr(procNameObj));
for (o = fromArg; o < objc; o++) {
Tcl_Obj *obj = objv[o];
if (obj->bytes == NULL) {
fprintf(stderr, "[%d]unk(%s) ", o, obj->typePtr->name);
} else {
fprintf(stderr, "[%d]%s ", o, ObjStr(obj));
}
}
fprintf(stderr, "\n");
}
#endif
currentParamPtr = paramPtr;
lastParamPtr = paramPtr + nrParams - 1;
for (o = fromArg; o < objc; o++) {
const Nsf_Param *pPtr = currentParamPtr;
Tcl_Obj *argumentObj = objv[o], *valueObj = NULL;
const char *valueInArgument = NULL;
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "arg [%d]: %s (param %ld, last %d)\n",
o, ObjStr(argumentObj), currentParamPtr - paramPtr, currentParamPtr == lastParamPtr);
#endif
if (unlikely(currentParamPtr > lastParamPtr)) {
int result;
Tcl_Obj *methodPathObj;
methodPathObj = NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 0),
NsfMethodName(procNameObj));
INCR_REF_COUNT(methodPathObj);
/*fprintf(stderr, "call NsfUnexpectedArgumentError 1\n");*/
result = NsfUnexpectedArgumentError(interp, ObjStr(argumentObj), (Nsf_Object*)object,
paramPtr, methodPathObj);
DECR_REF_COUNT(methodPathObj);
return result;
}
if (*currentParamPtr->name == '-') {
/*
* We expect a non-pos arg. Check whether we a Tcl_Obj already converted
* to NsfFlagObjType.
*/
NsfFlag *flagPtr = argumentObj->internalRep.twoPtrValue.ptr1;
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "... arg %p %s expect non-pos arg in block %s isFlag %d sig %d serial %d (%d => %d)\n",
(void*)argumentObj, ObjStr(argumentObj), currentParamPtr->name,
argumentObj->typePtr == &NsfFlagObjType,
argumentObj->typePtr == &NsfFlagObjType ? flagPtr->signature == paramPtr : 0,
argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial == serial : 0,
argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial : 0,
serial );
#endif
if (argumentObj->typePtr == &NsfFlagObjType
&& flagPtr->signature == paramPtr
&& flagPtr->serial == serial
&& flagPtr->paramPtr != NULL /* when the parameter was previously used in a cget */
) {
/*
* The argument was processed before and the Tcl_Obj is still valid.
*/
if ((flagPtr->flags & NSF_FLAG_DASHDAH) != 0u) {
/*
* We got a dashDash, skip non-pos param definitions and continue with next
* element from objv.
*/
SkipNonposParamDefs(currentParamPtr);
assert(!dashdash);
continue;
} else if ((flagPtr->flags & NSF_FLAG_CONTAINS_VALUE) != 0u) {
/*
* We got a flag with an embedded value (e.g. -flag=1).
*/
valueInArgument = "flag";
}
pPtr = flagPtr->paramPtr;
valueObj = flagPtr->payload;
} else if ((argumentObj->typePtr == Nsf_OT_byteArrayType)
|| (argumentObj->typePtr == Nsf_OT_properByteArrayType)
/*
|| (argumentObj->typePtr == Nsf_OT_intType)
|| (argumentObj->typePtr == Nsf_OT_doubleType)
*/
) {
/*
* The actual argument belongs to the types, for which we assume that
* these can't belong to a non-pos flag. The argument might be e.g. a
* pure Tcl bytearray, for which we do not want to add a string rep
* via ObjStr() such it loses its purity (Tcl 8.6). For these
* argument types. Proceed in the parameter vector to the next block
* (positional parameter)
*/
SkipNonposParamDefs(currentParamPtr);
pPtr = currentParamPtr;
/*
* currentParamPtr is either NULL or points to a positional parameter
*/
assert(currentParamPtr == NULL || currentParamPtr->name == NULL || *currentParamPtr->name != '-');
} else {
const char *argumentString = ObjStr(argumentObj);
/*
* We are in a state, where we expect a non-positional argument, and
* the lookup from the Tcl_Obj has failed. If this non-pos args are
* optional, the current argument might contain also a value for a
* positional argument maybe the argument is for a posarg
* later). First check whether the argument looks like a flag.
*/
if (argumentString[0] != '-') {
/*
* The actual argument is not a flag, so proceed in the parameter
* vector to the next block (positional parameter)
*/
SkipNonposParamDefs(currentParamPtr);
pPtr = currentParamPtr;
/*
* currentParamPtr is either NULL or points to a positional parameter
*/
assert(currentParamPtr == NULL || currentParamPtr->name == NULL || *currentParamPtr->name != '-');
} else {
/*
* The actual argument starts with a dash, so search for the flag in
* the current block of non-pos parameter definitions
*/
char ch1 = *(argumentString+1);
/*
* Is there a "--" ?
*/
if (ch1 == '-' && *(argumentString+2) == '\0' && !dashdash) {
dashdash = NSF_TRUE;
NsfFlagObjSet(interp, argumentObj, paramPtr, serial,
NULL, NULL, NSF_FLAG_DASHDAH);
SkipNonposParamDefs(currentParamPtr);
continue;
}
valueInArgument = strchr(argumentString, '=');
if (valueInArgument != NULL) {
bool found = NSF_FALSE;
long equalOffset = valueInArgument - argumentString;
/*
* Handle parameter like -flag=1
*/
for (; (pPtr <= lastParamPtr) && (*pPtr->name == '-'); pPtr++) {
if (pPtr->nrArgs > 0) {
/*
* Parameter expects no arg, can't be this.
*/
continue;
}
if ((pPtr->flags & NSF_ARG_NOCONFIG) == 0u
&& ch1 == pPtr->name[1]
&& strncmp(argumentString, pPtr->name, (size_t)equalOffset) == 0
&& *(pPtr->name+equalOffset) == '\0') {
valueObj = Tcl_NewStringObj(valueInArgument+1, TCL_INDEX_NONE);
/*fprintf(stderr, "... value from argument = %s\n", ObjStr(valueObj));*/
NsfFlagObjSet(interp, argumentObj, paramPtr, serial,
pPtr, valueObj, NSF_FLAG_CONTAINS_VALUE);
found = NSF_TRUE;
break;
}
}
if (!found) {
const Nsf_Param *nextParamPtr = NextParam(currentParamPtr, lastParamPtr);
if (nextParamPtr > lastParamPtr
|| ((nextParamPtr->flags & NSF_ARG_NODASHALNUM) != 0u)) {
int result;
Tcl_Obj *methodPathObj= NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 0),
NsfMethodName(procNameObj));
INCR_REF_COUNT(methodPathObj);
result = NsfUnexpectedNonposArgumentError(interp, argumentString,
(Nsf_Object *)object,
currentParamPtr, paramPtr,
methodPathObj);
DECR_REF_COUNT(methodPathObj);
return result;
}
pPtr = currentParamPtr = nextParamPtr;
}
} else {
/*
* Must be a classical non-pos arg; check for a matching parameter
* definition.
*/
bool found = NSF_FALSE;
assert(pPtr == currentParamPtr);
if (likely(ch1 != '\0')) {
if (unlikely(NsfParamDefsNonposLookup(interp, argumentString, currentParamPtr, &pPtr) != TCL_OK)) {
return TCL_ERROR;
} else {
if (pPtr != NULL) {
found = NSF_TRUE;
NsfFlagObjSet(interp, argumentObj, paramPtr, serial, pPtr, NULL, 0u);
}
}
}
/*
* We might have found the argument starting with the dash in the
* parameter definitions or not. If it was not found, then we can
* advance to the next positional parameter and stuff the value in
* there, if the parameter definition allows this.
*/
if (!found) {
int nonposArgError = 0;
const Nsf_Param *nextParamPtr = NextParam(currentParamPtr, lastParamPtr);
/*fprintf(stderr, "non-pos-arg '%s' not found, current %p %s last %p %s next %p %s\n",
argumentString,
currentParamPtr, currentParamPtr->name,
lastParamPtr, lastParamPtr->name,
nextParamPtr, nextParamPtr->name);*/
if (nextParamPtr > lastParamPtr) {
nonposArgError = 1;
} else if ((nextParamPtr->flags & NSF_ARG_NODASHALNUM) != 0u) {
/*
* Check whether argument is numeric, since we want to allow it as
* value even when NSF_ARG_NODASHALNUM was specified.
*/
nonposArgError = 1;
if (argumentString[1] >= '0' && argumentString[1] <= '9') {
char *p;
(void)strtod(&argumentString[1], &p);
if (*p == '\0') {
/*
* Argument is numeric.
*/
nonposArgError = 0;
}
}
}
if (nonposArgError != 0) {
int result;
Tcl_Obj *methodPathObj = NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 0),
NsfMethodName(procNameObj));
INCR_REF_COUNT(methodPathObj);
result = NsfUnexpectedNonposArgumentError(interp, argumentString,
(Nsf_Object *)object,
currentParamPtr, paramPtr,
methodPathObj);
DECR_REF_COUNT(methodPathObj);
return result;
}
pPtr = currentParamPtr = nextParamPtr;
}
}
}
/* end of lookup loop */
}
} else {
valueInArgument = NULL;
}
assert(pPtr != NULL);
/*
* "pPtr" points to the actual parameter (part of the currentParamPtr
* block) or might point to a place past the last parameter, in which case
* an unexpected argument was provided. "o" is the index of the actual
* parameter, "valueObj" might be already provided for valueInArgument.
*/
if (unlikely(pPtr > lastParamPtr)) {
int result;
Tcl_Obj *methodPathObj;
methodPathObj = NsfMethodNamePath(interp, CallStackGetTclFrame(interp, NULL, 0),
NsfMethodName(procNameObj));
INCR_REF_COUNT(methodPathObj);
/*fprintf(stderr, "call NsfUnexpectedArgumentError 2\n");*/
result = NsfUnexpectedArgumentError(interp, ObjStr(argumentObj),
(Nsf_Object *)object, paramPtr,
methodPathObj);
DECR_REF_COUNT(methodPathObj);
return result;
}
/*
* Set the position in the downstream argv (normalized order)
*/
j = pPtr - paramPtr;
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "... pPtr->name %s/%d o %d objc %d\n", pPtr->name, pPtr->nrArgs, o, objc);
#endif
if (*pPtr->name == '-') {
/*
* Process the non-pos arg.
*/
if (pPtr->nrArgs == 1) {
/*
* The non-pos arg expects an argument.
*/
o++;
if (unlikely(o >= objc)) {
/*
* We expect an argument, but we are already at the end of the
* argument list.
*/
return NsfPrintError(interp, "value for parameter '%s' expected", pPtr->name);
}
assert(valueObj == NULL);
valueObj = objv[o];
} else {
/*
* The non-pos arg expects no argument.
*/
if (valueObj == NULL) {
valueObj = NsfGlobalObjs[NSF_ONE];
}
}
} else if (unlikely((pPtr == lastParamPtr)
&& (pPtr->converter == ConvertToNothing))) {
/*
* "args" was given, use the varargs interface. Store the actual
* argument into pcPtr->objv. No checking is performed on "args".
*/
pcPtr->varArgs = NSF_TRUE;
pcPtr->objv[j] = argumentObj;
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "... args found o %d objc %d is dashdash %d [%ld] <%s>\n",
o, objc, (int)dashdash, j, ObjStr(argumentObj));
#endif
break;
} else {
/*
* Process an ordinary positional argument.
*/
currentParamPtr ++;
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "... positional arg o %d objc %d, nrArgs %d next paramPtr %s\n",
o, objc, pPtr->nrArgs, currentParamPtr->name);
#endif
if (unlikely(pPtr->nrArgs == 0)) {
/*
* Allow positional arguments with 0 args for object parameter
* aliases, which are always fired. Such parameter are non-consuming,
* therefore the processing of the current argument is not finished, we
* have to decrement o. We have to check here if we are already at the
* end if the parameter vector.
*/
o--;
continue;
}
if (unlikely(dashdash)) {
/*
* Reset dashdash.
*/
dashdash = NSF_FALSE;
}
valueObj = argumentObj;
}
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "... setting parameter %s pos %ld valueObj '%s'\n",
pPtr->name, j,
valueObj == argumentObj ? "=" : ObjStr(valueObj));
#endif
/*
* The value for the flag is now in the valueObj. We
* check, whether it is value is permissible.
*/
assert(valueObj != NULL);
if (unlikely(ArgumentCheck(interp, valueObj, pPtr, processFlags,
&pcPtr->flags[j],
&pcPtr->clientData[j],
&pcPtr->objv[j]) != TCL_OK)) {
if (pcPtr->flags[j] & NSF_PC_MUST_DECR) {
pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
}
return TCL_ERROR;
}
/*
* Switches are more tricky: if the flag is provided without
* valueInArgument, we take the default and invert it. If valueInArgument
* was used, the default inversion must not happen.
*/
if (likely(valueInArgument == NULL)) {
if (unlikely(pPtr->converter == Nsf_ConvertToSwitch)) {
/*fprintf(stderr, "... set INVERT_DEFAULT for '%s' flags %.6x\n",
pPtr->name, pPtr->flags);*/
assert(pPtr->defaultValue != NULL);
pcPtr->flags[j] |= NSF_PC_INVERT_DEFAULT;
}
}
/*fprintf(stderr, "... non-positional pcPtr %p check [%d] obj %p flags %.6x & %p\n",
pcPtr, j, pcPtr->objv[j], pcPtr->flags[j], &(pcPtr->flags[j])); */
/*
* Provide warnings for double-settings.
*/
if (unlikely((pcPtr->flags[j] & NSF_ARG_SET) != 0u)) {
Tcl_Obj *cmdLineObj = Tcl_NewListObj((TCL_SIZE_T)objc-1, objv+1);
INCR_REF_COUNT(cmdLineObj);
NsfLog(interp, NSF_LOG_WARN, "Non-positional parameter %s was passed more than once (%s%s%s %s)",
pPtr->name, (object != NULL) ? ObjectName(object) : "", (object != NULL) ? " method " : "",
ObjStr(procNameObj), ObjStr(cmdLineObj));
DECR_REF_COUNT(cmdLineObj);
}
pcPtr->flags[j] |= NSF_ARG_SET;
/*
* Embed error message of converter in current context.
*/
if (unlikely((pcPtr->flags[j] & NSF_ARG_WARN) != 0u)) {
Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
Tcl_DString ds, *dsPtr = &ds;
Tcl_DStringInit(dsPtr);
INCR_REF_COUNT(resultObj);
NsfDStringArgv(dsPtr, objc, objv);
NsfLog(interp, NSF_LOG_WARN, "%s during:\n%s %s",
ObjStr(resultObj), (object != NULL) ? ObjectName(object) : "nsf::proc", Tcl_DStringValue(dsPtr));
DECR_REF_COUNT(resultObj);
Tcl_DStringFree(dsPtr);
}
if (unlikely((pcPtr->flags[j] & NSF_PC_MUST_DECR) != 0u)) {
pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
}
assert(!pcPtr->varArgs);
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "... iterate on o %d objc %d, currentParamPtr %s\n",
o, objc, currentParamPtr->name);
#endif
}
if ((currentParamPtr <= lastParamPtr) && (!pcPtr->varArgs)) {
/*
* Not all parameter processed, make sure varags is set.
*/
/*fprintf(stderr, ".... not all parameters processed, pPtr '%s' j %ld nrParams %d last '%s' varArgs %d dashdash %d\n",
currentParamPtr->name, currentParamPtr - paramPtr, nrParams, lastParamPtr->name,
pcPtr->varArgs, (int)dashdash);*/
if (lastParamPtr->converter == ConvertToNothing) {
pcPtr->varArgs = NSF_TRUE;
}
}
/*
* Set lastObjc as index of the first "unprocessed" parameter.
*/
pcPtr->lastObjc = o;
pcPtr->objc = nrParams;
/*
* The index "pcPtr->lastObjc-1" can be "-1", which is a problem, when
* called via nsf::parseargs, where the allocated objv array starts at
* position 0. It is fine when just a part of the real objv is passed to
* ArgumentParse().
*
* assert(ISOBJ(objv[pcPtr->lastObjc-1]));
*/
#if defined(PARSE_TRACE_FULL)
fprintf(stderr, "..... argv processed o %d lastObjc %d nrParams %d olastObjc, nrParams, ovarArgs);
#endif
return ArgumentDefaults(pcPtr, interp, paramPtr, nrParams, processFlags);
}
/***********************************
* Begin result setting commands
* (essentially List*() and support
***********************************/
/*
*----------------------------------------------------------------------
* ListVarKeys --
*
* Return variable names of the provided hash table in the interp
* result. Optionally "pattern" might be used to filter the result
* list.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, const char *pattern)
nonnull(1);
static int
ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, const char *pattern) {
const Tcl_HashEntry *hPtr;
nonnull_assert(interp != NULL);
if (pattern != NULL && NoMetaChars(pattern)) {
Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, TCL_INDEX_NONE);
INCR_REF_COUNT(patternObj);
hPtr = (tablePtr != NULL) ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : NULL;
if (hPtr != NULL) {
const Var *val = TclVarHashGetValue(hPtr);
Tcl_SetObjResult(interp, TclVarHashGetKey(val));
} else {
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
}
DECR_REF_COUNT(patternObj);
} else {
Tcl_Obj *list = Tcl_NewListObj(0, NULL);
Tcl_HashSearch hSrch;
hPtr = (tablePtr != NULL) ? Tcl_FirstHashEntry(tablePtr, &hSrch) : NULL;
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
const Var *val = TclVarHashGetValue(hPtr);
Tcl_Obj *key = TclVarHashGetKey(val);
if (pattern == NULL || Tcl_StringMatch(ObjStr(key), pattern)) {
Tcl_ListObjAppendElement(interp, list, key);
}
}
Tcl_SetObjResult(interp, list);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* GetOriginalCommand --
*
* Obtain for an imported/aliased cmd the original definition.
*
* Results:
* Tcl command
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Command
GetOriginalCommand(
Tcl_Command cmd /* The imported command for which the original
* command should be returned.
*/
) {
Tcl_Command importedCmd;
nonnull_assert(cmd != NULL);
while (1) {
AliasCmdClientData *tcd;
/*
* Dereference the namespace import reference chain
*/
if ((importedCmd = TclGetOriginalCommand(cmd))) {
cmd = importedCmd;
}
/*
* Dereference the Next Scripting alias chain
*/
if (Tcl_Command_deleteProc(cmd) == AliasCmdDeleteProc) {
tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd);
/*
fprintf(stderr, "... GetOriginalCommand finds alias %s -> %s\n",
Tcl_GetCommandName(NULL, cmd), Tcl_GetCommandName(NULL, tcd->aliasedCmd));
*/
cmd = tcd->aliasedCmd;
continue;
}
/*
* Dereference the Next Scripting alias chain via potential proc contexts,
* since we identify the alias reference on the AliasCmdDeleteProc.
*/
if (Tcl_Command_deleteProc(cmd) == NsfProcDeleteProc
&& TCL_COMMAND_OBJPROC(cmd) == NsfProcAliasMethod) {
NsfProcContext *ctxPtr = Tcl_Command_deleteData(cmd);
if (ctxPtr->oldDeleteProc == AliasCmdDeleteProc) {
tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd);
/*
fprintf(stderr, "... GetOriginalCommand finds alias via oldDeleteProc %s -> %s (%p -> %p)\n",
Tcl_GetCommandName(NULL, cmd), Tcl_GetCommandName(NULL, tcd->aliasedCmd),
(void*)cmd, (void*)tcd->aliasedCmd );
char *name =Tcl_GetCommandName(NULL, cmd);
if (!strcmp("incr", name)) {char *p = NULL; *p=1;}
*/
cmd = tcd->aliasedCmd;
continue;
}
}
break;
}
return cmd;
}
/*
*----------------------------------------------------------------------
* ListProcBody --
*
* Return the body of a scripted proc as Tcl interp result.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListProcBody(Tcl_Interp *interp, Proc *procPtr)
nonnull(1) nonnull(2);
static int
ListProcBody(Tcl_Interp *interp, Proc *procPtr) {
const char *body;
nonnull_assert(interp != NULL);
nonnull_assert(procPtr != NULL);
body = ObjStr(procPtr->bodyPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), TCL_INDEX_NONE));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* ListParamDefs --
*
* Compute the parameter definition in one of four different forms.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *ListParamDefs(Tcl_Interp *interp, const Nsf_Param *paramsPtr,
NsfObject *contextObject, const char *pattern,
NsfParamsPrintStyle style)
nonnull(1) nonnull(2) returns_nonnull;
static Tcl_Obj *
ListParamDefs(Tcl_Interp *interp, const Nsf_Param *paramsPtr,
NsfObject *contextObject, const char *pattern,
NsfParamsPrintStyle style) {
Tcl_Obj *listObj = NsfGlobalObjs[NSF_EMPTY]; /* enumeration is complete, make stupid checker happy */
nonnull_assert(interp != NULL);
nonnull_assert(paramsPtr != NULL);
switch (style) {
case NSF_PARAMS_PARAMETER: listObj = ParamDefsFormat(interp, paramsPtr, contextObject, pattern); break;
case NSF_PARAMS_LIST: listObj = ParamDefsList(interp, paramsPtr, contextObject, pattern); break;
case NSF_PARAMS_NAMES: listObj = ParamDefsNames(interp, paramsPtr, contextObject, pattern); break;
case NSF_PARAMS_SYNTAX: listObj = NsfParamDefsSyntax(interp, paramsPtr, contextObject, pattern); break;
}
return listObj;
}
/*
*----------------------------------------------------------------------
* ListCmdParams --
*
* Obtains a cmd and a method name. As a side effect, sets the Tcl
* interp result to a list of parameter definitions, if
* available. The print-style NSF_PARAMS_NAMES, NSF_PARAMS_LIST,
* NSF_PARAMS_PARAMETER, NSF_PARAMS_SYNTAX controls the list
* content.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, NsfObject *contextObject,
const char *pattern, const char *methodName, NsfParamsPrintStyle printStyle)
nonnull(1) nonnull(2) nonnull(5);
static int
ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, NsfObject *contextObject,
const char *pattern, const char *methodName, NsfParamsPrintStyle printStyle) {
NsfParamDefs *paramDefs;
Tcl_Obj *listObj;
Proc *procPtr;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmd != NULL);
paramDefs = ParamDefsGet(cmd, NULL, NULL);
if (paramDefs != NULL && paramDefs->paramsPtr != NULL) {
/*
* Obtain parameter info from paramDefs.
*/
listObj = ListParamDefs(interp, paramDefs->paramsPtr, contextObject, pattern, printStyle);
Tcl_SetObjResult(interp, listObj);
DECR_REF_COUNT2("paramDefsObj", listObj);
return TCL_OK;
}
procPtr = GetTclProcFromCommand(cmd);
if (procPtr != NULL) {
/*
* Obtain parameter info from compiled locals.
*/
CompiledLocal *args = procPtr->firstLocalPtr;
listObj = Tcl_NewListObj(0, NULL);
for ( ; args; args = args->nextPtr) {
if (!TclIsCompiledLocalArgument(args)) {
continue;
}
if (pattern != NULL && !Tcl_StringMatch(args->name, pattern)) {
continue;
}
if (printStyle == NSF_PARAMS_SYNTAX && strcmp(args->name, "args") == 0) {
if (args != procPtr->firstLocalPtr) {
Tcl_AppendToObj(listObj, " ", 1);
}
Tcl_AppendToObj(listObj, "?/arg .../?", 11);
} else {
if (printStyle == NSF_PARAMS_SYNTAX) {
/*
* A default means that the argument is optional.
*/
if (args->defValuePtr != NULL) {
Tcl_AppendToObj(listObj, "?", 1);
Tcl_AppendToObj(listObj, args->name, TCL_INDEX_NONE);
Tcl_AppendToObj(listObj, "?", 1);
} else {
Tcl_AppendToObj(listObj, "/", 1);
Tcl_AppendToObj(listObj, args->name, TCL_INDEX_NONE);
Tcl_AppendToObj(listObj, "/", 1);
}
if (args->nextPtr != NULL) {
Tcl_AppendToObj(listObj, " ", 1);
}
} else {
Tcl_Obj *innerListObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, innerListObj, Tcl_NewStringObj(args->name, TCL_INDEX_NONE));
/*
* Return default just for NSF_PARAMS_PARAMETER.
*/
if ((args->defValuePtr != NULL) && (printStyle == NSF_PARAMS_PARAMETER)) {
Tcl_ListObjAppendElement(interp, innerListObj, args->defValuePtr);
}
Tcl_ListObjAppendElement(interp, listObj, innerListObj);
}
}
}
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
{
/*
* If a command is not found for the object|class, check whether we
* find the parameter definitions for the C-defined method.
*/
Nsf_methodDefinition *mdPtr = Nsf_CmdDefinitionGet((TCL_OBJCMDPROC_T*)((Command *)cmd)->objProc);
if (mdPtr != NULL) {
NsfParamDefs localParamDefs = {mdPtr->paramDefs, mdPtr->nrParameters, 1, 0};
Tcl_Obj *list = ListParamDefs(interp, localParamDefs.paramsPtr, contextObject, pattern, printStyle);
Tcl_SetObjResult(interp, list);
DECR_REF_COUNT2("paramDefsObj", list);
return TCL_OK;
}
}
if ((TCL_OBJCMDPROC_T*)((Command *)cmd)->objProc == NsfSetterMethod) {
SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd);
if (cd != NULL && cd->paramsPtr) {
NsfParamDefs localParamDefs;
Tcl_Obj *list;
localParamDefs.paramsPtr = cd->paramsPtr;
/*localParamDefs.nrParams = 1;*/
list = ListParamDefs(interp, localParamDefs.paramsPtr, contextObject, pattern, printStyle);
Tcl_SetObjResult(interp, list);
DECR_REF_COUNT2("paramDefsObj", list);
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(methodName, TCL_INDEX_NONE));
}
return TCL_OK;
}
/*
* In case, we failed so far to obtain a result, try to use the
* object-system implementers definitions in the global array
* ::nsf::parametersyntax. Note that we can only obtain the
* parameter syntax this way.
*/
if (printStyle == NSF_PARAMS_SYNTAX) {
Tcl_DString ds, *dsPtr = &ds;
Tcl_Obj *parameterSyntaxObj;
Tcl_DStringInit(dsPtr);
DStringAppendQualName(dsPtr, Tcl_Command_nsPtr(cmd), methodName);
/*fprintf(stderr, "Looking up ::nsf::parametersyntax(%s) ...\n", Tcl_DStringValue(dsPtr));*/
parameterSyntaxObj = Tcl_GetVar2Ex(interp, NsfGlobalStrings[NSF_ARRAY_PARAMETERSYNTAX],
Tcl_DStringValue(dsPtr), TCL_GLOBAL_ONLY);
/*fprintf(stderr, "No parametersyntax so far methodName %s cmd name %s ns %s\n",
methodName, Tcl_GetCommandName(interp, cmd), Tcl_DStringValue(dsPtr));*/
Tcl_DStringFree(dsPtr);
if (parameterSyntaxObj != NULL) {
Tcl_SetObjResult(interp, parameterSyntaxObj);
return TCL_OK;
}
}
if (TCL_COMMAND_OBJPROC(cmd) == NsfForwardMethod) {
result = NsfPrintError(interp, "could not obtain parameter definition for forwarder '%s'",
methodName);
} else if (CmdIsNsfObject(cmd)) {
/* procPtr == NsfObjDispatch:
Reached for:
... ensemble objects
... plain objects
*/
} else if (TCL_COMMAND_OBJPROC(cmd) == NsfProcStub) {
/*
* Reached for C-implemented Tcl command procs.
*/
} else {
/*
* Reached for other C-implemented command procs.
*/
result = NsfPrintError(interp, "could not obtain parameter definition for method '%s'", methodName);
}
return result;
}
/*
*----------------------------------------------------------------------
* AppendForwardDefinition --
*
* Append the parameters of a forward definition to the specified listObj.
*
* Results:
* None.
*
* Side effects:
* Appending to listObj
*
*----------------------------------------------------------------------
*/
static void AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd)
nonnull(1) nonnull(2) nonnull(3);
static void
AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd) {
nonnull_assert(interp != NULL);
nonnull_assert(listObj != NULL);
nonnull_assert(tcd != NULL);
if (tcd->prefix != NULL) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-prefix", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, listObj, tcd->prefix);
}
if (tcd->subcommands != NULL) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-default", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, listObj, tcd->subcommands);
}
if (tcd->objProc != NULL) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-earlybinding", TCL_INDEX_NONE));
}
if (tcd->frame == FrameObjectIdx) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-frame", 6));
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
}
Tcl_ListObjAppendElement(interp, listObj, tcd->cmdName);
if (tcd->args != NULL) {
Tcl_Obj **args;
TCL_SIZE_T nrArgs, i;
Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args);
for (i = 0; i < nrArgs; i++) {
Tcl_ListObjAppendElement(interp, listObj, args[i]);
}
}
}
/*
*----------------------------------------------------------------------
* AppendMethodRegistration --
*
* Append to the listObj the command words needed for definition /
* registration.
*
* Results:
* None.
*
* Side effects:
* Appending to listObj
*
*----------------------------------------------------------------------
*/
static void AppendMethodRegistration(Tcl_Interp *interp, Tcl_Obj *listObj, const char *registerCmdName,
NsfObject *object, const char *methodName, Tcl_Command cmd,
bool withObjFrame, bool withPer_object, int withProtection)
nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6);
static void
AppendMethodRegistration(Tcl_Interp *interp, Tcl_Obj *listObj, const char *registerCmdName,
NsfObject *object, const char *methodName, Tcl_Command cmd,
bool withObjFrame, bool withPer_object, int withProtection) {
nonnull_assert(interp != NULL);
nonnull_assert(listObj != NULL);
nonnull_assert(registerCmdName != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmd != NULL);
Tcl_ListObjAppendElement(interp, listObj, object->cmdName);
if (withProtection != CallprotectionNULL) {
Tcl_ListObjAppendElement(interp, listObj,
(((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD) != 0)
? Tcl_NewStringObj("private", 7)
: (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CALL_PROTECTED_METHOD) != 0)
? Tcl_NewStringObj("protected", 9)
: Tcl_NewStringObj("public", 6));
}
if (!NsfObjectIsClass(object) || withPer_object) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
}
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(registerCmdName, TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(methodName, TCL_INDEX_NONE));
if (withObjFrame) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-frame", 6));
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
}
if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD) != 0) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-frame", 6));
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("method", 6));
}
}
/*
*----------------------------------------------------------------------
* AppendReturnsClause --
*
* Append to the listObj a returns clause, if it was specified for
* the current cmd.
*
* Results:
* None.
*
* Side effects:
* Appending to listObj
*
*----------------------------------------------------------------------
*/
static void AppendReturnsClause(Tcl_Interp *interp, Tcl_Obj *listObj, Tcl_Command cmd)
nonnull(1) nonnull(2) nonnull(3);
static void
AppendReturnsClause(Tcl_Interp *interp, Tcl_Obj *listObj, Tcl_Command cmd) {
Tcl_Obj *returnsObj;
nonnull_assert(interp != NULL);
nonnull_assert(listObj != NULL);
nonnull_assert(cmd != NULL);
returnsObj = ParamDefsGetReturns(cmd);
if (returnsObj != NULL) {
/* TODO: avoid hard-coding the script-level/NX-specific keyword "-returns" */
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-returns", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, listObj, returnsObj);
}
}
static Tcl_Obj *DisassembleProc(Tcl_Interp *interp, Proc *procPtr,
const char *procName, Namespace *nsPtr)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
static Tcl_Obj *DisassembleProc(Tcl_Interp *interp, Proc *procPtr,
const char *procName, Namespace *nsPtr) {
unsigned int dummy = 0;
Tcl_Obj *byteCodeObj = NULL;
if ((procPtr->bodyPtr->typePtr == Nsf_OT_byteCodeType) ||
(ByteCompiled(interp, &dummy, procPtr, nsPtr, procName) == TCL_OK)) {
Tcl_Obj *ov[3];
ov[0] = NULL;
ov[1] = NsfGlobalObjs[NSF_SCRIPT];
ov[2] = procPtr->bodyPtr;
if ((NsfCallCommand(interp, NSF_DISASSEMBLE, 3, ov) == TCL_OK)) {
byteCodeObj = Tcl_GetObjResult(interp);
}
}
return byteCodeObj;
}
/*
*----------------------------------------------------------------------
* ListMethod --
*
* Construct a command to regenerate the specified method. The
* method might be scripted or not (alias, forwarder, ...). The
* command is returned in the interp result.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListMethod(Tcl_Interp *interp,
NsfObject *regObject,
NsfObject *defObject,
const char *methodName,
Tcl_Command cmd,
InfomethodsubcmdIdx_t subcmd,
NsfObject *contextObject,
const char *pattern,
bool withPer_object)
nonnull(1) nonnull(4) nonnull(5);
static int ListDefinedMethods(Tcl_Interp *interp, NsfObject *object, const char *pattern,
bool withPer_object,
MethodtypeIdx_t methodType,
CallprotectionIdx_t withCallprotection,
bool withPath)
nonnull(1) nonnull(2);
static int
ListMethod(Tcl_Interp *interp,
NsfObject *regObject,
NsfObject *defObject,
const char *methodName,
Tcl_Command cmd,
InfomethodsubcmdIdx_t subcmd,
NsfObject *contextObject,
const char *pattern,
bool withPer_object) {
TCL_OBJCMDPROC_T *objCmdProc;
Proc *procPtr;
bool outputPerObject;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmd != NULL);
assert(*methodName != ':');
Tcl_ResetResult(interp);
if (regObject != NULL && !NsfObjectIsClass(regObject)) {
withPer_object = 1;
/*
* Don't output "object" modifier, if regObject is not a class.
*/
outputPerObject = NSF_FALSE;
} else {
outputPerObject = withPer_object;
}
switch (subcmd) {
case InfomethodsubcmdRegistrationhandleIdx:
{
if (regObject != NULL) {
Tcl_SetObjResult(interp, MethodHandleObj(regObject, withPer_object, methodName));
}
return TCL_OK;
}
case InfomethodsubcmdDefinitionhandleIdx:
{
if (defObject != NULL) {
Tcl_SetObjResult(interp, MethodHandleObj(defObject,
NsfObjectIsClass(defObject) ? withPer_object : 1,
Tcl_GetCommandName(interp, cmd)));
}
return TCL_OK;
}
case InfomethodsubcmdExistsIdx:
{
Tcl_SetObjResult(interp, Tcl_NewIntObj((int)(!CmdIsNsfObject(cmd))));
return TCL_OK;
}
case InfomethodsubcmdArgsIdx:
{
Tcl_Command importedCmd = GetOriginalCommand(cmd);
return ListCmdParams(interp, importedCmd, contextObject, pattern, methodName, NSF_PARAMS_NAMES);
}
case InfomethodsubcmdParameterIdx:
{
Tcl_Command importedCmd = GetOriginalCommand(cmd);
return ListCmdParams(interp, importedCmd, contextObject, pattern, methodName, NSF_PARAMS_PARAMETER);
}
case InfomethodsubcmdReturnsIdx:
{
Tcl_Obj *returnsObj = ParamDefsGetReturns(GetOriginalCommand(cmd));
if (returnsObj != NULL) {
Tcl_SetObjResult(interp, returnsObj);
}
return TCL_OK;
}
case InfomethodsubcmdSyntaxIdx:
{
Tcl_Command importedCmd = GetOriginalCommand(cmd);
return ListCmdParams(interp, importedCmd, contextObject, pattern, methodName, NSF_PARAMS_SYNTAX);
}
case InfomethodsubcmdPreconditionIdx:
#if defined(NSF_WITH_ASSERTIONS)
if (regObject != NULL) {
NsfProcAssertion *procs = NULL;
if (withPer_object == 1) {
if (regObject->opt != NULL && regObject->opt->assertions != NULL) {
procs = AssertionFindProcs(regObject->opt->assertions, methodName);
}
} else {
NsfClass *class = (NsfClass *)regObject;
if (class->opt != NULL && class->opt->assertions != NULL) {
procs = AssertionFindProcs(class->opt->assertions, methodName);
}
}
if (procs != NULL) {
Tcl_SetObjResult(interp, AssertionList(interp, procs->pre));
}
}
#endif
return TCL_OK;
case InfomethodsubcmdPostconditionIdx:
#if defined(NSF_WITH_ASSERTIONS)
if (regObject != NULL) {
NsfProcAssertion *procs = NULL;
if (withPer_object == 1) {
if (regObject->opt != NULL && regObject->opt->assertions != NULL) {
procs = AssertionFindProcs(regObject->opt->assertions, methodName);
}
} else {
NsfClass *class = (NsfClass *)regObject;
if (class->opt != NULL && class->opt->assertions != NULL) {
procs = AssertionFindProcs(class->opt->assertions, methodName);
}
}
if (procs != NULL) {
Tcl_SetObjResult(interp, AssertionList(interp, procs->post));
}
}
#endif
return TCL_OK;
case InfomethodsubcmdSubmethodsIdx:
{
Tcl_Command origCmd = GetOriginalCommand(cmd);
if (CmdIsNsfObject(origCmd)) {
NsfObject *subObject = NsfGetObjectFromCmdPtr(origCmd);
if (subObject != NULL) {
return ListDefinedMethods(interp, subObject, NULL, NSF_TRUE /* per-object */,
NSF_METHODTYPE_ALL, CallprotectionAllIdx, NSF_FALSE);
}
}
/*
* All other cases return empty.
*/
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
return TCL_OK;
}
case InfomethodsubcmdBodyIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdOriginIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdTypeIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDisassembleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
objCmdProc = TCL_COMMAND_OBJPROC(cmd);
procPtr = GetTclProcFromCommand(cmd);
/*
* The subcommands differ per type of method. The converter in
* InfoMethods defines the types:
*
* all|scripted|builtin|alias|forwarder|object|setter|nsfproc
*/
if (procPtr != NULL) {
/*
* A scripted method.
*/
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
if (regObject != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("scripted", TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj("proc", TCL_INDEX_NONE));
}
break;
case InfomethodsubcmdBodyIdx:
ListProcBody(interp, procPtr);
break;
case InfomethodsubcmdDisassembleIdx:
{
Tcl_Namespace *nsPtr;
NsfParamDefs *paramDefs;
paramDefs = ParamDefsGet(cmd, NULL, &nsPtr);
if (paramDefs == NULL || nsPtr == NULL) {
nsPtr = (Tcl_Namespace *)procPtr->cmdPtr->nsPtr;
}
resultObj = DisassembleProc(interp, procPtr, methodName,
(Namespace *)nsPtr);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
}
break;
case InfomethodsubcmdDefinitionIdx:
{
resultObj = Tcl_NewListObj(0, NULL);
/* todo: don't hard-code registering command name "method" / NSF_METHOD */
if (regObject != NULL) {
AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_METHOD],
regObject, methodName, cmd, NSF_FALSE, outputPerObject, 1);
} else {
Tcl_DString ds, *dsPtr = &ds;
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("::proc", TCL_INDEX_NONE));
Tcl_DStringInit(dsPtr);
DStringAppendQualName(dsPtr, Tcl_Command_nsPtr(cmd), methodName);
Tcl_ListObjAppendElement(interp, resultObj,
Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
Tcl_DStringLength(dsPtr)));
Tcl_DStringFree(dsPtr);
}
ListCmdParams(interp, cmd, contextObject, NULL, methodName, NSF_PARAMS_PARAMETER);
Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
AppendReturnsClause(interp, resultObj, cmd);
ListProcBody(interp, procPtr);
Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
#if defined(NSF_WITH_ASSERTIONS)
if (regObject != NULL) {
NsfAssertionStore *assertions;
if (withPer_object == 1) {
assertions = (regObject->opt != NULL) ? regObject->opt->assertions : NULL;
} else {
NsfClass *class = (NsfClass *)regObject;
assertions = (class->opt != NULL) ? class->opt->assertions : NULL;
}
if (assertions != NULL) {
NsfProcAssertion *procs = AssertionFindProcs(assertions, methodName);
if (procs != NULL) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-precondition", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->pre));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-postcondition", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->post));
}
}
}
#endif
Tcl_SetObjResult(interp, resultObj);
break;
}
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdOriginIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
} else if (objCmdProc == NsfForwardMethod) {
/*
* The command is a forwarder.
*/
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_FORWARD]);
break;
case InfomethodsubcmdDefinitionIdx:
if (regObject != NULL) {
ClientData clientData;
clientData = Tcl_Command_objClientData(cmd);
if (clientData != NULL) {
resultObj = Tcl_NewListObj(0, NULL);
/* todo: don't hard-code registering command name "forward" / NSF_FORWARD*/
AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_FORWARD],
regObject, methodName, cmd, NSF_FALSE, outputPerObject, 1);
AppendReturnsClause(interp, resultObj, cmd);
AppendForwardDefinition(interp, resultObj, clientData);
Tcl_SetObjResult(interp, resultObj);
}
}
break;
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdBodyIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdOriginIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDisassembleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
} else if (objCmdProc == NsfSetterMethod) {
/*
* The cmd is one of the setter methods.
*/
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_SETTER]);
break;
case InfomethodsubcmdDefinitionIdx:
if (regObject != NULL) {
SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd);
resultObj = Tcl_NewListObj(0, NULL);
/* todo: don't hard-code registering command name "setter" / NSF_SETTER */
AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_SETTER], regObject,
(cd != NULL && cd->paramsPtr) ? ObjStr(cd->paramsPtr->paramObj) : methodName,
cmd, NSF_FALSE, outputPerObject, 1);
Tcl_SetObjResult(interp, resultObj);
}
break;
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdBodyIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdOriginIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDisassembleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
} else if (objCmdProc == NsfProcStub) {
/*
* Special nsfproc handling:
*/
NsfProcClientData *tcd = Tcl_Command_objClientData(cmd);
if (tcd != NULL && tcd->procName) {
Tcl_Command procCmd = Tcl_GetCommandFromObj(interp, tcd->procName);
Proc *tProcPtr = GetTclProcFromCommand(procCmd);
Tcl_DString ds, *dsPtr = &ds;
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
Tcl_SetObjResult(interp, Tcl_NewStringObj("nsfproc", TCL_INDEX_NONE));
break;
case InfomethodsubcmdBodyIdx:
ListProcBody(interp, tProcPtr);
break;
case InfomethodsubcmdDefinitionIdx:
resultObj = Tcl_NewListObj(0, NULL);
Tcl_DStringInit(dsPtr);
DStringAppendQualName(dsPtr, Tcl_Command_nsPtr(cmd), methodName);
/* don't hardcode names */
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("::nsf::proc", TCL_INDEX_NONE));
if ((tcd->flags & NSF_PROC_FLAG_AD) != 0) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-ad", 3));
}
if (((unsigned int)Tcl_Command_flags(tcd->wrapperCmd) & NSF_CMD_DEBUG_METHOD) != 0) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-debug", 6));
}
if (((unsigned int)Tcl_Command_flags(tcd->wrapperCmd) & NSF_CMD_DEPRECATED_METHOD) != 0) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-deprecated", 11));
}
Tcl_ListObjAppendElement(interp, resultObj,
Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
Tcl_DStringLength(dsPtr)));
ListCmdParams(interp, cmd, NULL, NULL, Tcl_DStringValue(dsPtr), NSF_PARAMS_PARAMETER);
Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
AppendReturnsClause(interp, resultObj, cmd);
ListProcBody(interp, tProcPtr);
Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
Tcl_SetObjResult(interp, resultObj);
Tcl_DStringFree(dsPtr);
break;
case InfomethodsubcmdDisassembleIdx:
resultObj = DisassembleProc(interp, tProcPtr, methodName,
tProcPtr->cmdPtr->nsPtr);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdOriginIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
}
} else if (defObject != NULL) {
/*
* The cmd must be an alias or object.
*
* Note that some aliases come with objCmdProc == NsfObjDispatch. In order
* to distinguish between "object" and alias, we have to do the lookup for
* the entryObj to determine whether it is really an alias.
*/
Tcl_Obj *entryObj;
entryObj = AliasGet(interp, defObject->cmdName,
Tcl_GetCommandName(interp, cmd),
regObject != defObject ? NSF_TRUE : withPer_object, NSF_FALSE);
/*
fprintf(stderr, "aliasGet %s -> %s/%s (%d) returned %p\n",
ObjectName(defObject), methodName, Tcl_GetCommandName(interp, cmd),
withPer_object, entryObj);
fprintf(stderr, "... regObject %p %s\n", regObject, ObjectName(regObject));
fprintf(stderr, "... defObject %p %s\n", defObject, ObjectName(defObject));
*/
if (entryObj != NULL) {
/*
* The entry is an alias.
*/
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_ALIAS]);
break;
case InfomethodsubcmdDefinitionIdx:
if (regObject != NULL) {
TCL_SIZE_T nrElements;
Tcl_Obj **listElements;
resultObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements);
/* todo: don't hard-code registering command name "alias" / NSF_ALIAS */
AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_ALIAS],
regObject, methodName, cmd,
objCmdProc == NsfObjscopedMethod,
outputPerObject, 1);
AppendReturnsClause(interp, resultObj, cmd);
Tcl_ListObjAppendElement(interp, resultObj, listElements[nrElements-1]);
Tcl_SetObjResult(interp, resultObj);
}
break;
case InfomethodsubcmdOriginIdx:
{
TCL_SIZE_T nrElements;
Tcl_Obj **listElements;
Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements);
Tcl_SetObjResult(interp, listElements[nrElements-1]);
break;
}
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdBodyIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDisassembleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
} else {
/*
* Check if the command is and nsfObject to be on the safe side.
*/
if (CmdIsNsfObject(cmd)) {
/*
* The command is an object.
*/
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
Tcl_SetObjResult(interp, Tcl_NewStringObj("object", TCL_INDEX_NONE));
break;
case InfomethodsubcmdDefinitionIdx:
{
NsfObject *subObject = NsfGetObjectFromCmdPtr(cmd);
assert(subObject != NULL);
resultObj = Tcl_NewListObj(0, NULL);
AppendMethodRegistration(interp, resultObj, "create",
&(subObject->cl)->object,
ObjStr(subObject->cmdName), cmd,
NSF_FALSE, NSF_FALSE, 0);
Tcl_SetObjResult(interp, resultObj);
break;
}
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdBodyIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdOriginIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDisassembleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
} else {
/*
* Should never happen.
*
* The warning is just a guess, so we don't raise an error here.
*/
NsfLog(interp, NSF_LOG_WARN, "Could not obtain alias definition for %s. "
"Maybe someone deleted the alias %s for object %s?",
methodName, methodName, ObjectName(regObject));
Tcl_ResetResult(interp);
}
}
} else {
/*
* The cmd must be a plain unregistered cmd
*/
switch (subcmd) {
case InfomethodsubcmdTypeIdx:
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_CMD]);
break;
case InfomethodsubcmdDefinitionIdx:
break;
case InfomethodsubcmdOriginIdx:
break;
case InfomethodsubcmdArgsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdBodyIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDefinitionhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdExistsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdParameterIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPostconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdPreconditionIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdRegistrationhandleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSubmethodsIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdSyntaxIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdDisassembleIdx: ;NSF_FALL_THROUGH; /* fall through */
case InfomethodsubcmdNULL:
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* ListMethodResolve --
*
* Call essentially ListMethod(), but try to resolve the method
* name/handle first.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ListMethodResolve(Tcl_Interp *interp, InfomethodsubcmdIdx_t subcmd,
NsfObject *contextObject, const char *pattern,
Tcl_Namespace *nsPtr, NsfObject *object,
Tcl_Obj *methodNameObj, bool fromClassNS)
nonnull(1) nonnull(7);
static int
ListMethodResolve(Tcl_Interp *interp, InfomethodsubcmdIdx_t subcmd,
NsfObject *contextObject, const char *pattern,
Tcl_Namespace *nsPtr, NsfObject *object,
Tcl_Obj *methodNameObj, bool fromClassNS) {
NsfObject *regObject, *defObject;
const char *methodName1 = NULL;
int result = TCL_OK;
Tcl_DString ds, *dsPtr = &ds;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(methodNameObj != NULL);
Tcl_DStringInit(dsPtr);
cmd = ResolveMethodName(interp, nsPtr, methodNameObj,
dsPtr, ®Object, &defObject, &methodName1, &fromClassNS);
/*
* If the cmd is NOT found, we return empty, unless for the sub-command
* "exists", we return TCL_ERROR.
*/
if (likely(cmd != NULL)) {
result = ListMethod(interp, (regObject != NULL) ? regObject : object, (defObject != NULL) ? defObject : object,
methodName1, cmd, subcmd,
contextObject, pattern, (fromClassNS == 0));
} else if (subcmd == InfomethodsubcmdExistsIdx) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
}
Tcl_DStringFree(dsPtr);
return result;
}
/*
*----------------------------------------------------------------------
* MethodSourceMatches --
*
* Check, whether the provided class or object (mutually exclusive)
* matches with the required method source (typically
* all|application|system).
*
* Results:
* Returns boolean
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool MethodSourceMatches(DefinitionsourceIdx_t withSource, NsfClass *class, NsfObject *object) NSF_pure;
static bool
MethodSourceMatches(DefinitionsourceIdx_t withSource, NsfClass *class, NsfObject *object) {
bool result;
if (withSource == DefinitionsourceAllIdx) {
result = NSF_TRUE;
} else if (class == NULL) {
/*
* If the method is object specific, it can't be from a baseclass and must
* be application specific.
*/
assert(object != NULL);
result = (withSource == DefinitionsourceApplicationIdx && !IsBaseClass(object));
} else {
bool isBaseClass;
assert(class != NULL);
isBaseClass = IsBaseClass(&class->object);
if (withSource == DefinitionsourceSystemIdx && isBaseClass) {
result = NSF_TRUE;
} else if (withSource == DefinitionsourceApplicationIdx && !isBaseClass) {
result = NSF_TRUE;
} else {
result = NSF_FALSE;
}
}
return result;
}
/*
*----------------------------------------------------------------------
* MethodTypeMatches --
*
* Check, whether the provided method (specified as a cmd) matches
* with the required method type (typically
* all|scripted|builtin|alias|forwarder|object|setter).
*
* Results:
* Returns Boolean value
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool MethodTypeMatches(Tcl_Interp *interp, MethodtypeIdx_t methodType, Tcl_Command cmd,
NsfObject *object, const char *methodName, int withPer_object,
bool *isObject)
nonnull(1) nonnull(3) nonnull(5) nonnull(7);
static bool
MethodTypeMatches(Tcl_Interp *interp, MethodtypeIdx_t methodType, Tcl_Command cmd,
NsfObject *object, const char *methodName, int withPer_object,
bool *isObject) {
TCL_OBJCMDPROC_T *proc;
Tcl_Command importedCmd;
nonnull_assert(interp != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(isObject != NULL);
proc = TCL_COMMAND_OBJPROC(cmd);
importedCmd = GetOriginalCommand(cmd);
/*
* Return always state isObject, since the cmd might be an ensemble,
* where we have to search further.
*/
*isObject = CmdIsNsfObject(importedCmd);
if (methodType == NSF_METHODTYPE_ALIAS) {
if (!(proc == NsfProcAliasMethod
|| AliasGet(interp, object->cmdName, methodName, withPer_object, NSF_FALSE))
) {
return NSF_FALSE;
}
} else {
TCL_OBJCMDPROC_T *resolvedProc;
if (proc == NsfProcAliasMethod) {
if ((methodType & NSF_METHODTYPE_ALIAS) == 0) {
return NSF_FALSE;
}
}
resolvedProc = TCL_COMMAND_OBJPROC(importedCmd);
/*
* The following cases are disjoint.
*/
if (CmdIsProc(importedCmd)) {
/*fprintf(stderr, "%s scripted %d\n", methodName, methodType & NSF_METHODTYPE_SCRIPTED);*/
if ((methodType & NSF_METHODTYPE_SCRIPTED) == 0) {
return NSF_FALSE;
}
} else if (resolvedProc == NsfForwardMethod) {
if ((methodType & NSF_METHODTYPE_FORWARDER) == 0) {
return NSF_FALSE;
}
} else if (resolvedProc == NsfSetterMethod) {
if ((methodType & NSF_METHODTYPE_SETTER) == 0) {
return NSF_FALSE;
}
} else if (*isObject) {
if ((methodType & NSF_METHODTYPE_OBJECT) == 0) {
return NSF_FALSE;
}
} else if (resolvedProc == NsfProcStub) {
if ((methodType & NSF_METHODTYPE_NSFPROC) == 0) {
return NSF_FALSE;
}
} else if ((methodType & NSF_METHODTYPE_OTHER) == 0) {
/* fprintf(stderr, "OTHER %s not wanted %.4x\n", methodName, methodType);*/
return NSF_FALSE;
}
/* NsfObjscopedMethod ??? */
}
return NSF_TRUE;
}
/*
*----------------------------------------------------------------------
* ProtectionMatches --
*
* Check, whether the provided method (specified as a cmd) matches
* with the required call-protection (typically
* all|public|protected|private).
*
* Results:
* Returns boolean
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool ProtectionMatches(CallprotectionIdx_t withCallprotection, Tcl_Command cmd)
nonnull(2) NSF_pure;
static bool
ProtectionMatches(CallprotectionIdx_t withCallprotection, Tcl_Command cmd) {
int result;
bool isProtected, isPrivate;
unsigned int cmdFlags;
nonnull_assert(cmd != NULL);
cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
isProtected = ((cmdFlags & NSF_CMD_CALL_PROTECTED_METHOD) != 0u);
isPrivate = ((cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u);
if (withCallprotection == CallprotectionNULL) {
withCallprotection = CallprotectionPublicIdx;
}
switch (withCallprotection) {
case CallprotectionAllIdx: result = NSF_TRUE; break;
case CallprotectionPublicIdx: result = (isProtected == 0); break;
case CallprotectionProtectedIdx: result = (isProtected && !isPrivate); break;
case CallprotectionPrivateIdx: result = isPrivate; break;
case CallprotectionNULL: result = NSF_TRUE; break;
default: result = NSF_FALSE; break;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* ListMethodKeys --
*
* List the method names contained in the specified hash-table
* according to the filtering options (types, pattern,
* protection, etc.). Optionally, a name prefix can be provided
* in form of a Tcl_DString. The result is placed into the interp
* result.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
Tcl_DString *prefix, const char *pattern,
MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection, bool withPath,
Tcl_HashTable *dups, NsfObject *object, bool withPer_object)
nonnull(1) nonnull(2);
static int
ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
Tcl_DString *prefix, const char *pattern,
MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection, bool withPath,
Tcl_HashTable *dups, NsfObject *object, bool withPer_object) {
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
Tcl_Command cmd;
const char *key;
bool isObject, methodTypeMatch;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(tablePtr != NULL);
resultObj = Tcl_GetObjResult(interp);
if (pattern != NULL && NoMetaChars(pattern) && strchr(pattern, ' ') == NULL) {
/*
* We have a pattern that can be used for direct lookup; no need
* to iterate.
*/
hPtr = Tcl_CreateHashEntry(tablePtr, pattern, NULL);
if (hPtr != NULL) {
NsfObject *childObject;
Tcl_Command origCmd;
key = Tcl_GetHashKey(tablePtr, hPtr);
cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
methodTypeMatch = MethodTypeMatches(interp, methodType, cmd, object, key,
withPer_object, &isObject);
if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CLASS_ONLY_METHOD) != 0u
&& !NsfObjectIsClass(object)) {
return TCL_OK;
}
/*
* Aliased objects methods return NSF_TRUE but lookup from cmd returns
* NULL. Below, we are just interested on true sub-objects.
*/
origCmd = GetOriginalCommand(cmd);
childObject = (isObject) ? NsfGetObjectFromCmdPtr(origCmd) : NULL;
if (childObject != NULL && withPath) {
return TCL_OK;
}
if (ProtectionMatches(withCallprotection, cmd) && methodTypeMatch) {
TCL_SIZE_T prefixLength = (prefix != NULL) ? Tcl_DStringLength(prefix) : 0;
if (prefixLength != 0) {
Tcl_DStringAppend(prefix, key, TCL_INDEX_NONE);
key = Tcl_DStringValue(prefix);
}
if (dups != NULL) {
int new;
(void)Tcl_CreateHashEntry(dups, key, &new);
if (new != 0) {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(key, TCL_INDEX_NONE));
}
} else {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(key, TCL_INDEX_NONE));
}
}
}
return TCL_OK;
} else {
size_t prefixLength = (prefix != NULL) ? (size_t)Tcl_DStringLength(prefix) : 0u;
/*
* We have to iterate over the elements.
*/
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
NsfObject *childObject = NULL, *directObject = NULL;
Tcl_Command origCmd;
key = Tcl_GetHashKey(tablePtr, hPtr);
cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
if (prefixLength != 0) {
Tcl_DStringSetLength(prefix, (TCL_SIZE_T)prefixLength);
}
methodTypeMatch = MethodTypeMatches(interp, methodType, cmd, object, key,
withPer_object, &isObject);
/*
* Aliased objects methods return NSF_TRUE but lookup from cmd returns
* NULL. Below, we are just interested on true sub-objects.
*/
origCmd = GetOriginalCommand(cmd);
if (isObject) {
childObject = NsfGetObjectFromCmdPtr(origCmd);
directObject = NsfGetObjectFromCmdPtr(cmd);
}
/*fprintf(stderr, "key <%s> isObject %d childObject %p directo %p ensemble %d prefixl %d ali %d ali2 %d hasChild %d\n",
key, isObject, (void*)childObject,(void*)directObject,
childObject ? ((childObject->flags & NSF_KEEP_CALLER_SELF) != 0u) : 0,
prefixLength, TCL_COMMAND_OBJPROC(cmd) == NsfProcAliasMethod,
childObject ? AliasGet(interp, childObject->cmdName, key, withPer_object, NSF_FALSE) != NULL : 0,
childObject ? (childObject->nsPtr == NULL) : 0
);*/
if (childObject != NULL) {
/*
* If we have a child object, check if we have an ensemble method,
* which we detect on the flag NSF_KEEP_CALLER_SELF.
*/
if (withPath
&& ((childObject->flags & NSF_KEEP_CALLER_SELF) != 0u)
&& ((childObject->flags & NSF_PER_OBJECT_DISPATCH) != 0u)
) {
Tcl_HashTable *cmdTablePtr;
if (childObject->nsPtr == NULL) {
/*
* Nothing to do.
*/
continue;
}
cmdTablePtr = Tcl_Namespace_cmdTablePtr(childObject->nsPtr);
if (cmdTablePtr == NULL) {
/*
* Nothing to do.
*/
continue;
}
if ((childObject->flags & NSF_IS_SLOT_CONTAINER) != 0u) {
/*
* Don't report slot container.
*/
continue;
}
if ((childObject->flags & NSF_KEEP_CALLER_SELF) == 0u) {
/*
* Do only report sub-objects with keep caller self.
*/
continue;
}
/*fprintf(stderr, "ListMethodKeys key %s append key space flags %.6x\n",
key, childObject->flags);*/
if (prefix == NULL) {
Tcl_DString ds, *dsPtr = &ds;
DSTRING_INIT(dsPtr);
Tcl_DStringAppend(dsPtr, key, TCL_INDEX_NONE);
Tcl_DStringAppend(dsPtr, " ", 1);
ListMethodKeys(interp, cmdTablePtr, dsPtr, pattern, methodType,
withCallprotection, NSF_TRUE, dups, object, withPer_object);
DSTRING_FREE(dsPtr);
} else {
Tcl_DStringAppend(prefix, key, TCL_INDEX_NONE);
Tcl_DStringAppend(prefix, " ", 1);
ListMethodKeys(interp, cmdTablePtr, prefix, pattern, methodType,
withCallprotection, NSF_TRUE, dups, object, withPer_object);
}
/*
* Don't list ensembles by themselves.
*/
continue;
}
if ((childObject->flags & NSF_IS_SLOT_CONTAINER) != 0u) {
/*
* Don't report slot container.
*/
continue;
}
if (withPath && directObject != NULL) {
/*
* Don't report direct children when "-path" was requested
*/
continue;
}
#if 0
if (!withPath && directObject != NULL) {
/*
* Don't report true child objects if no "-path" was requested,
* unless these are from ensemble methods.
*/
if (!(
((childObject->flags & NSF_KEEP_CALLER_SELF) != 0u)
&& ((childObject->flags & NSF_PER_OBJECT_DISPATCH) != 0u)
)) {
continue;
}
}
#endif
}
if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CLASS_ONLY_METHOD) != 0u
&& !NsfObjectIsClass(object)
) {
continue;
}
if (!ProtectionMatches(withCallprotection, cmd)
|| (!methodTypeMatch)) {
continue;
}
if (prefixLength != 0) {
Tcl_DStringAppend(prefix, key, TCL_INDEX_NONE);
key = Tcl_DStringValue(prefix);
}
if (pattern != NULL && !Tcl_StringMatch(key, pattern)) {
continue;
}
if (dups != NULL) {
int new;
Tcl_CreateHashEntry(dups, key, &new);
if (new == 0) {
continue;
}
}
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(key, TCL_INDEX_NONE));
}
}
/*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ListChildren --
*
* List the children of the specified object. The result can be
* filtered via a pattern or a type.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListChildren(
Tcl_Interp *interp, NsfObject *object,
const char *pattern,
bool classesOnly, NsfClass *typeClass
) nonnull(1) nonnull(2);
static int
ListChildren(
Tcl_Interp *interp, NsfObject *object,
const char *pattern,
bool classesOnly, NsfClass *typeClass
) {
NsfObject *childObject;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (object->nsPtr == NULL) {
return TCL_OK;
}
if (pattern != NULL && NoMetaChars(pattern)) {
Tcl_DString ds, *dsPtr = &ds;
Tcl_DStringInit(dsPtr);
if (*pattern != ':') {
/*
* Build a fully qualified name.
*/
DStringAppendQualName(dsPtr, object->nsPtr, pattern);
pattern = Tcl_DStringValue(dsPtr);
}
if ((childObject = GetObjectFromString(interp, pattern)) &&
(!classesOnly || NsfObjectIsClass(childObject)) &&
((typeClass == NULL) || IsSubType(childObject->cl, typeClass)) &&
(Tcl_Command_nsPtr(childObject->id) == object->nsPtr) /* true children */
) {
Tcl_SetObjResult(interp, childObject->cmdName);
} else {
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
}
Tcl_DStringFree(dsPtr);
} else {
Tcl_Obj *list = Tcl_NewListObj(0, NULL);
Tcl_HashSearch hSrch;
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(object->nsPtr);
const Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
const char *key = Tcl_GetHashKey(cmdTablePtr, hPtr);
if (pattern == NULL || 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, GetObjectFromString(interp, key),
NsfGetObjectFromCmdPtr(cmd));*/
if ((childObject = NsfGetObjectFromCmdPtr(cmd)) &&
(!classesOnly || NsfObjectIsClass(childObject)) &&
((typeClass == NULL) || IsSubType(childObject->cl, typeClass)) &&
(Tcl_Command_nsPtr(childObject->id) == object->nsPtr) /* true children */
) {
Tcl_ListObjAppendElement(interp, list, childObject->cmdName);
}
}
}
Tcl_SetObjResult(interp, list);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ListForward --
*
* List registered forwarder defined in the hash table. The result
* can be filtered via a pattern, optionally the forward definition
* is returned.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListForward(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
const char *pattern, int withDefinition)
nonnull(1) nonnull(2);
static int
ListForward(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
const char *pattern, int withDefinition) {
nonnull_assert(interp != NULL);
nonnull_assert(tablePtr != NULL);
if (withDefinition != 0) {
const Tcl_HashEntry *hPtr = (pattern != NULL) ? Tcl_CreateHashEntry(tablePtr, pattern, NULL) : NULL;
/*
* Notice: we don't use pattern for wildcard matching here; pattern can
* only contain wildcards when used without "-definition".
*/
if (hPtr != NULL) {
Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
ClientData clientData = (cmd != NULL) ? Tcl_Command_objClientData(cmd) : NULL;
ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData;
if (tcd != NULL && TCL_COMMAND_OBJPROC(cmd) == NsfForwardMethod) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
AppendForwardDefinition(interp, listObj, tcd);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
}
return NsfPrintError(interp, "'%s' is not a forwarder", pattern);
}
return ListMethodKeys(interp, tablePtr, NULL, pattern, NSF_METHODTYPE_FORWARDER,
CallprotectionAllIdx, NSF_FALSE, NULL, NULL, NSF_FALSE);
}
/*
*----------------------------------------------------------------------
*
* ListDefinedMethods --
*
* List the methods defined by the specified object/class
* according to the filtering options (types, pattern,
* protection, etc.). The result is placed into the interp
* result.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
ListDefinedMethods(Tcl_Interp *interp, NsfObject *object, const char *pattern,
bool withPer_object,
MethodtypeIdx_t methodType,
CallprotectionIdx_t withCallprotection,
bool withPath) {
Tcl_HashTable *cmdTablePtr;
Tcl_DString ds, *dsPtr = NULL;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (pattern != NULL && *pattern == ':' && *(pattern + 1) == ':') {
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
const char *remainder;
/*fprintf(stderr, "we have a colon pattern '%s' methodtype %.6x\n", pattern, methodType);*/
TclGetNamespaceForQualName(interp, pattern, NULL, 0,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &remainder);
/*fprintf(stderr,
"TclGetNamespaceForQualName with %s => (%p %s) (%p %s) (%p %s) (%p %s)\n",
pattern,
nsPtr, (nsPtr != NULL) ? nsPtr->fullName : "",
dummy1Ptr, (dummy1Ptr != NULL) ? dummy1Ptr->fullName : "",
dummy2Ptr, (dummy2Ptr != NULL) ? dummy2Ptr->fullName : "",
remainder, (remainder != 0) ? remainder : "");*/
if (nsPtr != NULL) {
cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
dsPtr = &ds;
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, nsPtr->fullName, TCL_INDEX_NONE);
if (Tcl_DStringLength(dsPtr) > 2) {
Tcl_DStringAppend(dsPtr, "::", 2);
}
pattern = remainder;
} else {
cmdTablePtr = NULL;
}
} else if (NsfObjectIsClass(object) && !withPer_object) {
cmdTablePtr = Tcl_Namespace_cmdTablePtr(((NsfClass *)object)->nsPtr);
} else {
cmdTablePtr = (object->nsPtr != NULL) ? Tcl_Namespace_cmdTablePtr(object->nsPtr) : NULL;
}
if (cmdTablePtr != NULL) {
ListMethodKeys(interp, cmdTablePtr, dsPtr, pattern, methodType, withCallprotection, withPath,
NULL, object, withPer_object);
if (dsPtr != NULL) {
Tcl_DStringFree(dsPtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ListSuperClasses --
*
* List the superclasses of a class. Optionally the transitive
* closure is computed and the result can be filtered via a
* pattern.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int ListSuperClasses(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *pattern, bool withClosure)
nonnull(1) nonnull(2);
static int
ListSuperClasses(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *pattern, bool withClosure) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
if (class->super != NULL) {
NsfObject *matchObject = NULL;
Tcl_Obj *outObjPtr, *patternObj = NULL;
const char *patternString = NULL;
ClientData clientData;
bool found;
if (pattern != NULL
&& ConvertToObjpattern(interp, pattern, NULL, &clientData, &outObjPtr) == TCL_OK
) {
patternObj = (Tcl_Obj *)clientData;
if (GetMatchObject(interp, patternObj, pattern, &matchObject, &patternString) == -1) {
/*
* The pattern has no meta chars and does not correspond to an existing
* object. Therefore, it can't be a superclass.
*/
if (patternObj != NULL) {
DECR_REF_COUNT2("patternObj", patternObj);
}
return TCL_OK;
}
}
if (withClosure) {
NsfClasses *pl = PrecedenceOrder(class);
if (pl != NULL) {
pl = pl->nextPtr;
}
found = AppendMatchingElementsFromClasses(interp, pl, patternString, matchObject);
} else {
NsfClasses *clSuper = NsfReverseClasses(class->super);
found = AppendMatchingElementsFromClasses(interp, clSuper, patternString, matchObject);
NsfClassListFree(clSuper);
}
if (matchObject != NULL) {
Tcl_SetObjResult(interp, found ? matchObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
}
if (patternObj != NULL) {
DECR_REF_COUNT2("patternObj", patternObj);
}
}
return TCL_OK;
}
/********************************
* End result setting commands
********************************/
/*
*----------------------------------------------------------------------
*
* AliasIndex --
*
* The alias index is an internal data structure keeping track of
* constructing aliases. This function computes the key of the index.
*
* Results:
* Returns a fresh Tcl_Obj. The caller is responsible for refcounting.
*
* Side effects:
* updating DString
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *AliasIndex(Tcl_Obj *cmdName, const char *methodName, bool withPer_object)
nonnull(1) nonnull(2) returns_nonnull;
static Tcl_Obj *
AliasIndex(Tcl_Obj *cmdName, const char *methodName, bool withPer_object) {
Tcl_DString ds, *dsPtr = &ds;
Tcl_Obj *resultObj;
nonnull_assert(cmdName != NULL);
nonnull_assert(methodName != NULL);
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, ObjStr(cmdName), TCL_INDEX_NONE);
Tcl_DStringAppend(dsPtr, ",", 1);
Tcl_DStringAppend(dsPtr, methodName, TCL_INDEX_NONE);
if (withPer_object) {
Tcl_DStringAppend(dsPtr, ",1", 2);
} else {
Tcl_DStringAppend(dsPtr, ",0", 2);
}
/*fprintf(stderr, "AI %s\n", Tcl_DStringValue(dsPtr));*/
resultObj = Tcl_NewStringObj(dsPtr->string, dsPtr->length);
Tcl_DStringFree(dsPtr);
return resultObj;
}
/*
*----------------------------------------------------------------------
*
* AliasAdd --
*
* Add an alias to the alias index
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Adding value to the hidden associated array.
*
*----------------------------------------------------------------------
*/
static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object,
Tcl_Obj *cmdObj)
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static int
AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object,
Tcl_Obj *cmdObj) {
Tcl_Obj *indexObj;
nonnull_assert(interp != NULL);
nonnull_assert(cmdName != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmdObj != NULL);
indexObj = AliasIndex(cmdName, methodName, withPer_object);
INCR_REF_COUNT(indexObj);
Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_ARRAY_ALIAS],
indexObj,
cmdObj,
TCL_GLOBAL_ONLY);
DECR_REF_COUNT(indexObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDelete --
*
* Deletes an alias from the index.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes an entry from the hidden associative array.
*
*----------------------------------------------------------------------
*/
static int
AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object) {
int result;
Tcl_Obj *indexObj;
nonnull_assert(interp != NULL);
nonnull_assert(cmdName != NULL);
nonnull_assert(methodName != NULL);
indexObj = AliasIndex(cmdName, methodName, withPer_object);
INCR_REF_COUNT(indexObj);
result = Tcl_UnsetVar2(interp, NsfGlobalStrings[NSF_ARRAY_ALIAS],
ObjStr(indexObj),
TCL_GLOBAL_ONLY);
DECR_REF_COUNT(indexObj);
/*fprintf(stderr, "aliasDelete ::nsf::alias(%s) returned %d (%d)\n",
AliasIndex(dsPtr, cmdName, methodName, withPer_object), result);*/
return result;
}
/*
*----------------------------------------------------------------------
*
* AliasGet --
*
* Get an entry from the alias index.
*
* Results:
* Alias in form of a Tcl_Obj* (or NULL).
*
* Side effects:
* delete an entry from the hidden associative array
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object, bool leaveError) {
Tcl_Obj *obj, *indexObj;
nonnull_assert(interp != NULL);
nonnull_assert(cmdName != NULL);
nonnull_assert(methodName != NULL);
indexObj = AliasIndex(cmdName, methodName, withPer_object);
INCR_REF_COUNT(indexObj);
obj = Tcl_ObjGetVar2(interp,
NsfGlobalObjs[NSF_ARRAY_ALIAS],
indexObj,
TCL_GLOBAL_ONLY);
DECR_REF_COUNT(indexObj);
/*fprintf(stderr, "aliasGet methodName '%s' returns %p\n", methodName, obj);*/
if (obj == NULL && leaveError) {
NsfPrintError(interp, "could not obtain alias definition for %s %s.",
ObjStr(cmdName), methodName);
}
return obj;
}
/*
*----------------------------------------------------------------------
* AliasDeleteObjectReference --
*
* Delete an alias to a referenced object. Such aliases are
* created by registering an alias to an object. This function
* distinguishes between a sub-object and an alias to an object,
* deletes the alias but never the referenced object.
*
* Results:
* Boolean value indicating when alias is deleted.
*
* Side effects:
* Deletes cmd sometimes
*
*----------------------------------------------------------------------
*/
static bool
AliasDeleteObjectReference(Tcl_Interp *interp, Tcl_Command cmd) {
NsfObject *referencedObject = NsfGetObjectFromCmdPtr(cmd);
nonnull_assert(interp != NULL);
nonnull_assert(cmd != NULL);
nonnull_assert(referencedObject != NULL);
/*fprintf(stderr, "AliasDeleteObjectReference on %p obj %p\n", cmd, referencedObject);*/
if (referencedObject->refCount > 0
&& cmd != referencedObject->id) {
/*
* The cmd is an aliased object, reduce the refCount of the
* object, delete the cmd.
*/
/*fprintf(stderr, "remove alias %s to %s\n",
Tcl_GetCommandName(interp, cmd), ObjectName(referencedObject));*/
NsfCleanupObject(referencedObject, "AliasDeleteObjectReference");
Tcl_DeleteCommandFromToken(interp, cmd);
return NSF_TRUE;
}
return NSF_FALSE;
}
/*
*----------------------------------------------------------------------
* AliasRefetch --
*
* Perform a refetch of an epoched aliased cmd and update the
* AliasCmdClientData structure with fresh values.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
AliasRefetch(Tcl_Interp *interp, NsfObject *object, const char *methodName, AliasCmdClientData *tcd) {
Tcl_Obj **listElements, *entryObj, *targetObj;
int withPer_object;
TCL_SIZE_T nrElements;
NsfObject *defObject;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(tcd != NULL);
/*fprintf(stderr, "AliasRefetch %s\n", methodName);*/
defObject = (tcd->class != NULL) ? &(tcd->class->object) : object;
/*
* Get the targetObject. Currently, we can get it just via the
* alias array.
*/
withPer_object = (tcd->class == NULL);
entryObj = AliasGet(interp, defObject->cmdName, methodName, withPer_object, NSF_TRUE);
if (unlikely(entryObj == NULL)) {
return TCL_ERROR;
}
INCR_REF_COUNT(entryObj);
Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements);
targetObj = listElements[nrElements-1];
NsfLog(interp, NSF_LOG_NOTICE,
"trying to refetch an epoched cmd %p as %s -- cmdName %s",
(void *)tcd->aliasedCmd, methodName, ObjStr(targetObj));
/*
* Replace cmd and its objProc and clientData with a newly fetched
* version.
*/
cmd = Tcl_GetCommandFromObj(interp, targetObj);
if (cmd != NULL) {
cmd = GetOriginalCommand(cmd);
/*fprintf(stderr, "cmd %p epoch %d deleted %.6x\n",
cmd,
Tcl_Command_cmdEpoch(cmd),
TclIsCommandDeleted(cmd));*/
if (TclIsCommandDeleted(cmd)) {
cmd = NULL;
}
}
if (cmd == NULL) {
int result = NsfPrintError(interp, "target \"%s\" of alias %s apparently disappeared",
ObjStr(targetObj), methodName);
DECR_REF_COUNT(entryObj);
return result;
}
assert(TCL_COMMAND_OBJPROC(cmd) != NULL);
NsfCommandRelease(tcd->aliasedCmd);
tcd->objProc = TCL_COMMAND_OBJPROC(cmd);
tcd->aliasedCmd = cmd;
tcd->clientData = Tcl_Command_objClientData(cmd);
NsfCommandPreserve(tcd->aliasedCmd);
DECR_REF_COUNT(entryObj);
/*
* Now, we should be able to proceed as planned, we have an
* non-epoched aliasCmd.
*/
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* AliasDereference --
*
* Dereference a cmd in respect of the alias structure. If necessary,
* this command refetches the aliased command.
*
* Results:
* NULL, in case refetching fails,
* the aliased cmd if it was an alias, or
* the original cmd
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
NSF_INLINE static Tcl_Command AliasDereference(Tcl_Interp *interp, NsfObject *object, const char *methodName, Tcl_Command cmd)
nonnull(1) nonnull(2) nonnull(3) nonnull(4);
NSF_INLINE static Tcl_Command
AliasDereference(Tcl_Interp *interp, NsfObject *object, const char *methodName, Tcl_Command cmd) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
nonnull_assert(cmd != NULL);
if (unlikely(TCL_COMMAND_OBJPROC(cmd) == NsfProcAliasMethod)) {
AliasCmdClientData *tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd);
assert(tcd != NULL);
/*fprintf(stderr, "AliasDereference %s epoch %d\n", methodName, Tcl_Command_cmdEpoch(tcd->aliasedCmd));*/
if (unlikely(Tcl_Command_cmdEpoch(tcd->aliasedCmd) != 0)) {
/*fprintf(stderr, "NsfProcAliasMethod aliasedCmd %p epoch %p\n",
tcd->aliasedCmd, Tcl_Command_cmdEpoch(tcd->aliasedCmd));*/
if (AliasRefetch(interp, object, methodName, tcd) != TCL_OK) {
return NULL;
}
}
return tcd->aliasedCmd;
}
return cmd;
}
#if defined(NSF_ASSEMBLE)
# include "asm/nsfAssemble.c"
#else
static int
NsfAsmMethodCreateCmd(Tcl_Interp *UNUSED(interp),
NsfObject *UNUSED(defObject),
int UNUSED(with_checkAlways),
int UNUSED(withInner_namespace),
int UNUSED(withPer_object),
NsfObject *UNUSED(regObject),
Tcl_Obj *UNUSED(nameObj),
Tcl_Obj *UNUSED(argumentsObj),
Tcl_Obj *UNUSED(bodyObj))
{
/*
* Dummy stub; used, when compiled without NSF_ASSEMBLE
*/
return TCL_OK;
}
#endif
/*
*----------------------------------------------------------------------
* SetBooleanFlag --
*
* Set an unsigned int flag based on valueObj
*
* Results:
* A standard Tcl result.
*
* Side effects:
* update passed flags
*
*----------------------------------------------------------------------
*/
static int SetBooleanFlag(Tcl_Interp *interp, unsigned int *flagsPtr, unsigned int flag, Tcl_Obj *valueObj, int *flagValue)
nonnull(1) nonnull(2) nonnull(4) nonnull(5);
static int
SetBooleanFlag(Tcl_Interp *interp, unsigned int *flagsPtr, unsigned int flag, Tcl_Obj *valueObj, int *flagValue) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(flagsPtr != NULL);
nonnull_assert(valueObj != NULL);
nonnull_assert(flagValue != NULL);
result = Tcl_GetBooleanFromObj(interp, valueObj, flagValue);
if (unlikely(result != TCL_OK)) {
return result;
}
if (*flagValue) {
*flagsPtr |= flag;
} else {
*flagsPtr &= ~flag;
}
return result;
}
/***********************************************************************
* Begin generated Next Scripting commands
***********************************************************************/
/*
cmd __db_compile_epoch NsfDebugCompileEpoch {}
*/
static int NsfDebugCompileEpoch(Tcl_Interp *interp)
nonnull(1);
static int
NsfDebugCompileEpoch(Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
Tcl_SetObjResult(interp, Tcl_NewIntObj((int)(((Interp *)interp)->compileEpoch)));
return TCL_OK;
}
/*
cmd __db_show_obj NsfDebugShowObj {
{-argName "obj" -required 1 -type tclobj}
}
*/
static int NsfDebugShowObj(Tcl_Interp *interp, Tcl_Obj *obj)
nonnull(1) nonnull(2);
static int
NsfDebugShowObj(Tcl_Interp *interp, Tcl_Obj *obj) {
nonnull_assert(interp != NULL);
nonnull_assert(obj != NULL);
fprintf(stderr, "*** obj %p refCount %lu type <%s> ",
(void *)obj, (unsigned long)obj->refCount, ObjTypeStr(obj));
if (obj->typePtr == &NsfObjectMethodObjType
|| obj->typePtr == &NsfInstanceMethodObjType
) {
NsfMethodContext *mcPtr = obj->internalRep.twoPtrValue.ptr1;
unsigned int currentMethodEpoch = obj->typePtr == &NsfObjectMethodObjType ?
RUNTIME_STATE(interp)->objectMethodEpoch :
RUNTIME_STATE(interp)->instanceMethodEpoch;
Tcl_Command cmd = mcPtr->cmd;
fprintf(stderr, " method epoch %u max %u cmd %p objProc 0x%" PRIxPTR " flags %.6x",
mcPtr->methodEpoch, currentMethodEpoch,
(void *)cmd,
(cmd != NULL) ? (unsigned long)PTR2UINT(((Command *)cmd)->objProc) : 0ul,
mcPtr->flags);
if (cmd != NULL) {
fprintf(stderr, "... cmd %p flags %.6x\n", (void *)cmd, Tcl_Command_flags(cmd));
assert(((Command *)cmd)->objProc != NULL);
}
assert(currentMethodEpoch >= mcPtr->methodEpoch);
} else if (obj->typePtr == Nsf_OT_tclCmdNameType) {
Tcl_Command cmd = Tcl_GetCommandFromObj(interp, obj);
if (likely(cmd != NULL)) {
Command *procPtr = (Command *)cmd;
const char *tail = Tcl_GetHashKey(procPtr->hPtr->tablePtr, procPtr->hPtr);
fprintf(stderr, "... cmd %p flags %.6x name '%s' ns '%s' objProcName %s",
(void *)cmd, Tcl_Command_flags(cmd), tail, procPtr->nsPtr->name,
CmdObjProcName(cmd));
}
} else if ((obj->typePtr == Nsf_OT_byteArrayType)
|| (obj->typePtr == Nsf_OT_properByteArrayType)) {
const char *bytes;
TCL_SIZE_T i, length;
bytes = (char *)Tcl_GetByteArrayFromObj(obj, &length);
fprintf(stderr, "bytearray proper %d length %ld string rep %p: ",
(obj->typePtr == Nsf_OT_properByteArrayType),
(long)length, (void*)obj->bytes);
for (i = 0; i < length; i++) {
fprintf(stderr, "%.2x", (unsigned)(*(bytes+i)) & 0xff);
}
}
fprintf(stderr, "\n");
return TCL_OK;
}
/*
cmd __db_get_obj NsfDebugGetDict {
{-argName "obj" -required 1 -type tclobj}
}
*/
#define NSF_DEBUG_SHOW_BYTES 10u
static int NsfDebugGetDict(Tcl_Interp *interp, Tcl_Obj *obj)
nonnull(1) nonnull(2);
static int
NsfDebugGetDict(Tcl_Interp *interp, Tcl_Obj *obj) {
Tcl_Obj *resultObj;
const char *typeString;
nonnull_assert(interp != NULL);
nonnull_assert(obj != NULL);
typeString = (obj->typePtr != NULL) ? obj->typePtr->name : "";
resultObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("type", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(typeString, TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("refcount", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewIntObj(obj->refCount));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("length", TCL_INDEX_NONE));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewIntObj(obj->length));
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("hex", TCL_INDEX_NONE));
if (obj->bytes != NULL) {
size_t i, objLength = (size_t)obj->length;
char trailer[3] = "...";
char buffer[NSF_DEBUG_SHOW_BYTES*2u + sizeof(trailer) + 1u];
for (i = 0; i < NSF_DEBUG_SHOW_BYTES && i < objLength; i++) {
snprintf(buffer + i*2, sizeof(buffer) - (i+1)*2, "%.2x", (unsigned)(*((obj->bytes)+i) & 0xff));
}
if (objLength > NSF_DEBUG_SHOW_BYTES) {
memmove(buffer, trailer, sizeof(buffer) - strlen(buffer) - 1);
}
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(buffer, TCL_INDEX_NONE));
} else {
Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("", 0));
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
cmd __db_show_stack NsfShowStackCmd {}
*/
static int
NsfShowStackCmd(Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
NsfShowStack(interp);
return TCL_OK;
}
/*
cmd __db_run_assertions NsfDebugRunAssertionsCmd {}
*/
static int
NsfDebugRunAssertionsCmd(Tcl_Interp *interp) {
NsfObjectSystem *osPtr;
NsfCmdList *instances = NULL, *entry;
nonnull_assert(interp != NULL);
/*
* Collect all instances from all object systems.
*/
for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
GetAllInstances(interp, &instances, osPtr->rootClass);
}
for (entry = instances; entry != NULL; entry = entry->nextPtr) {
#if !defined(NDEBUG)
NsfObject *object = (NsfObject *)entry->clorobj;
#endif
assert(object != NULL);
assert(object->refCount > 0);
assert(object->cmdName->refCount > 0);
assert(object->activationCount >= 0);
#if defined(CHECK_ACTIVATION_COUNTS)
if (object->activationCount > 0) {
Tcl_CallFrame *framePtr;
int count = 0;
NsfClasses *unstackedEntries = RUNTIME_STATE(interp)->cscList;
/*fprintf(stderr, "DEBUG obj %p %s activationcount %d\n",
object, ObjectName(object), object->activationCount);*/
framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp);
for (; framePtr != NULL; framePtr = Tcl_CallFrame_callerPtr(framePtr)) {
int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr);
NsfCallStackContent *cscPtr =
((frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) ?
((NsfCallStackContent *)Tcl_CallFrame_clientData(framePtr)) : NULL;
if (cscPtr != NULL && cscPtr->self == object) {
count ++;
}
if (cscPtr != NULL && (NsfObject *)cscPtr->cl == object) {
count ++;
}
}
for (; unstackedEntries; unstackedEntries = unstackedEntries->nextPtr) {
NsfCallStackContent *cscPtr = (NsfCallStackContent *)unstackedEntries->cl;
if (cscPtr != NULL && cscPtr->self == object) {
count ++;
}
if (cscPtr != NULL && (NsfObject *)cscPtr->cl == object) {
count ++;
}
}
if (count != object->activationCount) {
fprintf(stderr, "DEBUG obj %p %s activationcount %d on stack %d; "
"might be from non-stacked but active call-stack content\n",
object, ObjectName(object), object->activationCount, count);
fprintf(stderr, "fixed count %d\n", count);
/*NsfShowStack(interp);*/
/*return NsfPrintError(interp, "wrong activation count for object %s", ObjectName(object));*/
}
}
#endif
}
CmdListFree(&instances, NULL);
/*fprintf(stderr, "all assertions passed\n");*/
return TCL_OK;
}
/*
cmd __profile_clear_data NsfProfileClearDataStub {}
cmd __profile_get_data NsfProfileGetDataStub {}
cmd __profile_trace NsfProfileTraceStub {
{-argName "-enable" -required 1 -nrargs 1 -type boolean}
{-argName "-verbose" -required 0 -nrargs 1 -type boolean}
{-argName "-dontsave" -required 0 -nrargs 1 -type boolean}
{-argName "-builtins" -required 0 -nrargs 1 -type tclobj}
}
*/
static int NsfProfileClearDataStub(Tcl_Interp *interp)
nonnull(1);
static int NsfProfileGetDataStub(Tcl_Interp *interp)
nonnull(1);
static int NsfProfileTraceStub(Tcl_Interp *interp,
int withEnable, int withVerbose, int withDontsave,
Tcl_Obj *builtinsObj)
NSF_nonnull(1);
#if defined(NSF_PROFILE)
static int
NsfProfileClearDataStub(Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
NsfProfileClearData(interp);
return TCL_OK;
}
static int
NsfProfileGetDataStub(Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
NsfProfileGetData(interp);
return TCL_OK;
}
static int
NsfProfileTraceStub(Tcl_Interp *interp, int withEnable, int withVerbose, int withDontsave, Tcl_Obj *builtinsObj) {
nonnull_assert(interp != NULL);
NsfProfileTrace(interp, withEnable, withVerbose, withDontsave, builtinsObj);
return TCL_OK;
}
#else
static int NsfProfileClearDataStub(Tcl_Interp *UNUSED(interp)) {
return TCL_OK;
}
static int NsfProfileGetDataStub( Tcl_Interp *UNUSED(interp)) {
return TCL_OK;
}
static int NsfProfileTraceStub( Tcl_Interp *UNUSED(interp),
int UNUSED(withEnable),
int UNUSED(withVerbose),
int UNUSED(withDontsave),
Tcl_Obj *UNUSED(builtins)) {
return TCL_OK;
}
#endif
/*
* Valgrind/callgrind support
*/
#if defined(NSF_VALGRIND)
#include
/*
cmd __callgrind_dump_stats NsfCallgrindDumpStatsCmd {
{-argName "-name" -required 0 -nrargs 1}
}
cmd __callgrind_start_instrumentation NsfCallgrindStartInstrumentationCmd {}
cmd __callgrind_stop_instrumentation NsfCallgrindStopInstrumentationCmd {}
cmd __callgrind_toggle_collect NsfCallgrindToggleCollectCmd {}
cmd __callgrind_zero_stats NsfCallgrindZeroStatsCmd {}
*/
static int
NsfCallgrindDumpStatsCmd(Tcl_Interp *UNUSED(interp), const char *nameString) {
if (nameString == NULL) {
CALLGRIND_DUMP_STATS;
} else {
CALLGRIND_DUMP_STATS_AT(nameString);
}
return TCL_OK;
}
static int
NsfCallgrindStartInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
CALLGRIND_START_INSTRUMENTATION;
return TCL_OK;
}
static int
NsfCallgrindStopInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
CALLGRIND_STOP_INSTRUMENTATION;
return TCL_OK;
}
static int
NsfCallgrindToggleCollectCmd(Tcl_Interp *UNUSED(interp)) {
CALLGRIND_TOGGLE_COLLECT;
return TCL_OK;
}
static int
NsfCallgrindZeroStatsCmd(Tcl_Interp *UNUSED(interp)) {
CALLGRIND_ZERO_STATS;
return TCL_OK;
}
#else
static int NsfCallgrindDumpStatsCmd(Tcl_Interp *UNUSED(interp), const char *UNUSED(nameString)) {
return TCL_OK;
}
static int NsfCallgrindStartInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
return TCL_OK;
}
static int NsfCallgrindStopInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
return TCL_OK;
}
static int NsfCallgrindToggleCollectCmd(Tcl_Interp *UNUSED(interp)) {
return TCL_OK;
}
static int NsfCallgrindZeroStatsCmd(Tcl_Interp *UNUSED(interp)) {
return TCL_OK;
}
#endif
/*
*----------------------------------------------------------------------
* NsfUnsetUnknownArgsCmd --
*
* Unset variables set from arguments with the default dummy
* default value. The dummy default values are set by
* ArgumentDefaults()
*
* Results:
* A standard Tcl result.
*
* Side effects:
* unsets some variables
*
*----------------------------------------------------------------------
*/
/*
cmd __unset_unknown_args NsfUnsetUnknownArgsCmd {}
*/
static int
NsfUnsetUnknownArgsCmd(Tcl_Interp *interp) {
CallFrame *varFramePtr;
Proc *proc;
nonnull_assert(interp != NULL);
varFramePtr = Tcl_Interp_varFramePtr(interp);
proc = Tcl_CallFrame_procPtr(varFramePtr);
if (likely(proc != NULL)) {
const CompiledLocal *ap;
const Var *varPtr;
int i;
for (ap = proc->firstLocalPtr, i = 0; ap; ap = ap->nextPtr, i++) {
if (!TclIsCompiledLocalArgument(ap)) {
continue;
}
varPtr = &Tcl_CallFrame_compiledLocals(varFramePtr)[i];
/*fprintf(stderr, "NsfUnsetUnknownArgsCmd 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,
NsfGlobalObjs[NSF___UNKNOWN__]);*/
if (varPtr->value.objPtr != NsfGlobalObjs[NSF___UNKNOWN__]) {
continue;
}
/*fprintf(stderr, "NsfUnsetUnknownArgsCmd must unset %s\n", ap->name);*/
Tcl_UnsetVar2(interp, ap->name, NULL, 0);
}
}
return TCL_OK;
}
/*
cmd asmproc NsfAsmProcCmd {
{-argName "-ad" -required 0 -nrargs 0 -type switch}
{-argName "-checkalways" -required 0 -nrargs 0 -type switch}
{-argName "procName" -required 1 -type tclobj}
{-argName "arguments" -required 1 -type tclobj}
{-argName "body" -required 1 -type tclobj}
}
*/
#if !defined(NSF_ASSEMBLE)
static int
NsfAsmProcCmd(Tcl_Interp *UNUSED(interp),
int UNUSED(with_ad),
int UNUSED(with_checkAlways),
Tcl_Obj *UNUSED(nameObj),
Tcl_Obj *UNUSED(arguments),
Tcl_Obj *UNUSED(body))
{
return TCL_OK;
}
#else
static int
NsfAsmProcCmd(Tcl_Interp *interp, int with_ad, int with_checkAlways, Tcl_Obj *nameObj, Tcl_Obj *arguments, Tcl_Obj *body) {
NsfParsedParam parsedParam;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(arguments != NULL);
nonnull_assert(body != NULL);
/*
* Parse argument list "arguments" to determine if we should provide
* nsf parameter handling.
*/
result = ParamDefsParse(interp, nameObj, arguments,
NSF_DISALLOWED_ARG_METHOD_PARAMETER, NSF_FALSE,
&parsedParam, NULL);
if (unlikely(result != TCL_OK)) {
return result;
}
if (parsedParam.paramDefs != NULL) {
/*
* We need parameter handling.
*/
result = NsfAsmProcAddParam(interp, &parsedParam, nameObj, body, with_ad, with_checkAlways);
} else {
/*
* No parameter handling needed.
*/
result = NsfAsmProcAddArgs(interp, arguments, nameObj, body, with_ad, with_checkAlways);
}
return result;
}
#endif
/*
cmd "cmd::info" NsfCmdInfoCmd {
{-argName "subcmd" -required 1 -typeName "methodgetcmd" -type "args|body|definition|exists|registrationhandle|definitionhandle|origin|parameter|syntax|type|precondition|postcondition|submethods|returns"}
{-argName "-context" -required 0 -type object}
{-argName "methodName" -required 1 -type tclobj}
{-argName "pattern" -required 0}
} {-nxdoc 1}
*/
static int
NsfCmdInfoCmd(Tcl_Interp *interp, InfomethodsubcmdIdx_t subcmd, NsfObject *contextObject,
Tcl_Obj *methodNameObj, const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(methodNameObj != NULL);
return ListMethodResolve(interp, subcmd, contextObject, pattern, NULL, NULL, methodNameObj, NSF_FALSE);
}
/*
cmd configure NsfConfigureCmd {
{-argName "option" -required 1 -type "debug|dtrace|filter|profile|softrecreate|objectsystems|keepcmds|checkresults|checkarguments"}
{-argName "value" -required 0 -type tclobj}
}
*/
static int
NsfConfigureCmd(Tcl_Interp *interp, ConfigureoptionIdx_t option, Tcl_Obj *valueObj) {
int boolVal = 0;
nonnull_assert(interp != NULL);
#if defined(NSF_DTRACE)
if (NSF_DTRACE_CONFIGURE_PROBE_ENABLED()) {
NSF_DTRACE_CONFIGURE_PROBE(Nsf_Configureoption[option-1].key,
(valueObj != NULL) ? ObjStr(valueObj) : NULL);
}
#endif
if (option == ConfigureoptionObjectsystemsIdx) {
NsfObjectSystem *osPtr;
Tcl_Obj *list = Tcl_NewListObj(0, NULL);
for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
Tcl_Obj *osObj = Tcl_NewListObj(0, NULL);
Tcl_Obj *systemMethods = Tcl_NewListObj(0, NULL);
int idx;
Tcl_ListObjAppendElement(interp, osObj, osPtr->rootClass->object.cmdName);
Tcl_ListObjAppendElement(interp, osObj, osPtr->rootMetaClass->object.cmdName);
for (idx = 0; Nsf_SystemMethodOpts[idx]; idx++) {
/*fprintf(stderr, "opt %s %s\n", Nsf_SystemMethodOpts[idx],
osPtr->methods[idx] ? ObjStr(osPtr->methods[idx]) : "NULL");*/
if (osPtr->methods[idx] == NULL) {
continue;
}
Tcl_ListObjAppendElement(interp, systemMethods, Tcl_NewStringObj(Nsf_SystemMethodOpts[idx], TCL_INDEX_NONE));
if (osPtr->handles[idx] || osPtr->protected[idx]) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, listObj, osPtr->methods[idx]);
Tcl_ListObjAppendElement(interp, listObj, osPtr->handles[idx]);
if (osPtr->protected[idx]) {
Tcl_ListObjAppendElement(interp, listObj, Tcl_NewIntObj(1));
}
Tcl_ListObjAppendElement(interp, systemMethods, listObj);
} else {
Tcl_ListObjAppendElement(interp, systemMethods, osPtr->methods[idx]);
}
}
Tcl_ListObjAppendElement(interp, osObj, systemMethods);
Tcl_ListObjAppendElement(interp, list, osObj);
}
Tcl_SetObjResult(interp, list);
return TCL_OK;
}
if (option == ConfigureoptionDebugIdx) {
if (valueObj != NULL) {
int level, result = Tcl_GetIntFromObj(interp, valueObj, &level);
if (unlikely(result != TCL_OK)) {
return result;
}
RUNTIME_STATE(interp)->logSeverity = level;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp),
RUNTIME_STATE(interp)->logSeverity);
return TCL_OK;
}
/*
* All other configure options are boolean.
*/
if (valueObj != NULL) {
int result = Tcl_GetBooleanFromObj(interp, valueObj, &boolVal);
if (unlikely(result != TCL_OK)) {
return result;
}
}
switch (option) {
case ConfigureoptionDebugIdx: ;NSF_FALL_THROUGH; /* fall through */
case ConfigureoptionObjectsystemsIdx:
/*
* Handled above.
*/
break;
case ConfigureoptionDtraceIdx:
/*
* Not implemented.
*/
break;
case ConfigureoptionNULL:
/*
* Do nothing; just for detection if option was specified.
*/
break;
case ConfigureoptionFilterIdx:
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
(RUNTIME_STATE(interp)->doFilters));
if (valueObj != NULL) {
RUNTIME_STATE(interp)->doFilters = boolVal;
}
break;
case ConfigureoptionSoftrecreateIdx:
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
(RUNTIME_STATE(interp)->doSoftrecreate));
if (valueObj != NULL) {
RUNTIME_STATE(interp)->doSoftrecreate = boolVal;
}
break;
case ConfigureoptionKeepcmdsIdx:
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
(RUNTIME_STATE(interp)->doKeepcmds));
if (valueObj != NULL) {
RUNTIME_STATE(interp)->doKeepcmds = boolVal;
}
break;
case ConfigureoptionCheckresultsIdx:
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
(RUNTIME_STATE(interp)->doCheckResults));
if (valueObj != NULL) {
RUNTIME_STATE(interp)->doCheckResults = (unsigned int)boolVal;
}
break;
case ConfigureoptionCheckargumentsIdx:
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
(RUNTIME_STATE(interp)->doCheckArguments) != 0);
if (valueObj != NULL) {
RUNTIME_STATE(interp)->doCheckArguments = (boolVal != 0) ? NSF_ARGPARSE_CHECK : 0;
}
break;
}
return TCL_OK;
}
/*
cmd colon NsfColonCmd {
{-argName "args" -type allargs}
}
*/
static int
NsfColonCmd(Tcl_Interp *interp, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
const char *methodName = ObjStr(objv[0]);
NsfObject *self;
int result;
nonnull_assert(interp != NULL);
self = GetSelfObj(interp);
if (unlikely(self == NULL)) {
return NsfNoCurrentObjectError(interp, methodName);
}
/*fprintf(stderr, "Colon dispatch %s.%s (%d)\n",
ObjectName(self), ObjStr(objv[0]), objc);*/
/*
* Do we have a method, which is NOT a single colon?
*/
if (likely(!(*methodName == ':' && *(methodName + 1) == '\0'))) {
/*
* A method like ":foo" is called via plain ObjectDispatch().
*/
result = ObjectDispatch(self, interp, objc, objv, NSF_CM_NO_SHIFT);
} else {
/*
* The method name is a single colon, and might have one or more
* arguments.
*/
if (objc <= 1) {
/*
* Single colon and no arguments.
*/
Tcl_SetObjResult(interp, self->cmdName);
result = TCL_OK;
} else {
/*
* Single colon and multiple arguments.
*/
methodName = ObjStr(objv[1]);
if (*methodName != '-') {
/*
* No need to parse arguments (local, intrinsic, ...).
*/
result = ObjectDispatch(self, interp, objc, objv, 0u);
} else {
ParseContext pc;
/*
* Parse arguments, use definitions from nsf::my
*/
result = ArgumentParse(interp, objc, objv, NULL, objv[0],
method_definitions[NsfMyCmdIdx].paramDefs,
method_definitions[NsfMyCmdIdx].nrParameters,
0, NSF_ARGPARSE_BUILTIN, &pc);
if (likely(result == TCL_OK)) {
int withIntrinsic, withLocal, withSystem;
Tcl_Obj *methodObj;
withIntrinsic = (int)PTR2INT(pc.clientData[0]);
withLocal = (int)PTR2INT(pc.clientData[1]);
withSystem = (int)PTR2INT(pc.clientData[2]);
methodObj = (Tcl_Obj *)pc.clientData[3];
assert(pc.status == 0);
if ((withIntrinsic && withLocal)
|| (withIntrinsic && withSystem)
|| (withLocal && withSystem)) {
result = NsfPrintError(interp, "flags '-intrinsic', '-local' and '-system' are mutual exclusive");
} else {
unsigned int flags;
flags = NSF_CSC_IMMEDIATE;
if (withIntrinsic != 0) {
flags |= NSF_CM_INTRINSIC_METHOD;
}
if (withLocal != 0) {
flags |= NSF_CM_LOCAL_METHOD;
}
if (withSystem != 0) {
flags |= NSF_CM_SYSTEM_METHOD;
}
result = CallMethod(self, interp, methodObj, (objc - pc.lastObjc) + 2, objv + pc.lastObjc, flags);
}
}
}
}
}
return result;
}
/*
cmd "definitionnamespace" NsfDefinitionNamespaceCmd {
}
*/
static int
NsfDefinitionNamespaceCmd(Tcl_Interp *interp)
{
Tcl_Namespace *nsPtr;
nonnull_assert(interp != NULL);
nsPtr = CallingNameSpace(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE));
return TCL_OK;
}
/*
cmd "directdispatch" NsfDirectDispatchCmd {
{-argName "object" -required 1 -type object}
{-argName "-frame" -required 0 -nrargs 1 -type "method|object|default" -default "default"}
{-argName "command" -required 1 -type tclobj}
{-argName "args" -type args}
}
*/
static int
NsfDirectDispatchCmd(Tcl_Interp *interp, NsfObject *object, FrameIdx_t withFrame,
Tcl_Obj *commandObj, TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
int result;
const char *methodName;
Tcl_Command cmd, importedCmd;
CallFrame frame, *framePtr = &frame;
TCL_OBJCMDPROC_T *proc;
unsigned int flags = 0u;
bool useCmdDispatch = NSF_TRUE;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(commandObj != NULL);
/*fprintf(stderr, "NsfDirectDispatchCmd obj=%s, cmd m='%s' oc %d\n", ObjectName(object), methodName, nobjc);*/
methodName = ObjStr(commandObj);
if (unlikely(*methodName != ':')) {
return NsfPrintError(interp, "method name '%s' must be fully qualified", methodName);
}
/*
* We have a fully qualified name of a Tcl command that will be dispatched.
*/
cmd = Tcl_GetCommandFromObj(interp, commandObj);
if (likely(cmd != NULL)) {
importedCmd = TclGetOriginalCommand(cmd);
if (unlikely(importedCmd != NULL)) {
cmd = importedCmd;
}
}
if (unlikely(cmd == NULL)) {
return NsfPrintError(interp, "cannot lookup command '%s'", methodName);
}
proc = TCL_COMMAND_OBJPROC(cmd);
if (proc == (TCL_OBJCMDPROC_T*)TclObjInterpProc ||
proc == NsfForwardMethod ||
proc == NsfObjscopedMethod ||
proc == NsfSetterMethod ||
CmdIsNsfObject(cmd)) {
if (withFrame && withFrame != FrameDefaultIdx) {
return NsfPrintError(interp, "cannot use -frame object|method in dispatch for command '%s'",
methodName);
}
useCmdDispatch = NSF_FALSE;
} else {
if (unlikely(withFrame == FrameMethodIdx)) {
useCmdDispatch = NSF_FALSE;
}
}
/*
* If "withFrame == FrameObjectIdx" is specified, a call-stack frame is
* pushed to make instance variables accessible for the command.
*/
if (unlikely(withFrame == FrameObjectIdx)) {
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
flags = NSF_CSC_IMMEDIATE;
}
/*
* 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().
*/
if (useCmdDispatch) {
if (NSF_DTRACE_METHOD_ENTRY_ENABLED()) {
NSF_DTRACE_METHOD_ENTRY(ObjectName(object),
"",
(char *)methodName,
trailingObjc, (Tcl_Obj **)trailingObjv);
}
result = CmdMethodDispatch(object, interp, trailingObjc + 1, trailingObjv - 1,
object, cmd, NULL);
} else {
/*
* If "withFrame == FrameMethodIdx" is specified, a call-stack frame is
* pushed to make instance variables accessible for the command.
*/
if (unlikely(withFrame == FrameMethodIdx)) {
flags = NSF_CSC_FORCE_FRAME|NSF_CSC_IMMEDIATE;
}
result = MethodDispatch(interp, trailingObjc + 1, trailingObjv - 1, cmd, object,
NULL /*NsfClass *cl*/,
Tcl_GetCommandName(interp, cmd),
NSF_CSC_TYPE_PLAIN, flags);
}
if (unlikely(withFrame == FrameObjectIdx)) {
Nsf_PopFrameObj(interp, framePtr);
}
return result;
}
/*
cmd "dispatch" NsfDispatchCmd {
{-argName "object" -required 1 -type object}
{-argName "-intrinsic" -required 0 -nrargs 0}
{-argName "-system" -required 0 -nrargs 0}
{-argName "command" -required 1 -type tclobj}
{-argName "args" -type args}
}
*/
static int
NsfDispatchCmd(Tcl_Interp *interp, NsfObject *object,
int withIntrinsic, int withSystem,
Tcl_Obj *commandObj,
TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
unsigned int flags = NSF_CM_NO_UNKNOWN|NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS|NSF_CM_NO_SHIFT;
Tcl_Obj *const *objv = trailingObjv-1;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(commandObj != NULL);
/*
* We use the construct "tclobj" + "args" in the spec to enforce that at least a
* commandName is specified (this way we allow empty "args", and can provide
* a nice error message, if cmdName is not specified). Since the we know
* that the commandObj has to be right before "args" in the objv, we can
* decrement the nobjv to obtain objv (and increment nobjc), be we make sure
* that this assumption is correct.
*/
assert(objv[0] == commandObj);
assert(ISOBJ_(commandObj));
trailingObjc++;
#if 0
{int i;
fprintf(stderr, "NsfDispatchCmd %s method %s oc %2d", ObjectName(object), ObjStr(commandObj), trailingObjc);
for(i = 0; i < trailingObjc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(trailingObjv[i]));}
fprintf(stderr, "\n");
}
#endif
if (unlikely(withIntrinsic && withSystem)) {
return NsfPrintError(interp, "flags '-intrinsic' and '-system' are mutual exclusive");
}
/*
* Dispatch the command the method from the precedence order, with filters
* etc. -- strictly speaking unnecessary, but this function can be used to
* call protected methods and provide the flags '-intrinsics' and '-system'.
*/
if (withIntrinsic != 0) {
flags |= NSF_CM_INTRINSIC_METHOD;
}
if (withSystem != 0) {
flags |= NSF_CM_SYSTEM_METHOD;
}
/*
* 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().
*/
return ObjectDispatch(object, interp, trailingObjc, objv, flags);
}
/*
cmd finalize NsfFinalizeCmd {
{-argName "-keepvars" -required 0 -nrargs 0}
}
*/
static int
NsfFinalizeCmd(Tcl_Interp *interp, int withKeepvars) {
int result;
/* fprintf(stderr, "#### (%lx) NsfFinalizeCmd exitHandlerRound %d\n",
(long)(void*)pthread_self(), RUNTIME_STATE(interp)->exitHandlerDestroyRound );*/
nonnull_assert(interp != NULL);
#if defined(NSF_PROFILE)
/*
* Check whether profile trace is still running. If so, delete it here.
* Interestingly, NsfLog() seems to be unavailable at this place.
*/
if (RUNTIME_STATE(interp)->doTrace == 1) {
NsfLog(interp, NSF_LOG_WARN, "tracing is still active; deactivate it due to cleanup.");
NsfProfileTrace(interp, 0, 0, 0, NULL);
}
#endif
#if defined(NSF_STACKCHECK)
{NsfRuntimeState *rst = RUNTIME_STATE(interp);
NsfLog(interp, NSF_LOG_WARN, "Stack max usage %ld",
labs(rst->maxStack - rst->bottomOfStack));
}
#endif
/*fprintf(stderr, "+++ call tcl-defined exit handler (%x)\n", PTR2INT(pthread_self()));*/
/*
* Evaluate user-defined exit handler.
*/
result = Tcl_Eval(interp, "::nsf::__exithandler");
if (unlikely(result != TCL_OK)) {
fprintf(stderr, "User defined exit handler contains errors!\n"
"Error in line %d: %s\nExecution interrupted.\n",
(int)Tcl_GetErrorLine(interp), ObjStr(Tcl_GetObjResult(interp)));
}
ObjectSystemsCleanup(interp, withKeepvars ? NSF_TRUE : NSF_FALSE);
#ifdef DO_CLEANUP
{
NsfRuntimeState *rst = RUNTIME_STATE(interp);
# if defined(CHECK_ACTIVATION_COUNTS)
assert(rst->cscList == NULL);
# endif
/*fprintf(stderr, "CLEANUP TOP NS\n");*/
Tcl_Export(interp, rst->NsfNS, "", 1);
if (rst->NsfClassesNS != NULL) {
MEM_COUNT_FREE("TclNamespace", rst->NsfClassesNS);
Tcl_DeleteNamespace(rst->NsfClassesNS);
}
if (rst->NsfNS != NULL) {
MEM_COUNT_FREE("TclNamespace", rst->NsfNS);
Tcl_DeleteNamespace(rst->NsfNS);
}
{
NsfDList *dlPtr = &rst->freeDList;
size_t i;
#if defined(COLON_CMD_STATS)
fprintf(stderr, "#### DList free size %lu avail %lu\n", dlPtr->size, dlPtr->avail);
#endif
for (i = 0u; i < dlPtr->size; i++) {
/*
fprintf(stderr, "#### DList free data[%lu] %p: %p\n", i,
(void*)&(dlPtr->data[i]), (void*)dlPtr->data[i]);
*/
NsfColonCmdContextFree(dlPtr->data[i]);
}
NsfDListFree(dlPtr);
}
}
#endif
return TCL_OK;
}
/*
cmd interp NsfInterpObjCmd {
{-argName "name"}
{-argName "args" -type allargs}
}
*/
/*
* Create a slave interp that calls Next Scripting Init
*/
static int
NsfInterpObjCmd(Tcl_Interp *interp, const char *name, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
nonnull_assert(interp != NULL);
nonnull_assert(name != NULL);
/*
* Create a fresh Tcl interpreter, or pass command to an existing one
*/
if (unlikely(NsfCallCommand(interp, NSF_INTERP, objc, objv) != TCL_OK)) {
return TCL_ERROR;
}
/*
* Upon [interp create], set up NSF for the new child interp by running
* Nsf_Init()
*/
if (isCreateString(name)) {
Tcl_Obj *slaveCmdObj;
Tcl_Interp *slavePtr;
/*
* Tcl_InterpObjCmd() stores the newly created child interp's command name
* in the interp result store.
*/
slaveCmdObj = Tcl_GetObjResult(interp);
slavePtr = Tcl_GetChild(interp, ObjStr(slaveCmdObj));
if (slavePtr == NULL) {
return NsfPrintError(interp, "creation of slave interpreter failed");
}
if (unlikely(Nsf_Init(slavePtr) == TCL_ERROR)) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
cmd is NsfIsCmd {
{-argName "-complain" -nrargs 0}
{-argName "-configure" -nrargs 0}
{-argName "-name" -required 0}
{-argName "constraint" -required 1 -type tclobj}
{-argName "value" -required 1 -type tclobj}
} {-nxdoc 1}
*/
static int
NsfIsCmd(Tcl_Interp *interp,
int withComplain,
int withConfigure,
const char *withName,
Tcl_Obj *constraintObj,
Tcl_Obj *valueObj) {
Nsf_Param *paramPtr = NULL;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(constraintObj != NULL);
nonnull_assert(valueObj != NULL);
result = ParameterCheck(interp, constraintObj, valueObj,
(withName != NULL) ? withName : "value:", 1,
(withName != NULL),
(withConfigure == 1),
¶mPtr,
Tcl_GetCurrentNamespace(interp)->fullName);
if (unlikely(paramPtr == NULL)) {
/*
* We could not convert the arguments. Even with noComplain, we
* report the invalid converter spec as exception.
*/
result = TCL_ERROR;
} else {
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 (likely(result == TCL_OK)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
}
}
return result;
}
/*
cmd parseargs NsfParseArgsCmd {
{-argName "-asdict" -nrargs 0 -required 0 -type switch}
{-argName "argspec" -required 1 -type tclobj}
{-argName "arglist" -required 1 -type tclobj}
} {-nxdoc 0}
*/
static int
NsfParseArgsCmd(Tcl_Interp *interp, int withAsDict, Tcl_Obj *argspecObj, Tcl_Obj *arglistObj) {
NsfParsedParam parsedParam;
Tcl_Obj **objv;
TCL_SIZE_T objc;
int result;
result = ParamDefsParse(interp, NsfGlobalObjs[NSF_PARSE_ARGS], argspecObj,
NSF_DISALLOWED_ARG_METHOD_PARAMETER,
NSF_TRUE /* force use of param structure,
even for Tcl-only params */,
&parsedParam, Tcl_GetCurrentNamespace(interp)->fullName);
if (unlikely(result != TCL_OK)) {
return result;
}
result = Tcl_ListObjGetElements(interp, arglistObj, &objc, &objv);
if (likely(result == TCL_OK) && parsedParam.paramDefs != NULL) {
ParseContext pc;
NsfParamDefs *paramDefs = parsedParam.paramDefs;
unsigned int processFlags = 0u;
ParamDefsRefCountIncr(paramDefs);
result = ArgumentParse(interp, (TCL_OBJC_T)objc, objv, NULL, NsfGlobalObjs[NSF_PARSE_ARGS],
paramDefs->paramsPtr, paramDefs->nrParams, paramDefs->serial,
processFlags
|NSF_ARGPARSE_START_ZERO
|NSF_ARGPARSE_FORCE_REQUIRED
|RUNTIME_STATE(interp)->doCheckArguments,
&pc);
if (result == TCL_OK) {
Nsf_Param *paramPtr;
size_t i;
if (withAsDict == 1) {
Tcl_Obj *resultObj;
resultObj = Tcl_NewDictObj();
INCR_REF_COUNT2("resultDictObj", resultObj);
for (i = 0u, paramPtr = paramDefs->paramsPtr; paramPtr->name != NULL; paramPtr++, i++) {
Tcl_Obj *valueObj = pc.objv[i];
if (valueObj != NsfGlobalObjs[NSF___UNKNOWN__]) {
/*fprintf(stderr, "param %s -> <%s>\n", paramPtr->name, ObjStr(valueObj));*/
result = Tcl_DictObjPut(interp, resultObj, paramPtr->nameObj, valueObj);
if (result == TCL_ERROR) {
break;
}
}
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
}
DECR_REF_COUNT2("resultDictObj", resultObj);
} else {
for (i = 0u, paramPtr = paramDefs->paramsPtr; paramPtr->name != NULL; paramPtr++, i++) {
Tcl_Obj *valueObj = pc.objv[i];
if (valueObj != NsfGlobalObjs[NSF___UNKNOWN__]) {
/*fprintf(stderr, "param %s -> <%s>\n", paramPtr->name, ObjStr(valueObj));*/
if (Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
break;
}
}
}
}
}
ParamDefsRefCountDecr(paramDefs);
ParseContextRelease(&pc);
}
return result;
}
/*
cmd method::alias NsfMethodAliasCmd {
{-argName "object" -type object}
{-argName "-per-object"}
{-argName "methodName"}
{-argName "-frame" -required 0 -nrargs 1 -type "method|object|default" -default "default"}
{-argName "-protection" -required 0 -type "call-protected|redefine-protected|none" -default "none"}
{-argName "cmdName" -required 1 -type tclobj}
}
*/
static int
NsfMethodAliasCmd(
Tcl_Interp *interp, NsfObject *object, int withPer_object,
const char *methodName, FrameIdx_t withFrame, ProtectionIdx_t withProtection,
Tcl_Obj *cmdNameObj
) {
TCL_OBJCMDPROC_T *objProc, *newObjProc;
Tcl_CmdDeleteProc *deleteProc;
AliasCmdClientData *tcd;
Tcl_Command cmd, oldCmd, newCmd;
Tcl_Namespace *nsPtr;
int result;
unsigned int flags = 0u;
const NsfClass *class;
NsfObject *newTargetObject;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodName != NULL);
assert(*methodName != ':');
nonnull_assert(cmdNameObj != NULL);
cmd = Tcl_GetCommandFromObj(interp, cmdNameObj);
if (cmd == NULL) {
return NsfPrintError(interp, "cannot lookup command '%s'", ObjStr(cmdNameObj));
}
cmd = GetOriginalCommand(cmd);
objProc = TCL_COMMAND_OBJPROC(cmd);
assert(objProc != NULL);
/*
* objProc is either ...
*
* 1. NsfObjDispatch: a command representing a Next Scripting object
*
* 2. TclObjInterpProc: a cmd standing for a Tcl proc (including
* Next Scripting methods), verified through CmdIsProc() -> to be
* wrapped by NsfProcAliasMethod()
*
* 3. NsfForwardMethod: a Next Scripting forwarder
*
* 4. NsfSetterMethod: a Next Scripting setter
*
* 5. Arbitrary Tcl commands (e.g. set, ..., ::nsf::relation, ...)
*
*/
if (withFrame == FrameObjectIdx) {
newObjProc = NsfObjscopedMethod;
} else {
newObjProc = NULL;
}
/*
* We need to perform a defensive lookup of a previously defined
* object-alias under the given methodName.
*/
class = (withPer_object || ! NsfObjectIsClass(object)) ? NULL : (NsfClass *)object;
nsPtr = (class != NULL) ? class->nsPtr : object->nsPtr;
oldCmd = (nsPtr != NULL) ? FindMethod(nsPtr, methodName) : NULL;
newTargetObject = NsfGetObjectFromCmdPtr(cmd);
if (oldCmd != NULL) {
#if 1
/*
* Old solution, leasds to a broken regression test with Tcl 8.7a1.
* However, using Tcl_DeleteCommandFromToken() leads to a crash also with
* earlier solutions when defining recursive aliases.
*/
NsfObject *oldTargetObject;
/*fprintf(stderr, "... DELETE preexisting cmd %s in ns %s\n", methodName, nsPtr->fullName);*/
oldTargetObject = NsfGetObjectFromCmdPtr(oldCmd);
/* fprintf(stderr, "oldTargetObject %p flags %.6x newTargetObject %p\n",
oldTargetObject, (oldTargetObject != NULL) ? oldTargetObject->flags : 0, newTargetObject);*/
/*
* We might have to decrement the reference counter on a previously
* aliased object. Decrement the reference count to the old aliased object
* only, when it is different to the new target Object.
*/
if (oldTargetObject != NULL && oldTargetObject != newTargetObject) {
/*fprintf(stderr, "--- releasing old target object %p refCount %d\n",
oldTargetObject, oldTargetObject->refCount);*/
assert(oldTargetObject->refCount > 0);
AliasDeleteObjectReference(interp, oldCmd);
}
#else
Tcl_DeleteCommandFromToken(interp, oldCmd);
#endif
}
if (newTargetObject != NULL) {
/*
* We set now for every alias to an object a stub proc, such we can
* distinguish between cases, where the user wants to create a method, and
* between cases, where object-invocation via method interface might
* happen.
*/
newObjProc = NsfProcAliasMethod;
} else if (CmdIsProc(cmd)) {
/*
* When we have a Tcl proc|nsf-method as alias, then use the
* wrapper, which will be deleted automatically when the original
* proc/method is deleted.
*/
newObjProc = NsfProcAliasMethod;
if (objProc == (TCL_OBJCMDPROC_T*)TclObjInterpProc) {
/*
* We have an alias to a Tcl proc;
*/
Proc *procPtr = (Proc *)Tcl_Command_objClientData(cmd);
Tcl_Obj *bodyObj = (procPtr != NULL) ? procPtr->bodyPtr : NULL;
if (bodyObj && bodyObj->typePtr == Nsf_OT_byteCodeType) {
/*
* Flush old byte code
*/
/*fprintf(stderr, "flush byte code\n");*/
TclFreeInternalRep(bodyObj);
}
}
if (withFrame && withFrame != FrameDefaultIdx) {
return NsfPrintError(interp,
"cannot use -frame object|method in alias for scripted command '%s'",
ObjStr(cmdNameObj));
}
}
if (newObjProc != NULL) {
/*
* Add a wrapper.
*/
/*fprintf(stderr, "NsfMethodAliasCmd add wrapper cmd %p\n", cmd);*/
NsfCommandPreserve(cmd);
tcd = NEW(AliasCmdClientData);
tcd->cmdName = object->cmdName;
tcd->interp = interp; /* just for deleting the alias */
tcd->object = NULL;
tcd->class = (class != NULL) ? (NsfClass *) object : NULL;
tcd->objProc = objProc;
tcd->aliasedCmd = cmd;
tcd->clientData = Tcl_Command_objClientData(cmd);
objProc = newObjProc;
deleteProc = AliasCmdDeleteProc;
if (tcd->cmdName != NULL) {
INCR_REF_COUNT(tcd->cmdName);
}
} else {
/*
* Call the command directly (must be a c-implemented command not
* depending on a volatile client data)
*/
deleteProc = NULL;
tcd = Tcl_Command_objClientData(cmd);
/*fprintf(stderr, "NsfMethodAliasCmd no wrapper cmd %p\n", (void*)cmd);*/
}
switch (withProtection) {
case ProtectionCall_protectedIdx: flags = NSF_CMD_CALL_PROTECTED_METHOD; break;
case ProtectionRedefine_protectedIdx: flags = NSF_CMD_REDEFINE_PROTECTED_METHOD; break;
case ProtectionNoneIdx: ;NSF_FALL_THROUGH; /* fall through */
case ProtectionNULL:
flags = 0u;
break;
}
if (class != NULL) {
result = NsfAddClassMethod(interp, (Nsf_Class *)class, methodName,
objProc, tcd, deleteProc, flags);
nsPtr = class->nsPtr;
} else {
result = NsfAddObjectMethod(interp, (Nsf_Object *)object, methodName,
objProc, tcd, deleteProc, flags);
nsPtr = object->nsPtr;
}
if (likely(result == TCL_OK)) {
newCmd = FindMethod(nsPtr, methodName);
} else {
newCmd = NULL;
}
#if defined(WITH_IMPORT_REFS)
if (newObjProc != NULL) {
/*
* Define the reference chain like for 'namespace import' to
* obtain automatic deletes when the original command is deleted.
*/
ImportRef *refPtr = (ImportRef *) ckalloc((int)sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) newCmd;
refPtr->nextPtr = ((Command *) tcd->aliasedCmd)->importRefPtr;
((Command *) tcd->aliasedCmd)->importRefPtr = refPtr;
tcd->aliasCmd = newCmd;
}
#else
if (newObjProc != NULL) {
tcd->aliasCmd = newCmd;
}
#endif
if (newCmd != NULL) {
AliasAdd(interp, object->cmdName, methodName, class == NULL, cmdNameObj);
if (withFrame == FrameMethodIdx) {
Tcl_Command_flags(newCmd) |= NSF_CMD_NONLEAF_METHOD;
/*fprintf(stderr, "setting aliased for cmd %p %s flags %.6x, tcd = %p\n",
newCmd, methodName, Tcl_Command_flags(newCmd), tcd);*/
}
Tcl_SetObjResult(interp, MethodHandleObj(object, class == NULL, methodName));
result = TCL_OK;
}
return result;
}
/*
cmd method::assertion NsfMethodAssertionCmd {
{-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
NsfMethodAssertionCmd(Tcl_Interp *interp, NsfObject *object, AssertionsubcmdIdx_t subcmd, Tcl_Obj *argObj) {
#if defined(NSF_WITH_ASSERTIONS)
NsfClass *class;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
switch (subcmd) {
case AssertionsubcmdCheckIdx:
if (argObj != NULL) {
return AssertionSetCheckOptions(interp, object, argObj);
} else {
return AssertionListCheckOption(interp, object);
}
/*break; unreachable */
case AssertionsubcmdObject_invarIdx:
if (argObj != NULL) {
NsfObjectOpt *opt = NsfRequireObjectOpt(object);
AssertionSetInvariants(interp, &opt->assertions, argObj);
} else {
if (object->opt != NULL && object->opt->assertions != NULL) {
Tcl_SetObjResult(interp, AssertionList(interp, object->opt->assertions->invariants));
}
}
break;
case AssertionsubcmdClass_invarIdx:
if (!NsfObjectIsClass(object)) {
return NsfPrintError(interp, "object is not a class");
}
class = (NsfClass *)object;
if (argObj != NULL) {
NsfClassOpt *opt = NsfRequireClassOpt(class);
AssertionSetInvariants(interp, &opt->assertions, argObj);
} else {
if (class->opt != NULL && class->opt->assertions != NULL) {
Tcl_SetObjResult(interp, AssertionList(interp, class->opt->assertions->invariants));
}
}
case AssertionsubcmdNULL:
/*
* Do nothing; just for detection if option was specified.
*/
break;
}
#endif
return TCL_OK;
}
/*
cmd method::create NsfMethodCreateCmd {
{-argName "object" -required 1 -type object}
{-argName "-checkalways" -required 0 -nrargs 0 -type switch}
{-argName "-inner-namespace"}
{-argName "-per-object"}
{-argName "-reg-object" -required 0 -nrargs 1 -type object}
{-argName "name" -required 1 -type tclobj}
{-argName "arguments" -required 1 -type tclobj}
{-argName "body" -required 1 -type tclobj}
{-argName "-precondition" -nrargs 1 -type tclobj}
{-argName "-postcondition" -nrargs 1 -type tclobj}
}
*/
static int
NsfMethodCreateCmd(Tcl_Interp *interp, NsfObject *object,
int withCheckalways, int withInner_namespace,
int withPer_object, NsfObject *regObject,
Tcl_Obj *methodNameObj, Tcl_Obj *argumentsObj, Tcl_Obj *bodyObj,
Tcl_Obj *preconditionObj, Tcl_Obj *postconditionObj) {
NsfClass *class;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodNameObj != NULL);
nonnull_assert(argumentsObj != NULL);
nonnull_assert(bodyObj != NULL);
class = (withPer_object || ! NsfObjectIsClass(object)) ? NULL : (NsfClass *)object;
if (class == NULL) {
RequireObjNamespace(interp, object);
}
return MakeMethod(interp, object, regObject, class,
methodNameObj, argumentsObj, bodyObj,
preconditionObj, postconditionObj,
withInner_namespace, (withCheckalways != 0) ? NSF_ARGPARSE_CHECK : 0);
}
/*
cmd "method::delete" NsfMethodDeleteCmd {
{-argName "object" -required 1 -type object}
{-argName "-per-object"}
{-argName "methodName" -required 1 -type tclobj}
}
*/
static int
NsfMethodDeleteCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object,
Tcl_Obj *methodNameObj) {
NsfObject *regObject, *defObject;
const char *methodName1 = NULL;
const NsfClass *class;
bool fromClassNS;
int result;
Tcl_DString ds, *dsPtr = &ds;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodNameObj != NULL);
class = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL;
fromClassNS = (class != NULL);
Tcl_DStringInit(dsPtr);
cmd = ResolveMethodName(interp, (class != NULL) ? class->nsPtr : object->nsPtr, methodNameObj,
dsPtr, ®Object, &defObject, &methodName1, &fromClassNS);
/*fprintf(stderr,
"NsfMethodDeleteCmd method %s '%s' object %p regObject %p defObject %p cl %p fromClass %d cmd %p\n",
ObjStr(methodNameObj), methodName1, object, regObject, defObject, cl, fromClassNS, cmd);*/
if (cmd != NULL) {
methodName1 = Tcl_GetCommandName(interp, cmd);
if (defObject != NULL) {
class = (withPer_object == 0 && NsfObjectIsClass(defObject)) ? (NsfClass *)defObject : NULL;
} else {
defObject = object;
}
if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
result = (class != NULL) ?
NsfRemoveClassMethod(interp, (Nsf_Class *)defObject, methodName1) :
NsfRemoveObjectMethod(interp, (Nsf_Object *)defObject, methodName1);
} else {
result = TCL_OK;
}
} else {
result = NsfPrintError(interp, "%s: %s method '%s' does not exist",
ObjectName_(object), (withPer_object == 1) ? "object specific" : "instance",
ObjStr(methodNameObj));
}
Tcl_DStringFree(dsPtr);
return result;
}
/*
cmd method::forward NsfMethodForwardCmd {
{-argName "object" -required 1 -type object}
{-argName "-per-object" -required 0 -nrargs 0 -type switch}
{-argName "method" -required 1 -type tclobj}
{-argName "-default" -type tclobj}
{-argName "-earlybinding" -nrargs 0}
{-argName "-prefix" -type tclobj}
{-argName "-frame" -nrargs 1 -type "object|method|default" -default default}
{-argName "-verbose" -nrargs 0}
{-argName "target" -type tclobj}
{-argName "args" -type args}
}
*/
static int
NsfMethodForwardCmd(Tcl_Interp *interp,
NsfObject *object,
int withPer_object,
Tcl_Obj *methodObj,
Tcl_Obj *defaultObj,
int withEarlybinding,
Tcl_Obj *onerrorObj,
Tcl_Obj *prefixObj,
FrameIdx_t withFrame,
int withVerbose,
Tcl_Obj *targetObj,
TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
ForwardCmdClientData *tcd = NULL;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodObj != NULL);
result = ForwardProcessOptions(interp,
methodObj,
defaultObj,
withEarlybinding,
onerrorObj,
prefixObj,
(int)withFrame,
(withVerbose == 1),
targetObj,
trailingObjc, trailingObjv,
&tcd);
if (likely(result == TCL_OK)) {
const char *methodName = NSTail(ObjStr(methodObj));
NsfClass *class =
(withPer_object || ! NsfObjectIsClass(object)) ?
NULL : (NsfClass *)object;
tcd->object = object;
if (class == NULL) {
result = NsfAddObjectMethod(interp, (Nsf_Object *)object, methodName,
(TCL_OBJCMDPROC_T *)NsfForwardMethod,
tcd, ForwardCmdDeleteProc, 0u);
} else {
result = NsfAddClassMethod(interp, (Nsf_Class *)class, methodName,
(TCL_OBJCMDPROC_T *)NsfForwardMethod,
tcd, ForwardCmdDeleteProc, 0u);
}
if (likely(result == TCL_OK)) {
Tcl_SetObjResult(interp, MethodHandleObj(object, (class == NULL), methodName));
}
}
if (result != TCL_OK && tcd != NULL) {
ForwardCmdDeleteProc(tcd);
}
return result;
}
/*
cmd "method::forward::property" NsfForwardPropertyCmd {
{-argName "object" -required 1 -type object}
{-argName "-per-object" -required 0 -nrargs 0 -type switch}
{-argName "methodName" -required 1 -type tclobj}
{-argName "forwardProperty" -required 1 -type "target|verbose"}
{-argName "value" -type tclobj}
}
*/
static int
NsfForwardPropertyCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object,
Tcl_Obj *methodNameObj, ForwardpropertyIdx_t forwardProperty, Tcl_Obj *valueObj) {
ForwardCmdClientData *tcd;
TCL_OBJCMDPROC_T *procPtr;
Tcl_Command cmd;
NsfObject *defObject;
const NsfClass *class;
bool fromClassNS;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodNameObj != NULL);
class = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL;
fromClassNS = (class != NULL);
cmd = ResolveMethodName(interp, (class != NULL) ? class->nsPtr : object->nsPtr, methodNameObj,
NULL, NULL, &defObject, NULL, &fromClassNS);
if (unlikely(cmd == NULL)) {
return NsfPrintError(interp, "cannot lookup %smethod '%s' for %s",
class == NULL ? "object " : "",
ObjStr(methodNameObj), ObjectName_(object));
}
procPtr = TCL_COMMAND_OBJPROC(cmd);
if (procPtr != NsfForwardMethod) {
return NsfPrintError(interp, "%s is not a forwarder method",
ObjStr(methodNameObj));
}
tcd = (ForwardCmdClientData *)Tcl_Command_objClientData(cmd);
if (tcd == NULL) {
return NsfPrintError(interp, "forwarder method has no client data");
}
switch (forwardProperty) {
case ForwardpropertyTargetIdx:
if (valueObj != NULL) {
DECR_REF_COUNT(tcd->cmdName);
INCR_REF_COUNT(valueObj);
tcd->cmdName = valueObj;
}
Tcl_SetObjResult(interp, tcd->cmdName);
break;
case ForwardpropertyPrefixIdx:
if (valueObj != NULL) {
DECR_REF_COUNT(tcd->prefix);
INCR_REF_COUNT(valueObj);
tcd->prefix = valueObj;
}
Tcl_SetObjResult(interp, tcd->prefix);
break;
case ForwardpropertyVerboseIdx:
if (valueObj != NULL) {
int boolValue;
Tcl_GetBooleanFromObj(interp, valueObj, &boolValue);
tcd->verbose = (boolValue != 0);
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(tcd->verbose));
break;
case ForwardpropertyNULL:
/*
* Do nothing; just for detection if option was specified.
*/
break;
}
return TCL_OK;
}
/*
cmd ::method::property NsfMethodPropertyCmd {
{-argName "object" -required 1 -type object}
{-argName "-per-object"}
{-argName "methodName" -required 1 -type tclobj}
{-argName "methodProperty" -required 1 -type "class-only|call-private|call-protected|debug|deprecated|exists|redefine-protected|returns"}
{-argName "value" -type tclobj}
}
*/
static int
NsfMethodPropertyCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object,
Tcl_Obj *methodNameObj, MethodpropertyIdx_t methodProperty, Tcl_Obj *valueObj) {
NsfObject *defObject;
Tcl_Command cmd;
const NsfClass *class;
bool fromClassNS;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(methodNameObj != NULL);
class = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL;
fromClassNS = (class != NULL);
cmd = ResolveMethodName(interp,
(class != NULL) ? class->nsPtr : object->nsPtr,
methodNameObj, NULL, NULL, &defObject, NULL, &fromClassNS);
/*fprintf(stderr, "methodProperty for method '%s' prop %d value %s => cl %p cmd %p\n",
ObjStr(methodNameObj), methodproperty, (valueObj != NULL) ? ObjStr(valueObj) : "NULL", cl, cmd);*/
if (unlikely(cmd == NULL)) {
if (methodProperty == MethodpropertyExistsIdx) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
return TCL_OK;
} else {
return NsfPrintError(interp, "cannot lookup %smethod '%s' for %s",
class == NULL ? "object " : "",
ObjStr(methodNameObj), ObjectName_(object));
}
}
switch (methodProperty) {
case MethodpropertyExistsIdx:
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
break;
case MethodpropertyClass_onlyIdx: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyCall_privateIdx: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyCall_protectedIdx: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyDebugIdx: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyDeprecatedIdx: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyRedefine_protectedIdx:
{
int impliedSetFlag = 0, impliedClearFlag = 0;
unsigned int flag = 0u;
switch (methodProperty) {
case MethodpropertyClass_onlyIdx:
flag = NSF_CMD_CLASS_ONLY_METHOD;
break;
case MethodpropertyCall_privateIdx:
flag = NSF_CMD_CALL_PRIVATE_METHOD;
impliedSetFlag = NSF_CMD_CALL_PROTECTED_METHOD;
break;
case MethodpropertyCall_protectedIdx:
impliedClearFlag = NSF_CMD_CALL_PRIVATE_METHOD;
flag = NSF_CMD_CALL_PROTECTED_METHOD;
break;
case MethodpropertyDebugIdx:
flag = NSF_CMD_DEBUG_METHOD;
break;
case MethodpropertyDeprecatedIdx:
flag = NSF_CMD_DEPRECATED_METHOD;
break;
case MethodpropertyRedefine_protectedIdx:
flag = NSF_CMD_REDEFINE_PROTECTED_METHOD;
break;
case MethodpropertyNULL: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyReturnsIdx: ;NSF_FALL_THROUGH; /* fall through */
case MethodpropertyExistsIdx:
flag = 0u;
break;
}
if (valueObj != NULL) {
int boolVal, result;
result = Tcl_GetBooleanFromObj(interp, valueObj, &boolVal);
if (unlikely(result != TCL_OK)) {
return result;
}
if (boolVal != 0) {
/*
* set flag
*/
Tcl_Command_flags(cmd) |= (int)flag;
if (impliedSetFlag != 0) {
Tcl_Command_flags(cmd) |= (int)impliedSetFlag;
}
} else {
/*
* clear flag
*/
Tcl_Command_flags(cmd) &= (int)~flag;
if (impliedClearFlag != 0) {
Tcl_Command_flags(cmd) &= (int)~impliedClearFlag;
}
}
if (class != NULL) {
NsfInstanceMethodEpochIncr("Permissions");
} else {
NsfObjectMethodEpochIncr("Permissions");
}
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), ((unsigned int)Tcl_Command_flags(cmd) & flag) != 0u);
}
break;
case MethodpropertyReturnsIdx:
{
NsfProcContext *pCtx = ProcContextGet(cmd);
/*fprintf(stderr, "MethodProperty, ParamDefsGet cmd %p paramDefs %p returns %p\n",
cmd, paramDefs, (paramDefs != NULL) ? paramDefs->returns:NULL);*/
if (valueObj == NULL) {
/*
* Return the actual value for "returns".
*/
Tcl_Obj *resultObj;
if (pCtx == NULL || pCtx->returnsObj == NULL) {
resultObj = NsfGlobalObjs[NSF_EMPTY];
} else {
resultObj = pCtx->returnsObj;
}
Tcl_SetObjResult(interp, resultObj);
} else {
/*
* Set the value of "returns".
*/
ParamDefsSetReturns(cmd, valueObj);
}
}
break;
case MethodpropertyNULL:
/*
* Do nothing; just for detection if option was specified.
*/
break;
}
return TCL_OK;
}
/*
cmd "method::registered" NsfMethodRegisteredCmd {
{-argName "handle" -required 1 -type tclobj}
}
*/
static int
NsfMethodRegisteredCmd(Tcl_Interp *interp, Tcl_Obj *handleObj) {
NsfObject *regObject;
bool fromClassNS = NSF_FALSE;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(handleObj != NULL);
cmd = ResolveMethodName(interp, NULL, handleObj,
NULL, ®Object, NULL, NULL, &fromClassNS);
/*
* In case the provided cmd is fully qualified and refers to a registered
* method, the function returns the object, on which the method was
* resisted.
*/
Tcl_SetObjResult(interp, ((cmd != NULL) && (regObject != NULL)) ? regObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
return TCL_OK;
}
/*
cmd method::setter NsfMethodSetterCmd {
{-argName "object" -required 1 -type object}
{-argName "-per-object"}
{-argName "parameter" -type tclobj}
}
*/
static int
NsfMethodSetterCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object, Tcl_Obj *parameterObj) {
SetterCmdClientData *setterClientData;
const NsfClass *class;
const char *methodName;
size_t j, length;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(parameterObj != NULL);
methodName = ObjStr(parameterObj);
if (unlikely(*methodName == '-' || *methodName == ':')) {
return NsfPrintError(interp, "invalid setter name \"%s\" (must not start with a dash or colon)",
methodName);
}
setterClientData = NEW(SetterCmdClientData);
setterClientData->object = NULL;
setterClientData->paramsPtr = NULL;
length = strlen(methodName);
for (j = 0; j < length; j++) {
if (methodName[j] == ':' || NsfHasTclSpace(&methodName[j])) {
break;
}
}
class = (withPer_object || ! NsfObjectIsClass(object)) ? NULL : (NsfClass *)object;
if (j < length) {
/*
* Looks as if we have a parameter specification.
*/
int rc, possibleUnknowns = 0, nrNonposArgs = 0;
TCL_SIZE_T plainParams = 0;
NsfObject *ctx = (class != NULL) ? (NsfObject *)class : object;
Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(ctx->id);
setterClientData->paramsPtr = ParamsNew(1u);
rc = ParamDefinitionParse(interp, NsfGlobalObjs[NSF_SETTER], parameterObj,
NSF_DISALLOWED_ARG_SETTER|NSF_ARG_HAS_DEFAULT,
setterClientData->paramsPtr, &possibleUnknowns,
&plainParams, &nrNonposArgs,
nsPtr != NULL ? nsPtr->fullName : NULL);
if (unlikely(rc != TCL_OK)) {
SetterCmdDeleteProc(setterClientData);
return rc;
}
methodName = setterClientData->paramsPtr->name;
} else {
setterClientData->paramsPtr = NULL;
}
if (class != NULL) {
result = NsfAddClassMethod(interp, (Nsf_Class *)class, methodName,
(TCL_OBJCMDPROC_T *)NsfSetterMethod,
setterClientData, SetterCmdDeleteProc, 0u);
} else {
result = NsfAddObjectMethod(interp, (Nsf_Object *)object, methodName,
(TCL_OBJCMDPROC_T *)NsfSetterMethod,
setterClientData, SetterCmdDeleteProc, 0u);
}
if (likely(result == TCL_OK)) {
Tcl_SetObjResult(interp, MethodHandleObj(object, class == NULL, methodName));
} else {
SetterCmdDeleteProc(setterClientData);
}
return result;
}
/*
cmd "object::alloc" NsfObjectAllocCmd {
{-argName "class" -required 1 -type class}
{-argName "name" -required 1 -type tclobj}
{-argName "initcmd" -required 0 -type tclobj}
}
*/
static int
NsfObjectAllocCmd(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, Tcl_Obj *initcmdObj) {
Tcl_Obj *newNameObj = NULL;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(nameObj != NULL);
/*
* If the provided name is empty, make a new symbol
*/
if (strlen(ObjStr(nameObj)) == 0) {
Tcl_DString ds, *dsPtr = &ds;
Tcl_DStringInit(dsPtr);
Tcl_DStringAppend(dsPtr, autonamePrefix, (int)autonamePrefixLength);
NewTclCommand(interp, dsPtr);
newNameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
INCR_REF_COUNT(newNameObj);
Tcl_DStringFree(dsPtr);
nameObj = newNameObj;
}
/*fprintf(stderr, "trying to alloc <%s>\n", ObjStr(nameObj));*/
result = NsfCAllocMethod(interp, class, nameObj);
if (result == TCL_OK && initcmdObj != NULL) {
NsfObject *object;
Tcl_Obj *initNameObj = Tcl_GetObjResult(interp);
INCR_REF_COUNT(initNameObj);
if (unlikely(GetObjectFromObj(interp, initNameObj, &object) != TCL_OK)) {
result = NsfPrintError(interp, "couldn't find result of alloc");
} else {
result = NsfDirectDispatchCmd(interp, object, 1,
NsfGlobalObjs[NSF_EVAL],
1, &initcmdObj);
if (likely(result == TCL_OK)) {
Tcl_SetObjResult(interp, initNameObj);
}
}
DECR_REF_COUNT(initNameObj);
}
if (newNameObj != NULL) {
DECR_REF_COUNT(newNameObj);
}
return result;
}
/*
cmd "object::exists" NsfObjectExistsCmd {
{-argName "value" -required 1 -type tclobj}
}
*/
static int
NsfObjectExistsCmd(Tcl_Interp *interp, Tcl_Obj *valueObj) {
NsfObject *object;
nonnull_assert(interp != NULL);
nonnull_assert(valueObj != NULL);
/*
* Pass the object as Tcl_Obj, since we do not want to raise an error in
* case the object does not exist.
*/
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), GetObjectFromObj(interp, valueObj, &object) == TCL_OK);
return TCL_OK;
}
/*
cmd "object::property" NsfObjectPropertyCmd {
{-argName "object" -required 1 -type object}
{-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|volatile|autonamed|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch" -required 1}
{-argName "value" -required 0 -type tclobj}
}
*/
static int
NsfObjectPropertyCmd(Tcl_Interp *interp, NsfObject *object, ObjectpropertyIdx_t objectProperty, Tcl_Obj *valueObj) {
unsigned int flags = 0u, allowSet = 0u;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
switch (objectProperty) {
case ObjectpropertyAutonamedIdx: flags = NSF_IS_AUTONAMED; allowSet = 1; break;
case ObjectpropertyInitializedIdx: flags = NSF_INIT_CALLED; allowSet = 1; break;
case ObjectpropertyClassIdx: flags = NSF_IS_CLASS; break;
case ObjectpropertyRootmetaclassIdx: flags = NSF_IS_ROOT_META_CLASS; break;
case ObjectpropertyVolatileIdx:
if (valueObj == NULL) {
Tcl_SetObjResult(interp,
NsfGlobalObjs[object->opt != NULL && object->opt->volatileVarName ? NSF_ONE : NSF_ZERO]);
return TCL_OK;
}
allowSet = 1;
break;
/*
* If a value is provided, return the error below.
*/
case ObjectpropertyRootclassIdx: flags = NSF_IS_ROOT_CLASS; break;
case ObjectpropertySlotcontainerIdx: flags = NSF_IS_SLOT_CONTAINER; allowSet = 1; break;
case ObjectpropertyKeepcallerselfIdx: flags = NSF_KEEP_CALLER_SELF; allowSet = 1; break;
case ObjectpropertyPerobjectdispatchIdx: flags = NSF_PER_OBJECT_DISPATCH; allowSet = 1; break;
case ObjectpropertyHasperobjectslotsIdx: flags = NSF_HAS_PER_OBJECT_SLOTS; allowSet = 1; break;
case ObjectpropertyNULL:
/*
* Do nothing; just for detection if option was specified.
*/
break;
}
if (valueObj != NULL) {
if (likely(allowSet)) {
int flagValue, result;
result = SetBooleanFlag(interp, &object->flags, flags, valueObj, &flagValue);
if (unlikely(result != TCL_OK)) {
return result;
}
if (objectProperty == ObjectpropertySlotcontainerIdx) {
assert(object->nsPtr != NULL);
if (flagValue != 0) {
/*
* Turn on SlotContainerCmdResolver.
*/
Tcl_SetNamespaceResolvers(object->nsPtr,
(Tcl_ResolveCmdProc *)SlotContainerCmdResolver,
NsColonVarResolver,
(Tcl_ResolveCompiledVarProc *)NULL);
} else {
/*
* Turn off SlotContainerCmdResolver.
*/
Tcl_SetNamespaceResolvers(object->nsPtr,
(Tcl_ResolveCmdProc *)NULL,
NsColonVarResolver,
(Tcl_ResolveCompiledVarProc *)NULL);
}
} else if (objectProperty == ObjectpropertyVolatileIdx) {
bool objectIsVolatile = (object->opt != NULL && object->opt->volatileVarName != NULL);
if (flagValue != 0 && !objectIsVolatile) {
/*
* Set volatile property.
*/
/*NsfObjectSystem *osPtr = GetObjectSystem(object);*/
/*fprintf(stderr, "change volatile ... make volatile %s\n",
ObjectName(&osPtr->rootClass->object));*/
result = VolatileMethod(interp, object, NSF_TRUE);
} else if (flagValue == 0 && objectIsVolatile) {
/*
* Remove volatile property.
*/
UnsetTracedVars(interp, object);
object->opt->volatileVarName = NULL;
} else {
/*
* Nothing to do.
*/
}
if (unlikely(result != TCL_OK)) {
return result;
}
}
} else {
return NsfPrintError(interp, "object property is read only");
}
}
Tcl_SetObjResult(interp,
NsfGlobalObjs[(object->flags & flags) ?
NSF_ONE : NSF_ZERO]);
return TCL_OK;
}
/*
cmd "object::qualify" NsfObjectQualifyCmd {
{-argName "objectName" -required 1 -type tclobj}
}
*/
static int
NsfObjectQualifyCmd(Tcl_Interp *interp, Tcl_Obj *objectNameObj) {
const char *nameString;
nonnull_assert(interp != NULL);
nonnull_assert(objectNameObj != NULL);
nameString = ObjStr(objectNameObj);
if (isAbsolutePath(nameString)) {
Tcl_SetObjResult(interp, objectNameObj);
} else {
Tcl_SetObjResult(interp, NameInNamespaceObj(nameString, CallingNameSpace(interp)));
}
return TCL_OK;
}
/*
cmd "objectsystem::create" NsfObjectSystemCreateCmd {
{-argName "rootClass" -required 1 -type tclobj}
{-argName "rootMetaClass" -required 1 -type tclobj}
{-argName "systemMethods" -required 0 -type tclobj}
}
*/
static int
NsfObjectSystemCreateCmd(Tcl_Interp *interp, Tcl_Obj *rootClassObj, Tcl_Obj *rootMetaClassObj, Tcl_Obj *systemMethodsObj) {
NsfClass *theobj = NULL, *thecls = NULL;
Tcl_Obj *object, *class;
const char *objectName, *className;
NsfObjectSystem *osPtr;
nonnull_assert(interp != NULL);
nonnull_assert(rootClassObj != NULL);
nonnull_assert(rootMetaClassObj != NULL);
osPtr = NEW(NsfObjectSystem);
memset(osPtr, 0, sizeof(NsfObjectSystem));
objectName = ObjStr(rootClassObj);
object = isAbsolutePath(objectName) ? rootClassObj :
NameInNamespaceObj(objectName, CallingNameSpace(interp));
className = ObjStr(rootMetaClassObj);
class = isAbsolutePath(className) ? rootMetaClassObj :
NameInNamespaceObj(className, CallingNameSpace(interp));
GetClassFromObj(interp, object, &theobj, NSF_FALSE);
GetClassFromObj(interp, class, &thecls, NSF_FALSE);
if ((theobj != NULL) || (thecls != NULL)) {
ObjectSystemFree(interp, osPtr);
NsfLog(interp, NSF_LOG_WARN, "Base class '%s' exists already; ignoring definition",
(theobj != NULL) ? objectName : className);
return TCL_OK;
}
if (systemMethodsObj != NULL) {
int idx;
TCL_SIZE_T oc;
Tcl_Obj **ov;
if ((Tcl_ListObjGetElements(interp, systemMethodsObj, &oc, &ov)) == TCL_OK) {
TCL_SIZE_T i;
if (oc % 2) {
ObjectSystemFree(interp, osPtr);
return NsfPrintError(interp, "system methods must be provided as pairs");
}
for (i = 0; i < oc; i += 2) {
Tcl_Obj *arg, **arg_ov = NULL;
ptrdiff_t arg_oc = -1;
int result;
arg = ov[i+1];
result = Tcl_GetIndexFromObj(interp, ov[i], Nsf_SystemMethodOpts, "system method", 0, &idx);
if (likely(result == TCL_OK)) {
TCL_SIZE_T nrSplitElelements;
result = Tcl_ListObjGetElements(interp, arg, &nrSplitElelements, &arg_ov);
arg_oc = (ptrdiff_t)nrSplitElelements;
}
if (unlikely(result != TCL_OK)) {
ObjectSystemFree(interp, osPtr);
return NsfPrintError(interp, "invalid system method '%s'", ObjStr(ov[i]));
} else if (arg_oc < 1 || arg_oc > 3) {
ObjectSystemFree(interp, osPtr);
return NsfPrintError(interp, "invalid system method argument '%s'", ObjStr(ov[i]), ObjStr(arg));
}
/*fprintf(stderr, "NsfCreateObjectSystemCmd [%d] = %p %s (max %d, given %d)\n",
idx, ov[i+1], ObjStr(ov[i+1]), NSF_s_set_idx, oc);*/
if (arg_oc == 1) {
osPtr->methods[idx] = arg;
osPtr->methodNames[idx] = ObjStr(arg);
} else { /* (arg_oc == 2) */
osPtr->methods[idx] = arg_ov[0];
osPtr->methodNames[idx] = ObjStr(arg_ov[0]);
osPtr->handles[idx] = arg_ov[1];
if (arg_oc == 3) {
int boolVal = 0;
Tcl_GetBooleanFromObj(interp, arg_ov[2], &boolVal);
osPtr->protected[idx] = (char)boolVal;
}
INCR_REF_COUNT(osPtr->handles[idx]);
}
INCR_REF_COUNT(osPtr->methods[idx]);
}
} else {
ObjectSystemFree(interp, osPtr);
return NsfPrintError(interp, "provided system methods are not a proper list");
}
}
/*
* 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, NULL);
thecls = PrimitiveCCreate(interp, class, NULL, NULL);
/* fprintf(stderr, "CreateObjectSystem created base classes \n"); */
/*
* Check whether Object and Class creation was successful.
*/
if ((theobj == NULL) || (thecls == NULL)) {
if (thecls != NULL) {
PrimitiveCDestroy(thecls);
}
if (theobj != NULL) {
PrimitiveCDestroy(theobj);
}
ObjectSystemFree(interp, osPtr);
return NsfPrintError(interp, "creation of object system failed");
}
theobj->osPtr = osPtr;
thecls->osPtr = osPtr;
osPtr->rootClass = theobj;
osPtr->rootMetaClass = thecls;
theobj->object.flags |= (NSF_IS_ROOT_CLASS|NSF_INIT_CALLED);
thecls->object.flags |= (NSF_IS_ROOT_META_CLASS|NSF_INIT_CALLED);
ObjectSystemAdd(interp, osPtr);
AddInstance((NsfObject *)theobj, thecls);
AddInstance((NsfObject *)thecls, thecls);
AddSuper(thecls, theobj);
if (NSF_DTRACE_OBJECT_ALLOC_ENABLED()) {
NSF_DTRACE_OBJECT_ALLOC(ObjectName((NsfObject *)theobj), ClassName(((NsfObject *)theobj)->cl));
NSF_DTRACE_OBJECT_ALLOC(ObjectName((NsfObject *)thecls), ClassName(((NsfObject *)thecls)->cl));
}
return TCL_OK;
}
/*
cmd my NsfMyCmd {
{-argName "-intrinsic" -nrargs 0}
{-argName "-local" -nrargs 0}
{-argName "-system" -nrargs 0}
{-argName "method" -required 1 -type tclobj}
{-argName "args" -type args}
}
*/
static int
NsfMyCmd(Tcl_Interp *interp,
int withIntrinsic, int withLocal, int withSystem,
Tcl_Obj *methodNameObj,
TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
NsfObject *self;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(methodNameObj != NULL);
self = GetSelfObj(interp);
if (unlikely(self == NULL)) {
result = NsfNoCurrentObjectError(interp, method_definitions[NsfMyCmdIdx].methodName);
} else if ((withIntrinsic && withLocal)
|| (withIntrinsic && withSystem)
|| (withLocal && withSystem)) {
result = NsfPrintError(interp, "flags '-intrinsic', '-local' and '-system' are mutual exclusive");
} else {
unsigned int flags;
#if 0
/* TODO attempt to make "my" NRE-enabled, failed so far (crash in mixinInheritanceTest) */
NsfCallStackContent *cscPtr = CallStackGetTopFrame0(interp);
if (cscPtr == NULL || self != cscPtr->self) {
flags = NSF_CSC_IMMEDIATE;
} else {
flags = NsfImmediateFromCallerFlags(cscPtr->flags);
fprintf(stderr, "XXX MY %s.%s frame has flags %.6x -> next-flags %.6x\n",
ObjectName(self), ObjStr(methodNameObj), cscPtr->flags, flags);
}
if (withIntrinsic != 0) {flags |= NSF_CM_INTRINSIC_METHOD;}
if (withLocal != 0) {flags |= NSF_CM_LOCAL_METHOD;}
if (withSystem != 0) {flags |= NSF_CM_SYSTEM_METHOD;}
result = CallMethod(self, interp, methodNameObj, trailingObjc+2, trailingObjv, flags);
#else
flags = NSF_CSC_IMMEDIATE;
if (withIntrinsic != 0) {flags |= NSF_CM_INTRINSIC_METHOD;}
if (withLocal != 0) {flags |= NSF_CM_LOCAL_METHOD;}
if (withSystem != 0) {flags |= NSF_CM_SYSTEM_METHOD;}
result = CallMethod(self, interp, methodNameObj, trailingObjc+2, trailingObjv, flags);
#endif
}
return result;
}
/*
*----------------------------------------------------------------------
* NsfNextCmd --
*
* nsf::next calls the next shadowed method. It might get a single
* argument which is used as argument vector for that method. If no
* argument is provided, the argument vector of the last invocation
* is used.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The invoked method might produce side effects
*
*----------------------------------------------------------------------
*/
/*
cmd next NsfNextCmd {
{-argName "arguments" -required 0 -type tclobj}
}
*/
static int
NsfNextCmd(Tcl_Interp *interp, Tcl_Obj *argumentsObj) {
TCL_OBJC_T nobjc = 0;
ptrdiff_t oc;
int result;
bool freeArgumentVector;
NsfCallStackContent *cscPtr = NULL;
const char *methodName = NULL;
Tcl_Obj **nobjv = NULL, **ov;
nonnull_assert(interp != NULL);
if (argumentsObj != NULL) {
/*
* Arguments were provided.
*/
TCL_SIZE_T ocValue = 0;
int rc;
rc = Tcl_ListObjGetElements(interp, argumentsObj, &ocValue, &ov);
if (unlikely(rc != TCL_OK)) {
return rc;
}
oc = (ptrdiff_t)ocValue;
} else {
/*
* No arguments were provided.
*/
oc = -1;
ov = NULL;
}
result = NextGetArguments(interp, oc, ov, &cscPtr, &methodName,
&nobjc, &nobjv, &freeArgumentVector);
if (likely(result == TCL_OK)) {
assert(cscPtr != NULL);
assert(methodName != NULL);
result = NextSearchAndInvoke(interp, methodName, nobjc, nobjv, cscPtr, freeArgumentVector);
}
return result;
}
/*
cmd nscopyvars NsfNSCopyVars {
{-argName "fromNs" -required 1 -type tclobj}
{-argName "toNs" -required 1 -type tclobj}
}
*/
static int
NsfNSCopyVarsCmd(Tcl_Interp *interp, Tcl_Obj *fromNsObj, Tcl_Obj *toNsObj) {
Tcl_Namespace *fromNsPtr = NULL, *toNsPtr;
Var *varPtr = NULL;
Tcl_HashSearch hSrch;
const Tcl_HashEntry *hPtr;
TclVarHashTable *varTablePtr;
NsfObject *destObject;
const char *destFullName;
Tcl_Obj *destFullNameObj;
Tcl_CallFrame frame, *framePtr = &frame;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(fromNsObj != NULL);
nonnull_assert(toNsObj != NULL);
TclGetNamespaceFromObj(interp, fromNsObj, &fromNsPtr);
if (fromNsPtr != NULL) {
if (TclGetNamespaceFromObj(interp, toNsObj, &toNsPtr) != TCL_OK) {
return NsfPrintError(interp, "CopyVars: Destination namespace %s does not exist",
ObjStr(toNsObj));
}
destFullName = toNsPtr->fullName;
destFullNameObj = Tcl_NewStringObj(destFullName, TCL_INDEX_NONE);
INCR_REF_COUNT(destFullNameObj);
varTablePtr = Tcl_Namespace_varTablePtr(fromNsPtr);
Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, toNsPtr, 0);
} else {
NsfObject *newObject, *object;
if (GetObjectFromObj(interp, fromNsObj, &object) != TCL_OK) {
return NsfPrintError(interp, "CopyVars: Origin object/namespace %s does not exist",
ObjStr(fromNsObj));
} else if (GetObjectFromObj(interp, toNsObj, &newObject) != TCL_OK) {
return NsfPrintError(interp, "CopyVars: Destination object/namespace %s does not exist",
ObjStr(toNsObj));
} else {
varTablePtr = object->varTablePtr;
destFullNameObj = newObject->cmdName;
destFullName = ObjStr(destFullNameObj);
}
}
destObject = GetObjectFromString(interp, destFullName);
result = TCL_OK;
/*
* Copy all vars in the namespace.
*/
hPtr = (varTablePtr != NULL) ? Tcl_FirstHashEntry(TclVarHashTablePtr(varTablePtr), &hSrch) : NULL;
while (hPtr != NULL) {
Tcl_Obj *varNameObj, *resultObj;
GetVarAndNameFromHash(hPtr, &varPtr, &varNameObj);
INCR_REF_COUNT(varNameObj);
if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) {
if (TclIsVarScalar(varPtr)) {
/*
* Copy scalar variables from the namespace, which might be
* either instance or namespace variables.
*/
if (destObject != NULL) {
/* fprintf(stderr, "copy in obj %s var %s val '%s'\n", ObjectName(destObject), ObjStr(varNameObj),
ObjStr(TclVarValue(Tcl_Obj, varPtr, objPtr)));*/
resultObj = Nsf_ObjSetVar2((Nsf_Object *)destObject, interp, varNameObj, NULL,
TclVarValue(Tcl_Obj, varPtr, objPtr), TCL_LEAVE_ERR_MSG);
} else {
resultObj = Tcl_ObjSetVar2(interp, varNameObj, NULL,
TclVarValue(Tcl_Obj, varPtr, objPtr),
TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
}
if (unlikely(resultObj == NULL)) {
DECR_REF_COUNT(varNameObj);
result = TCL_ERROR;
goto copy_done;
}
} else {
if (TclIsVarArray(varPtr)) {
/* HERE!! PRE85 Why not [array get/set] based? Let the core iterate */
TclVarHashTable *aTable = TclVarValue(TclVarHashTable, varPtr, tablePtr);
Tcl_HashSearch ahSrch;
Tcl_HashEntry *ahPtr = (aTable != NULL) ? Tcl_FirstHashEntry(TclVarHashTablePtr(aTable), &ahSrch) : 0;
for (; ahPtr != NULL; ahPtr = Tcl_NextHashEntry(&ahSrch)) {
Tcl_Obj *eltNameObj;
Var *eltVar;
GetVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj);
INCR_REF_COUNT(eltNameObj);
if (TclIsVarScalar(eltVar)) {
if (destObject != NULL) {
resultObj = Nsf_ObjSetVar2((Nsf_Object *)destObject, interp, varNameObj, eltNameObj,
TclVarValue(Tcl_Obj, eltVar, objPtr), TCL_LEAVE_ERR_MSG);
} else {
resultObj = Tcl_ObjSetVar2(interp, varNameObj, eltNameObj,
TclVarValue(Tcl_Obj, eltVar, objPtr),
TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
}
if (unlikely(resultObj == NULL)) {
DECR_REF_COUNT(varNameObj);
result = TCL_ERROR;
goto copy_done;
}
}
DECR_REF_COUNT(eltNameObj);
}
}
}
}
DECR_REF_COUNT(varNameObj);
hPtr = Tcl_NextHashEntry(&hSrch);
}
copy_done:
if (fromNsPtr != NULL) {
DECR_REF_COUNT(destFullNameObj);
Tcl_PopCallFrame(interp);
}
return result;
}
/*
cmd parameter::info NsfParameterInfoCmd {
{-argName "subcmd" -typeName "parametersubcmd" -type "default|list|name|syntax|type" -required 1}
{-argName "parameterspec" -required 1 -type tclobj}
{-argName "varname" -required 0 -type tclobj}
}
*/
static int
NsfParameterInfoCmd(Tcl_Interp *interp, ParametersubcmdIdx_t subcmd, Tcl_Obj *specObj, Tcl_Obj *varnameObj) {
NsfParsedParam parsedParam;
Tcl_Obj *paramsObj, *listObj = NULL;
Nsf_Param *paramsPtr;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(specObj != NULL);
if (subcmd != ParametersubcmdDefaultIdx && varnameObj != NULL) {
return NsfPrintError(interp, "parameter::info: provided third argument is only valid for querying defaults");
}
paramsObj = Tcl_NewListObj(1, &specObj);
INCR_REF_COUNT(paramsObj);
result = ParamDefsParse(interp, NULL, paramsObj,
NSF_DISALLOWED_ARG_OBJECT_PARAMETER, NSF_TRUE,
&parsedParam, NULL);
DECR_REF_COUNT(paramsObj);
if (unlikely(result != TCL_OK)) {
return result;
}
assert(parsedParam.paramDefs != NULL);
paramsPtr = parsedParam.paramDefs->paramsPtr;
assert(paramsPtr != NULL);
/*
* Since we are passing in a parameter definition in Tcl syntax, and we want
* to extract information from that syntax, it makes limited sense to
* provide a context object for virtual parameter expansion. At least, we do
* not allow this so far.
*/
switch (subcmd) {
case ParametersubcmdDefaultIdx:
if (paramsPtr->defaultValue != NULL) {
if (varnameObj != NULL) {
Tcl_Obj *resultObj = Tcl_ObjSetVar2(interp, varnameObj, NULL,
paramsPtr->defaultValue,
TCL_LEAVE_ERR_MSG);
if (unlikely(resultObj == NULL)) {
ParamDefsRefCountDecr(parsedParam.paramDefs);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_ONE]);
} else {
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_ZERO]);
}
break;
case ParametersubcmdListIdx:
listObj = ParamDefsList(interp, paramsPtr, NULL, NULL);
Tcl_SetObjResult(interp, listObj);
DECR_REF_COUNT2("paramDefsObj", listObj);
break;
case ParametersubcmdNameIdx:
listObj = ParamDefsNames(interp, paramsPtr, NULL, NULL);
Tcl_SetObjResult(interp, listObj);
DECR_REF_COUNT2("paramDefsObj", listObj);
break;
case ParametersubcmdSyntaxIdx:
listObj = NsfParamDefsSyntax(interp, paramsPtr, NULL, NULL);
Tcl_SetObjResult(interp, listObj);
DECR_REF_COUNT2("paramDefsObj", listObj);
break;
case ParametersubcmdTypeIdx:
if (paramsPtr->type != NULL) {
if (paramsPtr->converter == Nsf_ConvertToTclobj && paramsPtr->converterArg) {
Tcl_SetObjResult(interp, paramsPtr->converterArg);
} else {
if (paramsPtr->converter == Nsf_ConvertToObject || paramsPtr->converter == Nsf_ConvertToClass) {
const char *what = paramsPtr->type;
/*
* baseclass and metaclass are communicated via flags
*/
if (unlikely((paramsPtr->flags & NSF_ARG_BASECLASS) != 0u)) {
what = "baseclass";
} else if (unlikely((paramsPtr->flags & NSF_ARG_METACLASS) != 0u)) {
what = "metaclass";
}
/*
* The converterArg might contain a class for type checking
*/
if (paramsPtr->converterArg == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(what, TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, paramsPtr->converterArg);
}
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(paramsPtr->type, TCL_INDEX_NONE));
}
}
} else {
Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
}
break;
case ParametersubcmdNULL:
/*
* Do nothing; just for detection if option was specified.
*/
break;
}
ParamDefsRefCountDecr(parsedParam.paramDefs);
return TCL_OK;
}
/*
cmd parameter::cache::classinvalidate NsfParameterCacheClassInvalidateCmd {
{-argName "class" -required 1 -type class}
}
*/
static int
NsfParameterCacheClassInvalidateCmd(Tcl_Interp *interp, NsfClass *class) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
/*
* First, increment the epoch in case we have a parsedParam. The
* classParamPtrEpoch is just used for PER_OBJECT_PARAMETER_CACHING
*/
#if defined(PER_OBJECT_PARAMETER_CACHING)
if (unlikely(class->parsedParamPtr != NULL)) {
NsfClassParamPtrEpochIncr("NsfParameterCacheClassInvalidateCmd");
}
#endif
/*
* During shutdown, no new objects are created, therefore, we do not need to
* to invalidate the cached parsedParamPtr of the classes.
*/
if (unlikely(RUNTIME_STATE(interp)->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF)) {
NsfClasses *dependentSubClasses;
NsfClasses *clPtr;
/*
* Clear the cached parsedParam of the class and all its subclasses (the
* result of DependentSubClasses() contains the starting
* class). Furthermore, make a quick check whether any of the subclasses
* is a class mixin of some other class.
*/
dependentSubClasses = DependentSubClasses(class);
if (dependentSubClasses != NULL) {
for (clPtr = dependentSubClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
NsfClass *subClass = clPtr->cl;
if (subClass->parsedParamPtr != NULL) {
ParsedParamFree(subClass->parsedParamPtr);
subClass->parsedParamPtr = NULL;
}
}
NsfClassListFree(dependentSubClasses);
}
}
return TCL_OK;
}
/*
cmd parameter::cache::objectinvalidate NsfParameterCacheObjectInvalidateCmd {
{-argName "object" -required 1 -type object}
}
*/
static int
NsfParameterCacheObjectInvalidateCmd(Tcl_Interp *UNUSED(interp), NsfObject *object) {
nonnull_assert(object != NULL);
#if defined(PER_OBJECT_PARAMETER_CACHING)
if (object->opt != NULL && object->opt->parsedParamPtr) {
/*fprintf(stderr, " %p %s invalidate %p\n", object,
ObjectName(object), object->opt->parsedParamPtr);*/
ParsedParamFree(object->opt->parsedParamPtr);
object->opt->parsedParamPtr = NULL;
}
#endif
return TCL_OK;
}
/*
cmd parameter::specs NsfParameterSpecsCmd {
{-argName "-configure" -nrargs 0 -required 0}
{-argName "-nonposargs" -nrargs 0 -required 0}
{-argName "slotobjs" -required 1 -type tclobj}
}
*/
static int
NsfParameterSpecsCmd(Tcl_Interp *interp, int withConfigure, int withNonposargs, Tcl_Obj *slotobjsObj) {
NsfTclObjList *objList = NULL, *elt;
Tcl_Obj **objv, *resultObj;
TCL_SIZE_T objc, i;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(slotobjsObj != NULL);
if (Tcl_ListObjGetElements(interp, slotobjsObj, &objc, &objv) != TCL_OK) {
return NsfPrintError(interp, "NsfParameterSpecsCmd: invalid slot object list");
}
/*
* Iterate over the slot objects and obtain the position and the
* parameterSpec.
*/
for (i = 0; i < objc; i++) {
NsfObject *slotObject;
Tcl_Obj *positionObj, *specObj = NULL;
if (GetObjectFromObj(interp, objv[i], &slotObject) != TCL_OK) {
return NsfPrintError(interp, "objectparameter: slot element is not a next scripting object");
}
assert(slotObject != NULL);
/*
* When withConfigure is provided, skip this parameter ...
* - when configure is not set
* - or configure == 0
*/
if (withConfigure != 0) {
int configure = 0;
Tcl_Obj *configureObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
NsfGlobalObjs[NSF_CONFIGURABLE], NULL, 0);
if (configureObj == NULL) {
continue;
}
Tcl_GetBooleanFromObj(interp, configureObj, &configure);
if (configure == 0) {
continue;
}
}
/*
* When withNonposargs is provided, skip this parameter ...
* - when positional == 1
*/
if (withNonposargs != 0) {
Tcl_Obj *positionalObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
NsfGlobalObjs[NSF_POSITIONAL], NULL, 0);
if (positionalObj != NULL) {
int positional = 0;
Tcl_GetBooleanFromObj(interp, positionalObj, &positional);
if (positional != 0) {
continue;
}
}
}
positionObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
NsfGlobalObjs[NSF_POSITION], NULL, 0);
specObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
NsfGlobalObjs[NSF_PARAMETERSPEC], NULL, 0);
if (specObj == NULL) {
result = CallMethod(slotObject, interp, NsfGlobalObjs[NSF_GET_PARAMETER_SPEC], 2, NULL,
NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
if (unlikely(result != TCL_OK)) {
return NsfPrintError(interp, "objectparameter: %s %s returned error",
ObjectName_(slotObject),
NsfGlobalStrings[NSF_GET_PARAMETER_SPEC]);
}
specObj = Tcl_GetObjResult(interp);
}
/*fprintf(stderr, "NsfParameterSpecsCmd slot obj = %s pos %s spec %s\n", ObjStr(objv[i]), (positionObj != NULL) ? ObjStr(positionObj) : "NONE", ObjStr(specObj) );*/
/*
* Add the spec to the list indicated by the position
*/
TclObjListAdd(interp, &objList, positionObj, specObj);
}
/*
* Fold the per-position lists into a flat result list
*/
resultObj = Tcl_NewListObj(0, NULL);
for (elt = objList; elt != NULL; elt = elt->nextPtr) {
Tcl_ListObjGetElements(interp, elt->payload, &objc, &objv);
for (i = 0; i < objc; i++) {
Tcl_ListObjAppendElement(interp, resultObj, objv[i]);
}
}
Tcl_SetObjResult(interp, resultObj);
if (objList != NULL) {
TclObjListFreeList(objList);
}
return result;
}
/*
cmd proc NsfProcCmd {
{-argName "-ad" -required 0 -nrargs 0 -type switch}
{-argName "-checkalways" -required 0 -nrargs 0 -type switch}
{-argName "-debug" -required 0 -nrargs 0 -type switch}
{-argName "-deprecated" -required 0 -nrargs 0 -type switch}
{-argName "procName" -required 1 -type tclobj}
{-argName "arguments" -required 1 -type tclobj}
{-argName "-returns" -required 0 -type tclobj}
{-argName "body" -required 1 -type tclobj}
}
*/
static int
NsfProcCmd(Tcl_Interp *interp, int withAd, int withCheckalways, int withDebug, int withDeprecated,
Tcl_Obj *procNameObj, Tcl_Obj *argumentsObj, Tcl_Obj *returnsObj, Tcl_Obj *bodyObj) {
NsfParsedParam parsedParam;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(procNameObj != NULL);
nonnull_assert(argumentsObj != NULL);
nonnull_assert(bodyObj != NULL);
/*
* Parse argument list "arguments" to determine if we should provide
* nsf parameter handling.
*/
result = ParamDefsParse(interp, procNameObj, argumentsObj,
NSF_DISALLOWED_ARG_METHOD_PARAMETER, (withDebug != 0),
&parsedParam, Tcl_GetCurrentNamespace(interp)->fullName);
if (unlikely(result != TCL_OK)) {
return result;
}
if (parsedParam.paramDefs != NULL
|| withDebug != 0
|| withDeprecated != 0
|| returnsObj != NULL
) {
/*
* We need parameter handling. In such cases, a thin C-based layer
* is added which handles the parameter passing and calls the proc
* later.
*/
result = NsfProcAdd(interp, &parsedParam, ObjStr(procNameObj), returnsObj, bodyObj,
withAd, withCheckalways, withDebug, withDeprecated);
} else {
/*
* No parameter handling needed. A plain Tcl proc is added.
*/
Tcl_Obj *ov[4];
ov[0] = NULL;
ov[1] = procNameObj;
ov[2] = argumentsObj;
ov[3] = bodyObj;
result = Tcl_ProcObjCmd(0, interp, 4, ov);
}
return result;
}
/*
cmd relation::get NsfRelationGetCmd {
{-argName "object" -type object}
{-argName "type" -required 1 -typeName "relationtype" -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"}
}
*/
static int
NsfRelationGetCmd(Tcl_Interp *interp, NsfObject *object, RelationtypeIdx_t type) {
return NsfRelationSetCmd(interp, object, type, NULL);
}
/*
*----------------------------------------------------------------------
* NsfRelationClassMixinsSet --
*
* Set class mixins; the main reason for the factored-out semantics is that
* it supports to undo/redo the operations in case of a failure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* class mixins are set, various kinds of invalidations.
*
*----------------------------------------------------------------------
*/
static int NsfRelationClassMixinsSet(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *valueObj, TCL_OBJC_T oc, Tcl_Obj **ov)
nonnull(1) nonnull(2) nonnull(3);
static int
NsfRelationClassMixinsSet(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *valueObj, TCL_OBJC_T oc, Tcl_Obj **ov) {
NsfCmdList *newMixinCmdList = NULL, *cmds;
NsfClasses *subClasses;
NsfClassOpt *clopt;
TCL_OBJC_T i;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(valueObj != NULL);
for (i = 0; i < oc; i++) {
if (unlikely(MixinAdd(interp, &newMixinCmdList, ov[i]) != TCL_OK)) {
CmdListFree(&newMixinCmdList, GuardDel);
return TCL_ERROR;
}
}
clopt = class->opt;
assert(clopt != NULL);
if (clopt->classMixins != NULL) {
RemoveFromClassMixinsOf(class->object.id, clopt->classMixins);
CmdListFree(&clopt->classMixins, GuardDel);
}
subClasses = DependentSubClasses(class);
MixinInvalidateObjOrders(subClasses);
/*
* Since methods of mixed in classes may be used as filters, we have to
* invalidate the filters as well.
*/
if (FiltersDefined(interp) > 0) {
FilterInvalidateObjOrders(interp, subClasses);
}
NsfClassListFree(subClasses);
/*
* Now register the specified mixins.
*/
clopt->classMixins = newMixinCmdList;
/*
* Finally, update classMixinOfs
*/
for (cmds = newMixinCmdList; cmds; cmds = cmds->nextPtr) {
NsfObject *nObject = NsfGetObjectFromCmdPtr(cmds->cmdPtr);
if (nObject != NULL) {
NsfClassOpt *nclopt = NsfRequireClassOpt((NsfClass *) nObject);
CmdListAddSorted(&nclopt->isClassMixinOf, class->object.id, NULL);
} else {
NsfLog(interp, NSF_LOG_WARN,
"Problem registering %s as a class mixin of %s\n",
ObjStr(valueObj), ClassName_(class));
}
}
return TCL_OK;
}
/*
cmd relation::set NsfRelationSetCmd {
{-argName "object" -required 1 -type object}
{-argName "type" -required 1 -typeName "relationtype" -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"}
{-argName "value" -required 0 -type tclobj}
}
*/
static int
NsfRelationSetCmd(Tcl_Interp *interp, NsfObject *object, RelationtypeIdx_t type, Tcl_Obj *valueObj) {
TCL_SIZE_T oc = 0;
Tcl_Obj **ov;
NsfClass *class = NULL;
NsfObjectOpt *objopt = NULL;
NsfClassOpt *clopt = NULL, *nclopt = NULL;
int i;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*fprintf(stderr, "NsfRelationSetCmd %s rel=%d val='%s'\n",
ObjectName(object), relationtype, (valueObj != NULL) ? ObjStr(valueObj) : "NULL");*/
if (type == RelationtypeClass_mixinIdx ||
type == RelationtypeClass_filterIdx) {
if (NsfObjectIsClass(object)) {
class = (NsfClass *)object;
} else {
/*
* Fall back to per-object case.
*/
type = (type == RelationtypeClass_mixinIdx) ?
RelationtypeObject_mixinIdx :
RelationtypeObject_filterIdx ;
}
}
/*
* The first switch block is just responsible for obtaining objopt or clopt
* or handling other simple cases.
*/
switch (type) {
case RelationtypeObject_filterIdx: ;NSF_FALL_THROUGH; /* fall through */
case RelationtypeObject_mixinIdx:
if (valueObj == NULL) {
objopt = object->opt;
if (type == RelationtypeObject_mixinIdx) {
return (objopt != NULL) ? MixinInfo(interp, objopt->objMixins, NULL, NSF_TRUE, NULL) : TCL_OK;
} else /* (type == RelationtypeObject_filterIdx) */ {
return (objopt != NULL) ? FilterInfo(interp, objopt->objFilters, NULL, NSF_TRUE, NSF_FALSE) : TCL_OK;
}
}
if (unlikely(Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK)) {
return TCL_ERROR;
}
objopt = NsfRequireObjectOpt(object);
break;
case RelationtypeClass_mixinIdx: ;NSF_FALL_THROUGH; /* fall through */
case RelationtypeClass_filterIdx:
assert(class != NULL);
if (valueObj == NULL) {
clopt = class->opt;
if (type == RelationtypeClass_mixinIdx) {
return (clopt != NULL) ? MixinInfo(interp, clopt->classMixins, NULL, NSF_TRUE, NULL) : TCL_OK;
} else /* if (relationtype == RelationtypeClass_filterIdx) */ {
return (clopt != NULL) ? FilterInfo(interp, clopt->classFilters, NULL, NSF_TRUE, NSF_FALSE) : TCL_OK;
}
}
if (unlikely(Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK)) {
return TCL_ERROR;
}
clopt = NsfRequireClassOpt(class);
break;
case RelationtypeSuperclassIdx:
if (!NsfObjectIsClass(object)) {
return NsfObjErrType(interp, "superclass", object->cmdName, "class", NULL);
}
class = (NsfClass *)object;
if (valueObj == NULL) {
return ListSuperClasses(interp, class, NULL, NSF_FALSE);
}
if (unlikely(Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK)) {
return TCL_ERROR;
}
return SuperclassAdd(interp, class, (TCL_OBJC_T)oc, ov, valueObj);
case RelationtypeClassIdx:
if (valueObj == NULL) {
Tcl_SetObjResult(interp, object->cl->object.cmdName);
return TCL_OK;
}
GetClassFromObj(interp, valueObj, &class, NSF_TRUE);
if (class == NULL) {
return NsfObjErrType(interp, "class", valueObj, "a class", NULL);
}
i = ChangeClass(interp, object, class);
if (i == TCL_OK) {
Tcl_SetObjResult(interp, object->cl->object.cmdName);
}
return i;
case RelationtypeRootclassIdx:
{
NsfClass *metaClass = NULL;
if (!NsfObjectIsClass(object)) {
return NsfObjErrType(interp, "rootclass", object->cmdName, "class", NULL);
}
class = (NsfClass *)object;
if (valueObj == NULL) {
return NsfPrintError(interp, "metaclass must be specified as third argument");
}
GetClassFromObj(interp, valueObj, &metaClass, NSF_FALSE);
if (metaClass == NULL) {
return NsfObjErrType(interp, "rootclass", valueObj, "class", NULL);
}
class->object.flags |= NSF_IS_ROOT_CLASS;
metaClass->object.flags |= NSF_IS_ROOT_META_CLASS;
return TCL_OK;
/* TODO:
Need to remove these properties?
Allow one to delete a class system at run time?
*/
}
case RelationtypeNULL:
/* do nothing; just for detection if option was specified */
return TCL_OK;
}
/*
* The second switch block is responsible for the more complex handling of
* the relations.
*/
switch (type) {
case RelationtypeObject_mixinIdx:
{
NsfCmdList *newMixinCmdList = NULL, *cmds;
TCL_SIZE_T ii;
/*
* Add every mixin class
*/
for (ii = 0; ii < oc; ii++) {
if (unlikely(MixinAdd(interp, &newMixinCmdList, ov[ii]) != TCL_OK)) {
CmdListFree(&newMixinCmdList, GuardDel);
return TCL_ERROR;
}
}
if (objopt->objMixins != NULL) {
NsfCmdList *cmdlist, *del;
/*
* Delete from old isObjectMixinOf lists
*/
for (cmdlist = objopt->objMixins; cmdlist != NULL; cmdlist = cmdlist->nextPtr) {
class = NsfGetClassFromCmdPtr(cmdlist->cmdPtr);
clopt = (class != NULL) ? class->opt : NULL;
if (clopt != NULL) {
del = CmdListFindCmdInList(object->id, clopt->isObjectMixinOf);
if (del != NULL) {
/* fprintf(stderr, "Removing object %s from isObjectMixinOf of class %s\n",
ObjectName(object), ObjStr(NsfGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */
del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del);
CmdListDeleteCmdListEntry(del, GuardDel);
}
}
}
CmdListFree(&objopt->objMixins, GuardDel);
}
/*
* Invalidate per-object infos
*/
NsfParameterCacheObjectInvalidateCmd(interp, object);
object->flags &= ~NSF_MIXIN_ORDER_VALID;
/*
* Since mixin procs may be used as filters -> we have to invalidate
* filters as well.
*/
object->flags &= ~NSF_FILTER_ORDER_VALID;
/*
* Now register the specified mixins.
*/
objopt->objMixins = newMixinCmdList;
for (cmds = newMixinCmdList; cmds; cmds = cmds->nextPtr) {
NsfObject *nObject = NsfGetObjectFromCmdPtr(cmds->cmdPtr);
if (nObject != NULL) {
nclopt = NsfRequireClassOpt((NsfClass *) nObject);
CmdListAddSorted(&nclopt->isObjectMixinOf, object->id, NULL);
} else {
NsfLog(interp, NSF_LOG_WARN,
"Problem registering %s as an object mixin of %s\n",
ObjStr(valueObj), ObjectName_(object));
}
}
MixinComputeDefined(interp, object);
FilterComputeDefined(interp, object);
}
break;
case RelationtypeObject_filterIdx:
{
NsfCmdList *newFilterCmdList = NULL;
TCL_SIZE_T ii;
for (ii = 0; ii < oc; ii ++) {
if (unlikely(FilterAdd(interp, &newFilterCmdList, ov[ii], object, NULL) != TCL_OK)) {
CmdListFree(&newFilterCmdList, GuardDel);
return TCL_ERROR;
}
}
if (objopt->objFilters != NULL) {
CmdListFree(&objopt->objFilters, GuardDel);
}
object->flags &= ~NSF_FILTER_ORDER_VALID;
objopt->objFilters = newFilterCmdList;
/*FilterComputeDefined(interp, object);*/
}
break;
case RelationtypeClass_mixinIdx:
if (unlikely(NsfRelationClassMixinsSet(interp, class, valueObj, (TCL_OBJC_T)oc, ov) != TCL_OK)) {
return TCL_ERROR;
}
break;
case RelationtypeClass_filterIdx:
{
NsfCmdList *newFilterCmdList = NULL;
TCL_SIZE_T ii;
for (ii = 0; ii < oc; ii ++) {
if (unlikely(FilterAdd(interp, &newFilterCmdList, ov[ii], NULL, class) != TCL_OK)) {
CmdListFree(&newFilterCmdList, GuardDel);
return TCL_ERROR;
}
}
if (clopt->classFilters != NULL) {
CmdListFree(&clopt->classFilters, GuardDel);
}
if (FiltersDefined(interp) > 0) {
NsfClasses *subClasses = DependentSubClasses(class);
if (subClasses != NULL) {
FilterInvalidateObjOrders(interp, subClasses);
NsfClassListFree(subClasses);
}
}
clopt->classFilters = newFilterCmdList;
}
break;
case RelationtypeClassIdx: ;NSF_FALL_THROUGH; /* fall through */
case RelationtypeRootclassIdx: ;NSF_FALL_THROUGH; /* fall through */
case RelationtypeSuperclassIdx: ;NSF_FALL_THROUGH; /* fall through */
case RelationtypeNULL:
/* handled above */
break;
}
/*
* Return on success the final setting
*/
NsfRelationSetCmd(interp, object, type, NULL);
return TCL_OK;
}
/*
cmd current NsfCurrentCmd {
{-argName "option" -required 0 -typeName "currentoption" -type "activelevel|activemixin|args|calledclass|calledmethod|calledproc|callingclass|callinglevel|callingmethod|callingobject|callingproc|class|filterreg|isnextcall|level|methodpath|method|nextmethod|object|proc" -default object}
}
*/
static int
NsfCurrentCmd(Tcl_Interp *interp, CurrentoptionIdx_t option) {
NsfObject *object;
NsfCallStackContent *cscPtr;
Tcl_CallFrame *framePtr;
int result = TCL_OK;
nonnull_assert(interp != NULL);
object = GetSelfObj(interp);
/*
* The first two clauses can succeed even it we are outside an NSF context
* (no object known). The commands are "nsf::current", "nsf::current
* object", "nsf::current level", and "nsf::current activelevel"
*/
if (option == CurrentoptionNULL || option == CurrentoptionObjectIdx) {
if (likely(object != NULL)) {
Tcl_SetObjResult(interp, object->cmdName);
} else {
result = NsfNoCurrentObjectError(interp, NULL);
}
return result;
}
if (unlikely(object == NULL)) {
if (option == CurrentoptionCallinglevelIdx) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else if (option == CurrentoptionLevelIdx) {
/*
* Return empty, if we are not on an NSF level.
*/
Tcl_ResetResult(interp);
} else {
result = NsfNoCurrentObjectError(interp, NULL);
}
return result;
}
/*
* From here on, we have to be on a valid nsf frame/level, object has to be
* know.
*/
assert(object != NULL);
switch (option) {
case CurrentoptionMethodIdx: ;NSF_FALL_THROUGH; /* fall through */
case CurrentoptionProcIdx:
cscPtr = CallStackGetTopFrame0(interp);
if (cscPtr != NULL) {
const char *procName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(procName, TCL_INDEX_NONE));
} else {
/* TODO: Is this, practically, reachable? */
return NsfPrintError(interp, "can't find method");
}
break;
case CurrentoptionMethodpathIdx:
cscPtr = CallStackGetTopFrame0(interp);
if (cscPtr != NULL) {
Tcl_SetObjResult(interp, NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, NULL, 1),
Tcl_GetCommandName(interp, cscPtr->cmdPtr)));
} else {
/* TODO: Is this, practically, reachable? */
return NsfPrintError(interp, "can't find method");
}
break;
case CurrentoptionClassIdx: /* class subcommand */
cscPtr = CallStackGetTopFrame0(interp);
Tcl_SetObjResult(interp, (cscPtr != NULL && cscPtr->cl) ?
cscPtr->cl->object.cmdName : NsfGlobalObjs[NSF_EMPTY]);
break;
case CurrentoptionActivelevelIdx:
Tcl_SetObjResult(interp, ComputeLevelObj(interp, ACTIVE_LEVEL));
break;
case CurrentoptionArgsIdx: {
cscPtr = CallStackGetTopFrame(interp, &framePtr);
if (cscPtr != NULL) {
TCL_SIZE_T nobjc;
Tcl_Obj **nobjv;
if (cscPtr->objv != NULL) {
nobjc = (TCL_SIZE_T)cscPtr->objc;
nobjv = (Tcl_Obj **)cscPtr->objv;
} else {
nobjc = Tcl_CallFrame_objc(framePtr);
nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(framePtr);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1));
} else {
return NsfPrintError(interp, "can't find proc");
}
break;
}
case CurrentoptionActivemixinIdx: {
NsfObject *cmdObject = NULL;
if (RUNTIME_STATE(interp)->currentMixinCmdPtr) {
cmdObject = NsfGetObjectFromCmdPtr(RUNTIME_STATE(interp)->currentMixinCmdPtr);
}
Tcl_SetObjResult(interp, (cmdObject != NULL) ? cmdObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
break;
}
case CurrentoptionCalledprocIdx:
case CurrentoptionCalledmethodIdx:
cscPtr = CallStackFindActiveFilter(interp);
if (cscPtr != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(MethodName(cscPtr->filterStackEntry->calledProc), TCL_INDEX_NONE));
} else {
NsfShowStack(interp);
result = NsfPrintError(interp, "called from outside of a filter 1");
}
break;
case CurrentoptionCalledclassIdx: {
const NsfClass *class = FindCalledClass(interp, object);
Tcl_SetObjResult(interp, (class != NULL) ? class->object.cmdName : NsfGlobalObjs[NSF_EMPTY]);
break;
}
case CurrentoptionCallingmethodIdx:
case CurrentoptionCallingprocIdx: {
Tcl_Obj *resultObj;
cscPtr = NsfCallStackFindLastInvocation(interp, 1, &framePtr);
if ((cscPtr != NULL) && (cscPtr->cmdPtr != NULL)) {
resultObj = NsfMethodNamePath(interp,
CallStackGetTclFrame(interp, framePtr, 1),
Tcl_GetCommandName(interp, cscPtr->cmdPtr));
} else {
resultObj = NsfGlobalObjs[NSF_EMPTY];
}
Tcl_SetObjResult(interp, resultObj);
break;
}
case CurrentoptionCallingclassIdx:
cscPtr = NsfCallStackFindLastInvocation(interp, 1, NULL);
Tcl_SetObjResult(interp, (cscPtr != NULL && cscPtr->cl != NULL)
? cscPtr->cl->object.cmdName
: NsfGlobalObjs[NSF_EMPTY]);
break;
case CurrentoptionCallinglevelIdx:
/*
* Special case of object==NULL handled above.
*/
Tcl_SetObjResult(interp, ComputeLevelObj(interp, CALLING_LEVEL));
break;
case CurrentoptionCallingobjectIdx:
cscPtr = NsfCallStackFindLastInvocation(interp, 1, NULL);
Tcl_SetObjResult(interp, (cscPtr != NULL) ? cscPtr->self->cmdName : NsfGlobalObjs[NSF_EMPTY]);
break;
case CurrentoptionFilterregIdx:
cscPtr = CallStackFindActiveFilter(interp);
if (cscPtr != NULL) {
Tcl_SetObjResult(interp, FilterFindReg(interp, object, cscPtr->cmdPtr));
} else {
result = NsfPrintError(interp, "called from outside of a filter");
}
break;
case CurrentoptionIsnextcallIdx: {
cscPtr = CallStackGetTopFrame(interp, &framePtr);
if ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u) {
(void)CallStackFindEnsembleCsc(framePtr, &framePtr);
}
framePtr = CallStackNextFrameOfType(Tcl_CallFrame_callerPtr(framePtr),
FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD);
cscPtr = (framePtr != NULL) ? Tcl_CallFrame_clientData(framePtr) : NULL;
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
(cscPtr != NULL && ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u)));
break;
}
case CurrentoptionLevelIdx:
/*
* We have an "object", therefore, we are on an NSF-frame/level. In this
* case, "nsf level" behaves like "info level" (without arguments).
*/
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_CallFrame_level(Tcl_Interp_varFramePtr(interp))));
break;
case CurrentoptionNextmethodIdx: {
Tcl_Obj *methodHandle;
/* cscPtr = */ (void) CallStackGetTopFrame(interp, &framePtr);
/*assert(cscPtr != NULL);*/
methodHandle = FindNextMethod(interp, framePtr);
if (methodHandle == NULL) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, methodHandle);
}
break;
}
case CurrentoptionObjectIdx: ;NSF_FALL_THROUGH; /* fall through */
case CurrentoptionNULL:
/* handled above */
break;
}
return result;
}
/*
cmd self NsfSelfCmd {
}
*/
static int
NsfSelfCmd(Tcl_Interp *interp) {
NsfObject *object;
nonnull_assert(interp != NULL);
object = GetSelfObj(interp);
if (likely(object != NULL)) {
Tcl_SetObjResult(interp, object->cmdName);
return TCL_OK;
} else {
return NsfNoCurrentObjectError(interp, NULL);
}
}
/*
cmd var::exists NsfVarExistsCmd {
{-argName "-array" -required 0 -nrargs 0}
{-argName "object" -required 1 -type object}
{-argName "varName" -required 1}
}
*/
static int
NsfVarExistsCmd(Tcl_Interp *interp, int withArray, NsfObject *object, const char *varName) {
unsigned int flags =
NSF_VAR_TRIGGER_TRACE|NSF_VAR_REQUIRE_DEFINED|
((withArray != 0) ? NSF_VAR_ISARRAY : 0u);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(varName != NULL);
if (unlikely(CheckVarName(interp, varName) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), VarExists(interp, object, varName, NULL, flags));
return TCL_OK;
}
/*
cmd var::get NsfVarGetCmd {
{-argName "-array" -required 0 -nrargs 0 -type switch}
{-argName "-notrace" -required 0 -nrargs 0 -type switch}
{-argName "object" -required 1 -type object}
{-argName "varName" -required 1 -type tclobj}
}
*/
static int
NsfVarGetCmd(Tcl_Interp *interp, int withArray, int withNotrace,
NsfObject *object, Tcl_Obj *varNameObj) {
return NsfVarSetCmd(interp, withArray, withNotrace, object, varNameObj, NULL);
}
/*
cmd var::import NsfVarImportCmd {
{-argName "object" -type object}
{-argName "args" -type args}
}
*/
static int NsfVarImport(Tcl_Interp *interp, NsfObject *object, const char *cmdName,
TCL_OBJC_T objc, Tcl_Obj *const objv[])
nonnull(1) nonnull(2) nonnull(3) nonnull(5);
static int
NsfVarImport(Tcl_Interp *interp, NsfObject *object, const char *cmdName,
TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
TCL_OBJC_T i;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(cmdName != NULL);
nonnull_assert(objv != NULL);
for (i = 0; i < objc && result == TCL_OK; i++) {
Tcl_Obj **ov;
TCL_SIZE_T oc;
/*fprintf(stderr, "ListGetElements %p %s\n", objv[i], ObjStr(objv[i]));*/
if ((result = Tcl_ListObjGetElements(interp, objv[i], &oc, &ov)) == TCL_OK) {
Tcl_Obj *varName = NULL, *alias = NULL;
switch (oc) {
case 0:
varName = objv[i];
break;
case 1:
varName = ov[0];
break;
case 2:
varName = ov[0];
alias = ov[1];
break;
default:
break;
}
if (likely(varName != NULL)) {
result = ImportInstVarIntoCurrentScope(interp, cmdName, object, varName, alias);
} else {
assert(objv[i] != NULL);
result = NsfPrintError(interp, "invalid variable specification '%s'", ObjStr(objv[i]));
}
}
}
return result;
}
static int
NsfVarImportCmd(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return NsfVarImport(interp, object, "importvar", trailingObjc, trailingObjv);
}
/*
cmd var::set NsfVarSetCmd {
{-argName "-array" -required 0 -nrargs 0 -type switch}
{-argName "-notrace" -required 0 -nrargs 0 -type switch}
{-argName "object" -required 1 -type object}
{-argName "varName" -required 1 -type tclobj}
{-argName "value" -required 0 -type tclobj}
}
*/
static int
NsfVarSetCmd(Tcl_Interp *interp, int withArray, int withNotrace,
NsfObject *object, Tcl_Obj *varNameObj, Tcl_Obj *valueObj) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(varNameObj != NULL);
if (unlikely(CheckVarName(interp, ObjStr(varNameObj)) != TCL_OK)) {
return TCL_ERROR;
}
if (withArray != 0) {
return SetInstArray(interp, object, varNameObj, valueObj);
} else {
return SetInstVar(interp, object, varNameObj, valueObj, withNotrace ? 0 : NSF_VAR_TRIGGER_TRACE);
}
}
/*
cmd var::unset NsfVarUnsetCmd {
{-argName "-nocomplain" -required 0 -nrargs 0}
{-argName "object" -required 1 -type object}
{-argName "varName" -required 1 -type tclobj}
}
*/
static int
NsfVarUnsetCmd(Tcl_Interp *interp, int withNocomplain, NsfObject *object, Tcl_Obj *varNameObj) {
const char *varName;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(varNameObj != NULL);
varName = ObjStr(varNameObj);
if (unlikely(CheckVarName(interp, varName) != TCL_OK)) {
return TCL_ERROR;
}
return UnsetInstVar(interp, withNocomplain, object, varName);
}
/***********************************************************************
* End generated Next Scripting commands
***********************************************************************/
/*
* Parameter support functions
*/
typedef struct NsfParamWrapper {
Nsf_Param *paramPtr;
int refCount;
bool canFree;
} NsfParamWrapper;
static Tcl_DupInternalRepProc ParamDupInteralRep;
static Tcl_FreeInternalRepProc ParamFreeInternalRep;
static Tcl_UpdateStringProc ParamUpdateString;
static void ParamUpdateString(Tcl_Obj *objPtr)
nonnull(1);
static void ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *UNUSED(dupPtr))
nonnull(1);
static void ParamFreeInternalRep(register Tcl_Obj *objPtr)
nonnull(1);
static int ParamSetFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr)
nonnull(1) nonnull(2);
static int ParamSetFromAny2(Tcl_Interp *interp, const char *varNamePrefix,
bool allowObjectParameter, register Tcl_Obj *objPtr,
const char *qualifier)
nonnull(1) nonnull(2) nonnull(4);
static void
ParamUpdateString(Tcl_Obj *objPtr) {
nonnull_assert(objPtr != NULL);
Tcl_Panic("%s of type %s should not be called", "updateStringProc",
objPtr->typePtr->name);
}
static Tcl_ObjType paramObjType = {
"nsfParam", /* name */
ParamFreeInternalRep, /* freeIntRepProc */
ParamDupInteralRep, /* dupIntRepProc */
ParamUpdateString, /* updateStringProc */
ParamSetFromAny /* setFromAnyProc */
#ifdef TCL_OBJTYPE_V0
,TCL_OBJTYPE_V0
#endif
};
static void
ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) {
NsfParamWrapper *srcParamWrapperPtr, *dupParamWrapperPtr;
nonnull_assert(srcPtr != NULL);
srcParamWrapperPtr = (NsfParamWrapper *)srcPtr->internalRep.twoPtrValue.ptr1;
if (srcParamWrapperPtr != NULL) {
/*fprintf(stderr, "ParamDupInteralRep src %p copy wrapper %p paramPtr %p refCount %d canFree %d\n",
(void*)srcPtr,
(void*)srcParamWrapperPtr,
(void*)srcParamWrapperPtr->paramPtr,
srcParamWrapperPtr->refCount,
srcParamWrapperPtr->canFree);*/
dupParamWrapperPtr = srcParamWrapperPtr;
dupPtr->internalRep.twoPtrValue.ptr1 = dupParamWrapperPtr;
dupPtr->typePtr = ¶mObjType;
dupParamWrapperPtr->refCount ++;
dupParamWrapperPtr->canFree = NSF_FALSE;
/*fprintf(stderr, "ParamDupInteralRep dup %p .... wrapper %p paramPtr %p refCount %d canFree %d\n",
(void*)dupPtr,
(void*)dupParamWrapperPtr,
(void*)dupParamWrapperPtr->paramPtr,
dupParamWrapperPtr->refCount,
dupParamWrapperPtr->canFree);*/
}
}
static void
ParamFreeInternalRep(
register Tcl_Obj *objPtr) /* Param structure object with internal
* representation to free. */
{
NsfParamWrapper *paramWrapperPtr;
nonnull_assert(objPtr != NULL);
paramWrapperPtr = (NsfParamWrapper *)objPtr->internalRep.twoPtrValue.ptr1;
if (paramWrapperPtr != NULL) {
/*fprintf(stderr, "ParamFreeInternalRep obj %p type %p '%s' freeing wrapper %p paramPtr %p refCount %d canFree %d\n",
(void*)objPtr,
(void*)objPtr->typePtr,
(void*)objPtr->typePtr == NULL ? "None" : objPtr->typePtr->name,
(void*)paramWrapperPtr,
(void*)paramWrapperPtr->paramPtr,
paramWrapperPtr->refCount,
paramWrapperPtr->canFree);*/
if (paramWrapperPtr->refCount < 0) {
char *p = NULL; *p=0;
}
if (paramWrapperPtr->canFree) {
ParamsFree(paramWrapperPtr->paramPtr);
FREE(NsfParamWrapper, paramWrapperPtr);
} else {
paramWrapperPtr->refCount--;
}
}
}
/*
*----------------------------------------------------------------------
* ParamSetFromAny2 --
*
* Convert the second argument (e.g. "x:integer") into the internal
* representation of a Tcl_Obj of the type parameter. The conversion is
* performed by the usual ParamDefinitionParse() function, used e.g. for
* the parameter passing for arguments.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Converted internal rep of Tcl_Obj
*
*----------------------------------------------------------------------
*/
static int
ParamSetFromAny2(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *varNamePrefix, /* shows up as varName in error message */
bool allowObjectParameter, /* allow object parameters */
register Tcl_Obj *objPtr, /* The object to convert. */
const char *qualifier)
{
Tcl_Obj *fullParamObj = Tcl_NewStringObj(varNamePrefix, TCL_INDEX_NONE);
int result, possibleUnknowns = 0, nrNonposArgs = 0;
TCL_SIZE_T plainParams = 0;
NsfParamWrapper *paramWrapperPtr = NEW(NsfParamWrapper);
nonnull_assert(interp != NULL);
nonnull_assert(varNamePrefix != NULL);
nonnull_assert(objPtr != NULL);
paramWrapperPtr->paramPtr = ParamsNew(1u);
paramWrapperPtr->refCount = 1;
paramWrapperPtr->canFree = NSF_FALSE;
Tcl_AppendLimitedToObj(fullParamObj, ObjStr(objPtr), TCL_INDEX_NONE, INT_MAX, NULL);
INCR_REF_COUNT(fullParamObj);
result = ParamDefinitionParse(interp, NsfGlobalObjs[NSF_VALUECHECK], fullParamObj,
(allowObjectParameter ? NSF_DISALLOWED_ARG_OBJECT_PARAMETER : NSF_DISALLOWED_ARG_VALUECHECK),
paramWrapperPtr->paramPtr, &possibleUnknowns,
&plainParams, &nrNonposArgs, qualifier);
/*
* We treat currently unknown user level converters as error.
*/
if (unlikely((paramWrapperPtr->paramPtr->flags & NSF_ARG_CURRENTLY_UNKNOWN) != 0u)) {
result = TCL_ERROR;
}
if (likely(result == TCL_OK)) {
/*
* In success cases, the memory allocated by this function is freed via
* the Tcl_Obj type.
*/
paramWrapperPtr->paramPtr->flags |= NSF_ARG_UNNAMED;
if (*(paramWrapperPtr->paramPtr->name) == 'r') {
paramWrapperPtr->paramPtr->flags |= NSF_ARG_IS_RETURNVALUE;
}
/*fprintf(stderr, "ParamSetFromAny2 frees interprep for obj %p type %p \n",
(void*)objPtr,
(void*)objPtr->typePtr);*/
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *)paramWrapperPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = ¶mObjType;
/*fprintf(stderr, "ParamSetFromAny2 obj %p creates wrapper %p paramPtr %p refCount %d canFree %d\n",
(void*)objPtr,
(void*)paramWrapperPtr,
(void*)paramWrapperPtr->paramPtr,
paramWrapperPtr->refCount,
paramWrapperPtr->canFree);*/
} else {
/*
* In error cases, free manually memory allocated by this function.
*/
/*fprintf(stderr, "ParamSetFromAny2 obj %p error case\n", (void*)objPtr);*/
ParamsFree(paramWrapperPtr->paramPtr);
FREE(NsfParamWrapper, paramWrapperPtr);
}
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. */
{
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
return ParamSetFromAny2(interp, "value:", NSF_FALSE, objPtr, NULL);
}
/*
*----------------------------------------------------------------------
* GetObjectParameterDefinition --
*
* Obtain the parameter definitions for an object by calling the method
* "__objectparameter" if the value is not cached already. Either "object"
* or "class" must be non-null. Caching is performed on the class, the
* cached values are used in case there are no object-specific slots.
*
* Results:
* A standard Tcl result, parsed structure in last argument
*
* Side effects:
* Updates potentially cl->parsedParamPtr
*
*----------------------------------------------------------------------
*/
static int
ComputeParameterDefinition(
Tcl_Interp *interp, Tcl_Obj *procNameObj,
NsfObject *object, NsfClass *class,
NsfParsedParam *parsedParamPtr
) {
int result;
Tcl_Obj *methodObj;
NsfObject *self;
if (object != NULL) {
methodObj = NsfMethodObj(object, NSF_o_configureparameter_idx);
self = object;
} else {
assert(class != NULL);
self = &class->object;
methodObj = NsfMethodObj(self, NSF_c_configureparameter_idx);
}
if (methodObj == NULL) {
result = TCL_OK;
} else {
/*fprintf(stderr, "calling %s %s\n", ObjectName(self), ObjStr(methodObj));*/
result = CallMethod(self, interp, methodObj, 2, NULL,
NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
if (likely(result == TCL_OK)) {
Tcl_Obj *rawConfArgs = Tcl_GetObjResult(interp);
/* fprintf(stderr, ".... rawConfArgs for %s => '%s'\n",
ObjectName(self), ObjStr(rawConfArgs));*/
INCR_REF_COUNT(rawConfArgs);
/*
* Parse the string representation to obtain the internal
* representation.
*/
result = ParamDefsParse(interp, procNameObj, rawConfArgs,
NSF_DISALLOWED_ARG_OBJECT_PARAMETER, NSF_TRUE,
parsedParamPtr, NULL);
if (likely(result == TCL_OK)) {
NsfParsedParam *ppDefPtr = NEW(NsfParsedParam);
ppDefPtr->paramDefs = parsedParamPtr->paramDefs;
ppDefPtr->possibleUnknowns = parsedParamPtr->possibleUnknowns;
if (class != NULL) {
assert(class->parsedParamPtr == NULL);
class->parsedParamPtr = ppDefPtr;
#if defined(PER_OBJECT_PARAMETER_CACHING)
} else if (object != NULL) {
NsfObjectOpt *opt = NsfRequireObjectOpt(object);
if (object->opt->parsedParamPtr != NULL) {
NsfParameterCacheObjectInvalidateCmd(interp, object);
}
opt->parsedParamPtr = ppDefPtr;
opt->classParamPtrEpoch = RUNTIME_STATE(interp)->classParamPtrEpoch;
/*fprintf(stderr, "set obj param for obj %p %s epoch %d ppDefPtr %p\n",
object, ObjectName(object), opt->classParamPtrEpoch, ppDefPtr);*/
#endif
}
if (ppDefPtr->paramDefs != NULL) {
ParamDefsRefCountIncr(ppDefPtr->paramDefs);
}
}
DECR_REF_COUNT(rawConfArgs);
}
}
return result;
}
/*
*----------------------------------------------------------------------
* GetObjectParameterDefinition --
*
* Obtain the parameter definitions for an object by calling the method
* "__objectparameter" if the value is not cached already. Caching is
* performed on the class, the cached values are used in case there are no
* object-specific slots.
*
* Results:
* A standard Tcl result, parsed structure in last argument.
*
* Side effects:
* Updates potentially cl->parsedParamPtr
*
*----------------------------------------------------------------------
*/
static int
GetObjectParameterDefinition(
Tcl_Interp *interp, Tcl_Obj *procNameObj,
NsfObject *object, NsfClass *class,
NsfParsedParam *parsedParamPtr
) {
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(procNameObj != NULL);
nonnull_assert(parsedParamPtr != NULL);
parsedParamPtr->paramDefs = NULL;
parsedParamPtr->possibleUnknowns = 0;
if (class == NULL) {
assert(object != NULL);
if ((object->flags & NSF_HAS_PER_OBJECT_SLOTS) != 0u
|| (object->opt != NULL && object->opt->objMixins)
) {
/*
* We have object-specific parameters. Do not use the per-class cache,
* and do not save the results in the per-class cache.
*/
/*fprintf(stderr, "per-object configure obj %s flags %.6x\n",
ObjectName(object), object->flags);*/
} else {
class = object->cl;
}
}
/*
* 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 class-mixins 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 whether there is already a parameter definition available for
* creating objects of this class.
*/
if (likely(class != NULL && class->parsedParamPtr != NULL)) {
NsfParsedParam *clParsedParamPtr = class->parsedParamPtr;
parsedParamPtr->paramDefs = clParsedParamPtr->paramDefs;
parsedParamPtr->possibleUnknowns = clParsedParamPtr->possibleUnknowns;
result = TCL_OK;
#if defined(PER_OBJECT_PARAMETER_CACHING)
} else if (object != NULL && object->opt != NULL && object->opt->parsedParamPtr != NULL &&
object->opt->classParamPtrEpoch == RUNTIME_STATE(interp)->classParamPtrEpoch) {
NsfParsedParam *objParsedParamPtr = object->opt->parsedParamPtr;
/*fprintf(stderr, "reuse obj param for obj %p %s paramPtr %p\n",
(void *)object, ObjectName(object), (void *)objParsedParamPtr);*/
parsedParamPtr->paramDefs = objParsedParamPtr->paramDefs;
parsedParamPtr->possibleUnknowns = objParsedParamPtr->possibleUnknowns;
result = TCL_OK;
#endif
} else {
/*
* There is no parameter definition available, get a new one in
* the string representation.
*/
result = ComputeParameterDefinition(interp, procNameObj,
object, class,
parsedParamPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
* ParameterCheck --
*
* Check the provided valueObj against the parameter specification
* provided in the second argument (paramObjPtr), when
* doCheckArguments is true. This function is used e.g. by nsf::is,
* where only the right-hand side of a parameter specification
* (after the colon) is specified. The argument Name (before the
* colon in a parameter spec) is provided via argNamePrefix.
*
* The converted parameter structure is returned optionally via the last
* argument.
*
* Results:
* A standard Tcl result and parsed structure in last argument.
*
* Side effects:
* Converts potentially tcl_obj type of paramObjPtr
*
*----------------------------------------------------------------------
*/
static int
ParameterCheck(
Tcl_Interp *interp, Tcl_Obj *paramObjPtr, Tcl_Obj *valueObj,
const char *argNamePrefix, unsigned int doCheckArguments,
bool isNamed, bool doConfigureParameter,
Nsf_Param **paramPtrPtr, const char *qualifier
) {
Nsf_Param *paramPtr;
NsfParamWrapper *paramWrapperPtr;
Tcl_Obj *outObjPtr;
ClientData checkedData;
int result;
unsigned int flags = 0u;
nonnull_assert(interp != NULL);
nonnull_assert(paramObjPtr != NULL);
nonnull_assert(valueObj != NULL);
/*fprintf(stderr, "ParameterCheck %s value %p %s refCount %d\n",
ObjStr(paramObjPtr), (void*)valueObj, ObjStr(valueObj), valueObj->refCount); */
if (paramObjPtr->typePtr == ¶mObjType) {
paramWrapperPtr = (NsfParamWrapper *) paramObjPtr->internalRep.twoPtrValue.ptr1;
} else {
/*
* We could use in principle Tcl_ConvertToType(..., ¶mObjType) instead
* of checking the type manually, but we want to pass the argNamePrefix
* explicitly.
*/
result = ParamSetFromAny2(interp, argNamePrefix, doConfigureParameter, paramObjPtr, qualifier);
if (likely(result == TCL_OK)) {
paramWrapperPtr = (NsfParamWrapper *) paramObjPtr->internalRep.twoPtrValue.ptr1;
} else {
const char *errMsg = ObjStr(Tcl_GetObjResult(interp));
Tcl_SetErrorCode(interp, "NSF", "VALUE", "CONSTRAINT", NULL);
if (*errMsg == '\0') {
return NsfPrintError(interp, "invalid value constraints \"%s\"",
ObjStr(paramObjPtr) );
} else {
return NsfPrintError(interp, "invalid value constraints \"%s\": %s",
ObjStr(paramObjPtr), errMsg);
}
}
}
paramPtr = paramWrapperPtr->paramPtr;
if (paramPtrPtr != NULL) {
*paramPtrPtr = paramPtr;
}
if (isNamed) {
paramPtr->flags &= ~NSF_ARG_UNNAMED;
}
RUNTIME_STATE(interp)->doClassConverterOmitUnknown = 1;
outObjPtr = NULL;
result = ArgumentCheck(interp, valueObj, paramPtr, doCheckArguments, &flags, &checkedData, &outObjPtr);
RUNTIME_STATE(interp)->doClassConverterOmitUnknown = 0;
/*fprintf(stderr, "ParameterCheck paramPtr %p final refCount of wrapper %d can free %d flags %.6x\n",
paramPtr, paramWrapperPtr->refCount, paramWrapperPtr->canFree, flags);*/
assert(paramWrapperPtr->refCount > 0);
paramWrapperPtr->canFree = NSF_TRUE;
if ((flags & NSF_PC_MUST_DECR) != 0u) {
DECR_REF_COUNT2("valueObj", outObjPtr);
}
return result;
}
/***********************************************************************
* Begin Object Methods
***********************************************************************/
/*
objectMethod autoname NsfOAutonameMethod {
{-argName "-instance"}
{-argName "-reset"}
{-argName "name" -required 1 -type tclobj}
}
*/
static int
NsfOAutonameMethod(
Tcl_Interp *interp, NsfObject *object, int withInstance, int withReset,
Tcl_Obj *nameObj
) {
Tcl_Obj *autonamedObj;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(nameObj != NULL);
autonamedObj = AutonameIncr(interp, nameObj, object, withInstance, withReset);
if (autonamedObj != NULL) {
Tcl_SetObjResult(interp, autonamedObj);
DECR_REF_COUNT2("autoname", autonamedObj);
return TCL_OK;
}
return NsfPrintError(interp, "autoname failed. Probably format string (with %%) was not well-formed");
}
/*
objectMethod class NsfOClassMethod {
{-argName "class" -required 0 -type tclobj}
}
*/
static int
NsfOClassMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *classObj) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return NsfRelationSetCmd(interp, object, RelationtypeClassIdx, classObj);
}
/*
objectMethod cleanup NsfOCleanupMethod {
}
*/
static int
NsfOCleanupMethod(Tcl_Interp *interp, NsfObject *object) {
NsfClass *class;
Tcl_Obj *savedNameObj;
bool softrecreate;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
#if defined(OBJDELETION_TRACE)
fprintf(stderr, "+++ NsfOCleanupMethod\n");
#endif
PRINTOBJ("NsfOCleanupMethod", object);
savedNameObj = object->cmdName;
INCR_REF_COUNT(savedNameObj);
/*
* Get the class before the object is destroyed.
*/
class = NsfObjectToClass(object);
/*
* Save and pass around softrecreate.
*/
softrecreate =
((object->flags & NSF_RECREATE) != 0u
&& RUNTIME_STATE(interp)->doSoftrecreate);
CleanupDestroyObject(interp, object, softrecreate);
CleanupInitObject(interp, object, object->cl, object->nsPtr, softrecreate);
if (class != NULL) {
CleanupDestroyClass(interp, class, softrecreate, NSF_TRUE);
CleanupInitClass(interp, class, class->nsPtr, softrecreate, NSF_TRUE);
}
DECR_REF_COUNT(savedNameObj);
return TCL_OK;
}
/*
objectMethod configure NsfOConfigureMethod {
{-argName "args" -type allargs}
}
*/
static NsfObject* GetSlotObject(Tcl_Interp *interp, Tcl_Obj *slotObj)
nonnull(1) nonnull(2);
static NsfObject*
GetSlotObject(Tcl_Interp *interp, Tcl_Obj *slotObj) {
NsfObject *slotObject = NULL;
nonnull_assert(interp != NULL);
nonnull_assert(slotObj != NULL);
if (unlikely(GetObjectFromObj(interp, slotObj, &slotObject) != TCL_OK || slotObject == NULL)) {
NsfPrintError(interp, "couldn't resolve slot object %s", ObjStr(slotObj));
}
return slotObject;
}
static int
NsfOConfigureMethod(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[], Tcl_Obj *objv0) {
int result;
NsfParsedParam parsedParam;
Nsf_Param *paramPtr;
NsfParamDefs *paramDefs;
Tcl_Obj *newValue, *initMethodObj;
const char *initString;
ParseContext pc;
CallFrame frame, *framePtr = &frame, *uplevelVarFramePtr;
TCL_OBJC_T i;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(objv != NULL);
nonnull_assert(objv0 != NULL);
#if 0
fprintf(stderr, "NsfOConfigureMethod %s.%s flags %.6x oc %2d", ObjectName(object), ObjStr(objv0), object->flags, objc);
for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
fprintf(stderr, "\n");
#endif
/*
* Get the object parameter definition.
*/
result = GetObjectParameterDefinition(interp, objv0, object, NULL, &parsedParam);
if (result != TCL_OK || parsedParam.paramDefs == NULL) {
/*fprintf(stderr, "... nothing to do for method %s\n", ObjStr(objv0));*/
return result;
}
/*
* Get the initMethodObj/initString outside the loop iterating over the
* arguments.
*/
if (CallDirectly(interp, object, NSF_o_init_idx, &initMethodObj)) {
initString = NULL;
} else {
initString = ObjStr(initMethodObj);
}
/*
* The effective call site of the configure() method (e.g., a proc or a
* method) can result from up-leveling the object creation procedure;
* therefore, the *effective* call site can deviate from the *declaring*
* call site (e.g. as in XOTcl2's unknown method). In such a scenario, the
* configure() dispatch finds itself in a particular call-stack
* configuration: The top-most frame reflects the declaring call site
* (interp->framePtr), while the effective call site (interp->varFramePtr)
* is identified by a lower call-stack level.
*
* Since configure pushes an object frame (for accessing the instance
* variables) and sometimes a CMETHOD frame (for method invocations) we
* record a) whether there was a preceding uplevel (identifiable through
* deviating interp->framePtr and interp->varFramePtr) and, in case, b) the
* ruling variable frame context. The preserved call-frame reference can
* later be used to restore the uplevel'ed call frame context.
*/
uplevelVarFramePtr =
(Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp) != Tcl_Interp_framePtr(interp)
? Tcl_Interp_varFramePtr(interp)
: NULL;
/*
* Push frame to allow for [self] and make instance variables of the object
* accessible as locals.
*/
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
/*
* Process the actual arguments based on the parameter definitions.
*/
paramDefs = parsedParam.paramDefs;
ParamDefsRefCountIncr(paramDefs);
#if 0
if (parsedParam.paramDefs != NULL) {
Tcl_Obj *listObj = ParamDefsList(interp, paramDefs->paramsPtr, NULL, NULL);
fprintf(stderr, "... got params <%s>\n", ObjStr(listObj));
}
#endif
result = ProcessMethodArguments(&pc, interp, object,
NSF_ARGPARSE_START_ZERO, paramDefs,
NsfGlobalObjs[NSF_CONFIGURE], objc, objv);
if (unlikely(result != TCL_OK)) {
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
/*
* At this point, the arguments are tested to be valid (according to the
* parameter definitions) and the defaults are set. Now we have to apply the
* arguments (mostly setting instance variables).
*/
#if defined(CONFIGURE_ARGS_TRACE)
fprintf(stderr, "*** POPULATE OBJ '%s': nr of parsed args %d\n", ObjectName(object), pc.objc);
#endif
for (i = 1, paramPtr = paramDefs->paramsPtr;
paramPtr->name != NULL;
paramPtr++, i++) {
/*
* Set the new value always when the new value was specified (was not
* taken from the default). When we take the default, we do not overwrite
* already existing values (which might have been set via parameter
* alias).
*/
/*fprintf(stderr, "[%d] param %s, object init called %d is default %d value = '%s' nrArgs %d\n",
i, paramPtr->name, (object->flags & NSF_INIT_CALLED),
(pc.flags[i-1] & NSF_PC_IS_DEFAULT),
ObjStr(pc.full_objv[i]), paramPtr->nrArgs);*/
if ((pc.flags[i-1] & NSF_PC_IS_DEFAULT)) {
/*
* Object parameter method calls (when the flag
* NSF_ARG_METHOD_INVOCATION is set) do not set instance variables, so
* we do not have to check for existing variables.
*/
if ((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) == 0u) {
Tcl_Obj *varObj = Tcl_ObjGetVar2(interp, paramPtr->nameObj, NULL, 0);
if (varObj != NULL) {
/*
* The value exists already, ignore this parameter.
*/
/*fprintf(stderr, "a variable for %s exists already, "
"ignore param flags %.6x valueObj %p\n",
paramPtr->name, paramPtr->flags, pc.full_objv[i]);*/
continue;
}
} else if ((object->flags & NSF_INIT_CALLED) != 0u) {
/*
* The object is already initialized. Don't use the default, since it
* might change part of the state back to the original default. This
* might happen, when e.g. configure is called on a class manually,
* where "superclass" has a default.
*/
/*fprintf(stderr, "%s skip default %s in configure\n",
ObjectName(object), ObjStr(pc.full_objv[i]));*/
continue;
}
} else if (unlikely((paramPtr->flags & NSF_ARG_REQUIRED) != 0u
&& pc.full_objv[i] == NsfGlobalObjs[NSF___UNKNOWN__])) {
/* Previous versions contained a test for
* (object->flags & NSF_INIT_CALLED)
*
* to perform required testing just for in the non-initialized state. We
* switched in 2.0b5 to checking for the existence of the associated
* instance variable, which works under the assumption that the instance
* variable has the same name and that e.g. a required alias parameter
* sets this variable either. Similar assumption is in the default
* handling. Future versions might use a more general handling of the
* parameter states.
*/
Tcl_Obj *varObj = Tcl_ObjGetVar2(interp, paramPtr->nameObj, NULL, 0);
if (unlikely(varObj == NULL)) {
Tcl_Obj *paramDefsObj = NsfParamDefsSyntax(interp, paramDefs->paramsPtr, object, NULL);
NsfPrintError(interp, "required argument '%s' is missing, should be:\n %s%s%s %s",
(paramPtr->nameObj != NULL) ? ObjStr(paramPtr->nameObj) : paramPtr->name,
(pc.object != NULL) ? ObjectName(pc.object) : "",
(pc.object != NULL) ? " " : "",
ObjStr(pc.full_objv[0]),
ObjStr(paramDefsObj));
DECR_REF_COUNT2("paramDefsObj", paramDefsObj);
Nsf_PopFrameObj(interp, framePtr);
result = TCL_ERROR;
goto configure_exit;
}
}
newValue = pc.full_objv[i];
/*fprintf(stderr, " new Value of %s = [%d] %p '%s', type %s addr %p\n",
ObjStr(paramPtr->nameObj), i,
newValue, (newValue != NULL) ? ObjStr(newValue) : "(null)", paramPtr->type,
&(pc.full_objv[i]));*/
/*
* Handling slot initialize
*/
if ((paramPtr->flags & NSF_ARG_SLOTINITIALIZE) != 0u) {
NsfObject *slotObject = GetSlotObject(interp, paramPtr->slotObj);
if (likely(slotObject != NULL)) {
Tcl_Obj *ov[1];
ov[0] = paramPtr->nameObj;
result = NsfCallMethodWithArgs(interp, (Nsf_Object *)slotObject, NsfGlobalObjs[NSF_INITIALIZE],
object->cmdName, 2, ov,
NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
}
if (unlikely(result != TCL_OK)) {
/*
* The error message was set either by GetSlotObject or by ...CallMethod...
*/
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
}
/*
* Special setter methods for invoking methods calls; handles types
* "cmd", "initcmd", "alias" and "forward".
*/
if ((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) != 0u) {
int consuming = (*paramPtr->name == '-' || paramPtr->nrArgs > 0);
if (consuming && newValue == NsfGlobalObjs[NSF___UNKNOWN__]) {
/*
* In the case we have a consuming parameter, but we have no value
* provided and not default, there is no reason to call the invocation
* parameter.
*/
/*fprintf(stderr, "%s consuming nrargs %d no value\n", paramPtr->name, paramPtr->nrArgs);*/
continue;
}
if ((paramPtr->flags & NSF_ARG_INITCMD) != 0u) {
if (paramPtr->defaultValue != NULL) {
/*
* The "defaultValue" holds the initcmd to be executed
*/
Tcl_Obj *varObj = Tcl_ObjGetVar2(interp, NsfGlobalObjs[NSF_ARRAY_INITCMD],
paramPtr->nameObj, 0);
/*fprintf(stderr, "### NSF_ARRAY_INITCMD %s has a value %s\n",
NsfGlobalStrings[NSF_ARRAY_INITCMD],
ObjStr(paramPtr->defaultValue));*/
if (varObj == NULL) {
/*
* The variable is not set. Therefore, we assume, we have to
* execute the initcmd. On success, we note the execution in the
* NSF_ARRAY_INITCMD variable (usually __initcmd(name))
*/
result = ParameterMethodDispatch(interp, object, paramPtr, paramPtr->defaultValue,
uplevelVarFramePtr, ObjStr(paramPtr->defaultValue) /*initString*/,
(Tcl_Obj **)&objv[pc.lastObjc],
objc - pc.lastObjc);
if (unlikely(result != TCL_OK)) {
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
if (unlikely(Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_ARRAY_INITCMD],
paramPtr->nameObj, Tcl_NewIntObj(1), TCL_LEAVE_ERR_MSG) == NULL)) {
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
}
} else {
/*
* We could consider to require a default.
*/
}
/*
* If we have a new actual value, proceed to setvars.
*/
if ((pc.flags[i-1] & NSF_PC_IS_DEFAULT) == 0) {
goto setvars;
}
continue;
}
/*
* lastObjc points to the first "unprocessed" argument, the argument before should be valid, when lastObjc > 1
*/
if (pc.lastObjc > 1) {
assert(ISOBJ(objv[pc.lastObjc-1]));
}
result = ParameterMethodDispatch(interp, object, paramPtr, newValue,
uplevelVarFramePtr, initString,
(Tcl_Obj **)&objv[pc.lastObjc],
objc - pc.lastObjc);
if (unlikely(result != TCL_OK)) {
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
continue;
}
setvars:
if (newValue == NsfGlobalObjs[NSF___UNKNOWN__]) {
/*
* Nothing to do, we have a value setter, but no value is specified and
* no default was provided.
*/
continue;
}
/*
* Set the instance variable unless the last argument of the
* definition is varArgs.
*/
if (i < paramDefs->nrParams || (!pc.varArgs)) {
#if defined(CONFIGURE_ARGS_TRACE)
fprintf(stderr, "*** %s SET %s '%s' // %p\n",
ObjectName(object), ObjStr(paramPtr->nameObj), ObjStr(newValue),
(void *)paramPtr->slotObj);
#endif
/*
* Actually, set instance variable with the provided value or default
* value. In case, explicit invocation of the setter is needed, we call the method, which
* is typically a forwarder to the slot object.
*/
if ((paramPtr->flags & NSF_ARG_SLOTSET) != 0u) {
NsfObject *slotObject = GetSlotObject(interp, paramPtr->slotObj);
if (likely(slotObject != NULL)) {
Tcl_Obj *ov[2];
Tcl_Obj *methodObj = NsfMethodObj(object, NSF_s_set_idx);
ov[0] = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
ov[1] = newValue;
/*fprintf(stderr, "SLOTSET %s %s %s %s %s idx %d %p\n", ObjectName(slotObject),
ObjStr(NsfGlobalObjs[NSF_SET]), ObjStr(object->cmdName),
ObjStr(paramPtr->nameObj), ObjStr(newValue),
NSF_s_set_idx, methodObj);*/
result = NsfCallMethodWithArgs(interp, (Nsf_Object *)slotObject,
(methodObj != NULL) ? methodObj : NsfGlobalObjs[NSF_SLOT_SET],
object->cmdName, 3, ov, NSF_CSC_IMMEDIATE);
}
if (unlikely(result != TCL_OK)) {
/*
* The error message was set either by GetSlotObject or by ...CallMethod...
*/
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
} else {
Tcl_Obj *resultObj;
/*
* Plain set of the variable.
*/
resultObj = Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, newValue, TCL_LEAVE_ERR_MSG);
if (unlikely(resultObj == NULL)) {
/*
* When the setting of the variable failed (e.g. caused by variable
* traces), report the error back.
*/
result = TCL_ERROR;
Nsf_PopFrameObj(interp, framePtr);
goto configure_exit;
}
}
}
}
Nsf_PopFrameObj(interp, framePtr);
configure_exit:
ParamDefsRefCountDecr(paramDefs);
ParseContextRelease(&pc);
if (likely(result == TCL_OK)) {
Tcl_ResetResult(interp);
}
return result;
}
/*
objectMethod cget NsfOCgetMethod {
{-argName "name" -type tclobj -required 1}
}
*/
static int
NsfOCgetMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj) {
int result;
NsfParsedParam parsedParam;
const Nsf_Param *paramPtr = NULL;
CallFrame frame, *framePtr = &frame, *uplevelVarFramePtr;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(nameObj != NULL);
/*
* Get the object parameter definition
*/
result = GetObjectParameterDefinition(interp, NsfGlobalObjs[NSF_EMPTY],
object, NULL, &parsedParam);
if (unlikely(result != TCL_OK)) {
return result;
}
/*
* GetObjectParameterDefinition() was returning TCL_OK, the paramdefs have
* to be set.
*/
assert(parsedParam.paramDefs != NULL);
/*
* We do not stack a plain stack from NSF_CSC_TYPE_PLAIN here, as we do in
* NsfOConfigureMethod (but maybe we have to for full compatibility TODO:
* check and compare with configure stack setup). Therefore, we pass NULL as
* cscPtr to ParameterMethodForwardDispatch).
*/
/*
* The uplevel handling is exactly the same as in NsfOConfigureMethod() and
* is needed, when methods are called, which perform an upvar.
*/
uplevelVarFramePtr =
(Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp) != Tcl_Interp_framePtr(interp)
? Tcl_Interp_varFramePtr(interp)
: NULL;
/*
* Push frame to allow invocations of [self] and make instance variables of
* the object accessible as locals.
*/
#pragma GCC diagnostic push
#if defined(__GNUC__) && !defined(__clang__)
# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
Nsf_PushFrameObj(interp, object, framePtr);
#pragma GCC diagnostic pop
ParamDefsRefCountIncr(parsedParam.paramDefs);
result = CGetParamLookup(interp, nameObj, parsedParam.paramDefs, ¶mPtr);
if (result != TCL_OK) {
/*
* Error message is already set by CGetParamLookup()
*/
} else if (paramPtr == NULL) {
result = NsfPrintError(interp, "cget: unknown configure parameter %s", ObjStr(nameObj));
} else {
/*
* Check for slot invocation.
*/
if (paramPtr->slotObj != NULL) {
NsfObject *slotObject = GetSlotObject(interp, paramPtr->slotObj);
Tcl_Obj *methodObj = NsfMethodObj(object, NSF_s_get_idx);
Tcl_Obj *ov[1];
/*
* Get instance variable via slot.
*/
if (uplevelVarFramePtr != NULL) {
Tcl_Interp_varFramePtr(interp) = uplevelVarFramePtr;
}
ov[0] = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
/*fprintf(stderr, "SLOTGET %s idx %d %p method %s\n", ObjectName(slotObject),
NSF_s_get_idx, (void *)methodObj, ObjStr(ov[0]));*/
result = NsfCallMethodWithArgs(interp, (Nsf_Object *)slotObject,
(methodObj != NULL) ? methodObj : NsfGlobalObjs[NSF_SLOT_GET],
object->cmdName, 2, ov, NSF_CSC_IMMEDIATE);
} else {
/*
* We do NOT have a slot
*/
if ((paramPtr->flags & NSF_ARG_METHOD_CALL) != 0u) {
if ((paramPtr->flags & NSF_ARG_ALIAS) != 0u) {
/*
* It is a parameter associated with an aliased method. Invoke the
* method without an argument.
*/
Tcl_Obj *methodObj = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
if (uplevelVarFramePtr != NULL) {
Tcl_Interp_varFramePtr(interp) = uplevelVarFramePtr;
}
result = CallMethod(object, interp, methodObj, 2, NULL, NSF_CSC_IMMEDIATE);
} else {
/*
* Must be NSF_ARG_FORWARD
*/
assert((paramPtr->flags & NSF_ARG_FORWARD) != 0u);
/*
* Since we have no cscPtr, we provide NULL.
*/
result = ParameterMethodForwardDispatch(interp, object,
paramPtr, NULL, NULL /* cscPtr */);
}
} else {
/*
* Must be a parameter associated with a variable.
*/
unsigned int flags = (object->nsPtr != NULL) ? (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY) : TCL_LEAVE_ERR_MSG;
Tcl_Obj *resultObj = Tcl_ObjGetVar2(interp, paramPtr->nameObj, NULL, (int)flags);
if (resultObj != NULL) {
/*
* The value exists.
*/
Tcl_SetObjResult(interp, resultObj);
}
}
}
}
Nsf_PopFrameObj(interp, framePtr);
ParamDefsRefCountDecr(parsedParam.paramDefs);
return result;
}
/*
objectMethod destroy NsfODestroyMethod {
}
*/
static int
NsfODestroyMethod(Tcl_Interp *interp, NsfObject *object) {
PRINTOBJ("NsfODestroyMethod", object);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*
* Provide protection against destroy on base classes.
*/
if (unlikely(IsBaseClass(object))) {
if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_ON_SOFT_DESTROY) {
return NsfPrintError(interp, "cannot destroy base class %s", ObjectName_(object));
}
}
/*fprintf(stderr, "NsfODestroyMethod %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);*/
/*
* NSF_DESTROY_CALLED might be set already be DispatchDestroyMethod(),
* 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 & NSF_DESTROY_CALLED) == 0u) {
object->flags |= NSF_DESTROY_CALLED;
/*fprintf(stderr, "NsfODestroyMethod %p sets DESTROY_CALLED %.6x\n", object, object->flags);*/
}
object->flags |= NSF_DESTROY_CALLED_SUCCESS;
if (likely((object->flags & NSF_DURING_DELETE) == 0u)) {
int result;
Tcl_Obj *methodObj;
/*fprintf(stderr, " call dealloc on %p %s\n", object,
((Command *)object->id)->flags == 0u ? ObjectName(object) : "(deleted)");*/
if (CallDirectly(interp, &object->cl->object, NSF_c_dealloc_idx, &methodObj)) {
NSF_PROFILE_TIME_DATA;
NSF_PROFILE_CALL(interp, &object->cl->object, Nsf_SystemMethodOpts[NSF_c_dealloc_idx]);
result = DoDealloc(interp, object);
NSF_PROFILE_EXIT(interp, &object->cl->object, Nsf_SystemMethodOpts[NSF_c_dealloc_idx]);
} else {
result = NsfCallMethodWithArgs(interp, (Nsf_Object *)object->cl, methodObj,
object->cmdName, 1, NULL,
NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
if (unlikely(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
*/
/*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", (void *)object);
#endif
}
return TCL_OK;
}
/*
objectMethod exists NsfOExistsMethod {
{-argName "varName" -required 1}
}
*/
static int
NsfOExistsMethod(Tcl_Interp *interp, NsfObject *object, const char *varName) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(varName != NULL);
Tcl_SetIntObj(Tcl_GetObjResult(interp),
VarExists(interp, object, varName, NULL,
NSF_VAR_TRIGGER_TRACE|NSF_VAR_REQUIRE_DEFINED));
return TCL_OK;
}
/*
objectMethod filterguard NsfOFilterGuardMethod {
{-argName "filter" -required 1}
{-argName "guard" -required 1 -type tclobj}
}
*/
static int
NsfOFilterGuardMethod(Tcl_Interp *interp, NsfObject *object, const char *filter, Tcl_Obj *guardObj) {
NsfObjectOpt *opt;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(filter != NULL);
nonnull_assert(guardObj != NULL);
opt = object->opt;
if (opt != NULL && opt->objFilters) {
NsfCmdList *h;
h = CmdListFindNameInList(interp, filter, opt->objFilters);
if (h != NULL) {
if (h->clientData != NULL) {
GuardDel((NsfCmdList *) h);
}
GuardAdd(h, guardObj);
object->flags &= ~NSF_FILTER_ORDER_VALID;
return TCL_OK;
}
}
return NsfPrintError(interp, "filterguard: can't find filter %s on %s",
filter, ObjectName_(object));
}
/*
objectMethod instvar NsfOInstvarMethod {
{-argName "args" -type allargs}
}
*/
static int
NsfOInstvarMethod(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
callFrameContext ctx = {NULL, NULL, 0};
int result;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if ((object->filterStack != NULL) || (object->mixinStack != NULL)) {
CallStackUseActiveFrame(interp, &ctx);
}
if (unlikely(Tcl_Interp_varFramePtr(interp) == NULL)) {
CallStackRestoreSavedFrames(interp, &ctx);
return NsfPrintError(interp, "instvar used on %s, but call-stack is not in procedure scope",
ObjectName_(object));
}
result = NsfVarImport(interp, object, ObjStr(objv[0]), objc-1, objv+1);
CallStackRestoreSavedFrames(interp, &ctx);
return result;
}
/*
objectMethod mixinguard NsfOMixinGuardMethod {
{-argName "mixin" -required 1 -type tclobj}
{-argName "guard" -required 1 -type tclobj}
}
*/
static int
NsfOMixinGuardMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *mixinObj, Tcl_Obj *guardObj) {
NsfObjectOpt *opt;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(mixinObj != NULL);
nonnull_assert(guardObj != NULL);
opt = object->opt;
if (opt != NULL && opt->objMixins) {
const Tcl_Command mixinCmd = Tcl_GetCommandFromObj(interp, mixinObj);
if (mixinCmd != NULL) {
const NsfClass *mixinClass = NsfGetClassFromCmdPtr(mixinCmd);
if (mixinClass != NULL) {
NsfCmdList *h = CmdListFindCmdInList(mixinCmd, opt->objMixins);
if (h != NULL) {
if (h->clientData != NULL) {
GuardDel((NsfCmdList *) h);
}
GuardAdd(h, guardObj);
object->flags &= ~NSF_MIXIN_ORDER_VALID;
return TCL_OK;
}
}
}
}
return NsfPrintError(interp, "mixinguard: can't find mixin %s on %s",
ObjStr(mixinObj), ObjectName_(object));
}
/*
objectMethod noinit NsfONoinitMethod {
}
*/
static int
NsfONoinitMethod(Tcl_Interp *UNUSED(interp), NsfObject *object) {
nonnull_assert(object != NULL);
object->flags |= NSF_INIT_CALLED;
return TCL_OK;
}
/*
objectMethod requirenamespace NsfORequireNamespaceMethod {
}
*/
static int
NsfORequireNamespaceMethod(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
RequireObjNamespace(interp, object);
return TCL_OK;
}
/*
objectMethod residualargs NsfOResidualargsMethod {
{-argName "args" -type allargs}
}
*/
static int
NsfOResidualargsMethod(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result = TCL_OK;
TCL_SIZE_T i, start = 1, argc = 0, nextArgc = 0, normalArgs;
dashArgType isdasharg = NO_DASH;
const char *methodName, *nextMethodName = NULL, *initString = NULL;
Tcl_Obj **argv = NULL, **nextArgv = NULL;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
#if 0
fprintf(stderr, "NsfOResidualargsMethod %s %2d ", ObjectName_(object), objc);
for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%p %s,", i, &objv[i], ObjStr(objv[i]));}
fprintf(stderr, "\n");
#endif
/*
* Skip arguments without leading dash.
*/
for (i = start; i < (TCL_SIZE_T)objc; i++) {
if ((isdasharg = IsDashArg(interp, objv[i], 1, &methodName, &argc, &argv))) {
break;
}
}
normalArgs = i-1;
/*
* Get the init string; do it once, outside the loop. If initString is not
* obtainable (i.e. not configured in the object system), don't call the
* "init" method in the loop.
*/
if (i < (TCL_SIZE_T)objc) {
NsfObjectSystem *osPtr = GetObjectSystem(object);
Tcl_Obj *initObj = osPtr->methods[NSF_o_init_idx];
if (initObj != NULL) {
initString = osPtr->methodNames[NSF_o_init_idx];
assert(initString != NULL);
}
}
for( ; i < (TCL_SIZE_T)objc; argc = nextArgc, argv = nextArgv, methodName = nextMethodName) {
Tcl_ResetResult(interp);
switch (isdasharg) {
case SCALAR_DASH: /* Argument is a scalar with a leading dash */
{ TCL_SIZE_T j;
nextMethodName = NULL;
nextArgv = NULL;
nextArgc = 0;
for (j = i+1; j < (TCL_SIZE_T)objc; j++, argc++) {
if ((isdasharg = IsDashArg(interp, objv[j], 1, &nextMethodName, &nextArgc, &nextArgv))) {
break;
}
}
if (initString != NULL) {
result = CallConfigureMethod(interp, object, initString, methodName, (TCL_OBJC_T)argc+1, objv+i+1);
if (unlikely(result != TCL_OK)) {
return result;
}
}
i += argc;
break;
}
case LIST_DASH: /* Argument is a list with a leading dash, grouping determined by list */
i++;
nextMethodName = NULL;
if (i < (TCL_SIZE_T)objc) {
isdasharg = IsDashArg(interp, objv[i], 1, &nextMethodName, &nextArgc, &nextArgv);
} else {
nextMethodName = NULL;
nextArgv = NULL;
nextArgc = 0;
}
if (initString != NULL) {
result = CallConfigureMethod(interp, object, initString, methodName, (TCL_OBJC_T)argc+1, argv+1);
if (unlikely(result != TCL_OK)) {
return result;
}
}
break;
case NO_DASH:
nextArgc = 0;
return NsfPrintError(interp, "%s configure: unexpected argument '%s' between parameters",
ObjectName_(object), ObjStr(objv[i]));
}
}
/*
* Call init with residual args in case it was not called yet.
*/
result = DispatchInitMethod(interp, object, (TCL_OBJC_T)normalArgs, objv+1, 0u);
if (likely(result == TCL_OK)) {
/*
* Return the non-processed leading arguments unless there was an
* error (XOTcl convention).
*/
Tcl_SetObjResult(interp, Tcl_NewListObj((TCL_SIZE_T)normalArgs, objv+1));
}
return result;
}
/*
objectMethod uplevel NsfOUplevelMethod {
{-argName "args" -type allargs}
}
*/
static int
NsfOUplevelMethod(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result, getFrameResult = 0;
CallFrame *requestedFramePtr = NULL;
nonnull_assert(interp != NULL);
nonnull_assert(objv != NULL);
if (objc < 2) {
result = NsfPrintError(interp,
"wrong # args: should be \"%s %s ?level? command ?arg ...?\"",
ObjectName_(object),
NsfMethodName(objv[0]));
} else if (objc == 2) {
result = TCL_OK;
} else {
/*
* TclObjGetFrame returns:
* 0 ... when a syntactically invalid (incl. no) level specifier was provided
* 1 ... when a syntactically valid level specifier with corresp. frame
was found
* -1 ... when a syntactically valid level specifier was provided,
but an error occurred while finding the frame
(error msg in interp, "bad level")
*/
getFrameResult = TclObjGetFrame(interp, objv[1], &requestedFramePtr);
result = unlikely(getFrameResult == -1) ? TCL_ERROR : TCL_OK;
}
if (likely(result == TCL_OK)) {
Tcl_CallFrame *framePtr, *savedVarFramePtr;
objc -= (TCL_OBJC_T)(getFrameResult + 1);
objv += getFrameResult + 1;
if (getFrameResult == 0) {
/*
* 0 is returned from TclObjGetFrame when no (or, an invalid) level
* specifier was provided; objv[0] is interpreted as a command word,
* uplevel defaults to the computed level.
*/
Tcl_CallFrame *callingFramePtr = NULL;
framePtr = NULL;
NsfCallStackFindCallingContext(interp, 1, &framePtr, &callingFramePtr);
if (framePtr == NULL) {
/*
* No proc frame was found, default to parent frame.
*/
framePtr = callingFramePtr;
}
} else {
/*
* Use the requested frame corresponding to the (valid) level specifier.
*/
framePtr = (Tcl_CallFrame *)requestedFramePtr;
}
assert(framePtr != NULL);
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((TCL_SIZE_T)objc, objv);
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (unlikely(result == TCL_ERROR)) {
Tcl_AppendObjToErrorInfo(interp,
Tcl_ObjPrintf("\n (\"uplevel\" body line %d)",
Tcl_GetErrorLine(interp)));
}
/*
* Restore the variable frame, and return.
*/
Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr;
}
return result;
}
/*
objectMethod upvar NsfOUpvarMethod {
{-argName "args" -type allargs}
}
*/
static int
NsfOUpvarMethod(Tcl_Interp *interp, NsfObject *object, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
Tcl_Obj *frameInfoObj;
int result = TCL_ERROR;
TCL_OBJC_T i;
const char *frameInfo;
callFrameContext ctx = {NULL, NULL, 0};
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (objc < 3) {
return NsfPrintError(interp,
"wrong # args: should be \"%s %s "
"?level? otherVar localVar ?otherVar localVar ...?\"",
ObjectName_(object),
NsfMethodName(objv[0]));
}
if (objc % 2 == 0) {
/*
* Even number of arguments (including method), therefore, the level
* specifier is considered to be the first argument.
*/
frameInfoObj = NULL;
frameInfo = ObjStr(objv[1]);
i = 2;
} else {
/*
* Odd number of arguments (including method), therefore, the level
* specifier considered absent and the level has to be computed.
*/
frameInfoObj = ComputeLevelObj(interp, CALLING_LEVEL);
INCR_REF_COUNT(frameInfoObj);
frameInfo = ObjStr(frameInfoObj);
i = 1;
}
if ((object->filterStack != NULL) || (object->mixinStack != NULL)) {
CallStackUseActiveFrame(interp, &ctx);
}
for ( ; i < objc; i += 2) {
result = Tcl_UpVar2(interp, frameInfo, ObjStr(objv[i]), NULL,
ObjStr(objv[i+1]), 0 /*flags*/);
if (unlikely(result != TCL_OK)) {
break;
}
}
if (frameInfoObj != NULL) {
DECR_REF_COUNT(frameInfoObj);
}
CallStackRestoreSavedFrames(interp, &ctx);
return result;
}
/*
objectMethod volatile NsfOVolatileMethod {
}
objectMethod volatile1 NsfOVolatile1Method {
}
*/
static int
VolatileMethod(Tcl_Interp *interp, NsfObject *object, bool shallow) {
int result = TCL_ERROR;
Tcl_Obj *objPtr;
const char *fullName, *vn;
callFrameContext ctx = {NULL, NULL, 0};
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (unlikely(RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_OFF)) {
return NsfPrintError(interp, "can't make objects volatile during shutdown");
}
if (shallow) {
CallStackUseActiveFrame(interp, &ctx);
} else {
NsfObjectSystem *osPtr = GetObjectSystem(object);
Tcl_CallFrame *invocationFrame;
/*
* XOTcl1 style
*/
/*NsfShowStack(interp);*/
CallStackUseActiveFrame(interp, &ctx);
/*fprintf(stderr, "active varframe %p\n", (void*)Tcl_Interp_varFramePtr(interp));*/
invocationFrame = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
while (1) {
if (((unsigned int)Tcl_CallFrame_isProcCallFrame(invocationFrame) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) {
NsfCallStackContent *cscPtr;
const char *cmdName;
cscPtr = ((NsfCallStackContent *)Tcl_CallFrame_clientData(invocationFrame));
cmdName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
/*
* We were not called from an NSF frame.
*/
if (cscPtr == NULL) {
break;
}
/*
* Walk up the stack of invocations of the current object to skip
* e.g. overloaded internally called methods like "configure".
*/
/*fprintf(stderr, "compare object %p == %p\n", (void*)object, (void*)cscPtr->self);*/
if (cscPtr->self == object &&
*osPtr->methodNames[NSF_o_configure_idx] == *cmdName &&
strcmp(osPtr->methodNames[NSF_o_configure_idx],
Tcl_GetCommandName(interp, cscPtr->cmdPtr)) == 0) {
invocationFrame = Tcl_CallFrame_callerPtr(invocationFrame);
/*fprintf(stderr, "same object, continue with %p\n", (void*)invocationFrame);*/
continue;
}
/*
* If this was a "next" call, continue to walk up.
*/
if ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u) {
invocationFrame = Tcl_CallFrame_callerPtr(invocationFrame);
/*fprintf(stderr, "next call with %p\n", (void*)invocationFrame);*/
continue;
}
/*
* Final special case for XOTcl1 compliance: In case, we were called
* from an "unknown" method, skip this frame as well.
*/
/*fprintf(stderr, "cmd %s\n", Tcl_GetCommandName(interp, cscPtr->cmdPtr));*/
if (*osPtr->methodNames[NSF_o_unknown_idx] == *cmdName &&
strcmp(osPtr->methodNames[NSF_o_unknown_idx],
Tcl_GetCommandName(interp, cscPtr->cmdPtr)) == 0) {
invocationFrame = Tcl_CallFrame_callerPtr(invocationFrame);
/*fprintf(stderr, "have unknown, continue with %p\n", (void*)invocationFrame);*/
continue;
}
}
break;
}
/*
* Finally, set the invocation frame. The original frame context was saved
* already by CallStackUseActiveFrame() and will be properly restored.
*/
Tcl_Interp_varFramePtr(interp) = (CallFrame *)invocationFrame;
}
objPtr = object->cmdName;
fullName = ObjStr(objPtr);
vn = NSTail(fullName);
if (Tcl_SetVar2(interp, vn, NULL, fullName, 0)) {
NsfObjectOpt *opt = NsfRequireObjectOpt(object);
/*fprintf(stderr, "### setting trace for %s on frame %p\n", fullName,
Tcl_Interp_varFramePtr(interp));
NsfShowStack(interp);*/
result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS,
(Tcl_VarTraceProc *)NsfUnsetTrace,
objPtr);
opt->volatileVarName = vn;
}
CallStackRestoreSavedFrames(interp, &ctx);
if (likely(result == TCL_OK)) {
INCR_REF_COUNT2("volatile", objPtr);
}
return result;
}
static int
NsfOVolatileMethod(Tcl_Interp *interp, NsfObject *object) {
return VolatileMethod(interp, object, NSF_TRUE);
}
static int
NsfOVolatile1Method(Tcl_Interp *interp, NsfObject *object) {
return VolatileMethod(interp, object, NSF_FALSE);
}
/***********************************************************************
* End Object Methods
***********************************************************************/
/***********************************************************************
* Begin Class Methods
***********************************************************************/
static int
NsfCAllocMethod_(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr) {
const char *nameString;
NsfObject *newObj;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(nameObj != NULL);
nameString = ObjStr(nameObj);
assert(isAbsolutePath(nameString));
assert(NSValidObjectName(nameString, 0) != 0);
/*
* Create a new object from scratch.
*/
if (! IsMetaClass(interp, class, NSF_TRUE)) {
/*
* If the base class is an ordinary class, we create an object.
*/
newObj = PrimitiveOCreate(interp, nameObj, parentNsPtr, class);
} else {
/*
* If the base class is a metaclass, we create a class.
*/
newObj = (NsfObject *)PrimitiveCCreate(interp, nameObj, parentNsPtr, class);
}
if (unlikely(newObj == NULL)) {
return NsfPrintError(interp, "alloc failed to create '%s' "
"(possibly parent namespace does not exist)",
nameString);
}
if (NSF_DTRACE_OBJECT_ALLOC_ENABLED()) {
NSF_DTRACE_OBJECT_ALLOC(ObjectName(newObj), ClassName(class));
}
/*fprintf(stderr, "PrimitiveCCreate returns nameObj %p typePtr %p %s\n",
nameObj, nameObj->typePtr,
ObjTypeStr(nameObj)); */
Tcl_SetObjResult(interp, nameObj);
return TCL_OK;
}
/*
classMethod alloc NsfCAllocMethod {
{-argName "name" -required 1 -type tclobj}
}
*/
static int
NsfCAllocMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj) {
const char *nameString;
int result;
TCL_SIZE_T nameLength = 0;
/*
* Create a new object from scratch.
*/
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(nameObj != NULL);
/*
* Check for illegal names.
*/
nameString = Tcl_GetStringFromObj(nameObj, &nameLength);
if (unlikely(NSValidObjectName(nameString, (size_t)nameLength) == 0)) {
result = NsfPrintError(interp, "cannot allocate object - illegal name '%s'", nameString);
} else {
Tcl_Namespace *parentNsPtr;
Tcl_Obj *tmpName;
/*
* Name is valid. If the path is not absolute, we add the appropriate
* namespace.
*/
if (isAbsolutePath(nameString)) {
parentNsPtr = NULL;
tmpName = NULL;
} else {
parentNsPtr = CallingNameSpace(interp);
nameObj = tmpName = NameInNamespaceObj(nameString, parentNsPtr);
if (strchr(nameString, ':')) {
parentNsPtr = NULL;
}
INCR_REF_COUNT(tmpName);
/*fprintf(stderr, " **** NoAbsoluteName for '%s' -> determined = '%s' parentNs %s\n",
nameString, ObjStr(tmpName), parentNsPtr->fullName);*/
}
result = NsfCAllocMethod_(interp, class, nameObj, parentNsPtr);
if (tmpName != NULL) {
DECR_REF_COUNT(tmpName);
}
}
return result;
}
/*
classMethod create NsfCCreateMethod {
{-argName "name" -required 1}
{-argName "args" -type allargs}
}
*/
static int
NsfCCreateMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
NsfObject *newObject = NULL;
Tcl_Obj *actualNameObj, *methodObj, *tmpObj = NULL;
int result;
TCL_SIZE_T nameLength = 0;
bool autoNameCreate;
const char *nameString;
Tcl_Namespace *parentNsPtr;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(nameObj != NULL);
nonnull_assert(objv != NULL);
nameString = Tcl_GetStringFromObj(nameObj, &nameLength);
#if 0
{ int i;
fprintf(stderr, "NsfCCreateMethod %s create <%s> oc %d ", ClassName(class), ObjStr(nameObj), objc);
for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
fprintf(stderr, "\n");
}
#endif
if (unlikely(RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_OFF)) {
fprintf(stderr, "### Can't create instance %s of class %s during interp shutdown.\n",
ObjStr(nameObj), ClassName_(class));
/*
* Don't fail, if this happens during destroy, it might be canceled.
*/
return TCL_OK;
}
/*
* Check for illegal names.
*/
if (unlikely(NSValidObjectName(nameString, (size_t)nameLength) == 0)) {
result = NsfPrintError(interp, "cannot allocate object - illegal name '%s'", nameString);
goto create_method_exit;
}
/*fprintf(stderr, "NsfCCreateMethod specifiedName %s\n", nameString);*/
/*
* Complete the name if it is not absolute.
*/
if (!isAbsolutePath(nameString)) {
parentNsPtr = CallingNameSpace(interp);
tmpObj = NameInNamespaceObj(nameString, parentNsPtr);
/*
* If the name contains colons, the parentNsPtr is not appropriate
* for determining the parent.
*/
if (strchr(nameString, ':')) {
parentNsPtr = NULL;
}
nameString = ObjStr(tmpObj);
/* fprintf(stderr, " **** fixed name is '%s'\n", nameString); */
INCR_REF_COUNT(tmpObj);
actualNameObj = tmpObj;
autoNameCreate = NSF_FALSE;
} else {
parentNsPtr = NULL;
actualNameObj = nameObj;
/* fprintf(stderr, " **** used specified name is '%s'\n", nameString); */
/*
* Check for autname prefix string. This string is always an absolute path
* name, so it is sufficient to test here.
*/
autoNameCreate = (strncmp(autonamePrefix, nameString, autonamePrefixLength) == 0);
}
/*
* Check whether we have to call recreate (i.e. when the object exists
* already). First check whether we have such a command, then check whether
* the command is an object.
*/
{
Tcl_Command cmd = NSFindCommand(interp, nameString);
if (cmd != NULL) {
newObject = NsfGetObjectFromCmdPtr(cmd);
if (newObject == NULL) {
/*
* We have a cmd, but no object. Don't allow one to overwrite an
* ordinary cmd by an NSF object.
*/
result = NsfPrintError(interp, "refuse to overwrite cmd %s; delete/rename it before overwriting", nameString);
goto create_method_exit;
}
}
}
/*fprintf(stderr, "+++ createspecifiedName '%s', nameString '%s', newObject=%p ismeta(%s) %d, ismeta(%s) %d\n",
ObjStr(specifiedNameObj), nameString, newObject,
ClassName(class), IsMetaClass(interp, class, NSF_TRUE),
(newObject != NULL) ? ClassName(newObject->cl) : "NULL",
(newObject != NULL) ? IsMetaClass(interp, newObject->cl, NSF_TRUE) : 0
);*/
/*
* Provide protection against recreation if base classes.
*/
if (unlikely(newObject != NULL && unlikely(IsBaseClass(newObject)))) {
result = NsfPrintError(interp, "cannot recreate base class %s", ObjectName(newObject));
goto create_method_exit;
}
/*
* Don't allow one to
* - recreate an object as a class,
* - recreate a class as an object, and to
* - recreate an object in a different object system
*
* In these cases, we use destroy followed by create instead of recreate.
*/
if ((newObject != NULL)
&& (IsMetaClass(interp, class, NSF_TRUE) == IsMetaClass(interp, newObject->cl, NSF_TRUE))
&& GetObjectSystem(newObject) == class->osPtr) {
/*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d oldOs %p != newOs %p EQ %d\n",
ObjStr(actualNameObj), objc+1,
GetObjectSystem(newObject), cl->osPtr,
GetObjectSystem(newObject) != cl->osPtr
);*/
/*
* Call recreate --> initialization.
*/
if (CallDirectly(interp, &class->object, NSF_c_recreate_idx, &methodObj)) {
NSF_PROFILE_TIME_DATA;
NSF_PROFILE_CALL(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_recreate_idx]);
result = RecreateObject(interp, class, newObject, objc, objv);
NSF_PROFILE_EXIT(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_recreate_idx]);
} else {
ALLOC_ON_STACK(Tcl_Obj*, objc+3, xov);
xov[0] = NULL; /* just a placeholder for passing conventions in ObjectDispatch() */
xov[1] = methodObj;
xov[2] = actualNameObj;
if (objc >= 1) {
memcpy(xov+3, objv, sizeof(Tcl_Obj *) * (size_t)objc);
}
result = ObjectDispatch(class, interp, objc+3, xov, NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
FREE_ON_STACK(Tcl_Obj *, xov);
}
if (unlikely(result != TCL_OK)) {
goto create_method_exit;
}
Tcl_SetObjResult(interp, newObject->cmdName);
ObjTrace("RECREATE", newObject);
} else {
/*
* "newObject" might exist here, but will be automatically destroyed by
* alloc.
*/
if (CallDirectly(interp, &class->object, NSF_c_alloc_idx, &methodObj)) {
NSF_PROFILE_TIME_DATA;
NSF_PROFILE_CALL(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_alloc_idx]);
result = NsfCAllocMethod_(interp, class, actualNameObj, parentNsPtr);
NSF_PROFILE_EXIT(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_alloc_idx]);
} else {
result = CallMethod(class, interp, methodObj,
3, &actualNameObj, NSF_CSC_IMMEDIATE);
}
if (unlikely(result != TCL_OK)) {
goto create_method_exit;
}
actualNameObj = Tcl_GetObjResult(interp);
if (unlikely(GetObjectFromObj(interp, actualNameObj, &newObject) != TCL_OK)) {
result = NsfPrintError(interp, "couldn't find result of alloc");
goto create_method_exit;
}
ObjTrace("CREATE", newObject);
if (autoNameCreate) {
newObject->flags |= NSF_IS_AUTONAMED;
}
/*
* In case, the object is destroyed during initialization, we increment
* the refCount.
*/
INCR_REF_COUNT(actualNameObj);
result = DoObjInitialization(interp, newObject, objc, objv);
DECR_REF_COUNT(actualNameObj);
}
create_method_exit:
if (tmpObj != NULL) {
DECR_REF_COUNT(tmpObj);
}
return result;
}
/*
classMethod dealloc NsfCDeallocMethod {
{-argName "object" -required 1 -type tclobj}
}
*/
static int
NsfCDeallocMethod(Tcl_Interp *interp, NsfClass *UNUSED(class), Tcl_Obj *objectObj) {
NsfObject *object;
nonnull_assert(interp != NULL);
if (GetObjectFromObj(interp, objectObj, &object) != TCL_OK) {
return NsfPrintError(interp, "can't destroy object %s that does not exist",
ObjStr(objectObj));
}
return DoDealloc(interp, object);
}
/*
classMethod filterguard NsfCFilterGuardMethod {
{-argName "filter" -required 1}
{-argName "guard" -required 1 -type tclobj}
}
*/
static int
NsfCFilterGuardMethod(Tcl_Interp *interp, NsfClass *class,
const char *filter, Tcl_Obj *guardObj) {
NsfClassOpt *opt;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(filter != NULL);
nonnull_assert(guardObj != NULL);
opt = class->opt;
if (opt != NULL && opt->classFilters) {
NsfCmdList *h = CmdListFindNameInList(interp, filter, opt->classFilters);
if (h != NULL) {
NsfClasses *subClasses = DependentSubClasses(class);
if (h->clientData != NULL) {
GuardDel(h);
}
GuardAdd(h, guardObj);
if (subClasses != NULL) {
FilterInvalidateObjOrders(interp, subClasses);
NsfClassListFree(subClasses);
}
return TCL_OK;
}
}
return NsfPrintError(interp, "filterguard: can't find filter %s on %s",
filter, ClassName_(class));
}
/*
classMethod getCachedParameters NsfCGetCachendParametersMethod {
}
*/
static int
NsfCGetCachendParametersMethod(Tcl_Interp *interp, NsfClass *class) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
if (likely(class->parsedParamPtr != NULL && class->parsedParamPtr->paramDefs != NULL)) {
Tcl_Obj *listObj;
listObj = ListParamDefs(interp, class->parsedParamPtr->paramDefs->paramsPtr,
NULL, NULL, NSF_PARAMS_PARAMETER);
Tcl_SetObjResult(interp, listObj);
DECR_REF_COUNT2("paramDefsObj", listObj);
}
return TCL_OK;
}
/*
classMethod mixinguard NsfCMixinGuardMethod {
{-argName "mixin" -required 1 -type tclobj}
{-argName "guard" -required 1 -type tclobj}
}
*/
static int
NsfCMixinGuardMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *mixinObj, Tcl_Obj *guardObj) {
NsfClassOpt *opt;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(mixinObj != NULL);
nonnull_assert(guardObj != NULL);
opt = class->opt;
if (opt != NULL && opt->classMixins != NULL) {
const Tcl_Command mixinCmd = Tcl_GetCommandFromObj(interp, mixinObj);
if (mixinCmd != NULL) {
const NsfClass *mixinClass = NsfGetClassFromCmdPtr(mixinCmd);
if (mixinClass != NULL) {
NsfCmdList *h = CmdListFindCmdInList(mixinCmd, opt->classMixins);
if (h != NULL) {
NsfClasses *subClasses;
if (h->clientData != NULL) {
GuardDel((NsfCmdList *) h);
}
GuardAdd(h, guardObj);
subClasses = DependentSubClasses(class);
MixinInvalidateObjOrders(subClasses);
NsfClassListFree(subClasses);
return TCL_OK;
}
}
}
}
return NsfPrintError(interp, "mixinguard: can't find mixin %s on %s",
ObjStr(mixinObj), ClassName_(class));
}
/*
classMethod new NsfCNewMethod {
{-argName "-childof" -required 0 -type tclobj}
{-argName "args" -required 0 -type args}
}
*/
static int
NsfCNewMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *childofObj,
TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
Tcl_Obj *fullnameObj;
Tcl_DString dFullname, *dsPtr = &dFullname;
int result;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
#if 0
{ int i;
fprintf(stderr, "NsfCNewMethod %s withChildof %p oc %d ", ClassName(class), childofObj, trailingObjc);
for(i = 0; i < trailingObjc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(trailingObjv[i]));}
fprintf(stderr, "\n");
}
#endif
Tcl_DStringInit(dsPtr);
if (childofObj != 0) {
const char *parentName = ObjStr(childofObj);
/*
* If "parentName" is fully qualified, use it as prefix, else prepend the
* CallingNameSpace() to be compatible with the object name completion.
*/
if (*parentName == ':' && *(parentName + 1) == ':') {
/*
* Prepend parentName only if it is not "::"
*/
if (*(parentName + 2) != '\0') {
Tcl_DStringAppend(dsPtr, parentName, TCL_INDEX_NONE);
}
} else {
Tcl_Obj *tmpName = NameInNamespaceObj(parentName, CallingNameSpace(interp));
const char *completedParentName;
INCR_REF_COUNT(tmpName);
completedParentName = ObjStr(tmpName);
if (strcmp(completedParentName, "::")) {
Tcl_DStringAppend(dsPtr, ObjStr(tmpName), TCL_INDEX_NONE);
}
DECR_REF_COUNT(tmpName);
}
Tcl_DStringAppend(dsPtr, "::__#", 5);
} else {
Tcl_DStringAppend(dsPtr, autonamePrefix, (int)autonamePrefixLength);
}
NewTclCommand(interp, dsPtr);
fullnameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
INCR_REF_COUNT(fullnameObj);
{
Tcl_Obj *methodObj;
int callDirectly;
callDirectly = CallDirectly(interp, &class->object, NSF_c_create_idx, &methodObj);
if (callDirectly != 0) {
NSF_PROFILE_TIME_DATA;
NSF_PROFILE_CALL(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_create_idx]);
result = NsfCCreateMethod(interp, class, fullnameObj, trailingObjc, trailingObjv);
NSF_PROFILE_EXIT(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_create_idx]);
} else {
ALLOC_ON_STACK(Tcl_Obj*, trailingObjc+3, ov);
ov[0] = NULL; /* just a placeholder for passing conventions in ObjectDispatch() */
ov[1] = methodObj;
ov[2] = fullnameObj;
if (trailingObjc >= 1) {
memcpy(ov+3, trailingObjv, sizeof(Tcl_Obj *) * (size_t)trailingObjc);
}
result = ObjectDispatch(class, interp, trailingObjc+3, ov, NSF_CSC_IMMEDIATE);
FREE_ON_STACK(Tcl_Obj *, ov);
}
}
DECR_REF_COUNT(fullnameObj);
Tcl_DStringFree(dsPtr);
return result;
}
/*
classMethod recreate NsfCRecreateMethod {
{-argName "objectName" -required 1 -type tclobj}
{-argName "args" -type virtualclassargs}
}
*/
static int
RecreateObject(Tcl_Interp *interp, NsfClass *class, NsfObject *object,
TCL_OBJC_T objc, Tcl_Obj *const objv[]) {
int result;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(object != NULL);
nonnull_assert(objv != NULL);
object->flags |= NSF_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 (likely(result == TCL_OK)) {
Tcl_Obj *methodObj;
/*
* Dispatch "cleanup" method.
*/
if (CallDirectly(interp, object, NSF_o_cleanup_idx, &methodObj)) {
NSF_PROFILE_TIME_DATA;
/*fprintf(stderr, "RECREATE calls cleanup directly for object %s\n", ObjectName(object));*/
NSF_PROFILE_CALL(interp, object, Nsf_SystemMethodOpts[NSF_o_cleanup_idx]);
result = NsfOCleanupMethod(interp, object);
NSF_PROFILE_EXIT(interp, object, Nsf_SystemMethodOpts[NSF_o_cleanup_idx]);
} else {
/*NsfObjectSystem *osPtr = GetObjectSystem(object);
fprintf(stderr, "RECREATE calls method cleanup for object %p %s OS %s\n",
object, ObjectName(object), ObjectName(&osPtr->rootClass->object));*/
result = CallMethod(object, interp, methodObj,
2, NULL, NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
}
}
/*
* Second: if cleanup was successful, initialize the object as usual.
*/
if (likely(result == TCL_OK)) {
result = DoObjInitialization(interp, object, objc, objv);
if (likely(result == TCL_OK)) {
Tcl_SetObjResult(interp, object->cmdName);
} else {
/* fprintf(stderr, "recreate DoObjInitialization returned %d\n", result);*/
}
}
return result;
}
static int
NsfCRecreateMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *objectNameObj,
TCL_OBJC_T trailingObjc, Tcl_Obj *const trailingObjv[]) {
NsfObject *object;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(objectNameObj != NULL);
if (GetObjectFromObj(interp, objectNameObj, &object) != TCL_OK) {
return NsfPrintError(interp, "can't recreate non existing object %s", ObjStr(objectNameObj));
}
return RecreateObject(interp, class, object, trailingObjc, trailingObjv);
}
/*
classMethod superclass NsfCSuperclassMethod {
{-argName "superclasses" -required 0 -type tclobj}
}
*/
static int
NsfCSuperclassMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *superclassesObj) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
return NsfRelationSetCmd(interp, &class->object, RelationtypeSuperclassIdx, superclassesObj);
}
/***********************************************************************
* End Class Methods
***********************************************************************/
static MethodtypeIdx_t
AggregatedMethodType(MethodtypeIdx_t methodType) {
MethodtypeIdx_t result;
if (methodType == MethodtypeNULL) {
result = MethodtypeAllIdx;
} else if (methodType == MethodtypeBuiltinIdx) {
result = NSF_METHODTYPE_BUILTIN|NSF_METHODTYPE_OBJECT;
} else {
result = methodType;
}
//fprintf(stderr, "AggregatedMethodType input %.4x output %.4x\n", methodType, result);
return result;
}
/***********************************************************************
* Begin Object Info Methods
***********************************************************************/
/*
objectInfoMethod baseclass NsfObjInfoBaseclassMethod {
}
*/
static int
NsfObjInfoBaseclassMethod(Tcl_Interp *interp, NsfObject *object) {
NsfObjectSystem *osPtr;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
osPtr = GetObjectSystem(object);
assert(osPtr != NULL);
Tcl_SetObjResult(interp, osPtr->rootClass->object.cmdName);
return TCL_OK;
}
/*
objectInfoMethod children NsfObjInfoChildrenMethod {
{-argName "-type" -required 0 -nrargs 1 -type class}
{-argName "pattern" -required 0}
}
*/
static int
NsfObjInfoChildrenMethod(Tcl_Interp *interp, NsfObject *object, NsfClass *typeClass, const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return ListChildren(interp, object, pattern, NSF_FALSE, typeClass);
}
/*
objectInfoMethod class NsfObjInfoClassMethod {
}
*/
static int
NsfObjInfoClassMethod(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
Tcl_SetObjResult(interp, object->cl->object.cmdName);
return TCL_OK;
}
/*
objectInfoMethod filterguard NsfObjInfoFilterguardMethod {
{-argName "filter" -required 1}
}
*/
static int
NsfObjInfoFilterguardMethod(Tcl_Interp *interp, NsfObject *object, const char *filter) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(filter != NULL);
return (object->opt != NULL) ? GuardList(interp, object->opt->objFilters, filter) : TCL_OK;
}
/*
objectInfoMethod filters NsfObjInfoFiltersMethod {
{-argName "-guards" -nrargs 0 -type switch}
{-argName "pattern"}
}
*/
static int
NsfObjInfoFiltersMethod(Tcl_Interp *interp, NsfObject *object, int withGuards,
const char *pattern) {
NsfObjectOpt *opt;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
opt = object->opt;
return (opt != NULL) ? FilterInfo(interp, opt->objFilters, pattern, (withGuards == 1), NSF_FALSE) : TCL_OK;
}
/*
objectInfoMethod forward NsfObjInfoForwardMethod {
{-argName "-definition"}
{-argName "pattern"}
}
*/
static int
NsfObjInfoForwardMethod(Tcl_Interp *interp, NsfObject *object, int withDefinition, const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return (object->nsPtr != NULL) ?
ListForward(interp, Tcl_Namespace_cmdTablePtr(object->nsPtr), pattern, withDefinition) :
TCL_OK;
}
/*
objectInfoMethod hasmixin NsfObjInfoHasMixinMethod {
{-argName "class" -required 1 -type class}
}
*/
static int
NsfObjInfoHasMixinMethod(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(class != NULL);
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (int)(HasMixin(interp, object, class)));
return TCL_OK;
}
/*
objectInfoMethod hasnamespace NsfObjInfoHasnamespaceMethod {
}
*/
static int
NsfObjInfoHasnamespaceMethod(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), object->nsPtr != NULL);
return TCL_OK;
}
/*
objectInfoMethod hastype NsfObjInfoHasTypeMethod {
{-argName "class" -required 1 -type class}
}
*/
static int
NsfObjInfoHasTypeMethod(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(class != NULL);
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (int)(IsSubType(object->cl, class)));
return TCL_OK;
}
/*
objectInfoMethod lookupfilter NsfObjInfoLookupFilterMethod {
{-argName "filter" -required 1}
}
*/
static int
NsfObjInfoLookupFilterMethod(Tcl_Interp *interp, NsfObject *object, const char *filter) {
const char *filterName;
NsfCmdList *cmdList;
NsfClass *fcl;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(filter != NULL);
/*
* Searches for filter on [self] and returns fully qualified name if it is
* not found it returns an empty string.
*/
Tcl_ResetResult(interp);
if ((object->flags & NSF_FILTER_ORDER_VALID) == 0u) {
FilterComputeDefined(interp, object);
}
if ((object->flags & NSF_FILTER_ORDER_DEFINED) == 0u) {
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 == NULL) {
return TCL_OK;
}
fcl = cmdList->clorobj;
Tcl_SetObjResult(interp, MethodHandleObj((NsfObject *)fcl, !NsfObjectIsClass(&fcl->object), filterName));
return TCL_OK;
}
/*
objectInfoMethod lookupfilters NsfObjInfoLookupFiltersMethod {
{-argName "-guards" -nrargs 0 -type switch}
{-argName "pattern"}
}
*/
static int
NsfObjInfoLookupFiltersMethod(Tcl_Interp *interp, NsfObject *object, int withGuards, const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if ((object->flags & NSF_FILTER_ORDER_VALID) == 0u) {
FilterComputeDefined(interp, object);
}
return FilterInfo(interp, object->filterOrder, pattern, (withGuards == 1), NSF_TRUE);
}
/*
objectInfoMethod lookupmethod NsfObjInfoLookupMethodMethod {
{-argName "name" -required 1 -type tclobj}
}
*/
static int
NsfObjInfoLookupMethodMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj) {
NsfClass *classPtr = NULL;
Tcl_Command cmd;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(nameObj != NULL);
cmd = ObjectFindMethod(interp, object, nameObj, &classPtr);
if (likely(cmd != NULL)) {
NsfObject *pobj = (classPtr != NULL) ? &classPtr->object : object;
int perObject = (classPtr == NULL);
ListMethod(interp, pobj, pobj, ObjStr(nameObj), cmd,
InfomethodsubcmdRegistrationhandleIdx,
NULL, NULL, (perObject == 1));
}
return TCL_OK;
}
static int ListMethodKeysClassList(Tcl_Interp *interp, NsfClasses *classListPtr,
DefinitionsourceIdx_t withSource, const char *pattern,
MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection,
bool withPath, Tcl_HashTable *dups,
NsfObject *object, bool withPer_object)
nonnull(1) nonnull(8) nonnull(9);
static int
ListMethodKeysClassList(Tcl_Interp *interp, NsfClasses *classListPtr,
DefinitionsourceIdx_t withSource, const char *pattern,
MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection,
bool withPath, Tcl_HashTable *dups,
NsfObject *object, bool withPer_object) {
nonnull_assert(interp != NULL);
nonnull_assert(dups != NULL);
nonnull_assert(object != NULL);
/*
* Append method keys from inheritance order
*/
for (; classListPtr != NULL; classListPtr = classListPtr->nextPtr) {
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(classListPtr->cl->nsPtr);
if (!MethodSourceMatches(withSource, classListPtr->cl, NULL)) {
continue;
}
ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType,
withCallprotection, withPath,
dups, object, withPer_object);
}
return TCL_OK;
}
/*
objectInfoMethod lookupmethods NsfObjInfoLookupMethodsMethod {
{-argName "-callprotection" -type "all|public|protected|private" -default all}
{-argName "-incontext" -nrargs 0}
{-argName "-type" -typeName "methodtype" -type "all|scripted|builtin|alias|forwarder|object|setter|nsfproc"}
{-argName "-nomixins" -nrargs 0}
{-argName "-path" -nrargs 0}
{-argName "-source" -type "all|application|system" -default all}
{-argName "pattern" -required 0}
}
*/
static int
NsfObjInfoLookupMethodsMethod(Tcl_Interp *interp, NsfObject *object,
CallprotectionIdx_t withCallprotection,
int withIncontext,
MethodtypeIdx_t withType,
int withNomixins,
int withPath,
DefinitionsourceIdx_t withSource,
const char *pattern) {
int result;
bool withPer_object = NSF_TRUE;
Tcl_HashTable dupsTable, *dups = &dupsTable;
MethodtypeIdx_t methodType = AggregatedMethodType(withType);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*
* TODO: We could make this faster for patterns without meta-chars 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 (withSource == DefinitionsourceNULL) {
withSource = DefinitionsourceAllIdx;
}
Tcl_InitHashTable(dups, TCL_STRING_KEYS);
if (object->nsPtr != NULL) {
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(object->nsPtr);
if (MethodSourceMatches(withSource, NULL, object)) {
ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType,
withCallprotection, (withPath == 1),
dups, object, withPer_object);
}
}
if (withNomixins == 0) {
if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
}
if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
NsfCmdList *ml;
for (ml = object->mixinOrder; ml; ml = ml->nextPtr) {
int guardOk = TCL_OK;
NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
assert(mixin != NULL);
if (withIncontext != 0) {
if (!RUNTIME_STATE(interp)->guardCount && ml->clientData) {
guardOk = GuardCall(object, interp, ml->clientData, NULL);
}
}
if (mixin && guardOk == TCL_OK) {
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(mixin->nsPtr);
if (!MethodSourceMatches(withSource, mixin, NULL)) {
continue;
}
ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType,
withCallprotection, withPath,
dups, object, withPer_object);
}
}
}
}
result = ListMethodKeysClassList(interp, PrecedenceOrder(object->cl),
withSource, pattern,
methodType, withCallprotection,
(withPath == 1), dups, object, withPer_object);
Tcl_DeleteHashTable(dups);
return result;
}
/*
objectInfoMethod lookupmixins NsfObjInfoLookupMixinsMethod {
{-argName "-guards" -nrargs 0 -type switch}
{-argName "pattern" -type objpattern}
}
*/
static int
NsfObjInfoLookupMixinsMethod(Tcl_Interp *interp, NsfObject *object, int withGuards,
const char *patternString, NsfObject *patternObject) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
MixinComputeDefined(interp, object);
}
return MixinInfo(interp, object->mixinOrder, patternString, (withGuards == 1), patternObject);
}
/*
objectInfoMethod lookupslots NsfObjInfoLookupSlotsMethod {
{-argName "-source" -nrargs 1 -type "all|application|system" -default all}
{-argName "-type" -required 0 -nrargs 1 -type class}
{-argName "pattern" -required 0}
}
*/
static int
NsfObjInfoLookupSlotsMethod(Tcl_Interp *interp, NsfObject *object,
DefinitionsourceIdx_t withSource,
NsfClass *typeClass,
const char *pattern) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
NsfClasses *precedenceList, *clPtr;
Tcl_HashTable slotTable;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
precedenceList = ComputePrecedenceList(interp, object, NULL /* pattern*/,
NSF_TRUE, NSF_TRUE);
assert(precedenceList != NULL);
if (withSource == 0) {
withSource = 1;
}
Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS);
MEM_COUNT_ALLOC("Tcl_InitHashTable", &slotTable);
/*
* First add the per-object slot objects.
*/
if (MethodSourceMatches(withSource, NULL, object)) {
AddSlotObjects(interp, object, "::per-object-slot", &slotTable,
typeClass, pattern, listObj);
}
/*
* Then add the class provided slot objects.
*/
for (clPtr = precedenceList; likely(clPtr != NULL); clPtr = clPtr->nextPtr) {
if (MethodSourceMatches(withSource, clPtr->cl, NULL)) {
AddSlotObjects(interp, &clPtr->cl->object, "::slot", &slotTable,
typeClass, pattern, listObj);
}
}
Tcl_DeleteHashTable(&slotTable);
MEM_COUNT_FREE("Tcl_InitHashTable", &slotTable);
NsfClassListFree(precedenceList);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
/*
objectInfoMethod method NsfObjInfoMethodMethod {
{-argName "infomethodsubcmd" -type "args|body|definition|exists|registrationhandle|definitionhandle|origin|parameter|syntax|type|precondition|postcondition|submethods"}
{-argName "name" -required 1 -type tclobj}
}
*/
static int
NsfObjInfoMethodMethod(Tcl_Interp *interp, NsfObject *object,
InfomethodsubcmdIdx_t subcmd, Tcl_Obj *nameObj) {
return ListMethodResolve(interp, subcmd, NULL, NULL, object->nsPtr, object, nameObj, NSF_FALSE);
}
/*
objectInfoMethod methods NsfObjInfoMethodsMethod {
{-argName "-callprotection" -type "all|public|protected|private" -default all}
{-argName "-type" -nrargs 1 -typeName "methodtype" -type "all|scripted|builtin|alias|forwarder|object|setter"}
{-argName "-path" -nrargs 0}
{-argName "pattern"}
}
*/
static int
NsfObjInfoMethodsMethod(Tcl_Interp *interp, NsfObject *object,
CallprotectionIdx_t withCallprotection,
MethodtypeIdx_t withType,
int withPath,
const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return ListDefinedMethods(interp, object, pattern, 1 /* per-object */,
AggregatedMethodType(withType), withCallprotection,
withPath);
}
/*
objectInfoMethod mixins NsfObjInfoMixinsMethod {
{-argName "-guards" -nrargs 0 -type switch}
{-argName "pattern" -type objpattern}
}
*/
static int
NsfObjInfoMixinsMethod(Tcl_Interp *interp, NsfObject *object, int withGuards,
const char *patternString, NsfObject *patternObject) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
return (object->opt != NULL) ?
MixinInfo(interp, object->opt->objMixins, patternString, (withGuards == 1), patternObject) :
TCL_OK;
}
/*
objectInfoMethod mixinguard NsfObjInfoMixinguardMethod {
{-argName "mixin" -required 1}
}
*/
static int
NsfObjInfoMixinguardMethod(Tcl_Interp *interp, NsfObject *object, const char *mixin) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
nonnull_assert(mixin != NULL);
return (object->opt != NULL) ? GuardList(interp, object->opt->objMixins, mixin) : TCL_OK;
}
/*
objectInfoMethod name NsfObjInfoNameMethod {
}
*/
static int
NsfObjInfoNameMethod(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetCommandName(interp, object->id), TCL_INDEX_NONE));
return TCL_OK;
}
/*
objectInfoMethod parent NsfObjInfoParentMethod {
}
*/
static int
NsfObjInfoParentMethod(Tcl_Interp *interp, NsfObject *object) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
if (object->id != NULL) {
Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(object->id);
Tcl_SetObjResult(interp, Tcl_NewStringObj((nsPtr != NULL) ? nsPtr->fullName : "", TCL_INDEX_NONE));
}
return TCL_OK;
}
/*
objectInfoMethod precedence NsfObjInfoPrecedenceMethod {
{-argName "-intrinsic"}
{-argName "pattern" -required 0}
}
*/
static int
NsfObjInfoPrecedenceMethod(Tcl_Interp *interp, NsfObject *object,
int withIntrinsic, const char *pattern) {
NsfClasses *precedenceList, *pl;
Tcl_Obj *resultObj = Tcl_NewObj();
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
precedenceList = ComputePrecedenceList(interp, object, pattern,
(withIntrinsic == 0), NSF_TRUE);
for (pl = precedenceList; pl != NULL; pl = pl->nextPtr) {
assert(pl->cl != NULL);
Tcl_ListObjAppendElement(interp, resultObj, pl->cl->object.cmdName);
}
if (precedenceList != NULL) {
NsfClassListFree(precedenceList);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
objectInfoMethod slotobjects NsfObjInfoSlotobjectsMethod {
{-argName "-type" -required 0 -nrargs 1 -type class}
{-argName "pattern" -required 0}
}
*/
static int
NsfObjInfoSlotobjectsMethod(Tcl_Interp *interp, NsfObject *object,
NsfClass *typeClass, const char *pattern) {
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
AddSlotObjects(interp, object, "::per-object-slot", NULL,
typeClass, pattern, listObj);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
/*
objectInfoMethod vars NsfObjInfoVarsMethod {
{-argName "pattern" -required 0}
}
*/
static int
NsfObjInfoVarsMethod(Tcl_Interp *interp, NsfObject *object, const char *pattern) {
Tcl_Obj *okList;
TclVarHashTable *varTablePtr;
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
okList = Tcl_NewListObj(0, NULL);
varTablePtr = (object->nsPtr != NULL) ?
Tcl_Namespace_varTablePtr(object->nsPtr) :
object->varTablePtr;
/*
* It is possible, that both, object->nsPtr and object->varTablePtr are
* NULL.
*/
if (likely(varTablePtr != NULL)) {
Tcl_Obj *varList, *element;
TCL_SIZE_T i, length;
ListVarKeys(interp, TclVarHashTablePtr(varTablePtr), pattern);
varList = Tcl_GetObjResult(interp);
Tcl_ListObjLength(interp, varList, &length);
for (i = 0; i < length; i++) {
Tcl_ListObjIndex(interp, varList, i, &element);
if (VarExists(interp, object, ObjStr(element), NULL, NSF_VAR_REQUIRE_DEFINED)) {
Tcl_ListObjAppendElement(interp, okList, element);
} else {
/*fprintf(stderr, "must ignore '%s' %d\n", ObjStr(element), i);*/
/*Tcl_ListObjReplace(interp, varList, i, 1, 0, NULL);*/
}
}
}
Tcl_SetObjResult(interp, okList);
return TCL_OK;
}
/***********************************************************************
* End Object Info Methods
***********************************************************************/
/***********************************************************************
* Begin Class Info methods
***********************************************************************/
/*
classInfoMethod filterguard NsfClassInfoFilterguardMethod {
{-argName "filter" -required 1}
}
*/
static int
NsfClassInfoFilterguardMethod(Tcl_Interp *interp, NsfClass *class, const char *filter) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(filter != NULL);
return (class->opt != NULL) ? GuardList(interp, class->opt->classFilters, filter) : TCL_OK;
}
/*
classInfoMethod filters NsfClassInfoFiltersMethod {
{-argName "-guards" -nrargs 0 -type switch}
{-argName "pattern"}
}
*/
static int
NsfClassInfoFiltersMethod(Tcl_Interp *interp, NsfClass *class,
int withGuards, const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
return (class->opt != NULL) ?
FilterInfo(interp, class->opt->classFilters, pattern, (withGuards == 1), NSF_FALSE) : TCL_OK;
}
/*
classInfoMethod forward NsfClassInfoForwardMethod {
{-argName "-definition"}
{-argName "pattern"}
}
*/
static int
NsfClassInfoForwardMethod(Tcl_Interp *interp, NsfClass *class,
int withDefinition, const char *pattern) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
return ListForward(interp, Tcl_Namespace_cmdTablePtr(class->nsPtr), pattern, withDefinition);
}
/*
classInfoMethod heritage NsfClassInfoHeritageMethod {
{-argName "pattern"}
}
*/
static int
NsfClassInfoHeritageMethod(Tcl_Interp *interp, NsfClass *class, const char *pattern) {
NsfClasses *pl, *intrinsic, *checkList = NULL, *mixinClasses = NULL;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
resultObj = Tcl_NewObj();
intrinsic = PrecedenceOrder(class);
NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
for (pl = mixinClasses; pl != NULL; pl = pl->nextPtr) {
if (NsfClassListFind(pl->nextPtr, pl->cl) == NULL &&
NsfClassListFind(intrinsic, pl->cl) == NULL) {
AppendMatchingElement(interp, resultObj, pl->cl->object.cmdName, pattern);
}
}
if (intrinsic != NULL) {
for (pl = intrinsic->nextPtr; pl != NULL; pl = pl->nextPtr) {
AppendMatchingElement(interp, resultObj, pl->cl->object.cmdName, pattern);
}
}
if (mixinClasses != NULL) {
NsfClassListFree(mixinClasses);
}
if (checkList != NULL) {
NsfClassListFree(checkList);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InstancesFromClassList --
*
* Collect all instances of the classes of the provided class list in the
* returned result object.
*
* Results:
* Tcl_Obj containing a list of instances or a single instance
*
* Side effects:
* Updated resultObj.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *InstancesFromClassList(
Tcl_Interp *interp, NsfClasses *subClasses,
const char *pattern, NsfObject *matchObject
) nonnull(1) nonnull(2) returns_nonnull;
static Tcl_Obj *
InstancesFromClassList(
Tcl_Interp *interp, NsfClasses *subClasses,
const char *pattern, NsfObject *matchObject
) {
Tcl_Obj *resultObj = Tcl_NewObj();
nonnull_assert(interp != NULL);
nonnull_assert(subClasses != NULL);
do {
Tcl_HashTable *tablePtr = &subClasses->cl->instances;
const Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
NsfObject *inst = (NsfObject *) Tcl_GetHashKey(tablePtr, hPtr);
if (matchObject != NULL && inst == matchObject) {
Tcl_SetStringObj(resultObj, ObjStr(matchObject->cmdName), TCL_INDEX_NONE);
return resultObj;
}
AppendMatchingElement(interp, resultObj, inst->cmdName, pattern);
}
subClasses = subClasses->nextPtr;
} while (subClasses != NULL);
return resultObj;
}
/*
classInfoMethod instances NsfClassInfoInstancesMethod {
{-argName "-closure" -nrargs 0}
{-argName "pattern" -type objpattern}
}
*/
static int
NsfClassInfoInstancesMethod(
Tcl_Interp *interp, NsfClass *class,
int withClosure, const char *patternString,
NsfObject *patternObject
) {
NsfClasses clElement, *subClasses;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
if (withClosure != 0) {
subClasses = TransitiveSubClasses(class);
} else {
subClasses = &clElement;
clElement.cl = class;
clElement.nextPtr = NULL;
}
Tcl_SetObjResult(interp, InstancesFromClassList(interp, subClasses, patternString, patternObject));
if (withClosure != 0) {
NsfClassListFree(subClasses);
}
return TCL_OK;
}
/*
classInfoMethod method NsfClassInfoMethodMethod {
{-argName "infomethodsubcmd" -type "args|body|definition|exists|registrationhandle|definitionhandle|origin|parameter|syntax|type|precondition|postcondition|submethods|returns"}
{-argName "name" -required 1 -type tclobj}
}
*/
static int
NsfClassInfoMethodMethod(
Tcl_Interp *interp, NsfClass *class,
InfomethodsubcmdIdx_t subcmd, Tcl_Obj *nameObj
) {
return ListMethodResolve(interp, subcmd, NULL, NULL, class->nsPtr, &class->object, nameObj, NSF_TRUE);
}
/*
classInfoMethod methods NsfClassInfoMethodsMethod {
{-argName "-callprotection" -type "all|public|protected|private" -default all}
{-argName "-closure" -nrargs 0}
{-argName "-type" -typeName "methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"}
{-argName "-path" -nrargs 0}
{-argName "-source" -nrargs 1 -type "all|application|system"}
{-argName "pattern"}
}
*/
static int
NsfClassInfoMethodsMethod(
Tcl_Interp *interp, NsfClass *class,
CallprotectionIdx_t withCallprotection,
int withClosure,
MethodtypeIdx_t withType,
int withPath,
DefinitionsourceIdx_t withSource,
const char *pattern
) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
if (withClosure != 0) {
NsfClasses *checkList = NULL, *mixinClasses = NULL;
Tcl_HashTable dupsTable, *dups = &dupsTable;
int result;
#if 0
if (withCallprotection == CallprotectionNULL) {
withCallprotection = CallprotectionPublicIdx;
}
#endif
if (withSource == DefinitionsourceNULL) {
withSource = DefinitionsourceAllIdx;
}
Tcl_InitHashTable(dups, TCL_STRING_KEYS);
/*
* Guards are ignored.
*/
NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
(void) ListMethodKeysClassList(interp, mixinClasses,
withSource, pattern,
AggregatedMethodType(withType), withCallprotection,
withPath, dups, &class->object, NSF_FALSE);
if (checkList != NULL) {
NsfClassListFree(checkList);
}
if (mixinClasses != NULL) {
NsfClassListFree(mixinClasses);
}
result = ListMethodKeysClassList(interp, PrecedenceOrder(class),
withSource, pattern,
AggregatedMethodType(withType), withCallprotection,
withPath, dups, &class->object, NSF_FALSE);
Tcl_DeleteHashTable(dups);
return result;
} else {
if (withSource != 0) {
return NsfPrintError(interp, "-source cannot be used without -closure\n");
}
return ListDefinedMethods(interp, &class->object, pattern, 0 /* per-object */,
AggregatedMethodType(withType), withCallprotection,
withPath);
}
}
/*
classInfoMethod mixins NsfClassInfoMixinsMethod {
{-argName "-closure" -nrargs 0 -type switch}
{-argName "-guards" -nrargs 0 -type switch}
{-argName "-heritage" -nrargs 0 -type switch}
{-argName "pattern" -type objpattern}
}
*/
static int
NsfClassInfoMixinsMethod(
Tcl_Interp *interp, NsfClass *class,
int withClosure, int withGuards, int withHeritage,
const char *patternString, NsfObject *patternObject
) {
NsfClassOpt *opt;
Tcl_Obj *resultObj;
int result = TCL_OK;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
opt = class->opt;
Tcl_ResetResult(interp);
resultObj = Tcl_GetObjResult(interp);
if (withHeritage != 0) {
NsfClasses *checkList = NULL, *mixinClasses = NULL, *clPtr;
if (withGuards != 0) {
return NsfPrintError(interp, "-guards cannot be used together with -heritage\n");
}
NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
for (clPtr = mixinClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
if (NsfClassListFind(clPtr->nextPtr, clPtr->cl)) {
continue;
}
AppendMatchingElement(interp, resultObj, clPtr->cl->object.cmdName, patternString);
}
if (checkList != NULL) {
NsfClassListFree(checkList);
}
if (mixinClasses != NULL) {
NsfClassListFree(mixinClasses);
}
} else if (withClosure != 0) {
Tcl_HashTable objTable, *commandTable = &objTable;
bool done;
MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
done = GetAllClassMixins(interp, commandTable, resultObj,
class, (withGuards == 1),
patternString, patternObject);
if (patternObject != NULL && done && !withGuards) {
Tcl_SetObjResult(interp, patternObject->cmdName);
}
Tcl_DeleteHashTable(commandTable);
MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
} else {
result = (opt != NULL) ?
MixinInfo(interp, opt->classMixins, patternString, (withGuards == 1), patternObject) : TCL_OK;
}
return result;
}
/*
classInfoMethod mixinguard NsfClassInfoMixinguardMethod {
{-argName "mixin" -required 1}
}
*/
static int
NsfClassInfoMixinguardMethod(Tcl_Interp *interp, NsfClass *class, const char *mixin) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
nonnull_assert(mixin != NULL);
return (class->opt != NULL) ? GuardList(interp, class->opt->classMixins, mixin) : TCL_OK;
}
/*
classInfoMethod mixinof NsfClassInfoMixinOfMethod {
{-argName "-closure" -nrargs 0}
{-argName "-scope" -required 0 -nrargs 1 -type "all|class|object"}
{-argName "pattern" -type objpattern}
}
*/
static int
NsfClassInfoMixinOfMethod(
Tcl_Interp *interp, NsfClass *class,
int withClosure,
MixinscopeIdx_t withScope,
const char *patternString,
NsfObject *patternObject
) {
NsfClassOpt *opt;
bool perClass, perObject, done = NSF_FALSE;
Tcl_Obj *resultObj;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
opt = class->opt;
Tcl_ResetResult(interp);
resultObj = Tcl_GetObjResult(interp);
if (withScope == MixinscopeNULL || withScope == MixinscopeAllIdx) {
perClass = NSF_TRUE;
perObject = NSF_TRUE;
} else if (withScope == MixinscopeClassIdx) {
perClass = NSF_TRUE;
perObject = NSF_FALSE;
} else {
perClass = NSF_FALSE;
perObject = NSF_TRUE;
}
if (opt != NULL && !withClosure) {
if (perClass && opt->isClassMixinOf != NULL) {
done = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf, resultObj,
patternString, patternObject);
if (done && (patternObject != NULL)) {
goto finished;
}
}
if (perObject && opt->isObjectMixinOf) {
done = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, resultObj,
patternString, patternObject);
}
} else if (withClosure != 0) {
Tcl_HashTable objTable, *commandTable = &objTable;
MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
if (perClass) {
done = GetAllClassMixinsOf(interp, commandTable, resultObj,
class, NSF_FALSE, NSF_TRUE, patternString, patternObject);
if (done && (patternObject != NULL)) {
goto finished;
}
}
if (perObject) {
done = GetAllObjectMixinsOf(interp, commandTable, resultObj,
class, NSF_FALSE, NSF_TRUE, patternString, patternObject);
}
Tcl_DeleteHashTable(commandTable);
MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
}
finished:
if (patternObject != NULL) {
Tcl_SetObjResult(interp, done ? patternObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
} else {
Tcl_SetObjResult(interp, resultObj);
}
return TCL_OK;
}
/*
classInfoMethod slots NsfClassInfoSlotobjectsMethod {
{-argName "-closure" -nrargs 0}
{-argName "-source" -nrargs 1 -type "all|application|system"}
{-argName "-type" -required 0 -nrargs 1 -type class}
{-argName "pattern" -required 0}
}
*/
static int
NsfClassInfoSlotobjectsMethod(Tcl_Interp *interp,
NsfClass *class,
int withClosure,
DefinitionsourceIdx_t withSource,
NsfClass *typeClass,
const char *pattern) {
NsfClasses *clPtr, *intrinsicClasses, *precedenceList = NULL;
Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
Tcl_HashTable slotTable;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
Tcl_ResetResult(interp);
intrinsicClasses = PrecedenceOrder(class);
if (withClosure != 0) {
NsfClasses *checkList = NULL, *mixinClasses = NULL;
/*
* Compute the closure: first the transitive mixin-classes...
*/
NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
for (clPtr = mixinClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
if (NsfClassListFind(clPtr->nextPtr, clPtr->cl) == NULL &&
NsfClassListFind(intrinsicClasses, clPtr->cl) == NULL) {
NsfClassListAdd(&precedenceList, clPtr->cl, NULL);
}
}
/*
* ... followed by the intrinsic classes.
*/
NsfClassListAdd(&precedenceList, class, NULL);
for (clPtr = intrinsicClasses->nextPtr; clPtr != NULL; clPtr = clPtr->nextPtr) {
NsfClassListAdd(&precedenceList, clPtr->cl, NULL);
}
if (checkList != NULL) {
NsfClassListFree(checkList);
}
if (mixinClasses != NULL) {
NsfClassListFree(mixinClasses);
}
} else {
NsfClassListAdd(&precedenceList, class, NULL);
}
/* NsfClassListPrint("precedence", precedenceList); */
if (withSource == 0) {
withSource = 1;
}
/*
* Use a hash-table to eliminate potential duplicates.
*/
Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS);
MEM_COUNT_ALLOC("Tcl_InitHashTable", &slotTable);
for (clPtr = precedenceList; clPtr != NULL; clPtr = clPtr->nextPtr) {
if (MethodSourceMatches(withSource, clPtr->cl, NULL)) {
AddSlotObjects(interp, &clPtr->cl->object, "::slot", &slotTable,
typeClass, pattern, listObj);
}
}
Tcl_DeleteHashTable(&slotTable);
MEM_COUNT_FREE("Tcl_InitHashTable", &slotTable);
if (precedenceList != NULL) {
NsfClassListFree(precedenceList);
}
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
/*
classInfoMethod subclass NsfClassInfoSubclassMethod {
{-argName "-closure" -nrargs 0 -type switch}
{-argName "-dependent" -nrargs 0 -type switch}
{-argName "pattern" -type objpattern}
}
*/
static int
NsfClassInfoSubclassMethod(Tcl_Interp *interp, NsfClass *class,
int withClosure, int withDependent,
const char *patternString, NsfObject *patternObject) {
bool found = NSF_FALSE;
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
if (withClosure && withDependent) {
return NsfPrintError(interp, "only -closure or -dependent can be specified, not both");
}
if (withClosure || withDependent) {
NsfClasses *subClasses = (withClosure != 0) ? TransitiveSubClasses(class) : DependentSubClasses(class);
if (subClasses != NULL) {
found = AppendMatchingElementsFromClasses(interp, subClasses, patternString, patternObject);
NsfClassListFree(subClasses);
}
} else if (class->sub != NULL) {
found = AppendMatchingElementsFromClasses(interp, class->sub, patternString, patternObject);
}
if (patternObject != NULL) {
Tcl_SetObjResult(interp, found ? patternObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
}
return TCL_OK;
}
/*
classInfoMethod superclass NsfClassInfoSuperclassMethod {
{-argName "-closure" -nrargs 0}
{-argName "pattern" -type tclobj}
}
*/
static int
NsfClassInfoSuperclassMethod(Tcl_Interp *interp, NsfClass *class, int withClosure, Tcl_Obj *patternObj) {
nonnull_assert(interp != NULL);
nonnull_assert(class != NULL);
return ListSuperClasses(interp, class, patternObj, (withClosure == 1));
}
/***********************************************************************
* End Class Info methods
***********************************************************************/
/*
* Initialization and Exit handlers
*/
#ifdef DO_FULL_CLEANUP
/*
* Delete global variables and procs.
*/
static void DeleteProcsAndVars(
Tcl_Interp *interp, Tcl_Namespace *nsPtr, bool withKeepvars
) nonnull(1) nonnull(2);
static void
DeleteProcsAndVars(
Tcl_Interp *interp, Tcl_Namespace *nsPtr, bool withKeepvars
) {
Tcl_HashTable *varTablePtr, *cmdTablePtr, *childTablePtr;
Tcl_HashSearch search;
Tcl_Command cmd;
register Tcl_HashEntry *entryPtr;
nonnull_assert(interp != NULL);
nonnull_assert(nsPtr != NULL);
/* fprintf(stderr, "DeleteProcsAndVars in %s\n", nsPtr->fullName); */
varTablePtr = (Tcl_HashTable *)Tcl_Namespace_varTablePtr(nsPtr);
cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
childTablePtr = Tcl_Namespace_childTablePtr(nsPtr);
/*
* Deleting the procs and vars in the child namespaces does not seem to be
* necessary, but we do it anyway.
*/
for (entryPtr = Tcl_FirstHashEntry(childTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Namespace *childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
DeleteProcsAndVars(interp, childNsPtr, withKeepvars);
}
if (!withKeepvars) {
for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Obj *nameObj;
Var *varPtr;
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(cmdTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
if (TCL_COMMAND_OBJPROC(cmd) == RUNTIME_STATE(interp)->objInterpProc) {
/*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n",
Tcl_GetHashKey(cmdTablePtr, entryPtr), cmd, Tcl_Command_proc(cmd), TCL_COMMAND_OBJPROC(cmd),
Tcl_Command_proc(cmd)==RUNTIME_STATE(interp)->objInterpProc);*/
Tcl_DeleteCommandFromToken(interp, cmd);
}
}
}
#endif
/*
*----------------------------------------------------------------------
*
* FinalObjectDeletion --
*
* The method is to be called, when an object is finally deleted,
* which happens typically during the final cleanup. It tests as
* well the activation count of the object.
*
* Results:
* None.
*
* Side effects:
* Deletion of the objects.
*
*----------------------------------------------------------------------
*/
static void
FinalObjectDeletion(
Tcl_Interp *interp, NsfObject *object
) {
nonnull_assert(interp != NULL);
nonnull_assert(object != NULL);
/*
* If a call to exit happens from a higher stack frame, the object
* refCount might not be decremented correctly. If we are in the
* physical destroy round, we can set the counter to an appropriate
* value to ensure deletion.
*/
#if defined(NSF_DEVELOPMENT_TEST)
if (unlikely(object->refCount != 1)) {
if (object->refCount > 1) {
NsfLog(interp, NSF_LOG_WARN, "RefCount for obj %p %d (name %s) > 1",
(void *)object, object->refCount, ObjectName_(object));
} else {
NsfLog(interp, NSF_LOG_WARN, "Refcount for obj %p %d > 1",
(void *)object, object->refCount);
}
/*object->refCount = 1;*/
}
#endif
#if !defined(NDEBUG)
if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_ON_PHYSICAL_DESTROY) {
assert(object->activationCount == 0);
} else if (object->activationCount != 0) {
NsfLog(interp, NSF_LOG_WARN, "FinalObjectDeletion obj %p activationcount %d\n",
(void *)object, object->activationCount);
}
#endif
if (likely(object->id != NULL)) {
/*fprintf(stderr, " ... cmd dealloc %p final delete refCount %d\n",
object->id, Tcl_Command_refCount(object->id));*/
if (NSF_DTRACE_OBJECT_FREE_ENABLED()) {
NSF_DTRACE_OBJECT_FREE(ObjectName(object), ClassName(object->cl));
}
Tcl_DeleteCommandFromToken(interp, object->id);
}
}
#ifdef DO_CLEANUP
/*
*----------------------------------------------------------------------
*
* DeleteNsfProcs --
*
* Delete all nsfprocs in the namespaces rooted by the second
* argument. If the provided nsPtr is NULL, the global namespace is
* used as root of the namespace tree. The function is necessary to
* trigger the freeing of the parameter definitions.
*
* Results:
* None.
*
* Side effects:
* Deletion of nsfprocs.
*
*----------------------------------------------------------------------
*/
static void DeleteNsfProcs(
Tcl_Interp *interp, Tcl_Namespace *nsPtr
) nonnull(1);
static void
DeleteNsfProcs(
Tcl_Interp *interp, Tcl_Namespace *nsPtr
) {
Tcl_HashTable *cmdTablePtr, *childTablePtr;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
nonnull_assert(interp != NULL);
if (nsPtr == NULL) {
nsPtr = Tcl_GetGlobalNamespace(interp);
}
nonnull_assert(nsPtr != NULL);
/*fprintf(stderr, "### DeleteNsfProcs current namespace '%s'\n", (nsPtr != NULL) ? nsPtr->fullName : "NULL");*/
cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
childTablePtr = Tcl_Namespace_childTablePtr(nsPtr);
for (entryPtr = Tcl_FirstHashEntry(cmdTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
if (TCL_COMMAND_OBJPROC(cmd) == NsfProcStub) {
/*fprintf(stderr, "cmdname = %s cmd %p\n",
Tcl_GetHashKey(cmdTablePtr, entryPtr), cmd);*/
Tcl_DeleteCommandFromToken(interp, cmd);
}
}
for (entryPtr = Tcl_FirstHashEntry(childTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Namespace *childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
DeleteNsfProcs(interp, childNsPtr);
}
}
/*
*----------------------------------------------------------------------
*
* ClassHasSubclasses --
*
* Check, whether the given class has subclasses.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool ClassHasSubclasses(
const NsfClass *class
) nonnull(1) NSF_pure;
static bool
ClassHasSubclasses(
const NsfClass *class
) {
nonnull_assert(class != NULL);
return (class->sub != NULL);
}
/*
*----------------------------------------------------------------------
*
* ClassHasInstances --
*
* Check, whether the given class has instances.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool ClassHasInstances(
NsfClass *class
) nonnull(1) NSF_pure;
static bool
ClassHasInstances(
NsfClass *class
) {
Tcl_HashSearch hSrch;
nonnull_assert(class != NULL);
return (Tcl_FirstHashEntry(&class->instances, &hSrch) != NULL);
}
/*
*----------------------------------------------------------------------
*
* ObjectHasChildren --
*
* Check, whether the given object has children.
*
* Results:
* A Boolean value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static bool ObjectHasChildren(
const NsfObject *object
) nonnull(1) NSF_pure;
static bool
ObjectHasChildren(
const NsfObject *object
) {
const Tcl_Namespace *ns;
bool result = NSF_FALSE;
nonnull_assert(object != NULL);
ns = object->nsPtr;
if (ns != NULL) {
const Tcl_HashEntry *hPtr;
Tcl_HashSearch hSrch;
Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(ns);
for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
Tcl_Command cmd = Tcl_GetHashValue(hPtr);
const NsfObject *childObject = NsfGetObjectFromCmdPtr(cmd);
if (childObject != NULL) {
result = NSF_TRUE;
break;
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* FreeAllNsfObjectsAndClasses --
*
* Destroy and free all objects and classes defined in the interp.
*
* Results:
* None.
*
* Side effects:
* Freeing memory.
*
*----------------------------------------------------------------------
*/
static void FreeAllNsfObjectsAndClasses(
Tcl_Interp *interp, NsfCmdList **instances
) nonnull(1) nonnull(2);
static void
FreeAllNsfObjectsAndClasses(
Tcl_Interp *interp, NsfCmdList **instances
) {
NsfCmdList *entry, *lastEntry;
int nrDeleted = 0;
nonnull_assert(interp != NULL);
nonnull_assert(instances != NULL);
/*fprintf(stderr, "FreeAllNsfObjectsAndClasses in %p\n", interp);*/
RUNTIME_STATE(interp)->exitHandlerDestroyRound = NSF_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 (entry = *instances; entry != NULL; entry = entry->nextPtr) {
NsfObject *object = (NsfObject *)entry->clorobj;
/*
* Delete per-object methods.
*/
if (object != NULL && object->nsPtr != NULL) {
const Tcl_HashEntry *hPtr;
Tcl_HashSearch hSrch;
for (hPtr = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(object->nsPtr), &hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
Tcl_Command cmd = Tcl_GetHashValue(hPtr);
if (cmd != NULL) {
if (CmdIsNsfObject(cmd)) {
AliasDeleteObjectReference(interp, cmd);
continue;
}
Tcl_DeleteCommandFromToken(interp, cmd);
nrDeleted ++;
}
}
}
/*
* Delete class methods; these methods might have aliases (dependencies) to
* objects, which will be resolved this way.
*/
if (object != NULL && NsfObjectIsClass(object)) {
const Tcl_HashEntry *hPtr;
Tcl_HashSearch hSrch;
for (hPtr = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(((NsfClass *)object)->nsPtr),
&hSrch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSrch)) {
Tcl_Command cmd = Tcl_GetHashValue(hPtr);
if ((cmd != NULL) && CmdIsNsfObject(cmd)) {
AliasDeleteObjectReference(interp, cmd);
continue;
}
}
}
}
/*fprintf(stderr, "deleted %d cmds\n", nrDeleted);*/
/*
* Finally delete the object/class tree in a bottom up manner,
* deleting 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.
*/
nrDeleted = 0;
for (entry = *instances, lastEntry = NULL;
entry != NULL;
lastEntry = entry, entry = entry->nextPtr) {
NsfObject *object = (NsfObject *)entry->clorobj;
/*
* The list of the instances should contain only alive objects, without
* duplicates. We would recognize duplicates since a deletion of one
* object would result in the CMD_DYING (previously, CMD_IS_DELETED)
* flag becoming set on the cmdPtr of the duplicate.
*/
assert(!TclIsCommandDeleted(entry->cmdPtr));
if (object != NULL && !NsfObjectIsClass(object) && !ObjectHasChildren(object)) {
/*fprintf(stderr, "check %p obj->flags %.6x cmd %p deleted %d\n",
object, object->flags, entry->cmdPtr,
TclIsCommandDeleted(entry->cmdPtr)); */
assert(object->id != NULL);
/*fprintf(stderr, " ... delete object %s %p, class=%s id %p ns %p\n",
ObjectName(object), object,
ClassName(object->cl), object->id, object->nsPtr);*/
FreeUnsetTraceVariable(interp, object);
FinalObjectDeletion(interp, object);
if (entry == *instances) {
*instances = entry->nextPtr;
CmdListDeleteCmdListEntry(entry, NULL);
entry = *instances;
} else {
lastEntry->nextPtr = entry->nextPtr;
CmdListDeleteCmdListEntry(entry, NULL);
entry = lastEntry;
}
assert(entry != NULL);
nrDeleted++;
}
}
/*fprintf(stderr, "deleted %d Objects without dependencies\n", nrDeleted);*/
if (nrDeleted > 0) {
continue;
}
/*
* Delete all classes without dependencies.
*/
for (entry = *instances, lastEntry = NULL;
entry != NULL;
(entry != NULL ? (lastEntry = entry, entry = entry->nextPtr) : NULL)) {
NsfClass *class = entry->clorobj;
assert(class != NULL);
if (!NsfObjectIsClass(&class->object)) {
continue;
}
/*fprintf(stderr, "### cl key = %s %p\n", ClassName(class), class); */
/*
* Remove manually mixinRegObjs to achieve correct deletion
* order. Otherwise, refcount checking for NsfObjects complains during
* shutdown (and dangling references would be a consequence).
*/
if (class->opt != NULL && class->opt->mixinRegObjs != NULL) {
NsfMixinregInvalidate(interp, class->opt->mixinRegObjs);
DECR_REF_COUNT2("mixinRegObjs", class->opt->mixinRegObjs);
class->opt->mixinRegObjs = NULL;
}
if (!ObjectHasChildren((NsfObject *)class)
&& !ClassHasInstances(class)
&& !ClassHasSubclasses(class)
&& !IsBaseClass(&class->object)
) {
/*fprintf(stderr, " ... delete class %s %p\n", ClassName(class), class); */
assert(class->object.id);
FreeUnsetTraceVariable(interp, &class->object);
FinalObjectDeletion(interp, &class->object);
if (entry == *instances) {
*instances = entry->nextPtr;
/*fprintf(stderr, "... delete first entry %p\n", entry);*/
CmdListDeleteCmdListEntry(entry, NULL);
entry = *instances;
} else {
/*fprintf(stderr, "... delete entry %p\n", entry);*/
lastEntry->nextPtr = entry->nextPtr;
CmdListDeleteCmdListEntry(entry, NULL);
entry = lastEntry;
}
nrDeleted++;
}
}
/*fprintf(stderr, "deleted %d Classes\n", nrDeleted);*/
if (nrDeleted == 0) {
int nrReclassed = 0;
/*
* Final check. If there are no cyclical dependencies, we should have
* now just the base classes left. If this is not the case, reclass
* the remaining objects to their base classes, and set the superClasses
* to the most general superclass.
*/
for (entry = *instances;
entry != NULL;
entry = entry->nextPtr) {
NsfObject *object = (NsfObject *)entry->clorobj;
NsfClass *baseClass;
NsfObjectSystem *osPtr;
if (NsfObjectIsClass(object) && IsBaseClass(object)) {
continue;
}
osPtr = GetObjectSystem(object);
/*
* For classes, check the superclass hierarchy.
*/
if (NsfObjectIsClass(object)) {
NsfClass *cl = (NsfClass *)object;
NsfClasses *sc;
for (sc = cl->super; sc != NULL; sc = sc->nextPtr) {
if (sc->cl != osPtr->rootClass) {
Tcl_Obj *objectName = osPtr->rootClass->object.cmdName;
SuperclassAdd(interp, cl, 1, &objectName, objectName);
nrReclassed ++;
break;
}
}
}
/*
* In all cases, straighten the class to the base case.
*/
baseClass = NsfObjectIsClass(object) ? osPtr->rootMetaClass : osPtr->rootClass;
if (object->cl != baseClass) {
ChangeClass(interp, object, baseClass);
nrReclassed ++;
}
}
/*fprintf(stderr, "We have reclassed %d objects\n", nrReclassed);*/
if (nrReclassed == 0) {
break;
}
}
}
}
#endif /* DO_CLEANUP */
/*
*----------------------------------------------------------------------
*
* ExitHandler --
*
* The exit handler is called on thread exit and application
* exit. It is responsible to free all resources to avoid memory
* leaks, especially in multi-threaded applications, when threads
* exit.
*
* Results:
* None.
*
* Side effects:
* Freeing memory.
*
*----------------------------------------------------------------------
*/
static void
ExitHandler(ClientData clientData) {
Tcl_Interp *interp = (Tcl_Interp *)clientData;
int flags;
NsfRuntimeState *rst;
nonnull_assert(clientData != NULL);
rst = RUNTIME_STATE(interp);
/*fprintf(stderr, "+++ (%lx) ExitHandler interp %p deleted %d exitHandlerDestroyRound %d\n",
(long)(void*)pthread_self(), interp, (Tcl_Interp_flags(interp) & DELETED),
rst->exitHandlerDestroyRound);*/
/*
* Don't use exit handler, if the interpreter is already 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 defined(NSF_MEM_COUNT)
/* The Tcl history list (which internally stores commands and scripts in the
* array ::tcl::history) can retain Tcl_Obj references beyond the scope of
* our shutdown procedures (::nsf::finalize, ExitHandler). Therefore, on
* MEM_COUNT_RELEASE(), we might see unbalanced refcounts which are false
* positives. Therefore, we aim at clearing the history list at this point.
*
* See also Tcl bug report 1ae12987cb.
*/
if (unlikely(Tcl_Eval(interp, "::history clear") != TCL_OK)) {
NsfLog(interp, NSF_LOG_WARN, "Clearing the Tcl history list failed! "
"Memcounts could be reported as unbalanced on MEM_COUNT_RELEASE(). "
"Error: %s\n",
ObjStr(Tcl_GetObjResult(interp)));
}
#endif
if (rst->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
NsfFinalizeCmd(interp, NSF_FALSE);
}
/*
* Must be before freeing of NsfGlobalObjs.
*/
NsfShadowTclCommands(interp, SHADOW_UNLOAD);
MEM_COUNT_FREE("Tcl_InitHashTable", &rst->activeFilterTablePtr);
Tcl_DeleteHashTable(&rst->activeFilterTablePtr);
/*
* Free "global" (per main interp) objects.
*/
{
int i;
for (i = 0; i < nr_elements(NsfGlobalStrings); i++) {
DECR_REF_COUNT(NsfGlobalObjs[i]);
}
}
NsfStringIncrFree(&rst->iss);
/*
* Free all data in the hash tables managing pointer converters,
* enumerations, and method definitions.
*/
Nsf_PointerExit(interp);
Nsf_EnumerationTypeRelease();
Nsf_CmdDefinitionRelease();
#if defined(NSF_PROFILE)
NsfProfileFree(interp);
#endif
FREE(Tcl_Obj**, NsfGlobalObjs);
#if defined(TCL_MEM_DEBUG)
TclDumpMemoryInfo((ClientData) stderr, 0);
Tcl_DumpActiveMemory("./nsfActiveMem");
/* Tcl_Eval(interp, "puts {checkmem to checkmemFile};
checkmem checkmemFile"); */
#endif
/*
* Free run time state.
*/
/*fprintf(stderr, "+++ ExiHandler frees run time state of interp %p\n", interp);*/
ckfree((char *) rst);
#if defined(USE_ASSOC_DATA)
Tcl_DeleteAssocData(interp, "NsfRuntimeState");
#else
Tcl_Interp_globalNsPtr(interp)->clientData = NULL;
#endif
#if defined(NSF_MEM_COUNT) && !defined(PRE86)
/*
* When raising an error, the Tcl_Objs on the error stack and in the
* inner context are refCount-incremented. When Tcl exits, it does normally
* not perform the according decrementing. We perform here a manual
* decrementing and reset these lists.
*/
{
Interp *iPtr = (Interp *) interp;
if (iPtr->innerContext != NULL) {
Tcl_DecrRefCount(iPtr->errorStack);
iPtr->errorStack = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->innerContext);
iPtr->innerContext = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(iPtr->innerContext);
}
}
#endif
Tcl_Interp_flags(interp) = flags;
Tcl_Release(interp);
MEM_COUNT_RELEASE();
}
#if defined(TCL_THREADS)
/*
* Gets activated at thread-exit
*/
static void
Nsf_ThreadExitProc(ClientData clientData) {
nonnull_assert(clientData != NULL);
/*fprintf(stderr, "+++ (%lx) Nsf_ThreadExitProc %p\n", (long)(void*)pthread_self(), clientData);*/
Tcl_DeleteThreadExitHandler(Nsf_ThreadExitProc, clientData);
Tcl_DeleteExitHandler(Nsf_ExitProc, clientData);
ExitHandler(clientData);
}
#endif
/*
* Gets activated at application-exit
*/
static void
Nsf_ExitProc(ClientData clientData) {
nonnull_assert(clientData != NULL);
/*fprintf(stderr, "+++ (%lx) Nsf_ExitProc %p\n", (long)(void*)pthread_self(), clientData);*/
#if defined(TCL_THREADS)
Tcl_DeleteExitHandler(Nsf_ExitProc, clientData);
Tcl_DeleteThreadExitHandler(Nsf_ThreadExitProc, clientData);
#endif
ExitHandler(clientData);
}
/*
* Registers thread/application exit handlers.
*/
static void RegisterExitHandlers(ClientData clientData)
nonnull(1);
static void
RegisterExitHandlers(ClientData clientData) {
nonnull_assert(clientData != NULL);
Tcl_Preserve(clientData);
#if defined(TCL_THREADS)
Tcl_CreateThreadExitHandler(Nsf_ThreadExitProc, clientData);
#endif
Tcl_CreateExitHandler(Nsf_ExitProc, clientData);
}
/*
* Tcl extension initialization routine
*/
#if 0
#include
#endif
int
Nsf_Init(
Tcl_Interp *interp
) {
static NsfMutex initMutex = 0;
ClientData runtimeState;
NsfRuntimeState *rst;
int result, i;
Tcl_Obj *tmpObj;
#ifdef NSF_BYTECODE
/*NsfCompEnv *interpstructions = NsfGetCompEnv();*/
#endif
#ifdef USE_TCL_STUBS
static int stubsInitialized = 0;
#endif
nonnull_assert(interp != NULL);
#if 0
ProfilerStart("profiler");
#endif
#ifdef USE_TCL_STUBS
/*
* Since the stub-tables are initialized globally (not per interp), we want
* to initialize these only once. The read operation on "stubsInitialized"
* is a potentially dirty read. However, we can't use a mutex lock around
* this, since Tcl_MutexLock() requires (at least on some platforms)
* initialized stub-tables. The dirty read of stubsInitialized is not so
* invasive as the dirty reads caused by overwriting the stub tables.
*
* NsfMutexLock(&stubFlagMutex);
* ...
* NsfMutexUnlock(&stubFlagMutex);
*/
if (stubsInitialized == 0) {
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
# if TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
/* Tcl_TomMath_InitStubs() not needed */
# else
if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
return TCL_ERROR;
}
# endif
stubsInitialized = 1;
}
#endif
#if defined(TCL_MEM_DEBUG)
TclDumpMemoryInfo((ClientData) stderr, 0);
#endif
/*
* Runtime State stored in the client data of the Interp's global namespace
* in order to avoid global state information. All fields are per default
* set to zero.
*/
runtimeState = ckalloc((int)sizeof(NsfRuntimeState));
memset(runtimeState, 0, sizeof(NsfRuntimeState));
#if defined(USE_ASSOC_DATA)
Tcl_SetAssocData(interp, "NsfRuntimeState", NULL, runtimeState);
#else
Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState;
#endif
/*
* If MEM_COUNT is activated, the tables have to be initialized before the
* first call to the MEM_COUNT macros (including e.g. INCR_REF_COUNT), but
* it requires that the runtimeState is already associated with the interp.
*/
MEM_COUNT_INIT();
/*
* Init global variables for Tcl_Obj types.
*/
NsfMutexLock(&initMutex);
Nsf_OT_byteCodeType = Tcl_GetObjType("bytecode");
assert(Nsf_OT_byteCodeType != NULL);
Nsf_OT_tclCmdNameType = Tcl_GetObjType("cmdName");
assert(Nsf_OT_tclCmdNameType != NULL);
Nsf_OT_listType = Tcl_GetObjType("list");
assert(Nsf_OT_listType != NULL);
Nsf_OT_doubleType = Tcl_GetObjType("double");
assert(Nsf_OT_doubleType != NULL);
/*
* Type "int" and "wideInt" are a moving target in Tcl 8.7a+. So, get the
* type from the Tcl_Obj directly, which will continue to work.
*/
tmpObj = Tcl_NewIntObj(0);
Nsf_OT_intType = tmpObj->typePtr;
Tcl_DecrRefCount(tmpObj);
assert(Nsf_OT_intType != NULL);
{
mp_int bignumValue;
Tcl_Obj *bigNumObj;
tmpObj = Tcl_NewStringObj("10000000000000000000000", TCL_INDEX_NONE);
Tcl_GetBignumFromObj(NULL, tmpObj, &bignumValue);
Nsf_OT_bignumType = tmpObj->typePtr;
assert(Nsf_OT_bignumType != NULL);
/* Make sure mp_int is actually cleared (w/o using mp_clear). */
bigNumObj = Tcl_NewBignumObj(&bignumValue);
Tcl_DecrRefCount(bigNumObj);
Tcl_DecrRefCount(tmpObj);
}
/*
* Get bytearray and proper bytearray from Tcl (latter if available,
* introduced in Tcl 8.7a+)
*/
Nsf_OT_byteArrayType = Tcl_GetObjType("bytearray");
tmpObj = Tcl_NewByteArrayObj(NULL, 0);
Nsf_OT_properByteArrayType = tmpObj->typePtr;
if (Nsf_OT_byteArrayType == NULL) {
Nsf_OT_byteArrayType = Nsf_OT_properByteArrayType;
}
if (Nsf_OT_properByteArrayType == Nsf_OT_byteArrayType) {
/*
* When both values are the same, we are in a Tcl version before 8.7,
* where we have no properByteArrayTypePtr. So set it to an invalid
* value to avoid potential confusions. Without this stunt, we would
* need several ifdefs.
*/
Nsf_OT_properByteArrayType = (Tcl_ObjType *)0xffffff;
}
Tcl_DecrRefCount(tmpObj);
assert(Nsf_OT_properByteArrayType != NULL);
assert(Nsf_OT_byteArrayType != NULL);
NsfMutexUnlock(&initMutex);
/*
* Initialize the pointer converter, the enumeration types and cmd
* definitions tables and load it with the generated information for
* introspection.
*/
Nsf_PointerInit();
Nsf_EnumerationTypeInit();
result = Nsf_EnumerationTypeRegister(interp, enumeratorConverterEntries);
if (unlikely(result != TCL_OK)) {
return result;
}
Nsf_CmdDefinitionInit();
Nsf_CmdDefinitionRegister(interp, method_definitions);
/*
fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n",
sizeof(NsfObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(NsfClass),
sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable));
*/
#if defined(NSF_PROFILE)
NsfProfileInit(interp);
#endif
rst = RUNTIME_STATE(interp);
rst->logSeverity = NSF_LOG_NOTICE;
rst->doFilters = 1;
rst->doCheckResults = 1;
rst->doCheckArguments = NSF_ARGPARSE_CHECK;
NsfDListInit(&rst->freeDList);
#if defined(NSF_STACKCHECK)
{ int someVar;
/*
* Note that Nsf_Init() is called typically via a package require, which
* is therefore not really the bottom of the stack, but just a first
* approximation.
*/
rst->bottomOfStack = &someVar;
rst->maxStack = rst->bottomOfStack;
}
#endif
/*
* Check whether the namespace exists, otherwise create it.
*/
rst->NsfNS = Tcl_FindNamespace(interp, "::nsf", NULL, TCL_GLOBAL_ONLY);
if (rst->NsfNS == NULL) {
rst->NsfNS = Tcl_CreateNamespace(interp, "::nsf", NULL,
(Tcl_NamespaceDeleteProc *)NULL);
}
MEM_COUNT_ALLOC("TclNamespace", rst->NsfNS);
/*
* Init an empty, faked proc structure in the RUNTIME state.
*/
rst->fakeProc.iPtr = (Interp *)interp;
rst->fakeProc.refCount = 1;
rst->fakeProc.cmdPtr = NULL;
rst->fakeProc.bodyPtr = NULL;
rst->fakeProc.numArgs = 0;
rst->fakeProc.numCompiledLocals = 0;
rst->fakeProc.firstLocalPtr = NULL;
rst->fakeProc.lastLocalPtr = NULL;
/*
* NsfClasses in separate Namespace / Objects
*/
rst->NsfClassesNS =
Tcl_CreateNamespace(interp, nsfClassesPrefix, NULL,
(Tcl_NamespaceDeleteProc *)NULL);
#if !defined(PRE86)
((Namespace *)rst->NsfClassesNS)->flags |= NS_SUPPRESS_COMPILATION;
#endif
MEM_COUNT_ALLOC("TclNamespace", rst->NsfClassesNS);
/*
* Cache interpreters proc interpretation functions
*/
rst->objInterpProc = TclGetObjInterpProc();
rst->exitHandlerDestroyRound = NSF_EXITHANDLER_OFF;
RegisterExitHandlers(interp);
NsfStringIncrInit(&RUNTIME_STATE(interp)->iss);
/*
* initialize global Tcl_Obj
*/
NsfGlobalObjs = NEW_ARRAY(Tcl_Obj*, nr_elements(NsfGlobalStrings));
for (i = 0; i < nr_elements(NsfGlobalStrings); i++) {
NsfGlobalObjs[i] = Tcl_NewStringObj(NsfGlobalStrings[i], TCL_INDEX_NONE);
INCR_REF_COUNT(NsfGlobalObjs[i]);
}
Tcl_InitHashTable(&rst->activeFilterTablePtr, TCL_STRING_KEYS);
MEM_COUNT_ALLOC("Tcl_InitHashTable", &rst->activeFilterTablePtr);
/*
* 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);
}
/*
* Create Shadowed Tcl cmds:
*/
result = NsfShadowTclCommands(interp, SHADOW_LOAD);
if (unlikely(result != TCL_OK)) {
return result;
}
/*
* Create new Tcl cmds:
*/
#ifdef NSF_BYTECODE
instructions[INST_NEXT].cmdPtr = (Command *)
#endif
TCL_CREATEOBJCOMMAND(interp, "::nsf::xotclnext", NsfNextObjCmd, 0, 0);
#ifdef NSF_BYTECODE
instructions[INST_SELF].cmdPtr =
(Command *)Tcl_FindCommand(interp, "::nsf::current", NULL, TCL_GLOBAL_ONLY);
#endif
/*TCL_CREATEOBJCOMMAND(interp, "::nsf::K", NsfKObjCmd, 0, 0);*/
#ifdef NSF_BYTECODE
NsfBytecodeInit();
#endif
NsfInitPkgConfig(interp);
Tcl_AddInterpResolvers(interp, "nsf",
(Tcl_ResolveCmdProc *)InterpColonCmdResolver,
InterpColonVarResolver,
(Tcl_ResolveCompiledVarProc *)InterpCompiledColonVarResolver);
rst->colonCmd = Tcl_FindCommand(interp, "::nsf::colon", NULL, TCL_GLOBAL_ONLY);
/*
* Tcl occasionally resolves a proc's cmd structure (e.g., in
* [info frame /number/] or TclInfoFrame()) without
* verification. However, NSF non-proc frames, in particular
* initcmd blocks, point to the fakeProc structure which does not
* contain an initialized Command pointer. For now, we default to
* an internal command. However, we might have to revisit this decision
* as non-proc frames (e.g., initcmds) report a "proc" entry
* for c-based functions with a proc scope, such as "::nsf::colon"),
* which can lead to confusions. "proc" does not mean "tcp proc",
* but an entry with a proc frame for local vars.
*/
rst->fakeProc.cmdPtr = (Command *)RUNTIME_STATE(interp)->colonCmd;
{
/*
* The file "predefined.h" contains some methods and library procs
* implemented in Tcl - they could go in .tcl file, but they are embedded
* here with Tcl_Eval to avoid the need to carry around a separate file at
* run time.
*/
#include "predefined.h"
/* fprintf(stderr, "predefined=<<%s>>\n", cmd);*/
if (
(Tcl_Eval(interp, predefined_part1) != TCL_OK)
|| (Tcl_Eval(interp, predefined_part2) != TCL_OK)
) {
static char reportingCmd[] =
"puts stderr \"Error in predefined code\n\
$::errorInfo\"";
Tcl_EvalEx(interp, reportingCmd, TCL_INDEX_NONE, 0);
return TCL_ERROR;
}
}
#ifndef AOL_SERVER
/*
* The AOL server uses a different package loading mechanism.
*/
# ifdef COMPILE_NSF_STUBS
Tcl_PkgProvideEx(interp, "nsf", PACKAGE_VERSION, &nsfStubs);
# else
Tcl_PkgProvide(interp, "nsf", PACKAGE_VERSION);
# endif
#endif
/*
* Obtain type for parsed var name.
*/
if (Nsf_OT_parsedVarNameType == NULL) {
Tcl_Obj *varNameObj = Tcl_NewStringObj("::nsf::version", TCL_INDEX_NONE);
Var *arrayPtr;
INCR_REF_COUNT(varNameObj);
TclObjLookupVar(interp, varNameObj, NULL, 0, "access",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
Nsf_OT_parsedVarNameType = varNameObj->typePtr;
assert(Nsf_OT_parsedVarNameType != NULL);
DECR_REF_COUNT(varNameObj);
}
#if !defined(TCL_THREADS)
if ((Tcl_GetVar2(interp, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) {
/*
* A non-threaded version of NSF is loaded into a threaded environment.
*/
fprintf(stderr, "\n A non threaded version of the Next Scripting Framework "
"is loaded into threaded environment.\n"
"Please reconfigure nsf with --enable-threads!\n\n\n");
}
#endif
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
EXTERN int
Nsf_SafeInit(Tcl_Interp *interp) {
nonnull_assert(interp != NULL);
/*** dummy for now **/
return Nsf_Init(interp);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 2
* fill-column: 78
* indent-tabs-mode: nil
* eval: (c-guess)
* End:
*/