1 /*
2  *  nsf.c --
3  *
4  *      Basic Machinery of the Next Scripting Framework, a Tcl-based framework
5  *      for supporting language-oriented programming.  For details, see
6  *      https://next-scripting.org/.
7  *
8  * Copyright (C) 1999-2019 Gustaf Neumann (a) (b)
9  * Copyright (C) 1999-2007 Uwe Zdun (a) (b)
10  * Copyright (C) 2007-2008 Martin Matuska (b)
11  * Copyright (C) 2010-2019 Stefan Sobernig (b)
12  *
13  *
14  * (a) University of Essen
15  *     Specification of Software Systems
16  *     Altendorferstrasse 97-101
17  *     D-45143 Essen, Germany
18  *
19  * (b) Vienna University of Economics and Business
20  *     Institute of Information Systems and New Media
21  *     A-1020, Welthandelsplatz 1
22  *     Vienna, Austria
23  *
24  * This work is licensed under the MIT License
25  * https://www.opensource.org/licenses/MIT
26  *
27  * Copyright:
28  *
29  * Permission is hereby granted, free of charge, to any person obtaining a
30  * copy of this software and associated documentation files (the "Software"),
31  * to deal in the Software without restriction, including without limitation
32  * the rights to use, copy, modify, merge, publish, distribute, sublicense,
33  * and/or sell copies of the Software, and to permit persons to whom the
34  * Software is furnished to do so, subject to the following conditions:
35  *
36  * The above copyright notice and this permission notice shall be included in
37  * all copies or substantial portions of the Software.
38  *
39  * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
40  * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
41  * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
42  * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
43  * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
44  * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
45  * DEALINGS IN THE SOFTWARE.
46  *
47  *
48  *  This software is based upon MIT Object Tcl by David Wetherall and
49  *  Christopher J. Lindblad, that contains the following copyright
50  *  message:
51  *
52  *   "Copyright 1993 Massachusetts Institute of Technology
53  *
54  *    Permission to use, copy, modify, distribute, and sell this
55  *    software and its documentation for any purpose is hereby granted
56  *    without fee, provided that the above copyright notice appear in
57  *    all copies and that both that copyright notice and this
58  *    permission notice appear in supporting documentation, and that
59  *    the name of M.I.T. not be used in advertising or publicity
60  *    pertaining to distribution of the software without specific,
61  *    written prior permission.  M.I.T. makes no representations about
62  *    the suitability of this software for any purpose.  It is
63  *    provided "as is" without express or implied warranty."
64  */
65 
66 #define NSF_FORWARD_WITH_ONERROR 1
67 
68 #define NSF_C 1
69 #include "nsfInt.h"
70 #include "nsfAccessInt.h"
71 
72 #ifdef COMPILE_NSF_STUBS
73 # if defined(PRE86)
74 EXTERN NsfStubs nsfStubs;
75 # else
76 MODULE_SCOPE const NsfStubs nsfStubs;
77 # endif
78 #endif
79 
80 #ifdef USE_TCL_STUBS
81 # define Nsf_ExprObjCmd(clientData, interp, objc, objv)        \
82   NsfCallCommand(interp, NSF_EXPR, objc, objv)
83 #else
84 # define Nsf_ExprObjCmd(clientData, interp, objc, objv)        \
85   Tcl_ExprObjCmd(clientData, interp, objc, objv)
86 #endif
87 
88 /*
89  * Call Stack specific definitions
90  */
91 
92 typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel;
93 
94 typedef struct callFrameContext {
95   Tcl_CallFrame *framePtr;
96   Tcl_CallFrame *varFramePtr;
97   bool           frameSaved;
98 } callFrameContext;
99 
100 /* #define COLON_CMD_STATS 1 */
101 
102 typedef struct {
103   void        *context;
104   Tcl_Command  cmd;
105   NsfClass    *class;
106   unsigned int methodEpoch;
107   unsigned int flags;
108 #if defined(COLON_CMD_STATS)
109   size_t       hits;
110   size_t       invalidates;
111   size_t       requiredRefetches;
112   Tcl_Obj     *obj;
113 #endif
114 } NsfColonCmdContext;
115 
116 typedef struct NsfProcContext {
117   ClientData          oldDeleteData;
118   Tcl_CmdDeleteProc  *oldDeleteProc;
119   NsfParamDefs       *paramDefs;
120   int                *colonLocalVarCache;
121   unsigned int        checkAlwaysFlag;
122   Tcl_Namespace      *execNsPtr;
123   Tcl_Obj            *returnsObj;
124 } NsfProcContext;
125 
126 /*
127  * TclCmdClientdata is an incomplete type containing the common
128  * field(s) of ForwardCmdClientData, AliasCmdClientData and
129  * SetterCmdClientData used for filling in at runtime the actual
130  * object.
131  */
132 typedef struct TclCmdClientData {
133   NsfObject *object;
134 } TclCmdClientData;
135 
136 typedef struct SetterCmdClientData {
137   NsfObject *object;
138   Nsf_Param *paramsPtr;
139 } SetterCmdClientData;
140 
141 typedef struct ForwardCmdClientData {
142   NsfObject      *object;
143   Tcl_Obj        *cmdName;
144   Tcl_ObjCmdProc *objProc;
145   ClientData      clientData;
146   bool            passthrough;
147   bool            needobjmap;
148   bool            verbose;
149   bool            hasNonposArgs;
150   Tcl_Obj        *args;
151   int             nr_args;
152   int             frame;
153 #if defined(NSF_FORWARD_WITH_ONERROR)
154   Tcl_Obj        *onerror;
155 #endif
156   Tcl_Obj        *prefix;
157   Tcl_Obj        *subcommands;
158   int             nr_subcommands;
159 } ForwardCmdClientData;
160 
161 typedef struct AliasCmdClientData {
162   NsfObject      *object;
163   Tcl_Obj        *cmdName;
164   Tcl_ObjCmdProc *objProc;
165   ClientData      clientData;
166   NsfClass       *class;
167   Tcl_Interp     *interp;
168   Tcl_Command     aliasedCmd;
169   Tcl_Command     aliasCmd;
170 } AliasCmdClientData;
171 
172 /*
173  * When NSF_MEM_COUNT is set, we want to trace as well the mem-count frees
174  * associated with the interp. Therefore, we need in this case a special
175  * client data structure.
176  */
177 #ifdef NSF_MEM_COUNT
178 typedef struct NsfNamespaceClientData {
179   NsfObject     *object;
180   Tcl_Namespace *nsPtr;
181   Tcl_Interp    *interp;
182 } NsfNamespaceClientData;
183 #endif
184 
185 /*
186  * Argv parsing specific definitions
187  */
188 
189 #define PARSE_CONTEXT_PREALLOC 20
190 typedef struct {
191   ClientData   *clientData;   /* 4 members pointer to the actual parse context data */
192   Tcl_Obj     **objv;
193   Tcl_Obj     **full_objv;    /* contains method as well */
194   unsigned int *flags;
195   ClientData    clientData_static[PARSE_CONTEXT_PREALLOC]; /* 3 preallocated parse context data */
196   Tcl_Obj      *objv_static[PARSE_CONTEXT_PREALLOC+1];
197   unsigned int  flags_static[PARSE_CONTEXT_PREALLOC+1];
198   unsigned int  status;
199   int           lastObjc;     /* points to the first "unprocessed" argument */
200   int           objc;
201   NsfObject    *object;
202   bool          varArgs;      /* does the parameter end with some kind of "args" */
203 } ParseContext;
204 
205 static Nsf_TypeConverter ConvertToNothing, ConvertViaCmd, ConvertToObjpattern;
206 
207 static const char  *autonamePrefix = "::nsf::__#";
208 static const size_t autonamePrefixLength = 10u;
209 static const char * nsfClassesPrefix = "::nsf::classes";
210 static const size_t nsfClassesPrefixLength = 14u;
211 /*
212  * Tcl_Obj Types for Next Scripting Objects
213  */
214 
215 static Tcl_ObjType CONST86
216   *Nsf_OT_byteCodeType = NULL,
217   *Nsf_OT_tclCmdNameType = NULL,
218   *Nsf_OT_listType = NULL,
219   *Nsf_OT_doubleType = NULL,
220   *Nsf_OT_intType = NULL,
221   *Nsf_OT_parsedVarNameType = NULL,
222   *Nsf_OT_byteArrayType = NULL,
223   *Nsf_OT_properByteArrayType = NULL;
224 
225 /*
226  * Function prototypes
227  */
228 
229 /*
230  * Prototypes for method definitions
231  */
232 static Tcl_ObjCmdProc NsfForwardMethod;
233 static Tcl_ObjCmdProc NsfObjscopedMethod;
234 static Tcl_ObjCmdProc NsfSetterMethod;
235 static Tcl_ObjCmdProc NsfProcAliasMethod;
236 static Tcl_ObjCmdProc NsfAsmProc;
237 Tcl_ObjCmdProc NsfProcStub;
238 
239 /*
240  * Prototypes for interpreter life-cyle
241  */
242 EXTERN Tcl_PackageInitProc Nsf_SafeInit;
243 EXTERN Tcl_PackageInitProc Nsf_Init;
244 static Tcl_ExitProc Nsf_ExitProc;
245 static Tcl_ExitProc Nsf_ThreadExitProc;
246 static Tcl_ExitProc ExitHandler;
247 
248 /*
249  * Prototypes for methods called directly when CallDirectly() returns NULL
250  */
251 static int NsfCAllocMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj)
252   nonnull(1) nonnull(2);
253 static int NsfCAllocMethod_(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr)
254   nonnull(1) nonnull(2) nonnull(3);
255 static int NsfCCreateMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, int objc, Tcl_Obj *const objv[])
256   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
257 static int NsfOCleanupMethod(Tcl_Interp *interp, NsfObject *object)
258   nonnull(1) nonnull(2);
259 static int NsfOConfigureMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[], Tcl_Obj *objv0)
260   nonnull(1) nonnull(2) nonnull(4) nonnull(5);
261 static int NsfODestroyMethod(Tcl_Interp *interp, NsfObject *object)
262   nonnull(1) nonnull(2);
263 static int MethodDispatch(
264     Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
265     Tcl_Command cmd, NsfObject *object, NsfClass *class,
266     const char *methodName, unsigned short frameType, unsigned int flags
267 ) nonnull(1) nonnull(3) nonnull(4) nonnull(5) nonnull(7);
268 static int DispatchDefaultMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *obj, unsigned int flags)
269   nonnull(1) nonnull(2) nonnull(3);
270 static int DispatchDestroyMethod(Tcl_Interp *interp, NsfObject *object, unsigned int flags)
271   nonnull(1) nonnull(2);
272 static int DispatchUnknownMethod(
273     Tcl_Interp *interp, NsfObject *object,
274     int objc, Tcl_Obj *const objv[], Tcl_Obj *callInfoObj,
275     Tcl_Obj *methodObj, unsigned int flags
276 ) nonnull(1) nonnull(2) nonnull(4) nonnull(6);
277 
278 NSF_INLINE static int ObjectDispatch(
279     ClientData clientData, Tcl_Interp *interp, int objc,
280     Tcl_Obj *const objv[], unsigned int flags
281 ) nonnull(1) nonnull(2) nonnull(4);
282 
283 NSF_INLINE static int ObjectDispatchFinalize(
284     Tcl_Interp *interp, NsfCallStackContent *cscPtr,
285     int result /*, const char *string , const char *methodName*/
286 ) nonnull(1) nonnull(2);
287 
288 /*
289  * Prototypes for object life-cycle management
290  */
291 static int RecreateObject(Tcl_Interp *interp, NsfClass *class, NsfObject *object, int objc, Tcl_Obj *const objv[])
292   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
293 static void FinalObjectDeletion(Tcl_Interp *interp, NsfObject *object)
294   nonnull(1) nonnull(2);
295 
296 #if defined(DO_CLEANUP)
297 static void FreeAllNsfObjectsAndClasses(Tcl_Interp *interp,  NsfCmdList **instances)
298   nonnull(1) nonnull(2);
299 #endif
300 static void CallStackDestroyObject(Tcl_Interp *interp, NsfObject *object)
301   nonnull(1) nonnull(2);
302 static void PrimitiveCDestroy(ClientData clientData)
303   nonnull(1);
304 static void PrimitiveODestroy(ClientData clientData)
305   nonnull(1);
306 static void PrimitiveDestroy(ClientData clientData)
307   nonnull(1);
308 
309 static int VolatileMethod(Tcl_Interp *interp, NsfObject *object, bool shallow)
310   nonnull(1) nonnull(2);
311 
312 /*
313  * Prototypes for object and command lookup
314  */
315 static NsfObject *GetObjectFromString(Tcl_Interp *interp, const char *name)
316   nonnull(1) nonnull(2);
317 static NsfClass *GetClassFromString(Tcl_Interp *interp, const char *name)
318   nonnull(1) nonnull(2);
319 static int GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, NsfClass **classPtr, bool withUnknown)
320   nonnull(1) nonnull(2) nonnull(3);
321 static void GetAllInstances(Tcl_Interp *interp, NsfCmdList **instances, NsfClass *startClass)
322   nonnull(1) nonnull(2) nonnull(3);
323 NSF_INLINE static Tcl_Command FindMethod(
324     const Tcl_Namespace *nsPtr,
325     const char *methodName
326 ) nonnull(1) nonnull(2);
327 NSF_INLINE static NsfClasses *PrecedenceOrder(
328     NsfClass *class
329 ) nonnull(1);
330 
331 
332 /*
333  * Prototypes for namespace specific calls
334  */
335 static Tcl_Obj *NameInNamespaceObj(const char *name, Tcl_Namespace *nsPtr)
336   nonnull(1) nonnull(2);
337 static Tcl_Namespace *CallingNameSpace(Tcl_Interp *interp)
338   nonnull(1) returns_nonnull;
339 NSF_INLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, const char *name)
340   nonnull(1) nonnull(2);
341 static Tcl_Namespace *NSGetFreshNamespace(Tcl_Interp *interp, NsfObject *object, const char *name)
342   nonnull(1) nonnull(2) nonnull(3);
343 static Tcl_Namespace *RequireObjNamespace(Tcl_Interp *interp, NsfObject *object)
344   nonnull(1) nonnull(2);
345 static int NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *methodName)
346   nonnull(1) nonnull(2) nonnull(3);
347 static void NSNamespaceDeleteProc(ClientData clientData)
348   nonnull(1);
349 static void NSNamespacePreserve(Tcl_Namespace *nsPtr)
350   nonnull(1);
351 static void NSNamespaceRelease(Tcl_Namespace *nsPtr)
352   nonnull(1);
353 
354 /*
355  * Prototypes for filters and mixins
356  */
357 static void FilterComputeDefined(Tcl_Interp *interp, NsfObject *object)
358   nonnull(1) nonnull(2);
359 static void MixinComputeDefined(Tcl_Interp *interp, NsfObject *object)
360   nonnull(1) nonnull(2);
361 NSF_INLINE static void GuardAdd(NsfCmdList *guardList, Tcl_Obj *guardObj)
362   nonnull(1) nonnull(2);
363 static int GuardCall(NsfObject *object, Tcl_Interp *interp,
364                      Tcl_Obj *guardObj, NsfCallStackContent *cscPtr)
365   nonnull(1) nonnull(2) nonnull(3);
366 static void GuardDel(NsfCmdList *guardList)
367   nonnull(1);
368 
369 /*
370  * Prototypes for forwarders
371  */
372 static void ForwardCmdDeleteProc(ClientData clientData)
373   nonnull(1);
374 static int ForwardProcessOptions(
375     Tcl_Interp *interp, Tcl_Obj *nameObj,
376     Tcl_Obj *withDefault, int withEarlybinding,
377     Tcl_Obj *withOnerror, Tcl_Obj *withMethodprefix,
378     int withFrame, bool withVerbose,
379     Tcl_Obj *target, int objc, Tcl_Obj * const objv[],
380     ForwardCmdClientData **tcdPtr
381 ) nonnull(1) nonnull(2) nonnull(11);
382 
383 /*
384  * Properties of objects and classes
385  */
386 static bool IsRootClass(
387     const NsfClass *class
388 ) nonnull(1) pure;
389 
390 static bool IsRootMetaClass(
391     const NsfClass *class
392 ) nonnull(1) pure;
393 
394 static bool IsBaseClass(
395     const NsfObject *object
396 ) nonnull(1) pure;
397 
398 static bool IsMetaClass(
399     Tcl_Interp *interp, NsfClass *class, bool withMixins
400 ) nonnull(1) nonnull(2);
401 
402 static bool IsSubType(
403     NsfClass *subClass, const NsfClass *class
404 ) nonnull(1) nonnull(2);
405 
406 static NsfClass *DefaultSuperClass(
407     Tcl_Interp *interp, const NsfClass *class, const NsfClass *metaClass, bool isMeta
408 ) nonnull(1) nonnull(2) nonnull(3);
409 
410 
411 /*
412  * Prototypes for call stack specific calls
413  */
414 NSF_INLINE static void CscInit_(
415     NsfCallStackContent *cscPtr,
416     NsfObject *object,
417     NsfClass *class,
418     const Tcl_Command cmd,
419     unsigned short frameType,
420     unsigned int flags
421 ) nonnull(1) nonnull(2);
422 
423 NSF_INLINE static void CscFinish_(Tcl_Interp *interp, NsfCallStackContent *cscPtr)
424   nonnull(1) nonnull(2);
425 NSF_INLINE static void CallStackDoDestroy(Tcl_Interp *interp, NsfObject *object)
426   nonnull(1) nonnull(2);
427 static void NsfShowStack(Tcl_Interp *interp)
428   nonnull(1);
429 
430 /*
431  * Prototypes for parameter and argument management
432  */
433 static int NsfParameterCacheClassInvalidateCmd(Tcl_Interp *interp, NsfClass *class)
434   nonnull(1) nonnull(2);
435 static int ProcessMethodArguments(
436     ParseContext *pcPtr,
437     Tcl_Interp *interp,
438     NsfObject *object,
439     unsigned int processFlags,
440     NsfParamDefs *paramDefs,
441     Tcl_Obj *methodNameObj,
442     int objc, Tcl_Obj *const objv[]
443 ) nonnull(1) nonnull(2) nonnull(5) nonnull(6) nonnull(8);
444 
445 static int ParameterCheck(
446     Tcl_Interp *interp, Tcl_Obj *paramObjPtr, Tcl_Obj *valueObj,
447     const char *argNamePrefix,
448     unsigned int doCheckArguments,
449     bool isNamed,
450     bool doConfigureParameter,
451     Nsf_Param **paramPtrPtr,
452     const char *qualifier
453 ) nonnull(1) nonnull(2) nonnull(3);
454 
455 static void ParamDefsRefCountIncr(NsfParamDefs *paramDefs)
456   nonnull(1);
457 
458 static void ParamDefsRefCountDecr(
459     NsfParamDefs *paramDefs
460 ) nonnull(1);
461 
462 static void ParsedParamFree(
463     NsfParsedParam *parsedParamPtr
464 ) nonnull(1);
465 
466 NSF_INLINE static NsfParamDefs *ParamDefsGet(
467     const Tcl_Command cmdPtr,
468     unsigned int *checkAlwaysFlagPtr,
469     Tcl_Namespace **execNsPtrPtr
470 ) nonnull(1);
471 
472 NSF_INLINE static NsfProcContext *ProcContextGet(
473     const Tcl_Command cmdPtr
474 ) nonnull(1) pure;
475 
476 static NsfProcContext *ProcContextRequire(
477     Tcl_Command cmd
478 ) nonnull(1);
479 
480 static int ArgumentParse(
481     Tcl_Interp *interp,
482     int objc, Tcl_Obj *const objv[],
483     NsfObject *object,
484     Tcl_Obj *procNameObj,
485     const Nsf_Param *paramPtr,
486     int nrParams,
487     int serial,
488     unsigned int processFlags,
489     ParseContext *pcPtr
490 ) nonnull(1) nonnull(3) nonnull(5) nonnull(6) nonnull(10);
491 
492 static int ArgumentCheck(
493     Tcl_Interp *interp, Tcl_Obj *objPtr, const struct Nsf_Param *pPtr,
494     unsigned int doCheckArguments,
495     unsigned int *flags, ClientData *clientData, Tcl_Obj **outObjPtr
496 ) nonnull(1) nonnull(2) nonnull(3) nonnull(5) nonnull(6) nonnull(7);
497 
498 static int GetMatchObject(
499     Tcl_Interp *interp, Tcl_Obj *patternObj, Tcl_Obj *origObj,
500     NsfObject **matchObjectPtr, const char **patternPtr
501 ) nonnull(1) nonnull(4) nonnull(5);
502 
503 static void NsfProcDeleteProc(ClientData clientData)
504   nonnull(1);
505 
506 static int NsfParameterCacheObjectInvalidateCmd(
507     Tcl_Interp *interp, NsfObject *object
508 ) nonnull(1) nonnull(2);
509 
510 static int GetObjectParameterDefinition(
511     Tcl_Interp *interp, Tcl_Obj *procNameObj,
512     NsfObject *object, NsfClass *class,
513     NsfParsedParam *parsedParamPtr
514 ) nonnull(1) nonnull(2) nonnull(5);
515 
516 typedef Tcl_Obj *(NsfFormatFunction)(
517     Tcl_Interp *interp, const Nsf_Param *paramsPtr,
518     NsfObject *contextObject, const char *pattern
519 );
520 
521 static Tcl_Obj *NsfParamDefsVirtualFormat(
522     Tcl_Interp *interp, const Nsf_Param *pPtr,
523     NsfObject *contextObject, const char *pattern,
524     NsfFormatFunction formatFunction
525 ) nonnull(1) nonnull(2) nonnull(3) nonnull(5);
526 
527 static bool NsfParamDefsAppendVirtual(
528     Tcl_Interp *interp, Tcl_Obj *listObj,
529     const Nsf_Param *paramsPtr,
530     NsfObject *contextObject,
531     const char *pattern,
532     NsfFormatFunction formatFunction
533 ) nonnull(1) nonnull(2) nonnull(3) nonnull(6);
534 
535 /*
536  * Prototypes for alias management
537  */
538 static int AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object)
539   nonnull(1) nonnull(2) nonnull(3);
540 
541 static Tcl_Obj *AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName,
542                          bool withPer_object, bool leaveError)
543   nonnull(1) nonnull(2) nonnull(3);
544 
545 static bool AliasDeleteObjectReference(Tcl_Interp *interp, Tcl_Command cmd)
546   nonnull(1) nonnull(2);
547 
548 static int AliasRefetch(Tcl_Interp *interp, NsfObject *object, const char *methodName,
549                         AliasCmdClientData *tcd)
550   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
551 
552 NSF_INLINE static Tcl_Command AliasDereference(Tcl_Interp *interp, NsfObject *object,
553                                                const char *methodName, Tcl_Command cmd)
554   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
555 
556 /*
557  * Prototypes for (class) list handling
558  */
559 static NsfClasses ** NsfClassListAdd(NsfClasses **firstPtrPtr, NsfClass *class, ClientData clientData)
560   nonnull(1) returns_nonnull;
561 
562 /*
563  * Misc prototypes
564  */
565 static int SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj, unsigned int flags)
566   nonnull(1) nonnull(2) nonnull(3);
567 
568 static int UnsetInstVar(Tcl_Interp *interp, int withNocomplain, NsfObject *object, const char *name)
569   nonnull(1) nonnull(3) nonnull(4);
570 
571 static int NextSearchAndInvoke(
572     Tcl_Interp *interp,
573     const char *methodName, int objc, Tcl_Obj *const objv[],
574     NsfCallStackContent *cscPtr, bool freeArgumentVector
575 ) nonnull(1) nonnull(2) nonnull(5);
576 
577 static void CmdListFree(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct)
578   nonnull(1);
579 static void NsfCommandPreserve(Tcl_Command cmd)
580   nonnull(1);
581 static void NsfCommandRelease(Tcl_Command cmd)
582   nonnull(1);
583 static Tcl_Command GetOriginalCommand(Tcl_Command cmd)
584   nonnull(1) returns_nonnull;
585 
586 EXTERN void NsfDStringArgv(Tcl_DString *dsPtr, int objc, Tcl_Obj *const objv[])
587   nonnull(1) nonnull(3);
588 
589 static NsfObjectOpt *NsfRequireObjectOpt(NsfObject *object)
590   nonnull(1) returns_nonnull;
591 
592 static int ObjectSystemsCheckSystemMethod(
593     Tcl_Interp *interp, const char *methodName,
594     const NsfObject *object, unsigned int flags
595 ) nonnull(1) nonnull(2) nonnull(3);
596 
597 #ifdef DO_CLEANUP
598 static void DeleteNsfProcs(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
599   nonnull(1);
600 #endif
601 
602 #if defined(NSF_WITH_ASSERTIONS)
603 static void AssertionRemoveProc(NsfAssertionStore *aStore, const char *name)
604   nonnull(1) nonnull(2);
605 #endif
606 
607 #ifdef DO_FULL_CLEANUP
608 static void DeleteProcsAndVars(Tcl_Interp *interp, Tcl_Namespace *nsPtr, bool withKeepvars)
609   nonnull(1) nonnull(2);
610 #endif
611 
612 
613 /*
614  *----------------------------------------------------------------------
615  *
616  * NsfDListInit, NsfDListAppend, NsfDListFree   --
617  *
618  *      Functions similar to Tcl_DString, but working on (void*) elements
619  *      instead of chars. The NsfDList operations work on static data as long
620  *      the space is sufficient, and doubles in size afterwards. In the
621  *      worst case, half of the data is unused, but that is the same size of
622  *      overhead like for a single linked list.
623  *
624  * Results:
625  *      None.
626  *
627  * Side effects:
628  *      Potentially allocating/reallocating memory.
629  *
630  *----------------------------------------------------------------------
631  */
632 static void
NsfDListInit(NsfDList * dlPtr)633 NsfDListInit(NsfDList *dlPtr) {
634   dlPtr->data = &dlPtr->static_data[0];
635   dlPtr->avail = nr_elements(dlPtr->static_data);
636   dlPtr->size = 0u;
637 }
638 
639 static void
NsfDListAppend(NsfDList * dlPtr,void * element)640 NsfDListAppend(NsfDList *dlPtr, void *element) {
641   if (dlPtr->avail < 1) {
642     size_t requiredSize = dlPtr->size * 2u;
643 
644     if (dlPtr->data != &dlPtr->static_data[0]) {
645       dlPtr->data = (void **)ckrealloc((char *)dlPtr->data, sizeof(dlPtr->data[0]) * requiredSize);
646     } else {
647       dlPtr->data = (void **)ckalloc(sizeof(dlPtr->data[0]) * requiredSize);
648       memcpy(dlPtr->data, &dlPtr->static_data[0], dlPtr->size * sizeof(dlPtr->data[0]));
649     }
650     dlPtr->avail = requiredSize - dlPtr->size;
651   }
652   dlPtr->avail --;
653   dlPtr->data[dlPtr->size] = element;
654   dlPtr->size ++;
655 }
656 
657 static void
NsfDListFree(NsfDList * dlPtr)658 NsfDListFree(NsfDList *dlPtr) {
659   if (dlPtr->data != &dlPtr->static_data[0]) {
660     ckfree((char*)dlPtr->data);
661   }
662   NsfDListInit(dlPtr);
663 }
664 
665 /*
666  *----------------------------------------------------------------------
667  *
668  * NsfErrorContext --
669  *
670  *      Print the current errorCode and errorInfo to stderr.
671  *      This should be used as the last resort, when e.g. logging fails
672  *
673  * Results:
674  *      None.
675  *
676  * Side effects:
677  *      Output to stderr
678  *
679  *----------------------------------------------------------------------
680  */
681 static void NsfErrorContext(
682     Tcl_Interp *interp, const char *context
683 ) nonnull(1) nonnull(2);
684 
685 static void
NsfErrorContext(Tcl_Interp * interp,const char * context)686 NsfErrorContext(
687     Tcl_Interp *interp, const char *context
688 ) {
689   Tcl_DString ds, *dsPtr = &ds;
690 
691   nonnull_assert(interp != NULL);
692   nonnull_assert(context != NULL);
693 
694   Tcl_DStringInit(dsPtr);
695   Tcl_DStringAppend(dsPtr, "puts stderr \"Error in ", -1);
696   Tcl_DStringAppend(dsPtr, context, -1);
697   Tcl_DStringAppend(dsPtr, ":\n$::errorCode $::errorInfo\"", -1);
698   Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0);
699   Tcl_DStringFree(dsPtr);
700 }
701 
702 #if 0
703 static char *
704 NsfErrorInfo(
705     Tcl_Interp *interp
706 ) {
707   Tcl_Obj *valueObj;
708   nonnull_assert(interp != NULL);
709 
710   valueObj = Tcl_GetVar2Ex(interp, "::errorInfo", NULL, TCL_GLOBAL_ONLY);
711   if (valueObj != NULL) {
712     return ObjStr(valueObj);
713   }
714   return NULL;
715 }
716 #endif
717 
718 /*
719  *----------------------------------------------------------------------
720  *
721  * NsfDStringEval --
722  *
723  *      Evaluate the provided Tcl_DString as a Tcl command and output
724  *      the error stack in case of a failure.
725  *
726  * Results:
727  *      Tcl result code.
728  *
729  * Side effects:
730  *      Output to stderr possible.
731  *
732  *----------------------------------------------------------------------
733  */
734 int
NsfDStringEval(Tcl_Interp * interp,Tcl_DString * dsPtr,const char * context,unsigned int traceEvalFlags)735 NsfDStringEval(
736     Tcl_Interp *interp, Tcl_DString *dsPtr, const char *context,
737     unsigned int traceEvalFlags
738 ) {
739   Tcl_InterpState  state;
740   NsfRuntimeState *rst;
741   int              result, prevDoProfile;
742   unsigned int     prevPreventRecursionFlags;
743 
744   nonnull_assert(interp != NULL);
745   nonnull_assert(dsPtr != NULL);
746   nonnull_assert(context != NULL);
747 
748   rst = RUNTIME_STATE(interp);
749 
750   if ((traceEvalFlags & NSF_EVAL_PREVENT_RECURSION) != 0u) {
751     /*
752      * We do not want to debug the debug statements, since this would cause an
753      * infinite recursion.  Check whether we allow execution of the eval call.
754      */
755     if ((rst->preventRecursionFlags & traceEvalFlags) != 0) {
756       /*
757        * Recursive case, do NOT execute the cmd and return silently.
758        */
759       return TCL_OK;
760     }
761     prevPreventRecursionFlags = rst->preventRecursionFlags;
762     rst->preventRecursionFlags |= traceEvalFlags;
763   } else {
764     prevPreventRecursionFlags = 0u;
765   }
766 
767   if ((traceEvalFlags & NSF_EVAL_NOPROFILE) && rst->doProfile == 1) {
768     /*
769      * Profiling should be deactivated for the eval.
770      */
771     prevDoProfile = 1;
772     rst->doProfile = 0;
773   } else {
774     prevDoProfile = 0;
775   }
776 
777   if ((traceEvalFlags & NSF_EVAL_SAVE) != 0u) {
778     state = Tcl_SaveInterpState(interp, TCL_OK);
779   }
780   result = Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0);
781 
782   if (unlikely(result == TCL_ERROR)) {
783     NsfErrorContext(interp, context);
784   }
785 
786   if ((traceEvalFlags & NSF_EVAL_SAVE) != 0u) {
787     Tcl_RestoreInterpState(interp, state);
788   }
789   if ((traceEvalFlags & NSF_EVAL_PREVENT_RECURSION) != 0u) {
790       rst->preventRecursionFlags = prevPreventRecursionFlags;
791   }
792 
793   if (prevDoProfile == 1) {
794     rst->doProfile = 1;
795   }
796 
797   return result;
798 }
799 
800 /*
801  *----------------------------------------------------------------------
802  *
803  * NsfLog --
804  *
805  *      Produce a formatted warning by calling an external function
806  *      ::nsf::log. It is defined static to allow for inlining.
807  *
808  * Results:
809  *      None.
810  *
811  * Side effects:
812  *      Output of the warning.
813  *
814  *----------------------------------------------------------------------
815  */
816 
817 void
NsfLog(Tcl_Interp * interp,int requiredLevel,const char * fmt,...)818 NsfLog(
819     Tcl_Interp *interp, int requiredLevel, const char *fmt, ...
820 ) {
821   nonnull_assert(interp != NULL);
822   nonnull_assert(fmt != NULL);
823 
824   if (requiredLevel >= RUNTIME_STATE(interp)->logSeverity) {
825     int          destroyRound = RUNTIME_STATE(interp)->exitHandlerDestroyRound;
826     Tcl_DString  cmdString, ds;
827     const char  *level;
828     va_list      ap;
829 
830     switch (requiredLevel) {
831     case NSF_LOG_DEBUG: level = "Debug"; break;
832     case NSF_LOG_NOTICE: level = "Notice"; break;
833     default: level = "Warning"; break;
834     }
835 
836     Tcl_DStringInit(&ds);
837     va_start(ap, fmt);
838     NsfDStringVPrintf(&ds, fmt, ap);
839     va_end(ap);
840 
841     Tcl_DStringInit(&cmdString);
842     Tcl_DStringAppendElement(&cmdString, "::nsf::log");
843     Tcl_DStringAppendElement(&cmdString, level);
844     Tcl_DStringAppendElement(&cmdString, Tcl_DStringValue(&ds));
845 
846     if (destroyRound != NSF_EXITHANDLER_ON_PHYSICAL_DESTROY) {
847       NsfDStringEval(interp, &cmdString, "log command", (NSF_EVAL_LOG|NSF_EVAL_NOPROFILE));
848     } else {
849       /*
850        * On physical destroy, we can't rely on NsfDStringEval() working
851        * properly.
852        */
853       fprintf(stderr, "%s", cmdString.string);
854     }
855     Tcl_DStringFree(&cmdString);
856     Tcl_DStringFree(&ds);
857   }
858 }
859 
860 
861 /*
862  *----------------------------------------------------------------------
863  *
864  * NsfDeprecatedCmd --
865  *
866  *      Provide a warning about a deprecated command or method. The message is
867  *      produced via calling the external Tcl function ::nsf::deprecated. In
868  *      case, profiling is turned on, it is deactivated temporarily. Saving
869  *      the interp result should not be an issue, since the command is called
870  *      before the body of the command is executed.
871  *
872  * Results:
873  *      None.
874  *
875  * Side effects:
876  *      Output of the warning.
877  *
878  *----------------------------------------------------------------------
879  */
880 void
NsfDeprecatedCmd(Tcl_Interp * interp,const char * what,const char * oldCmd,const char * newCmd)881 NsfDeprecatedCmd(
882     Tcl_Interp *interp, const char *what, const char *oldCmd, const char *newCmd
883 ) {
884   Tcl_DString ds, *dsPtr = &ds;
885 
886   nonnull_assert(interp != NULL);
887   nonnull_assert(newCmd != NULL);
888   nonnull_assert(what != NULL);
889   nonnull_assert(oldCmd != NULL);
890 
891   Tcl_DStringInit(dsPtr);
892   Tcl_DStringAppendElement(dsPtr, "::nsf::deprecated");
893   Tcl_DStringAppendElement(dsPtr, what);
894   Tcl_DStringAppendElement(dsPtr, oldCmd);
895   Tcl_DStringAppendElement(dsPtr, newCmd);
896 
897   NsfDStringEval(interp, dsPtr, "deprecated command", (NSF_EVAL_DEPRECATED|NSF_EVAL_NOPROFILE));
898 
899   Tcl_DStringFree(dsPtr);
900 }
901 
902 
903 /***********************************************************************
904  * argv parsing
905  ***********************************************************************/
906 /*
907  *----------------------------------------------------------------------
908  *
909  * ParseContextInit --
910  *
911  *      Initialize a ParseContext with default values and allocate
912  *      memory if needed. Every ParseContext has to be initialized
913  *      before usage and has to be freed with ParseContextRelease().
914  *
915  * Results:
916  *      None.
917  *
918  * Side effects:
919  *      Allocate potentially memory.
920  *
921  *----------------------------------------------------------------------
922  */
923 static void ParseContextInit(
924     ParseContext *pcPtr, int objc, NsfObject *object, Tcl_Obj *procName
925 ) nonnull(1) nonnull(4);
926 
927 static void
ParseContextInit(ParseContext * pcPtr,int objc,NsfObject * object,Tcl_Obj * procName)928 ParseContextInit(
929     ParseContext *pcPtr, int objc, NsfObject *object, Tcl_Obj *procName
930 ) {
931   nonnull_assert(pcPtr != NULL);
932   nonnull_assert(procName != NULL);
933 
934   if (likely(objc < PARSE_CONTEXT_PREALLOC)) {
935     /*
936      * The single larger memset below ....
937      */
938     memset(pcPtr, 0, sizeof(ParseContext));
939     /*
940      * ... is faster than the two smaller memsets below.
941      */
942     /* memset(pcPtr->clientData_static, 0, sizeof(ClientData)*(objc));
943        memset(pcPtr->objv_static, 0, sizeof(Tcl_Obj *)*(objc+1));*/
944     pcPtr->full_objv  = &pcPtr->objv_static[0];
945     pcPtr->clientData = &pcPtr->clientData_static[0];
946     pcPtr->flags      = &pcPtr->flags_static[0];
947   } else {
948     pcPtr->full_objv  = (Tcl_Obj **)ckalloc((int)sizeof(Tcl_Obj *) * ((unsigned)objc+1u));
949     pcPtr->flags      = (unsigned *)ckalloc((unsigned)sizeof(int) * ((unsigned)objc+1u));
950     MEM_COUNT_ALLOC("pcPtr.objv", pcPtr->full_objv);
951     pcPtr->clientData = (ClientData *)ckalloc((unsigned)sizeof(ClientData) * (unsigned)objc);
952     MEM_COUNT_ALLOC("pcPtr.clientData", pcPtr->clientData);
953     /*fprintf(stderr, "ParseContextMalloc %d objc, %p %p\n", objc, pcPtr->full_objv, pcPtr->clientData);*/
954     memset(pcPtr->full_objv,  0, sizeof(Tcl_Obj *)  * (size_t)(objc+1));
955     memset(pcPtr->flags,      0, sizeof(int)        * (size_t)(objc+1));
956     memset(pcPtr->clientData, 0, sizeof(ClientData) * (size_t)objc);
957     pcPtr->status     = NSF_PC_STATUS_FREE_OBJV|NSF_PC_STATUS_FREE_CD;
958     pcPtr->varArgs    = NSF_FALSE;
959     pcPtr->objc       = 0;
960   }
961   pcPtr->objv = &pcPtr->full_objv[1];
962   pcPtr->full_objv[0] = procName;
963   pcPtr->object = object;
964 }
965 
966 /*
967  *----------------------------------------------------------------------
968  *
969  * ParseContextExtendObjv --
970  *
971  *      Extend Tcl_Obj array at runtime, when more elements are
972  *      needed. This function is called to extend an already
973  *      initialized ParseContext.
974  *
975  * Results:
976  *      None.
977  *
978  * Side effects:
979  *      Allocate potentially memory.
980  *
981  *----------------------------------------------------------------------
982  */
983 
984 static void ParseContextExtendObjv(
985     ParseContext *pcPtr, unsigned from, unsigned elts, Tcl_Obj *const source[]
986 ) nonnull(1) nonnull(4);
987 
988 static void
ParseContextExtendObjv(ParseContext * pcPtr,unsigned from,unsigned elts,Tcl_Obj * const source[])989 ParseContextExtendObjv(
990     ParseContext *pcPtr, unsigned from, unsigned elts, Tcl_Obj *const source[]
991 ) {
992   unsigned requiredSize = from + elts + 1;
993 
994   nonnull_assert(pcPtr != NULL);
995   nonnull_assert(source != NULL);
996 
997   /*NsfPrintObjv("BEFORE: ", pcPtr->objc, pcPtr->full_objv);*/
998 
999   if (unlikely(requiredSize >= PARSE_CONTEXT_PREALLOC)) {
1000     if (pcPtr->objv == &pcPtr->objv_static[1]) {
1001       /*
1002        * Realloc from preallocated memory
1003        */
1004       pcPtr->full_objv = (Tcl_Obj **)ckalloc((int)sizeof(Tcl_Obj *) * requiredSize);
1005       pcPtr->flags     = (unsigned *)ckalloc((int)sizeof(int) * requiredSize);
1006       MEM_COUNT_ALLOC("pcPtr.objv", pcPtr->full_objv);
1007       memcpy(pcPtr->full_objv, &pcPtr->objv_static[0], sizeof(Tcl_Obj *) * PARSE_CONTEXT_PREALLOC);
1008       memcpy(pcPtr->flags, &pcPtr->flags_static[0], sizeof(int) * PARSE_CONTEXT_PREALLOC);
1009       /* fprintf(stderr, "ParseContextExtendObjv: extend %p alloc %d new objv=%p pcPtr %p\n",
1010          pcPtr, requiredSize, pcPtr->full_objv, pcPtr);*/
1011 
1012       pcPtr->status     |= NSF_PC_STATUS_FREE_OBJV;
1013     } else {
1014       /*
1015        *  Realloc from mallocated memory
1016        */
1017       pcPtr->full_objv = (Tcl_Obj **)ckrealloc((char *)pcPtr->full_objv, (unsigned)sizeof(Tcl_Obj *) * requiredSize);
1018       pcPtr->flags     = (unsigned *)ckrealloc((char *)pcPtr->flags,     (unsigned)sizeof(int) * requiredSize);
1019       /*fprintf(stderr, "ParseContextExtendObjv: extend %p realloc %d  new objv=%p pcPtr %p\n",
1020         pcPtr, requiredSize, pcPtr->full_objv, pcPtr);*/
1021     }
1022     pcPtr->objv = &pcPtr->full_objv[1];
1023   }
1024 
1025   memcpy(pcPtr->objv + from,  source, sizeof(Tcl_Obj *) * (size_t)elts);
1026   memset(pcPtr->flags + from, 0,      sizeof(int) * (size_t)elts);
1027   pcPtr->objc += (int)elts;
1028 
1029   /*NsfPrintObjv("AFTER:  ", pcPtr->objc, pcPtr->full_objv);*/
1030 }
1031 
1032 /*
1033  *----------------------------------------------------------------------
1034  *
1035  * ParseContextRelease --
1036  *
1037  *      Release (and potentially free) the content of a
1038  *      ParseContext. This function is the counterpart of
1039  *      ParseContextInit(),
1040  *
1041  * Results:
1042  *      None.
1043  *
1044  * Side effects:
1045  *      Free potentially memory.
1046  *
1047  *----------------------------------------------------------------------
1048  */
1049 static void ParseContextRelease(ParseContext *pcPtr)
1050   nonnull(1);
1051 
1052 static void
ParseContextRelease(ParseContext * pcPtr)1053 ParseContextRelease(ParseContext *pcPtr) {
1054   unsigned int status;
1055 
1056   nonnull_assert(pcPtr != NULL);
1057 
1058   status = pcPtr->status;
1059 
1060   /*fprintf(stderr, "ParseContextRelease %p status %.6x %d elements\n",
1061     pcPtr, status, pcPtr->objc);*/
1062 
1063 #if defined(NSF_DEVELOPMENT_TEST)
1064   {
1065     /*
1066      * Perform a general consistency check: although the contents of the parse
1067      * context are at release time sometimes only partially initialized, the
1068      * following holds true for ensuring correct release of Tcl_Objs:
1069      *
1070      *  1) if one of the objv-flags has NSF_PC_MUST_DECR set,
1071      *     then the status flag NSF_PC_STATUS_MUST_DECR has to
1072      *     be set as well.
1073      *
1074      *  2) if objc > 0 then for all objv entries having a flag
1075      *     different from 0  must have a
1076      *     TCL_OBJ in the vector.
1077      *
1078      *  3) for preallocated objvs, all elements of the objv
1079      *     after the argument vector must be 0 or
1080      *     NSF_PC_IS_DEFAULT (sanity check)
1081      */
1082     /*
1083      * (1) make sure that the status correctly reflects MUST_DECR.
1084      */
1085     int i;
1086     if (status == 0u || (status & NSF_PC_STATUS_MUST_DECR) == 0u) {
1087       for (i = 0; i < pcPtr->objc - 1; i++) {
1088         assert((pcPtr->flags[i] & NSF_PC_MUST_DECR) == 0);
1089       }
1090     }
1091 
1092     /*
1093      * (2) make sure, Tcl_Objs are set when needed for reclaiming memory.
1094      */
1095     if (pcPtr->objc > 0) {
1096       /*fprintf(stderr, "%s ", ObjStr(pcPtr->full_objv[0]));*/
1097       for (i = 0; i < pcPtr->objc; i++) {
1098         if (pcPtr->flags[i] != 0u) {
1099           assert(pcPtr->objv[i]);
1100           /*fprintf(stderr, "[%d]%s %.6x ", i, ObjStr(pcPtr->objv[i]), pcPtr->flags[i]);*/
1101         }
1102       }
1103     }
1104     /*
1105      * (3) All later flags must be empty or DEFAULT.
1106      */
1107     if (pcPtr->full_objv == &pcPtr->objv_static[0] && pcPtr->objc > 0) {
1108       for (i = pcPtr->objc; i < PARSE_CONTEXT_PREALLOC; i++) {
1109         assert(pcPtr->flags[i] == 0u || pcPtr->flags[i] == NSF_PC_IS_DEFAULT);
1110       }
1111     }
1112   }
1113 #endif
1114 
1115   if (unlikely(status != 0u)) {
1116     if ((status & NSF_PC_STATUS_MUST_DECR) != 0u) {
1117       int i;
1118       /*fprintf(stderr, "ParseContextRelease %p loop from 0 to %d\n", pcPtr, pcPtr->objc-1);*/
1119       for (i = 0; i < pcPtr->objc; i++) {
1120         /*fprintf(stderr, "ParseContextRelease %p check [%d] obj %p flags %.6x & %p\n",
1121                 pcPtr, i, pcPtr->objv[i],
1122                 pcPtr->flags[i], &(pcPtr->flags[i]));*/
1123         if ((pcPtr->flags[i] & NSF_PC_MUST_DECR) != 0u) {
1124           assert(pcPtr->objv[i]);
1125           assert(pcPtr->objv[i]->refCount > 0);
1126           /*fprintf(stderr, "... decr ref count on %p\n", pcPtr->objv[i]);*/
1127           DECR_REF_COUNT2("valueObj", pcPtr->objv[i]);
1128         }
1129       }
1130     }
1131     /*
1132      * Objv can be separately extended; also flags are extend when this
1133      * happens.
1134      */
1135     if (unlikely((status & NSF_PC_STATUS_FREE_OBJV) != 0u)) {
1136       /*fprintf(stderr, "ParseContextRelease %p free %p %p\n",
1137         pcPtr, pcPtr->full_objv, pcPtr->clientData);*/
1138       MEM_COUNT_FREE("pcPtr.objv", pcPtr->full_objv);
1139       ckfree((char *)pcPtr->full_objv);
1140       ckfree((char *)pcPtr->flags);
1141     }
1142     /*
1143      * If the parameter definition was extended at creation time also
1144      * clientData is extended.
1145      */
1146     if ((status & NSF_PC_STATUS_FREE_CD) != 0u) {
1147       /*fprintf(stderr, "free client-data for %p\n", pcPtr);*/
1148       MEM_COUNT_FREE("pcPtr.clientData", pcPtr->clientData);
1149       ckfree((char *)pcPtr->clientData);
1150     }
1151   }
1152 }
1153 
1154 /*
1155  *----------------------------------------------------------------------
1156  *
1157  * CallMethod --
1158  *
1159  *      Call a Next Scripting method. The provided "clientData" has to contain
1160  *      the object, on which the method is to be dispatched, "methodDobj"
1161  *      denotes the method, "objc" (which has to be >=2) and "objv" denotes
1162  *      the argument vector.
1163  *
1164  * Results:
1165  *      Tcl return code
1166  *
1167  * Side effects:
1168  *      potentially via the called method.
1169  *
1170  *----------------------------------------------------------------------
1171  */
1172 /*
1173  * call a Next Scripting method
1174  */
1175 static int
1176 CallMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *methodObj,
1177            int objc, Tcl_Obj *const objv[], unsigned int flags)
1178   nonnull(1) nonnull(2) nonnull(3);
1179 
1180 static int
CallMethod(ClientData clientData,Tcl_Interp * interp,Tcl_Obj * methodObj,int objc,Tcl_Obj * const objv[],unsigned int flags)1181 CallMethod(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *methodObj,
1182            int objc, Tcl_Obj *const objv[], unsigned int flags) {
1183   NsfObject *object;
1184   int        result;
1185   ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
1186 
1187   nonnull_assert(clientData != NULL);
1188   nonnull_assert(interp != NULL);
1189   nonnull_assert(methodObj != NULL);
1190   assert(objc > 1);
1191 
1192   object = (NsfObject *) clientData;
1193   tov[0] = object->cmdName;
1194   tov[1] = methodObj;
1195 
1196   if (likely(objc > 2)) {
1197     memcpy(tov+2, objv, sizeof(Tcl_Obj *) * ((size_t)objc - 2u));
1198   }
1199 
1200   /*fprintf(stderr, "%%%% CallMethod cmdName=%s, method=%s, objc=%d\n",
1201     ObjStr(tov[0]), ObjStr(tov[1]), objc);
1202     {int i; fprintf(stderr, "\t CALL: %s ", ObjStr(methodObj));for(i = 0; i < objc-2; i++) {
1203     fprintf(stderr, "%s ", ObjStr(objv[i]));} fprintf(stderr, "\n");}*/
1204 
1205   result = ObjectDispatch(clientData, interp, objc, tov, flags);
1206 
1207   FREE_ON_STACK(Tcl_Obj*, tov);
1208 
1209   return result;
1210 }
1211 
1212 /*
1213  *----------------------------------------------------------------------
1214  *
1215  * NsfCallMethodWithArgs --
1216  *
1217  *      Call method (passed in methodObj) on the object, with the often
1218  *      provided arg1 and the optional remaining args (passed vis objv).  This
1219  *      way, we save the memcpy in case no argument or a single argument are
1220  *      provided (common cases).
1221  *
1222  * Results:
1223  *      Tcl result.
1224  *
1225  * Side effects:
1226  *      Called method might side effect.
1227  *
1228  *----------------------------------------------------------------------
1229  */
1230 
1231 int NsfCallMethodWithArgs(Tcl_Interp *interp, Nsf_Object *object, Tcl_Obj *methodObj,
1232                       Tcl_Obj *arg1, int givenObjc, Tcl_Obj *const objv[], unsigned int flags)
1233   nonnull(1) nonnull(2) nonnull(3);
1234 
1235 int
NsfCallMethodWithArgs(Tcl_Interp * interp,Nsf_Object * object,Tcl_Obj * methodObj,Tcl_Obj * arg1,int givenObjc,Tcl_Obj * const objv[],unsigned int flags)1236 NsfCallMethodWithArgs(Tcl_Interp *interp, Nsf_Object *object, Tcl_Obj *methodObj,
1237                       Tcl_Obj *arg1, int givenObjc, Tcl_Obj *const objv[], unsigned int flags) {
1238   int       objc = givenObjc + 2;
1239   int       result;
1240   ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
1241 
1242   nonnull_assert(interp != NULL);
1243   nonnull_assert(object != NULL);
1244   assert(ISOBJ_(methodObj));
1245   assert(objc > 1);
1246 
1247   tov[0] = object->cmdName;
1248   tov[1] = methodObj;
1249   if (objc > 2) {
1250     tov[2] = arg1;
1251   }
1252   if (objc > 3) {
1253     memcpy(tov+3, objv, sizeof(Tcl_Obj *) * ((size_t)objc - 3u));
1254   }
1255 
1256   /*fprintf(stderr, "%%%% CallMethodWithArgs cmdName=%s, method=%s, arg1 %s objc=%d\n",
1257           ObjStr(tov[0]), ObjStr(tov[1]), (objc > 2) ? ObjStr(tov[2]) : "",  objc);*/
1258 
1259   result = ObjectDispatch(object, interp, objc, tov, flags);
1260 
1261   FREE_ON_STACK(Tcl_Obj*, tov);
1262 
1263   return result;
1264 }
1265 
1266 /*
1267  * Support for variable hash tables
1268  */
1269 static NSF_INLINE Var *VarHashCreateVar(TclVarHashTable *tablePtr, const Tcl_Obj *key, int *newPtr)
1270   nonnull(1) nonnull(2);
1271 
1272 static NSF_INLINE Var *
VarHashCreateVar(TclVarHashTable * tablePtr,const Tcl_Obj * key,int * newPtr)1273 VarHashCreateVar(TclVarHashTable *tablePtr, const Tcl_Obj *key, int *newPtr) {
1274   Var                 *varPtr;
1275   const Tcl_HashEntry *hPtr;
1276 
1277   nonnull_assert(tablePtr != NULL);
1278   nonnull_assert(key != NULL);
1279 
1280   hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
1281                              (char *) key, newPtr);
1282   if (likely(hPtr != NULL)) {
1283     varPtr = TclVarHashGetValue(hPtr);
1284   } else {
1285     varPtr = NULL;
1286   }
1287 
1288   return varPtr;
1289 }
1290 
1291 static NSF_INLINE TclVarHashTable *
VarHashTableCreate(void)1292 VarHashTableCreate(void) {
1293   TclVarHashTable *varTablePtr = (TclVarHashTable *) ckalloc((int)sizeof(TclVarHashTable));
1294 
1295   TclInitVarHashTable(varTablePtr, NULL);
1296   return varTablePtr;
1297 }
1298 
1299 #include "nsfCmdPtr.c"
1300 #include "nsfStack.c"
1301 
1302 /***********************************************************************
1303  * Value added replacements of Tcl functions
1304  ***********************************************************************/
1305 /*
1306  *----------------------------------------------------------------------
1307  * Nsf_NextHashEntry --
1308  *
1309  *    Function very similar to Tcl_NextHashEntry. If during the iteration of
1310  *    hash entries some of these entries are removed, Tcl_NextHashEntry() can
1311  *    lead to a valid looking but invalid hPtr, when the next entry was
1312  *    already deleted. This seem to occur only, when there are more than 12
1313  *    hash entries in the table (multiple buckets).  Therefore, we use
1314  *    numEntries to check whether it is sensible to return a hash entry. We
1315  *    can trigger refetch of the hSrchPtr, when the number of expected entries
1316  *    differs from the numbers of the actual entries.
1317  *
1318  * Results:
1319  *    Hash Entry or NULL.
1320  *
1321  * Side effects:
1322  *    None.
1323  *
1324  *----------------------------------------------------------------------
1325  */
1326 static Tcl_HashEntry * Nsf_NextHashEntry(Tcl_HashTable *tablePtr, int expected, Tcl_HashSearch *hSrchPtr)
1327   nonnull(1) nonnull(3);
1328 
1329 static Tcl_HashEntry *
Nsf_NextHashEntry(Tcl_HashTable * tablePtr,int expected,Tcl_HashSearch * hSrchPtr)1330 Nsf_NextHashEntry(Tcl_HashTable *tablePtr, int expected, Tcl_HashSearch *hSrchPtr) {
1331   Tcl_HashEntry *result;
1332 
1333   nonnull_assert(tablePtr != NULL);
1334   nonnull_assert(hSrchPtr != NULL);
1335 
1336   /*fprintf(stderr, "Nsf_NextHashEntry %p expected %d numEntries %d\n",
1337     tablePtr, expected, tablePtr->numEntries);*/
1338   if (tablePtr->numEntries < 1) {
1339     result = NULL;
1340   } else if (tablePtr->numEntries != expected) {
1341     result = Tcl_FirstHashEntry(tablePtr, hSrchPtr);
1342   } else {
1343     result = Tcl_NextHashEntry(hSrchPtr);
1344   }
1345   return result;
1346 }
1347 
1348 /*
1349  *----------------------------------------------------------------------
1350  * NsfCommandPreserve --
1351  *
1352  *    Increment Tcl's command refCount
1353  *
1354  * Results:
1355  *    void
1356  *
1357  * Side effects:
1358  *    None.
1359  *
1360  *----------------------------------------------------------------------
1361  */
1362 static void
NsfCommandPreserve(Tcl_Command cmd)1363 NsfCommandPreserve(Tcl_Command cmd) {
1364 
1365   nonnull_assert(cmd != NULL);
1366 
1367   Tcl_Command_refCount(cmd)++;
1368   MEM_COUNT_ALLOC("command.refCount", cmd);
1369 }
1370 
1371 /*
1372  *----------------------------------------------------------------------
1373  * NsfCommandRelease --
1374  *
1375  *    Decrement Tcl command refCount and free it if necessary.
1376  *
1377  * Results:
1378  *    void
1379  *
1380  * Side effects:
1381  *    Free potentially memory
1382  *
1383  *----------------------------------------------------------------------
1384  */
1385 static void
NsfCommandRelease(Tcl_Command cmd)1386 NsfCommandRelease(Tcl_Command cmd) {
1387 
1388   nonnull_assert(cmd != NULL);
1389 
1390   /*fprintf(stderr, "NsfCommandRelease %p\n", cmd);*/
1391   MEM_COUNT_FREE("command.refCount", cmd);
1392   TclCleanupCommandMacro((Command *)cmd);
1393 }
1394 
1395 /***********************************************************************
1396  * EXTERN callable routines for the preliminary C interface
1397  ***********************************************************************/
1398 Nsf_Object * NsfGetSelfObj(const Tcl_Interp *interp)
1399   nonnull(1) pure;
1400 Nsf_Object * NsfGetObject(Tcl_Interp *interp, const char *name)
1401   nonnull(1) nonnull(2);
1402 Nsf_Class * NsfGetClass(Tcl_Interp *interp, const char *name)
1403   nonnull(1) nonnull(2);
1404 Nsf_Class * NsfIsClass(Tcl_Interp *interp, ClientData clientData)
1405   nonnull(1) nonnull(2) pure;
1406 void NsfRequireObjNamespace(Tcl_Interp *interp, Nsf_Object *object)
1407   nonnull(1) nonnull(2);
1408 Tcl_Obj * Nsf_ObjSetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
1409                          Tcl_Obj *valueObj, unsigned int flags)
1410   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
1411 Tcl_Obj * Nsf_ObjGetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, unsigned int flags)
1412   nonnull(1) nonnull(2) nonnull(3);
1413 int NsfCreate(Tcl_Interp *interp, Nsf_Class *class, Tcl_Obj *nameObj, int objc, Tcl_Obj *const objv[])
1414   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
1415 int NsfDeleteObject(Tcl_Interp *interp, Nsf_Object *object)
1416   nonnull(1) nonnull(2);
1417 int NsfRemoveObjectMethod(Tcl_Interp *interp, Nsf_Object *object, const char *methodName)
1418   nonnull(1) nonnull(2) nonnull(3);
1419 int NsfRemoveClassMethod(Tcl_Interp *interp, Nsf_Class *class, const char *methodName)
1420   nonnull(1) nonnull(2) nonnull(3);
1421 int Nsf_UnsetVar2(Nsf_Object *object, Tcl_Interp *interp,
1422                   const char *name1, const char *name2, unsigned int flags)
1423   nonnull(1) nonnull(2) nonnull(4);
1424 
1425 void NsfSetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object, ClientData data)
1426   nonnull(1) nonnull(2);
1427 ClientData NsfGetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object)
1428   nonnull(1) nonnull(2) pure;
1429 void NsfSetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class, ClientData data)
1430   nonnull(1) nonnull(2);
1431 ClientData NsfGetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class)
1432   nonnull(1) nonnull(2) pure;
1433 
1434 Nsf_Object *
NsfGetSelfObj(const Tcl_Interp * interp)1435 NsfGetSelfObj(const Tcl_Interp *interp) {
1436   nonnull_assert(interp != NULL);
1437   return (Nsf_Object *) GetSelfObj(interp);
1438 }
1439 
1440 Nsf_Object *
NsfGetObject(Tcl_Interp * interp,const char * name)1441 NsfGetObject(Tcl_Interp *interp, const char *name) {
1442   nonnull_assert(interp != NULL);
1443   nonnull_assert(name != NULL);
1444   return (Nsf_Object *) GetObjectFromString(interp, name);
1445 }
1446 
1447 Nsf_Class *
NsfGetClass(Tcl_Interp * interp,const char * name)1448 NsfGetClass(Tcl_Interp *interp, const char *name) {
1449   nonnull_assert(interp != NULL);
1450   nonnull_assert(name != NULL);
1451   return (Nsf_Class *)GetClassFromString(interp, name);
1452 }
1453 
1454 Nsf_Class *
NsfIsClass(Tcl_Interp * UNUSED (interp),ClientData clientData)1455 NsfIsClass(Tcl_Interp *UNUSED(interp), ClientData clientData) {
1456 
1457   nonnull_assert(clientData != NULL);
1458 
1459   if (NsfObjectIsClass((NsfObject *)clientData)) {
1460     return (Nsf_Class *) clientData;
1461   }
1462   return NULL;
1463 }
1464 
1465 void
NsfRequireObjNamespace(Tcl_Interp * interp,Nsf_Object * object)1466 NsfRequireObjNamespace(Tcl_Interp *interp, Nsf_Object *object) {
1467 
1468   nonnull_assert(interp != NULL);
1469   nonnull_assert(object != NULL);
1470 
1471   RequireObjNamespace(interp, (NsfObject *) object);
1472 }
1473 
1474 Tcl_Obj *
Nsf_ObjSetVar2(Nsf_Object * object,Tcl_Interp * interp,Tcl_Obj * name1,Tcl_Obj * name2,Tcl_Obj * valueObj,unsigned int flags)1475 Nsf_ObjSetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
1476                  Tcl_Obj *valueObj, unsigned int flags) {
1477   Tcl_Obj *result;
1478   CallFrame frame, *framePtr = &frame;
1479 
1480   nonnull_assert(object != NULL);
1481   nonnull_assert(interp != NULL);
1482   nonnull_assert(name1 != NULL);
1483   nonnull_assert(valueObj != NULL);
1484 
1485   Nsf_PushFrameObj(interp, (NsfObject *)object, framePtr);
1486   if (((NsfObject *)object)->nsPtr != NULL) {
1487     flags |= TCL_NAMESPACE_ONLY;
1488   }
1489   result = Tcl_ObjSetVar2(interp, name1, name2, valueObj, (int)flags);
1490   Nsf_PopFrameObj(interp, framePtr);
1491   return result;
1492 }
1493 
1494 
1495 Tcl_Obj *
Nsf_ObjGetVar2(Nsf_Object * object,Tcl_Interp * interp,Tcl_Obj * name1,Tcl_Obj * name2,unsigned int flags)1496 Nsf_ObjGetVar2(Nsf_Object *object, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
1497                unsigned int flags) {
1498   Tcl_Obj  *result;
1499   CallFrame frame, *framePtr = &frame;
1500 
1501   nonnull_assert(object != NULL);
1502   nonnull_assert(interp != NULL);
1503   nonnull_assert(name1 != NULL);
1504 
1505   Nsf_PushFrameObj(interp, (NsfObject *)object, framePtr);
1506   if (((NsfObject *)object)->nsPtr != NULL) {
1507     flags |= TCL_NAMESPACE_ONLY;
1508   }
1509   result = Tcl_ObjGetVar2(interp, name1, name2, (int)flags);
1510   Nsf_PopFrameObj(interp, framePtr);
1511 
1512   return result;
1513 }
1514 
1515 int
Nsf_UnsetVar2(Nsf_Object * object,Tcl_Interp * interp,const char * name1,const char * name2,unsigned int flags)1516 Nsf_UnsetVar2(Nsf_Object *object, Tcl_Interp *interp,
1517                    const char *name1, const char *name2, unsigned int flags) {
1518   CallFrame  frame, *framePtr = &frame;
1519   NsfObject *o;
1520   int        result;
1521 
1522   nonnull_assert(object != NULL);
1523   nonnull_assert(interp != NULL);
1524   nonnull_assert(name1 != NULL);
1525   nonnull_assert(name2 != NULL);
1526 
1527   o = (NsfObject *) object;
1528   Nsf_PushFrameObj(interp, o, framePtr);
1529   if (o->nsPtr != NULL) {
1530     flags |= TCL_NAMESPACE_ONLY;
1531   }
1532   result = Tcl_UnsetVar2(interp, name1, name2, (int)flags);
1533   Nsf_PopFrameObj(interp, framePtr);
1534   return result;
1535 }
1536 
1537 int
NsfCreate(Tcl_Interp * interp,Nsf_Class * class,Tcl_Obj * nameObj,int objc,Tcl_Obj * const objv[])1538 NsfCreate(Tcl_Interp *interp, Nsf_Class *class, Tcl_Obj *nameObj,
1539           int objc, Tcl_Obj *const objv[]) {
1540   NsfClass *cl = (NsfClass *) class;
1541   int       result;
1542   ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
1543 
1544   nonnull_assert(interp != NULL);
1545   nonnull_assert(class != NULL);
1546   nonnull_assert(nameObj != NULL);
1547   nonnull_assert(objv != NULL);
1548 
1549   INCR_REF_COUNT2("nameObj", nameObj);
1550 
1551   tov[0] = NULL;
1552   tov[1] = nameObj;
1553   if (objc > 0) {
1554     memcpy(tov+2, objv, sizeof(Tcl_Obj *) * (size_t)objc);
1555   }
1556   result = NsfCCreateMethod(interp, cl, nameObj, objc+2, tov);
1557 
1558   FREE_ON_STACK(Tcl_Obj*, tov);
1559   DECR_REF_COUNT2("nameObj", nameObj);
1560 
1561   return result;
1562 }
1563 
1564 int
NsfDeleteObject(Tcl_Interp * interp,Nsf_Object * object)1565 NsfDeleteObject(Tcl_Interp *interp, Nsf_Object *object) {
1566 
1567   nonnull_assert(interp != NULL);
1568   nonnull_assert(object != NULL);
1569 
1570   return DispatchDestroyMethod(interp, (NsfObject *)object, 0u);
1571 }
1572 
1573 int
NsfRemoveObjectMethod(Tcl_Interp * interp,Nsf_Object * object,const char * methodName)1574 NsfRemoveObjectMethod(Tcl_Interp *interp, Nsf_Object *object, const char *methodName) {
1575   NsfObject *currentObject;
1576 
1577   nonnull_assert(interp != NULL);
1578   nonnull_assert(object != NULL);
1579   nonnull_assert(methodName != NULL);
1580 
1581   currentObject = (NsfObject *) object;
1582   /*fprintf(stderr, "... NsfRemoveObjectMethod %s %s\n", ObjectName(currentObject), methodName);*/
1583 
1584   NsfObjectMethodEpochIncr("NsfRemoveObjectMethod");
1585   AliasDelete(interp, currentObject->cmdName, methodName, NSF_TRUE);
1586 
1587 #if defined(NSF_WITH_ASSERTIONS)
1588   if (currentObject->opt != NULL && currentObject->opt->assertions != NULL) {
1589     AssertionRemoveProc(currentObject->opt->assertions, methodName);
1590   }
1591 #endif
1592 
1593   if (currentObject->nsPtr != NULL) {
1594     int rc = NSDeleteCmd(interp, currentObject->nsPtr, methodName);
1595     if (rc < 0) {
1596       return NsfPrintError(interp, "%s: cannot delete object specific method '%s'",
1597                            ObjectName_(currentObject), methodName);
1598     }
1599   }
1600   return TCL_OK;
1601 }
1602 
1603 int
NsfRemoveClassMethod(Tcl_Interp * interp,Nsf_Class * class,const char * methodName)1604 NsfRemoveClassMethod(Tcl_Interp *interp, Nsf_Class *class, const char *methodName) {
1605   const NsfClass *c;
1606   int             rc;
1607 #if defined(NSF_WITH_ASSERTIONS)
1608   NsfClassOpt    *opt;
1609 #endif
1610 
1611   nonnull_assert(interp != NULL);
1612   nonnull_assert(class != NULL);
1613   nonnull_assert(methodName != NULL);
1614 
1615   c = (NsfClass *)class;
1616   /*fprintf(stderr, "... NsfRemoveClassMethod %s %s\n", ClassName(class), methodName);*/
1617 
1618   NsfInstanceMethodEpochIncr("NsfRemoveClassMethod");
1619   AliasDelete(interp, class->object.cmdName, methodName, NSF_FALSE);
1620 
1621 #if defined(NSF_WITH_ASSERTIONS)
1622   opt = c->opt;
1623   if (opt != NULL && opt->assertions != NULL) {
1624     AssertionRemoveProc(opt->assertions, methodName);
1625   }
1626 #endif
1627 
1628   rc = NSDeleteCmd(interp, c->nsPtr, methodName);
1629   if (rc < 0) {
1630     return NsfPrintError(interp, "%s: cannot delete method '%s'", ClassName_(c), methodName);
1631   }
1632   return TCL_OK;
1633 }
1634 
1635 /*
1636  * obj/cl ClientData setter/getter
1637  */
1638 
1639 void
NsfSetObjClientData(Tcl_Interp * UNUSED (interp),Nsf_Object * object,ClientData data)1640 NsfSetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object, ClientData data) {
1641 
1642   nonnull_assert(object != NULL);
1643   nonnull_assert(data != NULL);
1644 
1645   NsfRequireObjectOpt((NsfObject *) object) -> clientData = data;
1646 }
1647 
1648 ClientData
NsfGetObjClientData(Tcl_Interp * UNUSED (interp),Nsf_Object * object)1649 NsfGetObjClientData(Tcl_Interp *UNUSED(interp), Nsf_Object *object) {
1650   NsfObject *object_;
1651 
1652   nonnull_assert(object != NULL);
1653 
1654   object_ = (NsfObject *) object;
1655   return (object_->opt != NULL) ? object_->opt->clientData : NULL;
1656 }
1657 
1658 void
NsfSetClassClientData(Tcl_Interp * UNUSED (interp),Nsf_Class * class,ClientData data)1659 NsfSetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class, ClientData data) {
1660 
1661   nonnull_assert(class != NULL);
1662 
1663   NsfRequireClassOpt((NsfClass *)class) -> clientData = data;
1664 }
1665 
1666 ClientData
NsfGetClassClientData(Tcl_Interp * UNUSED (interp),Nsf_Class * class)1667 NsfGetClassClientData(Tcl_Interp *UNUSED(interp), Nsf_Class *class) {
1668   NsfClass *c;
1669 
1670   c = (NsfClass *) class;
1671   return (c->opt != NULL) ? c->opt->clientData : NULL;
1672 }
1673 
1674 /***********************************************************************
1675  * Utility functions
1676  ***********************************************************************/
1677 
1678 #if defined(NSFOBJ_TRACE)
1679 void ObjTrace(const char *string, NsfObject *object)
1680   nonnull(1) nonnull(2);
1681 
1682 void
ObjTrace(const char * string,NsfObject * object)1683 ObjTrace(const char *string, NsfObject *object) {
1684 
1685   nonnull_assert(string != NULL);
1686   nonnull_assert(object != NULL);
1687 
1688   fprintf(stderr, "--- %s Tcl %p %s (%d %p) nsf %p (%d) %s \n", string,
1689           object->cmdName, ObjTypeStr(object->cmdName),
1690           object->cmdName->refCount, object->cmdName->internalRep.twoPtrValue.ptr1,
1691           object, object->refCount, ObjectName(object));
1692 }
1693 #else
1694 # define ObjTrace(a, b)
1695 #endif
1696 
1697 
1698 /*
1699  *----------------------------------------------------------------------
1700  * NSTail --
1701  *
1702  *    Return the namespace tail of a name.
1703  *
1704  * Results:
1705  *    String.
1706  *
1707  * Side effects:
1708  *    None.
1709  *
1710  *----------------------------------------------------------------------
1711  */
1712 static const char * NSTail(const char *string)
1713   nonnull(1) pure;
1714 
1715 static const char *
NSTail(const char * string)1716 NSTail(const char *string) {
1717   register const char *p;
1718 
1719   nonnull_assert(string != NULL);
1720 
1721   p = string + strlen(string);
1722   while (p > string) {
1723     if (unlikely(*p == ':' && *(p-1) == ':')) {
1724       return p+1;
1725     }
1726     p--;
1727   }
1728   return string;
1729 }
1730 
1731 /*
1732  *----------------------------------------------------------------------
1733  * IsClassNsName --
1734  *
1735  *    Check whether the provided string starts with the prefix of the
1736  *    classes namespace.
1737  *
1738  * Results:
1739  *    Boolean.
1740  *
1741  * Side effects:
1742  *    None.
1743  *
1744  *----------------------------------------------------------------------
1745  */
1746 NSF_INLINE static bool IsClassNsName(const char *string, const char **cont)
1747   nonnull(1);
1748 
1749 NSF_INLINE static bool
IsClassNsName(const char * string,const char ** cont)1750 IsClassNsName(const char *string, const char **cont) {
1751 
1752   nonnull_assert(string != NULL);
1753 
1754   if (*string == ':' && strncmp(string, nsfClassesPrefix, nsfClassesPrefixLength) == 0) {
1755     if (cont != NULL) {
1756       *cont = string + nsfClassesPrefixLength;
1757     }
1758     return NSF_TRUE;
1759   }
1760   return NSF_FALSE;
1761 }
1762 
1763 /*
1764  *----------------------------------------------------------------------
1765  * GetObjectFromNsName --
1766  *
1767  *    Get object or class from a fully qualified cmd name, such as
1768  *    e.g. ::nsf::classes::X
1769  *
1770  * Results:
1771  *    NsfObject and *fromClasses
1772  *
1773  * Side effects:
1774  *    None.
1775  *
1776  *----------------------------------------------------------------------
1777  */
1778 NSF_INLINE static NsfObject * GetObjectFromNsName(Tcl_Interp *interp, const char *string, bool *fromClassNS)
1779   nonnull(1) nonnull(2) nonnull(3);
1780 
1781 NSF_INLINE static NsfObject *
GetObjectFromNsName(Tcl_Interp * interp,const char * string,bool * fromClassNS)1782 GetObjectFromNsName(Tcl_Interp *interp, const char *string, bool *fromClassNS) {
1783   const char *className;
1784 
1785   nonnull_assert(interp != NULL);
1786   nonnull_assert(string != NULL);
1787   nonnull_assert(fromClassNS != NULL);
1788 
1789   if (IsClassNsName(string, &className)) {
1790     *fromClassNS = NSF_TRUE;
1791     return (NsfObject *)GetClassFromString(interp, className);
1792   } else {
1793     *fromClassNS = NSF_FALSE;
1794     return GetObjectFromString(interp, string);
1795   }
1796 }
1797 
1798 /*
1799  *----------------------------------------------------------------------
1800  * DStringAppendQualName --
1801  *
1802  *    Append to initialized DString the name of the namespace followed
1803  *    by a simple name (methodName, cmdName).
1804  *
1805  * Results:
1806  *    String pointing to DString value.
1807  *
1808  * Side effects:
1809  *    None.
1810  *
1811  *----------------------------------------------------------------------
1812  */
1813 static char *DStringAppendQualName(Tcl_DString *dsPtr, const Tcl_Namespace *nsPtr, const char *name)
1814   nonnull(1) nonnull(2) nonnull(3);
1815 
1816 static char *
DStringAppendQualName(Tcl_DString * dsPtr,const Tcl_Namespace * nsPtr,const char * name)1817 DStringAppendQualName(Tcl_DString *dsPtr, const Tcl_Namespace *nsPtr, const char *name) {
1818   int oldLength;
1819 
1820   nonnull_assert(dsPtr != NULL);
1821   nonnull_assert(nsPtr != NULL);
1822   nonnull_assert(name != NULL);
1823 
1824   oldLength = Tcl_DStringLength(dsPtr);
1825 
1826   Tcl_DStringAppend(dsPtr, nsPtr->fullName, -1);
1827   if (Tcl_DStringLength(dsPtr) > (oldLength + 2)) {
1828     Tcl_DStringAppend(dsPtr, "::", 2);
1829   }
1830   Tcl_DStringAppend(dsPtr, name, -1);
1831   return Tcl_DStringValue(dsPtr);
1832 }
1833 
1834 /*
1835  *----------------------------------------------------------------------
1836  * NsfCleanupObject --
1837  *
1838  *    Delete an object physically (performing ckfree()) when its refCount
1839  *    reaches 0
1840  *
1841  * Results:
1842  *    None.
1843  *
1844  * Side effects:
1845  *    Frees memory.
1846  *
1847  *----------------------------------------------------------------------
1848  */
1849 void
NsfCleanupObject_(NsfObject * object)1850 NsfCleanupObject_(NsfObject *object) {
1851 
1852   nonnull_assert(object != NULL);
1853 
1854   NsfObjectRefCountDecr(object);
1855   /*fprintf(stderr, "NsfCleanupObject obj refCount of %p after decr %d id %p interp %p flags %.6x\n",
1856     object, object->refCount, object->id, object->teardown, object->flags);*/
1857 
1858   if (unlikely(object->refCount <= 0)) {
1859     /*fprintf(stderr, "NsfCleanupObject %p ref-count %d\n", object, object->refCount);*/
1860     assert(object->refCount == 0);
1861     assert((object->flags & NSF_DELETED) != 0u);
1862 
1863     /*
1864      * During FinalObjectDeletion(), object->teardown is NULL, we cannot access
1865      * the object and class names anymore.
1866      */
1867     if (object->teardown && NSF_DTRACE_OBJECT_FREE_ENABLED()) {
1868       NSF_DTRACE_OBJECT_FREE(ObjectName(object), ClassName(object->cl));
1869     }
1870 
1871     MEM_COUNT_FREE("NsfObject/NsfClass", object);
1872 #if defined(NSFOBJ_TRACE)
1873     fprintf(stderr, "CKFREE Object %p refCount=%d\n", object, object->refCount);
1874 #endif
1875 #if !defined(NDEBUG)
1876     memset(object, 0, sizeof(NsfObject));
1877 #endif
1878     ckfree((char *) object);
1879   }
1880 }
1881 
1882 
1883 /*
1884  *  Tcl_Obj functions for objects
1885  */
1886 
1887 /*
1888  *----------------------------------------------------------------------
1889  * TclObjIsNsfObject --
1890  *
1891  *    Check whether the provided Tcl_Obj is bound to an NSF object. If so,
1892  *    return the NsfObject in the third argument.
1893  *
1894  * Results:
1895  *    Boolean
1896  *
1897  * Side effects:
1898  *    None
1899  *
1900  *----------------------------------------------------------------------
1901  */
1902 static bool TclObjIsNsfObject(
1903     Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr
1904 ) nonnull(1) nonnull(2) nonnull(3);
1905 
1906 static bool
TclObjIsNsfObject(Tcl_Interp * interp,Tcl_Obj * objPtr,NsfObject ** objectPtr)1907 TclObjIsNsfObject(Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr) {
1908   Tcl_ObjType CONST86 *cmdType;
1909   bool                 result = NSF_FALSE;
1910 
1911   nonnull_assert(interp != NULL);
1912   nonnull_assert(objPtr != NULL);
1913   nonnull_assert(objectPtr != NULL);
1914 
1915   cmdType = objPtr->typePtr;
1916   if (cmdType == Nsf_OT_tclCmdNameType) {
1917     const Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr);
1918     if (likely(cmd != NULL)) {
1919       NsfObject *object = NsfGetObjectFromCmdPtr(cmd);
1920       if (object != NULL) {
1921         *objectPtr = object;
1922         result = NSF_TRUE;
1923       }
1924     }
1925   }
1926   return result;
1927 }
1928 
1929 /*
1930  *----------------------------------------------------------------------
1931  * GetObjectFromObj --
1932  *
1933  *    Lookup a Next Scripting object from the given objPtr, preferably from
1934  *    an object of type "cmdName". On success the NsfObject is returned in the
1935  *    third argument. The objPtr might be converted by this function.
1936  *
1937  * Results:
1938  *    True or false,
1939  *
1940  * Side effects:
1941  *    object type of objPtr might be changed
1942  *
1943  *----------------------------------------------------------------------
1944  */
1945 static int GetObjectFromObj(
1946     Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr
1947 ) nonnull(1) nonnull(2) nonnull(3);
1948 
1949 static int
GetObjectFromObj(Tcl_Interp * interp,Tcl_Obj * objPtr,NsfObject ** objectPtr)1950 GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, NsfObject **objectPtr) {
1951   NsfObject    *object;
1952   const char   *string;
1953   Tcl_Command   cmd;
1954 
1955   nonnull_assert(interp != NULL);
1956   nonnull_assert(objPtr != NULL);
1957   nonnull_assert(objectPtr != NULL);
1958 
1959   /*fprintf(stderr, "GetObjectFromObj obj %p %s is of type %s\n",
1960     objPtr, ObjStr(objPtr), ObjTypeStr(objPtr));*/
1961 
1962   /*
1963    * Use the standard Tcl_GetCommandFromObj() which might convert the objPtr
1964    * to type cmdName.
1965    */
1966   cmd = Tcl_GetCommandFromObj(interp, objPtr);
1967 
1968   /*fprintf(stderr, "GetObjectFromObj obj %p %s (type %p) => cmd=%p (refCount %d)\n",
1969     objPtr, ObjStr(objPtr), objPtr->typePtr, cmd, (cmd != NULL) ? Tcl_Command_refCount(cmd) : -1);*/
1970 
1971   if (cmd != NULL) {
1972     NsfObject *cmdObject;
1973 
1974     /*
1975      * Tcl returned us a command. At least in Tcl 8.7, we cannot trust that
1976      * the returned cmd is still valid. Unfortunately, we can't check more
1977      * details here, since "struct ResolvedCmdName" is defined locally in
1978      * generic/tclObj.c. For cmd epochs>0 we take the conservative approach
1979      * not to trust in internal representation and fetch the cmd new.
1980      */
1981 
1982     cmdObject = NsfGetObjectFromCmdPtr(cmd);
1983 
1984     /* fprintf(stderr, "GetObjectFromObj obj %s, o is %p objProc %p NsfObjDispatch %p\n",
1985        ObjStr(objPtr), cmdObject, Tcl_Command_objProc(cmd), NsfObjDispatch);*/
1986 
1987     if (likely(cmdObject != NULL)) {
1988       *objectPtr = cmdObject;
1989       return TCL_OK;
1990     }
1991   }
1992   /*fprintf(stderr, "GetObjectFromObj convertFromAny for %s type %p %s\n", ObjStr(objPtr),
1993     objPtr->typePtr, ObjTypeStr(objPtr));*/
1994 
1995   /*
1996    * In case, we have to revolve via the CallingNameSpace (i.e. the argument
1997    * is not fully qualified), we retry here.
1998    */
1999   string = ObjStr(objPtr);
2000 
2001   if (isAbsolutePath(string)) {
2002     object = NULL;
2003   } else {
2004     Tcl_Obj    *tmpName = NameInNamespaceObj(string, CallingNameSpace(interp));
2005     const char *nsString = ObjStr(tmpName);
2006 
2007     INCR_REF_COUNT(tmpName);
2008     object = GetObjectFromString(interp, nsString);
2009     /* fprintf(stderr, " RETRY, string '%s' returned %p\n", nsString, object);*/
2010     DECR_REF_COUNT(tmpName);
2011   }
2012 
2013   if (likely(object != NULL)) {
2014     *objectPtr = object;
2015     return TCL_OK;
2016   }
2017 
2018   return TCL_ERROR;
2019 }
2020 
2021 /*
2022  *----------------------------------------------------------------------
2023  * NsfCallObjectUnknownHandler --
2024  *
2025  *    Call ::nsf::object::unknown; this function is typically called, when an unknown
2026  *    object or class is passed as an argument.
2027  *
2028  * Results:
2029  *    Tcl result code
2030  *
2031  * Side effects:
2032  *    Called handler might side effect.
2033  *
2034  *----------------------------------------------------------------------
2035  */
2036 
2037 static int NsfCallObjectUnknownHandler(
2038     Tcl_Interp *interp, Tcl_Obj *nameObj
2039 ) nonnull(1) nonnull(2);
2040 
2041 static int
NsfCallObjectUnknownHandler(Tcl_Interp * interp,Tcl_Obj * nameObj)2042 NsfCallObjectUnknownHandler(Tcl_Interp *interp, Tcl_Obj *nameObj) {
2043   int      result;
2044   Tcl_Obj *ov[3];
2045 
2046   nonnull_assert(interp != NULL);
2047   nonnull_assert(nameObj != NULL);
2048 
2049   /*fprintf(stderr, "try ::nsf::object::unknown for '%s'\n", ObjStr(nameObj));*/
2050 
2051   ov[0] = NsfGlobalObjs[NSF_OBJECT_UNKNOWN_HANDLER];
2052   ov[1] = nameObj;
2053 
2054   INCR_REF_COUNT(ov[1]);
2055   result = Tcl_EvalObjv(interp, 2, ov, 0);
2056   DECR_REF_COUNT(ov[1]);
2057 
2058   return result;
2059 }
2060 
2061 #if defined(NSF_EXPERIMENTAL)
2062 static int NsfCallArgumentUnknownHandler(
2063     Tcl_Interp *interp,
2064     Tcl_Obj *methodObj,
2065     Tcl_Obj *argumentObj,
2066     NsfObject *object
2067 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
2068 
2069 static int
NsfCallArgumentUnknownHandler(Tcl_Interp * interp,Tcl_Obj * methodObj,Tcl_Obj * argumentObj,NsfObject * object)2070 NsfCallArgumentUnknownHandler(
2071     Tcl_Interp *interp,
2072     Tcl_Obj *methodObj,
2073     Tcl_Obj *argumentObj,
2074     NsfObject *object
2075 ) {
2076   Tcl_Obj *ov[4];
2077   int      result, oc = 3;
2078 
2079   nonnull_assert(interp != NULL);
2080   nonnull_assert(methodObj != NULL);
2081   nonnull_assert(argumentObj != NULL);
2082   nonnull_assert(object != NULL);
2083 
2084   /*fprintf(stderr, "try ::nsf::argument::unknown for '%s'\n", ObjStr(nameObj));*/
2085 
2086   ov[0] = NsfGlobalObjs[NSF_ARGUMENT_UNKNOWN_HANDLER];
2087   ov[1] = methodObj;
2088   ov[2] = argumentObj;
2089   if (object != NULL) {
2090     ov[3] = object->cmdName;
2091     oc ++;
2092   }
2093 
2094   INCR_REF_COUNT(ov[1]);
2095   result = Tcl_EvalObjv(interp, oc, ov, 0);
2096   DECR_REF_COUNT(ov[1]);
2097 
2098   return result;
2099 }
2100 #endif
2101 
2102 /*
2103  *----------------------------------------------------------------------
2104  * GetClassFromObj --
2105  *
2106  *    Lookup a Next Scripting class from the given objPtr. If the class could
2107  *    not be directly converted and withUnknown is true, the function calls
2108  *    the unknown function (::nsf::object::unknown) to fetch the class on
2109  *    demand and retries the conversion.  On success the NsfClass is returned
2110  *    in the third argument. The objPtr might be converted by this function.
2111  *
2112  * Results:
2113  *    True or false,
2114  *
2115  * Side effects:
2116  *    object type of objPtr might be changed
2117  *
2118  *----------------------------------------------------------------------
2119  */
2120 
2121 static int
GetClassFromObj(Tcl_Interp * interp,register Tcl_Obj * objPtr,NsfClass ** classPtr,bool withUnknown)2122 GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr,
2123                 NsfClass **classPtr, bool withUnknown) {
2124   NsfObject   *object;
2125   NsfClass    *class;
2126   const char  *objName;
2127   Tcl_Command  cmd;
2128   int          result;
2129 
2130   nonnull_assert(interp != NULL);
2131   nonnull_assert(objPtr != NULL);
2132   nonnull_assert(classPtr != NULL);
2133 
2134   objName = ObjStr(objPtr);
2135   cmd = Tcl_GetCommandFromObj(interp, objPtr);
2136   /*fprintf(stderr, "GetClassFromObj %p %s unknown %d cmd %p\n", objPtr, objName, withUnknown, cmd);*/
2137 
2138   if (likely(cmd != NULL)) {
2139     class = NsfGetClassFromCmdPtr(cmd);
2140     if (class == NULL) {
2141       /*
2142        * We have a cmd, but no class; namespace-imported classes are already
2143        * resolved, but we have to care, if a class is "imported" via "interp
2144        * alias".
2145        */
2146       Tcl_Interp *alias_interp;
2147       const char *alias_cmd_name, *qualifiedObjName;
2148       Tcl_Obj    *nameObj = objPtr;
2149       Tcl_Obj   **alias_ov;
2150       int         alias_oc = 0;
2151 
2152       if (!isAbsolutePath(objName)) {
2153         nameObj = NameInNamespaceObj(objName, CallingNameSpace(interp));
2154         qualifiedObjName = ObjStr(nameObj);
2155         INCR_REF_COUNT(nameObj);
2156       } else {
2157         qualifiedObjName = objName;
2158       }
2159 
2160       result = Tcl_GetAliasObj(interp, qualifiedObjName,
2161                                &alias_interp, &alias_cmd_name, &alias_oc, &alias_ov);
2162       Tcl_ResetResult(interp);
2163 
2164       /*
2165        * We only want interp-aliases with 0 args
2166        */
2167       if (likely(result == TCL_OK) && likely(alias_oc == 0)) {
2168         cmd = NSFindCommand(interp, alias_cmd_name);
2169         /*fprintf(stderr, "..... alias arg 0 '%s' cmd %p\n", alias_cmd_name, cmd);*/
2170         if (cmd != NULL) {
2171           class = NsfGetClassFromCmdPtr(cmd);
2172         }
2173       }
2174 
2175       /*fprintf(stderr, "..... final cmd %p, class %p\n", cmd , class);*/
2176       if (nameObj != objPtr) {
2177         DECR_REF_COUNT(nameObj);
2178       }
2179     }
2180 
2181     if (likely(class != NULL)) {
2182       *classPtr = class;
2183       return TCL_OK;
2184     }
2185   }
2186 
2187   result = GetObjectFromObj(interp, objPtr, &object);
2188   if (likely(result == TCL_OK)) {
2189     class = NsfObjectToClass(object);
2190     if (likely(class != NULL)) {
2191       *classPtr = class;
2192       return TCL_OK;
2193     } else {
2194       /*
2195        * flag, that we could not convert so far
2196        */
2197       result = TCL_ERROR;
2198     }
2199   }
2200 
2201   if (withUnknown) {
2202     /*fprintf(stderr, "**** withUnknown 1 obj %s is shared %d\n", ObjStr(objPtr), Tcl_IsShared(objPtr));*/
2203     INCR_REF_COUNT(objPtr);
2204     result = NsfCallObjectUnknownHandler(interp, isAbsolutePath(objName) ? objPtr :
2205                                          NameInNamespaceObj(objName, CallingNameSpace(interp)));
2206     if (likely(result == TCL_OK)) {
2207       /*
2208        * Retry, but now, the last argument (withUnknown) has to be FALSE
2209        */
2210       result = GetClassFromObj(interp, objPtr, classPtr, NSF_FALSE);
2211     }
2212     DECR_REF_COUNT(objPtr);
2213     /*fprintf(stderr, "... ::nsf::object::unknown for '%s',
2214       result %d cl %p\n", objName, result, cl);*/
2215   }
2216 
2217   return result;
2218 }
2219 
2220 /*
2221  * Version of GetClassFromObj() with external symbol
2222  */
2223 int
NsfGetClassFromObj(Tcl_Interp * interp,Tcl_Obj * objPtr,NsfClass ** classPtr,bool withUnknown)2224 NsfGetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
2225                    NsfClass **classPtr, bool withUnknown) {
2226 
2227   nonnull_assert(interp != NULL);
2228   nonnull_assert(objPtr != NULL);
2229   nonnull_assert(classPtr != NULL);
2230 
2231   return GetClassFromObj(interp, objPtr, classPtr, withUnknown);
2232 }
2233 /*
2234  *----------------------------------------------------------------------
2235  * IsObjectOfType --
2236  *
2237  *    Check whether the provided NsfObject is of a certain type. The arguments
2238  *    "what" and "objPtr" are just used for the error messages. "objPtr" is
2239  *    the value from which the object was converted from.
2240  *
2241  * Results:
2242  *    Tcl result code.
2243  *
2244  * Side effects:
2245  *    None
2246  *
2247  *----------------------------------------------------------------------
2248  */
2249 
2250 static int IsObjectOfType(
2251     Tcl_Interp *interp, NsfObject *object, const char *what, Tcl_Obj *objPtr,
2252     const Nsf_Param *pPtr
2253 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
2254 
2255 static int
IsObjectOfType(Tcl_Interp * interp,NsfObject * object,const char * what,Tcl_Obj * objPtr,const Nsf_Param * pPtr)2256 IsObjectOfType(
2257     Tcl_Interp *interp, NsfObject *object, const char *what, Tcl_Obj *objPtr,
2258     const Nsf_Param *pPtr
2259 ) {
2260   NsfClass *class;
2261   int       result = TCL_ERROR;
2262 
2263   nonnull_assert(interp != NULL);
2264   nonnull_assert(object != NULL);
2265   nonnull_assert(what != NULL);
2266   nonnull_assert(objPtr != NULL);
2267   nonnull_assert(pPtr != NULL);
2268 
2269   if (unlikely((pPtr->flags & NSF_ARG_BASECLASS) != 0u)
2270       && !IsBaseClass(object)
2271      ) {
2272     what = "baseclass";
2273 
2274   } else if (unlikely((pPtr->flags & NSF_ARG_METACLASS) != 0u)
2275              && !IsMetaClass(interp, (NsfClass *)object, NSF_TRUE)
2276             ) {
2277     what = "metaclass";
2278 
2279   } else if (likely(pPtr->converterArg == NULL)) {
2280     result = TCL_OK;
2281 
2282   } else if (likely((GetClassFromObj(interp, pPtr->converterArg, &class, NSF_FALSE) == TCL_OK))
2283              && IsSubType(object->cl, class)
2284             ) {
2285     result = TCL_OK;
2286   }
2287 
2288   if (result == TCL_ERROR) {
2289     Tcl_DString ds, *dsPtr = &ds;
2290 
2291     DSTRING_INIT(dsPtr);
2292     Tcl_DStringAppend(dsPtr, what, -1);
2293     if (pPtr->converterArg != NULL) {
2294       Tcl_DStringAppend(dsPtr, " of type ", -1);
2295       Tcl_DStringAppend(dsPtr, ObjStr(pPtr->converterArg), -1);
2296     }
2297     NsfObjErrType(interp, NULL, objPtr, Tcl_DStringValue(dsPtr), (Nsf_Param *)pPtr);
2298     DSTRING_FREE(dsPtr);
2299   }
2300 
2301   return result;
2302 }
2303 
2304 /*
2305  *----------------------------------------------------------------------
2306  * NameInNamespaceObj --
2307  *
2308  *    Create a fully qualified name in the provided namespace or in
2309  *    the current namespace in form of a Tcl_Obj (with 0 refCount);
2310  *
2311  * Results:
2312  *    Tcl_Obj containing fully qualified name
2313  *
2314  * Side effects:
2315  *    Allocates fresh copies of list elements
2316  *
2317  *----------------------------------------------------------------------
2318  */
2319 static Tcl_Obj *
NameInNamespaceObj(const char * name,Tcl_Namespace * nsPtr)2320 NameInNamespaceObj(const char *name, Tcl_Namespace *nsPtr) {
2321   Tcl_Obj *objPtr;
2322   Tcl_DString ds, *dsPtr = &ds;
2323 
2324   nonnull_assert(name != NULL);
2325   nonnull_assert(nsPtr != NULL);
2326 
2327   /*fprintf(stderr, "NameInNamespaceObj %s (%p, %s) ", name, nsPtr, nsPtr->fullName);*/
2328 
2329   DSTRING_INIT(dsPtr);
2330   DStringAppendQualName(dsPtr, nsPtr, name);
2331   objPtr = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
2332 
2333   /*fprintf(stderr, "returns %s\n", ObjStr(objPtr));*/
2334   DSTRING_FREE(dsPtr);
2335   return objPtr;
2336 }
2337 
2338 /*
2339  *----------------------------------------------------------------------
2340  * NewTclCommand --
2341  *
2342  *    Given a provided prefix in dsPtr, make it a name of a command that does not exist.
2343  *    This function is used by the *new command, when "anonymous" objects are created
2344  *
2345  * Results:
2346  *    dsPtr will be complete to represent a new (unused) name of a command
2347  *
2348  * Side effects:
2349  *    None.
2350  *
2351  *----------------------------------------------------------------------
2352  */
2353 void NewTclCommand(Tcl_Interp *interp, Tcl_DString *dsPtr)
2354   nonnull(1) nonnull(2);
2355 
2356 void
NewTclCommand(Tcl_Interp * interp,Tcl_DString * dsPtr)2357 NewTclCommand(Tcl_Interp *interp, Tcl_DString *dsPtr) {
2358   int prefixLength;
2359   NsfStringIncrStruct *iss;
2360 
2361   nonnull_assert(interp != NULL);
2362   nonnull_assert(dsPtr != NULL);
2363 
2364   prefixLength = dsPtr->length;
2365   iss = &RUNTIME_STATE(interp)->iss;
2366 
2367   while (1) {
2368 
2369     (void)NsfStringIncr(iss);
2370     Tcl_DStringAppend(dsPtr, iss->start, (int)iss->length);
2371     if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, TCL_GLOBAL_ONLY)) {
2372       break;
2373     }
2374     /*
2375      * In case the symbol existed already, reset prefix to the
2376      * original length.
2377      */
2378     Tcl_DStringSetLength(dsPtr, prefixLength);
2379   }
2380 }
2381 
2382 /*
2383  *----------------------------------------------------------------------
2384  * NsfReverseClasses --
2385  *
2386  *    Reverse class list. Caller is responsible for freeing data.
2387  *
2388  * Results:
2389  *    Pointer to start of the reversed list
2390  *
2391  * Side effects:
2392  *    Allocates fresh copies of list elements
2393  *
2394  *----------------------------------------------------------------------
2395  */
2396 static NsfClasses *NsfReverseClasses(NsfClasses *sl)
2397   nonnull(1) returns_nonnull;
2398 
2399 static NsfClasses *
NsfReverseClasses(NsfClasses * sl)2400 NsfReverseClasses(NsfClasses *sl) {
2401   NsfClasses *firstPtr = NULL;
2402 
2403   nonnull_assert(sl != NULL);
2404 
2405   do {
2406     NsfClasses *element = NEW(NsfClasses);
2407 
2408     element->cl = sl->cl;
2409     element->clientData = sl->clientData;
2410     element->nextPtr = firstPtr;
2411     firstPtr = element;
2412 
2413     sl = sl->nextPtr;
2414   } while (likely(sl != NULL));
2415 
2416   return firstPtr;
2417 }
2418 
2419 /*
2420  *----------------------------------------------------------------------
2421  * NsfClassListFree --
2422  *
2423  *    Frees all elements of the provided class list
2424  *
2425  * Results:
2426  *    None.
2427  *
2428  * Side effects:
2429  *    Frees memory.
2430  *
2431  *----------------------------------------------------------------------
2432  */
2433 static void NsfClassListFree(NsfClasses *classList)
2434   nonnull(1);
2435 
2436 static void
NsfClassListFree(NsfClasses * classList)2437 NsfClassListFree(NsfClasses *classList) {
2438   NsfClasses *nextPtr;
2439 
2440  nonnull_assert(classList != NULL);
2441 
2442  do {
2443    nextPtr = classList->nextPtr;
2444    FREE(NsfClasses, classList);
2445    classList = nextPtr;
2446  } while (likely(classList != NULL));
2447 }
2448 
2449 /*
2450  *----------------------------------------------------------------------
2451  * NsfClassListAdd --
2452  *
2453  *    Add class list entry to the specified list. In case the initial
2454  *    list is empty, *firstPtrPtr is updated as well.
2455  *
2456  * Results:
2457  *    Returns address of next-pointer.
2458  *
2459  * Side effects:
2460  *    New list element is allocated.
2461  *
2462  *----------------------------------------------------------------------
2463  */
2464 
2465 static NsfClasses **
NsfClassListAdd(NsfClasses ** firstPtrPtr,NsfClass * class,ClientData clientData)2466 NsfClassListAdd(NsfClasses **firstPtrPtr, NsfClass *class, ClientData clientData) {
2467   NsfClasses *classListPtr, *element = NEW(NsfClasses);
2468 
2469   nonnull_assert(firstPtrPtr != NULL);
2470 
2471   element->cl = class;
2472   element->clientData = clientData;
2473   element->nextPtr = NULL;
2474 
2475   classListPtr = *firstPtrPtr;
2476   if (classListPtr != NULL) {
2477     while (classListPtr->nextPtr != NULL) {
2478       classListPtr = classListPtr->nextPtr;
2479     }
2480     classListPtr->nextPtr = element;
2481   } else {
2482     *firstPtrPtr = element;
2483   }
2484   return &(element->nextPtr);
2485 }
2486 
2487 /*
2488  *----------------------------------------------------------------------
2489  * NsfClassListAddNoDup --
2490  *
2491  *    Add class list entry to the specified list without duplicates. In case
2492  *    the initial list is empty, *firstPtrPtr is updated as well.
2493  *
2494  * Results:
2495  *    Returns address of next pointer.
2496  *
2497  * Side effects:
2498  *    New list element is allocated.
2499  *
2500  *----------------------------------------------------------------------
2501  */
2502 
2503 static NsfClasses **NsfClassListAddNoDup(NsfClasses **firstPtrPtr, NsfClass *class,
2504                                          ClientData clientData)
2505   nonnull(1) nonnull(2);
2506 
2507 static NsfClasses **
NsfClassListAddNoDup(NsfClasses ** firstPtrPtr,NsfClass * class,ClientData clientData)2508 NsfClassListAddNoDup(NsfClasses **firstPtrPtr, NsfClass *class, ClientData clientData) {
2509   NsfClasses *clPtr, **nextPtr;
2510 
2511   nonnull_assert(firstPtrPtr != NULL);
2512   nonnull_assert(class != NULL);
2513 
2514   clPtr = *firstPtrPtr;
2515   if (clPtr != NULL) {
2516     while ((clPtr->nextPtr != NULL) && (clPtr->cl != class)) {
2517       clPtr = clPtr->nextPtr;
2518     }
2519     nextPtr = &clPtr->nextPtr;
2520   } else {
2521     nextPtr = firstPtrPtr;
2522   }
2523 
2524   if (*nextPtr == NULL) {
2525     NsfClasses *element = NEW(NsfClasses);
2526 
2527     element->cl = class;
2528     element->clientData = clientData;
2529     element->nextPtr = NULL;
2530     *nextPtr = element;
2531   }
2532   return nextPtr;
2533 }
2534 
2535 /*
2536  *----------------------------------------------------------------------
2537  * NsfClassListFind --
2538  *
2539  *    Find an element in the class list and return it if found.
2540  *
2541  * Results:
2542  *    Found element or NULL
2543  *
2544  * Side effects:
2545  *    None.
2546  *
2547  *----------------------------------------------------------------------
2548  */
2549 static NsfClasses *NsfClassListFind(NsfClasses *clPtr, const NsfClass *class)
2550   nonnull(2) pure;
2551 
2552 static NsfClasses *
NsfClassListFind(NsfClasses * clPtr,const NsfClass * class)2553 NsfClassListFind(NsfClasses *clPtr, const NsfClass *class) {
2554 
2555   nonnull_assert(class != NULL);
2556 
2557   for (; clPtr != NULL; clPtr = clPtr->nextPtr) {
2558     if (clPtr->cl == class) {
2559       break;
2560     }
2561   }
2562   return clPtr;
2563 }
2564 
2565 #if defined(NSF_CLASSLIST_PRINT)
2566 /* debugging purposes only */
2567 /*
2568  *----------------------------------------------------------------------
2569  * NsfClassListStats --
2570  *
2571  *    Print some statistics about generated Class List structures for
2572  *    debugging purpose.
2573  *
2574  * Results:
2575  *    None.
2576  *
2577  * Side effects:
2578  *    None.
2579  *
2580  *----------------------------------------------------------------------
2581  */
2582 
2583 static void NsfClassListStats(const char *title, NsfClasses *classList)
2584   nonnull(1);
2585 
2586 static void
NsfClassListStats(const char * title,NsfClasses * classListPtr)2587 NsfClassListStats(const char *title, NsfClasses *classListPtr) {
2588   NsfClass *class;
2589   int count = 0;
2590 
2591   nonnull_assert(title != NULL);
2592 
2593   class = (classListPtr != NULL) ? classListPtr->cl : NULL;
2594   for (; classListPtr != NULL; classListPtr = classListPtr->nextPtr) {
2595     count++;
2596   }
2597 
2598   fprintf(stderr, "%s class list starting with %s has %d elements\n",
2599           title, (class != NULL) ? ClassName(class) : "none", count);
2600 }
2601 
2602 static void NsfClassListPrint(const char *title, NsfClasses *clsList)
2603   nonnull(1);
2604 
2605 static void
NsfClassListPrint(const char * title,NsfClasses * clsList)2606 NsfClassListPrint(const char *title, NsfClasses *clsList) {
2607 
2608   nonnull_assert(title != NULL);
2609 
2610   fprintf(stderr, "%s", title);
2611   /* fprintf(stderr, " %p:", clsList); */
2612   while (clsList != NULL) {
2613     /* fprintf(stderr, " %p", clsList->cl); */
2614     fprintf(stderr, " %p", clsList);
2615     fprintf(stderr, " %s", ClassName(clsList->cl));
2616     clsList = clsList->nextPtr;
2617   }
2618   fprintf(stderr, "\n");
2619 }
2620 #endif
2621 
2622 /*
2623  *----------------------------------------------------------------------
2624  * NsfClassListUnlink --
2625  *
2626  *    Return removed item with matching key form nsfClasses.
2627  *    Key is void to allow not only class pointers as keys.
2628  *
2629  * Results:
2630  *    unlinked element or NULL.
2631  *    In case the first element is unlinked, *firstPtrPtr
2632  *    is updated.
2633  *
2634  * Side effects:
2635  *    none.
2636  *
2637  *----------------------------------------------------------------------
2638  */
2639 static NsfClasses *NsfClassListUnlink(NsfClasses **firstPtrPtr, const void *key)
2640   nonnull(1) nonnull(2);
2641 
2642 static NsfClasses *
NsfClassListUnlink(NsfClasses ** firstPtrPtr,const void * key)2643 NsfClassListUnlink(NsfClasses **firstPtrPtr, const void *key) {
2644   NsfClasses *entryPtr;
2645 
2646   nonnull_assert(firstPtrPtr != NULL);
2647   nonnull_assert(key != NULL);
2648 
2649   if (*firstPtrPtr != NULL) {
2650     NsfClasses *prevPtr = NULL;
2651 
2652     /*
2653      * List is non-empty.
2654      */
2655     for (entryPtr = *firstPtrPtr;
2656          entryPtr != NULL;
2657          prevPtr = entryPtr, entryPtr = entryPtr->nextPtr
2658          ) {
2659       if ((void *)entryPtr->cl == key) {
2660         /*
2661          * Found entry.
2662          */
2663         if (prevPtr != NULL) {
2664           /*
2665            * Later item.
2666            */
2667           prevPtr->nextPtr = entryPtr->nextPtr;
2668         } else {
2669           /*
2670            * First item.
2671            */
2672           *firstPtrPtr = entryPtr->nextPtr;
2673         }
2674         entryPtr->nextPtr = NULL;
2675         break;
2676       }
2677     }
2678   } else {
2679     entryPtr = NULL;
2680   }
2681 
2682   return entryPtr;
2683 }
2684 
2685 
2686 /*
2687  * Functions for computing Precedence Order
2688  */
2689 
2690 /*
2691  *----------------------------------------------------------------------
2692  * TopoSortSub --
2693  *
2694  *    Performs a topological sort of the subclass hierarchy of a given
2695  *    class. The resulting list contains no duplicates or cycles and is
2696  *    returned in the class member "order". During computation, it colors
2697  *    the processed nodes in WHITE, GRAY or BLACK.
2698  *
2699  * Results:
2700  *    Boolean indicating whether a cycle was detected (0) or not (1); and,
2701  *    therefore, whether the sort failed (0) or succeeded (1).
2702  *
2703  * Side effects:
2704  *    Allocates class list.
2705  *
2706  *----------------------------------------------------------------------
2707  */
2708 
2709 enum colors { WHITE, GRAY, BLACK };
2710 
2711 static bool TopoSortSub(NsfClass *class, NsfClass *baseClass, bool withMixinOfs)
2712   nonnull(1) nonnull(2);
2713 
2714 static bool
TopoSortSub(NsfClass * class,NsfClass * baseClass,bool withMixinOfs)2715 TopoSortSub(NsfClass *class, NsfClass *baseClass, bool withMixinOfs) {
2716   NsfClasses *sl, *pl;
2717   bool        isAcyclic = NSF_TRUE;
2718 
2719   nonnull_assert(class != NULL);
2720   nonnull_assert(baseClass != NULL);
2721 
2722   sl = class->sub;
2723 
2724   /*
2725    * Be careful to reset the color of unreported classes to
2726    * white in case we unwind with error, and on final exit
2727    * reset color of reported classes to WHITE. Meaning of colors:
2728    *
2729    *     WHITE ... not processed
2730    *     GRAY  ... in work
2731    *     BLACK ... done
2732    */
2733 
2734   class->color = GRAY;
2735 
2736   for (; sl != NULL; sl = sl->nextPtr) {
2737     NsfClass *sc = sl->cl;
2738 
2739     if (sc->color == GRAY ||
2740         unlikely(sc->color == WHITE
2741                  && !TopoSortSub(sc, baseClass, withMixinOfs))
2742         ) {
2743       isAcyclic = NSF_FALSE;
2744       break;
2745     }
2746 
2747   }
2748 
2749   if (isAcyclic && withMixinOfs) {
2750     NsfCmdList *classMixins = ((class->opt != NULL) ? class->opt->isClassMixinOf : NULL);
2751 
2752     for (; classMixins != NULL; classMixins = classMixins->nextPtr) {
2753       NsfClass *sc = NsfGetClassFromCmdPtr(classMixins->cmdPtr);
2754 
2755       if (likely(sc != NULL)
2756           && unlikely(sc->color == WHITE &&
2757                       !TopoSortSub(sc, baseClass, withMixinOfs))) {
2758         NsfLog(sc->object.teardown, NSF_LOG_WARN,
2759                "cycle in the mixin graph list detected for class %s",
2760                ClassName_(sc));
2761       }
2762     }
2763   }
2764 
2765   class->color = BLACK;
2766   pl = NEW(NsfClasses);
2767   pl->cl = class;
2768   pl->nextPtr = baseClass->order;
2769   baseClass->order = pl;
2770 
2771   if (unlikely(class == baseClass)) {
2772     register const NsfClasses *pc;
2773 
2774     for (pc = class->order; pc != NULL; pc = pc->nextPtr) {
2775       pc->cl->color = WHITE;
2776     }
2777     assert(isAcyclic && baseClass->order != NULL);
2778   }
2779 
2780   return isAcyclic;
2781 }
2782 
2783 
2784 /*
2785  *----------------------------------------------------------------------
2786  * MustBeBefore --
2787  *
2788  *    Check the partial ordering of classes based on precedence list in the
2789  *    form of prior ordering from the topological sort. We compare here
2790  *    orderings based the class hierarchies with single inheritance and prior
2791  *    solved multiple inheritance orderings. The test is true, if b must be
2792  *    before a.
2793  *
2794  * Results:
2795  *    Boolean value indicating success.
2796  *
2797  * Side effects:
2798  *    None.
2799  *
2800  *----------------------------------------------------------------------
2801  */
2802 static bool MustBeBefore(const NsfClass *aClass, const NsfClass *bClass, const NsfClasses *superClasses)
2803   nonnull(1) nonnull(2) nonnull(3) pure;
2804 
2805 static bool
MustBeBefore(const NsfClass * aClass,const NsfClass * bClass,const NsfClasses * superClasses)2806 MustBeBefore(const NsfClass *aClass, const NsfClass *bClass, const NsfClasses *superClasses) {
2807   bool success;
2808 
2809   nonnull_assert(aClass != NULL);
2810   nonnull_assert(bClass != NULL);
2811   nonnull_assert(superClasses != NULL);
2812   assert(bClass->order != NULL);
2813 
2814   /*
2815    * Check whether a is in the precedence order of b. E.g.
2816    *
2817    *   a c1 object
2818    *   b c2 a object
2819    *
2820    * If so then b must be before a to preserve the precedence order based on
2821    * single inheritance (monotonicity).
2822    */
2823   success = (NsfClassListFind(bClass->order, aClass) != NULL);
2824 
2825   /*
2826    * When the partital ordering can't be decided based on the local order
2827    * test, we take the specified multiple inheritance ordering in superClasses
2828    * (e.g. coming from -superclass {x y}) which is not taken account by the
2829    * class hierarchy.
2830    */
2831   if (!success) {
2832     const NsfClasses *sl;
2833     bool              found = NSF_FALSE;
2834 
2835 #if defined(NSF_LINEARIZER_TRACE)
2836     fprintf(stderr, "--> check %s before %s?\n", ClassName(b), ClassName(a));
2837     NsfClassListPrint("superClasses", superClasses);
2838 #endif
2839     for (sl = superClasses; sl != NULL; sl = sl->nextPtr) {
2840       if (sl->cl == bClass) {
2841         found = NSF_TRUE;
2842       } else if (found && sl->cl == aClass) {
2843 #if defined(NSF_LINEARIZER_TRACE)
2844         fprintf(stderr, "%s in inheritanceList before %s therefore a < b\n",
2845                 ClassName(bClass), ClassName(aClass));
2846 #endif
2847         success = NSF_TRUE;
2848         break;
2849       }
2850     }
2851   }
2852 
2853 #if defined(NSF_LINEARIZER_TRACE)
2854   fprintf(stderr, "compare a: %s %p b: %s %p -> %d\n",
2855           ClassName(aClass), aClass->order,
2856           ClassName(bClass), bClass->order, (int)success);
2857   NsfClassListPrint("\ta", aClass->order);
2858   NsfClassListPrint("\tb", bClass->order);
2859 #endif
2860   return success;
2861 }
2862 
2863 
2864 /*
2865  *----------------------------------------------------------------------
2866  * ValidClassListTail --
2867  *
2868  *    Debug function to assure that the provided class lists are valid. The
2869  *    tail of the class list must be a base class of the current object
2870  *    system.
2871  *
2872  * Results:
2873  *    None.
2874  *
2875  * Side effects:
2876  *    None.
2877  *
2878  *----------------------------------------------------------------------
2879  */
2880 #if defined(NSF_DEVELOPMENT_TEST)
ValidClassListTail(const char * what,NsfClasses * classListPtr)2881 static void ValidClassListTail(const char *what, NsfClasses *classListPtr) {
2882   NsfClasses *sl, *tail;
2883 
2884   for (sl = classListPtr, tail = NULL; sl != NULL; sl = sl->nextPtr) {
2885     tail = sl;
2886   }
2887   if (tail != NULL) {
2888     /* fprintf(stderr, "check tail what %s %p\n", what, ClassName(tail->cl), tail->nextPtr);*/
2889     assert(IsBaseClass(&tail->cl->object));
2890     assert(tail->nextPtr == NULL);
2891   }
2892 }
2893 #else
2894 # define ValidClassListTail(what, classListPtr)
2895 #endif
2896 
2897 /*
2898  *----------------------------------------------------------------------
2899  * MergeInheritanceLists --
2900  *
2901  *    Merge the PrecedenceOrders of class cl. This function is called, when cl
2902  *    is defined with multiple inheritance. The precedence orders of the
2903  *    specified classes are merged in an order preserving manner to achieve
2904  *    monotonicity.
2905  *
2906  * Results:
2907  *    precedence order.
2908  *
2909  * Side effects:
2910  *    None.
2911  *
2912  *----------------------------------------------------------------------
2913  */
2914 static NsfClasses *MergeInheritanceLists(NsfClasses *pl, NsfClass *class)
2915   nonnull(1) nonnull(2) returns_nonnull;
2916 
2917 static NsfClasses *
MergeInheritanceLists(NsfClasses * pl,NsfClass * class)2918 MergeInheritanceLists(NsfClasses *pl, NsfClass *class) {
2919   NsfClasses *sl, *baseList, **plNext, *superClasses,
2920     *deletionList = NULL;
2921 
2922   nonnull_assert(pl != NULL);
2923   nonnull_assert(class != NULL);
2924 
2925 #if defined(NSF_LINEARIZER_TRACE)
2926   fprintf(stderr, "=== MergeInheritanceLists working on %s\n", ClassName(class));
2927 #endif
2928 
2929   /*
2930    * The available multiple inheritance list is in reversed order so we have
2931    * to reverse it to obtain the specified superClasses in the provided order.
2932    */
2933   superClasses = NsfReverseClasses(class->super);
2934 
2935   /*
2936    * We distinguish between a
2937    *
2938    *  - baseList (which might be later a result of partial merges), and a
2939    *  - mergeList, which is merged order-preserving into the baseList.
2940    *
2941    * The first baseList is the precedence list of the first element of the
2942    * specified superClasses.
2943    */
2944 
2945   baseList = superClasses->cl->order;
2946   assert(baseList != NULL);
2947 
2948 #if defined(NSF_LINEARIZER_TRACE)
2949   fprintf(stderr, "=== baseList from %s = %p\n", ClassName(superClasses->cl), baseList);
2950   NsfClassListPrint("baseList", baseList);
2951 #endif
2952 
2953   /*
2954    * The first element of the result list of the merge operation is the first
2955    * element of the baseList.
2956    */
2957   plNext = NsfClassListAdd(&pl, baseList->cl, NULL);
2958 
2959   /*
2960    * For every element but the first (which is already in baseList), we have to
2961    * perform the merge operation. For n elements in superClasses, the merge
2962    * operation is performed n-1 times.
2963    */
2964 
2965   sl = superClasses->nextPtr;
2966   assert(superClasses->nextPtr != NULL);
2967 
2968   do {
2969     NsfClasses *mergeList = sl->cl->order, *baseListCurrent;
2970 
2971 #if defined(NSF_LINEARIZER_TRACE)
2972     NsfClassListPrint("mergeList", mergeList);
2973 #endif
2974 
2975     /*
2976      * Merge mergeList into baseList. We start with the 2nd (later probably
2977      * nth) entry of the baseList
2978      */
2979     baseListCurrent = baseList->nextPtr;
2980     assert(baseListCurrent != NULL);
2981 
2982     while (mergeList != NULL) {
2983       NsfClass *addClass;
2984 
2985       ValidClassListTail("baseList",  baseList);
2986       ValidClassListTail("mergeList", mergeList);
2987 
2988       assert(baseListCurrent != NULL);
2989       /* NsfClassListPrint("baseListCurrent", baseListCurrent); */
2990 
2991       if (mergeList->cl == baseListCurrent->cl) {
2992         /*
2993          * The first element of mergeList and the current baseList element are
2994          * identical. The element is in the result, keep the element in the
2995          * result, advance in both lists.
2996          */
2997         /* fprintf(stderr, "\t\tadvance both\n"); */
2998         addClass = mergeList->cl;
2999         baseListCurrent = baseListCurrent->nextPtr;
3000         mergeList = mergeList->nextPtr;
3001 
3002       } else if (MustBeBefore(baseListCurrent->cl, mergeList->cl, superClasses)) {
3003         /*
3004          * Check whether current element of mergeList must be before the current
3005          * element of baseList. If so, insert current mergelist element before
3006          * baseListCurrent,
3007          */
3008         addClass  = mergeList->cl;
3009         mergeList = mergeList->nextPtr;
3010         /* fprintf(stderr, "\t\tadd from mergeList %s\n", ClassName(addClass)); */
3011 
3012       } else {
3013         /*
3014          * Two cases above do not apply, add from baseList and advance
3015          * baseList pointer.
3016          */
3017         addClass = baseListCurrent->cl;
3018         baseListCurrent = baseListCurrent->nextPtr;
3019         /* fprintf(stderr, "\t\tadd from baselist %s\n", ClassName(addClass)); */
3020       }
3021 
3022       if (addClass != NULL) {
3023         /*
3024          * We have to add an element to the precedence list. When the class to
3025          * be added is already in the result list (which might happen just in
3026          * crippled cases) then delete it. In the final step it will be added
3027          * again to the end.
3028          */
3029         NsfClasses *deletedElement = NsfClassListUnlink(&pl, addClass);
3030 
3031         if (deletedElement != NULL) {
3032 #if defined(NSF_LINEARIZER_TRACE)
3033           fprintf(stderr, "\t\t%s is redundant (in resultList)\n", ClassName(addClass));
3034 #endif
3035           /*
3036            * When plNext points to the nextPtr of the deleted element, search
3037            * the list from the begin
3038            */
3039           if (plNext == &(deletedElement->nextPtr)) {
3040             plNext = &pl;
3041           }
3042           NsfClassListFree(deletedElement);
3043         }
3044 
3045         /*
3046          * Add the new element.
3047          */
3048         plNext = NsfClassListAdd(plNext, addClass, NULL);
3049       }
3050 
3051 #if defined(NSF_LINEARIZER_TRACE)
3052       NsfClassListPrint("pl:", pl);
3053 #endif
3054     }
3055     /*
3056      * mergeList is processed, we have a final precedence list in pl.  In case
3057      * are at then of superClasses, we are done. Otherwise, use the resulting
3058      * pl as next baseList and continue with the next mergeList from
3059      * superClasses.
3060      */
3061 #if defined(NSF_LINEARIZER_TRACE)
3062     NsfClassListPrint("plFinal:", pl);
3063 #endif
3064 
3065     if (sl->nextPtr != NULL) {
3066       /*
3067        * We are not at the end, use pl as new base list.
3068        */
3069       baseList = pl;
3070 
3071 #if defined(NSF_LINEARIZER_TRACE)
3072       fprintf(stderr, "=== setting new baseList\n");
3073       NsfClassListPrint("new baseList", baseList);
3074 #endif
3075       /*
3076        * Add old pl to deletion list; these entries are deleted once merging
3077        * is finished.
3078        */
3079       NsfClassListAdd(&deletionList, NULL, pl);
3080 
3081       /*
3082        * Create a fresh pl for the next iteration.
3083        */
3084       pl = NULL;
3085       plNext = NsfClassListAdd(&pl, class, NULL);
3086     }
3087     /*
3088      * Get next element from the list.
3089      */
3090     sl = sl->nextPtr;
3091   } while (sl != NULL);
3092 
3093   for (sl = deletionList; sl != NULL; sl = sl->nextPtr) {
3094     /* fprintf(stderr, "delete from deletion list %p client data %p\n", sl, sl->clientData); */
3095     NsfClassListFree(sl->clientData);
3096   }
3097 
3098   if (deletionList != NULL) {
3099     NsfClassListFree(deletionList);
3100   }
3101   NsfClassListFree(superClasses);
3102 
3103   return pl;
3104 }
3105 
3106 #if defined(NSF_DEVELOPMENT_TEST)
AssertOrderIsWhite(NsfClasses * order)3107 static void AssertOrderIsWhite(NsfClasses *order) {
3108   register NsfClasses *pc;
3109 
3110   for (pc = order; pc != NULL; pc = pc->nextPtr) {
3111     assert(pc->cl->color == WHITE);
3112   }
3113 }
3114 #else
3115 # define AssertOrderIsWhite(arg)
3116 #endif
3117 
3118 /*
3119  *----------------------------------------------------------------------
3120  * TopoSortSuper --
3121  *
3122  *    Compute the precedence order for baseClass based on the superclasses. If
3123  *    the order is computable, update base class and return NSF_TRUE. Otherwise
3124  *    return NSF_FALSE.
3125  *
3126  * Results:
3127  *    Boolean indicating success
3128  *
3129  * Side effects:
3130  *    None.
3131  *
3132  *----------------------------------------------------------------------
3133  */
3134 static bool TopoSortSuper(NsfClass *class, NsfClass *baseClass)
3135   nonnull(1) nonnull(2);
3136 
3137 static bool
TopoSortSuper(NsfClass * class,NsfClass * baseClass)3138 TopoSortSuper(NsfClass *class, NsfClass *baseClass) {
3139   NsfClasses *pl, *sl;
3140 
3141   nonnull_assert(class != NULL);
3142   nonnull_assert(baseClass != NULL);
3143 
3144   /*
3145    * Be careful to reset the color of unreported classes to
3146    * white in the caller on all exits to WHITE.
3147    *
3148    *     WHITE ... not processed
3149    *     GRAY  ... in work
3150    *     BLACK ... done
3151    */
3152 
3153   class->color = GRAY;
3154   for (sl = class->super; likely(sl != NULL); sl = sl->nextPtr) {
3155     NsfClass *sc = sl->cl;
3156 
3157     if (sc->color == GRAY) {
3158       class->color = WHITE;
3159       return NSF_FALSE;
3160     }
3161     if (unlikely(sc->color == WHITE && !TopoSortSuper(sc, baseClass))) {
3162       class->color = WHITE;
3163       return NSF_FALSE;
3164     }
3165   }
3166 
3167   /*
3168    * Create a new precedence list containing cl.
3169    */
3170   pl = NEW(NsfClasses);
3171   pl->cl = class;
3172   pl->nextPtr = NULL;
3173 
3174   /*
3175    * If we have multiple inheritance we merge the precomputed inheritance
3176    * orders of the involved classes in the provided order.
3177    */
3178   if (likely(class->super != NULL) && unlikely(class->super->nextPtr != NULL)) {
3179 
3180     pl = MergeInheritanceLists(pl, class);
3181 
3182     if (baseClass->order != NULL) {
3183       NsfClassListFree(baseClass->order);
3184       /*
3185        * baseClass->order is reset below.
3186        */
3187     }
3188 
3189 
3190   } else {
3191     /*
3192      * Add baseClass order to the end of the precedence list.
3193      */
3194 
3195     assert(pl->nextPtr == NULL);
3196     pl->nextPtr = baseClass->order;
3197   }
3198 
3199   class->color = BLACK;
3200   /*
3201    * Set baseClass order to the newly computed list (the result of this
3202    * function).
3203    */
3204   baseClass->order = pl;
3205 
3206   return NSF_TRUE;
3207 }
3208 
3209 
3210 /*
3211  *----------------------------------------------------------------------
3212  * PrecedenceOrder --
3213  *
3214  *    Return a class list containing the transitive list of superclasses
3215  *    starting with (and containing) the provided class. The superclass list
3216  *    is cached in cl->order and has to be invalidated by FlushPrecedences()
3217  *    in case the order changes. The caller does not have to free the returned
3218  *    class list (like for TransitiveSubClasses);
3219  *
3220  * Results:
3221  *    Class list, NULL on error
3222  *
3223  * Side effects:
3224  *    Updating cl->order.
3225  *
3226  *----------------------------------------------------------------------
3227  */
3228 NSF_INLINE static NsfClasses *
PrecedenceOrder(NsfClass * class)3229 PrecedenceOrder(NsfClass *class) {
3230   register const NsfClasses *sl;
3231   bool                       success, haveMultipleInheritance;
3232 
3233   nonnull_assert(class != NULL);
3234 
3235   /*
3236    * Check, of the superclass order is already cached.
3237    */
3238   if (likely(class->order != NULL)) {
3239     return class->order;
3240   }
3241 
3242   /*
3243    * For multiple inheritance (more than one superclass), make sure that
3244    * required precedence orders are precomputed. But first check whether we
3245    * have to do this rather expensive operation now, or we can do it
3246    * lazily. We can't do this in MergeInheritanceLists() within
3247    * TopoSortSuper(), since there the class node coloring might be half done.
3248    */
3249   haveMultipleInheritance = NSF_FALSE;
3250   for (sl = class->super; sl != NULL; sl = sl->cl->super) {
3251     if (sl != NULL && sl->nextPtr != NULL) {
3252       haveMultipleInheritance = NSF_TRUE;
3253       break;
3254     }
3255   }
3256 
3257   if (unlikely(haveMultipleInheritance)) {
3258     /*
3259      * In the class hierarchy is somewhere a place with multiple
3260      * inheritance. All precedence orders of superclasses must be computed,
3261      * otherwise merging of sublists will not work.
3262      */
3263 
3264     for (sl = class->super; sl != NULL; sl = sl->nextPtr) {
3265       const NsfClasses *pl;
3266 
3267 #if defined(NSF_LINEARIZER_TRACE)
3268       fprintf(stderr, "====== PrecedenceOrder multiple inheritance: check %s %p \n",
3269               ClassName(sl->cl), sl->cl->order);
3270 #endif
3271       if (unlikely(sl->cl->order == NULL) && likely(class != sl->cl)) {
3272 #if defined(NSF_LINEARIZER_TRACE)
3273         fprintf(stderr, "====== PrecedenceOrder multiple inheritance computes required order for %s \n",
3274                 ClassName(sl->cl));
3275 #endif
3276         PrecedenceOrder(sl->cl);
3277 #if defined(NSF_LINEARIZER_TRACE)
3278         NsfClassListPrint("====== PrecedenceOrder multiple inheritance:", sl->cl->order);
3279 #endif
3280       }
3281 
3282       for (pl = sl->cl->order; pl != NULL; pl = pl->nextPtr) {
3283 #if defined(NSF_LINEARIZER_TRACE)
3284         fprintf(stderr, "====== PrecedenceOrder multiple inheritance: %s %p\n",
3285                 ClassName(pl->cl), pl->cl->order);
3286 #endif
3287         if (pl->cl->order == NULL) {
3288 #if defined(NSF_LINEARIZER_TRACE)
3289           fprintf(stderr, "========== recurse\n");
3290 #endif
3291           PrecedenceOrder(pl->cl);
3292         }
3293       }
3294     }
3295   }
3296 
3297   success = TopoSortSuper(class, class);
3298 
3299   /*
3300    * Reset the color of all nodes.
3301    */
3302   for (sl = class->order; sl != NULL; sl = sl->nextPtr) {
3303     sl->cl->color = WHITE;
3304   }
3305 
3306   /*
3307    * If computation is successful, return cl->order.
3308    * Otherwise clear cl->order if necessary.
3309    */
3310   if (likely(success)) {
3311     AssertOrderIsWhite(class->order);
3312     /*
3313      * TopoSortSuper succeeded, the cl-order is already set.
3314      */
3315   } else if (class->order != NULL) {
3316     /*
3317      * TopoSortSuper failed, but there is a computed cl->order. Flush it.
3318      */
3319     NsfClassListFree(class->order);
3320     class->order = NULL;
3321   } else {
3322     /*
3323      * TopoSortSuper failed, but there is no computed cl->order. Nothing to
3324      * do.
3325      */
3326   }
3327 
3328 #if defined(NSF_LINEARIZER_TRACE)
3329   NsfClassListPrint("!!! PrecedenceOrder computed", class->order);
3330 #endif
3331 
3332   return class->order;
3333 }
3334 
3335 /*
3336  *----------------------------------------------------------------------
3337  * GetSubClasses --
3338  *
3339  *    Return a class list containing the transitive or dependent subclasses
3340  *    starting with (and containing) the provided class. The caller has to
3341  *    free the returned class list.
3342  *
3343  * Results:
3344  *    Class list, at least with one element (i.e., the provided class).
3345  *
3346  * Side effects:
3347  *    None.
3348  *
3349  *----------------------------------------------------------------------
3350  */
3351 
3352 NSF_INLINE static NsfClasses *
3353 GetSubClasses(NsfClass *class, bool withMixinOfs)
3354   nonnull(1) returns_nonnull;
3355 
3356 #define TransitiveSubClasses(class)                         \
3357   GetSubClasses((class), NSF_FALSE)
3358 
3359 #define DependentSubClasses(class)                         \
3360   GetSubClasses((class), NSF_TRUE)
3361 
3362 NSF_INLINE static NsfClasses *
GetSubClasses(NsfClass * class,bool withMixinOfs)3363 GetSubClasses(NsfClass *class, bool withMixinOfs) {
3364   NsfClasses *order, *savedOrder;
3365 
3366   nonnull_assert(class != NULL);
3367 
3368   /*
3369    * Since TopoSort() places its result in cl->order, we have to save the old
3370    * cl->order, perform the computation, and restore the old order.
3371    */
3372   savedOrder = class->order;
3373   class->order = NULL;
3374 
3375   (void)TopoSortSub(class, class, withMixinOfs);
3376 
3377   order = class->order;
3378   assert(order != NULL);
3379 
3380   AssertOrderIsWhite(order);
3381 
3382   class->order = savedOrder;
3383   return order;
3384 }
3385 
3386 /*
3387  *----------------------------------------------------------------------
3388  * FlushPrecedences --
3389  *
3390  *    This function iterations over the provided class list and flushes (and
3391  *    frees) the superclass caches in cl->order for every element.
3392  *
3393  * Results:
3394  *    None.
3395  *
3396  * Side effects:
3397  *    Freeing class lists cached in cl->order.
3398  *
3399  *----------------------------------------------------------------------
3400  */
3401 static void FlushPrecedences(const NsfClasses *subClasses)
3402   nonnull(1);
3403 
3404 static void
FlushPrecedences(const NsfClasses * subClasses)3405 FlushPrecedences(const NsfClasses *subClasses) {
3406 
3407   nonnull_assert(subClasses != NULL);
3408 
3409   do {
3410     if (subClasses->cl->order != NULL) {
3411       NsfClassListFree(subClasses->cl->order);
3412     }
3413     subClasses->cl->order = NULL;
3414     subClasses = subClasses->nextPtr;
3415   } while (subClasses != NULL);
3416 }
3417 
3418 
3419 /*
3420  *----------------------------------------------------------------------
3421  * AddInstance --
3422  *
3423  *    Add an instance to a class.
3424  *
3425  * Results:
3426  *    None.
3427  *
3428  * Side effects:
3429  *    Add entry to children hash-table.
3430  *
3431  *----------------------------------------------------------------------
3432  */
3433 static void AddInstance(NsfObject *object, NsfClass *class)
3434   nonnull(1) nonnull(2);
3435 
3436 static void
AddInstance(NsfObject * object,NsfClass * class)3437 AddInstance(NsfObject *object, NsfClass *class) {
3438   int isNewItem;
3439 
3440   nonnull_assert(object != NULL);
3441   nonnull_assert(class != NULL);
3442 
3443   object->cl = class;
3444   (void) Tcl_CreateHashEntry(&class->instances, (char *)object, &isNewItem);
3445   /*if (newItem == 0) {
3446     fprintf(stderr, "instance %p %s was already an instance of %p %s\n", object, ObjectName(object), cl, ClassName(class));
3447     }*/
3448   assert(isNewItem != 0);
3449 }
3450 
3451 
3452 /*
3453  *----------------------------------------------------------------------
3454  * RemoveInstance --
3455  *
3456  *    Remove an instance from a class. The function checks, whether the entry
3457  *    is actually still an instance before it deletes it.
3458  *
3459  * Results:
3460  *    void
3461  *
3462  * Side effects:
3463  *    Entry deleted from instances hash-table
3464  *
3465  *----------------------------------------------------------------------
3466  */
3467 static void RemoveInstance(const NsfObject *object, NsfClass *class)
3468   nonnull(1) nonnull(2);
3469 
3470 static void
RemoveInstance(const NsfObject * object,NsfClass * class)3471 RemoveInstance(const NsfObject *object, NsfClass *class) {
3472 
3473   nonnull_assert(object != NULL);
3474   nonnull_assert(class != NULL);
3475 
3476   /*
3477    * If we are during a delete, which should not happen under normal
3478    * operations, prevent an abort due to a deleted hash table.
3479    */
3480   if (unlikely(class->object.flags & NSF_DURING_DELETE) != 0u) {
3481     NsfLog(class->object.teardown, NSF_LOG_WARN,
3482            "The class %s, from which an instance is to be removed, is currently under deletion",
3483             ObjStr((class)->object.cmdName));
3484   } else {
3485     Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&class->instances, (char *)object, NULL);
3486 
3487     /*if (hPtr == NULL) {
3488       fprintf(stderr, "instance %s is not an instance of %s\n", ObjectName(object), ClassName(class));
3489       }*/
3490     assert(hPtr != NULL);
3491     Tcl_DeleteHashEntry(hPtr);
3492   }
3493 }
3494 
3495 /*
3496  * superclass/subclass list maintenance
3497  */
3498 static void AddSuper1(NsfClass *class, NsfClasses **sl)
3499   nonnull(1) nonnull(2);
3500 static void AddSuper(NsfClass *class, NsfClass *superClass)
3501   nonnull(1);
3502 static bool RemoveSuper1(NsfClass *class, NsfClasses **sl)
3503   nonnull(1) nonnull(2);
3504 static bool RemoveSuper(NsfClass *class, NsfClass *superClass)
3505   nonnull(1) nonnull(2);
3506 
3507 static void
AddSuper1(NsfClass * class,NsfClasses ** sl)3508 AddSuper1(NsfClass *class, NsfClasses **sl) {
3509   NsfClasses *sc = NEW(NsfClasses);
3510 
3511   nonnull_assert(class != NULL);
3512   nonnull_assert(sl != NULL);
3513 
3514   sc->cl = class;
3515   sc->nextPtr = *sl;
3516   *sl = sc;
3517 }
3518 
3519 static void
AddSuper(NsfClass * class,NsfClass * superClass)3520 AddSuper(NsfClass *class, NsfClass *superClass) {
3521 
3522   nonnull_assert(class != NULL);
3523 
3524   if (superClass != NULL) {
3525     /*
3526      * keep corresponding sub in step with super
3527      */
3528     AddSuper1(superClass, &class->super);
3529     AddSuper1(class, &superClass->sub);
3530   }
3531 }
3532 
3533 static bool
RemoveSuper1(NsfClass * class,NsfClasses ** sl)3534 RemoveSuper1(NsfClass *class, NsfClasses **sl) {
3535   NsfClasses *l;
3536   bool        result;
3537 
3538   nonnull_assert(class != NULL);
3539   nonnull_assert(sl != NULL);
3540 
3541   l = *sl;
3542 
3543   if (l == NULL) {
3544     result = NSF_FALSE;
3545 
3546   } else if (l->cl == class) {
3547     *sl = l->nextPtr;
3548     FREE(NsfClasses, l);
3549     result = NSF_TRUE;
3550 
3551   } else {
3552     while ((l->nextPtr != NULL) && (l->nextPtr->cl != class)) {
3553       l = l->nextPtr;
3554     }
3555     if (l->nextPtr != NULL) {
3556       NsfClasses *n = l->nextPtr->nextPtr;
3557       FREE(NsfClasses, l->nextPtr);
3558       l->nextPtr = n;
3559       result = NSF_TRUE;
3560     } else {
3561       result = NSF_FALSE;
3562     }
3563   }
3564   return result;
3565 }
3566 
3567 static bool
RemoveSuper(NsfClass * class,NsfClass * superClass)3568 RemoveSuper(NsfClass *class, NsfClass *superClass) {
3569   bool sp, sb;
3570 
3571   nonnull_assert(class != NULL);
3572   nonnull_assert(superClass != NULL);
3573 
3574   /*
3575    * Keep corresponding sub in step with super
3576    */
3577 
3578   sp = RemoveSuper1(superClass, &class->super);
3579   sb = RemoveSuper1(class, &superClass->sub);
3580 
3581   return sp && sb;
3582 }
3583 
3584 /*
3585  * methods lookup
3586  */
3587 
3588 /*
3589  *----------------------------------------------------------------------
3590  * GetEnsembleObjectFromName --
3591  *
3592  *    Get an ensemble object from a method name.  If the method name
3593  *    is fully qualified, just use a Tcl lookup, otherwise get it from
3594  *    the provided namespace,
3595  *
3596  * Results:
3597  *    ensemble object or NULL
3598  *
3599  * Side effects:
3600  *    none
3601  *
3602  *----------------------------------------------------------------------
3603  */
3604 static NsfObject *GetEnsembleObjectFromName(
3605     Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *nameObj,
3606     Tcl_Command *cmdPtr, bool *fromClassNS
3607 ) nonnull(1) nonnull(3) nonnull(4) nonnull(5);
3608 
3609 static NsfObject *
GetEnsembleObjectFromName(Tcl_Interp * interp,Tcl_Namespace * nsPtr,Tcl_Obj * nameObj,Tcl_Command * cmdPtr,bool * fromClassNS)3610 GetEnsembleObjectFromName(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *nameObj,
3611                          Tcl_Command *cmdPtr, bool *fromClassNS) {
3612   Tcl_Command  cmd;
3613   const char  *nameString;
3614   NsfObject   *result;
3615 
3616   nonnull_assert(interp != NULL);
3617   nonnull_assert(nameObj != NULL);
3618   nonnull_assert(cmdPtr != NULL);
3619   nonnull_assert(fromClassNS != NULL);
3620 
3621   nameString = ObjStr(nameObj);
3622   if (*nameString == ':') {
3623     cmd = Tcl_GetCommandFromObj(interp, nameObj);
3624     *fromClassNS = IsClassNsName(nameString, NULL);
3625   } else {
3626     cmd = (nsPtr != NULL) ? FindMethod(nsPtr, nameString) : NULL;
3627   }
3628 
3629   if (cmd != NULL) {
3630     *cmdPtr = cmd;
3631     result = NsfGetObjectFromCmdPtr(GetOriginalCommand(cmd));
3632   } else {
3633     result = NULL;
3634   }
3635   return result;
3636 }
3637 
3638 /*
3639  *----------------------------------------------------------------------
3640  * GetRegObject --
3641  *
3642  *    Try to get the object, on which the method was registered from a
3643  *    fully qualified method handle
3644  *
3645  * Results:
3646  *    NsfObject * or NULL on failure
3647  *
3648  * Side effects:
3649  *    none
3650  *
3651  *----------------------------------------------------------------------
3652  */
3653 static NsfObject *GetRegObject(Tcl_Interp *interp, Tcl_Command cmd, const char *methodName,
3654                                const char **methodName1, bool *fromClassNS)
3655   nonnull(1) nonnull(3) nonnull(5) nonnull(2);
3656 
3657 static NsfObject *
GetRegObject(Tcl_Interp * interp,Tcl_Command cmd,const char * methodName,const char ** methodName1,bool * fromClassNS)3658 GetRegObject(Tcl_Interp *interp, Tcl_Command cmd, const char *methodName,
3659              const char **methodName1, bool *fromClassNS) {
3660   NsfObject  *regObject;
3661   const char *procName;
3662   size_t      objNameLength;
3663 
3664   nonnull_assert(interp != NULL);
3665   nonnull_assert(cmd != NULL);
3666   nonnull_assert(methodName != NULL);
3667   assert(*methodName == ':');
3668   nonnull_assert(fromClassNS != NULL);
3669   nonnull_assert(cmd != NULL);
3670 
3671   procName = Tcl_GetCommandName(interp, cmd);
3672   objNameLength = strlen(methodName) - strlen(procName) - 2;
3673 
3674   if (objNameLength > 0) {
3675     Tcl_DString ds, *dsPtr = &ds;
3676 
3677     /*
3678      * Obtain parent name.
3679      */
3680     Tcl_DStringInit(dsPtr);
3681     Tcl_DStringAppend(dsPtr, methodName, (int)objNameLength);
3682     regObject = GetObjectFromNsName(interp, Tcl_DStringValue(dsPtr), fromClassNS);
3683     if (regObject != NULL && methodName1 != NULL) {
3684       *methodName1 = procName;
3685     }
3686     Tcl_DStringFree(dsPtr);
3687   } else {
3688     regObject = NULL;
3689   }
3690 
3691   /*fprintf(stderr, "GetRegObject cmd %p methodName '%s' => %p\n", cmd, methodName, regObject);*/
3692   return regObject;
3693 }
3694 
3695 /*
3696  *----------------------------------------------------------------------
3697  * ResolveMethodName --
3698  *
3699  *    Resolve a method name relative to a provided namespace.
3700  *    The method name can be
3701  *      a) a fully qualified name
3702  *      b) a list of method name and subcommands
3703  *      c) a simple name
3704  *
3705  * Results:
3706  *    Tcl_Command or NULL on failure
3707  *
3708  * Side effects:
3709  *    none
3710  *
3711  *----------------------------------------------------------------------
3712  */
3713 static Tcl_Command ResolveMethodName(
3714     Tcl_Interp *interp,
3715     Tcl_Namespace *nsPtr,
3716     Tcl_Obj *methodObj,
3717     Tcl_DString *methodNameDs,
3718     NsfObject **regObject,
3719     NsfObject **defObject,
3720     const char **methodName1, bool *fromClassNS
3721 ) nonnull(1) nonnull(3) nonnull(8);
3722 
3723 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)3724 ResolveMethodName(
3725     Tcl_Interp *interp,
3726     Tcl_Namespace *nsPtr,
3727     Tcl_Obj *methodObj,
3728     Tcl_DString *methodNameDs,
3729     NsfObject **regObject,
3730     NsfObject **defObject,
3731     const char **methodName1,
3732     bool *fromClassNS
3733 ) {
3734   const char *methodName;
3735   NsfObject  *referencedObject;
3736   bool        containsSpace, tailContainsSpace;
3737   Tcl_Command cmd;
3738 
3739   nonnull_assert(interp != NULL);
3740   nonnull_assert(methodObj != NULL);
3741   nonnull_assert(fromClassNS != NULL);
3742 
3743   methodName = ObjStr(methodObj);
3744 
3745   /*fprintf(stderr, "methodName '%s' comp %d type %s\n",
3746     methodName, strchr(methodName, ' ')>0, ObjTypeStr(methodObj));*/
3747 
3748   if (methodObj->typePtr == Nsf_OT_listType) {
3749     int length;
3750 
3751     Tcl_ListObjLength(interp, methodObj, &length);
3752     containsSpace = (length > 1);
3753 
3754   } else if (methodObj->typePtr == Nsf_OT_tclCmdNameType) {
3755     containsSpace = NSF_FALSE;
3756   } else {
3757     containsSpace = NsfHasTclSpace(methodName);
3758   }
3759 
3760   if (containsSpace) {
3761     tailContainsSpace = NsfHasTclSpace(NSTail(methodName));
3762   } else {
3763     tailContainsSpace = NSF_FALSE;
3764   }
3765   /*fprintf(stderr, "<%s> containsSpace %d tailContainsSpace %d\n", methodName, containsSpace, tailContainsSpace);*/
3766 
3767 #if !defined(NDEBUG)
3768   if (containsSpace) {
3769     assert(NsfHasTclSpace(methodName));
3770   } else {
3771     assert(!tailContainsSpace);
3772   }
3773 #endif
3774 
3775   if (tailContainsSpace) {
3776     const char          *firstElementString;
3777     const Tcl_Namespace *parentNsPtr;
3778     const NsfObject     *ensembleObject;
3779     Tcl_Obj             *methodHandleObj, **ov;
3780     int                  oc, i;
3781 
3782     /*
3783      * When the methodName is required, we have to provide a methodNameDS as
3784      * well.
3785      */
3786     assert(methodName1 == NULL || methodNameDs != NULL);
3787 
3788     /*fprintf(stderr, "name '%s' contains space \n", methodName);*/
3789 
3790     if (likely(Tcl_ListObjGetElements(interp, methodObj, &oc, &ov) != TCL_OK)
3791         || ((referencedObject = GetEnsembleObjectFromName(interp, nsPtr, ov[0],
3792                                                           &cmd, fromClassNS)) == NULL)
3793         ) {
3794       if (methodName1 != NULL) {
3795         *methodName1 = NULL;
3796       }
3797       if (regObject != NULL) {
3798         *regObject = NULL;
3799       }
3800       if (defObject != NULL) {
3801         *defObject = NULL;
3802       }
3803       return NULL;
3804     }
3805 
3806     /*
3807      * We have an ensemble object. First, figure out, on which
3808      * object/class the ensemble object was registered. We determine
3809      * the regObject on the first element of the list. If we can't,
3810      * then the current object is the regObject.
3811      */
3812     firstElementString = ObjStr(ov[0]);
3813     if (*firstElementString == ':') {
3814       NsfObject *registrationObject;
3815 
3816       registrationObject = GetRegObject(interp, cmd, firstElementString, methodName1, fromClassNS);
3817       if (regObject != NULL) {
3818         *regObject = registrationObject;
3819       }
3820     } else {
3821       if (regObject != NULL) {
3822         *regObject = NULL;
3823       }
3824     }
3825 
3826     /*fprintf(stderr, "... regObject object '%s' reg %p, fromClassNS %d\n",
3827       ObjectName(referencedObject), *regObject, *fromClassNS);*/
3828 
3829     /*
3830      * Build a fresh methodHandleObj to held method name and names of
3831      * subcmds.
3832      */
3833     methodHandleObj = Tcl_DuplicateObj(referencedObject->cmdName);
3834     INCR_REF_COUNT(methodHandleObj);
3835 
3836     if (methodNameDs != NULL) {
3837       Tcl_DStringAppend(methodNameDs, Tcl_GetCommandName(interp, cmd), -1);
3838     }
3839     parentNsPtr = NULL;
3840 
3841     /*
3842      * Iterate over the objects and append to the methodNameDs and methodHandleObj
3843      */
3844     for (i = 1; i < oc; i++) {
3845       cmd = Tcl_GetCommandFromObj(interp, methodHandleObj);
3846       ensembleObject = (cmd != NULL) ? NsfGetObjectFromCmdPtr(cmd) : NULL;
3847 
3848       if (ensembleObject == NULL) {
3849         DECR_REF_COUNT(methodHandleObj);
3850         if (methodName1 != NULL) {
3851           *methodName1 = NULL;
3852         }
3853         if (regObject != NULL) {
3854           *regObject = NULL;
3855         }
3856         if (defObject != NULL) {
3857           *defObject = NULL;
3858         }
3859         return NULL;
3860       }
3861 
3862       if (parentNsPtr != NULL
3863           && (Tcl_Command_nsPtr(ensembleObject->id) != parentNsPtr)) {
3864         /* fprintf(stderr, "*** parent change saved parent %p %s computed parent %p %s\n",
3865                 parentNsPtr, parentNsPtr->fullName,
3866                 Tcl_Command_nsPtr(ensembleObject->id),
3867                 Tcl_Command_nsPtr(ensembleObject->id)->fullName);*/
3868         DECR_REF_COUNT(methodHandleObj);
3869         methodHandleObj = Tcl_DuplicateObj(ensembleObject->cmdName);
3870       }
3871       parentNsPtr = ensembleObject->nsPtr;
3872 
3873       Tcl_AppendLimitedToObj(methodHandleObj, "::", 2, INT_MAX, NULL);
3874       Tcl_AppendLimitedToObj(methodHandleObj, ObjStr(ov[i]), -1, INT_MAX, NULL);
3875       if (methodNameDs != NULL) {
3876         Tcl_DStringAppendElement(methodNameDs, ObjStr(ov[i]));
3877       }
3878     }
3879 
3880     /*
3881      * cmd contains now the parent-obj, on which the method was
3882      * defined. Get from this cmd the defObj.
3883      */
3884     if (defObject != NULL) {
3885       *defObject = NsfGetObjectFromCmdPtr(cmd);
3886     }
3887 
3888     /*fprintf(stderr, "... handle '%s' last cmd %p defObject %p\n",
3889       ObjStr(methodHandleObj), cmd, *defObject);*/
3890 
3891     /*
3892      * Obtain the command from the method handle and report back the
3893      * final methodName,
3894      */
3895     cmd = Tcl_GetCommandFromObj(interp, methodHandleObj);
3896     if (methodNameDs != NULL && methodName1 != NULL) {
3897       *methodName1 = Tcl_DStringValue(methodNameDs);
3898     }
3899 
3900     /*fprintf(stderr, "... methodname1 '%s' cmd %p\n", Tcl_DStringValue(methodNameDs), cmd);*/
3901     DECR_REF_COUNT(methodHandleObj);
3902 
3903   } else if (*methodName == ':') {
3904 
3905     cmd = Tcl_GetCommandFromObj(interp, methodObj);
3906     if (likely(cmd != NULL)) {
3907       referencedObject = GetRegObject(interp, cmd, methodName, methodName1, fromClassNS);
3908       if (regObject != NULL) {
3909         *regObject = referencedObject;
3910       }
3911       if (defObject != NULL) {
3912         *defObject = referencedObject;
3913       }
3914       if (methodName1 && *methodName1 == NULL) {
3915         /*
3916          * The return value for the method name is required and was not
3917          * computed by GetRegObject()
3918          */
3919         *methodName1 = Tcl_GetCommandName(interp, cmd);
3920       }
3921     } else {
3922       /*
3923        * The cmd was not registered on an object or class, but we
3924        * still report back the cmd (might be e.g. a primitive cmd).
3925        */
3926       if (regObject != NULL) {
3927         *regObject = NULL;
3928       }
3929       if (defObject != NULL) {
3930         *defObject = NULL;
3931       }
3932     }
3933   } else {
3934     if (methodName1 != NULL) {
3935       *methodName1 = methodName;
3936     }
3937     cmd = (nsPtr != NULL) ? FindMethod(nsPtr, methodName) : NULL;
3938     if (regObject != NULL) {
3939       *regObject = NULL;
3940     }
3941     if (defObject != NULL) {
3942       *defObject = NULL;
3943     }
3944   }
3945 
3946   return cmd;
3947 }
3948 
3949 /*
3950  *----------------------------------------------------------------------
3951  * CmdIsProc --
3952  *
3953  *    Check, whether the cmd is interpreted
3954  *
3955  * Results:
3956  *    Boolean
3957  *
3958  * Side effects:
3959  *    None
3960  *
3961  *----------------------------------------------------------------------
3962  */
3963 NSF_INLINE static bool CmdIsProc(const Tcl_Command cmd)
3964   nonnull(1) pure;
3965 
3966 NSF_INLINE static bool
CmdIsProc(const Tcl_Command cmd)3967 CmdIsProc(const Tcl_Command cmd) {
3968   /*
3969    * In 8.6: TclIsProc((Command *)cmd) is not equivalent to the definition
3970    * below.
3971    */
3972   nonnull_assert(cmd != NULL);
3973   return (Tcl_Command_objProc(cmd) == TclObjInterpProc);
3974 }
3975 
3976 /*
3977  *----------------------------------------------------------------------
3978  * CmdIsNsfObject --
3979  *
3980  *    Check whether the provided cmd refers to an NsfObject or Class.
3981  *
3982  * Results:
3983  *    Boolean
3984  *
3985  * Side effects:
3986  *    None.
3987  *
3988  *----------------------------------------------------------------------
3989  */
3990 NSF_INLINE static bool CmdIsNsfObject(Tcl_Command cmd)
3991   nonnull(1) pure;
3992 
3993 NSF_INLINE static bool
CmdIsNsfObject(Tcl_Command cmd)3994 CmdIsNsfObject(Tcl_Command cmd) {
3995   nonnull_assert(cmd != NULL);
3996   return Tcl_Command_objProc(cmd) == NsfObjDispatch;
3997 }
3998 
3999 /*
4000  *----------------------------------------------------------------------
4001  * GetTclProcFromCommand --
4002  *
4003  *    Check whether cmd refers to a Tcl proc, and if so, return the proc
4004  *    definition.
4005  *
4006  * Results:
4007  *    The found proc of cmd or NULL.
4008  *
4009  * Side effects:
4010  *    None
4011  *
4012  *----------------------------------------------------------------------
4013  */
4014 static Proc *GetTclProcFromCommand(const Tcl_Command cmd)
4015   nonnull(1) pure;
4016 
4017 static Proc *
GetTclProcFromCommand(const Tcl_Command cmd)4018 GetTclProcFromCommand(const Tcl_Command cmd) {
4019   Tcl_ObjCmdProc *proc;
4020   Proc           *result;
4021 
4022   nonnull_assert(cmd != NULL);
4023   proc = Tcl_Command_objProc(cmd);
4024   if (proc == TclObjInterpProc) {
4025     result = (Proc *)Tcl_Command_objClientData(cmd);
4026   } else {
4027     result = NULL;
4028   }
4029   return result;
4030 }
4031 
4032 /*
4033  *----------------------------------------------------------------------
4034  * FindMethod --
4035  *
4036  *    Lookup the cmd for methodName in a namespace.
4037  *
4038  * Results:
4039  *    The found cmd of the method or NULL.
4040  *
4041  * Side effects:
4042  *    None
4043  *
4044  *----------------------------------------------------------------------
4045  */
4046 
4047 NSF_INLINE static Tcl_Command
FindMethod(const Tcl_Namespace * nsPtr,const char * methodName)4048 FindMethod(
4049     const Tcl_Namespace *nsPtr,
4050     const char *methodName
4051 ) {
4052   register const Tcl_HashEntry *entryPtr;
4053   Tcl_Command                   result;
4054 
4055   nonnull_assert(nsPtr != NULL);
4056   nonnull_assert(methodName != NULL);
4057 
4058   if ((entryPtr = Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(nsPtr), methodName, NULL))) {
4059     result = (Tcl_Command) Tcl_GetHashValue(entryPtr);
4060   } else {
4061     result = NULL;
4062   }
4063   return result;
4064 }
4065 
4066 /*
4067  *----------------------------------------------------------------------
4068  * FindProcMethod --
4069  *
4070  *    Lookup the proc for methodName in a namespace.
4071  *
4072  * Results:
4073  *    The found proc of the method or NULL.
4074  *
4075  * Side effects:
4076  *    None
4077  *
4078  *----------------------------------------------------------------------
4079  */
4080 static Proc * FindProcMethod(const Tcl_Namespace *nsPtr, const char *methodName)
4081   nonnull(1) nonnull(2);
4082 
4083 static Proc *
FindProcMethod(const Tcl_Namespace * nsPtr,const char * methodName)4084 FindProcMethod(const Tcl_Namespace *nsPtr, const char *methodName) {
4085   Tcl_Command cmd;
4086 
4087   nonnull_assert(nsPtr != NULL);
4088   nonnull_assert(methodName != NULL);
4089 
4090   cmd = FindMethod(nsPtr, methodName);
4091   return (cmd != NULL) ? GetTclProcFromCommand(cmd) : NULL;
4092 }
4093 
4094 /*
4095  *----------------------------------------------------------------------
4096  * SearchPLMethod, SearchPLMethod0 --
4097  *
4098  *    Search a method along a provided class list.  The methodName must be
4099  *    simple (must not contain space). While SearchPLMethod() allows one to
4100  *    specify a flag for filtering the command, SearchPLMethod0() is a lightly
4101  *    optimized function without the filtering option.
4102  *
4103  * Results:
4104  *    The found class defining the method or NULL.
4105  *
4106  * Side effects:
4107  *    None
4108  *
4109  *----------------------------------------------------------------------
4110  */
4111 static NsfClass * SearchPLMethod(
4112     register const NsfClasses *pl, const char *methodName,
4113     Tcl_Command *cmdPtr, unsigned int flags
4114 ) nonnull(1) nonnull(2) nonnull(3);
4115 
4116 static NsfClass * SearchPLMethod0(
4117     register const NsfClasses *pl, const char *methodName,
4118     Tcl_Command *cmdPtr
4119 ) nonnull(1) nonnull(2) nonnull(3);
4120 
4121 static NsfClass *
SearchPLMethod0(register const NsfClasses * pl,const char * methodName,Tcl_Command * cmdPtr)4122 SearchPLMethod0(
4123     register const NsfClasses *pl, const char *methodName, Tcl_Command *cmdPtr
4124 ) {
4125   nonnull_assert(pl != NULL);
4126   nonnull_assert(methodName != NULL);
4127   nonnull_assert(cmdPtr != NULL);
4128 
4129   /*
4130    * Search the precedence list (class hierarchy).
4131    */
4132   do {
4133     register const Tcl_HashEntry *entryPtr =
4134       Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(pl->cl->nsPtr), methodName, NULL);
4135 
4136     if (entryPtr != NULL) {
4137       *cmdPtr = (Tcl_Command) Tcl_GetHashValue(entryPtr);
4138       return pl->cl;
4139     }
4140     pl = pl->nextPtr;
4141   } while (pl != NULL);
4142 
4143   return NULL;
4144 }
4145 
4146 static NsfClass *
SearchPLMethod(register const NsfClasses * pl,const char * methodName,Tcl_Command * cmdPtr,unsigned int flags)4147 SearchPLMethod(
4148     register const NsfClasses *pl, const char *methodName,
4149     Tcl_Command *cmdPtr, unsigned int flags
4150 ) {
4151 
4152   nonnull_assert(pl != NULL);
4153   nonnull_assert(methodName != NULL);
4154   nonnull_assert(cmdPtr != NULL);
4155 
4156   /*
4157    * Search the precedence list (class hierarchy).
4158    */
4159   do {
4160     register const Tcl_HashEntry *entryPtr =
4161       Tcl_CreateHashEntry(Tcl_Namespace_cmdTablePtr(pl->cl->nsPtr), methodName, NULL);
4162 
4163     if (entryPtr != NULL) {
4164       Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
4165 
4166       if (likely(((unsigned int)Tcl_Command_flags(cmd) & flags) == 0u)) {
4167         *cmdPtr = cmd;
4168         return pl->cl;
4169       }
4170     }
4171     pl = pl->nextPtr;
4172   } while (pl != NULL);
4173 
4174   return NULL;
4175 }
4176 
4177 /*
4178  *----------------------------------------------------------------------
4179  * SearchCMethod --
4180  *
4181  *    Search a method along the superclass hierarchy of the provided
4182  *    class. The methodObj must be simple (must not contain
4183  *    space). The method has the interface for internal calls during
4184  *    interpretation, while SearchSimpleCMethod() has the interface
4185  *    with more overhead for introspection.
4186  *
4187  * Results:
4188  *    The found class defining the method or NULL.
4189  *
4190  * Side effects:
4191  *    None
4192  *
4193  *----------------------------------------------------------------------
4194  */
4195 static NsfClass * SearchCMethod(NsfClass *class, const char *methodName, Tcl_Command *cmdPtr)
4196   nonnull(1) nonnull(2) nonnull(3);
4197 
4198 static NsfClass *
SearchCMethod(NsfClass * class,const char * methodName,Tcl_Command * cmdPtr)4199 SearchCMethod(NsfClass *class, const char *methodName, Tcl_Command *cmdPtr) {
4200 
4201   nonnull_assert(methodName != NULL);
4202   nonnull_assert(cmdPtr != NULL);
4203   nonnull_assert(class != NULL);
4204 
4205   return SearchPLMethod0(PrecedenceOrder(class), methodName, cmdPtr);
4206 }
4207 
4208 /*
4209  *----------------------------------------------------------------------
4210  * SearchSimpleCMethod --
4211  *
4212  *    Search a method along the superclass hierarchy of the provided
4213  *    class. The methodObj must be simple (must not contain
4214  *    space). The method has the same interface as
4215  *    SearchComplexCMethod().
4216  *
4217  * Results:
4218  *    The found class defining the method or NULL.
4219  *
4220  * Side effects:
4221  *    None
4222  *
4223  *----------------------------------------------------------------------
4224  */
4225 static NsfClass * SearchSimpleCMethod(Tcl_Interp *UNUSED(interp),
4226                                       NsfClass *class, Tcl_Obj *methodObj,
4227                                       Tcl_Command *cmdPtr)
4228   nonnull(2) nonnull(3) nonnull(4);
4229 
4230 static NsfClass *
SearchSimpleCMethod(Tcl_Interp * UNUSED (interp),NsfClass * class,Tcl_Obj * methodObj,Tcl_Command * cmdPtr)4231 SearchSimpleCMethod(
4232     Tcl_Interp *UNUSED(interp), NsfClass *class,
4233     Tcl_Obj *methodObj, Tcl_Command *cmdPtr
4234 ) {
4235 
4236   nonnull_assert(class != NULL);
4237   nonnull_assert(methodObj != NULL);
4238   nonnull_assert(cmdPtr != NULL);
4239 
4240   return SearchPLMethod0(PrecedenceOrder(class), ObjStr(methodObj), cmdPtr);
4241 }
4242 
4243 /*
4244  *----------------------------------------------------------------------
4245  * SearchComplexCMethod --
4246  *
4247  *    Search a method along the superclass hierarchy of the provided
4248  *    class. The methodObj can refer to an ensemble object (can
4249  *    contain space). The method has the same interface as
4250  *    SearchSimpleCMethod().
4251  *
4252  * Results:
4253  *    The found class defining the method or NULL.
4254  *
4255  * Side effects:
4256  *    None
4257  *
4258  *----------------------------------------------------------------------
4259  */
4260 static NsfClass * SearchComplexCMethod(Tcl_Interp *interp, NsfClass *class,
4261                      Tcl_Obj *methodObj, Tcl_Command *cmdPtr)
4262   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
4263 
4264 static NsfClass *
SearchComplexCMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * methodObj,Tcl_Command * cmdPtr)4265 SearchComplexCMethod(Tcl_Interp *interp, NsfClass *class,
4266                      Tcl_Obj *methodObj, Tcl_Command *cmdPtr) {
4267   NsfClasses *pl;
4268   bool        fromClassNS = NSF_TRUE;
4269 
4270   nonnull_assert(interp != NULL);
4271   nonnull_assert(class != NULL);
4272   nonnull_assert(methodObj != NULL);
4273   nonnull_assert(cmdPtr != NULL);
4274 
4275   for (pl = PrecedenceOrder(class); pl != NULL;  pl = pl->nextPtr) {
4276     Tcl_Command cmd = ResolveMethodName(interp, pl->cl->nsPtr, methodObj,
4277                                         NULL, NULL, NULL, NULL, &fromClassNS);
4278     if (cmd != NULL) {
4279       *cmdPtr = cmd;
4280       return pl->cl;
4281     }
4282   }
4283 
4284   return NULL;
4285 }
4286 
4287 /*
4288  *----------------------------------------------------------------------
4289  * ObjectFindMethod --
4290  *
4291  *    Find a method for a given object in the precedence path. The
4292  *    provided methodObj might be an ensemble object. This function
4293  *    tries to optimize access by calling different implementations
4294  *    for simple and ensemble method names.
4295  *
4296  * Results:
4297  *    Tcl command.
4298  *
4299  * Side effects:
4300  *    None.
4301  *
4302  *----------------------------------------------------------------------
4303  */
4304 
4305 static Tcl_Command ObjectFindMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *methodObj, NsfClass **classPtr)
4306   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
4307 
4308 static Tcl_Command
ObjectFindMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * methodObj,NsfClass ** classPtr)4309 ObjectFindMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *methodObj, NsfClass **classPtr) {
4310   Tcl_Command cmd = NULL;
4311   NsfClass *(*lookupFunction)(Tcl_Interp *interp, NsfClass *class,
4312                               Tcl_Obj *methodObj, Tcl_Command *cmdPtr);
4313 
4314   nonnull_assert(interp != NULL);
4315   nonnull_assert(object != NULL);
4316   nonnull_assert(methodObj != NULL);
4317   nonnull_assert(classPtr != NULL);
4318 
4319   if (NsfHasTclSpace(ObjStr(methodObj))) {
4320     lookupFunction = SearchComplexCMethod;
4321   } else {
4322     lookupFunction = SearchSimpleCMethod;
4323   }
4324 
4325   if (unlikely(object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
4326     MixinComputeDefined(interp, object);
4327   }
4328 
4329   if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
4330     NsfCmdList *mixinList;
4331 
4332     for (mixinList = object->mixinOrder; mixinList; mixinList = mixinList->nextPtr) {
4333       NsfClass *mixin = NsfGetClassFromCmdPtr(mixinList->cmdPtr);
4334 
4335       if ((mixin != NULL)
4336           && (*classPtr = (*lookupFunction)(interp, mixin, methodObj, &cmd))) {
4337         if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CLASS_ONLY_METHOD) != 0 && !NsfObjectIsClass(object)) {
4338           cmd = NULL;
4339           continue;
4340         }
4341         break;
4342       }
4343     }
4344   }
4345 
4346   if ((cmd == NULL) && (object->nsPtr != NULL)) {
4347     bool fromClassNS = NSF_FALSE;
4348 
4349     cmd = ResolveMethodName(interp, object->nsPtr, methodObj,
4350                             NULL, NULL, NULL, NULL, &fromClassNS);
4351   }
4352 
4353   if (cmd == NULL && object->cl != NULL) {
4354     *classPtr = (*lookupFunction)(interp, object->cl, methodObj, &cmd);
4355   }
4356 
4357   return cmd;
4358 }
4359 
4360 /*
4361  *----------------------------------------------------------------------
4362  * GetObjectSystem --
4363  *
4364  *    Return the object system for which the object was defined
4365  *
4366  * Results:
4367  *    Object system pointer
4368  *
4369  * Side effects:
4370  *    None.
4371  *
4372  *----------------------------------------------------------------------
4373  */
4374 static NsfObjectSystem * GetObjectSystem(const NsfObject *object)
4375   nonnull(1) pure;
4376 
4377 static NsfObjectSystem *
GetObjectSystem(const NsfObject * object)4378 GetObjectSystem(const NsfObject *object) {
4379 
4380   nonnull_assert(object != NULL);
4381 
4382   if (NsfObjectIsClass(object)) {
4383     return ((NsfClass *)object)->osPtr;
4384   }
4385   assert(object->cl != NULL);
4386   return object->cl->osPtr;
4387 }
4388 
4389 /*
4390  *----------------------------------------------------------------------
4391  * ObjectSystemFree --
4392  *
4393  *    Free a single object system structure including its root-classes.
4394  *
4395  * Results:
4396  *    None.
4397  *
4398  * Side effects:
4399  *    Free memory of structure, free the root-classes.
4400  *
4401  *----------------------------------------------------------------------
4402  */
4403 
4404 static void ObjectSystemFree(Tcl_Interp *interp, NsfObjectSystem *osPtr)
4405   nonnull(1) nonnull(2);
4406 
4407 static void
ObjectSystemFree(Tcl_Interp * interp,NsfObjectSystem * osPtr)4408 ObjectSystemFree(Tcl_Interp *interp, NsfObjectSystem *osPtr) {
4409   int idx;
4410 
4411   nonnull_assert(interp != NULL);
4412   nonnull_assert(osPtr != NULL);
4413 
4414   for (idx = 0; idx <= NSF_s_set_idx; idx++) {
4415     if (osPtr->methods[idx]) {
4416       DECR_REF_COUNT(osPtr->methods[idx]);
4417       osPtr->methodNames[idx] = NULL;
4418     }
4419     if (osPtr->handles[idx]) {
4420       DECR_REF_COUNT(osPtr->handles[idx]);
4421     }
4422   }
4423 
4424   if (osPtr->rootMetaClass != NULL && osPtr->rootClass != NULL) {
4425     RemoveSuper(osPtr->rootMetaClass, osPtr->rootClass);
4426     RemoveInstance((NsfObject *)osPtr->rootMetaClass, osPtr->rootMetaClass);
4427     RemoveInstance((NsfObject *)osPtr->rootClass, osPtr->rootMetaClass);
4428 
4429     FinalObjectDeletion(interp, &osPtr->rootClass->object);
4430     FinalObjectDeletion(interp, &osPtr->rootMetaClass->object);
4431   }
4432 
4433   FREE(NsfObjectSystem, osPtr);
4434 }
4435 
4436 /*
4437  *----------------------------------------------------------------------
4438  * ObjectSystemAdd --
4439  *
4440  *    Add and entry to the list of object systems of the interpreter.
4441  *
4442  * Results:
4443  *    None.
4444  *
4445  * Side effects:
4446  *    Updating the per interp list of object systems.
4447  *
4448  *----------------------------------------------------------------------
4449  */
4450 static void ObjectSystemAdd(Tcl_Interp *interp, NsfObjectSystem *osPtr)
4451   nonnull(1) nonnull(2);
4452 
4453 static void
ObjectSystemAdd(Tcl_Interp * interp,NsfObjectSystem * osPtr)4454 ObjectSystemAdd(Tcl_Interp *interp, NsfObjectSystem *osPtr) {
4455 
4456   nonnull_assert(interp != NULL);
4457   nonnull_assert(osPtr != NULL);
4458 
4459   osPtr->nextPtr = RUNTIME_STATE(interp)->objectSystems;
4460   RUNTIME_STATE(interp)->objectSystems = osPtr;
4461 }
4462 
4463 
4464 
4465 /*
4466  *----------------------------------------------------------------------
4467  * ObjectSystemsCleanup --
4468  *
4469  *    Delete all objects from all defined object systems.  This method
4470  *    is to be called when a Next Scripting process or thread exists.
4471  *
4472  * Results:
4473  *    None.
4474  *
4475  * Side effects:
4476  *    All commands and objects are deleted, memory is freed.
4477  *
4478  *----------------------------------------------------------------------
4479  */
4480 static int ObjectSystemsCleanup(Tcl_Interp *interp, bool withKeepvars)
4481   nonnull(1);
4482 
4483 static int
ObjectSystemsCleanup(Tcl_Interp * interp,bool withKeepvars)4484 ObjectSystemsCleanup(Tcl_Interp *interp, bool withKeepvars) {
4485   NsfCmdList      *instances = NULL, *entryPtr;
4486   NsfObjectSystem *osPtr, *nPtr;
4487 
4488   nonnull_assert(interp != NULL);
4489 
4490   /*
4491    * Deletion is performed in two rounds:
4492    *  (a) SOFT DESTROY: invoke all user-defined destroy methods
4493    *      without destroying objects
4494    *  (b) PHYSICAL DESTROY: delete the objects and classes,
4495    *      destroy methods are not invoked anymore
4496    *
4497    * This is to prevent that the destroy order causes classes to be
4498    * deleted before the methods invoked by destroy are executed.  Note
4499    * that it is necessary to iterate over all object systems
4500    * simultaneous, since the might be dependencies between objects of
4501    * different object systems.
4502    */
4503 
4504   /*
4505    * Collect all instances from all object systems
4506    */
4507 
4508   for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
4509     GetAllInstances(interp, &instances, osPtr->rootClass);
4510   }
4511 
4512   /***** SOFT DESTROY *****/
4513   RUNTIME_STATE(interp)->exitHandlerDestroyRound = NSF_EXITHANDLER_ON_SOFT_DESTROY;
4514 
4515   /*fprintf(stderr, "===CALL destroy on OBJECTS\n");*/
4516 
4517   for (entryPtr = instances; entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
4518     NsfObject *object = (NsfObject *)entryPtr->clorobj;
4519 
4520     /*fprintf(stderr, "key = %s %p %d flags %.6x\n",
4521       ObjectName(object), object, object && !NsfObjectIsClass(object), object->flags);*/
4522 
4523     if (object != NULL && !NsfObjectIsClass(object)
4524         && ((object->flags & NSF_DESTROY_CALLED) == 0u)) {
4525       DispatchDestroyMethod(interp, object, 0u);
4526     }
4527   }
4528 
4529   /*fprintf(stderr, "===CALL destroy on CLASSES\n");*/
4530 
4531   for (entryPtr = instances; entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
4532     const NsfClass *class = entryPtr->clorobj;
4533 
4534     if (class != NULL && ((class->object.flags & NSF_DESTROY_CALLED) == 0u)) {
4535       DispatchDestroyMethod(interp, (NsfObject *)class, 0u);
4536     }
4537   }
4538 
4539   /*
4540    * Now turn off filters, all destroy callbacks are done.
4541    */
4542   RUNTIME_STATE(interp)->doFilters = 0;
4543   (void)Tcl_RemoveInterpResolvers(interp, "nsf");
4544 
4545 #ifdef DO_CLEANUP
4546   FreeAllNsfObjectsAndClasses(interp, &instances);
4547 # ifdef DO_FULL_CLEANUP
4548   DeleteProcsAndVars(interp, Tcl_GetGlobalNamespace(interp), withKeepvars);
4549 # endif
4550 #endif
4551   (void)withKeepvars; /* make sure, the variable is not reported as unused */
4552   /*
4553    * Free all objects systems with their root-classes.
4554    */
4555   for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = nPtr) {
4556     nPtr = osPtr->nextPtr;
4557     ObjectSystemFree(interp, osPtr);
4558   }
4559 
4560 #ifdef DO_CLEANUP
4561   /*
4562    * Finally, free all nsfprocs.
4563    */
4564   DeleteNsfProcs(interp, NULL);
4565 #endif
4566 
4567   CmdListFree(&instances, NULL);
4568 
4569   return TCL_OK;
4570 }
4571 
4572 
4573 /*
4574  *----------------------------------------------------------------------
4575  * CallDirectly --
4576  *
4577  *    Determine when it is possible/necessary to call a method
4578  *    implementation directly or via method dispatch.
4579  *
4580  * Results:
4581  *    1 is returned when command should be invoked directly, 0
4582  *    otherwise.
4583  *
4584  * Side effects:
4585  *    methodObjPtr is set with the Tcl_Obj of the name of the method,
4586  *    if there is one defined.
4587  *
4588  *----------------------------------------------------------------------
4589  */
4590 static bool CallDirectly(Tcl_Interp *interp, NsfObject *object, int methodIdx, Tcl_Obj **methodObjPtr)
4591   nonnull(1) nonnull(2) nonnull(4);
4592 
4593 static bool
CallDirectly(Tcl_Interp * interp,NsfObject * object,int methodIdx,Tcl_Obj ** methodObjPtr)4594 CallDirectly(Tcl_Interp *interp, NsfObject *object, int methodIdx, Tcl_Obj **methodObjPtr) {
4595   /*
4596    * We can/must call a C-implemented method directly, when
4597    *
4598    *   a) the object system has no such appropriate method defined
4599    *
4600    *   b) the script does not contain a method with the appropriate
4601    *     name, and
4602    *
4603    *   c) filters are not active on the object
4604    */
4605   NsfObjectSystem *osPtr = GetObjectSystem(object);
4606   bool             callDirectly = NSF_TRUE;
4607   Tcl_Obj         *methodObj;
4608 
4609   nonnull_assert(interp != NULL);
4610   nonnull_assert(object != NULL);
4611   nonnull_assert(methodObjPtr != NULL);
4612 
4613   methodObj = osPtr->methods[methodIdx];
4614   /*fprintf(stderr, "OS of %s is %s, method %s methodObj %p osPtr %p defined %.8x %.8x overloaded %.8x %.8x flags %.8x\n",
4615           ObjectName(object), ObjectName(&osPtr->rootClass->object),
4616           Nsf_SystemMethodOpts[methodIdx]+1, methodObj,
4617           osPtr,
4618           osPtr->definedMethods, osPtr->definedMethods & (1 << methodIdx),
4619           osPtr->overloadedMethods, osPtr->overloadedMethods & (1 << methodIdx),
4620           1 << methodIdx );*/
4621 
4622   if (methodObj != NULL) {
4623     unsigned int flag = 1u << methodIdx;
4624 
4625     if ((osPtr->overloadedMethods & flag) != 0u) {
4626       /*
4627        * The method is overloaded, we must dispatch.
4628        */
4629       /*fprintf(stderr, "overloaded\n");*/
4630       callDirectly = NSF_FALSE;
4631     } else if ((osPtr->definedMethods & flag) == 0u) {
4632       /*
4633        * The method is not defined, we must call directly.
4634        */
4635       /*fprintf(stderr, "Warning: CallDirectly object %s idx %s not defined\n",
4636         ObjectName(object), Nsf_SystemMethodOpts[methodIdx]+1);*/
4637     } else {
4638 #if defined(DISPATCH_ALWAYS_DEFINED_METHODS)
4639       callDirectly = NSF_FALSE;
4640 #else
4641       if ((object->flags & NSF_FILTER_ORDER_VALID) == 0u) {
4642         FilterComputeDefined(interp, object);
4643       }
4644       /*fprintf(stderr, "CallDirectly object %s idx %s object flags %.6x %.6x \n",
4645               ObjectName(object), Nsf_SystemMethodOpts[methodIdx]+1,
4646               (object->flags & NSF_FILTER_ORDER_DEFINED_AND_VALID),
4647               NSF_FILTER_ORDER_DEFINED_AND_VALID);*/
4648       if ((object->flags & NSF_FILTER_ORDER_DEFINED_AND_VALID) == NSF_FILTER_ORDER_DEFINED_AND_VALID) {
4649         /*fprintf(stderr, "CallDirectly object %s idx %s has filter \n",
4650           ObjectName(object), Nsf_SystemMethodOpts[methodIdx]+1);*/
4651         callDirectly = NSF_FALSE;
4652       }
4653 #endif
4654     }
4655   }
4656 
4657   /*fprintf(stderr, "CallDirectly object %s idx %d returns %s => %d\n",
4658           ObjectName(object), methodIdx, (methodObj != NULL) ? ObjStr(methodObj) : "(null)", callDirectly);*/
4659 
4660   /*
4661    * Teturn the methodObj in every case.
4662    */
4663   *methodObjPtr = methodObj;
4664   return callDirectly;
4665 }
4666 
4667 /*
4668  *----------------------------------------------------------------------
4669  * NsfMethodObj --
4670  *
4671  *    Return the methodObj for a given method index.
4672  *
4673  * Results:
4674  *    Returns Tcl_Obj* or NULL
4675  *
4676  * Side effects:
4677  *    None.
4678  *
4679  *----------------------------------------------------------------------
4680  */
4681 Tcl_Obj *
NsfMethodObj(const NsfObject * object,int methodIdx)4682 NsfMethodObj(const NsfObject *object, int methodIdx) {
4683   NsfObjectSystem *osPtr = GetObjectSystem(object);
4684 
4685   nonnull_assert(object != NULL);
4686   /*
4687   fprintf(stderr, "NsfMethodObj object %s os %p idx %d %s methodObj %p\n",
4688           ObjectName(object), osPtr, methodIdx,
4689           Nsf_SystemMethodOpts[methodIdx]+1,
4690           osPtr->methods[methodIdx]);
4691   */
4692   return osPtr->methods[methodIdx];
4693 }
4694 
4695 
4696 /*
4697  * conditional memory allocations of optional storage
4698  */
4699 
4700 
4701 static NsfObjectOpt *
NsfRequireObjectOpt(NsfObject * object)4702 NsfRequireObjectOpt(NsfObject *object) {
4703 
4704   nonnull_assert(object != NULL);
4705 
4706   if (object->opt == NULL) {
4707     object->opt = NEW(NsfObjectOpt);
4708     memset(object->opt, 0, sizeof(NsfObjectOpt));
4709   }
4710   return object->opt;
4711 }
4712 
4713 
4714 NsfClassOpt *
NsfRequireClassOpt(NsfClass * class)4715 NsfRequireClassOpt(NsfClass *class) {
4716 
4717   nonnull_assert(class != NULL);
4718 
4719   if (class->opt == NULL) {
4720     class->opt = NEW(NsfClassOpt);
4721     memset(class->opt, 0, sizeof(NsfClassOpt));
4722     if ((class->object.flags & NSF_IS_CLASS) != 0u) {
4723       class->opt->id = class->object.id;  /* probably a temporary solution */
4724     }
4725   }
4726   return class->opt;
4727 }
4728 
4729 
4730 static void MakeObjNamespace(Tcl_Interp *interp, NsfObject *object)
4731   nonnull(1) nonnull(2);
4732 
4733 static void
MakeObjNamespace(Tcl_Interp * interp,NsfObject * object)4734 MakeObjNamespace(Tcl_Interp *interp, NsfObject *object) {
4735 
4736   nonnull_assert(interp != NULL);
4737   nonnull_assert(object != NULL);
4738 
4739 #ifdef NAMESPACE_TRACE
4740   fprintf(stderr, "+++ MakeObjNamespace for %s\n", ObjectName(object));
4741 #endif
4742   if (object->nsPtr == NULL) {
4743     Tcl_Namespace *nsPtr;
4744 
4745     nsPtr = object->nsPtr = NSGetFreshNamespace(interp, object,
4746                                                 ObjStr(object->cmdName));
4747     assert(nsPtr != NULL);
4748 
4749     /*
4750      * Copy all obj variables to the newly created namespace
4751      */
4752     if (object->varTablePtr != NULL) {
4753       Tcl_HashSearch  search;
4754       Tcl_HashEntry   *hPtr;
4755       TclVarHashTable *varTablePtr = Tcl_Namespace_varTablePtr(nsPtr);
4756       Tcl_HashTable   *varHashTablePtr = TclVarHashTablePtr(varTablePtr);
4757       Tcl_HashTable   *objHashTablePtr = TclVarHashTablePtr(object->varTablePtr);
4758 
4759       *varHashTablePtr = *objHashTablePtr; /* copy the table */
4760 
4761       if (objHashTablePtr->buckets == objHashTablePtr->staticBuckets) {
4762         varHashTablePtr->buckets = varHashTablePtr->staticBuckets;
4763       }
4764       for (hPtr = Tcl_FirstHashEntry(varHashTablePtr, &search);
4765            hPtr != NULL;
4766            hPtr = Tcl_NextHashEntry(&search)) {
4767         hPtr->tablePtr = varHashTablePtr;
4768       }
4769       CallStackReplaceVarTableReferences(interp, object->varTablePtr,
4770                                          (TclVarHashTable *)varHashTablePtr);
4771 
4772       ckfree((char *) object->varTablePtr);
4773       object->varTablePtr = NULL;
4774     }
4775   }
4776 }
4777 
4778 /*
4779  *----------------------------------------------------------------------
4780  * CompiledLocalsLookup --
4781  *
4782  *    Lookup variable from the compiled locals. The function performs a linear
4783  *    search in an unsorted list maintained by Tcl. This function is just used
4784  *    for the rather deprecated "instvar" method.
4785  *
4786  * Results:
4787  *    Returns Tcl_Var (or NULL, when lookup is not successful)
4788  *
4789  * Side effects:
4790  *    None.
4791  *
4792  *----------------------------------------------------------------------
4793  */
4794 static Tcl_Var CompiledLocalsLookup(CallFrame *varFramePtr, const char *varName)
4795   nonnull(1) nonnull(2);
4796 
4797 static Tcl_Var
CompiledLocalsLookup(CallFrame * varFramePtr,const char * varName)4798 CompiledLocalsLookup(CallFrame *varFramePtr, const char *varName) {
4799   int localCt;
4800 
4801   nonnull_assert(varFramePtr != NULL);
4802   nonnull_assert(varName != NULL);
4803 
4804   localCt = varFramePtr->numCompiledLocals;
4805   if (localCt > 0) {
4806     Tcl_Obj  **varNameObjPtr;
4807     int        i, nameLength;
4808 
4809     varNameObjPtr = &varFramePtr->localCachePtr->varName0;
4810     nameLength = (int)strlen(varName);
4811 
4812     /* fprintf(stderr, "=== compiled local search #local vars %d for <%s> flags %.8x\n",
4813        localCt, varName, varFramePtr->isProcCallFrame);
4814     */
4815 
4816     for (i = 0 ; i < localCt ; i++, varNameObjPtr++) {
4817       Tcl_Obj *varNameObj = *varNameObjPtr;
4818       int      len;
4819 
4820       if (likely(varNameObj != NULL)) {
4821         const char *localName = TclGetStringFromObj(varNameObj, &len);
4822 
4823         /* fprintf(stderr, ".. [%d] varNameObj %p %p <%s>\n",
4824            i, (void *)varNameObj, (void *)varNameObj->typePtr, localName);
4825         */
4826 
4827         if (unlikely(varName[0] == localName[0]
4828                      && varName[1] == localName[1]
4829                      && len == nameLength
4830                      && memcmp(varName, localName, (size_t)len) == 0)) {
4831           return (Tcl_Var) &varFramePtr->compiledLocals[i];
4832         }
4833       }
4834     }
4835   }
4836   return NULL;
4837 }
4838 
4839 
4840 /*
4841  *----------------------------------------------------------------------
4842  * CompiledColonLocalsLookupBuildCache --
4843  *
4844  *    Helper function for CompiledColonLocalsLookup(): build up a sorted cache
4845  *    consisting only of colon prefixed variables, such that e.g.
4846  *    non-successful lookup can be performed in O(n/2).  In comparison to
4847  *    CompiledLocalsLookup() this function is about a factor of 4 faster.
4848  *
4849  * Results:
4850  *    Returns Tcl_Var (or NULL, when lookup is not successful)
4851  *
4852  * Side effects:
4853  *    None.
4854  *
4855  *----------------------------------------------------------------------
4856  */
4857 static Tcl_Var CompiledColonLocalsLookupBuildCache(CallFrame     *varFramePtr,
4858                                                    const char    *varName,
4859                                                    int             nameLength,
4860                                                    Tcl_Obj       **localNames,
4861                                                    NsfProcContext *ctxPtr)
4862   nonnull(1) nonnull(2) nonnull(4) nonnull(5);
4863 
4864 static Tcl_Var
CompiledColonLocalsLookupBuildCache(CallFrame * varFramePtr,const char * varName,int nameLength,Tcl_Obj ** localNames,NsfProcContext * ctxPtr)4865 CompiledColonLocalsLookupBuildCache(CallFrame *varFramePtr, const char *varName,
4866                                     int nameLength, Tcl_Obj **localNames,
4867                                     NsfProcContext *ctxPtr) {
4868   int       nrColonVars = 0, localCt, i, j;
4869   Tcl_Var   result;
4870   Tcl_Obj **varNameObjPtr;
4871 
4872   nonnull_assert(varFramePtr != NULL);
4873   nonnull_assert(varName != NULL);
4874   nonnull_assert(localNames != NULL);
4875   nonnull_assert(ctxPtr != NULL);
4876 
4877   assert(ctxPtr->colonLocalVarCache == NULL);
4878   assert(varFramePtr->localCachePtr != NULL);
4879 
4880   localCt = varFramePtr->numCompiledLocals;
4881   varNameObjPtr = &varFramePtr->localCachePtr->varName0;
4882 
4883   /*
4884    * Count colonVars
4885    */
4886   for (i = 0; i < localCt; i++, varNameObjPtr++) {
4887     Tcl_Obj *varNameObj = *varNameObjPtr;
4888 
4889     if (varNameObj != NULL) {
4890       const char *localName = TclGetString(varNameObj);
4891 
4892       if (localName[0] == ':') {
4893         nrColonVars ++;
4894       }
4895     }
4896   }
4897 
4898   /*fprintf(stderr, ".. build cache #local vars %d for <%s> flags %.8x ctxPtr %p colonvars %d\n",
4899           localCt, varName, varFramePtr->isProcCallFrame,
4900           (void *)ctxPtr, nrColonVars
4901           );*/
4902 
4903   /*
4904    * Allocate colonLocalVarCache in the proper size (keep space for a
4905    * terminating element).
4906    */
4907   ctxPtr->colonLocalVarCache = NEW_ARRAY(int, nrColonVars+1);
4908   varNameObjPtr = &varFramePtr->localCachePtr->varName0;
4909 
4910   /*
4911    * Fill colonLocalVarCache; since we have to go through the whole list, we
4912    * might find and return the variable.
4913    */
4914   j = 0;
4915   result = NULL;
4916 
4917   for (i = 0; i < localCt ; i++, varNameObjPtr++) {
4918     Tcl_Obj *varNameObj = *varNameObjPtr;
4919 
4920     if (varNameObj != NULL) {
4921       int         len;
4922       const char *localName = TclGetStringFromObj(varNameObj, &len);
4923 
4924       if (localName[0] == ':') {
4925         int     k;
4926         Tcl_Var var = (Tcl_Var) &varFramePtr->compiledLocals[i];
4927 
4928         if (varName[1] == localName[1]
4929             && len == nameLength
4930             && memcmp(varName, localName, (size_t)len) == 0) {
4931           result = var;
4932         }
4933 
4934         /* fprintf(stderr, ".. insert %s (%d) on pos %d; check j %d entries \n", localName, i, j, j); */
4935         for (k = 0; k < j; k++) {
4936           int         idx, cmp;
4937           const char *cachedName;
4938 
4939           idx = ctxPtr->colonLocalVarCache[k];
4940           cachedName = TclGetStringFromObj(localNames[idx], &len);
4941           cmp = strcmp(localName, cachedName);
4942 
4943           /* fprintf(stderr, "... [%d] cmp newVarName <%s> (%d) with cachendName <%s> (%d) => %d\n",
4944                 k, localName, i, cachedName, idx, cmp);
4945           */
4946           if (cmp < 0) {
4947             int ii;
4948 
4949             /*
4950              * Make space on position k for inserting the new element. We
4951              * might uses memmove() instead.
4952              */
4953             for (ii = j; ii > k; ii--) {
4954               ctxPtr->colonLocalVarCache[ii] = ctxPtr->colonLocalVarCache[ii - 1];
4955             }
4956             break;
4957           }
4958         }
4959         ctxPtr->colonLocalVarCache[k] = i;
4960 
4961         j++;
4962         if (j == nrColonVars) {
4963           break;
4964         }
4965       }
4966     }
4967   }
4968   /*
4969    * Terminate list of indices with -1
4970    */
4971   ctxPtr->colonLocalVarCache[j] = -1;
4972 
4973   /* fprintf(stderr, ".. search #local vars %d varName <%s> colonvars %d found %p\n",
4974      localCt, varName, nrColonVars, (void*)result);
4975   */
4976 
4977   return result;
4978 }
4979 
4980 /*
4981  *----------------------------------------------------------------------
4982  * CompiledColonLocalsLookup --
4983  *
4984  *    Lookup single colon prefixed variables from the compiled locals. This
4985  *    function uses a cache consisting of colon prefixed variables to speed up
4986  *    variable access.
4987  *
4988  * Results:
4989  *    Returns Tcl_Var (or NULL, when lookup is not successful)
4990  *
4991  * Side effects:
4992  *    None.
4993  *
4994  *----------------------------------------------------------------------
4995  */
4996 
4997 static Tcl_Var CompiledColonLocalsLookup(CallFrame *varFramePtr, const char *varName)
4998   nonnull(1) nonnull(2);
4999 
5000 static Tcl_Var
CompiledColonLocalsLookup(CallFrame * varFramePtr,const char * varName)5001 CompiledColonLocalsLookup(CallFrame *varFramePtr, const char *varName) {
5002   Tcl_Var result;
5003 
5004   nonnull_assert(varFramePtr != NULL);
5005   nonnull_assert(varName != NULL);
5006 
5007   if (varFramePtr->numCompiledLocals == 0) {
5008     result = NULL;
5009   } else {
5010     Tcl_Obj       **localNames;
5011     int             nameLength;
5012     Tcl_Command     cmd;
5013     NsfProcContext *ctxPtr;
5014 
5015     /*
5016      * Get the string table of the compiled locals and the length of the
5017      * variable to search for faster access into local variables.
5018      */
5019     localNames = &varFramePtr->localCachePtr->varName0;
5020     nameLength = (int)strlen(varName);
5021 
5022     cmd = (Tcl_Command )varFramePtr->procPtr->cmdPtr;
5023     ctxPtr = ProcContextRequire(cmd);
5024 
5025     /*
5026      * Check whether we have already a sorted cache (colonLocalVarCache). If not,
5027      * build the cache and check in the same step for the wanted variable.
5028      */
5029     if (unlikely(ctxPtr->colonLocalVarCache == NULL)) {
5030       result = CompiledColonLocalsLookupBuildCache(varFramePtr, varName, nameLength, localNames, ctxPtr);
5031 
5032     } else {
5033       int i, j;
5034 
5035       /*
5036        * We have a colonLocalVarCache.
5037        *
5038        * Search the colonVarCache, which is alphabetically sorted to allow e.g.
5039        * termination after O(n/2) on failures.
5040        */
5041       result = NULL;
5042       for (i = 0, j = ctxPtr->colonLocalVarCache[0]; j > -1; ++i, j = ctxPtr->colonLocalVarCache[i]) {
5043         int         len;
5044         const char *localName;
5045 
5046         localName = TclGetStringFromObj(localNames[j], &len);
5047 
5048         /* fprintf(stderr, ".. [%d] varNameObj %p <%s> vs <%s>\n",
5049            j, (void *)varNameObj, localName, varName); */
5050 
5051         /*
5052          * The first char of colon varName is always a colon, so we do not need to
5053          * compare.
5054          */
5055         if (varName[1] < localName[1]) {
5056           break;
5057 
5058         } else if (varName[1] == localName[1]) {
5059           int cmp;
5060           /*
5061            * Even when the first character is identical, we call compare() only
5062            * when the lengths are equal.
5063            */
5064           if (len != nameLength) {
5065             continue;
5066           }
5067 
5068           cmp = strcmp(varName, localName);
5069           if (cmp == 0) {
5070             result = (Tcl_Var) &varFramePtr->compiledLocals[j];
5071             break;
5072 
5073           } else if (cmp < 0) {
5074             /*
5075              * We are past the place, where the variable should be, so give up.
5076              */
5077             break;
5078           }
5079         }
5080       }
5081 
5082 #if 0
5083       if (result != NULL) {
5084         fprintf(stderr, "... <%s> found -> [%d] %p\n", varName, j, (void *)result);
5085       }
5086 #endif
5087     }
5088   }
5089   return result;
5090 }
5091 
5092 
5093 /*
5094  *----------------------------------------------------------------------
5095  * GetVarAndNameFromHash --
5096  *
5097  *    Convenience function to obtain variable and name from
5098  *    a variable hash entry.
5099  *
5100  * Results:
5101  *    Results are passed back in argument 2 and 3
5102  *
5103  * Side effects:
5104  *    None.
5105  *
5106  *----------------------------------------------------------------------
5107  */
5108 static void GetVarAndNameFromHash(const Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj)
5109   nonnull(1) nonnull(2) nonnull(3);
5110 
5111 static void
GetVarAndNameFromHash(const Tcl_HashEntry * hPtr,Var ** val,Tcl_Obj ** varNameObj)5112 GetVarAndNameFromHash(const Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) {
5113 
5114   nonnull_assert(hPtr != NULL);
5115   nonnull_assert(val != NULL);
5116   nonnull_assert(varNameObj != NULL);
5117 
5118   *val = TclVarHashGetValue(hPtr);
5119   *varNameObj = TclVarHashGetKey(*val);
5120 }
5121 
5122 
5123 /*********************************************************
5124  *
5125  * Variable resolvers
5126  *
5127  *********************************************************/
5128 #define FOR_COLON_RESOLVER(ptr) (*(ptr) == ':' && *((ptr)+1) != ':')
5129 
5130 /*
5131  *----------------------------------------------------------------------
5132  * MethodName --
5133  *
5134  *    Return the methodName from a Tcl_Obj, strips potentially the
5135  *    colon prefix
5136  *
5137  * Results:
5138  *    method name
5139  *
5140  * Side effects:
5141  *    None.
5142  *
5143  *----------------------------------------------------------------------
5144  */
5145 static const char *MethodName(Tcl_Obj *methodObj)
5146   nonnull(1) returns_nonnull;
5147 
5148 static const char *
MethodName(Tcl_Obj * methodObj)5149 MethodName(Tcl_Obj *methodObj) {
5150   const char *methodName;
5151 
5152   nonnull_assert(methodObj != NULL);
5153 
5154   methodName = ObjStr(methodObj);
5155   if (FOR_COLON_RESOLVER(methodName)) {
5156     methodName ++;
5157   }
5158   return methodName;
5159 }
5160 
5161 const char *
NsfMethodName(Tcl_Obj * methodObj)5162 NsfMethodName(Tcl_Obj *methodObj) {
5163 
5164   nonnull_assert(methodObj != NULL);
5165 
5166   return MethodName(methodObj);
5167 }
5168 
5169 /*
5170  *----------------------------------------------------------------------
5171  * NsfMethodNamePath --
5172  *
5173  *    Compute the full method name for error messages containing the
5174  *    ensemble root.
5175  *
5176  * Results:
5177  *    Tcl_Obj of reference count 0, caller has to take care for
5178  *    refcounting.
5179  *
5180  * Side effects:
5181  *    None.
5182  *
5183  *----------------------------------------------------------------------
5184  */
5185 
5186 Tcl_Obj *
NsfMethodNamePath(Tcl_Interp * interp,Tcl_CallFrame * framePtr,const char * methodName)5187 NsfMethodNamePath(Tcl_Interp *interp,
5188                   Tcl_CallFrame *framePtr,
5189                   const char *methodName) {
5190 
5191   Tcl_Obj *resultObj;
5192 
5193   nonnull_assert(interp != NULL);
5194   nonnull_assert(methodName != NULL);
5195 
5196   if (framePtr != NULL) {
5197     resultObj = CallStackMethodPath(interp, framePtr);
5198   } else {
5199     resultObj = Tcl_NewListObj(0, NULL);
5200   }
5201 
5202   Tcl_ListObjAppendElement(interp, resultObj,
5203                            Tcl_NewStringObj(methodName, -1));
5204   return resultObj;
5205 }
5206 
5207 
5208 /*
5209  *----------------------------------------------------------------------
5210  * NsColonVarResolver --
5211  *
5212  *    Namespace resolver for namespace specific variable lookup.
5213  *    colon prefix
5214  *
5215  * Results:
5216  *    method name
5217  *
5218  * Side effects:
5219  *    None.
5220  *
5221  *----------------------------------------------------------------------
5222  */
5223 static int NsColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
5224                               int flags, Tcl_Var *varPtr)
5225   nonnull(1) nonnull(2) nonnull(5);
5226 
5227 static int
NsColonVarResolver(Tcl_Interp * interp,const char * varName,Tcl_Namespace * UNUSED (nsPtr),int flags,Tcl_Var * varPtr)5228 NsColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
5229                    int flags, Tcl_Var *varPtr) {
5230   Tcl_CallFrame *varFramePtr;
5231   TclVarHashTable *varTablePtr;
5232   NsfObject *object;
5233   int new;
5234   unsigned int frameFlags;
5235   Tcl_Obj *key;
5236 
5237   nonnull_assert(interp != NULL);
5238   nonnull_assert(varName != NULL);
5239   nonnull_assert(varPtr != NULL);
5240 
5241 #if defined(VAR_RESOLVER_TRACE)
5242   fprintf(stderr, "NsColonVarResolver '%s' flags %.6x\n", varName, flags);
5243 #endif
5244 
5245   /*
5246    * Case 1: The variable is to be resolved in global scope, proceed in
5247    * resolver chain
5248    */
5249   if (unlikely((flags & TCL_GLOBAL_ONLY) != 0u)) {
5250     /*fprintf(stderr, "global-scoped lookup for var '%s' in NS '%s'\n", varName,
5251       nsPtr->fullName);*/
5252     return TCL_CONTINUE;
5253   }
5254 
5255   /*
5256    * Case 2: The lookup happens in a proc frame (lookup in compiled
5257    * locals and hash-table vars).  We are not interested to handle
5258    * these cases here, so proceed in resolver chain.
5259    */
5260   varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
5261   assert(varFramePtr != NULL);
5262 
5263   frameFlags = (unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr);
5264 #if defined(VAR_RESOLVER_TRACE)
5265   fprintf(stderr, "NsColonVarResolver '%s' frame flags %.6x\n", varName,
5266           Tcl_CallFrame_isProcCallFrame(varFramePtr));
5267 #endif
5268 
5269   if ((frameFlags & FRAME_IS_PROC) != 0u) {
5270 #if defined(VAR_RESOLVER_TRACE)
5271     fprintf(stderr, "...... forwarding to next resolver\n");
5272 #endif
5273     /*fprintf(stderr, "proc-scoped var '%s' assumed, frame %p flags %.6x\n",
5274       name, varFramePtr, Tcl_CallFrame_isProcCallFrame(varFramePtr));*/
5275     return TCL_CONTINUE;
5276   }
5277 
5278   /*
5279    * FRAME_IS_NSF_CMETHOD has always FRAME_IS_PROC set, so it is
5280    * handled already above
5281    */
5282   assert((frameFlags & FRAME_IS_NSF_CMETHOD) == 0u);
5283 
5284   if ((frameFlags & FRAME_IS_NSF_OBJECT) == 0u) {
5285     /*
5286      * Case 3: we are not in a Next Scripting frame, so proceed as well
5287      */
5288     return TCL_CONTINUE;
5289 
5290   } else {
5291     /*
5292      *  Case 4: we are in a Next Scripting object frame
5293      */
5294 
5295     if (*varName == ':') {
5296       if (*(varName+1) != ':') {
5297         /*
5298          * Case 4a: The variable name starts with a single ":". Skip
5299          * the char, but stay in the resolver.
5300          */
5301         varName ++;
5302       } else {
5303         /*
5304          * Case 4b: Names starting  with "::" are not for us
5305          */
5306         return TCL_CONTINUE;
5307       }
5308     } else if (NSTail(varName) != varName) {
5309       /*
5310        * Case 4c: Names containing "::" are not for us
5311        */
5312       return TCL_CONTINUE;
5313     }
5314 
5315     /*
5316      * Since we know that we are here always in an object frame, we
5317      * can blindly get the object from the client data .
5318      */
5319     object = (NsfObject *)Tcl_CallFrame_clientData(varFramePtr);
5320   }
5321 
5322   /*
5323    * We have an object and create the variable if not found
5324    */
5325   assert(object != NULL);
5326 
5327   varTablePtr = (object->nsPtr != NULL) ? Tcl_Namespace_varTablePtr(object->nsPtr) : object->varTablePtr;
5328   assert(varTablePtr != NULL);
5329 
5330   /*
5331    * Does the variable exist in the object's namespace?
5332    */
5333   key = Tcl_NewStringObj(varName, -1);
5334   INCR_REF_COUNT(key);
5335 
5336   *varPtr = (Tcl_Var)VarHashCreateVar(varTablePtr, key, NULL);
5337 
5338 #if defined(VAR_RESOLVER_TRACE)
5339   fprintf(stderr, "...... lookup of '%s' for object '%s' returns %p\n",
5340           varName, ObjectName(object), *varPtr);
5341 #endif
5342   if (*varPtr == NULL) {
5343     /*
5344      * We failed to find the variable so far, therefore we create it
5345      * in this var table.  Note that in several cases above,
5346      * TCL_CONTINUE takes care for variable creation.
5347      */
5348 
5349     const Var *newVar = VarHashCreateVar(varTablePtr, key, &new);
5350     *varPtr = (Tcl_Var)newVar;
5351   }
5352   DECR_REF_COUNT(key);
5353 
5354   return likely(*varPtr != NULL) ? TCL_OK : TCL_ERROR;
5355 }
5356 
5357 /*********************************************************
5358  *
5359  * Begin of compiled var resolver
5360  *
5361  *********************************************************/
5362 
5363 typedef struct NsfResolvedVarInfo {
5364   Tcl_ResolvedVarInfo vInfo;        /* This must be the first element. */
5365   NsfObject          *lastObject;
5366   Tcl_Var             var;
5367   Tcl_Obj            *nameObj;
5368 } NsfResolvedVarInfo;
5369 
5370 /*
5371  *----------------------------------------------------------------------
5372  * HashVarFree --
5373  *
5374  *    Free hashed variables based on refCount.
5375  *
5376  * Results:
5377  *    None.
5378  *
5379  * Side effects:
5380  *   Changed refCount or freed variable.
5381  *
5382  *----------------------------------------------------------------------
5383  */
5384 NSF_INLINE static void
HashVarFree(Tcl_Var var)5385 HashVarFree(Tcl_Var var) {
5386   if (unlikely(VarHashRefCount(var) < 2)) {
5387     /*fprintf(stderr, "#### free %p\n", var);*/
5388     ckfree((char *) var);
5389   } else {
5390     VarHashRefCount(var)--;
5391   }
5392 }
5393 
5394 /*
5395  *----------------------------------------------------------------------
5396  * CompiledColonVarFetch --
5397  *
5398  *    This function is the actual variable resolution handler for a
5399  *    colon-prefixed (":/varName/") found in a compiled script registered by
5400  *    the compiling var resolver (see InterpCompiledColonVarResolver()). When
5401  *    initializing a call frame, this handler is called, crawls the object's
5402  *    var table (creating a variable, if needed), and returns a Var
5403  *    structure. Based on this, a link variable ":/varName/" pointing to this
5404  *    object variable (i.e., "varName") is created and is stored in the
5405  *    compiled locals array of the call frame. Beware that these link
5406  *    variables interact with the family of link-creating commands
5407  *    ([variable], [global], [upvar]) by being subject to "retargeting" upon
5408  *    name conflicts (see tests/varresolutiontest.tcl for some examples).
5409  *
5410  * Results:
5411  *    Tcl_Var containing value or NULL.
5412  *
5413  * Side effects:
5414  *    Updates of Variable structure cache in necessary.
5415  *
5416  *----------------------------------------------------------------------
5417  */
5418 
5419 static Tcl_Var CompiledColonVarFetch(Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr)
5420   nonnull(1) nonnull(2);
5421 
5422 static Tcl_Var
CompiledColonVarFetch(Tcl_Interp * interp,Tcl_ResolvedVarInfo * vinfoPtr)5423 CompiledColonVarFetch(Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr) {
5424   NsfResolvedVarInfo  *resVarInfo;
5425   NsfCallStackContent *cscPtr;
5426   NsfObject           *object;
5427   Tcl_Var              var;
5428 
5429   nonnull_assert(interp != NULL);
5430   nonnull_assert(vinfoPtr != NULL);
5431 
5432   resVarInfo = (NsfResolvedVarInfo *)vinfoPtr;
5433   var = resVarInfo->var;
5434 
5435 #if defined(VAR_RESOLVER_TRACE)
5436   {
5437     unsigned int flags = (var != NULL) ? ((Var *)var)->flags : 0u;
5438     fprintf(stderr, "CompiledColonVarFetch var '%s' var %p flags = %.4x dead? %.4x\n",
5439             ObjStr(resVarInfo->nameObj), var, flags, flags & VAR_DEAD_HASH);
5440   }
5441 #endif
5442 
5443   cscPtr = CallStackGetTopFrame0(interp);
5444   if (likely(cscPtr != NULL)) {
5445     object = cscPtr->self;
5446   } else {
5447     object = NULL;
5448   }
5449 
5450   /*
5451    * We cache lookups based on nsf objects; we have to care about
5452    * cases, where the instance variables are in some delete states.
5453    *
5454    */
5455 
5456   if ((var != NULL)
5457       && ((object == resVarInfo->lastObject))
5458       && (((((Var *)var)->flags) & VAR_DEAD_HASH) == 0u)) {
5459     /*
5460      * The variable is valid.
5461      */
5462 #if defined(VAR_RESOLVER_TRACE)
5463     fprintf(stderr, ".... cached var '%s' var %p flags = %.4x\n",
5464             ObjStr(resVarInfo->nameObj), var, ((Var *)var)->flags);
5465 #endif
5466     /*
5467      * return var;
5468      */
5469 
5470   } else if (unlikely(object == NULL)) {
5471     var = NULL;
5472 
5473   } else {
5474     TclVarHashTable  *varTablePtr;
5475     int               new;
5476 
5477     if (var != NULL) {
5478       /*
5479        * The variable is not valid anymore. Clean it up.
5480        */
5481       HashVarFree(var);
5482     }
5483 
5484     if (object->nsPtr != NULL) {
5485       varTablePtr = Tcl_Namespace_varTablePtr(object->nsPtr);
5486     } else if (object->varTablePtr != NULL) {
5487       varTablePtr = object->varTablePtr;
5488     } else {
5489       /*
5490        * In most situations, we have a varTablePtr through the clauses
5491        * above. However, if someone redefines e.g. the method "configure" or
5492        * "objectparameter", we might find an object with a still empty
5493        * varTable, since these are lazy initiated.
5494        */
5495       varTablePtr = object->varTablePtr = VarHashTableCreate();
5496     }
5497     assert(varTablePtr != NULL);
5498 
5499     resVarInfo->lastObject = object;
5500 #if defined(VAR_RESOLVER_TRACE)
5501     fprintf(stderr, "Fetch var %s in object %s\n", TclGetString(resVarInfo->nameObj), ObjectName(object));
5502 #endif
5503     resVarInfo->var = var = (Tcl_Var) VarHashCreateVar(varTablePtr, resVarInfo->nameObj, &new);
5504     /*
5505      * Increment the reference counter to avoid ckfree() of the variable
5506      * in Tcl's FreeVarEntry(); for cleanup, we provide our own
5507      * HashVarFree();
5508      */
5509     VarHashRefCount(var)++;
5510 #if defined(VAR_RESOLVER_TRACE)
5511     {
5512       const Var *v = (Var *)(resVarInfo->var);
5513       fprintf(stderr, ".... looked up existing var %s var %p flags = %.6x undefined %d\n",
5514               ObjStr(resVarInfo->nameObj),
5515               v, v->flags,
5516               TclIsVarUndefined(v));
5517     }
5518 #endif
5519   }
5520 
5521   return var;
5522 }
5523 
5524 /*
5525  *----------------------------------------------------------------------
5526  * CompiledColonVarFree --
5527  *
5528  *    DeleteProc of the compiled variable handler.
5529  *
5530  * Results:
5531  *    None.
5532  *
5533  * Side effects:
5534  *   Free compiled variable structure and variable.
5535  *
5536  *----------------------------------------------------------------------
5537  */
5538 static void CompiledColonVarFree(Tcl_ResolvedVarInfo *vInfoPtr)
5539   nonnull(1);
5540 
5541 static void
CompiledColonVarFree(Tcl_ResolvedVarInfo * vInfoPtr)5542 CompiledColonVarFree(Tcl_ResolvedVarInfo *vInfoPtr) {
5543   NsfResolvedVarInfo *resVarInfo;
5544 
5545   nonnull_assert(vInfoPtr != NULL);
5546 
5547   resVarInfo = (NsfResolvedVarInfo *)vInfoPtr;
5548 #if defined(VAR_RESOLVER_TRACE)
5549   fprintf(stderr, "CompiledColonVarFree %p for variable '%s'\n",
5550           resVarInfo, ObjStr(resVarInfo->nameObj));
5551 #endif
5552 
5553   DECR_REF_COUNT(resVarInfo->nameObj);
5554   if (resVarInfo->var != NULL) {
5555     HashVarFree(resVarInfo->var);
5556   }
5557   FREE(NsfResolvedVarInfo, vInfoPtr);
5558 }
5559 
5560 /*
5561  *----------------------------------------------------------------------
5562  * InterpCompiledColonVarResolver --
5563  *
5564  *    For colon-prefixed (":/varName/") variables, we provide our own
5565  *    var resolver for compiling scripts and evaluating compiled
5566  *    scripts (e.g., proc bodies). At the time of first compilation
5567  *    (or re-compilation), this resolver is processed (see
5568  *    tclProc.c:InitResolvedLocals()). It registers two handlers for a
5569  *    given, colon-prefixed variable found in the script: the actual
5570  *    variable fetcher and a variable cleanup handler. The variable
5571  *    fetcher is executed whenever a Tcl call frame is initialized and
5572  *    the array of compiled locals is constructed (see also
5573  *    InitResolvedLocals()).
5574  *
5575  *    The Tcl var resolver protocol dictates that per-namespace
5576  *    compiling var resolvers take precedence over this per-interp
5577  *    compiling var resolver. That is, per-namespace resolvers are
5578  *    processed first and can effectively out-rule per-interp
5579  *    resolvers by signaling TCL_OK or TCL_BREAK.
5580  *
5581  * Results:
5582  *    TCL_OK or TCL_CONTINUE (according to Tcl's var resolver protocol)
5583  *
5584  * Side effects:
5585  *    Registers per-variable resolution and cleanup handlers.
5586  *
5587  *----------------------------------------------------------------------
5588  */
5589 static int InterpCompiledColonVarResolver(Tcl_Interp *interp, const char *name, int length,
5590                                           Tcl_Namespace *UNUSED(context), Tcl_ResolvedVarInfo **rPtr)
5591   nonnull(1) nonnull(2) nonnull(5);
5592 
5593 static int
InterpCompiledColonVarResolver(Tcl_Interp * interp,const char * name,int length,Tcl_Namespace * UNUSED (context),Tcl_ResolvedVarInfo ** rPtr)5594 InterpCompiledColonVarResolver(Tcl_Interp *interp,
5595                                const char *name, int length, Tcl_Namespace *UNUSED(context),
5596                                Tcl_ResolvedVarInfo **rPtr) {
5597   /*
5598    *  The variable handler is registered, when we have an active Next
5599    *  Scripting object and the variable starts with the appropriate
5600    *  prefix. Note that getting the "self" object is a weak protection against
5601    *  handling of wrong vars
5602    */
5603   NsfObject *object;
5604 
5605   nonnull_assert(interp != NULL);
5606   nonnull_assert(name != NULL);
5607   nonnull_assert(rPtr != NULL);
5608 
5609   object = GetSelfObj(interp);
5610 #if defined(VAR_RESOLVER_TRACE)
5611   fprintf(stderr, "compiled var resolver for %s, obj %p\n", name, object);
5612 #endif
5613 
5614   if (likely(object != NULL) && FOR_COLON_RESOLVER(name)) {
5615     NsfResolvedVarInfo *resVarInfo = NEW(NsfResolvedVarInfo);
5616 
5617     resVarInfo->vInfo.fetchProc = CompiledColonVarFetch;
5618     resVarInfo->vInfo.deleteProc = CompiledColonVarFree; /* if NULL, Tcl does a ckfree on proc clean up */
5619     resVarInfo->lastObject = NULL;
5620     resVarInfo->var = NULL;
5621     resVarInfo->nameObj = Tcl_NewStringObj(name+1, length-1);
5622     INCR_REF_COUNT(resVarInfo->nameObj);
5623 
5624 #if defined(VAR_RESOLVER_TRACE)
5625     fprintf(stderr, "... resVarInfo %p nameObj %p '%s' obj %p %s\n",
5626             resVarInfo, resVarInfo->nameObj, ObjStr(resVarInfo->nameObj),
5627             object, ObjectName(object));
5628 #endif
5629 
5630     *rPtr = (Tcl_ResolvedVarInfo *)resVarInfo;
5631 
5632     return TCL_OK;
5633   }
5634   return TCL_CONTINUE;
5635 }
5636 
5637 /*
5638  *----------------------------------------------------------------------
5639  * InterpGetFrameAndFlags --
5640  *
5641  *    Return for the provided interp the flags of the frame (returned as
5642  *    result) and the actual varFrame (returned in the second argument). In
5643  *    case, the toplevel frame is a LAMBDA frame, skip it.
5644  *
5645  * Results:
5646  *    Frame flags, varFrame
5647  *
5648  * Side effects:
5649  *    None.
5650  *
5651  *----------------------------------------------------------------------
5652  */
5653 
5654 NSF_INLINE static int InterpGetFrameAndFlags(Tcl_Interp *interp, CallFrame **framePtr)
5655   nonnull(1) nonnull(2);
5656 
5657 NSF_INLINE static int
InterpGetFrameAndFlags(Tcl_Interp * interp,CallFrame ** framePtr)5658 InterpGetFrameAndFlags(Tcl_Interp *interp, CallFrame **framePtr) {
5659   int frameFlags;
5660 
5661   nonnull_assert(interp != NULL);
5662   nonnull_assert(framePtr != NULL);
5663 
5664   *framePtr = Tcl_Interp_varFramePtr(interp);
5665   frameFlags = Tcl_CallFrame_isProcCallFrame(*framePtr);
5666   /*
5667    * If the resolver is called from a lambda frame, use always the parent frame
5668    */
5669   if ((frameFlags & FRAME_IS_LAMBDA) != 0u) {
5670     *framePtr = (CallFrame *)Tcl_CallFrame_callerPtr(*framePtr);
5671     frameFlags = Tcl_CallFrame_isProcCallFrame(*framePtr);
5672 #if defined(VAR_RESOLVER_TRACE)
5673     fprintf(stderr, "InterpColonVarResolver skip lambda frame flags %.6x\n",
5674             Tcl_CallFrame_isProcCallFrame(*framePtr));
5675 #endif
5676   }
5677 #if defined(VAR_RESOLVER_TRACE)
5678   fprintf(stderr, "... final frame flags %.6x\n", frameFlags);
5679 #endif
5680   return frameFlags;
5681 }
5682 
5683 /*
5684  *----------------------------------------------------------------------
5685  * InterpColonVarResolver --
5686  *
5687  *    For accessing object (instance) variables using the colon-prefix
5688  *    notation (":/varName/"), we provide our own var resolvers. This function
5689  *    is the non-compiling var resolver; its services are requested in two
5690  *    situations: a) when evaluating non-compiled statements, b) when
5691  *    executing slow-path bytecode instructions, with "slow path" referring to
5692  *    bytecode instructions not making use of the compiled locals array (and,
5693  *    e.g., reverting to TclObjLookupVar*() calls).
5694  *
5695  *    The Tcl var resolver protocol dictates that per-namespace, non-compiling
5696  *    var resolvers take precedence over this per-interp non-compiling var
5697  *    resolver. That is, per-namespace resolvers are processed first and can
5698  *    effectively out-rule per-interp resolvers by signaling TCL_OK or
5699  *    TCL_BREAK. See e.g. TclLookupSimpleVar().
5700  *
5701  * Results:
5702  *    TCL_OK or TCL_CONTINUE (according to on Tcl's var resolver protocol)
5703  *
5704  * Side effects:
5705  *    If successful, return varPtr, pointing to instance variable.
5706  *
5707  *----------------------------------------------------------------------
5708  */
5709 
5710 static int InterpColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
5711                                   int flags, Tcl_Var *varPtr)
5712   nonnull(1) nonnull(2) nonnull(5);
5713 
5714 static int
InterpColonVarResolver(Tcl_Interp * interp,const char * varName,Tcl_Namespace * UNUSED (nsPtr),int flags,Tcl_Var * varPtr)5715 InterpColonVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *UNUSED(nsPtr),
5716                        int flags, Tcl_Var *varPtr) {
5717   int              new;
5718   unsigned int     frameFlags;
5719   CallFrame       *varFramePtr;
5720   TclVarHashTable *varTablePtr;
5721   NsfObject       *object;
5722   Tcl_Obj         *keyObj;
5723   Tcl_Var          var;
5724 
5725   nonnull_assert(interp != NULL);
5726   nonnull_assert(varName != NULL);
5727   nonnull_assert(varPtr != NULL);
5728 
5729   if (!FOR_COLON_RESOLVER(varName) || (flags & (TCL_NAMESPACE_ONLY)) != 0u) {
5730     /*
5731      * Ordinary names (not starting with our prefix) and namespace only
5732      * lookups are not for us. We cannot filter for TCL_GLOBAL_ONLY, since
5733      * "vwait :varName" is called with this flag.
5734      */
5735 #if defined(VAR_RESOLVER_TRACE)
5736     fprintf(stderr, "InterpColonVarResolver '%s' flags %.6x not for us\n",
5737             varName, flags);
5738 #endif
5739     return TCL_CONTINUE;
5740   }
5741 
5742   frameFlags = (unsigned int)InterpGetFrameAndFlags(interp, &varFramePtr);
5743 
5744   if (likely((frameFlags & FRAME_IS_NSF_METHOD) != 0u)) {
5745     /* varPtr = CompiledLocalsLookup(varFramePtr, varName);
5746        fprintf(stderr, "CompiledLocalsLookup for %p %s returned %p\n", varFramePtr, varName, *varPtr);
5747     */
5748     if ((*varPtr = CompiledColonLocalsLookup(varFramePtr, varName))) {
5749       /*
5750        * This section is reached under notable circumstances and represents a
5751        * point of interaction between our resolvers for non-compiled (i.e.,
5752        * InterpColonVarResolver()) and compiled script execution (i.e.,
5753        * InterpCompiledColonVarResolver()).
5754        *
5755        * Expect this branch to be hit iff...
5756        *
5757        * 1. ... InterpCompiledColonVarResolver() is called from within the Tcl
5758        * bytecode interpreter when executing a bytecode-compiled script on a
5759        * *slow path* (i.e., involving a TclObjLookupVarEx() call)
5760        *
5761        * 2. ... the act of variable resolution (i.e., TclObjLookupVarEx()) has
5762        * not been restricted to an effective namespace (TCL_NAMESPACE_ONLY)
5763        *
5764        * 3. ..., resulting from the fact of participating in a bytecode
5765        * interpretation, CompiledColonVarFetch() stored a link variable
5766        * (pointing to the actual/real object variable, whether defined or not)
5767        * under the given varName value into the current call frame's array of
5768        * compiled locals (when initializing the call frame; see
5769        * tclProc.c:InitResolvedLocals()).
5770        */
5771 #if defined(VAR_RESOLVER_TRACE)
5772       fprintf(stderr, ".... found local %s varPtr %p flags %.6x\n",
5773               varName, *varPtr, flags);
5774 #endif
5775       /*
5776        * By looking up the compiled-local directly and signaling TCL_OK, we
5777        * optimize a little by avoiding further lookups down the Tcl var
5778        * resolution infrastructure. Note that signaling TCL_CONTINUE would
5779        * work too, however, it would involve extra resolution overhead.
5780        */
5781       return TCL_OK;
5782     }
5783 
5784     object = ((NsfCallStackContent *)varFramePtr->clientData)->self;
5785 
5786   } else if ((frameFlags & FRAME_IS_NSF_CMETHOD) != 0u) {
5787     object = ((NsfCallStackContent *)varFramePtr->clientData)->self;
5788 
5789   } else if ((frameFlags & FRAME_IS_NSF_OBJECT) != 0u) {
5790     object = (NsfObject *)(varFramePtr->clientData);
5791 
5792   } else {
5793 #if defined(VAR_RESOLVER_TRACE)
5794     fprintf(stderr, ".... not found %s\n", varName);
5795 #endif
5796     return TCL_CONTINUE;
5797   }
5798 
5799   /*
5800    * Trim the varName for the colon prefix (":").
5801    */
5802   varName ++;
5803 
5804   /*
5805    * We have an object and create the variable if not found
5806    */
5807   assert(object != NULL);
5808   if (unlikely(object->nsPtr != NULL)) {
5809     varTablePtr = Tcl_Namespace_varTablePtr(object->nsPtr);
5810   } else if (likely(object->varTablePtr != NULL)) {
5811     varTablePtr = object->varTablePtr;
5812   } else {
5813     /*
5814      * In most situations, we have a varTablePtr through the clauses
5815      * above. However, if someone redefines e.g. the method "configure" or
5816      * "objectparameter", we might find an object with a still empty
5817      * varTable, since these are lazy initiated.
5818      */
5819     varTablePtr = object->varTablePtr = VarHashTableCreate();
5820   }
5821   assert(varTablePtr != NULL);
5822 
5823   /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTablePtr %p\n",
5824     varName, object, object->nsPtr, varTablePtr);*/
5825 
5826   keyObj = Tcl_NewStringObj(varName, -1);
5827   INCR_REF_COUNT(keyObj);
5828 
5829   var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, NULL);
5830   if (likely(var != NULL)) {
5831 #if defined(VAR_RESOLVER_TRACE)
5832     fprintf(stderr, ".... found in hash-table %s %p flags %.6x ns %p\n",
5833             varName, var, ((Var *)var)->flags,  object->nsPtr);
5834 #endif
5835     /*
5836      * Make coverage analysis easier.
5837      */
5838     assert(1);
5839   } else {
5840     /*
5841      * We failed to find the variable, therefore we create it new
5842      */
5843     var = (Tcl_Var)VarHashCreateVar(varTablePtr, keyObj, &new);
5844 #if defined(VAR_RESOLVER_TRACE)
5845     fprintf(stderr, ".... var %p %s created in hash-table %p\n", var, varName, varTablePtr);
5846 #endif
5847   }
5848 
5849   *varPtr = var;
5850   DECR_REF_COUNT(keyObj);
5851 
5852   return TCL_OK;
5853 }
5854 
5855 /*********************************************************
5856  *
5857  * End of var resolvers
5858  *
5859  *********************************************************/
5860 
5861 /*********************************************************
5862  *
5863  * Begin of cmd resolver
5864  *
5865  *********************************************************/
5866 /*
5867  *----------------------------------------------------------------------
5868  * InterpColonCmdResolver --
5869  *
5870  *    Resolve command names. If the command starts with the Next
5871  *    Scripting specific prefix and we are on a Next Scripting stack
5872  *    frame, treat command as OO method.
5873  *
5874  * Results:
5875  *    TCL_OK or TCL_CONTINUE (based on Tcl's command resolver protocol)
5876  *
5877  * Side effects:
5878  *   If successful, return cmdPtr, pointing to method.
5879  *
5880  *----------------------------------------------------------------------
5881  */
5882 static int InterpColonCmdResolver(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *UNUSED(nsPtr),
5883                                   unsigned int flags, Tcl_Command *cmdPtr)
5884   nonnull(1) nonnull(2) nonnull(5);
5885 
5886 static int
InterpColonCmdResolver(Tcl_Interp * interp,const char * cmdName,Tcl_Namespace * UNUSED (nsPtr),unsigned int flags,Tcl_Command * cmdPtr)5887 InterpColonCmdResolver(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *UNUSED(nsPtr),
5888                        unsigned int flags, Tcl_Command *cmdPtr) {
5889   CallFrame   *varFramePtr;
5890   unsigned int frameFlags;
5891 
5892   nonnull_assert(interp != NULL);
5893   nonnull_assert(cmdName != NULL);
5894   nonnull_assert(cmdPtr != NULL);
5895 
5896   /* fprintf(stderr, "InterpColonCmdResolver %s flags %.6x\n", cmdName, flags); */
5897 
5898   if (likely((*cmdName == ':' && *(cmdName + 1) == ':') || (flags & TCL_GLOBAL_ONLY) != 0u)) {
5899     /* fully qualified names and global lookups are not for us */
5900     /*fprintf(stderr, "... not for us %s flags %.6x\n", cmdName, flags);*/
5901     return TCL_CONTINUE;
5902   }
5903   frameFlags = (unsigned int)InterpGetFrameAndFlags(interp, &varFramePtr);
5904 
5905   /*
5906    * The resolver is called as well, when a body of a method is
5907    * compiled.  In these situations, Tcl stacks a non-proc frame, that
5908    * we have to skip. In order to safely identify such situations, we
5909    * stuff into the call flags of the proc frame during the
5910    * compilation step NSF_CSC_CALL_IS_COMPILE.
5911    */
5912   if ((frameFlags == 0u) && (Tcl_CallFrame_callerPtr(varFramePtr) != NULL)) {
5913     ClientData clientData;
5914 
5915     varFramePtr = (CallFrame *)Tcl_CallFrame_callerPtr(varFramePtr);
5916     frameFlags = (unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr);
5917     clientData = varFramePtr->clientData;
5918 
5919     if ( (frameFlags != 0u)
5920          && (clientData != NULL)
5921          && ((((NsfCallStackContent *)clientData)->flags & NSF_CSC_CALL_IS_COMPILE) == 0u)
5922          ) {
5923       frameFlags = 0u;
5924     } else {
5925 #if defined(CMD_RESOLVER_TRACE)
5926       fprintf(stderr, "InterpColonCmdResolver got parent frame cmdName %s flags %.6x, frame flags %.6x\n",
5927               cmdName, flags, Tcl_CallFrame_isProcCallFrame(varFramePtr));
5928 #endif
5929     }
5930  }
5931 
5932 #if defined(CMD_RESOLVER_TRACE)
5933   fprintf(stderr, "InterpColonCmdResolver cmdName %s flags %.6x, frame flags %.6x\n",
5934           cmdName, flags, frameFlags);
5935 #endif
5936 
5937   if ((frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_OBJECT|FRAME_IS_NSF_CMETHOD)) != 0u) {
5938     if (*cmdName == ':') {
5939 #if defined(CMD_RESOLVER_TRACE)
5940       fprintf(stderr, "    ... call colonCmd for %s\n", cmdName);
5941 #endif
5942       /*
5943        * We have a cmd starting with ':', we are in an NSF frame, so
5944        * forward to the colonCmd.
5945        */
5946       *cmdPtr = RUNTIME_STATE(interp)->colonCmd;
5947 
5948       return TCL_OK;
5949     } else {
5950 
5951 #if defined(NSF_WITH_OS_RESOLVER)
5952       /*
5953        * Experimental Object-System specific resolver: If an un-prefixed
5954        * method name is found in a body of a method, we try to perform a
5955        * lookup for this method in the namespace of the object system for the
5956        * current object. If this lookup is not successful the standard lookups
5957        * are performed. The object-system specific resolver allows one to use
5958        * the "right" (un-prefixed) "self" or "next" calls without namespace
5959        * imports.
5960        */
5961       NsfObject *object;
5962       NsfObjectSystem *osPtr;
5963 
5964       if ((frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) {
5965         const NsfCallStackContent *cscPtr = (NsfCallStackContent *)varFramePtr->clientData;
5966         assert(cscPtr != NULL);
5967         object = cscPtr->self;
5968       } else if ((frameFlags & (FRAME_IS_NSF_OBJECT)) != 0u) {
5969         object = (NsfObject *)(varFramePtr->clientData);
5970       } else {
5971         object = NULL;
5972       }
5973 
5974       if (object != NULL) {
5975         Tcl_HashEntry *entryPtr;
5976         Tcl_HashTable *cmdTablePtr;
5977         Tcl_Command cmd;
5978 
5979         osPtr = GetObjectSystem(object);
5980         cmd = osPtr->rootClass->object.id;
5981         cmdTablePtr = Tcl_Namespace_cmdTablePtr(((Command *)cmd)->nsPtr);
5982         entryPtr = Tcl_CreateHashEntry(cmdTablePtr, cmdName, NULL);
5983         /*fprintf(stderr, "InterpColonCmdResolver OS specific resolver tried to lookup %s for os %s in ns %s\n",
5984           cmdName, ClassName(osPtr->rootClass), ((Command *)cmd)->nsPtr->fullName);*/
5985 
5986         if (entryPtr != NULL) {
5987           /*fprintf(stderr, "InterpColonCmdResolver OS specific resolver found %s::%s frameFlags %.6x\n",
5988             ((Command *)cmd)->nsPtr->fullName, cmdName, frameFlags);*/
5989           *cmdPtr = Tcl_GetHashValue(entryPtr);
5990 
5991           return TCL_OK;
5992         }
5993       }
5994 #endif
5995     }
5996   }
5997 
5998 #if defined(CMD_RESOLVER_TRACE)
5999   fprintf(stderr, "    ... not found %s\n", cmdName);
6000   NsfShowStack(interp);
6001 #endif
6002 
6003   return TCL_CONTINUE;
6004 }
6005 /*********************************************************
6006  *
6007  * End of cmd resolver
6008  *
6009  *********************************************************/
6010 
6011 
6012 /*
6013  *----------------------------------------------------------------------
6014  * NsfNamespaceInit --
6015  *
6016  *    Initialize a provided namespace by setting its resolvers and
6017  *    namespace path
6018  *
6019  * Results:
6020  *    none
6021  *
6022  * Side effects:
6023  *    change ns behavior
6024  *
6025  *----------------------------------------------------------------------
6026  */
6027 
6028 static void NsfNamespaceInit(Tcl_Namespace *nsPtr)
6029   nonnull(1);
6030 
6031 static void
NsfNamespaceInit(Tcl_Namespace * nsPtr)6032 NsfNamespaceInit(Tcl_Namespace *nsPtr) {
6033 
6034   nonnull_assert(nsPtr != NULL);
6035 
6036   /*
6037    * This puts a per-object namespace resolver into position upon
6038    * acquiring the namespace. Works for object-scoped commands/procs
6039    * and object-only ones (set, unset, ...)
6040    */
6041   Tcl_SetNamespaceResolvers(nsPtr,
6042                             (Tcl_ResolveCmdProc *)NULL,
6043                             NsColonVarResolver,
6044                             (Tcl_ResolveCompiledVarProc *)NULL);
6045 
6046 #if defined(NSF_WITH_INHERIT_NAMESPACES)
6047   /*
6048    * In case there is a namespace path set for the parent namespace,
6049    * apply this as well to the object namespace to avoid surprises
6050    * with "namespace path nx".
6051    */
6052   { Namespace *parentNsPtr = Tcl_Namespace_parentPtr(nsPtr);
6053     int pathLength = Tcl_Namespace_commandPathLength(parentNsPtr);
6054 
6055     if (pathLength > 0) {
6056       Namespace **pathArray = (Namespace **)ckalloc((int)sizeof(Namespace *) * pathLength);
6057       NamespacePathEntry *tmpPathArray = Tcl_Namespace_commandPathArray(parentNsPtr);
6058       int i;
6059 
6060       for (i = 0; i < pathLength; i++) {
6061         pathArray[i] = tmpPathArray[i].nsPtr;
6062       }
6063       TclSetNsPath((Namespace *)nsPtr, pathLength, (Tcl_Namespace **)pathArray);
6064       ckfree((char *)pathArray);
6065     }
6066   }
6067 #endif
6068 }
6069 
6070 static NsfObject *NSNamespaceClientDataObject(ClientData clientData) nonnull(1) pure;
6071 
6072 static NsfObject *
NSNamespaceClientDataObject(ClientData clientData)6073 NSNamespaceClientDataObject(ClientData clientData) {
6074 #ifdef NSF_MEM_COUNT
6075   NsfNamespaceClientData *nsClientData = (NsfNamespaceClientData *)clientData;
6076 
6077   nonnull_assert(clientData != NULL);
6078 
6079   /*fprintf(stderr, "NSNamespaceDeleteProc cd %p\n", clientData);
6080     fprintf(stderr, "... nsPtr %p name '%s'\n", nsClientData->nsPtr, nsClientData->nsPtr->fullName);*/
6081 
6082   return nsClientData->object;
6083 #else
6084   nonnull_assert(clientData != NULL);
6085   return (NsfObject *) clientData;
6086 #endif
6087 }
6088 
6089 
6090 /*
6091  *----------------------------------------------------------------------
6092  * SlotContainerCmdResolver --
6093  *
6094  *    This is a specialized cmd resolver for slotcontainer.  The command
6095  *    resolver should be registered for a namespace and avoids the lookup of
6096  *    childobjs for unqualified calls. This way, it is e.g. possible to call
6097  *    in a slot-obj a method [list], even in cases, where a property "list"
6098  *    is defined.
6099  *
6100  * Results:
6101  *    either TCL_CONTINUE or TCL_OK;
6102  *
6103  * Side effects:
6104  *    None.
6105  *
6106  *----------------------------------------------------------------------
6107  */
6108 
6109 static int SlotContainerCmdResolver(Tcl_Interp *interp, const char *cmdName,
6110                          Tcl_Namespace *nsPtr, unsigned int flags, Tcl_Command *cmdPtr)
6111   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
6112 
6113 static int
SlotContainerCmdResolver(Tcl_Interp * interp,const char * cmdName,Tcl_Namespace * nsPtr,unsigned int flags,Tcl_Command * cmdPtr)6114 SlotContainerCmdResolver(Tcl_Interp *interp, const char *cmdName,
6115                          Tcl_Namespace *nsPtr, unsigned int flags, Tcl_Command *cmdPtr) {
6116 
6117   nonnull_assert(cmdName != NULL);
6118   nonnull_assert(nsPtr != NULL);
6119   nonnull_assert(cmdPtr != NULL);
6120 
6121   if (*cmdName == ':' || ((flags & TCL_GLOBAL_ONLY) != 0u)) {
6122     /*
6123      * Colon names (InterpColonCmdResolver) and global lookups are not for us.
6124      */
6125     return TCL_CONTINUE;
6126   }
6127 
6128   /*fprintf(stderr, "SlotContainerCmdResolver called with %s ns %s ourNs %d clientData %p\n",
6129           cmdName, nsPtr->fullName, nsPtr->deleteProc == NSNamespaceDeleteProc,
6130           nsPtr->clientData);*/
6131 
6132   /*
6133    * Check whether this already a namespace handled by NSF
6134    */
6135   if (nsPtr->deleteProc == NSNamespaceDeleteProc && nsPtr->clientData) {
6136     NsfObject *parentObject = NSNamespaceClientDataObject(nsPtr->clientData);
6137 
6138     /*fprintf(stderr, "SlotContainerCmdResolver parentObject %p %s\n",
6139       parentObject, ObjectName(parentObject));*/
6140     /*
6141      * Make global lookups when the parent is a slotcontainer
6142      */
6143     /* parentObject = (NsfObject *) GetObjectFromString(interp, nsPtr->fullName);*/
6144     if ((parentObject->flags & NSF_IS_SLOT_CONTAINER) != 0u) {
6145       Tcl_Command cmd = Tcl_FindCommand(interp, cmdName, NULL, TCL_GLOBAL_ONLY);
6146 
6147       if (likely(cmd != NULL)) {
6148         *cmdPtr = cmd;
6149         return TCL_OK;
6150       }
6151     }
6152   }
6153 
6154   return TCL_CONTINUE;
6155  }
6156 
6157 /*
6158  *----------------------------------------------------------------------
6159  * RequireObjNamespace --
6160  *
6161  *    Obtain for an object a namespace if necessary and initialize it.
6162  *    In this function, variables existing outside of the namespace
6163  *    get copied over to the fresh namespace.
6164  *
6165  * Results:
6166  *    Tcl_Namespace
6167  *
6168  * Side effects:
6169  *    Allocate potentially a Tcl_Namespace
6170  *
6171  *----------------------------------------------------------------------
6172  */
6173 
6174 static Tcl_Namespace *
RequireObjNamespace(Tcl_Interp * interp,NsfObject * object)6175 RequireObjNamespace(Tcl_Interp *interp, NsfObject *object) {
6176 
6177   nonnull_assert(interp != NULL);
6178   nonnull_assert(object != NULL);
6179 
6180   if (object->nsPtr == NULL) {
6181     MakeObjNamespace(interp, object);
6182     NsfNamespaceInit(object->nsPtr);
6183   }
6184   assert(object->nsPtr != NULL);
6185 
6186   return object->nsPtr;
6187 }
6188 
6189 /*
6190  * Namespace related commands
6191  */
6192 /*
6193  *----------------------------------------------------------------------
6194  * NSNamespacePreserve --
6195  *
6196  *    Increment namespace refCount
6197  *
6198  * Results:
6199  *    void
6200  *
6201  * Side effects:
6202  *    None.
6203  *
6204  *----------------------------------------------------------------------
6205  */
6206 static void
NSNamespacePreserve(Tcl_Namespace * nsPtr)6207 NSNamespacePreserve(Tcl_Namespace *nsPtr) {
6208 
6209   nonnull_assert(nsPtr != NULL);
6210 
6211   MEM_COUNT_ALLOC("NSNamespace", nsPtr);
6212   Tcl_Namespace_refCount(nsPtr)++;
6213 }
6214 /*
6215  *----------------------------------------------------------------------
6216  * NSNamespaceRelease --
6217  *
6218  *    Decrement namespace's "refCount" and free namespace if necessary.
6219  *
6220  * Results:
6221  *    void
6222  *
6223  * Side effects:
6224  *    Free potentially memory.
6225  *
6226  *----------------------------------------------------------------------
6227  */
6228 static void
NSNamespaceRelease(Tcl_Namespace * nsPtr)6229 NSNamespaceRelease(Tcl_Namespace *nsPtr) {
6230 
6231   nonnull_assert(nsPtr != NULL);
6232 
6233   MEM_COUNT_FREE("NSNamespace", nsPtr);
6234   Tcl_Namespace_refCount(nsPtr)--;
6235   if (unlikely(Tcl_Namespace_refCount(nsPtr) == 0 && (Tcl_Namespace_flags(nsPtr) & NS_DEAD))) {
6236     /*
6237      * The namespace "refCount" has reached 0, we have to free
6238      * it. Unfortunately, NamespaceFree() is not exported.
6239      */
6240     /*fprintf(stderr, "HAVE TO FREE namespace %p\n", nsPtr); */
6241 
6242     /*NamespaceFree(nsPtr);*/
6243     ckfree(nsPtr->fullName);
6244     ckfree(nsPtr->name);
6245     ckfree((char *)nsPtr);
6246   }
6247 }
6248 
6249 /*
6250  *----------------------------------------------------------------------
6251  * NSDeleteCmd --
6252  *
6253  *    Delete the Tcl command for the provided methodName located in
6254  *    the provided namespace.
6255  *
6256  * Results:
6257  *    Tcl result or -1, if no such method exists int.
6258  *
6259  * Side effects:
6260  *    Command is deleted.
6261  *
6262  *----------------------------------------------------------------------
6263  */
6264 static int
NSDeleteCmd(Tcl_Interp * interp,Tcl_Namespace * nsPtr,const char * methodName)6265 NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *methodName) {
6266   Tcl_Command token;
6267 
6268   nonnull_assert(interp != NULL);
6269   nonnull_assert(nsPtr != NULL);
6270   nonnull_assert(methodName != NULL);
6271 
6272   if ((token = FindMethod(nsPtr, methodName))) {
6273     return Tcl_DeleteCommandFromToken(interp, token);
6274   }
6275   return -1;
6276 }
6277 
6278 
6279 /*
6280  *----------------------------------------------------------------------
6281  * NSDeleteChild --
6282  *
6283  *    Delete a child of an object in cases, when the parent object is
6284  *    deleted. It is designed to delete either objects or classes to
6285  *    be a little bit more graceful on destructors. Not perfect yet.
6286  *
6287  * Results:
6288  *    Boolean indicating success
6289  *
6290  * Side effects:
6291  *    Might destroy an object.
6292  *
6293  *----------------------------------------------------------------------
6294  */
6295 static bool NSDeleteChild(Tcl_Interp *interp, Tcl_Command cmd, bool deleteObjectsOnly)
6296   nonnull(1) nonnull(2);
6297 
6298 static bool
NSDeleteChild(Tcl_Interp * interp,Tcl_Command cmd,bool deleteObjectsOnly)6299 NSDeleteChild(Tcl_Interp *interp, Tcl_Command cmd, bool deleteObjectsOnly) {
6300   bool deleted;
6301 
6302   nonnull_assert(cmd != NULL);
6303   nonnull_assert(interp != NULL);
6304 
6305   /*fprintf(stderr, "NSDeleteChildren child %p flags %.6x epoch %d\n",
6306     (void *)cmd, Tcl_Command_flags(cmd), Tcl_Command_cmdEpoch(cmd));*/
6307 
6308   /*
6309    * In some situations (e.g. small buckets, less than 12 entries), we
6310    * get from the cmd-table already deleted cmds; we had previously an
6311    * assert(Tcl_Command_cmdEpoch(cmd) == 0);
6312    * which will fail in such cases.
6313    */
6314 
6315   if (Tcl_Command_cmdEpoch(cmd) != 0) {
6316     deleted = NSF_FALSE;
6317 
6318   } else {
6319     NsfObject *object = NsfGetObjectFromCmdPtr(cmd);
6320 
6321     /*fprintf(stderr, "NSDeleteChildren child %p (%s) epoch %d\n",
6322       (void *)cmd, Tcl_GetCommandName(interp, cmd), Tcl_Command_cmdEpoch(cmd));*/
6323 
6324     if (object == NULL) {
6325       /*
6326        * This is just a plain Tcl command; let Tcl handle the
6327        * deletion.
6328        */
6329       deleted = NSF_FALSE;
6330 
6331     } else if (object->id == cmd) {
6332       /*
6333        * delete here just true children
6334        */
6335 
6336       if (deleteObjectsOnly && NsfObjectIsClass(object)) {
6337         deleted = NSF_FALSE;
6338 
6339       } else if (RUNTIME_STATE(interp)->exitHandlerDestroyRound
6340           == NSF_EXITHANDLER_ON_PHYSICAL_DESTROY) {
6341         /*
6342          * in the exit handler physical destroy --> directly call destroy
6343          */
6344         PrimitiveDestroy(object);
6345         deleted = NSF_TRUE;
6346 
6347       } else {
6348         if (object->teardown && ((object->flags & NSF_DESTROY_CALLED) == 0u)) {
6349           int result;
6350 
6351           NsfObjectRefCountIncr(object);
6352 
6353           result = DispatchDestroyMethod(interp, object, 0u);
6354           if (unlikely(result != TCL_OK) && object->teardown != NULL) {
6355             /*
6356              * The destroy method failed. However, we have to remove
6357              * the command anyway, since its parent is currently being
6358              * deleted.
6359              */
6360             /*fprintf(stderr, "==== NSDeleteChild DispatchDestroyMethod FAILED object %p (cmd %p) id %p teardown %p flags %.6x\n",
6361               (void *)object, (void *)cmd, (void *)object->id, (void *)object->teardown, object->flags);*/
6362 
6363             NsfLog(interp, NSF_LOG_NOTICE, "Destroy failed for object %s %p %.6x, perform low-level deletion",
6364                    (object->flags & NSF_DURING_DELETE) == NSF_DURING_DELETE ? "deleted-object" : ObjectName_(object),
6365                    (void*)object, object->flags);
6366             CallStackDestroyObject(interp, object);
6367           }
6368           NsfCleanupObject(object, "NSDeleteChild");
6369 
6370           deleted = NSF_TRUE;
6371         } else {
6372           deleted = NSF_FALSE;
6373         }
6374       }
6375     } else {
6376       /*fprintf(stderr, "NSDeleteChild remove alias %p %s\n", (void*)object, Tcl_GetCommandName(interp, cmd));*/
6377       deleted = AliasDeleteObjectReference(interp, cmd);
6378     }
6379   }
6380   return deleted;
6381 }
6382 
6383 /*
6384  *----------------------------------------------------------------------
6385  * NSDeleteChildren --
6386  *
6387  *    Delete the child objects of a namespace.
6388  *
6389  * Results:
6390  *    None.
6391  *
6392  * Side effects:
6393  *    Might destroy child objects.
6394  *
6395  *----------------------------------------------------------------------
6396  */
6397 
6398 static void NSDeleteChildren(Tcl_Interp *interp, const Tcl_Namespace *nsPtr)
6399   nonnull(1) nonnull(2);
6400 
6401 static void
NSDeleteChildren(Tcl_Interp * interp,const Tcl_Namespace * nsPtr)6402 NSDeleteChildren(Tcl_Interp *interp, const Tcl_Namespace *nsPtr) {
6403   Tcl_HashTable       *cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
6404   Tcl_HashSearch       hSrch;
6405   const Tcl_HashEntry *hPtr;
6406   int                  expected;
6407 
6408   nonnull_assert(interp != NULL);
6409   nonnull_assert(nsPtr != NULL);
6410 
6411 #ifdef OBJDELETION_TRACE
6412   fprintf(stderr, "NSDeleteChildren %p %s activationCount %d\n",
6413           nsPtr, nsPtr->fullName, Tcl_Namespace_activationCount(nsPtr));
6414 #endif
6415 
6416   /*
6417    * First, get rid of namespace imported objects; don't delete the
6418    * object, but the reference.
6419    */
6420   Tcl_ForgetImport(interp, (Tcl_Namespace*)nsPtr, "*"); /* don't destroy namespace imported objects */
6421 
6422 
6423 #if defined(OBJDELETION_TRACE)
6424   /*
6425    * Deletion is always tricky. Show, what elements should be deleted
6426    * in this loop. The actually deleted elements might be actually
6427    * less, if a deletion of one item triggers the destroy of another
6428    * item.
6429    */
6430   for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
6431        hPtr != NULL;
6432        hPtr = Tcl_NextHashEntry(&hSrch)) {
6433     Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
6434     fprintf(stderr, "will destroy %p %s\n", cmd, Tcl_GetCommandName(interp, cmd));
6435   }
6436 #endif
6437 
6438   /*
6439    * Second, delete the objects.
6440    */
6441 
6442   /*
6443    * A destroy of one element of the hash-table can trigger the
6444    * destroy of another item of the same table. Therefore we use
6445    * Nsf_NextHashEntry(), which handles this case.
6446    */
6447   for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
6448        hPtr != NULL;
6449        hPtr = Nsf_NextHashEntry(cmdTablePtr, expected, &hSrch)) {
6450     /*Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
6451     fprintf(stderr, "NSDeleteChild %p table %p numEntries before %d\n",
6452     cmd, hPtr->tablePtr, cmdTablePtr->numEntries );*/
6453     expected = cmdTablePtr->numEntries -
6454       (int)NSDeleteChild(interp, (Tcl_Command)Tcl_GetHashValue(hPtr), NSF_TRUE);
6455   }
6456  /*
6457   * Finally, delete the classes.
6458    */
6459   for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
6460        hPtr != NULL;
6461        hPtr = Nsf_NextHashEntry(cmdTablePtr, expected, &hSrch)) {
6462     expected = cmdTablePtr->numEntries -
6463       (int)NSDeleteChild(interp, (Tcl_Command)Tcl_GetHashValue(hPtr), NSF_FALSE);
6464   }
6465 }
6466 
6467 
6468 /*
6469  *----------------------------------------------------------------------
6470  * UnsetTracedVars --
6471  *
6472  *   This is a helper function which, as a first pass, attempts to unset
6473  *   traced object variables before TclDeleteVars() performs a second pass.
6474  *   This two-pass deletion of object variables is necessary because an unset
6475  *   trace might bring back the object variable currently being deleted. A
6476  *   single pass risks leaking so-revived Var structures. TclDeleteVars()
6477  *   requires variables under deletion to be untraced.
6478  *
6479  *   As Tcl does not provide access to the necessary lower-level Var API to
6480  *   extensions (ideally: TclDeleteNamespaceVars or TclPtrUnsetVar), we resort
6481  *   to a mix of navigating the variable table and calling high-level unset
6482  *   operations (UnsetInstVar).
6483  *
6484  *   With the fix to ticket https://core.tcl-lang.org/tcl/info/4dbdd9af144dbdd9af14,
6485  *   Tcl itself provides for two deletion passes for namespace variables (see
6486  *   TclDeleteNamespaceVars).
6487  *
6488  * Results:
6489  *    None.
6490  *
6491  * Side effects:
6492  *    Triggers the unset traces, if any.
6493  *
6494  *----------------------------------------------------------------------
6495  */
6496 
6497 static void UnsetTracedVars(Tcl_Interp *interp, NsfObject *object)
6498   nonnull(1) nonnull(2);
6499 
6500 static void
UnsetTracedVars(Tcl_Interp * interp,NsfObject * object)6501 UnsetTracedVars(
6502     Tcl_Interp *interp,  /* Interpreter to which object belongs. */
6503     NsfObject *object)   /* Object to which variables belong. */
6504 {
6505     Tcl_HashSearch search;
6506     TclVarHashTable *varTablePtr;
6507     Interp *iPtr = (Interp *)interp;
6508 
6509     varTablePtr = (object->nsPtr != NULL) ?
6510       Tcl_Namespace_varTablePtr(object->nsPtr) :
6511       object->varTablePtr;
6512 
6513     if (varTablePtr != NULL) {
6514       Tcl_HashEntry *entryPtr;
6515 
6516       for (entryPtr = Tcl_FirstHashEntry((Tcl_HashTable *)varTablePtr, &search);
6517            entryPtr != NULL;
6518            entryPtr = Tcl_NextHashEntry(&search)) {
6519         Tcl_Obj *nameObj;
6520         Var     *varPtr;
6521 
6522         GetVarAndNameFromHash(entryPtr, &varPtr, &nameObj);
6523         if ((varPtr->flags & VAR_TRACED_UNSET) != 0u /* TclIsVarTraced(varPtr) */) {
6524 
6525           VarHashRefCount(varPtr)++;
6526           (void)UnsetInstVar(interp, 1 /* no error msg */, object, ObjStr(nameObj));
6527 
6528           /*
6529            * The variable might have been brought back by an unset trace, plus
6530            * newly created unset traces; deactivate *all* traces on revived
6531            * vars.
6532            */
6533           if (TclIsVarTraced(varPtr)) {
6534             Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (const char *)varPtr);
6535             VarTrace *tracePtr = Tcl_GetHashValue(tPtr);
6536             ActiveVarTrace *activePtr;
6537 
6538             while (tracePtr != NULL) {
6539               VarTrace *prevPtr = tracePtr;
6540 
6541               tracePtr = tracePtr->nextPtr;
6542               prevPtr->nextPtr = NULL;
6543               Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
6544             }
6545             Tcl_DeleteHashEntry(tPtr);
6546             varPtr->flags &= ~VAR_ALL_TRACES;
6547             for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
6548                  activePtr = activePtr->nextPtr) {
6549               if (activePtr->varPtr == varPtr) {
6550                 activePtr->nextTracePtr = NULL;
6551               }
6552             }
6553           }
6554           VarHashRefCount(varPtr)--;
6555         }
6556       }
6557     }
6558 }
6559 
6560 /*
6561  *----------------------------------------------------------------------
6562  * NSCleanupNamespace --
6563  *
6564  *   Cleans up an object or class namespace by deleting 1) its variables, 2)
6565  *   resetting the var table, and 3) deleting user-defined namespace procs.
6566  *
6567  *   For namespaces holding variables with possible unset traces, make sure
6568  *   that UnsetTracedVars is called just before NSCleanupNamespace().
6569  *
6570  * Results:
6571  *    None.
6572  *
6573  * Side effects:
6574  *    Re-initializes the variable table of the cleaned-up namespace
6575  *    (TclInitVarHashTable).
6576  *
6577  *----------------------------------------------------------------------
6578  */
6579 
6580 static void NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
6581   nonnull(1) nonnull(2);
6582 
6583 static void
NSCleanupNamespace(Tcl_Interp * interp,Tcl_Namespace * nsPtr)6584 NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) {
6585   TclVarHashTable *varTablePtr;
6586   Tcl_HashTable *cmdTablePtr;
6587   Tcl_HashSearch hSrch;
6588   const Tcl_HashEntry *hPtr;
6589 
6590   nonnull_assert(interp != NULL);
6591   nonnull_assert(nsPtr != NULL);
6592 
6593   varTablePtr = Tcl_Namespace_varTablePtr(nsPtr);
6594   cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
6595 
6596 #ifdef OBJDELETION_TRACE
6597   fprintf(stderr, "NSCleanupNamespace %p flags %.6x\n", nsPtr, Tcl_Namespace_flags(nsPtr));
6598   fprintf(stderr, "NSCleanupNamespace %p %.6x varTablePtr %p\n", nsPtr, ((Namespace *)nsPtr)->flags, varTablePtr);
6599 #endif
6600   /*
6601    * Delete all variables and initialize var table again (TclDeleteVars frees
6602    * the var table). Any unset-traced variable has been deleted before
6603    * (UnsetTracedVars).
6604    */
6605   TclDeleteVars((Interp *)interp, varTablePtr);
6606   TclInitVarHashTable(varTablePtr, (Namespace *)nsPtr);
6607 
6608   /*
6609    * Delete all user-defined procs in the namespace
6610    */
6611   for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
6612        hPtr != NULL;
6613        hPtr = Tcl_NextHashEntry(&hSrch)) {
6614       Tcl_Command cmd = (Tcl_Command) Tcl_GetHashValue(hPtr);
6615 
6616       if (CmdIsNsfObject(cmd)) {
6617         /*
6618          * Sub-objects should not be deleted here to preserve children
6619          * deletion order. Just delete aliases.
6620          */
6621         AliasDeleteObjectReference(interp, cmd);
6622         continue;
6623       }
6624       /*fprintf(stderr, "NSCleanupNamespace calls DeleteCommandFromToken for %p flags %.6x\n",
6625                 cmd, ((Command *)cmd)->flags);
6626       fprintf(stderr, "    cmd = %s\n", Tcl_GetCommandName(interp, cmd));
6627       fprintf(stderr, "    nsPtr = %p\n", ((Command *)cmd)->nsPtr);
6628       fprintf(stderr, "    epoch = %d\n", Tcl_Command_cmdEpoch(cmd));
6629       fprintf(stderr, "    refCount = %d\n", Tcl_Command_refCount(cmd));
6630       fprintf(stderr, "    flags %.6x\n", ((Namespace *)((Command *)cmd)->nsPtr)->flags);*/
6631 
6632       Tcl_DeleteCommandFromToken(interp, cmd);
6633   }
6634 }
6635 
6636 
6637 static void
NSNamespaceDeleteProc(ClientData clientData)6638 NSNamespaceDeleteProc(ClientData clientData) {
6639   NsfObject *object;
6640 
6641   nonnull_assert(clientData != NULL);
6642 
6643   object = NSNamespaceClientDataObject(clientData);
6644   assert(object != NULL);
6645 
6646 #ifdef NSF_MEM_COUNT
6647   ckfree((char *)clientData);
6648 #endif
6649 
6650   /*fprintf(stderr, "namespace delete-proc obj=%p ns=%p\n",
6651     clientData, (object != NULL) ? object->nsPtr : NULL);*/
6652 
6653   MEM_COUNT_FREE("NSNamespace", object->nsPtr);
6654   object->nsPtr = NULL;
6655 }
6656 
6657 void Nsf_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
6658   nonnull(1) nonnull(2);
6659 
6660 void
Nsf_DeleteNamespace(Tcl_Interp * interp,Tcl_Namespace * nsPtr)6661 Nsf_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) {
6662 
6663 #if defined(NSF_DEVELOPMENT_TEST)
6664   int activationCount = 0;
6665   Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp);
6666 
6667   nonnull_assert(interp != NULL);
6668   nonnull_assert(nsPtr != NULL);
6669 
6670   /*fprintf(stderr, "Nsf_DeleteNamespace %p ", nsPtr);*/
6671 
6672   while (f != NULL) {
6673     if (f->nsPtr == nsPtr) {
6674       activationCount++;
6675     }
6676     f = Tcl_CallFrame_callerPtr(f);
6677   }
6678 
6679 
6680   if (Tcl_Namespace_activationCount(nsPtr) != activationCount) {
6681     fprintf(stderr, "WE HAVE TO FIX ACTIVATIONCOUNT\n");
6682     Tcl_Namespace_activationCount(nsPtr) = activationCount;
6683   }
6684   assert(Tcl_Namespace_activationCount(nsPtr) == activationCount);
6685   /*fprintf(stderr, "to %d. \n", ((Namespace *)nsPtr)->activationCount);*/
6686 #else
6687   (void)interp;
6688 #endif
6689 
6690   if (Tcl_Namespace_deleteProc(nsPtr)) {
6691     /*fprintf(stderr, "calling deteteNamespace %s\n", nsPtr->fullName);*/
6692     Tcl_DeleteNamespace(nsPtr);
6693   }
6694 }
6695 
6696 /*
6697  *----------------------------------------------------------------------
6698  * NSValidObjectName --
6699  *
6700  *    Check the provided colons in an object name. If the name is
6701  *    valid, the function NSF_TRUE.
6702  *
6703  * Results:
6704  *    returns boolean indicating success
6705  *
6706  * Side effects:
6707  *    none
6708  *
6709  *----------------------------------------------------------------------
6710  */
6711 NSF_INLINE static bool NSValidObjectName(const char *name, size_t l)
6712   nonnull(1) pure;
6713 
6714 NSF_INLINE static bool
NSValidObjectName(const char * name,size_t l)6715 NSValidObjectName(const char *name, size_t l) {
6716   register const char *n;
6717   bool           result = NSF_TRUE;
6718 
6719   nonnull_assert(name != NULL);
6720 
6721   n = name;
6722   if (*n == '\0') {
6723     result = NSF_FALSE; /* empty name */
6724   } else {
6725     /*
6726      * Compute size if not given.
6727      */
6728     if (l == 0) {
6729       l = strlen(n);
6730     }
6731     /*
6732      * Check string
6733      */
6734     if (*(n+l-1) == ':') {
6735       result = NSF_FALSE; /* name ends with : */
6736 
6737     } else if (*n == ':' && *(n+1) != ':') {
6738       result = NSF_FALSE; /* name begins with single : */
6739 
6740     } else {
6741       for (; *n != '\0'; n++) {
6742         if (*n == ':' && *(n+1) == ':' && *(n+2) == ':') {
6743           result = NSF_FALSE;  /* more than 2 colons in series in a name */
6744           break;
6745         }
6746       }
6747     }
6748   }
6749   return result;
6750 }
6751 
6752 /*
6753  *----------------------------------------------------------------------
6754  * NSGetFreshNamespace --
6755  *
6756  *    Create an object namespace, provide a deleteProc (avoid
6757  *    interference between object and namespace deletion order) and
6758  *    keep the object as client data.
6759  *
6760  * Results:
6761  *    Tcl_Namespace
6762  *
6763  * Side effects:
6764  *    might allocate a namespace
6765  *
6766  *----------------------------------------------------------------------
6767  */
6768 static Tcl_Namespace*
NSGetFreshNamespace(Tcl_Interp * interp,NsfObject * object,const char * name)6769 NSGetFreshNamespace(Tcl_Interp *interp, NsfObject *object, const char *name) {
6770   Namespace *dummy1Ptr, *dummy2Ptr, *nsPtr;
6771   const char *dummy;
6772 
6773   nonnull_assert(interp != NULL);
6774   nonnull_assert(object != NULL);
6775   nonnull_assert(name != NULL);
6776 
6777   TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS|TCL_CREATE_NS_IF_UNKNOWN,
6778                              &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
6779 
6780   if (nsPtr->deleteProc != NSNamespaceDeleteProc) {
6781     /*
6782      * Avoid hijacking a namespace with different client data
6783      */
6784     if (nsPtr->deleteProc || nsPtr->clientData) {
6785       Tcl_Panic("Namespace '%s' exists already with delProc 0x%" PRIxPTR " and clientData %p; "
6786                 "Can only convert a plain Tcl namespace into an NSF namespace, my delete proc 0x%" PRIxPTR,
6787                 name, (unsigned long)PTR2UINT(nsPtr->deleteProc),
6788                 nsPtr->clientData, (unsigned long)PTR2UINT(NSNamespaceDeleteProc));
6789     }
6790 
6791     {
6792 #ifdef NSF_MEM_COUNT
6793       NsfNamespaceClientData *nsClientData = (NsfNamespaceClientData *)ckalloc((int)sizeof(NsfNamespaceClientData));
6794 
6795       nsClientData->object = object;
6796       nsClientData->nsPtr = (Tcl_Namespace *)nsPtr;
6797       nsPtr->clientData = nsClientData;
6798 
6799       /*fprintf(stderr, "Adding NsfNamespaceClientData nsPtr %p cd %p name '%s'\n",
6800         nsPtr, nsClientData, nsPtr->fullName);*/
6801 #else
6802       nsPtr->clientData = object;
6803 #endif
6804       nsPtr->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc;
6805     }
6806     MEM_COUNT_ALLOC("NSNamespace", nsPtr);
6807   } else {
6808     fprintf(stderr, "NSGetFreshNamespace: reusing namespace %p %s\n", (void *)nsPtr, nsPtr->fullName);
6809   }
6810 
6811   return (Tcl_Namespace *)nsPtr;
6812 }
6813 
6814 /*
6815  *----------------------------------------------------------------------
6816  * NSRequireParentObject --
6817  *
6818  *    Try to require a parent object (e.g. during ttrace).  This function
6819  *    tries to load a parent object via ::nsf::object::unknown.
6820  *
6821  * Results:
6822  *    Tcl result code
6823  *
6824  * Side effects:
6825  *    might create an object
6826  *
6827  *----------------------------------------------------------------------
6828  */
6829 static int NSRequireParentObject(Tcl_Interp *interp, const char *parentName)
6830   nonnull(1) nonnull(2);
6831 
6832 static int
NSRequireParentObject(Tcl_Interp * interp,const char * parentName)6833 NSRequireParentObject(Tcl_Interp *interp, const char *parentName) {
6834   int result;
6835 
6836   nonnull_assert(interp != NULL);
6837   nonnull_assert(parentName != NULL);
6838 
6839   result = NsfCallObjectUnknownHandler(interp, Tcl_NewStringObj(parentName, -1));
6840   if (likely(result == TCL_OK)) {
6841     NsfObject *parentObj = (NsfObject *)GetObjectFromString(interp, parentName);
6842 
6843     if (parentObj != NULL) {
6844       RequireObjNamespace(interp, parentObj);
6845     }
6846     result = (Tcl_FindNamespace(interp, parentName,
6847                                 (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != NULL
6848               ? TCL_OK: TCL_ERROR);
6849   }
6850   return result;
6851 
6852 }
6853 
6854 /*
6855  *----------------------------------------------------------------------
6856  * NSCheckNamespace --
6857  *
6858  *    Check whether a namespace with the given name exists. If not, make sure
6859  *    that a potential parent object has already required a namespace. If
6860  *    there is no parent namespace yet, try to create a parent object via
6861  *    __unknown.
6862  *
6863  *    If the provided parentNsPtr is not NULL, we know, that (a) the
6864  *    provided name was relative and simple (contains no ":"
6865  *    characters) and that (b) this namespace was used to build a fully
6866  *    qualified name. In these cases, the parentNsPtr points already
6867  *    to the parentName, containing potentially a parent Object. In
6868  *    all other cases, the parent name is either obtained from the
6869  *    full namespace, or from string operations working on the
6870  *    provided name.
6871  *
6872  * Results:
6873  *    Tcl_Namespace for the provided name
6874  *
6875  * Side effects:
6876  *    might create parent objects
6877  *
6878  *----------------------------------------------------------------------
6879  */
6880 NSF_INLINE static Tcl_Namespace *NSCheckNamespace(
6881     Tcl_Interp *interp, const char *nameString, Tcl_Namespace *parentNsPtr1
6882 )  nonnull(1) nonnull(2);
6883 
6884 NSF_INLINE static Tcl_Namespace *
NSCheckNamespace(Tcl_Interp * interp,const char * nameString,Tcl_Namespace * parentNsPtr1)6885 NSCheckNamespace(
6886     Tcl_Interp *interp, const char *nameString, Tcl_Namespace *parentNsPtr1
6887 ) {
6888   Namespace   *nsPtr, *dummy1Ptr, *dummy2Ptr, *parentNsPtr = (Namespace *)parentNsPtr1;
6889   const char  *parentName, *dummy;
6890   Tcl_DString ds, *dsPtr = &ds;
6891 
6892   nonnull_assert(interp != NULL);
6893   nonnull_assert(nameString != NULL);
6894 
6895   /*fprintf(stderr, "NSCheckNamespace %s parentNsPtr %p\n", nameString, parentNsPtr);*/
6896 
6897   /*
6898    * Check whether there is a already a namespace for the full name. The
6899    * namespace will be only in rare cases, but we have to make this check in
6900    * every case. If there is a full namespace, we can use it to determine the
6901    * parent name.
6902    */
6903   TclGetNamespaceForQualName(interp, nameString, NULL,
6904                              TCL_GLOBAL_ONLY|TCL_FIND_ONLY_NS,
6905                              &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
6906   /*fprintf(stderr,
6907           "before create calls TclGetNamespaceForQualName with %s => %p (%s) %p %s %p %s %p %s\n",
6908           nameString, nsPtr, (nsPtr != NULL) ? nsPtr->fullName : "",
6909           dummy1Ptr, (dummy1Ptr != NULL) ? dummy1Ptr->fullName : "",
6910           parentNsPtr, (parentNsPtr != NULL) ? parentNsPtr->fullName : "",
6911           dummy, (dummy != NULL) ? dummy : "");*/
6912 
6913   /*
6914    * If there is a parentNs provided (or obtained from the full
6915    * namespace), we can determine the parent name from it. Otherwise,
6916    * we have to perform the string operations.
6917    */
6918 
6919   if (parentNsPtr == NULL && nsPtr != NULL) {
6920     parentNsPtr = Tcl_Namespace_parentPtr(nsPtr);
6921   }
6922 
6923   if (parentNsPtr != NULL) {
6924     parentName = parentNsPtr->fullName;
6925     if (*(parentName + 2) == '\0') {
6926       parentName = NULL;
6927     }
6928     /*fprintf(stderr, "NSCheckNamespace parentNs %s parentName of '%s' => '%s'\n",
6929       parentNsPtr->fullName, nameString, parentName);*/
6930   } else {
6931     int         parentNameLength;
6932     const char *n = nameString + strlen(nameString);
6933     /*
6934      * search for last '::'
6935      */
6936     while ((*n != ':' || *(n-1) != ':') && n-1 > nameString) {
6937       n--;
6938     }
6939     if (*n == ':' && n > nameString && *(n-1) == ':') {
6940       n--;
6941     }
6942     parentNameLength = (int)(n - nameString);
6943     if (parentNameLength > 0) {
6944       DSTRING_INIT(dsPtr);
6945       Tcl_DStringAppend(dsPtr, nameString, parentNameLength);
6946       parentName = Tcl_DStringValue(dsPtr);
6947       DSTRING_FREE(dsPtr);
6948     } else {
6949       parentName = NULL;
6950     }
6951   }
6952 
6953   if (parentName != NULL) {
6954     NsfObject *parentObj;
6955 
6956     parentObj = (NsfObject *) GetObjectFromString(interp, parentName);
6957     /*fprintf(stderr, "parentName %s parentObj %p\n", parentName, parentObj);*/
6958 
6959     if (parentObj != NULL) {
6960       RequireObjNamespace(interp, parentObj);
6961     } else if (nsPtr == NULL && parentNsPtr == NULL) {
6962       TclGetNamespaceForQualName(interp, parentName, NULL,
6963                                  TCL_GLOBAL_ONLY|TCL_FIND_ONLY_NS,
6964                                  &parentNsPtr, &dummy1Ptr,
6965                                  &dummy2Ptr, &dummy);
6966       if (parentNsPtr == NULL) {
6967         /*fprintf(stderr, "===== calling NSRequireParentObject %s", parentName);*/
6968         NSRequireParentObject(interp, parentName);
6969       }
6970     }
6971   }
6972 
6973   return (Tcl_Namespace *)nsPtr;
6974 }
6975 
6976 
6977 /*
6978  *----------------------------------------------------------------------
6979  * NSFindCommand --
6980  *
6981  *    Find the "real" command belonging e.g. to a Next Scripting class or
6982  *    object.  Do not return cmds produced by Tcl_Import, but the "real" cmd
6983  *    to which they point.
6984  *
6985  * Results:
6986  *    Tcl_Command or NULL
6987  *
6988  * Side effects:
6989  *    None.
6990  *
6991  *----------------------------------------------------------------------
6992  */
6993 
6994 NSF_INLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, const char *name)
6995   nonnull(1) nonnull(2);
6996 
6997 NSF_INLINE static Tcl_Command
NSFindCommand(Tcl_Interp * interp,const char * name)6998 NSFindCommand(Tcl_Interp *interp, const char *name) {
6999   Tcl_Command cmd;
7000 
7001   nonnull_assert(interp != NULL);
7002   nonnull_assert(name != NULL);
7003   assert(*name == ':' && *(name + 1) == ':');
7004 
7005   cmd = Tcl_FindCommand(interp, name, NULL, TCL_GLOBAL_ONLY);
7006   if (likely(cmd != NULL)) {
7007     Tcl_Command importedCmd = TclGetOriginalCommand(cmd);
7008     if (unlikely(importedCmd != NULL)) {
7009       cmd = importedCmd;
7010     }
7011   }
7012   return cmd;
7013 }
7014 
7015 #if defined(NSF_DEVELOPMENT_TEST)
7016 /*
7017  *----------------------------------------------------------------------
7018  * ReverseLookupCmdFromCmdTable --
7019  *
7020  *    Allows for looking up objects in command tables (e.g., namespace cmd
7021  *    tables, the interp's hidden cmd table) based on their command pointer
7022  *    (rather than their command name).
7023  *
7024  * Results:
7025  *    Boolean result indicating success
7026  *
7027  * Side effects:
7028  *    None.
7029  *
7030  *----------------------------------------------------------------------
7031  */
7032 
7033 static bool ReverseLookupCmdFromCmdTable(
7034     const Tcl_Command searchCmdPtr,
7035     Tcl_HashTable *cmdTablePtr
7036 ) nonnull(1) nonnull(2);
7037 
7038 static bool
ReverseLookupCmdFromCmdTable(const Tcl_Command searchCmdPtr,Tcl_HashTable * cmdTablePtr)7039 ReverseLookupCmdFromCmdTable(
7040     const Tcl_Command searchCmdPtr,
7041     Tcl_HashTable *cmdTablePtr
7042 ) {
7043   Tcl_HashSearch       search;
7044   const Tcl_HashEntry *hPtr;
7045   bool                 result = NSF_FALSE;
7046 
7047   nonnull_assert(searchCmdPtr != NULL);
7048   nonnull_assert(cmdTablePtr != NULL);
7049 
7050   for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &search);
7051        hPtr != NULL;
7052        hPtr = Tcl_NextHashEntry(&search)) {
7053     Tcl_Command needleCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr);
7054 
7055     if (needleCmdPtr == searchCmdPtr) {
7056       result = NSF_TRUE;
7057       break;
7058     }
7059   }
7060   return result;
7061 }
7062 
7063 /*
7064  *----------------------------------------------------------------------
7065  * GetHiddenObjectFromCmd --
7066  *
7067  *    Obtains a hidden object for a specified cmd. The function uses a reverse
7068  *    lookup of *hidden* object structures based on their commands. This
7069  *    helper is needed for handling hidden and re-exposed objects during the
7070  *    shutdown and the cleanup of object systems.
7071  *
7072  * Results:
7073  *    NsfObject* or NULL
7074  *
7075  * Side effects:
7076  *    None.
7077  *
7078  *----------------------------------------------------------------------
7079  */
7080 
7081 static NsfObject *GetHiddenObjectFromCmd(
7082     Tcl_Interp *interp, const Tcl_Command cmdPtr
7083 ) nonnull(1);
7084 
7085 static NsfObject *
GetHiddenObjectFromCmd(Tcl_Interp * interp,const Tcl_Command cmdPtr)7086 GetHiddenObjectFromCmd(
7087     Tcl_Interp *interp, const Tcl_Command cmdPtr
7088 ) {
7089   Interp    *iPtr = (Interp *) interp;
7090   NsfObject *screenedObject;
7091 
7092   nonnull_assert(cmdPtr != NULL);
7093 
7094   /*
7095    * We can provide a shortcut, knowing that a) exposed cmds have an epoch
7096    * counter > 0, and b) the commands originating namespace must be the global
7097    * one. See also Tcl_HideCommand() and Tcl_ExposeCommand().
7098    */
7099   if (Tcl_Command_cmdEpoch(cmdPtr) == 0 ||
7100       ((Command *)cmdPtr)->nsPtr != iPtr->globalNsPtr) {
7101     screenedObject = NULL;
7102 
7103   } else {
7104     bool found;
7105 
7106     /*
7107      * Reverse lookup object in the interp's hidden command table. We start
7108      * off with the hidden cmds as we suspect their number being smaller than
7109      * the re-exposed ones, living in the global namespace
7110      */
7111     found = ReverseLookupCmdFromCmdTable(cmdPtr, iPtr->hiddenCmdTablePtr);
7112     if (!found) {
7113       /*
7114        * Reverse lookup object in the interp's global command table. Most likely
7115        * needed due to hiding + exposing on a different name.
7116        */
7117       found = ReverseLookupCmdFromCmdTable(cmdPtr, &iPtr->globalNsPtr->cmdTable);
7118     }
7119     screenedObject = found ? NsfGetObjectFromCmdPtr(cmdPtr) : NULL;
7120 
7121 #if !defined(NDEBUG)
7122     if (screenedObject != NULL) {
7123       NsfLog(interp, NSF_LOG_NOTICE, "screened object %s found: object %p (%s) cmd %p",
7124              Tcl_GetCommandName(interp, cmdPtr), (void *)screenedObject,
7125              ObjectName(screenedObject), (void *)cmdPtr);
7126     }
7127 #endif
7128   }
7129   return screenedObject;
7130 }
7131 #endif
7132 
7133 /*
7134  *----------------------------------------------------------------------
7135  * GetObjectFromString --
7136  *
7137  *    Lookup an object from a given string. The function performs a
7138  *    command lookup (every object is a command) and checks, if the
7139  *    command is bound to an NSF object.
7140  *
7141  * Results:
7142  *    NsfObject* or NULL
7143  *
7144  * Side effects:
7145  *    None.
7146  *
7147  *----------------------------------------------------------------------
7148  */
7149 static NsfObject *
GetObjectFromString(Tcl_Interp * interp,const char * name)7150 GetObjectFromString(Tcl_Interp *interp, const char *name) {
7151   register Tcl_Command cmd;
7152 
7153   nonnull_assert(interp != NULL);
7154   nonnull_assert(name != NULL);
7155 
7156   /*fprintf(stderr, "GetObjectFromString name = '%s'\n", name);*/
7157   cmd = NSFindCommand(interp, name);
7158 
7159   if (likely(cmd != NULL && CmdIsNsfObject(cmd))) {
7160     /*fprintf(stderr, "GetObjectFromString %s => %p\n", name, Tcl_Command_objClientData(cmd));*/
7161     return (NsfObject *)Tcl_Command_objClientData(cmd);
7162   }
7163   /*fprintf(stderr, "GetObjectFromString %s => NULL\n", name);*/
7164   return NULL;
7165 }
7166 
7167 /*
7168  *----------------------------------------------------------------------
7169  * GetClassFromString --
7170  *
7171  *    Lookup a class from a given string. The function performs an
7172  *    object lookup and checks, if the object is a class
7173  *
7174  * Results:
7175  *    NsfClass* or NULL
7176  *
7177  * Side effects:
7178  *    None.
7179  *
7180  *----------------------------------------------------------------------
7181  */
7182 static NsfClass *
GetClassFromString(Tcl_Interp * interp,const char * name)7183 GetClassFromString(Tcl_Interp *interp, const char *name) {
7184   NsfObject *object = GetObjectFromString(interp, name);
7185 
7186   nonnull_assert(interp != NULL);
7187   nonnull_assert(name != NULL);
7188   return (object != NULL && NsfObjectIsClass(object)) ? (NsfClass *)object : NULL;
7189 }
7190 
7191 /*
7192  *----------------------------------------------------------------------
7193  * CanRedefineCmd --
7194  *
7195  *    This function tests, whether a method (provided as a string) is
7196  *    allowed to be redefined in a provided namespace.
7197  *
7198  * Results:
7199  *    Tcl result code.
7200  *
7201  * Side effects:
7202  *    None.
7203  *
7204  *----------------------------------------------------------------------
7205  */
7206 static int CanRedefineCmd(
7207     Tcl_Interp *interp,
7208     const Tcl_Namespace *nsPtr,
7209     const NsfObject *object,
7210     const char *methodName,
7211     unsigned int flags
7212 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
7213 
7214 static int
CanRedefineCmd(Tcl_Interp * interp,const Tcl_Namespace * nsPtr,const NsfObject * object,const char * methodName,unsigned int flags)7215 CanRedefineCmd(
7216     Tcl_Interp *interp,
7217     const Tcl_Namespace *nsPtr,
7218     const NsfObject *object,
7219     const char *methodName,
7220     unsigned int flags
7221 ) {
7222   int         result;
7223   bool        ok;
7224   Tcl_Command cmd;
7225 
7226   nonnull_assert(interp != NULL);
7227   nonnull_assert(nsPtr != NULL);
7228   nonnull_assert(object != NULL);
7229   nonnull_assert(methodName != NULL);
7230 
7231   cmd = FindMethod(nsPtr, methodName);
7232 
7233   if (cmd != NULL) {
7234     if ( NsfGetObjectFromCmdPtr(cmd) != NULL) {
7235       /*
7236        * Don't allow overwriting of an object with a method.
7237        */
7238       return NsfPrintError(interp,
7239                            "refuse to overwrite child object with method %s; delete/rename it before overwriting",
7240                            methodName);
7241     }
7242     ok = (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_REDEFINE_PROTECTED_METHOD) == 0u);
7243   } else {
7244     ok = NSF_TRUE;
7245   }
7246 
7247   if (likely(ok)) {
7248     result = TCL_OK;
7249 
7250   } else {
7251     /*
7252      * We could test, whether we are bootstrapping the "right" object
7253      * system, and allow only overwrites for the current bootstrap
7254      * object system, but this seems necessary by now.
7255      */
7256     Tcl_Obj *bootstrapObj = Tcl_GetVar2Ex(interp, "::nsf::bootstrap", NULL, TCL_GLOBAL_ONLY);
7257 
7258     if (bootstrapObj == NULL) {
7259       result = NsfPrintError(interp, "refuse to overwrite protected method '%s'; "
7260                              "derive e.g. a subclass!", methodName, ObjectName_(object));
7261     } else {
7262       result = TCL_OK;
7263     }
7264   }
7265 
7266   if (likely(result == TCL_OK)) {
7267     result = ObjectSystemsCheckSystemMethod(interp, methodName, object, flags);
7268   }
7269   return result;
7270 }
7271 
7272 /*
7273  *----------------------------------------------------------------------
7274  * NsfAddObjectMethod --
7275  *
7276  *    Externally callable function to register an object level method
7277  *    for the provided object.
7278  *
7279  * Results:
7280  *    Tcl result code.
7281  *
7282  * Side effects:
7283  *    Newly created Tcl command.
7284  *
7285  *----------------------------------------------------------------------
7286  */
7287 int NsfAddObjectMethod(
7288     Tcl_Interp *interp, Nsf_Object *object, const char *methodName,
7289     Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
7290     unsigned int flags
7291 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
7292 
7293 int
NsfAddObjectMethod(Tcl_Interp * interp,Nsf_Object * object,const char * methodName,Tcl_ObjCmdProc * proc,ClientData clientData,Tcl_CmdDeleteProc * dp,unsigned int flags)7294 NsfAddObjectMethod(
7295     Tcl_Interp *interp, Nsf_Object *object, const char *methodName,
7296     Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
7297     unsigned int flags
7298 ) {
7299   NsfObject           *currentObject;
7300   Tcl_DString          newCmdName, *dsPtr = &newCmdName;
7301   const Tcl_Namespace *ns;
7302   Tcl_Command          newCmd;
7303   int                  result;
7304 
7305   nonnull_assert(interp != NULL);
7306   nonnull_assert(object != NULL);
7307   nonnull_assert(methodName != NULL);
7308   nonnull_assert(proc != NULL);
7309 
7310   currentObject = (NsfObject *)object;
7311   ns = RequireObjNamespace(interp, currentObject);
7312 
7313   /*
7314    * Check whether we are allowed to redefine the method
7315    */
7316   result = CanRedefineCmd(interp, currentObject->nsPtr, currentObject, (char *)methodName, flags);
7317   if (unlikely(result != TCL_OK)) {
7318     return result;
7319   }
7320   NsfObjectMethodEpochIncr("NsfAddObjectMethod");
7321 
7322   /*
7323    * Delete an alias definition, if it exists.
7324    */
7325   AliasDelete(interp, currentObject->cmdName, methodName, NSF_TRUE);
7326 
7327   Tcl_DStringInit(dsPtr);
7328   DStringAppendQualName(dsPtr, ns, methodName);
7329 
7330   newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp);
7331 
7332   if (flags != 0u) {
7333     ((Command *) newCmd)->flags |= (int)flags;
7334   }
7335   Tcl_DStringFree(dsPtr);
7336   return TCL_OK;
7337 }
7338 
7339 /*
7340  *----------------------------------------------------------------------
7341  * NsfAddClassMethod --
7342  *
7343  *    Externally callable function to register a class level method
7344  *    for the provided class.
7345  *
7346  * Results:
7347  *    Tcl result code.
7348  *
7349  * Side effects:
7350  *    Newly created Tcl command.
7351  *
7352  *----------------------------------------------------------------------
7353  */
7354 int NsfAddClassMethod(
7355     Tcl_Interp *interp, Nsf_Class *class, const char *methodName,
7356     Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
7357     unsigned int flags
7358 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
7359 
7360 int
NsfAddClassMethod(Tcl_Interp * interp,Nsf_Class * class,const char * methodName,Tcl_ObjCmdProc * proc,ClientData clientData,Tcl_CmdDeleteProc * dp,unsigned int flags)7361 NsfAddClassMethod(
7362     Tcl_Interp *interp, Nsf_Class *class, const char *methodName,
7363     Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp,
7364     unsigned int flags
7365 ) {
7366   Tcl_DString  newCmdName, *dsPtr = &newCmdName;
7367   Tcl_Command  newCmd;
7368   NsfClass    *c;
7369   int          result;
7370 
7371   nonnull_assert(interp != NULL);
7372   nonnull_assert(class != NULL);
7373   nonnull_assert(methodName != NULL);
7374   nonnull_assert(proc != NULL);
7375 
7376   c = (NsfClass *)class;
7377   assert(c->nsPtr != NULL);
7378 
7379   /*
7380    * Check whether we are allowed to redefine the method.
7381    */
7382   result = CanRedefineCmd(interp, c->nsPtr, &c->object, (char *)methodName, flags);
7383   if (unlikely(result != TCL_OK)) {
7384     return result;
7385   }
7386 
7387   NsfInstanceMethodEpochIncr("NsfAddClassMethod");
7388 
7389   /*
7390    * Delete the alias definition, if it exists already.
7391    */
7392   AliasDelete(interp, class->object.cmdName, methodName, NSF_FALSE);
7393 
7394   Tcl_DStringInit(dsPtr);
7395   DStringAppendQualName(dsPtr, c->nsPtr, methodName);
7396 
7397   newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp);
7398 
7399   if (flags != 0) {
7400     ((Command *) newCmd)->flags |= (int)flags;
7401   }
7402   Tcl_DStringFree(dsPtr);
7403   return TCL_OK;
7404 }
7405 
7406 /*
7407  * Auto-naming
7408  */
7409 
7410 static Tcl_Obj * AutonameIncr(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfObject *object,
7411              int isInstanceOpt, int doResetOpt)
7412   nonnull(1) nonnull(2) nonnull(3);
7413 
7414 static Tcl_Obj *
AutonameIncr(Tcl_Interp * interp,Tcl_Obj * nameObj,NsfObject * object,int isInstanceOpt,int doResetOpt)7415 AutonameIncr(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfObject *object,
7416              int isInstanceOpt, int doResetOpt) {
7417   Tcl_Obj *valueObj, *resultObj;
7418   CallFrame frame, *framePtr = &frame;
7419   int flogs = TCL_LEAVE_ERR_MSG;
7420 
7421   nonnull_assert(interp != NULL);
7422   nonnull_assert(nameObj != NULL);
7423   nonnull_assert(object != NULL);
7424 
7425   Nsf_PushFrameObj(interp, object, framePtr);
7426   if (object->nsPtr != NULL) {
7427     flogs |= TCL_NAMESPACE_ONLY;
7428   }
7429   valueObj = Tcl_ObjGetVar2(interp, NsfGlobalObjs[NSF_AUTONAMES], nameObj, flogs);
7430   if (valueObj != NULL) {
7431     long autoname_counter;
7432 
7433     /*
7434      * The autoname counter can overflow, but this should cause no troubles.
7435      */
7436     Tcl_GetLongFromObj(interp, valueObj, &autoname_counter);
7437     autoname_counter++;
7438     if (Tcl_IsShared(valueObj)) {
7439       valueObj = Tcl_DuplicateObj(valueObj);
7440     }
7441     Tcl_SetLongObj(valueObj, autoname_counter);
7442     resultObj = Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_AUTONAMES], nameObj,
7443                                valueObj, flogs);
7444     if (unlikely(resultObj == NULL)) {
7445       return NULL;
7446     }
7447   } else {
7448     resultObj = NsfGlobalObjs[NSF_EMPTY];
7449   }
7450 
7451   if (doResetOpt == 1) {
7452     if (valueObj != NULL) {
7453       /*
7454        * We have such a variable. The reset operation has to unset it.
7455        */
7456       Tcl_UnsetVar2(interp, NsfGlobalStrings[NSF_AUTONAMES], ObjStr(nameObj), flogs);
7457     }
7458     resultObj = NsfGlobalObjs[NSF_EMPTY];
7459     INCR_REF_COUNT2("autoname", resultObj);
7460   } else {
7461     bool        mustCopy = NSF_TRUE, format = NSF_FALSE;
7462     const char *c;
7463 
7464     if (valueObj == NULL) {
7465       valueObj = Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_AUTONAMES],
7466                                    nameObj, NsfGlobalObjs[NSF_ONE], flogs);
7467     }
7468     if (isInstanceOpt == 1) {
7469       char        firstChar;
7470       const char *nextChars = ObjStr(nameObj);
7471 
7472       firstChar = *(nextChars ++);
7473       if (isupper((int)firstChar)) {
7474         char buffer[1];
7475 
7476         buffer[0] = (char)tolower((int)firstChar);
7477         resultObj = Tcl_NewStringObj(buffer, 1);
7478         INCR_REF_COUNT2("autoname", resultObj);
7479         Tcl_AppendLimitedToObj(resultObj, nextChars, -1, INT_MAX, NULL);
7480         mustCopy = NSF_FALSE;
7481       }
7482     }
7483     if (mustCopy) {
7484       resultObj = Tcl_DuplicateObj(nameObj);
7485       INCR_REF_COUNT2("autoname", resultObj);
7486       /*
7487         fprintf(stderr, "*** copy %p %s = %p\n", name, ObjStr(name), resultObj);
7488       */
7489     }
7490 
7491     /*
7492      * If there is a "%" in the autoname, use Tcl_FormatObjCmd to let the
7493      * autoname string be formatted, like Tcl "format" command, with the
7494      * value. E.g.: autoname a%06d --> a000000, a000001, a000002, ...
7495      */
7496     for (c = ObjStr(resultObj); *c != '\0'; c++) {
7497       if (*c == '%') {
7498         if (*(c+1) != '%') {
7499           format = NSF_TRUE;
7500           break;
7501         } else {
7502           /*
7503            * When name contains "%%" format and then append autoname, e.g.
7504            * autoname a%% --> a%1, a%2, ...
7505            */
7506           c++;
7507         }
7508       }
7509     }
7510     if (format) {
7511       Tcl_Obj *savedResultObj, *ov[3];
7512 
7513       savedResultObj = Tcl_GetObjResult(interp);
7514       INCR_REF_COUNT(savedResultObj);
7515       ov[0] = NULL;
7516       ov[1] = resultObj;
7517       ov[2] = valueObj;
7518       if (NsfCallCommand(interp, NSF_FORMAT, 3, ov) != TCL_OK) {
7519         Nsf_PopFrameObj(interp, framePtr);
7520         DECR_REF_COUNT(savedResultObj);
7521         return NULL;
7522       }
7523       DECR_REF_COUNT(resultObj);
7524       resultObj = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
7525       INCR_REF_COUNT2("autoname", resultObj);
7526       Tcl_SetObjResult(interp, savedResultObj);
7527       DECR_REF_COUNT(savedResultObj);
7528 
7529     } else {
7530       const char *valueString = Tcl_GetString(valueObj);
7531 
7532       Tcl_AppendLimitedToObj(resultObj, valueString, valueObj->length, INT_MAX, NULL);
7533     }
7534   }
7535 
7536   Nsf_PopFrameObj(interp, framePtr);
7537   assert((doResetOpt == 1 && resultObj->refCount>=1) || (resultObj->refCount == 1));
7538   return resultObj;
7539 }
7540 
7541 /*
7542  * Next Scripting CallStack functions
7543  */
7544 
7545 NSF_INLINE static void CallStackDoDestroy(Tcl_Interp *interp, NsfObject *object)
7546   nonnull(1) nonnull(2);
7547 
7548 NSF_INLINE static void
CallStackDoDestroy(Tcl_Interp * interp,NsfObject * object)7549 CallStackDoDestroy(Tcl_Interp *interp, NsfObject *object) {
7550   Tcl_Command oid;
7551 
7552   nonnull_assert(interp != NULL);
7553   nonnull_assert(object != NULL);
7554 
7555   /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x\n", object, object->flags);*/
7556   PRINTOBJ("CallStackDoDestroy", object);
7557 
7558   /*
7559    * Don't do anything, if a recursive DURING_DELETE is for some
7560    * reason active.
7561    */
7562   if (unlikely((object->flags & NSF_DURING_DELETE) != 0u)) {
7563     return;
7564   }
7565   /*fprintf(stderr, "CallStackDoDestroy %p flags %.6x activation %d object->refCount %d cmd %p \n",
7566     object, object->flags, object->activationCount, object->refCount, object->id);*/
7567 
7568   object->flags |= NSF_DURING_DELETE;
7569   oid = object->id;
7570 
7571   /*
7572    * The oid might be freed already, we can't even use
7573    * (((Command *)oid)->flags & CMD_IS_DELETED)
7574    */
7575   if (object->teardown != NULL && oid != NULL) {
7576     /*
7577      * PrimitiveDestroy() has to be called before DeleteCommandFromToken(),
7578      * otherwise e.g. unset traces on this object cannot be executed from
7579      * Tcl. We make sure via refCounting that the object structure is kept
7580      * until after DeleteCommandFromToken().
7581      */
7582     NsfObjectRefCountIncr(object);
7583 
7584     PrimitiveDestroy(object);
7585 
7586     if /*(object->teardown == NULL)*/ ((object->flags & NSF_TCL_DELETE) == 0u) {
7587       Tcl_Obj *savedResultObj = Tcl_GetObjResult(interp);
7588       INCR_REF_COUNT(savedResultObj);
7589 
7590       assert(object->teardown == NULL);
7591 
7592       /*fprintf(stderr, "    before DeleteCommandFromToken %p object flags %.6x\n", (void *)oid, object->flags);*/
7593       /*fprintf(stderr, "cmd dealloc %p refCount %d dodestroy \n", (void *)oid, Tcl_Command_refCount(oid));*/
7594       Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */
7595       /*fprintf(stderr, "    after DeleteCommandFromToken %p %.6x\n", (void *)oid, ((Command *)oid)->flags);*/
7596       Tcl_SetObjResult(interp, savedResultObj);
7597       DECR_REF_COUNT(savedResultObj);
7598     }
7599 
7600     NsfCleanupObject(object, "CallStackDoDestroy");
7601   }
7602 }
7603 
7604 static void
CallStackDestroyObject(Tcl_Interp * interp,NsfObject * object)7605 CallStackDestroyObject(Tcl_Interp *interp, NsfObject *object) {
7606 
7607   nonnull_assert(interp != NULL);
7608   nonnull_assert(object != NULL);
7609 
7610 #ifdef OBJDELETION_TRACE
7611   fprintf(stderr, "CallStackDestroyObject %p %s activationcount %d flags %.6x\n",
7612           object, ObjectName(object), object->activationCount, object->flags);
7613 #endif
7614 
7615   if ((object->flags & NSF_DESTROY_CALLED) == 0u) {
7616     int activationCount = object->activationCount;
7617 
7618     /*
7619      * If the destroy method was not called yet, do it now.
7620      */
7621 #ifdef OBJDELETION_TRACE
7622     fprintf(stderr, "  CallStackDestroyObject has to DispatchDestroyMethod %p activationCount %d\n",
7623             object, activationCount);
7624 #endif
7625     DispatchDestroyMethod(interp, object, 0u);
7626 
7627     if (activationCount == 0) {
7628       /*
7629        * We assume, the object is now freed. If the object is already
7630        * freed, we cannot access activation count, and we cannot call
7631        * CallStackDoDestroy.
7632        */
7633       /*fprintf(stderr, "  CallStackDestroyObject %p done\n",  obj);*/
7634       return;
7635     }
7636   }
7637 
7638   /*
7639    * If the object is not referenced on the call-stack anymore
7640    * we have to destroy it directly, because CscFinish won't
7641    * find the object destroy.
7642    */
7643   if (object->activationCount == 0) {
7644     CallStackDoDestroy(interp, object);
7645   } else {
7646     /*
7647      * To preserve the deletion order, call delete children now such that
7648      * child destructors are called before parent destructors.
7649      */
7650     if ((object->teardown != NULL) && (object->nsPtr != NULL)) {
7651       /*fprintf(stderr, "  CallStackDestroyObject calls NSDeleteChildren\n");*/
7652       NSDeleteChildren(interp, object->nsPtr);
7653     }
7654   }
7655   /*fprintf(stderr, "  CallStackDestroyObject %p DONE\n",  object);*/
7656 }
7657 
7658 /*
7659  * cmd list handling
7660  */
7661 
7662 /*
7663  *----------------------------------------------------------------------
7664  * CmdListAdd --
7665  *
7666  *    Add an entry to a cmdlist. Optionally, the function checks for
7667  *    duplicates (does not insert a duplicate) or it allows one to add new
7668  *    entries to the end of the list.
7669  *
7670  * Results:
7671  *    The newly inserted command list item or a found item (never null)
7672  *
7673  * Side effects:
7674  *    Added List entry.
7675  *
7676  *----------------------------------------------------------------------
7677  */
7678 static NsfCmdList *CmdListAdd(
7679     NsfCmdList **cList, const Tcl_Command cmd, NsfClass *clorobj,
7680     bool noDuplicates, bool atEnd
7681 ) nonnull(1) nonnull(2) returns_nonnull;
7682 
7683 static NsfCmdList *
CmdListAdd(NsfCmdList ** cList,const Tcl_Command cmd,NsfClass * clorobj,bool noDuplicates,bool atEnd)7684 CmdListAdd(
7685     NsfCmdList **cList, const Tcl_Command cmd, NsfClass *clorobj,
7686     bool noDuplicates, bool atEnd
7687 ) {
7688   NsfCmdList *l, *nextPtr, *new;
7689 
7690   nonnull_assert(cmd != NULL);
7691   nonnull_assert(cList != NULL);
7692 
7693   if (unlikely(atEnd)) {
7694     l = *cList;
7695     nextPtr = NULL;
7696   } else {
7697     l = NULL;
7698     nextPtr = *cList;
7699   }
7700 
7701   /*
7702    * Check for duplicates, if necessary.
7703    */
7704   if (unlikely(noDuplicates)) {
7705     NsfCmdList *h = l, **end = NULL;
7706 
7707     while (h != NULL) {
7708       if (h->cmdPtr == cmd) {
7709         return h;
7710       }
7711       end = &(h->nextPtr);
7712       h = h->nextPtr;
7713     }
7714     if (end != NULL) {
7715       /*
7716        * No duplicates, no need to search below, we are at the end of the
7717        * list.
7718        */
7719       cList = end;
7720       l = NULL;
7721     }
7722   }
7723 
7724   /*
7725    * Ok, we have no duplicates -> append NsfCmdList "new" to the end of the
7726    * list.
7727    */
7728   new = NEW(NsfCmdList);
7729   new->cmdPtr = cmd;
7730   NsfCommandPreserve(new->cmdPtr);
7731   new->clientData = NULL;
7732   new->clorobj = clorobj;
7733   new->nextPtr = nextPtr;
7734 
7735   if (unlikely(l != NULL)) {
7736     /*
7737      * append new element at the end
7738      */
7739     while (l->nextPtr != NULL) {
7740       l = l->nextPtr;
7741     }
7742     l->nextPtr = new;
7743   } else {
7744     /*
7745      * prepend new element
7746      */
7747     *cList = new;
7748   }
7749 
7750   return new;
7751 }
7752 
7753 /*
7754  *----------------------------------------------------------------------
7755  * CmdListAddSorted --
7756  *
7757  *    Add an entry to a cmdlist without duplicates. The order of the entries
7758  *    is not supposed to be relevant. This function maintains a sorted list to
7759  *    reduce cost to n/2. Can be improved be using better data structures of
7760  *    needed.
7761  *
7762  * Results:
7763  *    The newly inserted command list item or a found item
7764  *
7765  * Side effects:
7766  *    Added List entry.
7767  *
7768  *----------------------------------------------------------------------
7769  */
7770 static NsfCmdList *CmdListAddSorted(NsfCmdList **cList, Tcl_Command cmd, NsfClass *clorobj)
7771   nonnull(1) nonnull(2) returns_nonnull;
7772 
7773 static NsfCmdList *
CmdListAddSorted(NsfCmdList ** cList,Tcl_Command cmd,NsfClass * clorobj)7774 CmdListAddSorted(NsfCmdList **cList, Tcl_Command cmd, NsfClass *clorobj) {
7775   NsfCmdList *prev, *new, *h;
7776 
7777   nonnull_assert(cmd != NULL);
7778   nonnull_assert(cList != NULL);
7779 
7780   for (h = *cList, prev = NULL; h != NULL; prev = h, h = h->nextPtr) {
7781     if (h->cmdPtr == cmd) {
7782       return h;
7783     } else if (h->cmdPtr > cmd) {
7784       break;
7785     }
7786   }
7787 
7788   new = NEW(NsfCmdList);
7789   new->cmdPtr = cmd;
7790   NsfCommandPreserve(new->cmdPtr);
7791   new->clientData = NULL;
7792   new->clorobj = clorobj;
7793   new->nextPtr = h;
7794 
7795   if (prev != NULL) {
7796     prev->nextPtr = new;
7797   } else {
7798     *cList = new;
7799   }
7800 
7801   return new;
7802 }
7803 
7804 static void CmdListReplaceCmd(NsfCmdList *replace, Tcl_Command cmd, NsfClass *clorobj)
7805   nonnull(1) nonnull(3);
7806 
7807 static void
CmdListReplaceCmd(NsfCmdList * replace,Tcl_Command cmd,NsfClass * clorobj)7808 CmdListReplaceCmd(NsfCmdList *replace, Tcl_Command cmd, NsfClass *clorobj) {
7809   Tcl_Command del;
7810 
7811   nonnull_assert(replace != NULL);
7812   nonnull_assert(clorobj != NULL);
7813 
7814   del = replace->cmdPtr;
7815   replace->cmdPtr = cmd;
7816   replace->clorobj = clorobj;
7817   NsfCommandPreserve(cmd);
7818   NsfCommandRelease(del);
7819 }
7820 
7821 #if defined(NSF_DEBUGGING)
7822 /** for debug purposes only */
7823 static void CmdListPrint(Tcl_Interp *interp, const char *title, NsfCmdList *cmdList)
7824   nonnull(1) nonnull(3);
7825 
7826 static void
CmdListPrint(Tcl_Interp * interp,const char * title,NsfCmdList * cmdList)7827 CmdListPrint(Tcl_Interp *interp, const char *title, NsfCmdList *cmdList) {
7828 
7829   nonnull_assert(interp != NULL);
7830   nonnull_assert(cmdList != NULL);
7831 
7832   if (title != NULL) {
7833     fprintf(stderr, "%s %p:\n", title, cmdList);
7834   }
7835   while (cmdList != NULL) {
7836     fprintf(stderr, "   CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n",
7837             cmdList,
7838             cmdList->cmdPtr, (interp != NULL) ? Tcl_GetCommandName(interp, cmdList->cmdPtr) : "",
7839             cmdList->clorobj,
7840             cmdList->clientData);
7841     cmdList = cmdList->nextPtr;
7842   }
7843 }
7844 #endif
7845 
7846 /*
7847  * physically delete an entry 'del'
7848  */
7849 static void CmdListDeleteCmdListEntry(NsfCmdList *del, NsfFreeCmdListClientData *freeFct)
7850   nonnull(1);
7851 
7852 static void
CmdListDeleteCmdListEntry(NsfCmdList * del,NsfFreeCmdListClientData * freeFct)7853 CmdListDeleteCmdListEntry(NsfCmdList *del, NsfFreeCmdListClientData *freeFct) {
7854 
7855   nonnull_assert(del != NULL);
7856 
7857   if (unlikely(freeFct != NULL)) {
7858     (*freeFct)(del);
7859   }
7860   NsfCommandRelease(del->cmdPtr);
7861   FREE(NsfCmdList, del);
7862 }
7863 
7864 /*
7865  * remove a command 'delCL' from a command list, but do not
7866  * free it ... returns the removed NsfCmdList*
7867  */
7868 static NsfCmdList *CmdListRemoveFromList(NsfCmdList **cmdList, NsfCmdList *delCL)
7869   nonnull(1) nonnull(2);
7870 
7871 static NsfCmdList *
CmdListRemoveFromList(NsfCmdList ** cmdList,NsfCmdList * delCL)7872 CmdListRemoveFromList(NsfCmdList **cmdList, NsfCmdList *delCL) {
7873   register NsfCmdList *c;
7874   NsfCmdList          *del = NULL;
7875 
7876   nonnull_assert(cmdList != NULL);
7877   nonnull_assert(delCL != NULL);
7878 
7879   c = *cmdList;
7880   if (likely(c != NULL)) {
7881     if (c == delCL) {
7882       *cmdList = c->nextPtr;
7883       del = c;
7884     } else {
7885       while ((c->nextPtr != NULL) && (c->nextPtr != delCL)) {
7886         c = c->nextPtr;
7887       }
7888       if (c->nextPtr == delCL) {
7889         del = delCL;
7890         c->nextPtr = delCL->nextPtr;
7891       }
7892     }
7893   }
7894   return del;
7895 }
7896 
7897 /*
7898  *----------------------------------------------------------------------
7899  * CmdListRemoveDeleted --
7900  *
7901  *    Remove all command pointers from a command list which are marked
7902  *    "deleted". The condition for deletion is the presence of the flag
7903  *    CMD_IS_DELETED, with the flag bit being set by
7904  *    Tcl_DeleteCommandFromToken().
7905  *
7906  * Results:
7907  *    The cmd list filtered for non-deleted commands
7908  *
7909  * Side effects:
7910  *    None
7911  *
7912  *----------------------------------------------------------------------
7913  */
7914 static void CmdListRemoveDeleted(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct)
7915   nonnull(1) nonnull(2);
7916 
7917 static void
CmdListRemoveDeleted(NsfCmdList ** cmdList,NsfFreeCmdListClientData * freeFct)7918 CmdListRemoveDeleted(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct) {
7919   NsfCmdList *f, *del;
7920 
7921   nonnull_assert(cmdList != NULL);
7922   nonnull_assert(freeFct != NULL);
7923 
7924   f = *cmdList;
7925   while (f != NULL) {
7926     /*
7927      * HIDDEN OBJECTS: For supporting hidden mixins, we cannot rely on the
7928      * cmdEpoch as indicator of the deletion status of a cmd because the epoch
7929      * counters of hidden and re-exposed commands are bumped. Despite of this,
7930      * their object structures remain valid. We resort to the use of the
7931      * per-cmd flag CMD_IS_DELETED, set upon processing a command in
7932      * Tcl_DeleteCommandFromToken().
7933      */
7934     if (((unsigned int)Tcl_Command_flags(f->cmdPtr) & CMD_IS_DELETED) != 0u)  {
7935       del = f;
7936       f = f->nextPtr;
7937       del = CmdListRemoveFromList(cmdList, del);
7938       CmdListDeleteCmdListEntry(del, freeFct);
7939     } else
7940       f = f->nextPtr;
7941   }
7942 }
7943 
7944 
7945 /*
7946  * Delete all cmds with given context class object
7947  */
7948 static void CmdListRemoveContextClassFromList(
7949     NsfCmdList **cmdList, const NsfClass *clorobj,
7950     NsfFreeCmdListClientData *freeFct
7951 ) nonnull(1) nonnull(2) nonnull(3);
7952 
7953 static void
CmdListRemoveContextClassFromList(NsfCmdList ** cmdList,const NsfClass * clorobj,NsfFreeCmdListClientData * freeFct)7954 CmdListRemoveContextClassFromList(
7955     NsfCmdList **cmdList, const NsfClass *clorobj,
7956     NsfFreeCmdListClientData *freeFct
7957 ) {
7958   NsfCmdList *c, *del = NULL;
7959 
7960   nonnull_assert(cmdList != NULL);
7961   nonnull_assert(clorobj != NULL);
7962   nonnull_assert(freeFct != NULL);
7963 
7964   /*
7965     CmdListRemoveDeleted(cmdList, freeFct);
7966   */
7967   c = *cmdList;
7968   while (c != NULL && c->clorobj == clorobj) {
7969     del = c;
7970     *cmdList = c->nextPtr;
7971     CmdListDeleteCmdListEntry(del, freeFct);
7972     c = *cmdList;
7973   }
7974 
7975   while (c != NULL) {
7976     if (c->clorobj == clorobj) {
7977       del = c;
7978       c = *cmdList;
7979       while ((c->nextPtr != NULL) && (c->nextPtr != del)) {
7980         c = c->nextPtr;
7981       }
7982       if (c->nextPtr == del) {
7983         c->nextPtr = del->nextPtr;
7984       }
7985       CmdListDeleteCmdListEntry(del, freeFct);
7986     }
7987     c = c->nextPtr;
7988   }
7989 }
7990 
7991 /*
7992  * free the memory of a whole 'cmdList'
7993  */
7994 static void
CmdListFree(NsfCmdList ** cmdList,NsfFreeCmdListClientData * freeFct)7995 CmdListFree(NsfCmdList **cmdList, NsfFreeCmdListClientData *freeFct) {
7996 
7997   nonnull_assert(cmdList != NULL);
7998 
7999   while (*cmdList != NULL) {
8000     NsfCmdList *del = *cmdList;
8001     *cmdList = (*cmdList)->nextPtr;
8002     CmdListDeleteCmdListEntry(del, freeFct);
8003   }
8004 }
8005 
8006 /*
8007  * simple list search proc to search a list of cmds
8008  * for a command ptr
8009  */
8010 static NsfCmdList * CmdListFindCmdInList(const Tcl_Command cmd, NsfCmdList *l)
8011   nonnull(2) nonnull(1) pure;
8012 
8013 static NsfCmdList *
CmdListFindCmdInList(const Tcl_Command cmd,NsfCmdList * l)8014 CmdListFindCmdInList(const Tcl_Command cmd, NsfCmdList *l) {
8015   register NsfCmdList *h;
8016 
8017   nonnull_assert(cmd != NULL);
8018   nonnull_assert(l != NULL);
8019 
8020   for (h = l; h != NULL; h = h->nextPtr) {
8021     if (h->cmdPtr == cmd) {
8022       return h;
8023     }
8024   }
8025   return NULL;
8026 }
8027 
8028 /*
8029  * simple list search proc to search a list of cmds
8030  * for a simple Name
8031  */
8032 static NsfCmdList * CmdListFindNameInList(Tcl_Interp *interp, const char *name, NsfCmdList *cmdList)
8033   nonnull(1) nonnull(2) nonnull(3);
8034 
8035 static NsfCmdList *
CmdListFindNameInList(Tcl_Interp * interp,const char * name,NsfCmdList * cmdList)8036 CmdListFindNameInList(Tcl_Interp *interp, const char *name, NsfCmdList *cmdList) {
8037 
8038   nonnull_assert(interp != NULL);
8039   nonnull_assert(name != NULL);
8040   nonnull_assert(cmdList != NULL);
8041 
8042   do {
8043     const char *cmdName = Tcl_GetCommandName(interp, cmdList->cmdPtr);
8044     if (cmdName[0] == name[0] && strcmp(cmdName, name) == 0) {
8045       return cmdList;
8046     }
8047     cmdList = cmdList->nextPtr;
8048   } while (cmdList != NULL);
8049 
8050   return NULL;
8051 }
8052 
8053 /*
8054  *----------------------------------------------------------------------
8055  * CheckConditionInScope --
8056  *
8057  *    Check a given condition in the current call-frame's scope. It is
8058  *    the responsibility of the caller to push the intended call-frame.
8059  *
8060  * Results:
8061  *    Tcl result code.
8062  *
8063  * Side effects:
8064  *    None
8065  *
8066  *----------------------------------------------------------------------
8067  */
8068 static int CheckConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition)
8069   nonnull(1) nonnull(2);
8070 
8071 static int
CheckConditionInScope(Tcl_Interp * interp,Tcl_Obj * condition)8072 CheckConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition) {
8073   int      result, success;
8074   Tcl_Obj *ov[2] = {NULL, condition};
8075 
8076   nonnull_assert(interp != NULL);
8077   nonnull_assert(condition != NULL);
8078 
8079   INCR_REF_COUNT(condition);
8080   result = Nsf_ExprObjCmd(NULL, interp, 2, ov);
8081   DECR_REF_COUNT(condition);
8082 
8083   if (likely(result == TCL_OK)) {
8084     result = Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), &success);
8085     if (result == TCL_OK && success == 0) {
8086       result = NSF_CHECK_FAILED;
8087     }
8088   }
8089   return result;
8090 }
8091 
8092 /*
8093  * Generic Obj-List handling functions.
8094  */
8095 
8096 /*
8097  *----------------------------------------------------------------------
8098  * TclObjListFreeList --
8099  *
8100  *    Free the elements of the obj list.
8101  *
8102  * Results:
8103  *    None.
8104  *
8105  * Side effects:
8106  *    free memory.
8107  *
8108  *----------------------------------------------------------------------
8109  */
8110 static void TclObjListFreeList(NsfTclObjList *list)
8111   nonnull(1);
8112 
8113 static void
TclObjListFreeList(NsfTclObjList * list)8114 TclObjListFreeList(NsfTclObjList *list) {
8115 
8116   nonnull_assert(list != NULL);
8117 
8118   do {
8119     NsfTclObjList *del = list;
8120 
8121     list = list->nextPtr;
8122     DECR_REF_COUNT2("listContent", del->content);
8123     if (del->payload != NULL) {
8124       DECR_REF_COUNT2("listPayload", del->payload);
8125     }
8126     FREE(NsfTclObjList, del);
8127   } while (list != NULL);
8128 }
8129 
8130 /*
8131  *----------------------------------------------------------------------
8132  * TclObjListNewElement --
8133  *
8134  *    Add a new element to the obj list with an optional value (stored in
8135  *    payload).
8136  *
8137  * Results:
8138  *    None.
8139  *
8140  * Side effects:
8141  *    allocate memory.
8142  *
8143  *----------------------------------------------------------------------
8144  */
8145 static Tcl_Obj * TclObjListNewElement(NsfTclObjList **list, Tcl_Obj *obj, Tcl_Obj *valueObj)
8146   nonnull(1) nonnull(2) returns_nonnull;
8147 
8148 static Tcl_Obj *
TclObjListNewElement(NsfTclObjList ** list,Tcl_Obj * obj,Tcl_Obj * valueObj)8149 TclObjListNewElement(NsfTclObjList **list, Tcl_Obj *obj, Tcl_Obj *valueObj) {
8150   NsfTclObjList *elt = NEW(NsfTclObjList);
8151 
8152   nonnull_assert(list != NULL);
8153   nonnull_assert(obj != NULL);
8154 
8155   INCR_REF_COUNT2("listContent", obj);
8156   elt->content = obj;
8157   elt->payload = valueObj;
8158   if (valueObj != NULL) {
8159     INCR_REF_COUNT2("listPayload", valueObj);
8160   }
8161   elt->nextPtr = *list;
8162   *list = elt;
8163 
8164   return obj;
8165 }
8166 
8167 /*
8168  *----------------------------------------------------------------------
8169  * TclObjListAdd --
8170  *
8171  *    Add an NsfTclObjList element to the obj list indexed by a key into a
8172  *    sorted list of elements. Duplicates are appended to the payload
8173  *    elements.
8174  *
8175  * Results:
8176  *    None.
8177  *
8178  * Side effects:
8179  *    Add element to the obj-list.
8180  *
8181  *----------------------------------------------------------------------
8182  */
8183 static void TclObjListAdd(Tcl_Interp *interp, NsfTclObjList **list, Tcl_Obj *key, Tcl_Obj *value)
8184   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
8185 
8186 static void
TclObjListAdd(Tcl_Interp * interp,NsfTclObjList ** list,Tcl_Obj * key,Tcl_Obj * value)8187 TclObjListAdd(Tcl_Interp *interp, NsfTclObjList **list, Tcl_Obj *key, Tcl_Obj *value) {
8188   NsfTclObjList *elt, **prevPtr;
8189   const char    *keyString;
8190 
8191   nonnull_assert(interp != NULL);
8192   nonnull_assert(list != NULL);
8193   nonnull_assert(key != NULL);
8194   nonnull_assert(value != NULL);
8195 
8196   keyString = ObjStr(key);
8197   for (elt = *list, prevPtr = list; elt != NULL; prevPtr = &elt->nextPtr, elt = elt->nextPtr) {
8198     const char *eltString = ObjStr(elt->content);
8199 
8200     if (key == elt->content || strcmp(keyString, eltString) == 0) {
8201       /*
8202        * Found the element, append to it
8203        */
8204       /* fprintf(stderr, "TclObjListAdd: insert %s/%s equal, append to %s\n",
8205          keyString, ObjStr(value), ObjStr(elt->payload));*/
8206       Tcl_ListObjAppendElement(interp, elt->payload, value);
8207       return;
8208     }
8209     if (strcmp(keyString, eltString) < 0) {
8210       /*
8211        * Element not found, insert new before as a new entry.
8212        */
8213       /*fprintf(stderr, "TclObjListAdd: insert %s/%s before %s isshared %d\n",
8214         keyString, ObjStr(value), eltString, Tcl_IsShared(key));*/
8215       TclObjListNewElement(prevPtr, key, Tcl_IsShared(value) ? Tcl_DuplicateObj(value) : value);
8216       return;
8217     }
8218   }
8219   /*
8220    * Element not found, insert new as last entry.
8221    */
8222   /* fprintf(stderr, "TclObjListAdd: insert last %s value %s\n", keyString, ObjStr(value)); */
8223   TclObjListNewElement(prevPtr, key, Tcl_NewListObj(1, &value));
8224 
8225   return;
8226 }
8227 
8228 /*
8229  *----------------------------------------------------------------------
8230  * AddObjToTclList --
8231  *
8232  *    Add a Tcl_Obj to a potential not-existing Tcl list, which is created on
8233  *    demand.
8234  *
8235  * Results:
8236  *    None.
8237  *
8238  * Side effects:
8239  *    Add Tcl_Obj to the Tcl list, potentially creating list.
8240  *
8241  *----------------------------------------------------------------------
8242  */
8243 static void
8244 AddObjToTclList(
8245     Tcl_Interp  *interp,
8246     Tcl_Obj    **listObjPtr,
8247     Tcl_Obj     *obj
8248 ) nonnull(2) nonnull(3);
8249 
8250 static void
AddObjToTclList(Tcl_Interp * interp,Tcl_Obj ** listObjPtr,Tcl_Obj * obj)8251 AddObjToTclList(
8252     Tcl_Interp  *interp,
8253     Tcl_Obj    **listObjPtr,
8254     Tcl_Obj     *obj
8255 ) {
8256   nonnull_assert(listObjPtr != NULL);
8257   nonnull_assert(obj != NULL);
8258 
8259   if (*listObjPtr == NULL) {
8260     *listObjPtr = Tcl_NewListObj(1, &obj);
8261     INCR_REF_COUNT2("AddObjToTclList", *listObjPtr);
8262   } else {
8263     Tcl_ListObjAppendElement(interp, *listObjPtr, obj);
8264   }
8265 }
8266 
8267 
8268 #if defined(NSF_WITH_ASSERTIONS)
8269 /*********************************************************************
8270  * Assertions
8271  **********************************************************************/
8272 
8273 static NsfTclObjList * AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj)
8274   nonnull(1);
8275 
8276 static NsfTclObjList *
AssertionNewList(Tcl_Interp * interp,Tcl_Obj * aObj)8277 AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj) {
8278   Tcl_Obj **ov; int oc;
8279   NsfTclObjList *last = NULL;
8280 
8281   nonnull_assert(interp != NULL);
8282 
8283   if (aObj && Tcl_ListObjGetElements(interp, aObj, &oc, &ov) == TCL_OK) {
8284     if (oc > 0) {
8285       int i;
8286       for (i = oc - 1; i >= 0; i--) {
8287         TclObjListNewElement(&last, ov[i], NULL);
8288       }
8289     }
8290   }
8291   return last;
8292 }
8293 
8294 static Tcl_Obj *AssertionList(Tcl_Interp *interp, NsfTclObjList *alist)
8295   nonnull(1);
8296 
8297 static Tcl_Obj *
AssertionList(Tcl_Interp * interp,NsfTclObjList * alist)8298 AssertionList(Tcl_Interp *interp, NsfTclObjList *alist) {
8299   Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
8300 
8301   nonnull_assert(interp != NULL);
8302 
8303   for (; alist != NULL; alist = alist->nextPtr) {
8304     Tcl_ListObjAppendElement(interp, listObj, alist->content);
8305   }
8306   return listObj;
8307 }
8308 
8309 static int AssertionListCheckOption(Tcl_Interp *interp, NsfObject *object)
8310   nonnull(1) nonnull(2);
8311 
8312 static int
AssertionListCheckOption(Tcl_Interp * interp,NsfObject * object)8313 AssertionListCheckOption(Tcl_Interp *interp, NsfObject *object) {
8314   NsfObjectOpt *opt;
8315   Tcl_Obj      *resultObj;
8316 
8317   nonnull_assert(interp != NULL);
8318   nonnull_assert(object != NULL);
8319 
8320   opt = object->opt;
8321   if (opt == NULL) {
8322     return TCL_OK;
8323   }
8324 
8325   resultObj = Tcl_GetObjResult(interp);
8326 
8327   if (opt->checkoptions & CHECK_OBJINVAR) {
8328     Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("object-invar", -1));
8329   }
8330   if (opt->checkoptions & CHECK_CLINVAR) {
8331     Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("class-invar", -1));
8332   }
8333   if (opt->checkoptions & CHECK_PRE) {
8334     Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("pre", -1));
8335   }
8336   if (opt->checkoptions & CHECK_POST) {
8337     Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("post", -1));
8338   }
8339 
8340   return TCL_OK;
8341 }
8342 
8343 static NsfProcAssertion *AssertionFindProcs(NsfAssertionStore *aStore, const char *name)
8344   nonnull(1) nonnull(2);
8345 
8346 static NsfProcAssertion *
AssertionFindProcs(NsfAssertionStore * aStore,const char * name)8347 AssertionFindProcs(NsfAssertionStore *aStore, const char *name) {
8348   const Tcl_HashEntry *hPtr;
8349 
8350   nonnull_assert(aStore != NULL);
8351   nonnull_assert(name != NULL);
8352 
8353   hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL);
8354   if (hPtr == NULL) {
8355     return NULL;
8356   }
8357   return (NsfProcAssertion *) Tcl_GetHashValue(hPtr);
8358 }
8359 
8360 static void AssertionRemoveProc(NsfAssertionStore *aStore, const char *name)
8361   nonnull(1) nonnull(2);
8362 
8363 static void
AssertionRemoveProc(NsfAssertionStore * aStore,const char * name)8364 AssertionRemoveProc(NsfAssertionStore *aStore, const char *name) {
8365   Tcl_HashEntry *hPtr;
8366 
8367   nonnull_assert(aStore != NULL);
8368   nonnull_assert(name != NULL);
8369 
8370   hPtr = Tcl_CreateHashEntry(&aStore->procs, name, NULL);
8371   if (hPtr != NULL) {
8372     NsfProcAssertion *procAss = (NsfProcAssertion *) Tcl_GetHashValue(hPtr);
8373 
8374     if (procAss->pre != NULL) {
8375       TclObjListFreeList(procAss->pre);
8376     }
8377     if (procAss->post != NULL) {
8378       TclObjListFreeList(procAss->post);
8379     }
8380     FREE(NsfProcAssertion, procAss);
8381     Tcl_DeleteHashEntry(hPtr);
8382   }
8383 }
8384 
8385 static void AssertionAddProc(Tcl_Interp *interp, const char *name, NsfAssertionStore *aStore,
8386                  Tcl_Obj *pre, Tcl_Obj *post)
8387   nonnull(1) nonnull(2) nonnull(3);
8388 
8389 static void
AssertionAddProc(Tcl_Interp * interp,const char * name,NsfAssertionStore * aStore,Tcl_Obj * pre,Tcl_Obj * post)8390 AssertionAddProc(Tcl_Interp *interp, const char *name, NsfAssertionStore *aStore,
8391                  Tcl_Obj *pre, Tcl_Obj *post) {
8392   int isNew = 0;
8393   Tcl_HashEntry *hPtr;
8394   NsfProcAssertion *procs = NEW(NsfProcAssertion);
8395 
8396   nonnull_assert(interp != NULL);
8397   nonnull_assert(name != NULL);
8398   nonnull_assert(aStore != NULL);
8399 
8400   AssertionRemoveProc(aStore, name);
8401   procs->pre = AssertionNewList(interp, pre);
8402   procs->post = AssertionNewList(interp, post);
8403   hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &isNew);
8404   if (isNew != 0) {
8405     Tcl_SetHashValue(hPtr, procs);
8406   }
8407 }
8408 
8409 static NsfAssertionStore *AssertionCreateStore(void) returns_nonnull;
8410 
8411 static NsfAssertionStore *
AssertionCreateStore(void)8412 AssertionCreateStore(void) {
8413   NsfAssertionStore *aStore = NEW(NsfAssertionStore);
8414 
8415   aStore->invariants = NULL;
8416   Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS);
8417   MEM_COUNT_ALLOC("Tcl_InitHashTable", &aStore->procs);
8418   return aStore;
8419 }
8420 
8421 static void AssertionRemoveStore(NsfAssertionStore *aStore)
8422   nonnull(1);
8423 
8424 static void
AssertionRemoveStore(NsfAssertionStore * aStore)8425 AssertionRemoveStore(NsfAssertionStore *aStore) {
8426   Tcl_HashSearch hSrch;
8427   const Tcl_HashEntry *hPtr;
8428 
8429   nonnull_assert(aStore != NULL);
8430 
8431   for (hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch);
8432        hPtr != NULL;
8433        hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch)) {
8434     /*
8435      * AssertionRemoveProc calls Tcl_DeleteHashEntry(hPtr), thus
8436      * we get the FirstHashEntry afterwards again to proceed
8437      */
8438     AssertionRemoveProc(aStore, Tcl_GetHashKey(&aStore->procs, hPtr));
8439   }
8440   Tcl_DeleteHashTable(&aStore->procs);
8441   MEM_COUNT_FREE("Tcl_InitHashTable", &aStore->procs);
8442   if (aStore->invariants != NULL) {
8443     TclObjListFreeList(aStore->invariants);
8444   }
8445   FREE(NsfAssertionStore, aStore);
8446 }
8447 
8448 static int AssertionCheckList(Tcl_Interp *interp, NsfObject *object,
8449                               NsfTclObjList *alist, const char *methodName)
8450   nonnull(1) nonnull(2) nonnull(4);
8451 
8452 static int
AssertionCheckList(Tcl_Interp * interp,NsfObject * object,NsfTclObjList * alist,const char * methodName)8453 AssertionCheckList(Tcl_Interp *interp, NsfObject *object,
8454                    NsfTclObjList *alist, const char *methodName) {
8455   NsfTclObjList *checkFailed = NULL;
8456   Tcl_Obj       *savedResultObj;
8457   CheckOptions   savedCheckoptions;
8458   int            acResult = TCL_OK;
8459 
8460   nonnull_assert(interp != NULL);
8461   nonnull_assert(object != NULL);
8462   nonnull_assert(methodName != NULL);
8463 
8464   /*
8465    * No obj->opt -> checkoption == CHECK_NONE
8466    */
8467   if (object->opt == NULL) {
8468     return TCL_OK;
8469   }
8470 
8471   /*
8472    * Do not check assertion modifying methods, otherwise we cannot react in
8473    * catch on a runtime assertion check failure
8474    */
8475 
8476 #if 1
8477   /*
8478    * TODO: the following check operations is XOTcl1 legacy and is not
8479    * generic. It should be replaced by another method-property.  Most of the
8480    * is*String() definition are then obsolete and should be deleted from
8481    * nsfInt.h as well.
8482    */
8483 
8484   if (isCheckString(methodName)) {
8485     return TCL_OK;
8486   }
8487 #endif
8488 
8489   savedResultObj = Tcl_GetObjResult(interp);
8490   INCR_REF_COUNT(savedResultObj);
8491 
8492   Tcl_ResetResult(interp);
8493 
8494   while (alist != NULL) {
8495     /*
8496      * Eval instead of IfObjCmd => the substitutions in the conditions will be
8497      * done by Tcl.
8498      */
8499     const char *assStr = ObjStr(alist->content), *c = assStr;
8500     int         comment = 0;
8501 
8502     for (; c && *c != '\0'; c++) {
8503       if (*c == '#') {
8504         comment = 1; break;
8505       }
8506     }
8507 
8508     if (comment == 0) {
8509       CallFrame frame, *framePtr = &frame;
8510       Nsf_PushFrameObj(interp, object, framePtr);
8511 
8512       /*
8513        * Don't check assertions during the condition check.
8514        */
8515       savedCheckoptions = object->opt->checkoptions;
8516       object->opt->checkoptions = CHECK_NONE;
8517 
8518       /* fprintf(stderr, "Checking Assertion %s ", assStr); */
8519 
8520       /*
8521        * Now check the condition in the pushed call-frame's scope.
8522        */
8523       acResult = CheckConditionInScope(interp, alist->content);
8524       if (acResult != TCL_OK) {
8525         checkFailed = alist;
8526       }
8527       object->opt->checkoptions = savedCheckoptions;
8528       /* fprintf(stderr, "...%s\n", (checkFailed != 0) ? "failed" : "ok"); */
8529       Nsf_PopFrameObj(interp, framePtr);
8530     }
8531     if (checkFailed != 0) {
8532       break;
8533     }
8534     alist = alist->nextPtr;
8535   }
8536 
8537   if (unlikely(checkFailed != 0)) {
8538     DECR_REF_COUNT(savedResultObj);
8539     if (acResult == TCL_ERROR) {
8540       Tcl_Obj *sr = Tcl_GetObjResult(interp);
8541       INCR_REF_COUNT(sr);
8542       NsfPrintError(interp, "error in Assertion: {%s} in proc '%s'\n%s",
8543                     ObjStr(checkFailed->content), methodName, ObjStr(sr));
8544       DECR_REF_COUNT(sr);
8545       return TCL_ERROR;
8546     }
8547     return NsfPrintError(interp, "assertion failed check: {%s} in proc '%s'",
8548                          ObjStr(checkFailed->content), methodName);
8549   }
8550 
8551   Tcl_SetObjResult(interp, savedResultObj);
8552   DECR_REF_COUNT(savedResultObj);
8553 
8554   return TCL_OK;
8555 }
8556 
8557 static int AssertionCheckInvars(Tcl_Interp *interp, NsfObject *object,
8558                      const char *methodName,
8559                      CheckOptions checkoptions)
8560   nonnull(1) nonnull(2) nonnull(3);
8561 
8562 static int
AssertionCheckInvars(Tcl_Interp * interp,NsfObject * object,const char * methodName,CheckOptions checkoptions)8563 AssertionCheckInvars(Tcl_Interp *interp, NsfObject *object,
8564                      const char *methodName,
8565                      CheckOptions checkoptions) {
8566   int result = TCL_OK;
8567 
8568   nonnull_assert(interp != NULL);
8569   nonnull_assert(object != NULL);
8570   nonnull_assert(methodName != NULL);
8571 
8572   if (checkoptions & CHECK_OBJINVAR && object->opt->assertions) {
8573     result = AssertionCheckList(interp, object, object->opt->assertions->invariants,
8574                                 methodName);
8575   }
8576 
8577   if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) {
8578     NsfClasses *clPtr;
8579 
8580     clPtr = PrecedenceOrder(object->cl);
8581     while ((clPtr != NULL) && (result != TCL_ERROR)) {
8582       NsfAssertionStore *aStore = (clPtr->cl->opt != NULL) ? clPtr->cl->opt->assertions : NULL;
8583 
8584       if (aStore != NULL) {
8585         result = AssertionCheckList(interp, object, aStore->invariants, methodName);
8586       }
8587       clPtr = clPtr->nextPtr;
8588     }
8589   }
8590   return result;
8591 }
8592 
8593 static int AssertionCheck(Tcl_Interp *interp, NsfObject *object, NsfClass *class,
8594                           const char *method, CheckOptions checkOption)
8595   nonnull(1) nonnull(2) nonnull(4);
8596 
8597 static int
AssertionCheck(Tcl_Interp * interp,NsfObject * object,NsfClass * class,const char * method,CheckOptions checkOption)8598 AssertionCheck(Tcl_Interp *interp, NsfObject *object, NsfClass *class,
8599                const char *method, CheckOptions checkOption) {
8600   int                result = TCL_OK;
8601   NsfAssertionStore *aStore;
8602 
8603   nonnull_assert(interp != NULL);
8604   nonnull_assert(object != NULL);
8605   nonnull_assert(method != NULL);
8606   assert(object->opt != NULL);
8607 
8608   if (class != NULL) {
8609     aStore = (class->opt != NULL) ? class->opt->assertions : NULL;
8610   } else {
8611     aStore = (object->opt != NULL) ? object->opt->assertions : NULL;
8612   }
8613 
8614   if ((aStore != NULL)
8615       && (checkOption & object->opt->checkoptions)
8616       ) {
8617     NsfProcAssertion *procs = AssertionFindProcs(aStore, method);
8618 
8619     if (procs != NULL) {
8620       switch (checkOption) {
8621       case CHECK_PRE:
8622         result = AssertionCheckList(interp, object, procs->pre, method);
8623         break;
8624       case CHECK_POST:
8625         result = AssertionCheckList(interp, object, procs->post, method);
8626         break;
8627       case CHECK_ALL:      /* fall through */
8628       case CHECK_NONE:     /* fall through */
8629       case CHECK_CLINVAR:  /* fall through */
8630       case CHECK_OBJINVAR: /* fall through */
8631       case CHECK_INVAR:    /* fall through */
8632         break;
8633       }
8634     }
8635     if (likely(result != TCL_ERROR)) {
8636       result = AssertionCheckInvars(interp, object, method, object->opt->checkoptions);
8637     }
8638   }
8639   return result;
8640 }
8641 
8642 static int AssertionSetCheckOptions(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arg)
8643   nonnull(1) nonnull(2) nonnull(3);
8644 
8645 static int
AssertionSetCheckOptions(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * arg)8646 AssertionSetCheckOptions(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arg) {
8647   NsfObjectOpt *opt;
8648   int ocArgs;
8649   Tcl_Obj **ovArgs;
8650 
8651   nonnull_assert(interp != NULL);
8652   nonnull_assert(object != NULL);
8653   nonnull_assert(arg != NULL);
8654 
8655   opt = NsfRequireObjectOpt(object);
8656   opt->checkoptions = CHECK_NONE;
8657 
8658   if (Tcl_ListObjGetElements(interp, arg, &ocArgs, &ovArgs) == TCL_OK
8659       && ocArgs > 0) {
8660     int i;
8661     for (i = 0; i < ocArgs; i++) {
8662       const char *option = ObjStr(ovArgs[i]);
8663       if (option != NULL) {
8664         switch (*option) {
8665         case 'c':
8666           if (strcmp(option, "class-invar") == 0) {
8667             opt->checkoptions |= CHECK_CLINVAR;
8668           }
8669           break;
8670         case 'o':
8671           if (strcmp(option, "object-invar") == 0) {
8672             opt->checkoptions |= CHECK_OBJINVAR;
8673           }
8674           break;
8675         case 'p':
8676           if (strcmp(option, "pre") == 0) {
8677             opt->checkoptions |= CHECK_PRE;
8678           } else if (strcmp(option, "post") == 0) {
8679             opt->checkoptions  |= CHECK_POST;
8680           }
8681           break;
8682         case 'a':
8683           if (strcmp(option, "all") == 0) {
8684             opt->checkoptions |= CHECK_ALL;
8685           }
8686           break;
8687         }
8688       }
8689     }
8690   }
8691   if (opt->checkoptions == CHECK_NONE && ocArgs > 0) {
8692     return NsfPrintError(interp, "unknown check option in command '%s' check %s, ",
8693                          "valid: all pre post object-invar class-invar",
8694                          ObjectName_(object), ObjStr(arg));
8695   }
8696   return TCL_OK;
8697 }
8698 
8699 static void AssertionSetInvariants(Tcl_Interp *interp, NsfAssertionStore **assertions, Tcl_Obj *arg)
8700   nonnull(1) nonnull(2) nonnull(3);
8701 
8702 static void
AssertionSetInvariants(Tcl_Interp * interp,NsfAssertionStore ** assertions,Tcl_Obj * arg)8703 AssertionSetInvariants(Tcl_Interp *interp, NsfAssertionStore **assertions, Tcl_Obj *arg) {
8704 
8705   nonnull_assert(interp != NULL);
8706   nonnull_assert(assertions != NULL);
8707   nonnull_assert(arg != NULL);
8708 
8709   if (*assertions != NULL) {
8710     TclObjListFreeList((*assertions)->invariants);
8711   } else {
8712     *assertions = AssertionCreateStore();
8713   }
8714   (*assertions)->invariants = AssertionNewList(interp, arg);
8715 }
8716 #endif /* NSF_WITH_ASSERTIONS */
8717 
8718 
8719 
8720 
8721 /***********************************************************************
8722  * Mixin support
8723  ***********************************************************************/
8724 
8725 /*
8726  * push a mixin stack information on this object
8727  */
8728 static void MixinStackPush(NsfObject *object)
8729   nonnull(1);
8730 
8731 static void
MixinStackPush(NsfObject * object)8732 MixinStackPush(NsfObject *object) {
8733   register NsfMixinStack *h = NEW(NsfMixinStack);
8734 
8735   nonnull_assert(object != NULL);
8736 
8737   h->currentCmdPtr = NULL;
8738   h->nextPtr = object->mixinStack;
8739   object->mixinStack = h;
8740   /*fprintf(stderr, "MixinStackPush %p %s\n", object, ObjectName(object));*/
8741 }
8742 
8743 /*
8744  * Pop a mixin stack information on this object.
8745  */
8746 static void MixinStackPop(NsfObject *object)
8747   nonnull(1);
8748 
8749 static void
MixinStackPop(NsfObject * object)8750 MixinStackPop(NsfObject *object) {
8751   register const NsfMixinStack *h;
8752 
8753   nonnull_assert(object != NULL);
8754 
8755   /*fprintf(stderr, "MixinStackPop %p %s\n", object, ObjectName(object));*/
8756   h = object->mixinStack;
8757   object->mixinStack = h->nextPtr;
8758   FREE(NsfMixinStack, h);
8759 }
8760 
8761 /*
8762  * Appends NsfClasses (containing the mixin-classes and their
8763  * superclasses) to 'mixinClasses' list from a given mixinList.
8764  */
8765 static void MixinComputeOrderFullList(
8766     Tcl_Interp *interp, NsfCmdList **mixinList,
8767     NsfClasses **mixinClasses,
8768     NsfClasses **checkList, int level
8769 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
8770 
8771 static void
MixinComputeOrderFullList(Tcl_Interp * interp,NsfCmdList ** mixinList,NsfClasses ** mixinClasses,NsfClasses ** checkList,int level)8772 MixinComputeOrderFullList(
8773     Tcl_Interp *interp, NsfCmdList **mixinList,
8774     NsfClasses **mixinClasses,
8775     NsfClasses **checkList, int level
8776 ) {
8777   NsfCmdList *m;
8778   NsfClasses *pl, **clPtr = mixinClasses;
8779 
8780   nonnull_assert(interp != NULL);
8781   nonnull_assert(mixinList != NULL);
8782   nonnull_assert(mixinClasses != NULL);
8783   nonnull_assert(checkList != NULL);
8784 
8785   CmdListRemoveDeleted(mixinList, GuardDel);
8786 
8787   for (m = *mixinList; m != NULL; m = m->nextPtr) {
8788     NsfClass *mixinClass = NsfGetClassFromCmdPtr(m->cmdPtr);
8789 
8790     if (mixinClass != NULL) {
8791       for (pl = PrecedenceOrder(mixinClass); pl != NULL; pl = pl->nextPtr) {
8792         if (!IsRootClass(pl->cl)) {
8793           NsfClassOpt *opt = pl->cl->opt;
8794 
8795           /* fprintf(stderr, "find %p %s in checklist 1 %p\n",
8796              pl->cl, ClassName(pl->cl), *checkList);*/
8797           if (*checkList != NULL && (NsfClassListFind(*checkList, pl->cl) != NULL)) {
8798             /*fprintf(stderr, "+++ never add %s\n", ClassName(pl->cl));*/
8799           } else {
8800             if (opt != NULL && opt->classMixins != NULL) {
8801               /*
8802                * Compute transitively the (class) mixin-classes of this
8803                * added class.
8804                */
8805               NsfClassListAdd(checkList, pl->cl, NULL);
8806               /*fprintf(stderr, "+++ transitive %s\n", ClassName(pl->cl));*/
8807               MixinComputeOrderFullList(interp, &opt->classMixins, mixinClasses,
8808                                         checkList, level+1);
8809             }
8810             /*fprintf(stderr, "+++ add to mixinClasses %p path: %s clPtr %p\n",
8811               mixinClasses, ClassName(pl->cl), clPtr);*/
8812             clPtr = NsfClassListAddNoDup(clPtr, pl->cl, m->clientData);
8813           }
8814         }
8815       }
8816     }
8817   }
8818 
8819   if (level == 0 && *checkList) {
8820     NsfClassListFree(*checkList);
8821     *checkList = NULL;
8822   }
8823 }
8824 
8825 /*
8826  *----------------------------------------------------------------------
8827  * MixinResetOrder --
8828  *
8829  *    Free the mixin order of the provided object if it exists.
8830  *
8831  * Results:
8832  *    void
8833  *
8834  * Side effects:
8835  *    Frees potentially the mixinOrder list.
8836  *
8837  *----------------------------------------------------------------------
8838  */
8839 static void MixinResetOrder(NsfObject *object)
8840   nonnull(1);
8841 
8842 static void
MixinResetOrder(NsfObject * object)8843 MixinResetOrder(NsfObject *object) {
8844 
8845   nonnull_assert(object != NULL);
8846 
8847   CmdListFree(&object->mixinOrder, NULL /*GuardDel*/);
8848   object->mixinOrder = NULL;
8849 }
8850 
8851 /*
8852  *----------------------------------------------------------------------
8853  * NsfClassListAddPerClassMixins --
8854  *
8855  *    Append the class mixins to the provided list. CheckList is used to
8856  *    eliminate potential duplicates.
8857  *
8858  * Results:
8859  *    void
8860  *
8861  * Side effects:
8862  *    Appends potentially elements to classListPtr and checkList
8863  *
8864  *----------------------------------------------------------------------
8865  */
8866 static void NsfClassListAddPerClassMixins(Tcl_Interp *interp, NsfClass *class,
8867                               NsfClasses **classListPtr, NsfClasses **checkList)
8868   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
8869 
8870 static void
NsfClassListAddPerClassMixins(Tcl_Interp * interp,NsfClass * class,NsfClasses ** classListPtr,NsfClasses ** checkList)8871 NsfClassListAddPerClassMixins(Tcl_Interp *interp, NsfClass *class,
8872                               NsfClasses **classListPtr, NsfClasses **checkList) {
8873   NsfClasses *pl;
8874 
8875   nonnull_assert(interp != NULL);
8876   nonnull_assert(class != NULL);
8877   nonnull_assert(classListPtr != NULL);
8878   nonnull_assert(checkList != NULL);
8879 
8880   for (pl = PrecedenceOrder(class); pl != NULL; pl = pl->nextPtr) {
8881     NsfClassOpt *clopt = pl->cl->opt;
8882     if (clopt != NULL && clopt->classMixins) {
8883       MixinComputeOrderFullList(interp, &clopt->classMixins,
8884                                 classListPtr, checkList, 1);
8885     }
8886   }
8887 }
8888 
8889 /*
8890  *----------------------------------------------------------------------
8891  * MixinComputeOrder --
8892  *
8893  *    Compute a duplicate-free linearized order of per-object and per-class
8894  *    mixins and the class inheritance. The precedence rule is that the last
8895  *    occurrence makes it into the final list.
8896  *
8897  * Results:
8898  *    void
8899  *
8900  * Side effects:
8901  *    object->mixinOrder is updated.
8902  *
8903  *----------------------------------------------------------------------
8904  */
8905 static void MixinComputeOrder(Tcl_Interp *interp, NsfObject *object)
8906   nonnull(1) nonnull(2);
8907 
8908 static void
MixinComputeOrder(Tcl_Interp * interp,NsfObject * object)8909 MixinComputeOrder(Tcl_Interp *interp, NsfObject *object) {
8910   NsfClasses *fullList, *checkList = NULL, *mixinClasses = NULL, *clPtr;
8911 
8912   nonnull_assert(interp != NULL);
8913   nonnull_assert(object != NULL);
8914 
8915   if (object->mixinOrder != NULL) {
8916     MixinResetOrder(object);
8917   }
8918 
8919   /*
8920    * Append per-obj mixins.
8921    */
8922   if (object->opt != NULL) {
8923     NsfCmdList *m;
8924 
8925     MixinComputeOrderFullList(interp, &object->opt->objMixins, &mixinClasses,
8926                               &checkList, 1);
8927     /*
8928      * Add per-object mixins to checkList to avoid these classes in the
8929      * class mixins.
8930      *
8931      * TODO: we could add this already in MixinComputeOrderFullList() if we
8932      * provide an additional flag.
8933      */
8934     for (m = object->opt->objMixins; m != NULL; m = m->nextPtr) {
8935       NsfClass *mixinClass = NsfGetClassFromCmdPtr(m->cmdPtr);
8936       if (mixinClass != NULL) {
8937         NsfClassListAddNoDup(&checkList, mixinClass, NULL);
8938       }
8939     }
8940   }
8941   /*fprintf(stderr, "%s ", ObjectName(object));
8942   NsfClassListPrint("MixinComputeOrder poms", mixinClasses);
8943   NsfClassListPrint("MixinComputeOrder poms checkList", checkList);*/
8944 
8945   /*
8946    * Append per-class mixins.
8947    */
8948   NsfClassListAddPerClassMixins(interp, object->cl, &mixinClasses, &checkList);
8949 
8950   /*fprintf(stderr, "%s ", ObjectName(object));
8951   NsfClassListPrint("MixinComputeOrder poms+pcms", mixinClasses);
8952   CmdListPrint(interp, "mixinOrder", object->mixinOrder);*/
8953 
8954   if (checkList != NULL) {
8955     NsfClassListFree(checkList);
8956   }
8957 
8958   fullList = mixinClasses;
8959 
8960   /*
8961    * Don't add duplicates or classes of the precedence order to the resulting
8962    * list.
8963    */
8964   for (clPtr = mixinClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
8965     const NsfClass *class = clPtr->cl;
8966     NsfClasses     *checker;
8967 
8968     /*fprintf(stderr, "--- Work on %s\n", ClassName(cl));
8969       CmdListPrint(interp, "mixinOrder", object->mixinOrder);*/
8970 
8971     checker = NsfClassListFind(clPtr->nextPtr, class);
8972 
8973     /*
8974      * If checker is set, it is a duplicate and ignored.
8975      */
8976     if (checker == NULL) {
8977       /*
8978        * Check object->cl hierarchy
8979        */
8980       checker = NsfClassListFind(PrecedenceOrder(object->cl), class);
8981       /*
8982        * If checker is set, it was found in the class hierarchy and it is
8983        * ignored.
8984        */
8985     }
8986     if (checker == NULL) {
8987       /*
8988        * Add the class to the mixinOrder list.
8989        */
8990       NsfCmdList *new;
8991 
8992       /*fprintf(stderr, "--- adding to mixinOrder %s to cmdlist %p of object %s\n",
8993         ClassName(class), object->mixinOrder, ObjectName(object));*/
8994       new = CmdListAdd(&object->mixinOrder, class->object.id, NULL,
8995                        /*noDuplicates*/ NSF_FALSE, NSF_TRUE);
8996       /*CmdListPrint(interp, "mixinOrder", object->mixinOrder);*/
8997 
8998       /*
8999        * We require the first matching guard of the full list in the new
9000        * client data
9001        */
9002       checker = NsfClassListFind(fullList, class);
9003       if (checker != NULL) {
9004         new->clientData = checker->clientData;
9005       }
9006     }
9007 
9008   }
9009 
9010   /*
9011    * ... and free the memory of the full list.
9012    */
9013   if (fullList != NULL) {
9014     NsfClassListFree(fullList);
9015   }
9016 
9017   /*CmdListPrint(interp, "mixin order\n", obj->mixinOrder);*/
9018 }
9019 
9020 
9021 /*
9022  *----------------------------------------------------------------------
9023  * MixinAdd --
9024  *
9025  *    Add a mixinreg (mixin-class with a potential guard) provided as a
9026  *    Tcl_Obj* to 'mixinList' by appending it to the provided cmdList.
9027  *
9028  * Results:
9029  *    Tcl result code.
9030  *
9031  * Side effects:
9032  *    Potentially allocating cmd list elements added to the mixinList
9033  *
9034  *----------------------------------------------------------------------
9035  */
9036 static int MixinAdd(Tcl_Interp *interp, NsfCmdList **mixinList, Tcl_Obj *nameObj)
9037   nonnull(1) nonnull(2) nonnull(3);
9038 
9039 static int
MixinAdd(Tcl_Interp * interp,NsfCmdList ** mixinList,Tcl_Obj * nameObj)9040 MixinAdd(Tcl_Interp *interp, NsfCmdList **mixinList, Tcl_Obj *nameObj) {
9041   int         result;
9042 
9043   nonnull_assert(interp != NULL);
9044   nonnull_assert(mixinList != NULL);
9045   nonnull_assert(nameObj != NULL);
9046 
9047   /*fprintf(stderr, "MixinAdd gets obj %p type %p %s\n",
9048     nameObj, nameObj->typePtr, ObjTypeStr(nameObj));*/
9049 
9050   /*
9051    * When the provided nameObj is of type NsfMixinregObjType, the nsf specific
9052    * converter was called already; otherwise call the converter here.
9053    */
9054   if (nameObj->typePtr != &NsfMixinregObjType
9055       && Tcl_ConvertToType(interp, nameObj, &NsfMixinregObjType) != TCL_OK
9056      ) {
9057     result = TCL_ERROR;
9058 
9059   } else {
9060     Tcl_Obj  *guardObj = NULL;
9061     NsfClass *mixinCl = NULL;
9062 
9063     result = NsfMixinregGet(interp, nameObj, &mixinCl, &guardObj);
9064     if (result == TCL_OK) {
9065       NsfCmdList *new;
9066 
9067       assert(mixinCl != NULL);
9068       assert(((unsigned int)Tcl_Command_flags(mixinCl->object.id) & CMD_IS_DELETED) == 0);
9069 
9070       new = CmdListAdd(mixinList, mixinCl->object.id, NULL,
9071                        /*noDuplicates*/ NSF_TRUE, NSF_TRUE);
9072 
9073       if (guardObj != NULL) {
9074         GuardAdd(new, guardObj);
9075       } else if (new->clientData != NULL) {
9076         GuardDel(new);
9077       }
9078     }
9079   }
9080 
9081   return result;
9082 }
9083 
9084 /*
9085  *----------------------------------------------------------------------
9086  * AppendMatchingElement --
9087  *
9088  *    Call AppendElement to the resultObj for values matching the specified
9089  *    pattern.
9090  *
9091  * Results:
9092  *    void
9093  *
9094  * Side effects:
9095  *    Appends element to the result object
9096  *
9097  *----------------------------------------------------------------------
9098  */
9099 static void AppendMatchingElement(
9100     Tcl_Interp *interp, Tcl_Obj *resultObj, Tcl_Obj *nameObj, const char *pattern
9101 ) nonnull(1) nonnull(2) nonnull(3);
9102 
9103 static void
AppendMatchingElement(Tcl_Interp * interp,Tcl_Obj * resultObj,Tcl_Obj * nameObj,const char * pattern)9104 AppendMatchingElement(
9105     Tcl_Interp *interp, Tcl_Obj *resultObj, Tcl_Obj *nameObj, const char *pattern
9106 ) {
9107 
9108   nonnull_assert(interp != NULL);
9109   nonnull_assert(resultObj != NULL);
9110   nonnull_assert(nameObj != NULL);
9111 
9112   if (pattern == NULL || Tcl_StringMatch( ObjStr(nameObj), pattern)) {
9113     Tcl_ListObjAppendElement(interp, resultObj, nameObj);
9114   }
9115 }
9116 
9117 /*
9118  *----------------------------------------------------------------------
9119  * AppendMatchingElementsFromCmdList --
9120  *
9121  *    Apply AppendMatchingElement() to all elements of the passed
9122  *    Cmdlist
9123  *
9124  * Results:
9125  *    NSF_TRUE iff a matching object was provided and it was found;
9126  *    NSF_FALSE otherwise
9127  *
9128  * Side effects:
9129  *    Appends elements to the result
9130  *
9131  *----------------------------------------------------------------------
9132  */
9133 static bool AppendMatchingElementsFromCmdList(
9134     Tcl_Interp *interp, const NsfCmdList *cmdList,
9135     Tcl_Obj *resultObj,
9136     const char *pattern, NsfObject *matchObject
9137 ) nonnull(1) nonnull(2) nonnull(3);
9138 
9139 static bool
AppendMatchingElementsFromCmdList(Tcl_Interp * interp,const NsfCmdList * cmdList,Tcl_Obj * resultObj,const char * pattern,NsfObject * matchObject)9140 AppendMatchingElementsFromCmdList(
9141     Tcl_Interp *interp, const NsfCmdList *cmdList,
9142     Tcl_Obj *resultObj,
9143     const char *pattern, NsfObject *matchObject
9144 ) {
9145   int success = NSF_FALSE;
9146 
9147   nonnull_assert(interp != NULL);
9148   nonnull_assert(cmdList != NULL);
9149   nonnull_assert(resultObj != NULL);
9150 
9151   do {
9152     NsfObject *object = NsfGetObjectFromCmdPtr(cmdList->cmdPtr);
9153     if (object != NULL) {
9154       if (matchObject == object) {
9155         return NSF_TRUE;
9156       } else {
9157         AppendMatchingElement(interp, resultObj, object->cmdName, pattern);
9158       }
9159     }
9160     cmdList = cmdList->nextPtr;
9161   } while (cmdList != NULL);
9162 
9163   return success;
9164 }
9165 
9166 /*
9167  *----------------------------------------------------------------------
9168  * AppendMatchingElementsFromClasses --
9169  *
9170  *    Apply AppendMatchingElement() to all elements of the passed
9171  *    class list
9172  *
9173  * Results:
9174  *    NSF_TRUE iff a matching object was provided and it was found; NSF_FALSE otherwise
9175  *
9176  * Side effects:
9177  *    Appends elements to the result
9178  *
9179  *----------------------------------------------------------------------
9180  */
9181 static bool AppendMatchingElementsFromClasses(
9182     Tcl_Interp *interp, const NsfClasses *cls,
9183     const char *pattern, NsfObject *matchObject
9184 ) nonnull(1);
9185 
9186 static bool
AppendMatchingElementsFromClasses(Tcl_Interp * interp,const NsfClasses * cls,const char * pattern,NsfObject * matchObject)9187 AppendMatchingElementsFromClasses(
9188     Tcl_Interp *interp, const NsfClasses *cls,
9189     const char *pattern, NsfObject *matchObject
9190 ) {
9191   Tcl_Obj *resultObj;
9192 
9193   nonnull_assert(interp != NULL);
9194 
9195   resultObj = Tcl_GetObjResult(interp);
9196   for ( ; cls != NULL; cls = cls->nextPtr) {
9197     NsfObject *object = (NsfObject *)cls->cl;
9198 
9199     if (object != NULL) {
9200       if (matchObject != NULL && object == matchObject) {
9201         /*
9202          * We have a matchObject and it is identical to obj,
9203          * just return true and don't continue search
9204          */
9205         return NSF_TRUE;
9206       } else {
9207         AppendMatchingElement(interp, resultObj, object->cmdName, pattern);
9208       }
9209     }
9210   }
9211   return NSF_FALSE;
9212 }
9213 
9214 /*
9215  *----------------------------------------------------------------------
9216  * GetAllInstances --
9217  *
9218  *    Get all instances of a class recursively into an initialized
9219  *    String key hash-table
9220  *
9221  * Results:
9222  *    void
9223  *
9224  * Side effects:
9225  *    Passed hash-table contains instances
9226  *
9227  *----------------------------------------------------------------------
9228  */
9229 static void
GetAllInstances(Tcl_Interp * interp,NsfCmdList ** instances,NsfClass * startClass)9230 GetAllInstances(Tcl_Interp *interp, NsfCmdList **instances, NsfClass *startClass) {
9231   NsfClasses *clPtr, *subClasses;
9232 
9233   nonnull_assert(interp != NULL);
9234   nonnull_assert(instances != NULL);
9235   nonnull_assert(startClass != NULL);
9236 
9237   subClasses = TransitiveSubClasses(startClass);
9238   for (clPtr = subClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
9239     Tcl_HashTable *tablePtr = &clPtr->cl->instances;
9240     Tcl_HashSearch search;
9241     const Tcl_HashEntry *hPtr;
9242 
9243     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
9244          hPtr != NULL;
9245          hPtr = Tcl_NextHashEntry(&search)) {
9246       NsfObject *inst = (NsfObject *)Tcl_GetHashKey(tablePtr, hPtr);
9247       Command *cmdPtr;
9248 
9249       assert(inst != NULL);
9250 
9251       if (unlikely((inst->flags & NSF_TCL_DELETE) != 0u)) {
9252         NsfLog(interp, NSF_LOG_NOTICE, "Object %s is apparently deleted", ObjectName(inst));
9253         continue;
9254       }
9255 
9256       cmdPtr = (Command *)inst->id;
9257       assert(cmdPtr != NULL);
9258 
9259       if (unlikely((cmdPtr->nsPtr->flags & NS_DYING) != 0u)) {
9260         NsfLog(interp, NSF_LOG_WARN, "Namespace of %s is apparently deleted", ObjectName_(inst));
9261         continue;
9262       }
9263 
9264 #if defined(NSF_DEVELOPMENT_TEST)
9265       {
9266         /*
9267          * Make sure, we can still lookup the object; the object has to be still
9268          * alive.
9269          */
9270         NsfObject *object = GetObjectFromString(interp, ObjectName(inst));
9271         /*
9272          * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is
9273          * needed because objects can be hidden or re-exposed under a different
9274          * name which is not reported back to the object system by the [interp
9275          * hide|expose] mechanism. However, we still want to process hidden and
9276          * re-exposed objects during cleanup like ordinary, exposed ones.
9277          */
9278         if (unlikely(object == NULL)) {
9279           object = GetHiddenObjectFromCmd(interp, inst->id);
9280         }
9281         assert(object != NULL);
9282       }
9283 #endif
9284 
9285       /*fprintf (stderr, " -- %p flags %.6x activation %d %s id %p id->flags %.6x "
9286         "nsPtr->flags %.6x (instance of %s)\n",
9287         inst, inst->flags, inst->activationCount,
9288         ObjectName(inst), inst->id, cmdPtr->flags, (cmdPtr->nsPtr != NULL) ? cmdPtr->nsPtr->flags : 0,
9289         ClassName(clPtr->cl));*/
9290 
9291       CmdListAdd(instances, inst->id, (NsfClass *)inst,
9292                  NSF_FALSE, NSF_FALSE);
9293     }
9294   }
9295 
9296   if (subClasses != NULL) {
9297     NsfClassListFree(subClasses);
9298   }
9299 }
9300 
9301 /*
9302  *----------------------------------------------------------------------
9303  * AddToResultSet --
9304  *
9305  *    Helper function to add classes to the result set (implemented as
9306  *    a hash-table), flagging test for matchObject as result
9307  *
9308  * Results:
9309  *    NSF_TRUE iff a matching object was provided and it was found; NSF_FALSE otherwise
9310  *
9311  * Side effects:
9312  *    Appends optionally element to the result object
9313  *
9314  *----------------------------------------------------------------------
9315  */
9316 static bool AddToResultSet(
9317     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9318     Tcl_Obj *resultSet, const NsfObject *object, int *isNewPtr,
9319     bool appendResult, const char *pattern, NsfObject *matchObject
9320 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
9321 
9322 static bool
AddToResultSet(Tcl_Interp * interp,Tcl_HashTable * destTablePtr,Tcl_Obj * resultSet,const NsfObject * object,int * isNewPtr,bool appendResult,const char * pattern,NsfObject * matchObject)9323 AddToResultSet(
9324     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9325     Tcl_Obj *resultSet, const NsfObject *object, int *isNewPtr,
9326     bool appendResult, const char *pattern, NsfObject *matchObject
9327 ) {
9328 
9329   nonnull_assert(interp != NULL);
9330   nonnull_assert(destTablePtr != NULL);
9331   nonnull_assert(resultSet != NULL);
9332   nonnull_assert(object != NULL);
9333   nonnull_assert(isNewPtr != NULL);
9334 
9335   Tcl_CreateHashEntry(destTablePtr, (char *)object, isNewPtr);
9336   if (*isNewPtr != 0) {
9337     if (matchObject != NULL && matchObject == object) {
9338       return NSF_TRUE;
9339     }
9340     if (appendResult) {
9341       AppendMatchingElement(interp, resultSet, object->cmdName, pattern);
9342     }
9343   }
9344   return NSF_FALSE;
9345 }
9346 
9347 /*
9348  *----------------------------------------------------------------------
9349  * AddToResultSetWithGuards --
9350  *
9351  *    Helper function to add classes with guards to the result set
9352  *    (implemented as a hash-table, full version as a Tcl list), flagging test
9353  *    for matchObject as result.
9354  *
9355  * Results:
9356  *    NSF_TRIE iff a matching object was provided and it was found; NSF_FALSE otherwise
9357  *
9358  * Side effects:
9359  *    Appends optionally element to the result object
9360  *
9361  *----------------------------------------------------------------------
9362  */
9363 static bool AddToResultSetWithGuards(
9364     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9365     Tcl_Obj *resultSet, const NsfClass *class,
9366     ClientData clientData, int *isNewPtr, bool appendResult,
9367     const char *pattern, NsfObject *matchObject
9368 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(6) nonnull(5);
9369 
9370 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)9371 AddToResultSetWithGuards(
9372     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9373     Tcl_Obj *resultSet, const NsfClass *class,
9374     ClientData clientData, int *isNewPtr, bool appendResult,
9375     const char *pattern, NsfObject *matchObject
9376 ) {
9377   bool result;
9378 
9379   nonnull_assert(clientData != NULL);
9380   nonnull_assert(interp != NULL);
9381   nonnull_assert(destTablePtr != NULL);
9382   nonnull_assert(class != NULL);
9383   nonnull_assert(resultSet != NULL);
9384   nonnull_assert(isNewPtr != NULL);
9385 
9386   Tcl_CreateHashEntry(destTablePtr, (char *)class, isNewPtr);
9387   if (*isNewPtr != 0 && appendResult) {
9388     if (pattern == NULL || Tcl_StringMatch(ClassName_(class), pattern)) {
9389       Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
9390       Tcl_Obj *g       = (Tcl_Obj *)clientData;
9391 
9392       INCR_REF_COUNT(listObj);
9393       Tcl_ListObjAppendElement(interp, listObj, class->object.cmdName);
9394       Tcl_ListObjAppendElement(interp, listObj, NsfGlobalObjs[NSF_GUARD_OPTION]);
9395       Tcl_ListObjAppendElement(interp, listObj, g);
9396       Tcl_ListObjAppendElement(interp, resultSet, listObj);
9397       DECR_REF_COUNT(listObj);
9398     }
9399     result = (matchObject != NULL && matchObject == (NsfObject *)class);
9400   } else {
9401     result = NSF_FALSE;
9402   }
9403 
9404   return result;
9405 }
9406 
9407 /*
9408  *----------------------------------------------------------------------
9409  * GetAllObjectMixinsOf --
9410  *
9411  *    Computes a set of classes, into which this class was mixed in
9412  *    via per object mixin. The function gets recursively all per
9413  *    object mixins from a class and its subclasses/isClassMixinOf
9414  *    and adds it into an initialized object ptr hash-table
9415  *    (TCL_ONE_WORD_KEYS)
9416  *
9417  * Results:
9418  *    Boolean value indicating when done.
9419  *
9420  * Side effects:
9421  *    The set of classes is returned in the provided hash-table
9422  *
9423  *----------------------------------------------------------------------
9424  */
9425 static bool GetAllObjectMixinsOf(
9426     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9427     Tcl_Obj *resultSet, const NsfClass *startClass, bool isMixin,
9428     bool appendResult, const char *pattern, NsfObject *matchObject
9429 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
9430 
9431 static bool
GetAllObjectMixinsOf(Tcl_Interp * interp,Tcl_HashTable * destTablePtr,Tcl_Obj * resultSet,const NsfClass * startClass,bool isMixin,bool appendResult,const char * pattern,NsfObject * matchObject)9432 GetAllObjectMixinsOf(
9433     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9434     Tcl_Obj *resultSet, const NsfClass *startClass, bool isMixin,
9435     bool appendResult, const char *pattern, NsfObject *matchObject
9436 ) {
9437   int         isNew = 0;
9438   NsfClasses *sc;
9439   bool        done = NSF_FALSE;
9440 
9441   nonnull_assert(interp != NULL);
9442   nonnull_assert(destTablePtr != NULL);
9443   nonnull_assert(resultSet != NULL);
9444   nonnull_assert(startClass != NULL);
9445 
9446   /*fprintf(stderr, "startClass = %s, opt %p, isMixin %d, pattern '%s', matchObject %p\n",
9447     ClassName(startClass), startClass->opt, isMixin, pattern, matchObject);*/
9448 
9449   /*
9450    * check all subclasses of startCl for mixins
9451    */
9452   for (sc = startClass->sub; sc != NULL; sc = sc->nextPtr) {
9453     done = GetAllObjectMixinsOf(interp, destTablePtr, resultSet,
9454                               sc->cl, isMixin, appendResult,
9455                               pattern, matchObject);
9456     if (done) {
9457       return done;
9458     }
9459   }
9460   /*fprintf(stderr, "check subclasses of %s done\n", ClassName(startClass));*/
9461 
9462   if (startClass->opt != NULL) {
9463     NsfCmdList *m;
9464 
9465     for (m = startClass->opt->isClassMixinOf; m != NULL; m = m->nextPtr) {
9466       NsfClass *class;
9467 
9468       /*
9469        * There should be no deleted commands in the list.
9470        */
9471       assert(((unsigned int)Tcl_Command_flags(m->cmdPtr) & CMD_IS_DELETED) == 0);
9472 
9473       class = NsfGetClassFromCmdPtr(m->cmdPtr);
9474       assert(class != NULL);
9475       /*fprintf(stderr, "check %s mixinof %s\n", ClassName(class), ClassName((startClass)));*/
9476       done = GetAllObjectMixinsOf(interp, destTablePtr, resultSet,
9477                                 class, isMixin, appendResult,
9478                                 pattern, matchObject);
9479       /* fprintf(stderr, "check %s mixinof %s done\n",
9480          ClassName(class), ClassName(startClass));*/
9481       if (done) {
9482         return done;
9483       }
9484     }
9485   }
9486 
9487   /*
9488    * Check whether startCl has associated per-object mixins.
9489    */
9490   if (startClass->opt != NULL) {
9491     NsfCmdList *m;
9492 
9493     for (m = startClass->opt->isObjectMixinOf; m != NULL; m = m->nextPtr) {
9494       NsfObject *object;
9495 
9496       /*
9497        * There should not be deleted commands in the list.
9498        */
9499       assert(((unsigned int)Tcl_Command_flags(m->cmdPtr) & CMD_IS_DELETED) == 0);
9500 
9501       object = NsfGetObjectFromCmdPtr(m->cmdPtr);
9502       assert(object != NULL);
9503 
9504       done = AddToResultSet(interp, destTablePtr, resultSet,
9505                             object, &isNew, appendResult,
9506                             pattern, matchObject);
9507       if (done) {
9508         return done;
9509       }
9510     }
9511   }
9512   return done;
9513 }
9514 
9515 /*
9516  *----------------------------------------------------------------------
9517  * AddClassListEntriesToMixinsOfSet --
9518  *
9519  *    Helper function of GetAllClassMixinsOf(). Iterate over the provided
9520  *    class list (mixinOfs) and add every entry to the result set. If the
9521  *    entry is new, GetAllClassMixinsOf() is called recursively.
9522  *
9523  * Results:
9524  *    Boolean value indicating when done.
9525  *
9526  * Side effects:
9527  *    The set of classes is returned in the provided hash-table
9528  *
9529  *----------------------------------------------------------------------
9530  */
9531 static bool
9532 AddClassListEntriesToMixinsOfSet(
9533     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9534     Tcl_Obj *resultSet, const NsfCmdList *mixinOfs,
9535     bool appendResult,
9536     const char *pattern, NsfObject *matchObject
9537 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
9538 
9539 static bool GetAllClassMixinsOf(
9540     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9541     Tcl_Obj *resultSet, NsfClass *startClass,
9542     bool isPCM, bool appendResult,
9543     const char *pattern, NsfObject *matchObject
9544 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
9545 
9546 static bool
AddClassListEntriesToMixinsOfSet(Tcl_Interp * interp,Tcl_HashTable * destTablePtr,Tcl_Obj * resultSet,const NsfCmdList * mixinOfs,bool appendResult,const char * pattern,NsfObject * matchObject)9547 AddClassListEntriesToMixinsOfSet(
9548     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9549     Tcl_Obj *resultSet, const NsfCmdList *mixinOfs,
9550     bool appendResult,
9551     const char *pattern, NsfObject *matchObject
9552 ) {
9553   const NsfCmdList *m;
9554 
9555   nonnull_assert(interp != NULL);
9556   nonnull_assert(destTablePtr != NULL);
9557   nonnull_assert(resultSet != NULL);
9558   nonnull_assert(mixinOfs != NULL);
9559 
9560   for (m = mixinOfs; m != NULL; m = m->nextPtr) {
9561     NsfClass *class;
9562     int       isNew;
9563     bool      done;
9564 
9565     /*
9566      * We must not have deleted commands in the list
9567      */
9568     assert(((unsigned int)Tcl_Command_flags(m->cmdPtr) & CMD_IS_DELETED) == 0);
9569 
9570     class = NsfGetClassFromCmdPtr(m->cmdPtr);
9571     assert(class != NULL);
9572 
9573     done = AddToResultSet(interp, destTablePtr, resultSet,
9574                         &class->object, &isNew,
9575                         appendResult, pattern, matchObject);
9576     if (done) {
9577       return done;
9578     }
9579     if (isNew != 0) {
9580       done = GetAllClassMixinsOf(interp, destTablePtr, resultSet, class,
9581                                  NSF_TRUE, appendResult, pattern, matchObject);
9582       if (done) {
9583         return done;
9584       }
9585     }
9586   }
9587   return NSF_FALSE;
9588 }
9589 
9590 /*
9591  *----------------------------------------------------------------------
9592  * GetAllClassMixinsOf --
9593  *
9594  *    Computes a set of classes, into which this class was mixed in
9595  *    via as a class mixin. The function gets recursively all per
9596  *    class mixins from a class and its subclasses and adds it
9597  *    into an initialized object ptr hash-table (TCL_ONE_WORD_KEYS)
9598  *
9599  * Results:
9600  *    Boolean value indicating when done.
9601  *
9602  * Side effects:
9603  *    The set of classes is returned in the provided hash-table
9604  *
9605  *----------------------------------------------------------------------
9606  */
9607 
9608 static bool
GetAllClassMixinsOf(Tcl_Interp * interp,Tcl_HashTable * destTablePtr,Tcl_Obj * resultSet,NsfClass * startClass,bool isPCM,bool appendResult,const char * pattern,NsfObject * matchObject)9609 GetAllClassMixinsOf(
9610     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9611     Tcl_Obj *resultSet, NsfClass *startClass,
9612     bool isPCM, bool appendResult,
9613     const char *pattern, NsfObject *matchObject
9614 ) {
9615   NsfClasses *sc;
9616   int         isNew = 0;
9617   bool        done = NSF_FALSE;
9618 
9619   nonnull_assert(interp != NULL);
9620   nonnull_assert(destTablePtr != NULL);
9621   nonnull_assert(resultSet != NULL);
9622   nonnull_assert(startClass != NULL);
9623 
9624   /*fprintf(stderr, "GetAllClassMixinsOf startClass = %p %s, opt %p, isPCM %d\n",
9625     startClass, ClassName(startClass), startClass->opt, isPCM);*/
9626 
9627   /*
9628    * If the startClass is a per class mixin, add it to the result set
9629    */
9630   if (isPCM) {
9631     done = AddToResultSet(interp, destTablePtr, resultSet,
9632                         &startClass->object, &isNew,
9633                         appendResult, pattern, matchObject);
9634     if (done) {
9635       return done;
9636     }
9637 
9638     /*
9639      * check all subclasses of startClass for mixins
9640      */
9641     for (sc = startClass->sub; sc != NULL; sc = sc->nextPtr) {
9642 #if !defined(NDEBUG)
9643       if (sc->cl == startClass) {
9644         /*
9645          * Sanity check: it seems that we can create via
9646          *  __default_superclass a class which has itself as subclass!
9647          */
9648         fprintf(stderr, "... STRANGE %p is subclass of %p %s, sub %p\n",
9649                 (void *)sc->cl, (void *)startClass, ClassName_(startClass),
9650                 (void *)startClass->sub);
9651         continue;
9652       }
9653 #endif
9654       assert(sc->cl != startClass);
9655       done = GetAllClassMixinsOf(interp, destTablePtr, resultSet,
9656                                sc->cl, isPCM,
9657                                appendResult, pattern, matchObject);
9658       if (done) {
9659         return done;
9660       }
9661     }
9662   }
9663 
9664   /*
9665    * Check whether "startClass" has a subclass which is a per-class mixin of some other
9666    * class(es)
9667    */
9668   {
9669     NsfClasses *subClasses = TransitiveSubClasses(startClass), *subClass;
9670 
9671     for (subClass = subClasses; subClass; subClass = subClass->nextPtr) {
9672       const NsfClass *subSubClass = subClass->cl;
9673 
9674       /*fprintf(stderr, "... check subclass = %p %s, opt %p, isPCM %d\n",
9675         subSubClass, ClassName(subSubClass), subSubClass->opt, isPCM);*/
9676 
9677       if (subSubClass->opt != NULL && subSubClass->opt->isClassMixinOf) {
9678         done = AddClassListEntriesToMixinsOfSet(interp, destTablePtr, resultSet,
9679                                                 subSubClass->opt->isClassMixinOf,
9680                                                 appendResult, pattern, matchObject);
9681         if (done) {
9682           goto subclassExit;
9683         }
9684       }
9685     }
9686 
9687   subclassExit:
9688     if (subClasses != NULL) {
9689       NsfClassListFree(subClasses);
9690     }
9691     if (done) {
9692       return done;
9693     }
9694   }
9695 
9696   /*
9697    * Check whether "startClass" is a per-class mixin of some other classes.
9698    */
9699   if (startClass->opt != NULL && startClass->opt->isClassMixinOf) {
9700     done = AddClassListEntriesToMixinsOfSet(interp, destTablePtr, resultSet,
9701                                             startClass->opt->isClassMixinOf,
9702                                             appendResult, pattern, matchObject);
9703   }
9704 
9705   return done;
9706 }
9707 
9708 /*
9709  *----------------------------------------------------------------------
9710  * GetAllClassMixins --
9711  *
9712  *    Computes a set class-mixins of a given class and handles
9713  *    transitive cases. The classes are added it into an initialized
9714  *    object ptr hash-table (TCL_ONE_WORD_KEYS)
9715  *
9716  * Results:
9717  *    Boolean value indicating when done.
9718  *
9719  * Side effects:
9720  *    The set of classes is returned in the provided hash-table
9721  *
9722  *----------------------------------------------------------------------
9723  */
9724 
9725 static bool GetAllClassMixins(
9726     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9727     Tcl_Obj *resultObj, const NsfClass *startClass,
9728     bool withGuards, const char *pattern, NsfObject *matchObject
9729 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
9730 
9731 static bool
GetAllClassMixins(Tcl_Interp * interp,Tcl_HashTable * destTablePtr,Tcl_Obj * resultObj,const NsfClass * startClass,bool withGuards,const char * pattern,NsfObject * matchObject)9732 GetAllClassMixins(
9733     Tcl_Interp *interp, Tcl_HashTable *destTablePtr,
9734     Tcl_Obj *resultObj, const NsfClass *startClass,
9735     bool withGuards, const char *pattern, NsfObject *matchObject
9736 ) {
9737   int         isNew = 0;
9738   NsfClass   *class;
9739   NsfClasses *sc;
9740   bool        done = NSF_FALSE;
9741 
9742   nonnull_assert(interp != NULL);
9743   nonnull_assert(destTablePtr != NULL);
9744   nonnull_assert(resultObj != NULL);
9745   nonnull_assert(startClass != NULL);
9746 
9747   /*
9748    * check this class for class mixins.
9749    */
9750   if (startClass->opt != NULL) {
9751     NsfCmdList *m;
9752 
9753     for (m = startClass->opt->classMixins; m != NULL; m = m->nextPtr) {
9754 
9755       /*
9756        * Make sure, there are no deleted commands in the list.
9757        */
9758       assert(((unsigned int)Tcl_Command_flags(m->cmdPtr) & CMD_IS_DELETED) == 0);
9759 
9760       class = NsfGetClassFromCmdPtr(m->cmdPtr);
9761       assert(class != NULL);
9762 
9763       /* fprintf(stderr, "class mixin found: %s\n", ClassName(class)); */
9764 
9765       if (withGuards && (m->clientData)) {
9766         /* fprintf(stderr, "AddToResultSetWithGuards: %s\n", ClassName(class)); */
9767         done = AddToResultSetWithGuards(interp, destTablePtr, resultObj,
9768                                         class, m->clientData, &isNew,
9769                                         NSF_TRUE, pattern, matchObject);
9770       } else {
9771         /* fprintf(stderr, "AddToResultSet: %s\n", ClassName(class)); */
9772         done = AddToResultSet(interp, destTablePtr, resultObj,
9773                               &class->object, &isNew,
9774                               NSF_TRUE, pattern, matchObject);
9775       }
9776       if (done) {
9777         return done;
9778       }
9779 
9780       if (isNew != 0) {
9781         /* fprintf(stderr, "class mixin GetAllClassMixins for: %s (%s)\n",
9782            ClassName(class), ClassName(startClass)); */
9783         done = GetAllClassMixins(interp, destTablePtr, resultObj,
9784                                class, withGuards,
9785                                pattern, matchObject);
9786         if (done) {
9787           return done;
9788         }
9789       }
9790     }
9791   }
9792 
9793 
9794   /*
9795    * Check all superClasses of startCl for class mixins.
9796    */
9797   for (sc = startClass->super; sc != NULL; sc = sc->nextPtr) {
9798     /* fprintf(stderr, "Superclass GetAllClassMixins for %s (%s)\n",
9799        ClassName(sc->cl), ClassName(startClass)); */
9800     done = GetAllClassMixins(interp, destTablePtr, resultObj,
9801                              sc->cl, withGuards,
9802                              pattern, matchObject);
9803     if (done) {
9804       return done;
9805     }
9806   }
9807   return done;
9808 }
9809 
9810 /*
9811  *----------------------------------------------------------------------
9812  * RemoveFromClassMixinsOf --
9813  *
9814  *    Remove the class (provided as a cmd) from all isClassMixinOf definitions
9815  *    from the provided classes (provided as cmdlist).
9816  *
9817  * Results:
9818  *    void
9819  *
9820  * Side effects:
9821  *    Deletes potentially some entries in the isClassMixinOf lists.
9822  *
9823  *----------------------------------------------------------------------
9824  */
9825 
9826 static void RemoveFromClassMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList)
9827   nonnull(1) nonnull(2);
9828 
9829 static void
RemoveFromClassMixinsOf(Tcl_Command cmd,NsfCmdList * cmdList)9830 RemoveFromClassMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList) {
9831 
9832   nonnull_assert(cmd != NULL);
9833   nonnull_assert(cmdList != NULL);
9834 
9835   do {
9836     const NsfClass    *class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
9837     NsfClassOpt *nclopt = (class != NULL) ? class->opt : NULL;
9838     if (nclopt != NULL) {
9839       NsfCmdList *del = CmdListFindCmdInList(cmd, nclopt->isClassMixinOf);
9840       if (del != NULL) {
9841         /* fprintf(stderr, "Removing class %s from isClassMixinOf of class %s\n",
9842            ClassName(cl), ObjStr(NsfGetClassFromCmdPtr(cmdList->cmdPtr)->object.cmdName)); */
9843         del = CmdListRemoveFromList(&nclopt->isClassMixinOf, del);
9844         CmdListDeleteCmdListEntry(del, GuardDel);
9845       }
9846     }
9847     cmdList = cmdList->nextPtr;
9848   } while (cmdList != NULL);
9849 }
9850 
9851 /*
9852  *----------------------------------------------------------------------
9853  * RemoveFromObjectMixinsOf --
9854  *
9855  *    Remove the class (provided as a cmd) from all isObjectMixinOf definitions
9856  *    from the provided classes (provided as cmdList).
9857  *
9858  * Results:
9859  *    void
9860  *
9861  * Side effects:
9862  *    Deletes potentially some entries in the isObjectMixinOf lists.
9863  *
9864  *----------------------------------------------------------------------
9865  */
9866 
9867 static void RemoveFromObjectMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList)
9868   nonnull(1) nonnull(2);
9869 
9870 static void
RemoveFromObjectMixinsOf(Tcl_Command cmd,NsfCmdList * cmdList)9871 RemoveFromObjectMixinsOf(Tcl_Command cmd, NsfCmdList *cmdList) {
9872 
9873   nonnull_assert(cmd != NULL);
9874   nonnull_assert(cmdList != NULL);
9875 
9876   do {
9877     const NsfClass *class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
9878     NsfClassOpt    *clopt = (class != NULL) ? class->opt : NULL;
9879 
9880     if (clopt != NULL) {
9881       NsfCmdList *del = CmdListFindCmdInList(cmd, clopt->isObjectMixinOf);
9882 
9883       if (del != NULL) {
9884         /* fprintf(stderr, "Removing object %s from isObjectMixinOf of Class %s\n",
9885            ObjectName(object), ObjStr(NsfGetClassFromCmdPtr(cmdList->cmdPtr)->object.cmdName)); */
9886         del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del);
9887         CmdListDeleteCmdListEntry(del, GuardDel);
9888       }
9889     } /* else fprintf(stderr, "CleanupDestroyObject %s: NULL pointer in mixins!\n", ObjectName(object)); */
9890     cmdList = cmdList->nextPtr;
9891   } while(likely(cmdList != NULL));
9892 }
9893 
9894 /*
9895  *----------------------------------------------------------------------
9896  * RemoveFromClassmixins --
9897  *
9898  *    Remove the class (provided as a cmd) from all class mixins lists
9899  *    from the provided classes (provided as cmdList).
9900  *
9901  * Results:
9902  *    void
9903  *
9904  * Side effects:
9905  *    Deletes potentially some entries in the class mixins lists.
9906  *
9907  *----------------------------------------------------------------------
9908  */
9909 
9910 static void RemoveFromClassmixins(Tcl_Command cmd, NsfCmdList *cmdList)
9911   nonnull(1) nonnull(2);
9912 
9913 static void
RemoveFromClassmixins(Tcl_Command cmd,NsfCmdList * cmdList)9914 RemoveFromClassmixins(Tcl_Command cmd, NsfCmdList *cmdList) {
9915 
9916   nonnull_assert(cmd != NULL);
9917   nonnull_assert(cmdList != NULL);
9918 
9919   do {
9920     NsfClass    *class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
9921     NsfClassOpt *clopt = (class != NULL) ? class->opt : NULL;
9922 
9923     if (clopt != NULL) {
9924       NsfCmdList *del = CmdListFindCmdInList(cmd, clopt->classMixins);
9925 
9926       if (del != NULL) {
9927         /* fprintf(stderr, "Removing class %s from mixins of object %s\n",
9928            ClassName(class), ObjStr(NsfGetObjectFromCmdPtr(cmdList->cmdPtr)->cmdName)); */
9929         del = CmdListRemoveFromList(&clopt->classMixins, del);
9930         CmdListDeleteCmdListEntry(del, GuardDel);
9931         if (class->object.mixinOrder != NULL) {
9932           MixinResetOrder(&class->object);
9933         }
9934       }
9935     }
9936     cmdList = cmdList->nextPtr;
9937   } while (likely(cmdList != NULL));
9938 }
9939 
9940 /*
9941  *----------------------------------------------------------------------
9942  * RemoveFromObjectMixins --
9943  *
9944  *    Remove the class (provided as a cmd) from all object mixin lists
9945  *    from the provided classes (provided as cmdList).
9946  *
9947  * Results:
9948  *    void
9949  *
9950  * Side effects:
9951  *    Deletes potentially some entries in the object mixins lists.
9952  *
9953  *----------------------------------------------------------------------
9954  */
9955 static void RemoveFromObjectMixins(Tcl_Command cmd, NsfCmdList *cmdList)
9956   nonnull(1) nonnull(2);
9957 
9958 static void
RemoveFromObjectMixins(Tcl_Command cmd,NsfCmdList * cmdList)9959 RemoveFromObjectMixins(Tcl_Command cmd, NsfCmdList *cmdList) {
9960 
9961   nonnull_assert(cmd != NULL);
9962   nonnull_assert(cmdList != NULL);
9963 
9964   do {
9965     NsfObject    *object = NsfGetObjectFromCmdPtr(cmdList->cmdPtr);
9966     NsfObjectOpt *objopt = (object != 0) ? object->opt : NULL;
9967 
9968     if (objopt != NULL) {
9969       NsfCmdList *del = CmdListFindCmdInList(cmd, objopt->objMixins);
9970 
9971       if (del != NULL) {
9972         /* fprintf(stderr, "Removing class %s from mixins of object %s\n",
9973            ClassName(del->clorobj), ObjStr(NsfGetObjectFromCmdPtr(cmdList->cmdPtr)->cmdName)); */
9974         del = CmdListRemoveFromList(&objopt->objMixins, del);
9975         CmdListDeleteCmdListEntry(del, GuardDel);
9976         if (object->mixinOrder != NULL) {
9977           MixinResetOrder(object);
9978         }
9979       }
9980     }
9981     cmdList = cmdList->nextPtr;
9982   } while (likely(cmdList != NULL));
9983 }
9984 
9985 
9986 /*
9987  *----------------------------------------------------------------------
9988  * ResetOrderOfObjectsUsingThisClassAsObjectMixin --
9989  *
9990  *    Reset the per-object mixin order for all objects having this class as
9991  *    per-object mixin.
9992  *
9993  * Results:
9994  *    void
9995  *
9996  * Side effects:
9997  *    Deletes potentially the mixin list for the objects.
9998  *
9999  *----------------------------------------------------------------------
10000  */
10001 static void ResetOrderOfObjectsUsingThisClassAsObjectMixin(const NsfClass *class)
10002   nonnull(1);
10003 
10004 static void
ResetOrderOfObjectsUsingThisClassAsObjectMixin(const NsfClass * class)10005 ResetOrderOfObjectsUsingThisClassAsObjectMixin(const NsfClass *class) {
10006 
10007   /*fprintf(stderr, "ResetOrderOfObjectsUsingThisClassAsObjectMixin %s - %p\n",
10008     ClassName(class), class->opt);*/
10009 
10010   nonnull_assert(class != NULL);
10011 
10012   if (class->opt != NULL) {
10013     const NsfCmdList *ml;
10014 
10015     for (ml = class->opt->isObjectMixinOf; ml != NULL; ml = ml->nextPtr) {
10016       NsfObject *object = NsfGetObjectFromCmdPtr(ml->cmdPtr);
10017 
10018       if (object != NULL) {
10019         if (object->mixinOrder != NULL) {
10020           MixinResetOrder(object);
10021         }
10022         object->flags &= ~NSF_MIXIN_ORDER_VALID;
10023       }
10024     }
10025   }
10026 }
10027 
10028 /*
10029  *----------------------------------------------------------------------
10030  * MixinInvalidateObjOrders --
10031  *
10032  *    Reset mixin order for all instances of the class and the instances of
10033  *    its dependent subclasses. This function is typically called, when the
10034  *    the class hierarchy or the class mixins have changed and invalidate
10035  *    mixin entries in all dependent instances.
10036  *
10037  * Results:
10038  *    void
10039  *
10040  * Side effects:
10041  *    Deletes potentially the mixin list for the objects and classes.
10042  *
10043  *----------------------------------------------------------------------
10044  */
10045 
10046 static void MixinInvalidateObjOrders(NsfClasses *subClasses)
10047   nonnull(1);
10048 
10049 static void
MixinInvalidateObjOrders(NsfClasses * subClasses)10050 MixinInvalidateObjOrders(NsfClasses *subClasses) {
10051 
10052   nonnull_assert(subClasses != NULL);
10053 
10054   /*
10055    * Iterate over the subclass hierarchy.
10056    */
10057   do {
10058     Tcl_HashSearch       hSrch;
10059     const Tcl_HashEntry *hPtr;
10060     Tcl_HashTable       *instanceTablePtr;
10061 
10062     /*
10063      * Reset mixin order for all objects having this class as per object mixin
10064      */
10065     ResetOrderOfObjectsUsingThisClassAsObjectMixin(subClasses->cl);
10066 
10067     if (subClasses->cl->parsedParamPtr != NULL) {
10068       ParsedParamFree(subClasses->cl->parsedParamPtr);
10069       subClasses->cl->parsedParamPtr = NULL;
10070     }
10071 
10072     instanceTablePtr = &subClasses->cl->instances;
10073     for (hPtr = Tcl_FirstHashEntry(instanceTablePtr, &hSrch);
10074          hPtr != NULL;
10075          hPtr = Tcl_NextHashEntry(&hSrch)) {
10076       NsfObject *object = (NsfObject *)Tcl_GetHashKey(instanceTablePtr, hPtr);
10077 
10078       assert(object != NULL);
10079 
10080       if (likely((object->flags & NSF_DURING_DELETE) == 0u)
10081           && ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u)
10082           ) {
10083         MixinResetOrder(object);
10084         object->flags &= ~NSF_MIXIN_ORDER_VALID;
10085       }
10086     }
10087     subClasses = subClasses->nextPtr;
10088   } while (subClasses != NULL);
10089 
10090 }
10091 
10092 /*
10093  *----------------------------------------------------------------------
10094  * MixinComputeDefined --
10095  *
10096  *    This function computes the mixin order for the provided object and
10097  *    adjusts the mixin flags accordingly. The mixin order is either
10098  *
10099  *       DEFINED (there are mixins on the instance),
10100  *       NONE    (there are no mixins for the instance),
10101  *       or INVALID (a class restructuring has occurred.
10102  *                  It is not clear whether mixins are defined or not).
10103  *
10104  *    If the mixin order is INVALID, MixinComputeDefined can be used to
10105  *    compute the order and set the instance to DEFINED or NONE
10106  *
10107  * Results:
10108  *    void
10109  *
10110  * Side effects:
10111  *    Might alter the mixin order.
10112  *
10113  *----------------------------------------------------------------------
10114  */
10115 static void
MixinComputeDefined(Tcl_Interp * interp,NsfObject * object)10116 MixinComputeDefined(Tcl_Interp *interp, NsfObject *object) {
10117 
10118   nonnull_assert(interp != NULL);
10119   nonnull_assert(object != NULL);
10120 
10121   MixinComputeOrder(interp, object);
10122   object->flags |= NSF_MIXIN_ORDER_VALID;
10123   if (object->mixinOrder != NULL) {
10124     object->flags |= NSF_MIXIN_ORDER_DEFINED;
10125   } else {
10126     object->flags &= ~NSF_MIXIN_ORDER_DEFINED;
10127   }
10128 }
10129 
10130 /*
10131  *----------------------------------------------------------------------
10132  * ComputePrecedenceList --
10133  *
10134  *    Returns the precedence list for the provided object.  The precedence
10135  *    list can optionally include the mixins and the root-class. If pattern is
10136  *    provided, this is used as well for filtering. The caller has to free the
10137  *    resulting list via NsfClassListFree();
10138  *
10139  * Results:
10140  *    Precedence list in form of a class list, potentially NULL due to filtering.
10141  *
10142  * Side effects:
10143  *    Allocated class list.
10144  *
10145  *----------------------------------------------------------------------
10146  */
10147 
10148 static NsfClasses *ComputePrecedenceList(Tcl_Interp *interp, NsfObject *object,
10149                                          const char *pattern,
10150                                          bool withMixins, bool withRootClass)
10151   nonnull(1) nonnull(2);
10152 
10153 static NsfClasses *
ComputePrecedenceList(Tcl_Interp * interp,NsfObject * object,const char * pattern,bool withMixins,bool withRootClass)10154 ComputePrecedenceList(Tcl_Interp *interp, NsfObject *object,
10155                       const char *pattern,
10156                       bool withMixins, bool withRootClass) {
10157   NsfClasses *precedenceList = NULL, *pcl, **npl = &precedenceList;
10158 
10159   nonnull_assert(interp != NULL);
10160   nonnull_assert(object != NULL);
10161 
10162   if (withMixins) {
10163     if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
10164       MixinComputeDefined(interp, object);
10165     }
10166     if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
10167       NsfCmdList *ml;
10168 
10169       for (ml = object->mixinOrder; ml; ml = ml->nextPtr) {
10170         NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
10171 
10172         if ((pattern != NULL)
10173             && (mixin != NULL)
10174             && !Tcl_StringMatch(ClassName(mixin), pattern)) {
10175           continue;
10176         }
10177         npl = NsfClassListAdd(npl, mixin, NULL);
10178       }
10179     }
10180   }
10181 
10182   pcl = PrecedenceOrder(object->cl);
10183   for (; pcl != NULL; pcl = pcl->nextPtr) {
10184     if (!withRootClass && IsRootClass(pcl->cl)) {
10185       continue;
10186     }
10187     if (pattern != NULL && !Tcl_StringMatch(ClassName(pcl->cl), pattern)) {
10188       continue;
10189     }
10190     npl = NsfClassListAdd(npl, pcl->cl, NULL);
10191   }
10192   return precedenceList;
10193 }
10194 
10195 /*
10196  *----------------------------------------------------------------------
10197  * SeekCurrent --
10198  *
10199  *    Walk through the command list until the provided command is reached.
10200  *    return the next entry. If the provided cmd is NULL, then return the
10201  *    first entry.
10202  *
10203  * Results:
10204  *    Command list pointer or NULL
10205  *
10206  * Side effects:
10207  *    None.
10208  *
10209  *----------------------------------------------------------------------
10210  */
10211 static NsfCmdList *SeekCurrent(const Tcl_Command cmd, register NsfCmdList *cmdListPtr)
10212   nonnull(2) pure;
10213 
10214 static NsfCmdList *
SeekCurrent(const Tcl_Command cmd,register NsfCmdList * cmdListPtr)10215 SeekCurrent(const Tcl_Command cmd, register NsfCmdList *cmdListPtr) {
10216 
10217   nonnull_assert(cmdListPtr != NULL);
10218 
10219   if (cmd != NULL) {
10220     do {
10221       if (cmdListPtr->cmdPtr == cmd) {
10222         return cmdListPtr->nextPtr;
10223       }
10224       cmdListPtr = cmdListPtr->nextPtr;
10225     } while  likely(cmdListPtr != NULL);
10226 
10227     return NULL;
10228   }
10229   return cmdListPtr;
10230 }
10231 
10232 /*
10233  *----------------------------------------------------------------------
10234  * CanInvokeMixinMethod --
10235  *
10236  *    Check, whether the provided cmd is allowed to be dispatch in a mixin.
10237  *
10238  * Results:
10239  *    Tcl result code or NSF_CHECK_FAILED in case, search should continue
10240  *
10241  * Side effects:
10242  *    None.
10243  *
10244  *----------------------------------------------------------------------
10245  */
10246 
10247 static int CanInvokeMixinMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd, NsfCmdList *cmdList)
10248   nonnull(1) nonnull(2) nonnull(4);
10249 
10250 static int
CanInvokeMixinMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Command cmd,NsfCmdList * cmdList)10251 CanInvokeMixinMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd, NsfCmdList *cmdList) {
10252   int result = TCL_OK;
10253   unsigned int cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
10254 
10255   nonnull_assert(interp != NULL);
10256   nonnull_assert(object != NULL);
10257   nonnull_assert(cmdList != NULL);
10258 
10259   if ((cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u ||
10260       ((cmdFlags & NSF_CMD_CLASS_ONLY_METHOD) != 0u && !NsfObjectIsClass(object))) {
10261     /*
10262      * The command is not applicable for objects (i.e. might crash,
10263      * since it expects a class record); therefore skip it
10264      */
10265     return NSF_CHECK_FAILED;
10266   }
10267 
10268   if ((cmdList->clientData != NULL) && !RUNTIME_STATE(interp)->guardCount) {
10269     /*fprintf(stderr, "guard call\n");*/
10270     result = GuardCall(object, interp, (Tcl_Obj *)cmdList->clientData, NULL);
10271   }
10272 
10273   return result;
10274 }
10275 
10276 
10277 /*
10278  *----------------------------------------------------------------------
10279  * MixinSearchProc --
10280  *
10281  *    Search for a method name in the mixin list of the provided
10282  *    object. Depending on the state of the mixin stack, the search starts
10283  *    at the beginning or at the last dispatched, shadowed method on
10284  *    the mixin path.
10285  *
10286  * Results:
10287  *    Tcl result code.
10288  *    Returns as well always cmd (maybe NULL) in cmdPtr.
10289  *    Returns on success as well the class and the currentCmdPointer
10290  *    for continuation in next.
10291  *
10292  * Side effects:
10293  *    None.
10294  *
10295  *----------------------------------------------------------------------
10296  */
10297 static int MixinSearchProc(
10298     Tcl_Interp *interp, NsfObject *object,
10299     const char *methodName,
10300     NsfClass **classPtr, Tcl_Command *currentCmdPtr, Tcl_Command *cmdPtr
10301 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6);
10302 
10303 static int
MixinSearchProc(Tcl_Interp * interp,NsfObject * object,const char * methodName,NsfClass ** classPtr,Tcl_Command * currentCmdPtr,Tcl_Command * cmdPtr)10304 MixinSearchProc(
10305     Tcl_Interp *interp, NsfObject *object,
10306     const char *methodName,
10307     NsfClass **classPtr, Tcl_Command *currentCmdPtr, Tcl_Command *cmdPtr
10308 ) {
10309   Tcl_Command cmd = NULL;
10310   NsfCmdList *cmdList;
10311   NsfClass   *class = NULL;
10312   int         result = TCL_OK;
10313 
10314   nonnull_assert(interp != NULL);
10315   nonnull_assert(object != NULL);
10316   nonnull_assert(methodName != NULL);
10317   nonnull_assert(classPtr != NULL);
10318   nonnull_assert(currentCmdPtr != NULL);
10319   nonnull_assert(cmdPtr != NULL);
10320 
10321   assert(object->mixinStack != NULL);
10322 
10323   /*
10324    * Ensure that the mixin order is valid.
10325    */
10326   assert((object->flags & NSF_MIXIN_ORDER_VALID) != 0u);
10327 
10328   if (object->mixinOrder == NULL) {
10329     return TCL_OK;
10330   }
10331 
10332   cmdList = SeekCurrent(object->mixinStack->currentCmdPtr, object->mixinOrder);
10333   RUNTIME_STATE(interp)->currentMixinCmdPtr = (cmdList != NULL) ? cmdList->cmdPtr : NULL;
10334 
10335   /*fprintf(stderr, "searching for '%s' in %p\n", methodName, cmdList);
10336   CmdListPrint(interp, "MixinSearch CL = \n", cmdList);*/
10337 
10338   if (unlikely((*classPtr != NULL) && (*cmdPtr != NULL))) {
10339     Tcl_Command lastCmdPtr = NULL;
10340 
10341     /*fprintf(stderr, "... new branch\n");*/
10342 
10343     for (; cmdList != NULL; cmdList = cmdList->nextPtr) {
10344       NsfClass *class1;
10345 
10346       /*
10347        * Ignore deleted commands
10348        */
10349       if (((unsigned int)Tcl_Command_flags(cmdList->cmdPtr) & CMD_IS_DELETED) != 0u) {
10350         continue;
10351       }
10352 
10353       class1 = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
10354       assert(class1 != NULL);
10355       lastCmdPtr = cmdList->cmdPtr;
10356 
10357       if (class1 == *classPtr) {
10358         /*
10359          * The wanted class was found. Check guards and permissions to
10360          * determine whether we can invoke this method.
10361          */
10362         result = CanInvokeMixinMethod(interp, object, *cmdPtr, cmdList);
10363 
10364         if (likely(result == TCL_OK)) {
10365           class = class1;
10366         } else if (result == NSF_CHECK_FAILED) {
10367           result = TCL_OK;
10368         }
10369         /*
10370          * No matter, what the result is, stop the search through the mixin
10371          * classes here.
10372          */
10373         break;
10374       }
10375     }
10376 
10377     if (class != NULL) {
10378       assert(cmdList != NULL);
10379       /*
10380        * On success: return class and cmdList->cmdPtr;
10381        */
10382       *currentCmdPtr = cmdList->cmdPtr;
10383       /*fprintf(stderr, "... mixinsearch success returns %p (class %s)\n", cmd, ClassName(class));*/
10384 
10385     } else {
10386       /*
10387        * We did not find the absolute entry in the mixins.  Set the
10388        * currentCmdPtr (on the mixin stack) to the last entry to flag, that
10389        * the mixin list should not started again on a next.
10390        */
10391       *cmdPtr = NULL;
10392       *currentCmdPtr = lastCmdPtr;
10393       /*fprintf(stderr, "... mixinsearch success failure %p (class %s)\n", cmd, ClassName(class));*/
10394     }
10395 
10396     return result;
10397 
10398   } else {
10399 
10400     for (; cmdList; cmdList = cmdList->nextPtr) {
10401       /*
10402        * Ignore deleted commands
10403        */
10404       if (((unsigned int)Tcl_Command_flags(cmdList->cmdPtr) & CMD_IS_DELETED) != 0u) {
10405         continue;
10406       }
10407       class = NsfGetClassFromCmdPtr(cmdList->cmdPtr);
10408       assert(class != NULL);
10409       /*
10410         fprintf(stderr, "+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n",
10411         ObjectName(object), methodName, cmdList,
10412         cmdList->cmdPtr, cmdList->clientData);
10413       */
10414       cmd = FindMethod(class->nsPtr, methodName);
10415       if (cmd == NULL) {
10416         continue;
10417       }
10418 
10419       result = CanInvokeMixinMethod(interp, object, cmd, cmdList);
10420 
10421       if (unlikely(result == TCL_ERROR)) {
10422         return result;
10423       } else if (result == NSF_CHECK_FAILED) {
10424         result = TCL_OK;
10425         cmd = NULL;
10426         continue;
10427       }
10428 
10429       /*
10430        * cmd was found and is applicable. We return class and cmdPtr.
10431        */
10432       *classPtr = class;
10433       *currentCmdPtr = cmdList->cmdPtr;
10434       /*fprintf(stderr, "mixinsearch returns %p (cl %s)\n", cmd, ClassName(class));*/
10435       break;
10436     }
10437 
10438   }
10439   *cmdPtr = cmd;
10440   return result;
10441 }
10442 
10443 /*
10444  * info option for mixins and class mixins
10445  */
10446 static int MixinInfo(
10447     Tcl_Interp *interp, const NsfCmdList *m, const char *pattern,
10448     bool withGuards, const NsfObject *matchObject
10449 ) nonnull(1);
10450 
10451 static int
MixinInfo(Tcl_Interp * interp,const NsfCmdList * m,const char * pattern,bool withGuards,const NsfObject * matchObject)10452 MixinInfo(
10453     Tcl_Interp *interp, const NsfCmdList *m, const char *pattern,
10454     bool withGuards, const NsfObject *matchObject
10455 ) {
10456   Tcl_Obj *list = Tcl_NewListObj(0, NULL);
10457 
10458   nonnull_assert(interp != NULL);
10459 
10460   /*fprintf(stderr, "   mixin info m=%p, pattern %s, matchObject %p\n",
10461     m, pattern, matchObject);*/
10462 
10463   while (m != NULL) {
10464     const NsfClass *mixinClass = NsfGetClassFromCmdPtr(m->cmdPtr);
10465 
10466     /* fprintf(stderr, "   mixin info m=%p, next=%p, pattern %s, matchObject %p\n",
10467        m, m->next, pattern, matchObject);*/
10468 
10469     if (mixinClass != NULL &&
10470         (pattern == NULL
10471          || (matchObject != NULL && &(mixinClass->object) == matchObject)
10472          || (matchObject == NULL && Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern)))) {
10473       if (withGuards && (m->clientData != NULL)) {
10474         Tcl_Obj *l = Tcl_NewListObj(0, NULL);
10475         Tcl_Obj *g = (Tcl_Obj *) m->clientData;
10476 
10477         Tcl_ListObjAppendElement(interp, l, mixinClass->object.cmdName);
10478         Tcl_ListObjAppendElement(interp, l, NsfGlobalObjs[NSF_GUARD_OPTION]);
10479         Tcl_ListObjAppendElement(interp, l, g);
10480         Tcl_ListObjAppendElement(interp, list, l);
10481       } else {
10482         Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName);
10483       }
10484       if (matchObject != NULL) {
10485         break;
10486       }
10487     }
10488     m = m->nextPtr;
10489   }
10490 
10491   Tcl_SetObjResult(interp, list);
10492   return TCL_OK;
10493 }
10494 
10495 /*
10496  * info option for mixinofs and isClassMixinOf
10497  */
10498 
10499 static Tcl_Command MixinSearchMethodByName(NsfCmdList *mixinList, const char *name, NsfClass **classPtr)
10500   nonnull(1) nonnull(2) nonnull(3);
10501 
10502 static Tcl_Command
MixinSearchMethodByName(NsfCmdList * mixinList,const char * name,NsfClass ** classPtr)10503 MixinSearchMethodByName(NsfCmdList *mixinList, const char *name, NsfClass **classPtr) {
10504   Tcl_Command cmd;
10505 
10506   nonnull_assert(mixinList != NULL);
10507   nonnull_assert(name != NULL);
10508   nonnull_assert(classPtr != NULL);
10509 
10510   do {
10511     NsfClass *foundClass = NsfGetClassFromCmdPtr(mixinList->cmdPtr);
10512 
10513     if ((foundClass != NULL) && SearchCMethod(foundClass, name, &cmd)) {
10514       *classPtr = foundClass;
10515       return cmd;
10516     }
10517     mixinList = mixinList->nextPtr;
10518   } while (mixinList != NULL);
10519 
10520   return NULL;
10521 }
10522 
10523 
10524 /*
10525  *  Filter-Commands
10526  */
10527 
10528 /*
10529  * The search method implements filter search order for object and
10530  * class filter: first a given name is interpreted as fully qualified
10531  * method name. If no method is found, a proc is searched with fully
10532  * name. Otherwise the simple name is searched on the heritage order:
10533  * object (only for per-object filters), class, metaclass
10534  */
10535 
10536 static Tcl_Command FilterSearch(const char *name, NsfObject *startingObject,
10537              NsfClass *startingClass, NsfClass **classPtr)
10538   nonnull(1) nonnull(4);
10539 
10540 static Tcl_Command
FilterSearch(const char * name,NsfObject * startingObject,NsfClass * startingClass,NsfClass ** classPtr)10541 FilterSearch(const char *name, NsfObject *startingObject,
10542              NsfClass *startingClass, NsfClass **classPtr) {
10543   Tcl_Command cmd = NULL;
10544 
10545   nonnull_assert(name != NULL);
10546   nonnull_assert(classPtr != NULL);
10547 
10548   if (startingObject != NULL) {
10549     NsfObjectOpt *opt = startingObject->opt;
10550     /*
10551      * the object-specific filter can also be defined on the object's
10552      * class, its hierarchy, or the respective class mixins; thus use the
10553      * object's class as start point for the class-specific search then ...
10554      */
10555     startingClass = startingObject->cl;
10556 
10557     /*
10558      * search for filters on object mixins
10559      */
10560     if (opt != NULL
10561         && opt->objMixins != NULL
10562         && (cmd = MixinSearchMethodByName(opt->objMixins, name, classPtr))
10563        ) {
10564       return cmd;
10565     }
10566   }
10567 
10568   /*
10569    * Search for class filters on class mixins
10570    */
10571   if (startingClass != NULL) {
10572     NsfClassOpt *opt = startingClass->opt;
10573     if (opt != NULL && opt->classMixins != NULL) {
10574       if ((cmd = MixinSearchMethodByName(opt->classMixins, name, classPtr))) {
10575         return cmd;
10576       }
10577     }
10578   }
10579 
10580   /*
10581    * Search for object procs that are used as filters
10582    */
10583   if ((startingObject != NULL) && (startingObject->nsPtr != NULL)) {
10584     /*fprintf(stderr, "search filter %s as proc \n", name);*/
10585     if ((cmd = FindMethod(startingObject->nsPtr, name))) {
10586       *classPtr = (NsfClass *)startingObject;
10587       return cmd;
10588     }
10589   }
10590 
10591   /*
10592    * Ok, no filter on obj or mixins -> search class
10593    */
10594   if (startingClass != NULL) {
10595     *classPtr = SearchCMethod(startingClass, name, &cmd);
10596     if (*classPtr == NULL) {
10597       /*
10598        * If no filter is found yet -> search the metaclass
10599        */
10600       *classPtr = SearchCMethod(startingClass->object.cl, name, &cmd);
10601     }
10602   }
10603   return cmd;
10604 }
10605 
10606 /*
10607  * Filter Guards
10608  */
10609 
10610 /*
10611  *----------------------------------------------------------------------
10612  * GuardCheck --
10613  *
10614  *    Check, a filter guard
10615  *
10616  * Results:
10617  *    Tcl result code or NSF_CHECK_FAILED in case, search should continue
10618  *
10619  * Side effects:
10620  *    None.
10621  *
10622  *----------------------------------------------------------------------
10623  */
10624 
10625 static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObj)
10626   nonnull(1) nonnull(2);
10627 
10628 static int
GuardCheck(Tcl_Interp * interp,Tcl_Obj * guardObj)10629 GuardCheck(Tcl_Interp *interp, Tcl_Obj *guardObj) {
10630   NsfRuntimeState *rst;
10631   int              result;
10632 
10633   nonnull_assert(interp != NULL);
10634   nonnull_assert(guardObj != NULL);
10635 
10636   /*
10637    * if there are more than one filter guard for this filter
10638    * (i.e. they are inherited), then they are OR combined
10639    * -> if one check succeeds => return 1
10640    */
10641 
10642   /*fprintf(stderr, "checking guard **%s**\n", ObjStr(guardObj));*/
10643   rst = RUNTIME_STATE(interp);
10644   rst->guardCount++;
10645   result = CheckConditionInScope(interp, guardObj);
10646   rst->guardCount--;
10647 
10648   /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", ObjStr(guardObj), rc);*/
10649 
10650   if (likely(result == TCL_OK)) {
10651     /* fprintf(stderr, " +++ OK\n"); */
10652 
10653   } else if (unlikely(result == TCL_ERROR)) {
10654     Tcl_Obj *sr = Tcl_GetObjResult(interp);
10655 
10656     INCR_REF_COUNT(sr);
10657     NsfPrintError(interp, "Guard error: '%s'\n%s", ObjStr(guardObj), ObjStr(sr));
10658     DECR_REF_COUNT(sr);
10659 
10660   } else {
10661     /*
10662       fprintf(stderr, " +++ FAILED\n");
10663     */
10664     result = NSF_CHECK_FAILED;
10665   }
10666   return result;
10667 }
10668 
10669 /*
10670   static void
10671   GuardPrint(Tcl_Interp *interp, ClientData clientData) {
10672   Tcl_Obj *guardObj = (Tcl_Obj *) clientData;
10673   fprintf(stderr, " +++ <GUARDS> \n");
10674   if (guardObj != NULL) {
10675   fprintf(stderr, "   *     %s \n", ObjStr(guardObj));
10676   }
10677   fprintf(stderr, " +++ </GUARDS>\n");
10678   }
10679 */
10680 
10681 static void
GuardDel(NsfCmdList * guardList)10682 GuardDel(NsfCmdList *guardList) {
10683 
10684   nonnull_assert(guardList != NULL);
10685 
10686   /*fprintf(stderr, "GuardDel %p clientData = %p\n",
10687     guardList, (guardList != NULL) ? guardList->clientData : NULL);*/
10688 
10689   if (guardList->clientData != NULL) {
10690     DECR_REF_COUNT2("guardObj", (Tcl_Obj *)guardList->clientData);
10691     guardList->clientData = NULL;
10692   }
10693 }
10694 
10695 NSF_INLINE static void
GuardAdd(NsfCmdList * guardList,Tcl_Obj * guardObj)10696 GuardAdd(NsfCmdList *guardList, Tcl_Obj *guardObj) {
10697 
10698   nonnull_assert(guardList != NULL);
10699   nonnull_assert(guardObj != NULL);
10700 
10701   GuardDel(guardList);
10702   if (strlen(ObjStr(guardObj)) > 0) {
10703     INCR_REF_COUNT2("guardObj", guardObj);
10704     guardList->clientData = guardObj;
10705     /*fprintf(stderr, "guard added to %p cmdPtr=%p, clientData= %p\n",
10706       guardList, guardList->cmdPtr, guardList->clientData);
10707     */
10708   }
10709 }
10710 
10711 static int
GuardCall(NsfObject * object,Tcl_Interp * interp,Tcl_Obj * guardObj,NsfCallStackContent * cscPtr)10712 GuardCall(NsfObject *object, Tcl_Interp *interp, Tcl_Obj *guardObj, NsfCallStackContent *cscPtr) {
10713   int result = TCL_OK;
10714   Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */
10715   CallFrame frame, *framePtr = &frame;
10716 
10717   nonnull_assert(object != NULL);
10718   nonnull_assert(interp != NULL);
10719   nonnull_assert(guardObj != NULL);
10720 
10721   INCR_REF_COUNT(res);
10722 
10723   /*
10724    * For the guard push a fake call-frame on the Tcl stack so that
10725    * e.g. a "self calledproc" and other methods in the guard behave
10726    * like in the proc.
10727    */
10728   if (cscPtr != NULL) {
10729     Nsf_PushFrameCsc(interp, cscPtr, framePtr);
10730   } else {
10731     Nsf_PushFrameObj(interp, object, framePtr);
10732   }
10733   result = GuardCheck(interp, guardObj);
10734 
10735   if (cscPtr != NULL) {
10736     Nsf_PopFrameCsc(interp, framePtr);
10737   } else {
10738     Nsf_PopFrameObj(interp, framePtr);
10739   }
10740 
10741   if (result != TCL_ERROR) {
10742     Tcl_SetObjResult(interp, res);  /* restore the result */
10743   }
10744 
10745   DECR_REF_COUNT(res);
10746   return result;
10747 }
10748 
10749 /*
10750  *----------------------------------------------------------------------
10751  * GuardAddFromDefinitionList --
10752  *
10753  *    Add a guard to the specified destination list (first arg) from a list of
10754  *    definitions (last arg).  If the provided cmd is found in the list of
10755  *    definitions, it is added to the destination list if it has non-null
10756  *    client data.
10757  *
10758  * Results:
10759  *    Returns Boolean value depending on whether the cmd is part of the
10760  *    definition list.
10761  *
10762  * Side effects:
10763  *    None.
10764  *
10765  *----------------------------------------------------------------------
10766  */
10767 static bool GuardAddFromDefinitionList(NsfCmdList *dest, Tcl_Command interceptorCmd,
10768                                       NsfCmdList *interceptorDefList)
10769   nonnull(1) nonnull(2) nonnull(3);
10770 
10771 static bool
GuardAddFromDefinitionList(NsfCmdList * dest,Tcl_Command interceptorCmd,NsfCmdList * interceptorDefList)10772 GuardAddFromDefinitionList(NsfCmdList *dest, Tcl_Command interceptorCmd,
10773                            NsfCmdList *interceptorDefList) {
10774   NsfCmdList *h;
10775 
10776   nonnull_assert(interceptorCmd != NULL);
10777   nonnull_assert(dest != NULL);
10778   nonnull_assert(interceptorDefList != NULL);
10779 
10780   h = CmdListFindCmdInList(interceptorCmd, interceptorDefList);
10781   if (h != NULL) {
10782     if (h->clientData != NULL) {
10783       GuardAdd(dest, (Tcl_Obj *) h->clientData);
10784     }
10785     return NSF_TRUE;
10786   }
10787 
10788   return NSF_FALSE;
10789 }
10790 
10791 /*
10792  *----------------------------------------------------------------------
10793  * GuardAddInheritedGuards --
10794  *
10795  *    Add a inherited guards to the provided destination list.
10796  *
10797  * Results:
10798  *    None.
10799  *
10800  * Side effects:
10801  *    Updates potentially destination list
10802  *
10803  *----------------------------------------------------------------------
10804  */
10805 static void GuardAddInheritedGuards(Tcl_Interp *interp, NsfCmdList *dest,
10806                                     NsfObject *object, Tcl_Command filterCmd)
10807   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
10808 
10809 static void
GuardAddInheritedGuards(Tcl_Interp * interp,NsfCmdList * dest,NsfObject * object,Tcl_Command filterCmd)10810 GuardAddInheritedGuards(Tcl_Interp *interp, NsfCmdList *dest,
10811                         NsfObject *object, Tcl_Command filterCmd) {
10812   NsfClasses   *pl;
10813   bool          guardAdded = NSF_FALSE;
10814   NsfObjectOpt *opt;
10815 
10816   nonnull_assert(filterCmd != NULL);
10817   nonnull_assert(interp != NULL);
10818   nonnull_assert(dest != NULL);
10819   nonnull_assert(object != NULL);
10820 
10821   /*
10822    * Search guards for class filters registered on mixins.
10823    */
10824   if (((object->flags & NSF_MIXIN_ORDER_VALID)) == 0u) {
10825     MixinComputeDefined(interp, object);
10826   }
10827   if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
10828     NsfCmdList *ml;
10829 
10830     for (ml = object->mixinOrder; ml != NULL && !guardAdded; ml = ml->nextPtr) {
10831       NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
10832 
10833       if (mixin != NULL && mixin->opt != NULL && mixin->opt->classFilters != NULL) {
10834         guardAdded = GuardAddFromDefinitionList(dest, filterCmd, mixin->opt->classFilters);
10835       }
10836     }
10837   }
10838 
10839   /*
10840    * Search per-object filters.
10841    */
10842   opt = object->opt;
10843   if (!guardAdded && (opt != NULL) && (opt->objFilters != NULL)) {
10844     guardAdded = GuardAddFromDefinitionList(dest, filterCmd, opt->objFilters);
10845   }
10846 
10847   if (!guardAdded) {
10848     /*
10849      * Search per-class filters.
10850      */
10851     for (pl = PrecedenceOrder(object->cl); !guardAdded && (pl != NULL); pl = pl->nextPtr) {
10852       NsfClassOpt *clopt = pl->cl->opt;
10853       if (clopt != NULL && clopt->classFilters != NULL) {
10854         guardAdded = GuardAddFromDefinitionList(dest, filterCmd, clopt->classFilters);
10855       }
10856     }
10857 
10858     /*
10859      * if this is not a registered filter, it is an inherited filter, like:
10860      *   Class create A
10861      *   A method f ...
10862      *   Class create B -superclass A
10863      *   B method {{f {<guard>}}}
10864      *   B filter f
10865      * -> get the guard from the filter that inherits it (here B->f)
10866      */
10867     if (!guardAdded) {
10868       NsfCmdList *registeredFilter =
10869         CmdListFindNameInList(interp, (char *) Tcl_GetCommandName(interp, filterCmd),
10870                               object->filterOrder);
10871       if (registeredFilter && registeredFilter->clientData) {
10872         GuardAdd(dest, (Tcl_Obj *) registeredFilter->clientData);
10873       }
10874     }
10875   }
10876 }
10877 
10878 /*
10879  *----------------------------------------------------------------------
10880  * GuardList --
10881  *
10882  *    Set interp result to a named guard in the provided guardList. The
10883  *    variable "guardList" might be NULL.
10884  *
10885  * Results:
10886  *    interp result
10887  *
10888  * Side effects:
10889  *    None.
10890  *
10891  *----------------------------------------------------------------------
10892  */
10893 static int GuardList(Tcl_Interp *interp, NsfCmdList *guardList, const char *interceptorName)
10894   nonnull(1) nonnull(3);
10895 
10896 static int
GuardList(Tcl_Interp * interp,NsfCmdList * guardList,const char * interceptorName)10897 GuardList(Tcl_Interp *interp, NsfCmdList *guardList, const char *interceptorName) {
10898 
10899   nonnull_assert(interp != NULL);
10900   nonnull_assert(interceptorName != NULL);
10901 
10902   if (guardList != NULL) {
10903     /*
10904      * Try to find simple name first.
10905      */
10906     NsfCmdList *h = CmdListFindNameInList(interp, interceptorName, guardList);
10907     if (h == NULL) {
10908       /*
10909        * Maybe it is a qualified name.
10910        */
10911       Tcl_Command cmd = NSFindCommand(interp, interceptorName);
10912       if (cmd != NULL) {
10913         h = CmdListFindCmdInList(cmd, guardList);
10914       }
10915     }
10916     if (h != NULL) {
10917       Tcl_ResetResult(interp);
10918       if (h->clientData != NULL) {
10919         Tcl_Obj *g = (Tcl_Obj *) h->clientData;
10920         Tcl_SetObjResult(interp, g);
10921       }
10922       return TCL_OK;
10923     }
10924   }
10925   return NsfPrintError(interp, "info guard: can't find filter/mixin %s", interceptorName);
10926 }
10927 
10928 /*
10929  *----------------------------------------------------------------------
10930  * FilterAddActive --
10931  *
10932  *    Add a method name to the set of methods, which were used as filters in
10933  *    the current interp.
10934  *
10935  *    TODO: let the set shrink, when filters are removed.
10936  *
10937  * Results:
10938  *    None.
10939  *
10940  * Side effects:
10941  *    Adding or updating of a hash entry
10942  *
10943  *----------------------------------------------------------------------
10944  */
10945 static void FilterAddActive(Tcl_Interp *interp, const char *methodName)
10946   nonnull(1) nonnull(2);
10947 
10948 static void
FilterAddActive(Tcl_Interp * interp,const char * methodName)10949 FilterAddActive(Tcl_Interp *interp, const char *methodName) {
10950   Tcl_HashEntry *hPtr;
10951   int            newItem;
10952 
10953   nonnull_assert(interp != NULL);
10954   nonnull_assert(methodName != NULL);
10955 
10956   hPtr = Tcl_CreateHashEntry(&RUNTIME_STATE(interp)->activeFilterTablePtr, methodName, &newItem);
10957   if (newItem != 0) {
10958     Tcl_SetHashValue(hPtr, INT2PTR(1));
10959   } else {
10960     int count = PTR2INT(Tcl_GetHashValue(hPtr));
10961     Tcl_SetHashValue(hPtr, INT2PTR(count+1));
10962   }
10963 }
10964 
10965 /*
10966  *----------------------------------------------------------------------
10967  * FilterIsActive --
10968  *
10969  *    Check, whether a method name is in the set of methods, which were used as
10970  *    filters in the current interp.
10971  *
10972  * Results:
10973  *    Boolean
10974  *
10975  * Side effects:
10976  *    none
10977  *
10978  *----------------------------------------------------------------------
10979  */
10980 static bool FilterIsActive(Tcl_Interp *interp, const char *methodName)
10981   nonnull(1) nonnull(2);
10982 
10983 static bool
FilterIsActive(Tcl_Interp * interp,const char * methodName)10984 FilterIsActive(Tcl_Interp *interp, const char *methodName) {
10985   const Tcl_HashEntry *hPtr;
10986 
10987   nonnull_assert(interp != NULL);
10988   nonnull_assert(methodName != NULL);
10989 
10990   hPtr = Tcl_CreateHashEntry(&RUNTIME_STATE(interp)->activeFilterTablePtr, methodName, NULL);
10991   return (hPtr != NULL);
10992 }
10993 
10994 /*
10995  *----------------------------------------------------------------------
10996  * FiltersDefined --
10997  *
10998  *    Return the number of defined distinct names of filters.
10999  *
11000  * Results:
11001  *    Positive number.
11002  *
11003  * Side effects:
11004  *    none.
11005  *
11006  *----------------------------------------------------------------------
11007  */
11008 static int FiltersDefined(Tcl_Interp *interp)
11009   nonnull(1) pure;
11010 
11011 static int
FiltersDefined(Tcl_Interp * interp)11012 FiltersDefined(Tcl_Interp *interp) {
11013 
11014   nonnull_assert(interp != NULL);
11015 
11016   return Tcl_HashSize(&RUNTIME_STATE(interp)->activeFilterTablePtr);
11017 }
11018 
11019 
11020 /*
11021  *----------------------------------------------------------------------
11022  * FilterAdd --
11023  *
11024  *    Append a filter command to the 'filterList' of an obj/class
11025  *
11026  * Results:
11027  *    Standard Tcl result
11028  *
11029  * Side effects:
11030  *    Modifies interp result in error situations.
11031  *
11032  *----------------------------------------------------------------------
11033  */
11034 static int FilterAdd(Tcl_Interp *interp, NsfCmdList **filterList, Tcl_Obj *filterregObj,
11035                      NsfObject *startingObject, NsfClass *startingClass)
11036   nonnull(1) nonnull(2) nonnull(3);
11037 
11038 static int
FilterAdd(Tcl_Interp * interp,NsfCmdList ** filterList,Tcl_Obj * filterregObj,NsfObject * startingObject,NsfClass * startingClass)11039 FilterAdd(Tcl_Interp *interp, NsfCmdList **filterList, Tcl_Obj *filterregObj,
11040           NsfObject *startingObject, NsfClass *startingClass) {
11041   Tcl_Obj     *filterObj = NULL;
11042   Tcl_Obj     *guardObj = NULL;
11043   Tcl_Command  cmd;
11044   NsfClass    *class;
11045   int          result = TCL_OK;
11046 
11047   nonnull_assert(interp != NULL);
11048   nonnull_assert(filterList != NULL);
11049   nonnull_assert(filterregObj != NULL);
11050 
11051   /*
11052    * When the provided nameObj is of type NsfFilterregObjType, the nsf specific
11053    * converter was called already; otherwise call the converter here.
11054    */
11055   if (filterregObj->typePtr != &NsfFilterregObjType) {
11056     /*fprintf(stderr, "FilterAdd: convert %s in FilterAdd\n", ObjStr(filterregObj));*/
11057     if (Tcl_ConvertToType(interp, filterregObj, &NsfFilterregObjType) != TCL_OK) {
11058       result = TCL_ERROR;
11059     }
11060   } else {
11061     /*fprintf(stderr, "FilterAdd: %s already converted\n", ObjStr(filterregObj));*/
11062   }
11063 
11064   if (result == TCL_OK) {
11065     result = NsfFilterregGet(interp, filterregObj, &filterObj, &guardObj);
11066 
11067     if (result == TCL_OK) {
11068       const char *filterName = ObjStr(filterObj);
11069 
11070       cmd = FilterSearch(filterName, startingObject, startingClass, &class);
11071       if (cmd == NULL) {
11072         if (startingObject != NULL) {
11073           result = NsfPrintError(interp, "object filter: can't find filterproc '%s' on %s ",
11074                                  filterName, ObjectName(startingObject));
11075         } else {
11076           result = NsfPrintError(interp, "class filter: can't find filterproc '%s' on %s ",
11077                                  filterName, ClassName(startingClass));
11078         }
11079         assert(result == TCL_ERROR);
11080       }
11081     }
11082   }
11083 
11084   if (result == TCL_OK) {
11085     NsfCmdList *new;
11086 
11087     /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(nameObj), class);*/
11088 
11089     new = CmdListAdd(filterList, cmd, class,
11090                      /*noDuplicates*/ NSF_TRUE, NSF_TRUE);
11091     FilterAddActive(interp, ObjStr(filterObj));
11092 
11093     if (guardObj != NULL) {
11094       GuardAdd(new, guardObj);
11095     } else if (new->clientData != NULL) {
11096       GuardDel(new);
11097     }
11098   }
11099 
11100   return result;
11101 }
11102 
11103 /*
11104  *----------------------------------------------------------------------
11105  * FilterResetOrder --
11106  *
11107  *    Reset the filter order cached in obj->filterOrder
11108  *
11109  * Results:
11110  *    None
11111  *
11112  * Side effects:
11113  *    None
11114  *
11115  *----------------------------------------------------------------------
11116  */
11117 
11118 static void FilterResetOrder(NsfObject *object)
11119   nonnull(1);
11120 
11121 static void
FilterResetOrder(NsfObject * object)11122 FilterResetOrder(NsfObject *object) {
11123 
11124   nonnull_assert(object != NULL);
11125 
11126   CmdListFree(&object->filterOrder, GuardDel);
11127   object->filterOrder = NULL;
11128 }
11129 
11130 /*
11131  *----------------------------------------------------------------------
11132  * FilterSearchAgain --
11133  *
11134  *    Search the filter in the hierarchy again with FilterSearch, e.g.  upon
11135  *    changes in the class hierarchy or mixins that carry the filter command,
11136  *    so that we can be sure it is still reachable.
11137  *
11138  * Results:
11139  *    None
11140  *
11141  * Side effects:
11142  *    None
11143  *
11144  *----------------------------------------------------------------------
11145  */
11146 static void FilterSearchAgain(Tcl_Interp *interp, NsfCmdList **filters,
11147                               NsfObject *startingObject, NsfClass *startingClass)
11148   nonnull(1) nonnull(2);
11149 
11150 static void
FilterSearchAgain(Tcl_Interp * interp,NsfCmdList ** filters,NsfObject * startingObject,NsfClass * startingClass)11151 FilterSearchAgain(Tcl_Interp *interp, NsfCmdList **filters,
11152                   NsfObject *startingObject, NsfClass *startingClass) {
11153   NsfCmdList *cmdList;
11154 
11155   nonnull_assert(interp != NULL);
11156   nonnull_assert(filters != NULL);
11157 
11158   CmdListRemoveDeleted(filters, GuardDel);
11159   cmdList = *filters;
11160 
11161   while (cmdList != NULL) {
11162     NsfCmdList *del = NULL;
11163     NsfClass   *class = NULL;
11164     const char *simpleName = Tcl_GetCommandName(interp, cmdList->cmdPtr);
11165     Tcl_Command cmd = FilterSearch(simpleName, startingObject, startingClass,
11166                                    &class);
11167 
11168     if (cmd == NULL) {
11169       del = CmdListRemoveFromList(filters, cmdList);
11170       /*
11171        * The actual deletion via CmdListDeleteCmdListEntry is deferred to the
11172        * end of the loop block, otherwise for del == cmdList, we risk running
11173        * into an invalid pointer access.
11174        */
11175     } else if (cmd != cmdList->cmdPtr) {
11176       CmdListReplaceCmd(cmdList, cmd, class);
11177     }
11178 
11179     cmdList = cmdList->nextPtr;
11180 
11181     if (del != NULL) {
11182       CmdListDeleteCmdListEntry(del, GuardDel);
11183     }
11184   }
11185 }
11186 
11187 /*
11188  *----------------------------------------------------------------------
11189  * FilterInvalidateObjOrders --
11190  *
11191  *    Invalidate filter entries in all dependent instances. This will be
11192  *    e.g. necessary, when the class hierarchy or the class filters have
11193  *    changed.
11194  *
11195  * Results:
11196  *    None
11197  *
11198  * Side effects:
11199  *    None
11200  *
11201  *----------------------------------------------------------------------
11202  */
11203 static void FilterInvalidateObjOrders(Tcl_Interp *interp, NsfClasses *subClasses)
11204   nonnull(1) nonnull(2);
11205 
11206 static void
FilterInvalidateObjOrders(Tcl_Interp * interp,NsfClasses * subClasses)11207 FilterInvalidateObjOrders(Tcl_Interp *interp, NsfClasses *subClasses) {
11208 
11209   nonnull_assert(interp != NULL);
11210   nonnull_assert(subClasses != NULL);
11211 
11212   do {
11213     Tcl_HashSearch hSrch;
11214     const Tcl_HashEntry *hPtr;
11215 
11216     assert(subClasses->cl);
11217 
11218     hPtr = Tcl_FirstHashEntry(&subClasses->cl->instances, &hSrch);
11219 
11220     /*
11221      * Recalculate the commands of all class-filter registrations.
11222      */
11223     if (subClasses->cl->opt != NULL) {
11224       FilterSearchAgain(interp, &subClasses->cl->opt->classFilters, NULL, subClasses->cl);
11225     }
11226 
11227     for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
11228       NsfObject *object = (NsfObject *)Tcl_GetHashKey(&subClasses->cl->instances, hPtr);
11229 
11230       FilterResetOrder(object);
11231       object->flags &= ~NSF_FILTER_ORDER_VALID;
11232 
11233       /*
11234        * Recalculate the commands of all object filter registrations.
11235        */
11236       if (object->opt != NULL) {
11237         FilterSearchAgain(interp, &object->opt->objFilters, object, NULL);
11238       }
11239     }
11240     subClasses = subClasses->nextPtr;
11241   } while (likely(subClasses != NULL));
11242 }
11243 
11244 /*
11245  *----------------------------------------------------------------------
11246  * FilterRemoveDependentFilterCmds --
11247  *
11248  *
11249  *    Remove all filters from all subclasses that refer to "removeClass". This
11250  *    function is e.g. used to remove filters defined in superclass list from
11251  *    a dependent class.
11252  *
11253  * Results:
11254  *    None
11255  *
11256  * Side effects:
11257  *    None
11258  *
11259  *----------------------------------------------------------------------
11260  */
11261 /*
11262  */
11263 static void FilterRemoveDependentFilterCmds(NsfClass *removeClass, NsfClasses *subClasses)
11264   nonnull(1) nonnull(2);
11265 
11266 static void
FilterRemoveDependentFilterCmds(NsfClass * removeClass,NsfClasses * subClasses)11267 FilterRemoveDependentFilterCmds(NsfClass *removeClass, NsfClasses *subClasses) {
11268 
11269   nonnull_assert(removeClass != NULL);
11270   nonnull_assert(subClasses != NULL);
11271 
11272   /*fprintf(stderr, "FilterRemoveDependentFilterCmds removeClass %p %s\n",
11273     removeClass, ObjStr(removeClass->object.cmdName));*/
11274 
11275   do {
11276     Tcl_HashSearch hSrch;
11277     const Tcl_HashEntry *hPtr;
11278     NsfClassOpt   *opt;
11279 
11280     assert(subClasses->cl);
11281     hPtr = Tcl_FirstHashEntry(&subClasses->cl->instances, &hSrch);
11282 
11283     opt = subClasses->cl->opt;
11284     if (opt != NULL) {
11285       CmdListRemoveContextClassFromList(&opt->classFilters, removeClass, GuardDel);
11286     }
11287     for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
11288       NsfObject *object = (NsfObject *) Tcl_GetHashKey(&subClasses->cl->instances, hPtr);
11289 
11290       if (object->opt != NULL) {
11291         CmdListRemoveContextClassFromList(&object->opt->objFilters, removeClass, GuardDel);
11292       }
11293     }
11294     subClasses = subClasses->nextPtr;
11295   } while (subClasses != NULL);
11296 }
11297 
11298 /*
11299  *----------------------------------------------------------------------
11300  * MethodHandleObj --
11301  *
11302  *    Builds a methodHandle from a method name. We assume, the methodName is
11303  *    not fully qualified (i.e. it must not start with a colon).
11304  *
11305  * Results:
11306  *    fresh Tcl_Obj
11307  *
11308  * Side effects:
11309  *    none
11310  *
11311  *----------------------------------------------------------------------
11312  */
11313 static Tcl_Obj * MethodHandleObj(NsfObject *object, int withPer_object, const char *methodName)
11314   nonnull(1) nonnull(3) returns_nonnull;
11315 
11316 static Tcl_Obj *
MethodHandleObj(NsfObject * object,int withPer_object,const char * methodName)11317 MethodHandleObj(NsfObject *object, int withPer_object, const char *methodName) {
11318   Tcl_Obj *resultObj;
11319 
11320   nonnull_assert(object != NULL);
11321   nonnull_assert(methodName != NULL);
11322   assert(*methodName != ':');
11323 
11324   if (withPer_object == 1) {
11325     resultObj = Tcl_NewStringObj("", 0);
11326   } else {
11327     resultObj = Tcl_NewStringObj(nsfClassesPrefix, (int)nsfClassesPrefixLength);
11328   }
11329   Tcl_AppendObjToObj(resultObj, object->cmdName);
11330   Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL);
11331 
11332   return resultObj;
11333 }
11334 
11335 /*
11336  *----------------------------------------------------------------------
11337  * FilterInfo --
11338  *
11339  *    Set the interp results with a Tcl list containing the content of the
11340  *    filter list. The options withGuards and withMethodHandles can be used
11341  *    for different output structures
11342  *
11343  * Results:
11344  *    Standard Tcl results
11345  *
11346  * Side effects:
11347  *    Updating interp result
11348  *
11349  *----------------------------------------------------------------------
11350  */
11351 static int FilterInfo(Tcl_Interp *interp, NsfCmdList *f, const char *pattern,
11352                       bool withGuards, bool withMethodHandles)
11353   nonnull(1);
11354 
11355 static int
FilterInfo(Tcl_Interp * interp,NsfCmdList * f,const char * pattern,bool withGuards,bool withMethodHandles)11356 FilterInfo(Tcl_Interp *interp, NsfCmdList *f, const char *pattern,
11357            bool withGuards, bool withMethodHandles) {
11358   Tcl_Obj *list = Tcl_NewListObj(0, NULL);
11359 
11360   nonnull_assert(interp != NULL);
11361 
11362   /*
11363    * Guard lists should only have unqualified filter lists when "withGuards"
11364    * is activated. "withMethodHandles" has no effect when "withGuards" is
11365    * specified.
11366    */
11367   if (withGuards) {
11368     withMethodHandles = NSF_FALSE;
11369   }
11370 
11371   while (f != NULL) {
11372     const char *simpleName = Tcl_GetCommandName(interp, f->cmdPtr);
11373 
11374     if (pattern == NULL || Tcl_StringMatch(simpleName, pattern)) {
11375       if (withGuards && (f->clientData != NULL)) {
11376         Tcl_Obj *innerList = Tcl_NewListObj(0, NULL);
11377         Tcl_Obj *g = (Tcl_Obj *) f->clientData;
11378 
11379         Tcl_ListObjAppendElement(interp, innerList,
11380                                  Tcl_NewStringObj(simpleName, -1));
11381         Tcl_ListObjAppendElement(interp, innerList, NsfGlobalObjs[NSF_GUARD_OPTION]);
11382         Tcl_ListObjAppendElement(interp, innerList, g);
11383         Tcl_ListObjAppendElement(interp, list, innerList);
11384       } else {
11385         if (withMethodHandles) {
11386           NsfClass *filterClass = f->clorobj;
11387 
11388           Tcl_ListObjAppendElement(interp, list,
11389                                    MethodHandleObj((NsfObject *)filterClass,
11390                                                    !NsfObjectIsClass(&filterClass->object), simpleName));
11391         } else {
11392           Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1));
11393         }
11394       }
11395     }
11396     f = f->nextPtr;
11397   }
11398   Tcl_SetObjResult(interp, list);
11399   return TCL_OK;
11400 }
11401 
11402 
11403 /*
11404  *----------------------------------------------------------------------
11405  * FilterComputeOrderFullList --
11406  *
11407  *    Compute a fresh list of filters and append it to the filterList.
11408  *
11409  * Results:
11410  *    None
11411  *
11412  * Side effects:
11413  *    Updating filterList
11414  *
11415  *----------------------------------------------------------------------
11416  */
11417 static void FilterComputeOrderFullList(
11418     Tcl_Interp *interp, NsfCmdList **filters,
11419     NsfCmdList **filterList
11420 ) nonnull(1) nonnull(2) nonnull(3);
11421 
11422 static void
FilterComputeOrderFullList(Tcl_Interp * interp,NsfCmdList ** filters,NsfCmdList ** filterList)11423 FilterComputeOrderFullList(
11424     Tcl_Interp *interp, NsfCmdList **filters,
11425     NsfCmdList **filterList
11426 ) {
11427   const NsfCmdList *f ;
11428   const NsfClasses *pl;
11429   NsfClass         *filterClass;
11430 
11431   nonnull_assert(interp != NULL);
11432   nonnull_assert(filters != NULL);
11433   nonnull_assert(filterList != NULL);
11434 
11435   /*
11436    * Ensure that no epoched command is in the filters list.
11437    */
11438   CmdListRemoveDeleted(filters, GuardDel);
11439 
11440   for (f = *filters; f != NULL; f = f->nextPtr) {
11441     const char *simpleName = Tcl_GetCommandName(interp, f->cmdPtr);
11442 
11443     filterClass = f->clorobj;
11444     CmdListAdd(filterList, f->cmdPtr, filterClass,
11445                /*noDuplicates*/ NSF_FALSE, NSF_TRUE);
11446 
11447     if (filterClass != NULL && !NsfObjectIsClass(&filterClass->object)) {
11448       /*
11449        * Get the class from the object for per-object filter.
11450        */
11451       filterClass = ((NsfObject *)filterClass)->cl;
11452     }
11453 
11454     /*
11455      * If we have a filter class -> search up the inheritance hierarchy.
11456      */
11457     if (filterClass != NULL) {
11458       pl = PrecedenceOrder(filterClass);
11459       if (pl != NULL && pl->nextPtr != NULL) {
11460         /*
11461          * Don't search on the start class again.
11462          */
11463         pl = pl->nextPtr;
11464         /*
11465          * Now go up the hierarchy.
11466          */
11467         for(; pl != NULL; pl = pl->nextPtr) {
11468           Tcl_Command pi = FindMethod(pl->cl->nsPtr, simpleName);
11469 
11470           if (pi != NULL) {
11471             CmdListAdd(filterList, pi, pl->cl,
11472                        /*noDuplicates*/ NSF_FALSE, NSF_TRUE);
11473             /*
11474               fprintf(stderr, " %s::%s, ", ClassName(pl->cl), simpleName);
11475             */
11476           }
11477         }
11478       }
11479     }
11480   }
11481   /*CmdListPrint(interp, "FilterComputeOrderFullList....\n", *filterList);*/
11482 }
11483 
11484 /*
11485  *----------------------------------------------------------------------
11486  * FilterComputeOrder --
11487  *
11488  *    Computes a linearized order of object and class filter. Then duplicates
11489  *    in the full list and with the class inheritance list of 'obj' are
11490  *    eliminated.  The precedence rule is that the last occurrence makes it
11491  *    into the final list (object->filterOrder).
11492  *
11493  * Results:
11494  *    None
11495  *
11496  * Side effects:
11497  *    Updating interp result
11498  *
11499  *----------------------------------------------------------------------
11500  */
11501 static void FilterComputeOrder(Tcl_Interp *interp, NsfObject *object)
11502   nonnull(1) nonnull(2);
11503 
11504 static void
FilterComputeOrder(Tcl_Interp * interp,NsfObject * object)11505 FilterComputeOrder(Tcl_Interp *interp, NsfObject *object) {
11506   NsfCmdList *filterList = NULL, *next, *checker, *newList;
11507   NsfClasses *pl;
11508 
11509   nonnull_assert(interp != NULL);
11510   nonnull_assert(object != NULL);
11511 
11512   if (object->filterOrder != NULL) {
11513     FilterResetOrder(object);
11514   }
11515   /*
11516     fprintf(stderr, "<Filter Order obj=%s> List: ", ObjectName(object));
11517   */
11518 
11519   /*
11520    * Append class filters registered for mixins.
11521    */
11522   if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
11523     MixinComputeDefined(interp, object);
11524   }
11525   if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
11526     NsfCmdList *ml;
11527 
11528     for (ml = object->mixinOrder; ml != NULL; ml = ml->nextPtr) {
11529       NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
11530 
11531       if (mixin != NULL && mixin->opt != NULL && mixin->opt->classFilters != NULL) {
11532         FilterComputeOrderFullList(interp, &mixin->opt->classFilters, &filterList);
11533       }
11534     }
11535   }
11536 
11537   /*
11538    * Append per-obj filters.
11539    */
11540   if (object->opt != NULL) {
11541     FilterComputeOrderFullList(interp, &object->opt->objFilters, &filterList);
11542   }
11543 
11544   /*
11545    * Append per-class filters.
11546    */
11547   for (pl = PrecedenceOrder(object->cl); pl != NULL; pl = pl->nextPtr) {
11548     NsfClassOpt *clopt = pl->cl->opt;
11549     if (clopt != NULL && clopt->classFilters != NULL) {
11550       FilterComputeOrderFullList(interp, &clopt->classFilters, &filterList);
11551     }
11552   }
11553 
11554   /*
11555    * Use no duplicates & no classes of the precedence order
11556    * on the resulting list.
11557    */
11558   while (filterList != NULL) {
11559     /*
11560      * Search for filterList->cmdPtr
11561      */
11562     for (checker = next = filterList->nextPtr; checker != NULL; checker = checker->nextPtr) {
11563       if (checker->cmdPtr == filterList->cmdPtr) {
11564         break;
11565       }
11566     }
11567 
11568     if (checker == NULL) {
11569       /*
11570        * filterList->cmdPtr was found
11571        */
11572       newList = CmdListAdd(&object->filterOrder, filterList->cmdPtr, filterList->clorobj,
11573                            /*noDuplicates*/ NSF_FALSE, NSF_TRUE);
11574       GuardAddInheritedGuards(interp, newList, object, filterList->cmdPtr);
11575       /*
11576         GuardPrint(interp, newList->clientData);
11577       */
11578     }
11579 
11580     CmdListDeleteCmdListEntry(filterList, GuardDel);
11581     filterList = next;
11582   }
11583 }
11584 
11585 /*
11586  *----------------------------------------------------------------------
11587  * FilterComputeDefined --
11588  *
11589  *    Compute the state of the filter order. The filter order is either
11590  *
11591  *       DEFINED (there are filter on the instance),
11592  *       NONE    (there are no filter for the instance),
11593  *       or INVALID (a class restructuring has occurred, thus it is not clear
11594  *                whether filters are defined or not).
11595  *
11596  *    If it is INVALID FilterComputeDefined can be used to compute the order
11597  *    and set the instance to DEFINE or NONE.
11598  *
11599  * Results:
11600  *    None
11601  *
11602  * Side effects:
11603  *    Updating object-flags
11604  *
11605  *----------------------------------------------------------------------
11606  */
11607 static void
FilterComputeDefined(Tcl_Interp * interp,NsfObject * object)11608 FilterComputeDefined(Tcl_Interp *interp, NsfObject *object) {
11609 
11610   nonnull_assert(interp != NULL);
11611   nonnull_assert(object != NULL);
11612 
11613   FilterComputeOrder(interp, object);
11614   object->flags |= NSF_FILTER_ORDER_VALID;
11615   if (object->filterOrder != NULL) {
11616     object->flags |= NSF_FILTER_ORDER_DEFINED;
11617   } else {
11618     object->flags &= ~NSF_FILTER_ORDER_DEFINED;
11619   }
11620 }
11621 
11622 /*
11623  *----------------------------------------------------------------------
11624  * FilterStackPush --
11625  *
11626  *    Push a filter stack information on this object and initialize it with
11627  *    calledProc.
11628  *
11629  * Results:
11630  *    None
11631  *
11632  * Side effects:
11633  *    Updating object->filterStack
11634  *
11635  *----------------------------------------------------------------------
11636  */
11637 static void FilterStackPush(NsfObject *object, Tcl_Obj *calledProc)
11638   nonnull(1) nonnull(2);
11639 
11640 static void
FilterStackPush(NsfObject * object,Tcl_Obj * calledProc)11641 FilterStackPush(NsfObject *object, Tcl_Obj *calledProc) {
11642   register NsfFilterStack *h = NEW(NsfFilterStack);
11643 
11644   nonnull_assert(object != NULL);
11645   nonnull_assert(calledProc != NULL);
11646 
11647   h->currentCmdPtr = NULL;
11648   h->calledProc = calledProc;
11649   INCR_REF_COUNT(h->calledProc);
11650   h->nextPtr = object->filterStack;
11651   object->filterStack = h;
11652 }
11653 
11654 /*
11655  *----------------------------------------------------------------------
11656  * FilterStackPush --
11657  *
11658  *    Pop filter stack information from the specified object
11659  *
11660  * Results:
11661  *    None
11662  *
11663  * Side effects:
11664  *    Free filter stack info
11665  *
11666  *----------------------------------------------------------------------
11667  */
11668 static void FilterStackPop(NsfObject *object)
11669   nonnull(1);
11670 
11671 static void
FilterStackPop(NsfObject * object)11672 FilterStackPop(NsfObject *object) {
11673   register NsfFilterStack *h;
11674 
11675   nonnull_assert(object != NULL);
11676 
11677   h = object->filterStack;
11678   object->filterStack = h->nextPtr;
11679 
11680   /*
11681    * Free stack entry.
11682    */
11683   DECR_REF_COUNT(h->calledProc);
11684   FREE(NsfFilterStack, h);
11685 }
11686 
11687 /*
11688  *----------------------------------------------------------------------
11689  * FilterFindReg --
11690  *
11691  *    Search through the filter list on obj and class hierarchy for
11692  *    registration of a cmdPtr as filter
11693  *
11694  * Results:
11695  *    Returns a Tcl list with the filter registration, like:
11696  *    "<obj> filter <filterName>, "<class> filter <filterName>,
11697  *    or an empty list, if not registered
11698  *
11699  * Side effects:
11700  *    None.
11701  *
11702  *----------------------------------------------------------------------
11703  */
11704 static Tcl_Obj * FilterFindReg(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd)
11705   nonnull(1) nonnull(2) nonnull(3) returns_nonnull;
11706 
11707 static Tcl_Obj *
FilterFindReg(Tcl_Interp * interp,NsfObject * object,Tcl_Command cmd)11708 FilterFindReg(Tcl_Interp *interp, NsfObject *object, Tcl_Command cmd) {
11709   Tcl_Obj *list = Tcl_NewListObj(0, NULL);
11710   NsfClasses *pl;
11711 
11712   nonnull_assert(interp != NULL);
11713   nonnull_assert(object != NULL);
11714   nonnull_assert(cmd != NULL);
11715 
11716   /*
11717    * Search per-object filters.
11718    */
11719   if (object->opt != NULL
11720       && object->opt->objFilters != NULL
11721       && CmdListFindCmdInList(cmd, object->opt->objFilters)) {
11722     Tcl_ListObjAppendElement(interp, list, object->cmdName);
11723     Tcl_ListObjAppendElement(interp, list, NsfGlobalObjs[NSF_OBJECT]);
11724     Tcl_ListObjAppendElement(interp, list, NsfGlobalObjs[NSF_FILTER]);
11725     Tcl_ListObjAppendElement(interp, list,
11726                              Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1));
11727     return list;
11728   }
11729 
11730   /*
11731    * Search per-class filters.
11732    */
11733   for (pl = PrecedenceOrder(object->cl); pl != NULL; pl = pl->nextPtr) {
11734     NsfClassOpt *opt = pl->cl->opt;
11735     if (opt != NULL && opt->classFilters != NULL) {
11736       if (CmdListFindCmdInList(cmd, opt->classFilters)) {
11737         Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName);
11738         Tcl_ListObjAppendElement(interp, list, NsfGlobalObjs[NSF_FILTER]);
11739         Tcl_ListObjAppendElement(interp, list,
11740                                  Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1));
11741         return list;
11742       }
11743     }
11744   }
11745   return list;
11746 }
11747 
11748 /*
11749  *----------------------------------------------------------------------
11750  * FilterSearchProc --
11751  *
11752  *     FilterSearchProc seeks the current filter and the relevant calling
11753  *     information (class and currentCmd). The function assumes to be called
11754  *     with an existing filterStack.
11755  *
11756  * Results:
11757  *    Tcl_Command or NULL
11758  *
11759  * Side effects:
11760  *    Updates *currentCmd and **cl
11761  *
11762  *----------------------------------------------------------------------
11763  */
11764 /*
11765  */
11766 static Tcl_Command FilterSearchProc(Tcl_Interp *interp, NsfObject *object,
11767                  Tcl_Command *currentCmd, NsfClass **classPtr)
11768   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
11769 
11770 static Tcl_Command
FilterSearchProc(Tcl_Interp * interp,NsfObject * object,Tcl_Command * currentCmd,NsfClass ** classPtr)11771 FilterSearchProc(Tcl_Interp *interp, NsfObject *object,
11772                  Tcl_Command *currentCmd, NsfClass **classPtr) {
11773 
11774   nonnull_assert(interp != NULL);
11775   nonnull_assert(object != NULL);
11776   nonnull_assert(currentCmd != NULL);
11777   nonnull_assert(classPtr != NULL);
11778 
11779   assert(object->filterStack != NULL);
11780   /*
11781    * Ensure that the filter order is not invalid, otherwise compute order
11782    * FilterComputeDefined(interp, object);
11783    */
11784   assert(object->flags & NSF_FILTER_ORDER_VALID);
11785 
11786   if (object->filterOrder != NULL) {
11787     NsfCmdList *cmdList;
11788 
11789     *currentCmd = NULL;
11790     cmdList = SeekCurrent(object->filterStack->currentCmdPtr, object->filterOrder);
11791 
11792     while (cmdList != NULL) {
11793       /*fprintf(stderr, "FilterSearchProc found %s\n",
11794         Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr));*/
11795       if (Tcl_Command_cmdEpoch(cmdList->cmdPtr) != 0) {
11796         cmdList = cmdList->nextPtr;
11797       } else if (FilterActiveOnObj(interp, object, cmdList->cmdPtr)) {
11798         /* fprintf(stderr, "Filter <%s> -- Active on: %s\n",
11799            Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), ObjectName(object));
11800         */
11801         object->filterStack->currentCmdPtr = cmdList->cmdPtr;
11802         cmdList = SeekCurrent(object->filterStack->currentCmdPtr, object->filterOrder);
11803       } else {
11804         /*
11805          * Ok, ee found it
11806          */
11807         if (cmdList->clorobj && !NsfObjectIsClass(&cmdList->clorobj->object)) {
11808           *classPtr = NULL;
11809         } else {
11810           *classPtr = cmdList->clorobj;
11811         }
11812         *currentCmd = cmdList->cmdPtr;
11813         /* fprintf(stderr, "FilterSearchProc - found: %s, %p\n",
11814            Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), cmdList->cmdPtr);
11815         */
11816         return cmdList->cmdPtr;
11817       }
11818     }
11819   }
11820   return NULL;
11821 }
11822 
11823 /*
11824  *----------------------------------------------------------------------
11825  * SuperclassAdd --
11826  *
11827  *    Add a list of superClasses (specified in the argument vector) to
11828  *    the specified class. On the first call, the class has no previous
11829  *    superClasses.
11830  *
11831  * Results:
11832  *    Tcl result code.
11833  *
11834  * Side effects:
11835  *    Rearranging the class relations, flushing previous precedence orders.
11836  *
11837  *----------------------------------------------------------------------
11838  */
11839 static int SuperclassAdd(Tcl_Interp *interp, NsfClass *class, int oc, Tcl_Obj **ov, Tcl_Obj *arg)
11840   nonnull(1) nonnull(2) nonnull(4) nonnull(5);
11841 
11842 static int
SuperclassAdd(Tcl_Interp * interp,NsfClass * class,int oc,Tcl_Obj ** ov,Tcl_Obj * arg)11843 SuperclassAdd(Tcl_Interp *interp, NsfClass *class, int oc, Tcl_Obj **ov, Tcl_Obj *arg) {
11844   NsfClasses       *superClasses, *subClasses, *osl = NULL;
11845   NsfObjectSystem  *osPtr;
11846   NsfClass        **classPtr;
11847   int i, j;
11848 
11849   nonnull_assert(interp != NULL);
11850   nonnull_assert(class != NULL);
11851   nonnull_assert(ov != NULL);
11852   nonnull_assert(arg != NULL);
11853 
11854   superClasses = PrecedenceOrder(class);
11855   subClasses = DependentSubClasses(class);
11856 
11857   /*
11858    * We have to remove all dependent superclass filter referenced
11859    * by class or one of its subclasses.
11860    *
11861    * Do not check the class "cl" itself (first entry in
11862    * filterCheck class list).
11863    */
11864   if (superClasses != NULL) {
11865     superClasses = superClasses->nextPtr;
11866   }
11867   for (; superClasses; superClasses = superClasses->nextPtr) {
11868     FilterRemoveDependentFilterCmds(superClasses->cl, subClasses);
11869   }
11870 
11871   /*
11872    * Invalidate all interceptors' orders of instances of this and of all
11873    * depended classes.
11874    */
11875   MixinInvalidateObjOrders(subClasses);
11876   if (FiltersDefined(interp) > 0) {
11877     FilterInvalidateObjOrders(interp, subClasses);
11878   }
11879 
11880   /*
11881    * Build an array of superClasses from the argument vector.
11882    */
11883   classPtr = NEW_ARRAY(NsfClass*, oc);
11884   for (i = 0; i < oc; i++) {
11885     if (GetClassFromObj(interp, ov[i], &classPtr[i], NSF_TRUE) != TCL_OK) {
11886       FREE(NsfClass**, classPtr);
11887       NsfClassListFree(subClasses);
11888       return NsfObjErrType(interp, "superclass", arg, "a list of classes", NULL);
11889     }
11890   }
11891 
11892   /*
11893    * Check that superClasses don't precede their classes.
11894    */
11895   for (i = 0; i < oc; i++) {
11896     for (j = i+1; j < oc; j++) {
11897       NsfClasses *dl = PrecedenceOrder(classPtr[j]);
11898 
11899       dl = NsfClassListFind(dl, classPtr[i]);
11900       if (dl != NULL) {
11901         FREE(NsfClass**, classPtr);
11902         NsfClassListFree(subClasses);
11903         return NsfObjErrType(interp, "superclass", arg, "classes in dependence order", NULL);
11904       }
11905     }
11906   }
11907 
11908   /*
11909    * Ensure that the current class and new superClasses are from the
11910    * same object system.
11911    */
11912   osPtr = GetObjectSystem(&class->object);
11913   for (i = 0; i < oc; i++) {
11914     if (osPtr != GetObjectSystem(&classPtr[i]->object)) {
11915       NsfPrintError(interp, "class \"%s\" has a different object system as class  \"%s\"",
11916                            ClassName_(class), ClassName(classPtr[i]));
11917       NsfClassListFree(subClasses);
11918       FREE(NsfClass**, classPtr);
11919       return TCL_ERROR;
11920     }
11921   }
11922 
11923   while (class->super != NULL) {
11924     /*
11925      * Build a backup of the old superclass list in case we need to revert.
11926      */
11927     NsfClass   *superClass = class->super->cl;
11928     NsfClasses *l = osl;
11929 
11930     osl = NEW(NsfClasses);
11931     osl->cl = superClass;
11932     osl->nextPtr = l;
11933     (void)RemoveSuper(class, class->super->cl);
11934   }
11935 
11936   for (i = 0; i < oc; i++) {
11937     AddSuper(class, classPtr[i]);
11938   }
11939 
11940   FlushPrecedences(subClasses);
11941   NsfClassListFree(subClasses);
11942   FREE(NsfClass**, classPtr);
11943 
11944   if (unlikely(!PrecedenceOrder(class))) {
11945     NsfClasses *l;
11946     /*
11947      * There is a cycle in the superclass graph, we have to revert and return
11948      * an error.
11949      */
11950     while (class->super != NULL) {
11951       (void)RemoveSuper(class, class->super->cl);
11952     }
11953     for (l = osl; l != NULL; l = l->nextPtr) {
11954       AddSuper(class, l->cl);
11955     }
11956     if (osl != NULL) {
11957       NsfClassListFree(osl);
11958     }
11959 
11960     return NsfObjErrType(interp, "superclass", arg, "a cycle-free graph", NULL);
11961   }
11962 
11963   if (osl != NULL) {
11964     NsfClassListFree(osl);
11965   }
11966 
11967   assert(class->super != NULL);
11968 
11969   Tcl_ResetResult(interp);
11970   return TCL_OK;
11971 }
11972 
11973 /*
11974  *----------------------------------------------------------------------
11975  * CheckVarName --
11976  *
11977  *    Check, whether the provided name is free of namespace markup.
11978  *
11979  * Results:
11980  *    Tcl result code.
11981  *
11982  * Side effects:
11983  *    none
11984  *
11985  *----------------------------------------------------------------------
11986  */
11987 static int CheckVarName(Tcl_Interp *interp, const char *varNameString)
11988   nonnull(1) nonnull(2);
11989 
11990 static int
CheckVarName(Tcl_Interp * interp,const char * varNameString)11991 CheckVarName(Tcl_Interp *interp, const char *varNameString) {
11992 
11993   nonnull_assert(interp != NULL);
11994   nonnull_assert(varNameString != NULL);
11995 
11996   /*
11997    * We want to have a plain variable name, since we do not want to
11998    * get interferences with namespace resolver and such.  In a first
11999    * attempt, we disallowed occurrences of "::", but we have to deal as
12000    * well with e.g. arrayName(::x::y)
12001    *
12002    * TODO: more general and efficient solution to disallow e.g. a::b
12003    * (check for :: until parens)
12004    */
12005   /*if (strstr(varNameString, "::") || *varNameString == ':') {*/
12006   if (*varNameString == ':') {
12007     return NsfPrintError(interp, "variable name \"%s\" must not contain "
12008                          "namespace separator or colon prefix",
12009                          varNameString);
12010   }
12011   return TCL_OK;
12012 }
12013 
12014 /*
12015  *----------------------------------------------------------------------
12016  * VarExists --
12017  *
12018  *    Check, whether the named variable exists on the specified object.
12019  *
12020  * Results:
12021  *    Tcl result code.
12022  *
12023  * Side effects:
12024  *    none
12025  *
12026  *----------------------------------------------------------------------
12027  */
12028 static bool VarExists(
12029     Tcl_Interp *interp, NsfObject *object,
12030     const char *name1, const char *name2, unsigned int flags
12031 ) nonnull(1) nonnull(2) nonnull(3);
12032 
12033 static bool
VarExists(Tcl_Interp * interp,NsfObject * object,const char * name1,const char * name2,unsigned int flags)12034 VarExists(
12035     Tcl_Interp *interp, NsfObject *object,
12036     const char *name1, const char *name2,
12037     unsigned int flags
12038 ) {
12039   CallFrame frame, *framePtr = &frame;
12040   const Var *varPtr;
12041   Var *arrayPtr;
12042   bool result;
12043 
12044   nonnull_assert(interp != NULL);
12045   nonnull_assert(object != NULL);
12046   nonnull_assert(name1 != NULL);
12047 
12048   Nsf_PushFrameObj(interp, object, framePtr);
12049 
12050   if ((flags & NSF_VAR_TRIGGER_TRACE) != 0u) {
12051     varPtr = TclVarTraceExists(interp, name1);
12052   } else {
12053     varPtr = TclLookupVar(interp, name1, name2, 0, "access",
12054                           /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
12055   }
12056   /*
12057     fprintf(stderr, "VarExists %s varPtr %p flags %.4x isundef %d\n",
12058     name1,
12059     varPtr,
12060     flags, (varPtr != NULL) ? TclIsVarUndefined(varPtr) : NULL);
12061   */
12062   result = ((varPtr != NULL) && ((flags & NSF_VAR_REQUIRE_DEFINED) == 0u || !TclIsVarUndefined(varPtr)));
12063   if (result && ((flags & NSF_VAR_ISARRAY) != 0u) && !TclIsVarArray(varPtr)) {
12064     result = NSF_FALSE;
12065   }
12066   Nsf_PopFrameObj(interp, framePtr);
12067 
12068   return result;
12069 }
12070 
12071 #if defined(WITH_TCL_COMPILE)
12072 # include <tclCompile.h>
12073 #endif
12074 
12075 /*
12076  *----------------------------------------------------------------------
12077  * MakeProcError --
12078  *
12079  *    Function called internally from Tcl in case the definition of the proc
12080  *    failed.
12081  *
12082  * Results:
12083  *    None
12084  *
12085  * Side effects:
12086  *    none
12087  *
12088  *----------------------------------------------------------------------
12089  */
12090 static void
MakeProcError(Tcl_Interp * interp,Tcl_Obj * procNameObj)12091 MakeProcError(
12092     Tcl_Interp *interp,        /* The interpreter in which the procedure was called. */
12093     Tcl_Obj *procNameObj       /* Name of the procedure. Used for error
12094                                 * messages and trace information. */
12095 ) {
12096   int         overflow, limit = 60, nameLen;
12097   const char *procName;
12098 
12099   /*fprintf(stderr, "MakeProcError %p type %p refCount %d\n",
12100     procNameObj, procNameObj->typePtr, procNameObj->refCount);*/
12101 
12102   procName = Tcl_GetString(procNameObj);
12103   nameLen = procNameObj->length;
12104   overflow = (nameLen > limit);
12105   Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
12106                                                  "\n    (procedure \"%.*s%s\" line %d)",
12107                                                  ((overflow != 0) ? limit : nameLen), procName,
12108                                                  ((overflow != 0) ? "..." : ""), Tcl_GetErrorLine(interp)));
12109 }
12110 
12111 /*
12112  *----------------------------------------------------------------------
12113  * ByteCompiled --
12114  *
12115  *    Function to determine whether a proc is already byte compiled or not.
12116  *
12117  * Results:
12118  *    Standard Tcl return code
12119  *
12120  * Side effects:
12121  *    none
12122  *
12123  *----------------------------------------------------------------------
12124  */
12125 static int ByteCompiled(
12126     Tcl_Interp *interp, unsigned int *flagsPtr,
12127     Proc *procPtr, Namespace *nsPtr, const char *procName
12128 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
12129 
12130 static int
ByteCompiled(Tcl_Interp * interp,unsigned int * flagsPtr,Proc * procPtr,Namespace * nsPtr,const char * procName)12131 ByteCompiled(
12132     Tcl_Interp *interp, unsigned int *flagsPtr,
12133     Proc *procPtr, Namespace *nsPtr, const char *procName
12134 ) {
12135   Tcl_Obj *bodyObj;
12136 
12137   nonnull_assert(interp != NULL);
12138   nonnull_assert(flagsPtr != NULL);
12139   nonnull_assert(procPtr != NULL);
12140   nonnull_assert(procName != NULL);
12141   nonnull_assert(nsPtr != NULL);
12142 
12143   bodyObj = procPtr->bodyPtr;
12144 
12145   if (likely(bodyObj->typePtr == Nsf_OT_byteCodeType)) {
12146 #if defined(HAVE_TCL_COMPILE_H)
12147     ByteCode *codePtr;
12148     Interp   *iPtr = (Interp *) interp;
12149 
12150     /*
12151      * When we've got bytecode, this is the check for validity. That is,
12152      * the bytecode must be for the right interpreter (no cross-leaks!),
12153      * the code must be from the current epoch (so subcommand compilation
12154      * is up-to-date), the namespace must match (so variable handling
12155      * is right) and the resolverEpoch must match (so that new shadowed
12156      * commands and/or resolver changes are considered).
12157      */
12158 
12159     codePtr = bodyObj->internalRep.otherValuePtr;
12160     if (unlikely(((Interp *) *codePtr->interpHandle != iPtr)
12161                  || (codePtr->compileEpoch != iPtr->compileEpoch)
12162                  || (codePtr->nsPtr != nsPtr)
12163                  || (codePtr->nsEpoch != nsPtr->resolverEpoch))) {
12164 
12165 # if defined(VAR_RESOLVER_TRACE)
12166       fprintf(stderr, "ByteCompiled bytecode not valid proc %p cmd %p method %s\n",
12167               procPtr, procPtr->cmdPtr,
12168               Tcl_GetCommandName(interp, (Tcl_Command)procPtr->cmdPtr));
12169       fprintf(stderr, "    %d %d %d %d\n",
12170               ((Interp *) *codePtr->interpHandle != iPtr),
12171                (codePtr->compileEpoch != iPtr->compileEpoch),
12172                (codePtr->nsPtr != nsPtr),
12173                (codePtr->nsEpoch != nsPtr->resolverEpoch));
12174 
12175       {
12176         CompiledLocal *localPtr = procPtr->firstLocalPtr;
12177         for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
12178           fprintf(stderr, "... local %p '%s' resolveInfo %p deleteProc %p\n",
12179                   localPtr, localPtr->name, localPtr->resolveInfo,
12180                   (localPtr->resolveInfo != NULL) ? localPtr->resolveInfo->deleteProc : NULL);
12181         }
12182       }
12183 # endif
12184       /* dummy statement for coverage analysis */
12185       assert(1);
12186       goto doCompilation;
12187     }
12188 #endif
12189     return TCL_OK;
12190   } else {
12191     int        result;
12192     Namespace *definitionNsPtr;
12193 
12194 #if defined(HAVE_TCL_COMPILE_H)
12195   doCompilation:
12196 #endif
12197 
12198     *flagsPtr |= NSF_CSC_CALL_IS_COMPILE;
12199     /*fprintf(stderr, "compiling '%s' with ns %s\n", procName, nsPtr->name);*/
12200 
12201     /*
12202      * Tcl's bytecode compiler (TclCompileScript & friends) will access the
12203      * proc command's namespace as resolution context for command lookups
12204      * (Tcl_FindCommand) when compiling the proc. We, therefore, have to patch
12205      * the proc command for the compilation step to point to the execution
12206      * namespace; and restore the definition namespace on leaving.
12207      */
12208 
12209     definitionNsPtr = procPtr->cmdPtr->nsPtr;
12210     procPtr->cmdPtr->nsPtr = nsPtr;
12211 
12212     result = TclProcCompileProc(interp, procPtr, bodyObj,
12213                                 (Namespace *) nsPtr, "body of proc",
12214                                 procName);
12215     procPtr->cmdPtr->nsPtr = definitionNsPtr;
12216 
12217     /*fprintf(stderr, "compiling '%s' with ns %s DONE\n", procName, nsPtr->name);*/
12218     *flagsPtr &= ~NSF_CSC_CALL_IS_COMPILE;
12219 
12220     return result;
12221   }
12222 }
12223 
12224 /*
12225  *----------------------------------------------------------------------
12226  * PushProcCallFrame --
12227  *
12228  *    Set up and push a new call frame for the procedure invocation.
12229  *    call-frame. The proc is passed via clientData.
12230  *
12231  * Results:
12232  *    Tcl result code
12233  *
12234  * Side effects:
12235  *    compiles body conditionally
12236  *
12237  *----------------------------------------------------------------------
12238  */
12239 static int PushProcCallFrame(
12240     Proc *procPtr, Tcl_Interp *interp,
12241     int objc, Tcl_Obj *const objv[],
12242     Tcl_Namespace *execNsPtr,
12243     NsfCallStackContent *cscPtr
12244 ) nonnull(1) nonnull(2) nonnull(4) nonnull(6);
12245 
12246 static int
PushProcCallFrame(Proc * procPtr,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],Tcl_Namespace * execNsPtr,NsfCallStackContent * cscPtr)12247 PushProcCallFrame(
12248     Proc *procPtr, Tcl_Interp *interp,
12249     int objc, Tcl_Obj *const objv[],
12250     Tcl_Namespace *execNsPtr,
12251     NsfCallStackContent *cscPtr
12252 ) {
12253   Tcl_CallFrame *framePtr;
12254   int            result;
12255 
12256   nonnull_assert(procPtr != NULL);
12257   nonnull_assert(interp != NULL);
12258   nonnull_assert(objv != NULL);
12259   nonnull_assert(cscPtr != NULL);
12260 
12261   /*
12262    * Set up and push a new call frame for the new procedure invocation.  This
12263    * call frame will execute either in the provided execNs or in the proc's
12264    * namespace, which might be different than the current namespace. The
12265    * proc's namespace is that of its command, which can change when the
12266    * command is renamed from one namespace to another.
12267    */
12268 
12269   if (execNsPtr == NULL) {
12270     execNsPtr = (Tcl_Namespace *) procPtr->cmdPtr->nsPtr;
12271   }
12272 
12273   /*
12274    * TODO: we could use Tcl_PushCallFrame(), if we would allocate the Tcl stack frame earlier
12275    */
12276   result = TclPushStackFrame(interp, (Tcl_CallFrame **)&framePtr,
12277                              execNsPtr,
12278                              (FRAME_IS_PROC|FRAME_IS_NSF_METHOD));
12279 
12280   if (likely(result == TCL_OK)) {
12281 
12282     Tcl_CallFrame_objc(framePtr) = objc;
12283     Tcl_CallFrame_objv(framePtr) = objv;
12284     Tcl_CallFrame_procPtr(framePtr) = procPtr;
12285     Tcl_CallFrame_clientData(framePtr) = cscPtr;
12286 
12287     /*fprintf(stderr, "Stack Frame %p procPtr %p compiledLocals %p firstLocal %p\n",
12288       framePtr, procPtr, Tcl_CallFrame_compiledLocals(framePtr), procPtr->firstLocalPtr);*/
12289 
12290     result = ByteCompiled(interp, &cscPtr->flags, procPtr, (Namespace *)execNsPtr, ObjStr(objv[0]));
12291   }
12292 
12293   return result;
12294 }
12295 
12296 #include "nsfAPI.h"
12297 
12298 /*
12299  *----------------------------------------------------------------------
12300  * ObjectSystemsCheckSystemMethod --
12301  *
12302  *    Mark the specified method as (potentially) 'overloaded' in all object
12303  *    systems and declare it 'defined' in the specified object system.
12304  *
12305  * Results:
12306  *    Tcl result code.
12307  *
12308  * Side effects:
12309  *    Updates the object system structure(s).
12310  *
12311  *----------------------------------------------------------------------
12312  */
12313 static int
ObjectSystemsCheckSystemMethod(Tcl_Interp * interp,const char * methodName,const NsfObject * object,unsigned int flags)12314 ObjectSystemsCheckSystemMethod(
12315     Tcl_Interp *interp, const char *methodName, const NsfObject *object, unsigned int flags
12316 ) {
12317   NsfObjectSystem *osPtr, *defOsPtr;
12318   char             firstChar;
12319 
12320   nonnull_assert(interp != NULL);
12321   nonnull_assert(object != NULL);
12322   nonnull_assert(methodName != NULL);
12323 
12324   firstChar = *methodName;
12325   defOsPtr = GetObjectSystem(object);
12326 
12327   for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
12328     int           i, isRootClassMethod;
12329     unsigned int  flag = 0u;
12330     NsfObject    *defObject;
12331     const char  **methodStrings = osPtr->methodNames;
12332 
12333     for (i = 0; i <= NSF_s_set_idx; i++) {
12334       const char *methodString = *methodStrings ++;
12335 
12336       if (likely(methodString != NULL)
12337           && unlikely(*methodString == firstChar)
12338           && strcmp(methodName, methodString) == 0) {
12339         flag = 1u << i;
12340         break;
12341       }
12342     }
12343     if (flag == 0u) {
12344       continue;
12345     }
12346 
12347     isRootClassMethod = *(Nsf_SystemMethodOpts[i]+1) == 'o';
12348     defObject = (isRootClassMethod == 1)
12349       ? &osPtr->rootClass->object
12350       : &osPtr->rootMetaClass->object;
12351 
12352     if (osPtr->handles[i] && osPtr->protected[i]) {
12353       if (defObject == object && (flags & NSF_CMD_REDEFINE_PROTECTED_METHOD) == 0u) {
12354         return NsfPrintError(interp, "refuse to overwrite protected method %s on %s",
12355                              methodName, ObjectName(defObject));
12356       }
12357     }
12358 
12359     if ((osPtr->definedMethods & flag) != 0u) {
12360       /*
12361        *  If for some reason base methods become redefined (e.g. in a reload),
12362        *  do not count them as overloads.
12363        */
12364       if ((isRootClassMethod == 1
12365            && object == &defOsPtr->rootClass->object)
12366           || (isRootClassMethod == 0
12367               && object == &defOsPtr->rootMetaClass->object)
12368           ) {
12369         /*fprintf(stderr, "+++ %s %.6x NOT overloading %s.%s %s (is root %d, is meta %d)\n",
12370           ClassName(defOsPtr->rootClass),
12371           osPtr->overloadedMethods, ObjectName(object), methodName, Nsf_SystemMethodOpts[i],
12372           object == &defOsPtr->rootClass->object,
12373           object == &defOsPtr->rootMetaClass->object);*/
12374       } else {
12375         osPtr->overloadedMethods |= flag;
12376         /*fprintf(stderr, "+++ %s %.6x overloading %s.%s %s (is root %d, is meta %d)\n",
12377           ClassName(defOsPtr->rootClass),
12378           osPtr->overloadedMethods, ObjectName(object), methodName, Nsf_SystemMethodOpts[i],
12379           object == &defOsPtr->rootClass->object,
12380           object == &defOsPtr->rootMetaClass->object);*/
12381       }
12382     }
12383     if ((osPtr == defOsPtr)
12384         && ((osPtr->definedMethods & flag) == 0u)
12385         ) {
12386       /*
12387        * Mark the method as defined.
12388        */
12389       osPtr->definedMethods |= flag;
12390 
12391       /*fprintf(stderr, "+++ %s %.6x defining %s.%s %s osPtr %p defined %.8x flag %.8x handle %p\n",
12392               ClassName(defOsPtr->rootClass),  osPtr->definedMethods, ObjectName(object),
12393               methodName, Nsf_SystemMethodOpts[i], osPtr, osPtr->definedMethods, flag,
12394               osPtr->handles[i]);*/
12395 
12396       /*
12397        * If there is a method handle provided for this system method, register
12398        * it as a fallback; unless the method is to be defined at the root
12399        * class.
12400        */
12401       if (osPtr->handles[i]) {
12402 
12403         if (defObject != object) {
12404           int result;
12405 
12406           NsfLog(interp, NSF_LOG_DEBUG, "Define automatically alias %s for %s",
12407                  ObjStr(osPtr->handles[i]), Nsf_SystemMethodOpts[i]);
12408 
12409           result = NsfMethodAliasCmd(interp, defObject, 0, methodName, 0,
12410                                          ProtectionRedefine_protectedIdx, osPtr->handles[i]);
12411 
12412           if (unlikely(result != TCL_OK)) {
12413             /*
12414              * Alias definition failed.
12415              */
12416             NsfLog(interp, NSF_LOG_WARN, "Could not define alias %s for %s",
12417                    ObjStr(osPtr->handles[i]), Nsf_SystemMethodOpts[i]);
12418             return TCL_ERROR;
12419           } else {
12420             /*
12421              * Alias definition succeeded.
12422              */
12423             Tcl_Obj     *methodObj = Tcl_GetObjResult(interp);
12424             Tcl_Command  cmd       = Tcl_GetCommandFromObj(interp, methodObj);
12425 
12426             /*
12427              * Since the defObject is not equal to the overloaded method, the
12428              * definition above is effectively an overload of the alias.
12429              */
12430             osPtr->overloadedMethods |= flag;
12431 
12432             /*
12433              * Set method protection.
12434              */
12435             if (cmd != NULL) {
12436               Tcl_Command_flags(cmd) |= NSF_CMD_CALL_PROTECTED_METHOD;
12437               if (osPtr->protected[i]) {
12438                 Tcl_Command_flags(cmd) |= NSF_CMD_REDEFINE_PROTECTED_METHOD;
12439               }
12440             }
12441             Tcl_ResetResult(interp);
12442           }
12443         }
12444       }
12445     }
12446   }
12447 
12448   return TCL_OK;
12449 }
12450 
12451 
12452 /*----------------------------------------------------------------------
12453  * ParamsNew --
12454  *
12455  *    Allocate an array of Nsf_Param structures
12456  *
12457  * Results:
12458  *    Pointer to allocated memory
12459  *
12460  * Side effects:
12461  *    Allocation of memory.
12462  *
12463  *----------------------------------------------------------------------
12464  */
12465 
12466 static Nsf_Param *
ParamsNew(size_t nr)12467 ParamsNew(size_t nr) {
12468   Nsf_Param *paramsPtr = NEW_ARRAY(Nsf_Param, nr+1);
12469 
12470   memset(paramsPtr, 0, sizeof(Nsf_Param) * (nr+1));
12471 
12472   return paramsPtr;
12473 }
12474 
12475 /*----------------------------------------------------------------------
12476  * ParamFree --
12477  *
12478  *    Deallocate the contents of a single Nsf_Param*
12479  *
12480  * Results:
12481  *    None.
12482  *
12483  * Side effects:
12484  *    Free the parameter definition.
12485  *
12486  *----------------------------------------------------------------------
12487  */
12488 static void ParamFree(Nsf_Param *paramPtr)
12489   nonnull(1);
12490 
12491 static void
ParamFree(Nsf_Param * paramPtr)12492 ParamFree(Nsf_Param *paramPtr) {
12493 
12494   nonnull_assert(paramPtr != NULL);
12495 
12496   /*fprintf(stderr, "ParamFree %p\n", paramPtr);*/
12497   if (paramPtr->name != NULL) {STRING_FREE("paramPtr->name", paramPtr->name);}
12498   if (paramPtr->nameObj != NULL) {DECR_REF_COUNT(paramPtr->nameObj);}
12499   if (paramPtr->defaultValue != NULL) {DECR_REF_COUNT(paramPtr->defaultValue);}
12500   if (paramPtr->converterName != NULL) {DECR_REF_COUNT2("converterNameObj", paramPtr->converterName);}
12501   if (paramPtr->converterArg != NULL) {DECR_REF_COUNT(paramPtr->converterArg);}
12502   if (paramPtr->paramObj != NULL) {DECR_REF_COUNT(paramPtr->paramObj);}
12503   if (paramPtr->slotObj != NULL) {DECR_REF_COUNT(paramPtr->slotObj);}
12504   if (paramPtr->method != NULL) {DECR_REF_COUNT(paramPtr->method);}
12505 }
12506 
12507 /*----------------------------------------------------------------------
12508  * ParamsFree --
12509  *
12510  *    Deallocate a block of multiple Nsf_Param*
12511  *
12512  * Results:
12513  *    None.
12514  *
12515  * Side effects:
12516  *    Free the parameter definition.
12517  *
12518  *----------------------------------------------------------------------
12519  */
12520 static void ParamsFree(Nsf_Param *paramsPtr)
12521   nonnull(1);
12522 
12523 static void
ParamsFree(Nsf_Param * paramsPtr)12524 ParamsFree(Nsf_Param *paramsPtr) {
12525   Nsf_Param *paramPtr;
12526 
12527   nonnull_assert(paramsPtr != NULL);
12528 
12529   /*fprintf(stderr, "ParamsFree %p\n", paramsPtr);*/
12530   for (paramPtr = paramsPtr; paramPtr->name != NULL; paramPtr++) {
12531     ParamFree(paramPtr);
12532   }
12533 
12534   FREE(Nsf_Param*, paramsPtr);
12535 }
12536 
12537 /*----------------------------------------------------------------------
12538  * ParamDefsGet --
12539  *
12540  *    Obtain parameter definitions for a cmdPtr; Optionally, this command
12541  *    returns as well a flag for ProcessMethodArguments to indicate if the
12542  *    parameter have to checked always.
12543  *
12544  * Results:
12545  *    Parameter definitions or NULL
12546  *
12547  * Side effects:
12548  *    None.
12549  *
12550  *----------------------------------------------------------------------
12551  */
12552 NSF_INLINE static NsfParamDefs *
ParamDefsGet(const Tcl_Command cmdPtr,unsigned int * checkAlwaysFlagPtr,Tcl_Namespace ** execNsPtrPtr)12553 ParamDefsGet(
12554     const Tcl_Command cmdPtr,
12555     unsigned int *checkAlwaysFlagPtr,
12556     Tcl_Namespace **execNsPtrPtr
12557 ) {
12558   NsfParamDefs *result;
12559 
12560   nonnull_assert(cmdPtr != NULL);
12561 
12562   if (likely(Tcl_Command_deleteProc(cmdPtr) == NsfProcDeleteProc)) {
12563     NsfProcContext *ctx = (NsfProcContext *)Tcl_Command_deleteData(cmdPtr);
12564 
12565     if (checkAlwaysFlagPtr != NULL) {
12566       *checkAlwaysFlagPtr = ctx->checkAlwaysFlag;
12567     }
12568     if (execNsPtrPtr != NULL) {
12569       *execNsPtrPtr = ctx->execNsPtr;
12570     }
12571     result = ctx->paramDefs;
12572   } else {
12573     result = NULL;
12574   }
12575 
12576   return result;
12577 }
12578 
12579 /*----------------------------------------------------------------------
12580  * ParamDefsGetReturns --
12581  *
12582  *    Obtain the "returns" value from NsfProcContext.
12583  *
12584  * Results:
12585  *    Tcl_Obj or NULL
12586  *
12587  * Side effects:
12588  *    None.
12589  *
12590  *----------------------------------------------------------------------
12591  */
12592 NSF_INLINE static Tcl_Obj *ParamDefsGetReturns(
12593     const Tcl_Command cmdPtr
12594 ) nonnull(1) pure;
12595 
12596 NSF_INLINE static Tcl_Obj *
ParamDefsGetReturns(const Tcl_Command cmdPtr)12597 ParamDefsGetReturns(const Tcl_Command cmdPtr) {
12598   const NsfProcContext *pCtx;
12599   Tcl_Obj              *resultObj;
12600 
12601   nonnull_assert(cmdPtr != NULL);
12602 
12603   pCtx = ProcContextGet(cmdPtr);
12604   if (pCtx != NULL) {
12605     resultObj = pCtx->returnsObj;
12606   } else {
12607     resultObj = NULL;
12608   }
12609   return resultObj;
12610 }
12611 
12612 
12613 /*----------------------------------------------------------------------
12614  * NsfParamDefsNonposLookup --
12615  *
12616  *    Process a list of ParamDefs look for a non-pos args. If there is no exact
12617  *    match, look for an abbreviated match having at least
12618  *    NSF_ABBREV_MIN_CHARS leading chars which are identical.
12619  *
12620  * Results:
12621  *    Standard Tcl result; might set paramPtrPtr;
12622  *
12623  * Side effects:
12624  *    None.
12625  *
12626  *----------------------------------------------------------------------
12627  */
12628 static int NsfParamDefsNonposLookup(
12629     Tcl_Interp *interp, const char *nameString,
12630     const Nsf_Param *paramsPtr,  const Nsf_Param **paramPtrPtr
12631 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
12632 
12633 static int
NsfParamDefsNonposLookup(Tcl_Interp * interp,const char * nameString,const Nsf_Param * paramsPtr,const Nsf_Param ** paramPtrPtr)12634 NsfParamDefsNonposLookup(
12635     Tcl_Interp *interp, const char *nameString,
12636     const Nsf_Param *paramsPtr, const Nsf_Param **paramPtrPtr
12637 ) {
12638   const Nsf_Param *paramPtr;
12639   char             ch1;
12640   size_t           length;
12641 
12642   nonnull_assert(interp != NULL);
12643   nonnull_assert(nameString != NULL);
12644   nonnull_assert(paramsPtr != NULL);
12645   nonnull_assert(paramPtrPtr != NULL);
12646 
12647   /*
12648    * The provided paramsPtr must point to a block starting with a non-pos arg.
12649    */
12650   assert(paramsPtr->name != NULL);
12651   assert(*paramsPtr->name == '-');
12652 
12653   /*
12654    * The provided nameString starts as well with a leading dash.
12655    */
12656   assert(*nameString == '-');
12657 
12658   ch1 = nameString[2];
12659   for (paramPtr = paramsPtr; likely(paramPtr->name != NULL) && *paramPtr->name == '-'; paramPtr++) {
12660     if (unlikely((paramPtr->flags & NSF_ARG_NOCONFIG) != 0u)) {
12661       continue;
12662     }
12663     if (ch1 == paramPtr->name[2]
12664         && strcmp(nameString, paramPtr->name) == 0) {
12665         *paramPtrPtr = paramPtr;
12666         return TCL_OK;
12667     }
12668   }
12669 
12670   length = strlen(nameString);
12671 
12672   if (length >= NSF_ABBREV_MIN_CHARS) {
12673 
12674     for (paramPtr = paramsPtr; likely(paramPtr->name != NULL) && *paramPtr->name == '-'; paramPtr++) {
12675       if (unlikely((paramPtr->flags & NSF_ARG_NOCONFIG) != 0u)) {
12676         continue;
12677       }
12678 
12679       if (ch1 == paramPtr->name[2]
12680           && strncmp(nameString, paramPtr->name, length) == 0) {
12681         const Nsf_Param *pPtr;
12682 
12683         /* fprintf(stderr, "... <%s> is an abbrev of <%s>\n", nameString, paramPtr->name); */
12684         /*
12685          * Check whether the abbreviation is unique.
12686          */
12687         for (pPtr = paramPtr + 1; likely(pPtr->name != NULL) && *pPtr->name == '-'; pPtr++) {
12688           if (unlikely((pPtr->flags & NSF_ARG_NOCONFIG) != 0u)) {
12689             continue;
12690           }
12691           if (ch1 == pPtr->name[2]
12692               && strncmp(nameString, pPtr->name, length) == 0) {
12693             /*
12694              * The abbreviation is not unique
12695              */
12696             *paramPtrPtr = NULL;
12697             return NsfPrintError(interp, "the provided argument %s is an abbreviation for %s and %s",
12698                                  nameString, paramPtr->name, pPtr->name);
12699           }
12700         }
12701         /*
12702          * The abbreviation is unique
12703          */
12704         *paramPtrPtr = paramPtr;
12705         return TCL_OK;
12706       }
12707     }
12708   }
12709   *paramPtrPtr = NULL;
12710   return TCL_OK;
12711 }
12712 
12713 /*
12714  *----------------------------------------------------------------------
12715  * CGetParamLookup --
12716  *
12717  *    Obtain the parameter definition for a Tcl_Obj starting with a "-".  It
12718  *    can return an error, when the specified parameter is ambiguous.
12719  *
12720  * Results:
12721  *    Tcl return code, on success paramPtr in last argument
12722  *
12723  * Side effects:
12724  *    None
12725  *
12726  *----------------------------------------------------------------------
12727  */
12728 static int
12729 CGetParamLookup(
12730     Tcl_Interp       *interp,
12731     Tcl_Obj          *nameObj,
12732     NsfParamDefs     *paramDefs,
12733     const Nsf_Param **paramPtrPtr
12734 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4);
12735 
12736 static int
CGetParamLookup(Tcl_Interp * interp,Tcl_Obj * nameObj,NsfParamDefs * paramDefs,const Nsf_Param ** paramPtrPtr)12737 CGetParamLookup(Tcl_Interp *interp, Tcl_Obj *nameObj, NsfParamDefs *paramDefs, const Nsf_Param **paramPtrPtr)
12738 {
12739   const char *nameString;
12740   int         result = TCL_OK;
12741 
12742   nonnull_assert(interp != NULL);
12743   nonnull_assert(nameObj != NULL);
12744   nonnull_assert(paramDefs != NULL);
12745   nonnull_assert(paramPtrPtr != NULL);
12746 
12747   /*
12748    * Does provided value start with a dash?
12749    */
12750   nameString = ObjStr(nameObj);
12751   if (unlikely(*nameString != '-')) {
12752     result = NsfPrintError(interp,
12753                            "cget: parameter must start with a '-': %s",
12754                            nameString);
12755 
12756   } else {
12757     NsfFlag *flagPtr = nameObj->internalRep.twoPtrValue.ptr1;
12758 
12759     if ((nameObj->typePtr == &NsfFlagObjType)
12760         && (flagPtr->signature == paramDefs->paramsPtr)
12761         && (flagPtr->serial == paramDefs->serial)
12762         ) {
12763       *paramPtrPtr = flagPtr->paramPtr;
12764 
12765     } else {
12766       Nsf_Param  *paramPtr;
12767 
12768       /*
12769        * Skip leading parameters from the definition, which are no non-pos args
12770        * (very unlikely).
12771        */
12772       for (paramPtr = paramDefs->paramsPtr;
12773            (paramPtr->name != NULL) && (*paramPtr->name != '-');
12774            paramPtr++) {
12775         ;
12776       }
12777 
12778       /*
12779        * Perform the lookup from the group starting with paramPtr.
12780        */
12781       result = NsfParamDefsNonposLookup(interp, nameString, paramPtr, paramPtrPtr);
12782       if (unlikely(result == TCL_OK)) {
12783         /*
12784          * Set the flag value. Probably, we should prohibit conversion on some
12785          * types.
12786          */
12787         NsfFlagObjSet(interp, nameObj, paramDefs->paramsPtr, paramDefs->serial,
12788                       *paramPtrPtr, NULL, 0u);
12789       }
12790     }
12791   }
12792 
12793   return result;
12794 }
12795 
12796 /*
12797  *----------------------------------------------------------------------
12798  * NsfProcDeleteProc --
12799  *
12800  *    FreeProc for procs with associated parameter definitions.
12801  *
12802  * Results:
12803  *    None.
12804  *
12805  * Side effects:
12806  *    Freeing memory.
12807  *
12808  *----------------------------------------------------------------------
12809  */
12810 static void
NsfProcDeleteProc(ClientData clientData)12811 NsfProcDeleteProc(
12812     ClientData clientData
12813 ) {
12814   const NsfProcContext *ctxPtr;
12815 
12816   nonnull_assert(clientData != NULL);
12817 
12818   ctxPtr = (NsfProcContext *)clientData;
12819   if (ctxPtr->oldDeleteProc != NULL) {
12820     (*ctxPtr->oldDeleteProc)(ctxPtr->oldDeleteData);
12821   }
12822   if (ctxPtr->paramDefs != NULL) {
12823     /*fprintf(stderr, "free ParamDefs %p\n", (void*)ctxPtr->paramDefs);*/
12824     ParamDefsRefCountDecr(ctxPtr->paramDefs);
12825   }
12826   if (ctxPtr->colonLocalVarCache != NULL) {
12827     /*fprintf(stderr, "free colonLocalVarCache %p\n", (void*)ctxPtr->colonLocalVarCache);*/
12828     FREE(int*, ctxPtr->colonLocalVarCache);
12829   }
12830   if (ctxPtr->returnsObj != NULL) {
12831     DECR_REF_COUNT2("returnsObj", ctxPtr->returnsObj);
12832   }
12833 
12834   if (ctxPtr->execNsPtr != NULL) {
12835     /*
12836      * Balances increment in ParamDefsStore.
12837      */
12838     NSNamespaceRelease(ctxPtr->execNsPtr);
12839   }
12840 
12841   /*fprintf(stderr, "free %p\n", ctxPtr);*/
12842   FREE(NsfProcContext, ctxPtr);
12843 }
12844 
12845 /*
12846  *----------------------------------------------------------------------
12847  * ProcContextRequire --
12848  *
12849  *    Obtain an NsfProcContext for the given cmd. Create a new one, if it does
12850  *    not exist, or return the existing one.
12851  *
12852  * Results:
12853  *    NsfProcContext *
12854  *
12855  * Side effects:
12856  *    Might allocate memory
12857  *
12858  *----------------------------------------------------------------------
12859  */
12860 static NsfProcContext *
ProcContextRequire(Tcl_Command cmd)12861 ProcContextRequire(
12862     Tcl_Command cmd
12863 ) {
12864   NsfProcContext *ctxPtr;
12865   Command        *cmdPtr;
12866 
12867   nonnull_assert(cmd != NULL);
12868 
12869   cmdPtr = (Command *)cmd;
12870 
12871   if (cmdPtr->deleteProc != NsfProcDeleteProc) {
12872     ctxPtr = NEW(NsfProcContext);
12873 
12874     /*fprintf(stderr, "ParamDefsStore %p replace deleteProc %p by %p\n",
12875       paramDefs, cmdPtr->deleteProc, NsfProcDeleteProc);*/
12876 
12877     ctxPtr->oldDeleteData      = (Proc *)cmdPtr->deleteData;
12878     ctxPtr->oldDeleteProc      = cmdPtr->deleteProc;
12879     cmdPtr->deleteProc         = NsfProcDeleteProc;
12880     cmdPtr->deleteData         = ctxPtr;
12881 
12882     ctxPtr->paramDefs          = NULL;
12883     ctxPtr->checkAlwaysFlag    = 0;
12884     ctxPtr->execNsPtr          = NULL;
12885     ctxPtr->colonLocalVarCache = NULL;
12886     ctxPtr->returnsObj         = NULL;
12887   } else {
12888     ctxPtr = (NsfProcContext *)Tcl_Command_deleteData(cmdPtr);
12889   }
12890   return ctxPtr;
12891 }
12892 
12893 /*
12894  *----------------------------------------------------------------------
12895  * ProcContextGet --
12896  *
12897  *    Obtain an NsfProcContext for the given cmd when it is defined.
12898  *
12899  * Results:
12900  *    NsfProcContext * or NULL
12901  *
12902  * Side effects:
12903  *    None
12904  *
12905  *----------------------------------------------------------------------
12906  */
12907 NSF_INLINE static NsfProcContext *
ProcContextGet(const Tcl_Command cmdPtr)12908 ProcContextGet(
12909     const Tcl_Command cmdPtr
12910 ) {
12911   NsfProcContext *result;
12912 
12913   nonnull_assert(cmdPtr != NULL);
12914 
12915   if (likely(Tcl_Command_deleteProc(cmdPtr) == NsfProcDeleteProc)) {
12916     result = (NsfProcContext *)Tcl_Command_deleteData(cmdPtr);
12917   } else {
12918     result = NULL;
12919   }
12920 
12921   return result;
12922 }
12923 
12924 /*
12925  *----------------------------------------------------------------------
12926  * ParamDefsStore --
12927  *
12928  *    Store the provided parameter definitions in the provided
12929  *    command. It stores a new deleteProc which will call the original
12930  *    delete proc automatically.
12931  *
12932  * Results:
12933  *    Tcl result code.
12934  *
12935  * Side effects:
12936  *    None
12937  *
12938  *----------------------------------------------------------------------
12939  */
12940 static void ParamDefsStore(
12941     Tcl_Command cmd,
12942     NsfParamDefs *paramDefs,
12943     unsigned int checkAlwaysFlag,
12944     Tcl_Namespace *execNsPtr
12945 ) nonnull(1);
12946 
12947 static void
ParamDefsStore(Tcl_Command cmd,NsfParamDefs * paramDefs,unsigned int checkAlwaysFlag,Tcl_Namespace * execNsPtr)12948 ParamDefsStore(
12949     Tcl_Command cmd,
12950     NsfParamDefs *paramDefs,
12951     unsigned int checkAlwaysFlag,
12952     Tcl_Namespace *execNsPtr
12953 ) {
12954   NsfProcContext *ctxPtr;
12955 
12956   nonnull_assert(cmd != NULL);
12957 
12958   ctxPtr = ProcContextRequire(cmd);
12959 
12960   /*
12961    * We assume, that this never called for overwriting paramDefs
12962    */
12963   assert(ctxPtr->paramDefs == NULL);
12964   /* fprintf(stderr, "ParamDefsStore paramDefs %p called: NS %s\n", paramDefs, execNsPtr ? execNsPtr->fullName : "na");*/
12965   ctxPtr->paramDefs       = paramDefs;
12966   ctxPtr->checkAlwaysFlag = checkAlwaysFlag;
12967   ctxPtr->execNsPtr       = execNsPtr;
12968 
12969   if (ctxPtr->execNsPtr != NULL) {
12970     /*
12971      * Balanced by decrement in NsfProcDeleteProc.
12972      */
12973     NSNamespacePreserve(ctxPtr->execNsPtr);
12974   }
12975 }
12976 
12977 /*
12978  *----------------------------------------------------------------------
12979  * ParamDefsNew --
12980  *
12981  *    Allocate a new paramDefs structure and initialize it with zeros. The
12982  *    allocated structure should be freed with ParamDefsFree().
12983  *
12984  * Results:
12985  *    pointer to paramDefs structure
12986  *
12987  * Side effects:
12988  *    Allocating memory
12989  *
12990  *----------------------------------------------------------------------
12991  */
12992 static NsfParamDefs *
ParamDefsNew(void)12993 ParamDefsNew(void) {
12994   NsfParamDefs    *paramDefs;
12995   static NsfMutex  serialMutex = 0;
12996   static int       serial = 0;
12997 
12998   paramDefs = NEW(NsfParamDefs);
12999   memset(paramDefs, 0, sizeof(NsfParamDefs));
13000 
13001   /*
13002    * We could keep the serial as well in thread local storage.
13003    */
13004   NsfMutexLock(&serialMutex);
13005   paramDefs->serial = serial++;
13006   NsfMutexUnlock(&serialMutex);
13007 
13008   /*fprintf(stderr, "ParamDefsNew %p\n", paramDefs);*/
13009 
13010   return paramDefs;
13011 }
13012 
13013 
13014 /*
13015  *----------------------------------------------------------------------
13016  * ParamDefsFree --
13017  *
13018  *    Free the parameter definitions. Since the parameter definitions are
13019  *    ref-counted, this function should be just called via
13020  *    ParamDefsRefCountDecr.
13021  *
13022  * Results:
13023  *    None.
13024  *
13025  * Side effects:
13026  *    Free the parameter definitions.
13027  *
13028  *----------------------------------------------------------------------
13029  */
13030 
13031 static void ParamDefsFree(NsfParamDefs *paramDefs)
13032   nonnull(1);
13033 
13034 static void
ParamDefsFree(NsfParamDefs * paramDefs)13035 ParamDefsFree(NsfParamDefs *paramDefs) {
13036   /* fprintf(stderr, "ParamDefsFree %p \n",
13037      paramDefs, paramDefs);*/
13038 
13039   nonnull_assert(paramDefs != NULL);
13040 
13041   if (paramDefs->paramsPtr != NULL) {
13042     ParamsFree(paramDefs->paramsPtr);
13043   }
13044 
13045   FREE(NsfParamDefs, paramDefs);
13046 }
13047 
13048 /*
13049  *----------------------------------------------------------------------
13050  * ParamDefsRefCountIncr --
13051  * ParamDefsRefCountDecr --
13052  *
13053  *    Perform book keeping on the parameter definitions. RefCounting is
13054  *    necessary, since it might be possible that during the processing of the
13055  *    e.g. object parameters, these might be redefined (when an object
13056  *    parameter calls a method, redefining the structures).
13057  *    ParamDefsRefCountDecr() is responsible for actually freeing the
13058  *    structure.
13059  *
13060  * Results:
13061  *    None.
13062  *
13063  * Side effects:
13064  *    No direct.
13065  *
13066  *----------------------------------------------------------------------
13067  */
13068 
13069 
13070 static void
ParamDefsRefCountIncr(NsfParamDefs * paramDefs)13071 ParamDefsRefCountIncr(NsfParamDefs *paramDefs) {
13072 
13073   nonnull_assert(paramDefs != NULL);
13074 
13075   paramDefs->refCount ++;
13076 }
13077 
13078 static void
ParamDefsRefCountDecr(NsfParamDefs * paramDefs)13079 ParamDefsRefCountDecr(NsfParamDefs *paramDefs) {
13080 
13081   nonnull_assert(paramDefs != NULL);
13082 
13083   paramDefs->refCount --;
13084   if (paramDefs->refCount < 1) {
13085     ParamDefsFree(paramDefs);
13086   }
13087 }
13088 
13089 /*
13090  *----------------------------------------------------------------------
13091  * ParamDefsFormatOption --
13092  *
13093  *    Append a parameter option to the nameStringObj representing the
13094  *    syntax of the parameter definition.
13095  *
13096  * Results:
13097  *    None.
13098  *
13099  * Side effects:
13100  *    none
13101  *
13102  *----------------------------------------------------------------------
13103  */
13104 static void ParamDefsFormatOption(
13105     Tcl_Obj *nameStringObj, const char *option, int optionLength,
13106     int *colonWritten, int *firstOption
13107 ) nonnull(1) nonnull(2) nonnull(4) nonnull(5);
13108 
13109 static void
ParamDefsFormatOption(Tcl_Obj * nameStringObj,const char * option,int optionLength,int * colonWritten,int * firstOption)13110 ParamDefsFormatOption(
13111     Tcl_Obj *nameStringObj, const char *option, int optionLength,
13112     int *colonWritten, int *firstOption
13113 ) {
13114 
13115   nonnull_assert(nameStringObj != NULL);
13116   nonnull_assert(option != NULL);
13117   nonnull_assert(colonWritten != NULL);
13118   nonnull_assert(firstOption != NULL);
13119 
13120   if (!*colonWritten) {
13121     Tcl_AppendLimitedToObj(nameStringObj, ":", 1, INT_MAX, NULL);
13122     *colonWritten = 1;
13123   }
13124   if (*firstOption) {
13125     *firstOption = 0;
13126   } else {
13127     Tcl_AppendLimitedToObj(nameStringObj, ",", 1, INT_MAX, NULL);
13128   }
13129   Tcl_AppendLimitedToObj(nameStringObj, option, optionLength, INT_MAX, NULL);
13130 }
13131 
13132 /*
13133  *----------------------------------------------------------------------
13134  * ParamDefsFormat --
13135  *
13136  *    Produce a Tcl_Obj representing a single parameter in the syntax
13137  *    of the parameter definition.
13138  *
13139  * Results:
13140  *    Tcl_Obj
13141  *
13142  * Side effects:
13143  *    None.
13144  *
13145  *----------------------------------------------------------------------
13146  */
13147 static Tcl_Obj *ParamDefsFormat(
13148     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13149 ) nonnull(1) nonnull(2) returns_nonnull;
13150 
ParamsDefMatchPattern(const Nsf_Param * paramsPtr,const char * pattern)13151 static int ParamsDefMatchPattern(const Nsf_Param *paramsPtr, const char *pattern) {
13152   if (paramsPtr->nameObj != NULL) {
13153     return Tcl_StringMatch(ObjStr(paramsPtr->nameObj), pattern);
13154   } else {
13155     return Tcl_StringMatch(paramsPtr->name, pattern);
13156   }
13157 }
13158 
13159 
13160 static Tcl_Obj *
ParamDefsFormat(Tcl_Interp * interp,const Nsf_Param * paramsPtr,NsfObject * contextObject,const char * pattern)13161 ParamDefsFormat(
13162     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13163 ) {
13164   int      first, colonWritten;
13165   Tcl_Obj *listObj = Tcl_NewListObj(0, NULL), *innerListObj, *nameStringObj;
13166 
13167   nonnull_assert(interp != NULL);
13168   nonnull_assert(paramsPtr != NULL);
13169 
13170   INCR_REF_COUNT2("paramDefsObj", listObj);
13171 
13172   for (; likely(paramsPtr->name != NULL); paramsPtr++) {
13173     if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
13174       continue;
13175     }
13176     if (paramsPtr->paramObj != NULL) {
13177       if (pattern != NULL && !ParamsDefMatchPattern(paramsPtr, pattern)) {
13178         continue;
13179       }
13180       innerListObj = paramsPtr->paramObj;
13181     } else {
13182       /*
13183        * We need this part only for C-defined parameter definitions, defined
13184        * via genTclAPI.
13185        *
13186        * TODO: we could streamline this by defining as well C-API via the same
13187        * syntax as for accepted for Tcl obj types "nsfParam"
13188        */
13189       int isNonpos = *paramsPtr->name == '-';
13190       int outputRequired = (isNonpos && ((paramsPtr->flags & NSF_ARG_REQUIRED) != 0u));
13191       int outputOptional = (!isNonpos && ((paramsPtr->flags & NSF_ARG_REQUIRED) == 0u)
13192                             && !paramsPtr->defaultValue &&
13193                             paramsPtr->converter != ConvertToNothing);
13194       first = 1;
13195       colonWritten = 0;
13196 
13197       if (NsfParamDefsAppendVirtual(interp, listObj, paramsPtr, contextObject, pattern, ParamDefsFormat)) {
13198         continue;
13199       }
13200       if (pattern != NULL && !ParamsDefMatchPattern(paramsPtr, pattern)) {
13201         continue;
13202       }
13203 
13204       nameStringObj = Tcl_NewStringObj(paramsPtr->name, -1);
13205 
13206       if (paramsPtr->type != NULL) {
13207         ParamDefsFormatOption(nameStringObj, paramsPtr->type, -1, &colonWritten, &first);
13208       } else if (isNonpos && paramsPtr->nrArgs == 0) {
13209         ParamDefsFormatOption(nameStringObj, "switch", 6, &colonWritten, &first);
13210       }
13211       if (outputRequired != 0) {
13212         ParamDefsFormatOption(nameStringObj, "required", 8, &colonWritten, &first);
13213       } else if (outputOptional != 0) {
13214         ParamDefsFormatOption(nameStringObj, "optional", 8, &colonWritten, &first);
13215       }
13216       if ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT) != 0u) {
13217         char buffer[30];
13218         int  len = 12;
13219 
13220         memcpy(buffer, "substdefault", (size_t)len);
13221 
13222         if ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_ALL) != 0u) {
13223           memcpy(buffer + len + 1, "=0b", 3u);
13224           len += 4;
13225           buffer[len] = ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_VARIABLES) != 0u) ? '1' : '0';
13226           len ++;
13227           buffer[len] = ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_COMMANDS) != 0u) ? '1' : '0';
13228           len ++;
13229           buffer[len] = ((paramsPtr->flags & NSF_ARG_SUBST_DEFAULT_BACKSLASHES) != 0u) ? '1' : '0';
13230           len ++;
13231         } else {
13232           len ++;
13233         }
13234         buffer[len] = '\0';
13235         ParamDefsFormatOption(nameStringObj, buffer, len, &colonWritten, &first);
13236 
13237       }
13238       if ((paramsPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u || (paramsPtr->flags & NSF_ARG_MULTIVALUED) != 0u) {
13239         char option[10] = "....";
13240 
13241         option[0] = ((paramsPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u) ? '0' : '1';
13242         option[3] = ((paramsPtr->flags & NSF_ARG_MULTIVALUED) != 0u) ? '*' : '1';
13243         ParamDefsFormatOption(nameStringObj, option, 4, &colonWritten, &first);
13244       }
13245       if ((paramsPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) {
13246         ParamDefsFormatOption(nameStringObj, "convert", 7, &colonWritten, &first);
13247       }
13248       if ((paramsPtr->flags & NSF_ARG_INITCMD) != 0u) {
13249         ParamDefsFormatOption(nameStringObj, "initcmd", 7, &colonWritten, &first);
13250       } else if ((paramsPtr->flags & NSF_ARG_CMD) != 0u) {
13251         ParamDefsFormatOption(nameStringObj, "cmd", 3, &colonWritten, &first);
13252       } else if ((paramsPtr->flags & NSF_ARG_ALIAS) != 0u) {
13253         ParamDefsFormatOption(nameStringObj, "alias", 5, &colonWritten, &first);
13254       } else if ((paramsPtr->flags & NSF_ARG_FORWARD) != 0u) {
13255         ParamDefsFormatOption(nameStringObj, "forward", 7, &colonWritten, &first);
13256       } else if ((paramsPtr->flags & NSF_ARG_NOARG) != 0u) {
13257         ParamDefsFormatOption(nameStringObj, "noarg", 5, &colonWritten, &first);
13258       } else if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
13259         ParamDefsFormatOption(nameStringObj, "noconfig", 8, &colonWritten, &first);
13260       }
13261 
13262       innerListObj = Tcl_NewListObj(0, NULL);
13263       Tcl_ListObjAppendElement(interp, innerListObj, nameStringObj);
13264       if (paramsPtr->defaultValue != NULL) {
13265         Tcl_ListObjAppendElement(interp, innerListObj, paramsPtr->defaultValue);
13266       }
13267     }
13268 
13269     Tcl_ListObjAppendElement(interp, listObj, innerListObj);
13270   }
13271 
13272   return listObj;
13273 }
13274 
13275 /*
13276  *----------------------------------------------------------------------
13277  * ParamDefsList --
13278  *
13279  *    Produce a Tcl_ListObj containing the list of the parameters
13280  *    based on a parameter structure.
13281  *
13282  * Results:
13283  *    Tcl_Obj
13284  *
13285  * Side effects:
13286  *    None.
13287  *
13288  *----------------------------------------------------------------------
13289  */
13290 static Tcl_Obj *ParamDefsList(
13291     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13292 ) nonnull(1) nonnull(2) returns_nonnull;
13293 
13294 static Tcl_Obj *
ParamDefsList(Tcl_Interp * interp,const Nsf_Param * paramsPtr,NsfObject * contextObject,const char * pattern)13295 ParamDefsList(
13296     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13297 ) {
13298   Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
13299 
13300   nonnull_assert(interp != NULL);
13301   nonnull_assert(paramsPtr != NULL);
13302 
13303   INCR_REF_COUNT2("paramDefsObj", listObj);
13304 
13305   for (; likely(paramsPtr->name != NULL); paramsPtr++) {
13306     if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
13307       continue;
13308     }
13309     if (NsfParamDefsAppendVirtual(interp, listObj, paramsPtr, contextObject, pattern, ParamDefsList)) {
13310       continue;
13311     }
13312 
13313     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(paramsPtr->name, -1));
13314   }
13315 
13316   return listObj;
13317 }
13318 
13319 
13320 /*
13321  *----------------------------------------------------------------------
13322  * ParamDefsNames --
13323  *
13324  *    Produce a Tcl_ListObj containing the names of the parameters
13325  *    based on a parameter structure.
13326  *
13327  * Results:
13328  *    Tcl_Obj
13329  *
13330  * Side effects:
13331  *    None.
13332  *
13333  *----------------------------------------------------------------------
13334  */
13335 static Tcl_Obj * ParamDefsNames(
13336     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13337 ) nonnull(1) nonnull(2) returns_nonnull;
13338 
13339 static Tcl_Obj *
ParamDefsNames(Tcl_Interp * interp,const Nsf_Param * paramsPtr,NsfObject * contextObject,const char * pattern)13340 ParamDefsNames(
13341     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13342 ) {
13343   Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
13344 
13345   nonnull_assert(interp != NULL);
13346   nonnull_assert(paramsPtr != NULL);
13347 
13348   INCR_REF_COUNT2("paramDefsObj", listObj);
13349 
13350   for (; likely(paramsPtr->name != NULL); paramsPtr++) {
13351     const char* paramName;
13352 
13353     if ((paramsPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
13354       continue;
13355     }
13356     if (NsfParamDefsAppendVirtual(interp, listObj, paramsPtr, contextObject, pattern, ParamDefsNames)) {
13357       continue;
13358     }
13359 
13360     paramName = *paramsPtr->name == '-' ? paramsPtr->name+1 : paramsPtr->name;
13361     if (pattern != NULL && !Tcl_StringMatch(paramName, pattern)) {
13362       continue;
13363     }
13364     Tcl_ListObjAppendElement(interp, listObj, (paramsPtr->nameObj != NULL) ?
13365                              paramsPtr->nameObj : Tcl_NewStringObj(paramsPtr->name, -1));
13366   }
13367 
13368   return listObj;
13369 }
13370 
13371 /*
13372  *----------------------------------------------------------------------
13373  * ParamGetType --
13374  *
13375  *    Obtain the type of a single parameter and return it as a string.
13376  *
13377  * Results:
13378  *    Type of the parameter in form of a string
13379  *
13380  * Side effects:
13381  *    None.
13382  *
13383  *----------------------------------------------------------------------
13384  */
13385 static const char *ParamGetType(Nsf_Param const *paramPtr)
13386   nonnull(1) returns_nonnull;
13387 
13388 static const char *
ParamGetType(Nsf_Param const * paramPtr)13389 ParamGetType(Nsf_Param const *paramPtr) {
13390   const char *result = "value";
13391 
13392   nonnull_assert(paramPtr != NULL);
13393 
13394   if (paramPtr->type != NULL) {
13395     if (paramPtr->converter == ConvertViaCmd) {
13396       result = paramPtr->type + 5;
13397     } else if (paramPtr->converter == Nsf_ConvertToClass &&
13398                ((paramPtr->flags & (NSF_ARG_BASECLASS|NSF_ARG_METACLASS)) != 0u) ) {
13399       if ((paramPtr->flags & NSF_ARG_BASECLASS) != 0u) {
13400         result = "baseclass";
13401       } else {
13402         result = "metaclass";
13403       }
13404     } else if (strcmp(paramPtr->type, "stringtype") == 0) {
13405       if (paramPtr->converterArg != NULL) {
13406         result = ObjStr(paramPtr->converterArg);
13407       }
13408     } else {
13409       result = paramPtr->type;
13410     }
13411   }
13412 
13413   return result;
13414 }
13415 
13416 /*
13417  *----------------------------------------------------------------------
13418  * ParamGetDomain --
13419  *
13420  *    Obtain the domain of a single parameter and return it as a
13421  *    string. The domain is an approximate type used in the parameter
13422  *    syntax.
13423  *
13424  * Results:
13425  *    Domain of the parameter in form of a string
13426  *
13427  * Side effects:
13428  *    None.
13429  *
13430  *----------------------------------------------------------------------
13431  */
13432 static const char * ParamGetDomain(Nsf_Param const *paramPtr)
13433   nonnull(1) returns_nonnull;
13434 
13435 static const char *
ParamGetDomain(Nsf_Param const * paramPtr)13436 ParamGetDomain(Nsf_Param const *paramPtr) {
13437   const char *result;
13438 
13439   nonnull_assert(paramPtr != NULL);
13440 
13441   if ((paramPtr->flags & NSF_ARG_IS_ENUMERATION) != 0u) {
13442     return Nsf_EnumerationTypeGetDomain(paramPtr->converter);
13443   } else {
13444     result = ParamGetType(paramPtr);
13445   }
13446   return result;
13447 }
13448 
13449 /*
13450  *----------------------------------------------------------------------
13451  * NsfParamDefsSyntaxOne --
13452  *
13453  *    Appends the formatted parameter (provided as 2nd argument) to the
13454  *    content of the first argument.
13455  *
13456  * Results:
13457  *    None
13458  *
13459  * Side effects:
13460  *    Appending to first argument.
13461  *
13462  *----------------------------------------------------------------------
13463  */
13464 
13465 static void NsfParamDefsSyntaxOne(Tcl_Obj *argStringObj, const Nsf_Param *pPtr)
13466   nonnull(1) nonnull(2);
13467 
13468 static void
NsfParamDefsSyntaxOne(Tcl_Obj * argStringObj,const Nsf_Param * pPtr)13469 NsfParamDefsSyntaxOne(Tcl_Obj *argStringObj, const Nsf_Param *pPtr) {
13470 
13471   nonnull_assert(argStringObj != NULL);
13472   nonnull_assert(pPtr != NULL);
13473 
13474   if (pPtr->nrArgs > 0 && *pPtr->name == '-') {
13475     Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL);
13476     Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
13477     if ((pPtr->flags & NSF_ARG_IS_ENUMERATION) != 0u) {
13478       Tcl_AppendLimitedToObj(argStringObj, ParamGetDomain(pPtr), -1, INT_MAX, NULL);
13479       if ((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u)  {
13480         Tcl_AppendLimitedToObj(argStringObj, " ...", 4, INT_MAX, NULL);
13481       }
13482     } else {
13483       Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
13484       Tcl_AppendLimitedToObj(argStringObj, ParamGetDomain(pPtr), -1, INT_MAX, NULL);
13485       if ((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u) {
13486         Tcl_AppendLimitedToObj(argStringObj, " ...", 4, INT_MAX, NULL);
13487       }
13488       Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
13489     }
13490   } else if (*pPtr->name != '-') {
13491     Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
13492     Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL);
13493     Tcl_AppendLimitedToObj(argStringObj, "/", 1, INT_MAX, NULL);
13494   } else {
13495     Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL);
13496   }
13497 }
13498 
13499 /*
13500  * NsfParamDefsVirtualFormat --
13501  *
13502  *    This function is called, when we know we can resolve a virtual argument
13503  *    against the context object. In such cases, obtain the resolved parsed
13504  *    params and call the formatter.
13505  *
13506  * Results:
13507  *    Standard Tcl result code.
13508  *
13509  * Side effects:
13510  *    None.
13511  *
13512  *----------------------------------------------------------------------
13513  */
13514 
13515 static Tcl_Obj *
NsfParamDefsVirtualFormat(Tcl_Interp * interp,const Nsf_Param * pPtr,NsfObject * contextObject,const char * pattern,NsfFormatFunction formatFunction)13516 NsfParamDefsVirtualFormat(
13517     Tcl_Interp *interp, const Nsf_Param *pPtr,
13518     NsfObject *contextObject, const char *pattern,
13519     NsfFormatFunction formatFunction
13520 ) {
13521   NsfParsedParam parsedParam;
13522   int result;
13523 
13524   nonnull_assert(interp != NULL);
13525   nonnull_assert(pPtr != NULL);
13526   nonnull_assert(contextObject != NULL);
13527   nonnull_assert(formatFunction != NULL);
13528   assert(pPtr->type != NULL);
13529 
13530   parsedParam.paramDefs = NULL;
13531   if (strcmp(pPtr->type, "virtualobjectargs") == 0) {
13532     result = GetObjectParameterDefinition(interp, NsfGlobalObjs[NSF_EMPTY], contextObject, NULL, &parsedParam);
13533   } else if (NsfObjectIsClass(contextObject)) {
13534     result = GetObjectParameterDefinition(interp, NsfGlobalObjs[NSF_EMPTY], NULL, (NsfClass *)contextObject, &parsedParam);
13535   } else {
13536     NsfLog(interp, NSF_LOG_WARN, "virtual args: provided context is not a class <%s>", ObjectName_(contextObject));
13537     result = TCL_ERROR;
13538   }
13539 
13540   if (result == TCL_OK && parsedParam.paramDefs != NULL) {
13541     return (*formatFunction)(interp, parsedParam.paramDefs->paramsPtr, contextObject, pattern);
13542   }
13543 
13544   return NULL;
13545 }
13546 
13547 /*
13548  *----------------------------------------------------------------------
13549  * NsfParamDefsAppendVirtual --
13550  *
13551  *    Check for the given paramsPtr whether this is a virtual parameter and if
13552  *    possible, resolve it and append the formatted content to the Tcl_Obj.
13553  *
13554  * Results:
13555  *    Boolean value for success
13556  *
13557  * Side effects:
13558  *    None.
13559  *
13560  *----------------------------------------------------------------------
13561  */
13562 static bool
NsfParamDefsAppendVirtual(Tcl_Interp * interp,Tcl_Obj * listObj,const Nsf_Param * paramsPtr,NsfObject * contextObject,const char * pattern,NsfFormatFunction formatFunction)13563 NsfParamDefsAppendVirtual(
13564     Tcl_Interp *interp, Tcl_Obj *listObj,
13565     const Nsf_Param *paramsPtr, NsfObject *contextObject,
13566     const char *pattern, NsfFormatFunction formatFunction
13567 ) {
13568   nonnull_assert(interp != NULL);
13569   nonnull_assert(listObj != NULL);
13570   nonnull_assert(paramsPtr != NULL);
13571   nonnull_assert(formatFunction != NULL);
13572 
13573   assert(paramsPtr->name != NULL);
13574 
13575   if (paramsPtr->converter == ConvertToNothing && strcmp(paramsPtr->name, "args") == 0) {
13576 
13577     if ((contextObject != NULL)
13578         && (paramsPtr->type != NULL)
13579         && strncmp(paramsPtr->type, "virtual", 7) == 0
13580         ) {
13581       Tcl_Obj *formattedObj = NsfParamDefsVirtualFormat(interp, paramsPtr, contextObject, pattern, formatFunction);
13582 
13583       if (formattedObj != NULL) {
13584         Tcl_ListObjAppendList(interp, listObj, formattedObj);
13585         DECR_REF_COUNT2("paramDefsObj", formattedObj);
13586 
13587         return NSF_TRUE;
13588       }
13589     }
13590   }
13591   return NSF_FALSE;
13592 }
13593 
13594 /*
13595  *----------------------------------------------------------------------
13596  * NsfParamDefsSyntax --
13597  *
13598  *    Return the parameter definitions of a sequence of parameters in
13599  *    the form of the "parametersyntax", inspired by the Tcl manual
13600  *    pages.
13601  *
13602  * Results:
13603  *    Tcl_Obj containing the parameter syntax
13604  *
13605  * Side effects:
13606  *    None.
13607  *
13608  *----------------------------------------------------------------------
13609  */
13610 
13611 Tcl_Obj *NsfParamDefsSyntax(
13612     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13613 ) nonnull(1) nonnull(2) returns_nonnull;
13614 
13615 Tcl_Obj *
NsfParamDefsSyntax(Tcl_Interp * interp,const Nsf_Param * paramsPtr,NsfObject * contextObject,const char * pattern)13616 NsfParamDefsSyntax(
13617     Tcl_Interp *interp, const Nsf_Param *paramsPtr, NsfObject *contextObject, const char *pattern
13618 ) {
13619   Tcl_Obj         *argStringObj = Tcl_NewObj();
13620   const Nsf_Param *pPtr;
13621   int              needSpace = 0;
13622 
13623   nonnull_assert(interp != NULL);
13624   nonnull_assert(paramsPtr != NULL);
13625 
13626   INCR_REF_COUNT2("paramDefsObj", argStringObj);
13627 
13628   for (pPtr = paramsPtr; pPtr->name != NULL; pPtr++) {
13629 
13630     if ((pPtr->flags & NSF_ARG_NOCONFIG) != 0u) {
13631       /*
13632        * Don't output non-configurable parameters
13633        */
13634       continue;
13635     }
13636 
13637     if (pPtr != paramsPtr) {
13638       /*
13639        * Don't output non-consuming parameters (i.e. positional, and no args)
13640        */
13641       if (*pPtr->name != '-' && pPtr->nrArgs == 0) {
13642         continue;
13643       }
13644     }
13645 
13646     if (pPtr->converter == ConvertToNothing && strcmp(pPtr->name, "args") == 0) {
13647       int argsResolved = 0;
13648 
13649       if ((contextObject != NULL)
13650           && (pPtr->type != NULL)
13651           && strncmp(pPtr->type, "virtual", 7) == 0
13652           ) {
13653         Tcl_Obj *formattedObj = NsfParamDefsVirtualFormat(interp, pPtr, contextObject,
13654                                                           pattern, NsfParamDefsSyntax);
13655 
13656         if (formattedObj != NULL) {
13657           argsResolved = 1;
13658           if (needSpace != 0) {
13659             Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
13660           }
13661           Tcl_AppendObjToObj(argStringObj, formattedObj);
13662           DECR_REF_COUNT2("paramDefsObj", formattedObj);
13663         }
13664       }
13665       if (argsResolved == 0) {
13666         if (pattern != NULL && !ParamsDefMatchPattern(pPtr, pattern)) {
13667           continue;
13668         }
13669         if (needSpace != 0) {
13670           Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
13671         }
13672         Tcl_AppendLimitedToObj(argStringObj, "?/arg .../?", 11, INT_MAX, NULL);
13673       }
13674 
13675     } else if ((pPtr->flags & NSF_ARG_REQUIRED) != 0u) {
13676       if (pattern != NULL && !ParamsDefMatchPattern(pPtr, pattern)) {
13677         continue;
13678       }
13679       if (needSpace != 0) {
13680         Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
13681       }
13682 
13683       if ((pPtr->flags & NSF_ARG_IS_ENUMERATION) != 0u) {
13684         Tcl_AppendLimitedToObj(argStringObj, Nsf_EnumerationTypeGetDomain(pPtr->converter), -1, INT_MAX, NULL);
13685       } else {
13686         NsfParamDefsSyntaxOne(argStringObj, pPtr);
13687       }
13688 
13689     } else {
13690       if (pattern != NULL && !ParamsDefMatchPattern(pPtr, pattern)) {
13691         continue;
13692       }
13693       if (needSpace != 0) Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL);
13694       Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL);
13695       NsfParamDefsSyntaxOne(argStringObj, pPtr);
13696       Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL);
13697     }
13698     needSpace = 1;
13699   }
13700 
13701   /*
13702    * Caller has to decrement.
13703    */
13704   return argStringObj;
13705 }
13706 
13707 /*
13708  *----------------------------------------------------------------------
13709  * ParsedParamFree --
13710  *
13711  *    Free the provided information of the parsed parameters.
13712  *
13713  * Results:
13714  *    None.
13715  *
13716  * Side effects:
13717  *    Freed Memory.
13718  *
13719  *----------------------------------------------------------------------
13720  */
13721 static void
ParsedParamFree(NsfParsedParam * parsedParamPtr)13722 ParsedParamFree(NsfParsedParam *parsedParamPtr) {
13723 
13724   nonnull_assert(parsedParamPtr != NULL);
13725 
13726   /*fprintf(stderr, "ParsedParamFree %p, npargs %p\n",
13727     parsedParamPtr, parsedParamPtr->paramDefs);*/
13728   if (parsedParamPtr->paramDefs != NULL) {
13729     ParamDefsRefCountDecr(parsedParamPtr->paramDefs);
13730   }
13731   FREE(NsfParsedParam, parsedParamPtr);
13732 }
13733 
13734 
13735 
13736 /*
13737  * method dispatch
13738  */
13739 /*
13740  *----------------------------------------------------------------------
13741  * ProcMethodDispatchFinalize --
13742  *
13743  *    Finalization function for ProcMethodDispatch which executes
13744  *    scripted methods. Essentially it handles post-assertions and
13745  *    frees per-invocation memory. The function was developed for NRE
13746  *    enabled Tcl versions but is used in the same way for non-NRE
13747  *    enabled versions.
13748  *
13749  * Results:
13750  *    Tcl result code.
13751  *
13752  * Side effects:
13753  *    indirect effects by calling Tcl code
13754  *
13755  *----------------------------------------------------------------------
13756  */
13757 static int ProcMethodDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result)
13758   nonnull(1) nonnull(2);
13759 
13760 static int
ProcMethodDispatchFinalize(ClientData data[],Tcl_Interp * interp,int result)13761 ProcMethodDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result) {
13762   ParseContext       *pcPtr;
13763   /*const char *methodName = data[2];*/
13764 #if defined(NSF_WITH_ASSERTIONS) || defined(NRE)
13765   NsfCallStackContent *cscPtr;
13766 #endif
13767 #if defined(NSF_WITH_ASSERTIONS)
13768   NsfObject           *object;
13769   NsfObjectOpt        *opt;
13770 #endif
13771 
13772   nonnull_assert(data != NULL);
13773   nonnull_assert(interp != NULL);
13774 
13775   pcPtr = data[0];
13776 
13777 #if defined(NSF_WITH_ASSERTIONS) || defined(NRE)
13778   cscPtr = data[1];
13779   assert(cscPtr != NULL);
13780 #endif
13781 #if defined(NSF_WITH_ASSERTIONS)
13782   object = cscPtr->self;
13783   opt = object->opt;
13784 #endif
13785 
13786   /*fprintf(stderr, "ProcMethodDispatchFinalize %s %s flags %.6x isNRE %d pcPtr %p result %d\n",
13787           ObjectName(object), methodName,
13788           cscPtr->flags, (cscPtr->flags & NSF_CSC_CALL_IS_NRE), pcPtr, result);*/
13789 
13790 #if defined(NSF_WITH_ASSERTIONS)
13791   if (unlikely(opt != NULL && object->teardown != NULL && (opt->checkoptions & CHECK_POST))
13792       && likely(result == TCL_OK)) {
13793     int rc = AssertionCheck(interp, object, cscPtr->cl, data[2], CHECK_POST);
13794     if (rc != TCL_OK) {
13795       result = rc;
13796     }
13797   }
13798 #endif
13799 
13800 #if defined(NRE)
13801   if (likely((cscPtr->flags & NSF_CSC_CALL_IS_NRE) != 0u)) {
13802     if (likely(pcPtr != NULL)) {
13803       ParseContextRelease(pcPtr);
13804       NsfTclStackFree(interp, pcPtr, "release parse context");
13805     }
13806     result = ObjectDispatchFinalize(interp, cscPtr, result /*, "NRE" , methodName*/);
13807 
13808     CscFinish(interp, cscPtr, result, "scripted finalize");
13809   }
13810 #else
13811   if (unlikely(pcPtr != NULL)) {
13812     ParseContextRelease(pcPtr);
13813   }
13814 #endif
13815 
13816   return result;
13817 }
13818 
13819 /*
13820  *----------------------------------------------------------------------
13821  * ProcDispatchFinalize --
13822  *
13823  *    Finalization function for nsf::proc. Simplified version of
13824  *    ProcMethodDispatchFinalize().
13825  *
13826  * Results:
13827  *    Tcl result code.
13828  *
13829  * Side effects:
13830  *    indirect effects by calling Tcl code
13831  *
13832  *----------------------------------------------------------------------
13833  */
13834 static int ProcDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result)
13835   nonnull(1) nonnull(2);
13836 
13837 static int
ProcDispatchFinalize(ClientData data[],Tcl_Interp * interp,int result)13838 ProcDispatchFinalize(ClientData data[], Tcl_Interp *interp, int result) {
13839   ParseContext *pcPtr;
13840   Tcl_Time     *ttPtr;
13841 
13842   nonnull_assert(data != NULL);
13843   nonnull_assert(interp != NULL);
13844 
13845   /*const char *methodName = data[0];
13846     fprintf(stderr, "ProcDispatchFinalize of method %s\n", methodName);*/
13847 
13848   pcPtr = data[1];
13849   ttPtr = data[2];
13850 
13851   if (ttPtr != NULL) {
13852     const char      *methodName = data[0];
13853     unsigned int     cmdFlags   = PTR2UINT(data[3]);
13854 #if defined(NSF_PROFILE)
13855     NsfRuntimeState *rst        = RUNTIME_STATE(interp);
13856 #endif
13857     /*fprintf(stderr, "ProcDispatchFinalize methodName %s flags %.6lx\n",
13858       methodName, (cmdFlags & NSF_CMD_DEBUG_METHOD));*/
13859     if ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u) {
13860       NsfProfileDebugExit(interp, NULL, NULL, methodName, ttPtr->sec, ttPtr->usec);
13861     }
13862 #if defined(NSF_PROFILE)
13863     if (rst->doProfile != 0) {
13864       NsfProfileRecordProcData(interp, methodName, ttPtr->sec, ttPtr->usec);
13865     }
13866 #endif
13867     if (ttPtr != NULL) {
13868       ckfree((char *)ttPtr);
13869     }
13870   }
13871 
13872   ParseContextRelease(pcPtr);
13873   NsfTclStackFree(interp, pcPtr, "nsf::proc dispatch finalize release parse context");
13874   return result;
13875 }
13876 
13877 
13878 /*
13879  *----------------------------------------------------------------------
13880  * ProcMethodDispatch --
13881  *
13882  *    Invoke a scripted method (with assertion checking and filters).
13883  *
13884  * Results:
13885  *    Tcl result code.
13886  *
13887  * Side effects:
13888  *    Indirect effects by calling Tcl code
13889  *
13890  *----------------------------------------------------------------------
13891  */
13892 static int ProcMethodDispatch(
13893     ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
13894     const char *methodName, NsfObject *object, NsfClass *class, Tcl_Command cmdPtr,
13895     NsfCallStackContent *cscPtr
13896 ) nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6) nonnull(8) nonnull(9);
13897 
13898 static int
ProcMethodDispatch(ClientData cp,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],const char * methodName,NsfObject * object,NsfClass * class,Tcl_Command cmdPtr,NsfCallStackContent * cscPtr)13899 ProcMethodDispatch(
13900     ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
13901     const char *methodName, NsfObject *object, NsfClass *class, Tcl_Command cmdPtr,
13902     NsfCallStackContent *cscPtr
13903 ) {
13904   NsfParamDefs  *paramDefs;
13905   int            result;
13906   bool           releasePc = NSF_FALSE;
13907   Tcl_Namespace *execNsPtr = NULL;
13908   unsigned int   checkAlwaysFlag = 0u;
13909 #if defined(NSF_WITH_ASSERTIONS)
13910   NsfObjectOpt  *opt;
13911 #endif
13912 #if defined(NRE)
13913   ParseContext  *pcPtr = NULL;
13914 #else
13915   ParseContext   pc, *pcPtr = &pc;
13916 #endif
13917 
13918   nonnull_assert(cp != NULL);
13919   nonnull_assert(interp != NULL);
13920   nonnull_assert(objv != NULL);
13921   nonnull_assert(methodName != NULL);
13922   nonnull_assert(cmdPtr != NULL);
13923   nonnull_assert(cscPtr != NULL);
13924   nonnull_assert(object != NULL);
13925 
13926   assert(object->teardown != NULL);
13927 
13928 #if defined(NRE)
13929   /*fprintf(stderr, "ProcMethodDispatch cmd %s\n", Tcl_GetCommandName(interp, cmdPtr));*/
13930   assert((cscPtr->flags & NSF_CSC_CALL_IS_NRE) != 0u);
13931 #endif
13932 
13933   /*
13934    * If this is a filter, check whether its guard applies,
13935    * if not: just step forward to the next filter
13936    */
13937 
13938   if (unlikely(cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER)) {
13939     NsfCmdList *cmdList;
13940     /*
13941      * Seek cmd in obj's filterOrder.
13942      */
13943     assert((object->flags & NSF_FILTER_ORDER_VALID) != 0u);
13944     /* otherwise: FilterComputeDefined(interp, object);*/
13945 
13946     for (cmdList = object->filterOrder;
13947          (cmdList != NULL) && (cmdList->cmdPtr != cmdPtr);
13948          cmdList = cmdList->nextPtr) {
13949       ;
13950     }
13951 
13952     if (cmdList != NULL) {
13953       /*
13954        * A filter was found, check whether it has a guard.
13955        */
13956       if (cmdList->clientData != NULL) {
13957         result = GuardCall(object, interp, cmdList->clientData, cscPtr);
13958       } else {
13959         result = TCL_OK;
13960       }
13961 
13962       if (unlikely(result != TCL_OK)) {
13963         /*fprintf(stderr, "Filter GuardCall in invokeProc returned %d\n", result);*/
13964 
13965         if (likely(result != TCL_ERROR)) {
13966           /*
13967            * The guard failed (but no error), and we call "next".
13968            * Since we may not be in a method with already provided
13969            * arguments, we call next with the actual arguments and
13970            * perform no argument substitution.
13971            *
13972            * The call stack content is not jet pushed to the Tcl
13973            * stack, we pass it already to search-and-invoke.
13974            */
13975 
13976           /*fprintf(stderr, "... calling nextmethod cscPtr %p\n", cscPtr);*/
13977           result = NextSearchAndInvoke(interp, methodName, objc, objv, cscPtr, NSF_FALSE);
13978           /*fprintf(stderr, "... after nextmethod result %d\n", result);*/
13979         }
13980 
13981         /*
13982          * Next might have succeeded or not, but we are done. In the
13983          * NRE-case, we need a CscFinish for all return codes.
13984          */
13985 #if defined(NRE)
13986         CscFinish(interp, cscPtr, result, "guard failed");
13987 #endif
13988         return result;
13989       }
13990     }
13991   }
13992 
13993 #if defined(NSF_WITH_ASSERTIONS)
13994   opt = object->opt;
13995   if (unlikely(opt != NULL && (opt->checkoptions & CHECK_PRE)) &&
13996       (result = AssertionCheck(interp, object, class, methodName, CHECK_PRE)) == TCL_ERROR) {
13997     goto prep_done;
13998   }
13999 #endif
14000 
14001   /*
14002    *  If the method to be invoked has paramDefs, we have to call the
14003    *  argument parser with the argument definitions obtained from the
14004    *  proc context from the cmdPtr.
14005    */
14006   paramDefs = ParamDefsGet(cmdPtr, &checkAlwaysFlag, &execNsPtr);
14007 
14008   if (paramDefs != NULL && paramDefs->paramsPtr != NULL) {
14009 #if defined(NRE)
14010     pcPtr = (ParseContext *) NsfTclStackAlloc(interp, sizeof(ParseContext), "parse context");
14011 #endif
14012     result = ProcessMethodArguments(pcPtr, interp, object,
14013                                     checkAlwaysFlag|NSF_ARGPARSE_METHOD_PUSH|NSF_ARGPARSE_FORCE_REQUIRED,
14014                                     paramDefs, objv[0], objc, objv);
14015     cscPtr->objc = objc;
14016     cscPtr->objv = (Tcl_Obj **)objv;
14017 
14018     if (likely(result == TCL_OK)) {
14019       releasePc = NSF_TRUE;
14020       result = PushProcCallFrame(cp, interp, pcPtr->objc+1, pcPtr->full_objv, execNsPtr, cscPtr);
14021     } else {
14022       /*
14023        * some error occurred
14024        */
14025 #if defined(NRE)
14026       ParseContextRelease(pcPtr);
14027       NsfTclStackFree(interp, pcPtr, "parse context (proc prep failed)");
14028       pcPtr = NULL;
14029 #else
14030       ParseContextRelease(pcPtr);
14031 #endif
14032     }
14033   } else {
14034     /*if (execNsPtr == NULL) {
14035       fprintf(stderr, "PushProcCallFrame for %s without method arguments and empty execNsPtr %p\n",
14036               methodName, (void*)execNsPtr);
14037               }*/
14038     result = PushProcCallFrame(cp, interp, objc, objv, execNsPtr, cscPtr);
14039   }
14040 
14041   /*
14042    * The stack frame is pushed, we could do something here before
14043    * running the byte code of the body.
14044    */
14045 
14046   /* We could consider to run here ARG_METHOD or ARG_INITCMD
14047   if (likely(result == TCL_OK)) {
14048 
14049   }
14050   */
14051 
14052 #if defined(NSF_WITH_ASSERTIONS)
14053  prep_done:
14054 #endif
14055 
14056   if (likely(result == TCL_OK)) {
14057 #if defined(NRE)
14058     /*fprintf(stderr, "CALL TclNRInterpProcCore %s method '%s'\n",
14059       ObjectName(object), ObjStr(objv[0]));*/
14060     Tcl_NRAddCallback(interp, ProcMethodDispatchFinalize,
14061                       (releasePc ? pcPtr : NULL),
14062                       cscPtr,
14063                       (ClientData)methodName,
14064                       NULL);
14065     cscPtr->flags |= NSF_CSC_CALL_IS_NRE;
14066     result = TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
14067 #else
14068     ClientData data[3] = {
14069       (releasePc ? pcPtr : NULL),
14070       cscPtr,
14071       (ClientData)methodName
14072     };
14073 
14074     result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
14075     result = ProcMethodDispatchFinalize(data, interp, result);
14076 #endif
14077   } else /* result != OK */ {
14078 #if defined(NRE)
14079     CscFinish(interp, cscPtr, result, "nre, prep failed");
14080 #endif
14081   }
14082 
14083   return result;
14084 }
14085 
14086 /*
14087  *----------------------------------------------------------------------
14088  * CmdMethodDispatch --
14089  *
14090  *    Invoke a method implemented as a cmd.  Essentially it stacks
14091  *    optionally a frame, calls the method, pops the frame and runs
14092  *    invariants.
14093  *
14094  * Results:
14095  *    Tcl result code.
14096  *
14097  * Side effects:
14098  *    Indirect effects by calling cmd
14099  *
14100  *----------------------------------------------------------------------
14101  */
14102 static int CmdMethodDispatch(
14103     ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
14104     NsfObject *object, Tcl_Command cmd, NsfCallStackContent *cscPtr
14105 ) nonnull(2) nonnull(4) nonnull(5) nonnull(6);
14106 
14107 static int
CmdMethodDispatch(ClientData cp,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],NsfObject * object,Tcl_Command cmd,NsfCallStackContent * cscPtr)14108 CmdMethodDispatch(
14109     ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
14110     NsfObject *object, Tcl_Command cmd, NsfCallStackContent *cscPtr
14111 ) {
14112   CallFrame frame, *framePtr = &frame;
14113   int result;
14114 
14115   nonnull_assert(interp != NULL);
14116   nonnull_assert(objv != NULL);
14117   nonnull_assert(cmd != NULL);
14118   nonnull_assert(object != NULL);
14119 
14120   assert(object->teardown != NULL);
14121 
14122 #if defined(NRE)
14123   assert(!cscPtr || (cscPtr->flags & NSF_CSC_CALL_IS_NRE) == 0u);
14124 #endif
14125 
14126   if (cscPtr != NULL) {
14127     /*
14128      * We have a call-stack content, but the requested dispatch will not store
14129      * the call-stack content in a corresponding call-frame on its own. To get,
14130      * for example, self-introspection working for the requested dispatch, we
14131      * introduce a CMETHOD frame.
14132      */
14133     /*fprintf(stderr, "Nsf_PushFrameCsc %s %s\n", ObjectName(object), Tcl_GetCommandName(interp, cmd));*/
14134     Nsf_PushFrameCsc(interp, cscPtr, framePtr);
14135     result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmd), cp, objc, objv);
14136     Nsf_PopFrameCsc(interp, framePtr);
14137   } else {
14138     result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmd), cp, objc, objv);
14139   }
14140 
14141 #if defined(NSF_WITH_ASSERTIONS)
14142   if (unlikely(object->opt != NULL) && likely(result == TCL_OK)) {
14143     CheckOptions co = object->opt->checkoptions;
14144 
14145     if ((co & CHECK_INVAR)) {
14146       int rc = AssertionCheckInvars(interp, object, Tcl_GetCommandName(interp, cmd), co);
14147 
14148       if (rc != TCL_OK) {
14149         result = rc;
14150       }
14151     }
14152   }
14153 #endif
14154 
14155   /*
14156    * Reference counting in the calling ObjectDispatch() makes sure
14157    * that obj->opt is still accessible even after "dealloc"
14158    */
14159   return result;
14160 }
14161 
14162 /*
14163  *----------------------------------------------------------------------
14164  * ObjectCmdMethodDispatch --
14165  *
14166  *    Invoke a method implemented as an object. The referenced object is used
14167  *    as a source for methods to be executed.  Essentially this is currently
14168  *    primarily used to implement the dispatch of ensemble objects.
14169  *
14170  * Results:
14171  *    Tcl result code.
14172  *
14173  * Side effects:
14174  *    Indirect effects by calling cmd
14175  *
14176  *----------------------------------------------------------------------
14177  */
14178 
14179 static int ObjectCmdMethodDispatch(
14180     NsfObject *invokedObject, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
14181     const char *methodName, NsfObject *callerSelf, NsfCallStackContent *cscPtr
14182 ) nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6) nonnull(7);
14183 
14184 static int
ObjectCmdMethodDispatch(NsfObject * invokedObject,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],const char * methodName,NsfObject * callerSelf,NsfCallStackContent * cscPtr)14185 ObjectCmdMethodDispatch(
14186     NsfObject *invokedObject, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
14187     const char *methodName, NsfObject *callerSelf, NsfCallStackContent *cscPtr
14188 ) {
14189   CallFrame    frame, *framePtr = &frame;
14190   Tcl_Command  cmd, subMethodCmd;
14191   const char  *subMethodName;
14192   NsfObject   *actualSelf;
14193   NsfClass    *actualClass;
14194   int          result;
14195 
14196   nonnull_assert(invokedObject != NULL);
14197   nonnull_assert(interp != NULL);
14198   nonnull_assert(objv != NULL);
14199   nonnull_assert(methodName != NULL);
14200   nonnull_assert(callerSelf != NULL);
14201   nonnull_assert(cscPtr != NULL);
14202 
14203   cmd = cscPtr->cmdPtr;
14204   /*fprintf(stderr, "ObjectCmdMethodDispatch %p %s\n", cmd, Tcl_GetCommandName(interp, cmd));*/
14205   /*fprintf(stderr, "ObjectCmdMethodDispatch method %s invokedObject %p %s callerSelf %p %s\n",
14206           methodName, invokedObject, ObjectName(invokedObject),
14207           callerSelf, ObjectName(callerSelf));*/
14208 
14209   if (unlikely((invokedObject->flags & NSF_DELETED) != 0u)) {
14210     /*
14211      * When we try to invoke a deleted object, the cmd (alias) is
14212      * automatically removed. Note that the cmd might be still referenced
14213      * in various entries in the call-stack. The reference counting on
14214      * these elements takes care that the cmdPtr is deleted on a pop
14215      * operation (although we do a Tcl_DeleteCommandFromToken() below.
14216      */
14217 
14218     /*fprintf(stderr, "methodName %s found DELETED object with cmd %p my cscPtr %p\n",
14219       methodName, cmd, cscPtr);*/
14220 
14221     Tcl_DeleteCommandFromToken(interp, cmd);
14222     if (cscPtr->cl != NULL) {
14223       NsfInstanceMethodEpochIncr("DeleteObjectAlias");
14224     } else {
14225       NsfObjectMethodEpochIncr("DeleteObjectAlias");
14226     }
14227 
14228     NsfCleanupObject(invokedObject, "alias-delete1");
14229     return NsfPrintError(interp, "trying to dispatch deleted object via method '%s'",
14230                          methodName);
14231   }
14232 
14233   /*
14234    * Check whether the object cmd was called without a reference to a
14235    * method. If so, perform the standard dispatch of default methods.
14236    */
14237   if (unlikely(objc < 2)) {
14238 
14239     if ((invokedObject->flags & NSF_PER_OBJECT_DISPATCH) != 0u) {
14240       cscPtr->flags |= NSF_CSC_CALL_IS_ENSEMBLE;
14241     }
14242     Nsf_PushFrameCsc(interp, cscPtr, framePtr);
14243     result = DispatchDefaultMethod(interp, invokedObject, objv[0], NSF_CSC_IMMEDIATE);
14244     Nsf_PopFrameCsc(interp, framePtr);
14245     return result;
14246   }
14247 
14248   /*
14249    * Check whether we want NSF_KEEP_CALLER_SELF. The setting of this flag
14250    * determines the values of actualSelf and actualClass.
14251    */
14252   if ((invokedObject->flags & NSF_KEEP_CALLER_SELF) != 0u) {
14253     actualSelf = callerSelf;
14254     actualClass = cscPtr->cl;
14255   } else {
14256     actualSelf = invokedObject;
14257     actualClass = NULL;
14258   }
14259   subMethodName = ObjStr(objv[1]);
14260 
14261   if ((invokedObject->flags & NSF_PER_OBJECT_DISPATCH) == 0u) {
14262     /*fprintf(stderr, "invokedObject %p %s methodName %s: no perobjectdispatch\n",
14263       invokedObject, ObjectName(invokedObject), methodName);*/
14264 #if 0
14265     /*
14266      * We should have either an approach
14267      *  - to obtain from an object to methodname the cmd, and
14268      *    call e.g. MethodDispatch(), or pass a fully qualified
14269      *     method name, or
14270      *  - to pass the actualSelf and invokedObject both
14271      *    to MethodDispatch/MethodDispatch
14272      *  TODO: maybe remove NSF_CM_KEEP_CALLER_SELF when done.
14273      */
14274     result = MethodDispatch(interp, nobjc+1, nobjv-1, cmd, object,
14275                             NULL /*NsfClass *cl*/,
14276                             Tcl_GetCommandName(interp, cmd),
14277                             NSF_CSC_TYPE_PLAIN, flags);
14278 #endif
14279 #if 1
14280     /*
14281      * Simple and brutal.
14282      */
14283     if (likely(invokedObject->nsPtr != NULL)) {
14284       subMethodCmd = FindMethod(invokedObject->nsPtr, subMethodName);
14285     } else {
14286       subMethodCmd = NULL;
14287     }
14288 
14289     if (subMethodCmd == NULL) {
14290       /*
14291        * no -system handling.
14292        */
14293       actualClass = SearchPLMethod(invokedObject->cl->order, subMethodName, &subMethodCmd,
14294                                    NSF_CMD_CALL_PRIVATE_METHOD);
14295     }
14296     if (likely(subMethodCmd != NULL)) {
14297       cscPtr->objc = objc;
14298       cscPtr->objv = objv;
14299       Nsf_PushFrameCsc(interp, cscPtr, framePtr);
14300       result = MethodDispatch(interp, objc-1, objv+1,
14301                               subMethodCmd, actualSelf, actualClass, subMethodName,
14302                               cscPtr->frameType|NSF_CSC_TYPE_ENSEMBLE,
14303                               (cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE);
14304       Nsf_PopFrameCsc(interp, framePtr);
14305       return result;
14306     }
14307 
14308   /*fprintf(stderr, "... objv[0] %s cmd %p %s csc %p\n",
14309     ObjStr(objv[0]), subMethodCmd, subMethodName, cscPtr); */
14310 
14311 #endif
14312     return ObjectDispatch(actualSelf, interp, objc, objv, NSF_CM_KEEP_CALLER_SELF);
14313   }
14314 
14315   /*
14316    * NSF_PER_OBJECT_DISPATCH is set
14317    */
14318 
14319   if (likely(invokedObject->nsPtr != NULL)) {
14320     subMethodCmd = FindMethod(invokedObject->nsPtr, subMethodName);
14321   } else {
14322     subMethodCmd = NULL;
14323   }
14324 
14325 #if 1
14326   if (subMethodCmd != NULL) {
14327     unsigned int cmdFlags = (unsigned int)Tcl_Command_flags(subMethodCmd);
14328 
14329     if ((cscPtr->flags & (NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0u &&
14330         (cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u) {
14331       subMethodCmd = NULL;
14332     } else if (unlikely((cmdFlags & NSF_CMD_CALL_PROTECTED_METHOD) != 0u)) {
14333       const NsfObject *lastSelf;
14334       Tcl_CallFrame   *framePtr0;
14335       bool             withinEnsemble = ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u);
14336 
14337       if (withinEnsemble) {
14338         Tcl_CallFrame *framePtr1;
14339 
14340         /* Alternatively: (void)NsfCallStackFindLastInvocation(interp, 0, &framePtr1); */
14341         (void)CallStackGetTopFrame(interp, &framePtr0);
14342         (void)CallStackFindEnsembleCsc(framePtr0, &framePtr1);
14343         /* NsfShowStack(interp);
14344            fprintf(stderr, "framePtr %p\n", framePtr1);*/
14345         if (framePtr1 != NULL) {
14346           lastSelf = GetSelfObj2(interp, framePtr1);
14347         } else {
14348           lastSelf = NULL;
14349         }
14350       } else {
14351         lastSelf = GetSelfObj(interp);
14352       }
14353 
14354 
14355       /* fprintf(stderr, "'%s (%s) == %s == %s? for %s\n", lastSelf != NULL ? ObjectName(lastSelf): "n/a",
14356               ObjectName(GetSelfObj(interp)), ObjectName(actualSelf), ObjectName(invokedObject), subMethodName); */
14357 
14358       if (actualSelf != lastSelf) {
14359         const char *path;
14360         Tcl_Obj *pathObj = NULL;
14361 
14362         if (withinEnsemble) {
14363           pathObj = NsfMethodNamePath(interp, framePtr0, methodName);
14364           INCR_REF_COUNT(pathObj);
14365           path = ObjStr(pathObj);
14366         } else {
14367           path = methodName;
14368         }
14369 
14370         NsfLog(interp, NSF_LOG_WARN, "'%s %s %s' fails since method %s.%s %s is protected",
14371                ObjectName(actualSelf), path, subMethodName, (actualClass != NULL) ?
14372                ClassName(actualClass) : ObjectName(actualSelf), path, subMethodName);
14373 
14374         subMethodCmd = NULL;
14375         if (pathObj != NULL) {
14376           DECR_REF_COUNT(pathObj);
14377         }
14378       }
14379     }
14380   }
14381 #endif
14382 
14383 
14384   /*
14385    * Make sure that the current call is marked as an ensemble call, both
14386    * for dispatching to the default-method and for dispatching the method
14387    * interface of the given object. Otherwise, current introspection
14388    * specific to sub-methods fails (e.g., a [current method-path] in the
14389    * default-method).
14390    */
14391   cscPtr->flags |= NSF_CSC_CALL_IS_ENSEMBLE;
14392 
14393   /* fprintf(stderr, "ensemble dispatch cp %s %s objc %d\n",
14394      ObjectName((NsfObject*)cp), methodName, objc);*/
14395 
14396   cscPtr->objc = objc;
14397   cscPtr->objv = objv;
14398   Nsf_PushFrameCsc(interp, cscPtr, framePtr);
14399 
14400   /*fprintf(stderr, "... objv[0] %s cmd %p %s csc %p\n",
14401     ObjStr(objv[0]), subMethodCmd, subMethodName, cscPtr); */
14402 
14403   if (likely(subMethodCmd != NULL)) {
14404     /*
14405      * In order to allow [next] to be called in an ensemble method,
14406      * an extra call-frame is needed. This CSC frame is typed as
14407      * NSF_CSC_TYPE_ENSEMBLE. Note that the associated call is flagged
14408      * additionally (NSF_CSC_CALL_IS_ENSEMBLE; see above) to be able
14409      * to identify ensemble-specific frames during [next] execution.
14410      *
14411      * The dispatch requires NSF_CSC_IMMEDIATE to be set, ensuring
14412      * that scripted methods are executed before the ensemble ends. If
14413      * they were executed later, they would find their parent frame
14414      * (CMETHOD) being popped from the stack already.
14415      */
14416 
14417     /*fprintf(stderr, ".... ensemble dispatch object %s self %s pass %s\n",
14418       ObjectName(invokedObject), ObjectName(actualSelf), (actualSelf->flags & NSF_KEEP_CALLER_SELF) ? "callerSelf" : "invokedObject");
14419       fprintf(stderr, ".... ensemble dispatch on %s.%s objflags %.8x cscPtr %p base flags %.6x flags %.6x cl %s\n",
14420       ObjectName(actualSelf), subMethodName, actualSelf->flags,
14421       cscPtr, (0xFF & cscPtr->flags), (cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE, (actualClass != NULL) ? ClassName(actualClass) : "NONE");*/
14422     result = MethodDispatch(interp, objc-1, objv+1,
14423                             subMethodCmd, actualSelf, actualClass, subMethodName,
14424                             cscPtr->frameType|NSF_CSC_TYPE_ENSEMBLE,
14425                             (cscPtr->flags & 0xFF)|NSF_CSC_IMMEDIATE);
14426     /*if (unlikely(result != TCL_OK)) {
14427       fprintf(stderr, "ERROR: cmd %p %s subMethodName %s -- %s -- %s\n",
14428       subMethodCmd, Tcl_GetCommandName(interp, subMethodCmd), subMethodName,
14429       Tcl_GetCommandName(interp, cscPtr->cmdPtr), ObjStr(Tcl_GetObjResult(interp)));
14430       }*/
14431 
14432   } else {
14433     /*
14434      * The method to be called was not part of this ensemble. Call
14435      * next to try to call such methods along the next path.
14436      */
14437     Tcl_CallFrame       *framePtr1;
14438     NsfCallStackContent *cscPtr1 = CallStackGetTopFrame(interp, &framePtr1);
14439 
14440     /*fprintf(stderr, "call next instead of unknown %s.%s \n",
14441       ObjectName(cscPtr->self), methodName);*/
14442 
14443     assert(cscPtr1 != NULL);
14444     if ((cscPtr1->frameType & NSF_CSC_TYPE_ENSEMBLE)) {
14445       /*
14446        * We are in an ensemble method. The next works here not on the
14447        * actual methodName + frame, but on the ensemble above it. We
14448        * locate the appropriate call-stack content and continue next on
14449        * that.
14450        */
14451       cscPtr1 = CallStackFindEnsembleCsc(framePtr1, &framePtr1);
14452       assert(cscPtr1 != NULL);
14453     }
14454 
14455     /*
14456      * We mark in the flags that we are in an ensemble but failed so far to
14457      * resolve the cmd. Now we try to resolve the unknown subcmd via next and
14458      * we record this in the flags. The method name for next might be
14459      * colon-prefixed. In these cases, we have to skip the single colon with
14460      * the MethodName() function.
14461      */
14462     cscPtr1->flags |= NSF_CM_ENSEMBLE_UNKNOWN;
14463     /*fprintf(stderr, "==> trying to find <%s> in ensemble <%s> via next\n",
14464       subMethodName, MethodName(cscPtr1->objv[0]));*/
14465     result = NextSearchAndInvoke(interp, MethodName(cscPtr1->objv[0]),
14466                                  cscPtr1->objc, cscPtr1->objv, cscPtr1, NSF_FALSE);
14467 
14468     /*fprintf(stderr, "==> next %s.%s subMethodName %s (obj %s) cscPtr %p (flags %.8x)) cscPtr1 %p (flags %.8x) result %d unknown %d\n",
14469             ObjectName(callerSelf), methodName, subMethodName, ObjectName(invokedObject),
14470             (void*)cscPtr, cscPtr->flags, (void*)cscPtr1, (cscPtr1 != NULL) ? cscPtr1->flags : 0,
14471             result, RUNTIME_STATE(interp)->unknown);*/
14472 
14473     if (RUNTIME_STATE(interp)->unknown) {
14474       Tcl_Obj       *callInfoObj = Tcl_NewListObj(1, &callerSelf->cmdName);
14475       Tcl_CallFrame *varFramePtr, *tclFramePtr = CallStackGetTclFrame(interp, (Tcl_CallFrame *)framePtr, 1);
14476       int            pathLength, pathLength0 = 0, unknownIndex;
14477       Tcl_Obj       *pathObj = NsfMethodNamePath(interp, tclFramePtr, MethodName(objv[0]));
14478       bool           getPath = NSF_TRUE;
14479 
14480       INCR_REF_COUNT(pathObj);
14481 
14482       /*
14483        * The "next" call could not resolve the unknown subcommand. At this
14484        * point, potentially serval different ensembles were tried, which can
14485        * be found on the stack.
14486        *
14487        * Example1:  call: foo a b d
14488        *    mixin:  foo a b c
14489        *    object: foo a x
14490        *
14491        * We want to return the longest, most precise prefix (here "foo a b")
14492        * and flag "d" as unknown (here the mixin frame). Another (inferior)
14493        * solution would be to report "foo a" as know prefix and "b d" as
14494        * unknown (when the error is generated from the point of view of the
14495        * object method frame).
14496        *
14497        * In the general case, we traverse the stack for all ensembles and pick
14498        * the longest known ensemble for reporting. This path is passed to the
14499        * unknown-handler of the ensemble.
14500        */
14501 
14502       Tcl_ListObjLength(interp, pathObj, &pathLength0);
14503       pathLength = pathLength0;
14504 
14505       for (varFramePtr = (Tcl_CallFrame *)framePtr; likely(varFramePtr != NULL);
14506            varFramePtr = Tcl_CallFrame_callerVarPtr(varFramePtr)) {
14507         const NsfCallStackContent *stackCscPtr;
14508 
14509         /*
14510          * If we reach a non-nsf frame, or it is not an ensemble, we are done.
14511          */
14512         stackCscPtr =
14513           (((unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) ?
14514           ((NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr)) : NULL;
14515         if (stackCscPtr == NULL || (stackCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0u) {
14516           break;
14517         }
14518         /*
14519          * Every ensemble block starts with a frame of
14520          * NSF_CSC_TYPE_ENSEMBLE. If we find one, then we compute a new path
14521          * in the next iteration.
14522          */
14523         if ((stackCscPtr->frameType & (NSF_CSC_TYPE_ENSEMBLE)) == 0) {
14524           /*
14525            * Get method path the next round.
14526            */
14527           getPath = NSF_TRUE;
14528         } else if (getPath) {
14529           int      pathLength1;
14530           Tcl_Obj *pathObj1 = CallStackMethodPath(interp, varFramePtr);
14531 
14532           INCR_REF_COUNT(pathObj1);
14533           getPath = NSF_FALSE;
14534           Tcl_ListObjLength(interp, pathObj1, &pathLength1);
14535           if (pathLength1 > pathLength) {
14536             if (pathObj != NULL) {
14537               DECR_REF_COUNT(pathObj);
14538             }
14539             pathObj    = pathObj1;
14540             pathLength = pathLength1;
14541           } else {
14542             DECR_REF_COUNT(pathObj1);
14543           }
14544         }
14545       }
14546 
14547       unknownIndex = pathLength <= pathLength0 ? 1 : 1 + pathLength - pathLength0;
14548       assert(objc > unknownIndex);
14549 
14550       INCR_REF_COUNT(callInfoObj);
14551       Tcl_ListObjAppendList(interp, callInfoObj, pathObj);
14552       Tcl_ListObjAppendElement(interp, callInfoObj, objv[unknownIndex]);
14553 
14554       /* fprintf(stderr, "DispatchUnknownMethod is called with callinfo <%s> (callerSelf <%s>, methodName '%s', methodPath '%s')\n",
14555               ObjStr(callInfoObj), ObjStr(callerSelf->cmdName), MethodName(objv[0]),
14556               ObjStr(callInfoObj)); */
14557       result = DispatchUnknownMethod(interp, invokedObject, objc-1, objv+1, callInfoObj,
14558                                      objv[1], NSF_CM_NO_OBJECT_METHOD|NSF_CSC_IMMEDIATE);
14559       DECR_REF_COUNT(callInfoObj);
14560       DECR_REF_COUNT(pathObj);
14561     }
14562   }
14563   Nsf_PopFrameCsc(interp, framePtr);
14564 
14565   return result;
14566 }
14567 
14568 #if !defined(NSF_ASSEMBLE)
NsfAsmProc(ClientData UNUSED (clientData),Tcl_Interp * UNUSED (interp),int UNUSED (objc),Tcl_Obj * const UNUSED (objv[]))14569 static int NsfAsmProc(ClientData UNUSED(clientData), Tcl_Interp *UNUSED(interp),
14570                       int UNUSED(objc), Tcl_Obj *const UNUSED(objv[])) {
14571   return TCL_OK;
14572 }
14573 #endif
14574 
14575 
14576 /*
14577  *----------------------------------------------------------------------
14578  * CheckCStack --
14579  *
14580  *    Monitor the growth of the C Stack when complied with
14581  *    NSF_STACKCHECK.
14582  *
14583  * Results:
14584  *    none
14585  *
14586  * Side effects:
14587  *    update of rst->bottomOfStack
14588  *
14589  *----------------------------------------------------------------------
14590  */
14591 #if defined(NSF_STACKCHECK)
14592 NSF_INLINE static void CheckCStack(Tcl_Interp *interp, const char *prefix, const char *fullMethodName)
14593   nonnull(1) nonnull(2) nonnull(3);
14594 
14595 NSF_INLINE static void
CheckCStack(Tcl_Interp * interp,const char * prefix,const char * fullMethodName)14596 CheckCStack(Tcl_Interp *interp, const char *prefix, const char *fullMethodName) {
14597   int somevar;
14598   NsfRuntimeState *rst = RUNTIME_STATE(interp);
14599 
14600   nonnull_assert(interp != NULL);
14601   nonnull_assert(prefix != NULL);
14602   nonnull_assert(fullMethodName != NULL);
14603 
14604   if (rst->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
14605 # if TCL_STACK_GROWS_UP
14606     if ((void *)&somevar < rst->bottomOfStack) {
14607       NsfLog(interp, NSF_LOG_WARN, "Stack adjust bottom %ld - %s %s",
14608              (void *)&somevar - rst->bottomOfStack, prefix, fullMethodName);
14609       rst->bottomOfStack = (void *)&somevar;
14610     } else if ((void *)&somevar > rst->maxStack) {
14611       NsfLog(interp, NSF_LOG_WARN, "Stack adjust top %ld - %s %s",
14612              (void *)&somevar - rst->bottomOfStack, prefix, fullMethodName);
14613       rst->maxStack = (void *)&somevar;
14614     }
14615 # else
14616     if ((void *)&somevar > rst->bottomOfStack) {
14617       NsfLog(interp, NSF_LOG_WARN, "Stack adjust bottom %ld - %s %s",
14618              rst->bottomOfStack - (void *)&somevar, prefix, fullMethodName);
14619       rst->bottomOfStack = (void *)&somevar;
14620     } else if ((void *)&somevar < rst->maxStack) {
14621       NsfLog(interp, NSF_LOG_WARN, "Stack adjust top %ld - %s %s",
14622              rst->bottomOfStack - (void *)&somevar, prefix, fullMethodName);
14623       rst->maxStack = (void *)&somevar;
14624     }
14625 # endif
14626   }
14627 }
14628 #else
14629 # define CheckCStack(interp, prefix, methodName)
14630 #endif
14631 
14632 /*
14633  *----------------------------------------------------------------------
14634  * MethodDispatchCsc --
14635  *
14636  *    Dispatch a method (scripted or cmd) with an already allocated
14637  *    call stack content. The method calls either ProcMethodDispatch()
14638  *    (for scripted methods) or CmdMethodDispatch() (otherwise).
14639  *
14640  * Results:
14641  *    Tcl result code.
14642  *
14643  * Side effects:
14644  *    Indirect effects by calling methods
14645  *
14646  *----------------------------------------------------------------------
14647  */
14648 static int MethodDispatchCsc(
14649     ClientData clientData, Tcl_Interp *interp,
14650     int objc, Tcl_Obj *const objv[],
14651     Tcl_Command cmd,
14652     NsfCallStackContent *cscPtr,
14653     const char *methodName,
14654     bool *validCscPtr
14655 ) nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8);
14656 
14657 static int
MethodDispatchCsc(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],Tcl_Command cmd,NsfCallStackContent * cscPtr,const char * methodName,bool * validCscPtr)14658 MethodDispatchCsc(
14659     ClientData clientData, Tcl_Interp *interp,
14660     int objc, Tcl_Obj *const objv[],
14661     Tcl_Command cmd,
14662     NsfCallStackContent *cscPtr,
14663     const char *methodName,
14664     bool *validCscPtr
14665 ) {
14666   NsfObject           *object;
14667   ClientData           cp;
14668   Tcl_ObjCmdProc      *proc;
14669   NsfCallStackContent *cscPtr1;
14670 
14671   nonnull_assert(clientData != NULL);
14672   nonnull_assert(interp != NULL);
14673   nonnull_assert(objv != NULL);
14674   nonnull_assert(cmd != NULL);
14675   nonnull_assert(cscPtr != NULL);
14676   nonnull_assert(methodName != NULL);
14677   nonnull_assert(validCscPtr != NULL);
14678 
14679   cp = Tcl_Command_objClientData(cmd);
14680   proc = Tcl_Command_objProc(cmd);
14681   object = cscPtr->self;
14682 
14683   /*
14684    * Provide DTrace with calling info
14685    */
14686   if (NSF_DTRACE_METHOD_ENTRY_ENABLED()) {
14687     NSF_DTRACE_METHOD_ENTRY(ObjectName(object), (cscPtr->cl != NULL) ? ClassName(cscPtr->cl) : ObjectName(object),
14688                             (char *)methodName,
14689                             objc-1, (Tcl_Obj **)objv+1);
14690   }
14691   if (unlikely(((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_DEPRECATED_METHOD) != 0u)) {
14692     NsfProfileDeprecatedCall(interp, object, cscPtr->cl, methodName, "");
14693   }
14694   if (unlikely(((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_DEBUG_METHOD) != 0u)) {
14695     NsfProfileDebugCall(interp, object, cscPtr->cl, methodName, objc-1, (Tcl_Obj **)objv+1);
14696   }
14697 
14698   /*fprintf(stderr, "MethodDispatch method '%s' cmd %p %s clientData %p cp=%p objc=%d cscPtr %p csc->flags %.6x \n",
14699           methodName, cmd, Tcl_GetCommandName(interp, cmd), clientData,
14700           cp, objc, cscPtr, cscPtr->flags);*/
14701   /*fprintf(stderr, "MethodDispatch method '%s' cmd %p cp=%p objc=%d cscPtr %p csc->flags %.6x "
14702           "obj->flags %.6x teardown %p\n",
14703           methodName, cmd, cp, objc, cscPtr, cscPtr->flags, object->flags, object->teardown);*/
14704   assert(object->teardown != NULL);
14705 
14706   /*
14707    * The default assumption is that the CscPtr is valid after this function
14708    * finishes.
14709    */
14710 
14711   if (likely(proc == TclObjInterpProc)) {
14712     int           result;
14713 #if defined(NRE)
14714     NRE_callback *rootPtr = TOP_CB(interp);
14715     int           isImmediate = (cscPtr->flags & NSF_CSC_IMMEDIATE);
14716 # if defined(NRE_CALLBACK_TRACE)
14717     NsfClass     *class = cscPtr->cl;
14718 # endif
14719 #endif
14720     /*
14721      * The cmd is a scripted method
14722      */
14723 
14724     result = ProcMethodDispatch(cp, interp, objc, objv, methodName,
14725                                 object, cscPtr->cl, cmd, cscPtr);
14726 #if defined(NRE)
14727     /*
14728      * In the NRE case, there is no trust in the cscPtr anymore, it might be already gone.
14729      */
14730     *validCscPtr = NSF_FALSE;
14731 
14732     if (unlikely(isImmediate)) {
14733 # if defined(NRE_CALLBACK_TRACE)
14734       fprintf(stderr, ".... manual run callbacks rootPtr = %p, result %d methodName %s.%s\n",
14735               rootPtr, result, ClassName(class), methodName);
14736 # endif
14737       result = NsfNRRunCallbacks(interp, result, rootPtr);
14738     } else {
14739 # if defined(NRE_CALLBACK_TRACE)
14740       fprintf(stderr, ".... don't run callbacks rootPtr = %p, result %d methodName %s.%s\n",
14741               rootPtr, result, ClassName(class), methodName);
14742 # endif
14743     }
14744 #endif
14745     /*
14746      * scripted method done
14747      */
14748     return result;
14749 
14750   } else if (proc == NsfObjDispatch) {
14751 
14752     assert(cp != NULL);
14753     return ObjectCmdMethodDispatch((NsfObject *)cp, interp, objc, objv,
14754                                    methodName, object, cscPtr);
14755 
14756   } else if (cp != NULL) {
14757 
14758     cscPtr1 = cscPtr;
14759 
14760     /*fprintf(stderr, "cscPtr %p cmd %p %s want to stack cmd %p %s cp %p no-leaf %d force frame %d\n",
14761             cscPtr, cmd, Tcl_GetCommandName(interp, cmd),
14762             cmd, Tcl_GetCommandName(interp, cmd),
14763             cp,
14764             (Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD),
14765             (cscPtr->flags & NSF_CSC_FORCE_FRAME));*/
14766     /*
14767      * The cmd has client data, we check for required updates in this
14768      * structure.
14769      */
14770 
14771     if (proc == NsfForwardMethod ||
14772         proc == NsfObjscopedMethod ||
14773         proc == NsfSetterMethod ||
14774         proc == NsfAsmProc
14775         ) {
14776       TclCmdClientData *tcd = (TclCmdClientData *)cp;
14777 
14778       assert(tcd != NULL);
14779       tcd->object = object;
14780       assert(!CmdIsProc(cmd));
14781 
14782     } else if (cp == (ClientData)NSF_CMD_NONLEAF_METHOD) {
14783       cp = clientData;
14784       assert(!CmdIsProc(cmd));
14785 
14786     }
14787 #if !defined(NDEBUG)
14788     else if (proc == NsfProcAliasMethod) {
14789       /*
14790        * This should never happen!
14791        */
14792       Tcl_Panic("Alias invoked in unexpected way");
14793     }
14794 #endif
14795 
14796 
14797   } else if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD) != 0u
14798              || ((cscPtr->flags & NSF_CSC_FORCE_FRAME) != 0u)) {
14799     /*
14800      * Technically, we would not need a frame to execute the cmd, but maybe,
14801      * the user wants it (to be able to call next, or the keep proc-level
14802      * variables. The clientData cp is in such cases typically NULL.
14803      */
14804     /*fprintf(stderr, "FORCE_FRAME\n");*/
14805     cscPtr1 = cscPtr;
14806 
14807   } else {
14808     /*
14809      * There is no need to pass a frame. Use the original clientData.
14810      */
14811     cscPtr1 = NULL;
14812   }
14813 
14814   if (cscPtr1 != NULL) {
14815     /*
14816      * Call with a stack frame.
14817      */
14818 
14819     /*fprintf(stderr, "cmdMethodDispatch %s.%s, cscPtr %p objflags %.6x\n",
14820       ObjectName(object), methodName, cscPtr, object->flags); */
14821 
14822     return CmdMethodDispatch(cp, interp, objc, objv, object, cmd, cscPtr1);
14823   } else {
14824     /*
14825      * Call without a stack frame.
14826      */
14827     CscListAdd(interp, cscPtr);
14828 
14829     /*fprintf(stderr, "cmdMethodDispatch %p %s.%s, nothing stacked, objflags %.6x\n",
14830       cmd, ObjectName(object), methodName, object->flags); */
14831 
14832     return CmdMethodDispatch(clientData, interp, objc, objv, object, cmd, NULL);
14833   }
14834 }
14835 
14836 /*
14837  *----------------------------------------------------------------------
14838  * MethodDispatch --
14839  *
14840  *    Convenience wrapper for MethodDispatchCsc(). It allocates a call
14841  *    stack content and invokes MethodDispatchCsc.
14842  *
14843  * Results:
14844  *    Tcl result code.
14845  *
14846  * Side effects:
14847  *    Indirect effects by calling methods
14848  *
14849  *----------------------------------------------------------------------
14850  */
14851 static int
MethodDispatch(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],Tcl_Command cmd,NsfObject * object,NsfClass * class,const char * methodName,unsigned short frameType,unsigned int flags)14852 MethodDispatch(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
14853                Tcl_Command cmd, NsfObject *object, NsfClass *class,
14854                const char *methodName, unsigned short frameType, unsigned int flags) {
14855   NsfCallStackContent csc, *cscPtr;
14856   bool                isValidCsc = NSF_TRUE;
14857   Tcl_Command         resolvedCmd;
14858   int                 result;
14859 
14860   nonnull_assert(interp != NULL);
14861   nonnull_assert(objv != NULL);
14862   nonnull_assert(cmd != NULL);
14863   nonnull_assert(object != NULL);
14864   nonnull_assert(methodName != NULL);
14865 
14866   assert(object->teardown != NULL);
14867 
14868   CheckCStack(interp, "method", methodName);
14869 
14870   /*fprintf(stderr, "MethodDispatch method '%s.%s' objc %d flags %.6x\n",
14871     ObjectName(object), methodName, objc, flags); */
14872 
14873   resolvedCmd = AliasDereference(interp, object, methodName, cmd);
14874   if (unlikely(resolvedCmd == NULL)) {
14875     return TCL_ERROR;
14876   }
14877 
14878   /*
14879    * cscAlloc uses for resolvedCmd for allocating the call stack content and
14880    * sets the IS_NRE flag based on it. We use the original cmd in the
14881    * call-stack content structure for introspection.
14882    */
14883   cscPtr = CscAlloc(interp, &csc, resolvedCmd);
14884 
14885   /*
14886    * We would not need CscInit when cp (clientData) == NULL &&
14887    * !(Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD) TODO: We could pass
14888    * cmd == NULL, but is this worth it?
14889    */
14890   CscInit(cscPtr, object, class, cmd, frameType, flags, methodName);
14891 
14892   result = MethodDispatchCsc(object, interp, objc, objv,
14893                              resolvedCmd, cscPtr, methodName, &isValidCsc);
14894 
14895 #if defined(NRE)
14896   if (isValidCsc) {
14897     CscListRemove(interp, cscPtr, NULL);
14898     CscFinish(interp, cscPtr, result, "csc cleanup");
14899   }
14900 #else
14901   CscListRemove(interp, cscPtr, NULL);
14902   CscFinish(interp, cscPtr, result, "csc cleanup");
14903 #endif
14904 
14905   return result;
14906 }
14907 
14908 /*
14909  *----------------------------------------------------------------------
14910  * ObjectDispatchFinalize --
14911  *
14912  *    Finalization function for ObjectDispatch() which performs method
14913  *    lookup and call all kind of methods. The function runs after
14914  *    ObjectDispatch() and calls the unknown handler if necessary and
14915  *    resets the filter and mixin stacks.
14916  *
14917  * Results:
14918  *    Tcl result code.
14919  *
14920  * Side effects:
14921  *    Maybe side effects by the cmd called by ParameterCheck()
14922  *    or DispatchUnknownMethod()
14923  *
14924  *----------------------------------------------------------------------
14925  */
14926 NSF_INLINE static int ObjectDispatchFinalize(Tcl_Interp *interp, NsfCallStackContent *cscPtr,
14927                                              int result /*, char *msg, const char *methodName*/)
14928   nonnull(1) nonnull(2);
14929 
14930 NSF_INLINE static int
ObjectDispatchFinalize(Tcl_Interp * interp,NsfCallStackContent * cscPtr,int result)14931 ObjectDispatchFinalize(Tcl_Interp *interp, NsfCallStackContent *cscPtr,
14932                        int result /*, char *msg, const char *methodName*/) {
14933   const NsfRuntimeState *rst;
14934   NsfObject             *object;
14935   unsigned int           flags;
14936 
14937   nonnull_assert(interp != NULL);
14938   nonnull_assert(cscPtr != NULL);
14939 
14940   object = cscPtr->self;
14941   assert(object != NULL);
14942   assert(object->id != NULL);
14943 
14944   flags = cscPtr->flags;
14945   rst = RUNTIME_STATE(interp);
14946 
14947   /*fprintf(stderr, "ObjectDispatchFinalize %p %s flags %.6x (%d) frame %.6x unk %d m %s\n",
14948           (void*)cscPtr, ObjectName(object), flags,
14949           result, cscPtr->frameType, RUNTIME_STATE(interp)->unknown,
14950           (cscPtr->cmdPtr != NULL) ? Tcl_GetCommandName(interp, cscPtr->cmdPtr) : "");*/
14951 
14952   /*
14953    * Check the return value if wanted
14954    */
14955   if (likely((result == TCL_OK)
14956              && (cscPtr->cmdPtr != NULL)
14957              && (Tcl_Command_cmdEpoch(cscPtr->cmdPtr) == 0))) {
14958     Tcl_Obj *returnsObj = ParamDefsGetReturns(cscPtr->cmdPtr);
14959 
14960     if (returnsObj != NULL) {
14961       NsfObject     *ctxObject = (cscPtr->cl != NULL) ? (NsfObject *)cscPtr->cl : object;
14962       Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(ctxObject->id);
14963       Tcl_Obj       *valueObj = Tcl_GetObjResult(interp);
14964 
14965       result = ParameterCheck(interp, returnsObj, valueObj, "return-value:",
14966                               rst->doCheckResults, NSF_FALSE, NSF_FALSE, NULL,
14967                               nsPtr != NULL ? nsPtr->fullName : NULL);
14968     }
14969   } else {
14970     /*fprintf(stderr, "We have no cmdPtr in cscPtr %p %s",  cscPtr, ObjectName(object));
14971     fprintf(stderr, "... cannot check return values!\n");*/
14972   }
14973 
14974 
14975   /*
14976    * On success (no error occurred) check for unknown cases.
14977    */
14978   if (likely(result == TCL_OK)) {
14979 
14980     /*
14981      * When triggered via filter, we might have cases with NRE, where the
14982      * filter is called from a filter, leading to an unknown cscPtr->objv);
14983      * however, there is no need to dispatch in such a case the unknown method.
14984      */
14985     if (unlikely(((flags & NSF_CSC_METHOD_IS_UNKNOWN) != 0u)
14986                  || ((cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) && rst->unknown && (cscPtr->objv != NULL))
14987                  )) {
14988       result = DispatchUnknownMethod(interp, object,
14989                                      cscPtr->objc, cscPtr->objv, NULL, cscPtr->objv[0],
14990                                      (cscPtr->flags & NSF_CSC_CALL_NO_UNKNOWN)|NSF_CSC_IMMEDIATE);
14991     }
14992   }
14993 
14994   /*
14995    * Resetting mixin and filter stacks
14996    */
14997 
14998   if (unlikely((flags & NSF_CSC_MIXIN_STACK_PUSHED) && object->mixinStack != NULL) != 0u) {
14999     /* fprintf(stderr, "MixinStackPop %s.%s %p %s\n",
15000        ObjectName(object), methodName, object->mixinStack, msg);*/
15001     MixinStackPop(object);
15002   }
15003   if (unlikely((flags & NSF_CSC_FILTER_STACK_PUSHED) && object->filterStack) != 0u) {
15004     /* fprintf(stderr, "FilterStackPop %s.%s %p %s\n",
15005        ObjectName(object), methodName, object->filterStack, msg);*/
15006     FilterStackPop(object);
15007   }
15008 
15009   return result;
15010 }
15011 
15012 /*#define INHERIT_CLASS_METHODS 1*/
15013 
15014 #if defined(INHERIT_CLASS_METHODS)
15015 static Tcl_Command NsfFindClassMethod(Tcl_Interp *interp, NsfClass *class, const char *methodName)
15016   nonnull(1) nonnull(2) nonnull(3);
15017 
15018 static Tcl_Command
NsfFindClassMethod(Tcl_Interp * interp,NsfClass * class,const char * methodName)15019 NsfFindClassMethod(Tcl_Interp *interp, NsfClass *class, const char *methodName) {
15020   Tcl_Command  cmd;
15021   NsfClasses  *p;
15022 
15023   nonnull_assert(interp != NULL);
15024   nonnull_assert(class != NULL);
15025   nonnull_assert(methodName != NULL);
15026 
15027   /*fprintf(stderr, "NsfFindClassMethod %s %s\n", ClassName(class), methodName);*/
15028   for(p = PrecedenceOrder(class); p != NULL; p = p->nextPtr) {
15029     NsfClass      *currentClass = p->cl;
15030     Tcl_Namespace *nsPtr = currentClass->object.nsPtr;
15031 
15032     /*fprintf(stderr, "1 check for obj ns in class %s => %p\n",
15033       ClassName(currentClass), nsPtr);*/
15034     if (nsPtr != NULL) {
15035       cmd = FindMethod(nsPtr, methodName);
15036       /*fprintf(stderr, "1 lookup for method %s in class %s => %p\n",
15037         methodName, ClassName(currentClass), cmd);*/
15038       if (cmd != NULL) {
15039         return cmd;
15040       }
15041     }
15042   }
15043   return NULL;
15044 }
15045 #endif
15046 
15047 
15048 /*
15049  *----------------------------------------------------------------------
15050  * CmdObjProcName --
15051  *
15052  *    Try to find a symbolic name for the objCmdProc of a Tcl_command.
15053  *
15054  * Results:
15055  *    String name, potentially "other"
15056  *
15057  * Side effects:
15058  *    None
15059  *
15060  *----------------------------------------------------------------------
15061  */
15062 static const char *CmdObjProcName(
15063     Tcl_Command cmd
15064 ) nonnull(1) pure;
15065 
15066 static const char *
CmdObjProcName(Tcl_Command cmd)15067 CmdObjProcName(
15068     Tcl_Command cmd
15069 ) {
15070   const char     *result;
15071   Tcl_ObjCmdProc *proc;
15072 
15073   nonnull_assert(cmd != NULL);
15074 
15075   proc = Tcl_Command_objProc(cmd);
15076   if (CmdIsNsfObject(cmd)) {
15077     result = "object";
15078   } else if (CmdIsProc(cmd)) {
15079     result = "proc";
15080   } else if (proc == NsfForwardMethod) {
15081     result = "forward";
15082   } else if (proc == NsfProcAliasMethod) {
15083     result = "alias";
15084   } else if (proc == NsfODestroyMethodStub) {
15085     result = "destroy";
15086   } else if (proc == NsfCCreateMethodStub) {
15087     result = "create";
15088   } else if (proc == NsfCNewMethodStub) {
15089     result = "new";
15090   } else if (proc == NsfOConfigureMethodStub) {
15091     result = "configure";
15092   } else if (proc == NsfOVolatileMethodStub) {
15093     result = "volatile";
15094   } else if (proc == NsfOVolatile1MethodStub) {
15095     result = "volatile";
15096   } else if (proc == NsfOAutonameMethodStub) {
15097     result = "autoname";
15098   } else if (proc == NsfOUplevelMethodStub) {
15099     result = "uplevel";
15100   } else if (proc == NsfOUpvarMethodStub) {
15101     result = "upvar";
15102   } else if (proc == NsfObjscopedMethod) {
15103     result = "objscoped";
15104   } else if (proc == NsfProcStub) {
15105     result = "nsfproc";
15106   } else if (proc == NsfSetterMethod) {
15107     result = "setter";
15108   } else if (proc == NsfAsmProc) {
15109     result = "asm";
15110   } else if (proc == TclObjInterpProc) {
15111     result = "alt proc";
15112 #if 0
15113   } else if (proc == Tcl_ApplyObjCmd) {
15114     result = "apply";
15115   } else if (proc == Tcl_EvalObjCmd) {
15116     result = "eval";
15117 #endif
15118   } else {
15119     result = "unknown";
15120   }
15121   return result;
15122 }
15123 
15124 /*
15125  *----------------------------------------------------------------------
15126  * ColonCmdCacheSet --
15127  *
15128  *     Fill out an ColonCmdCacheSet entry
15129  *
15130  * Results:
15131  *    None
15132  *
15133  * Side effects:
15134  *    None
15135  *
15136  *----------------------------------------------------------------------
15137  */
15138 
15139 NSF_INLINE static void
ColonCmdCacheSet(NsfColonCmdContext * ccCtxPtr,NsfClass * currentClass,unsigned int methodEpoch,Tcl_Command cmd,NsfClass * class,unsigned int flags)15140 ColonCmdCacheSet(
15141     NsfColonCmdContext *ccCtxPtr,
15142     NsfClass           *currentClass,
15143     unsigned int        methodEpoch,
15144     Tcl_Command         cmd,
15145     NsfClass           *class,
15146     unsigned int        flags
15147 ) {
15148   ccCtxPtr->context = currentClass;
15149   ccCtxPtr->methodEpoch = methodEpoch;
15150   ccCtxPtr->cmd = cmd;
15151   ccCtxPtr->class = class;
15152   ccCtxPtr->flags = flags;
15153 }
15154 
15155 #if defined(COLON_CMD_STATS)
ColonCmdCacheNew(NsfColonCmdContext * ccCtxPtr,Tcl_Obj * obj)15156 static void ColonCmdCacheNew(NsfColonCmdContext *ccCtxPtr, Tcl_Obj *obj) {
15157   ccCtxPtr->hits = 0u;
15158   ccCtxPtr->invalidates = 0u;
15159   ccCtxPtr->requiredRefetches = 0u;
15160   ccCtxPtr->obj = obj;
15161   INCR_REF_COUNT(obj);
15162 }
ColonCmdCacheInvalidate(NsfColonCmdContext * ccCtxPtr)15163 static void ColonCmdCacheInvalidate(NsfColonCmdContext *ccCtxPtr) {
15164   ccCtxPtr->invalidates ++;
15165 }
ColonCmdCacheRequiredRefetch(NsfColonCmdContext * ccCtxPtr)15166 static void ColonCmdCacheRequiredRefetch(NsfColonCmdContext *ccCtxPtr) {
15167   ccCtxPtr->requiredRefetches ++;
15168 }
ColonCmdCacheHit(NsfColonCmdContext * ccCtxPtr)15169 static void ColonCmdCacheHit(NsfColonCmdContext *ccCtxPtr) {
15170   ccCtxPtr->hits ++;
15171 }
15172 #else
15173 #define ColonCmdCacheNew(ccCtxPtr, obj)
15174 #define ColonCmdCacheInvalidate(ccCtxPtr)
15175 #define ColonCmdCacheRequiredRefetch(ccCtxPtr)
15176 #define ColonCmdCacheHit(ccCtxPtr)
15177 #endif
15178 
15179 
15180 
15181 /*
15182  *----------------------------------------------------------------------
15183  * NsfColonCmdContextFree --
15184  *
15185  *    FreeProc for NsfColonCmdContext
15186  *
15187  * Results:
15188  *    None.
15189  *
15190  * Side effects:
15191  *    Freeing memory.
15192  *
15193  *----------------------------------------------------------------------
15194  */
15195 static void
NsfColonCmdContextFree(void * clientData)15196 NsfColonCmdContextFree(void *clientData) {
15197 #if defined(COLON_CMD_STATS)
15198   NsfColonCmdContext *ccCtxPtr = clientData;
15199 
15200   fprintf(stderr, "### free colonCmdContext for %s: hits %lu invalidates %lu required-refetches %lu\n",
15201           ObjStr(ccCtxPtr->obj), (unsigned long)ccCtxPtr->hits,
15202           (unsigned long)ccCtxPtr->invalidates, (unsigned long)ccCtxPtr->requiredRefetches);
15203   DECR_REF_COUNT(ccCtxPtr->obj);
15204 #endif
15205   FREE(NsfColonCmdContext, clientData);
15206 }
15207 
15208 /*
15209  *----------------------------------------------------------------------
15210  * CacheCmd --
15211  *
15212  *     Cache a Tcl_Command element in a Tcl_Obj, using either the NSF specific
15213  *     object types, or the colon cmd cache for Tcl cmd types.
15214  *
15215  * Results:
15216  *    None
15217  *
15218  * Side effects:
15219  *    Add cache entry
15220  *
15221  *----------------------------------------------------------------------
15222  */
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)15223 static void CacheCmd(
15224     Tcl_Interp        *interp,
15225     Tcl_Command        cmd,
15226     Tcl_Obj           *methodObj,
15227     const Tcl_ObjType *nsfObjTypePtr,
15228     void              *context,
15229     unsigned int       methodEpoch,
15230     NsfClass          *class,
15231     unsigned int       flags,
15232     bool               isColonCmd
15233 ) {
15234   const Tcl_ObjType *methodObjTypePtr = methodObj->typePtr;
15235 
15236   if (((methodObjTypePtr != Nsf_OT_tclCmdNameType))
15237       && (methodObjTypePtr != Nsf_OT_parsedVarNameType)
15238      ) {
15239     /*fprintf(stderr, "==== SET OBJ TYPE for %s.%s to NsfInstanceMethodObjType cmd %p\n",
15240       ObjectName(object), calledName, (void*)cmd);*/
15241     NsfMethodObjSet(interp, methodObj, nsfObjTypePtr,
15242                     context, methodEpoch, cmd, class, flags);
15243 
15244   } else if (isColonCmd && (methodObj->refCount > 1)) {
15245     /*
15246      * When the refCount <= 1, the object is a temporary object, for which
15247      * caching is not useful. We could also cache the following types, but the
15248      * benefit is not clear.
15249      *
15250      *     (methodObjTypePtr != Nsf_OT_tclCmdNameType)
15251      *     || (Tcl_Command_objProc(cmd) == NsfProcAliasMethod)
15252      *
15253      */
15254     NsfColonCmdContext *ccCtxPtr = methodObj->internalRep.twoPtrValue.ptr2;
15255 
15256     if (ccCtxPtr != NULL) {
15257       /*
15258        * We had already a ccCtxPtr, so the values was invalidated before.
15259        */
15260       ColonCmdCacheInvalidate(ccCtxPtr);
15261 
15262       if (ccCtxPtr->cmd != cmd) {
15263         /*
15264          * The cached cmd differs from actual one, so this was a required
15265          * refetch operation, where the invalidation was truly necessary.
15266          */
15267         ColonCmdCacheRequiredRefetch(ccCtxPtr);
15268       }
15269       ColonCmdCacheSet(ccCtxPtr, context, methodEpoch, cmd, class, flags);
15270 
15271     } else {
15272       NsfRuntimeState *rst = RUNTIME_STATE(interp);
15273 
15274       /*fprintf(stderr, "======== new entry for %p %s type %s refCount %d ccCtxPtr %p flags %.6x context %s\n",
15275               (void*)methodObj, ObjStr(methodObj), ObjTypeStr(methodObj),
15276               methodObj->refCount, (void*)ccCtxPtr, flags, ObjectName((NsfObject*)context));*/
15277 
15278       /*
15279        * Create an NsfColonCmdContext and supply it with data (primarily the
15280        * cmd, the other data is for validation).
15281        */
15282       ccCtxPtr = NEW(NsfColonCmdContext);
15283       ColonCmdCacheNew(ccCtxPtr, methodObj);
15284       ColonCmdCacheSet(ccCtxPtr, context, methodEpoch, cmd, class, flags);
15285 
15286       /*
15287        * Save the NsfColonCmdContext in the proc context for memory management
15288        * and as well for reuse in twoPtrValue.ptr2.
15289        */
15290       /* rst->freeListPtr = NsfListCons(ccCtxPtr, rst->freeListPtr); */
15291       NsfDListAppend(&rst->freeDList, ccCtxPtr);
15292       methodObj->internalRep.twoPtrValue.ptr2 = ccCtxPtr;
15293 
15294       /*fprintf(stderr, "==== ptr2 of %s empty, is set %p for obj %p %p %s target proc ctx %p ccCtx %p\n",
15295         ObjStr(methodObj),
15296         (void*)cmd, (void*)object, (void*)methodObj, ObjStr(methodObj),
15297         (void*)pCtxPtr, (void*)pCtxPtr->freeListObj);*/
15298     }
15299   } else {
15300     /*
15301      * We found a command, but we do not cache it...
15302      */
15303     /* fprintf(stderr, "... found cmd '%s' type of methodObj '%s' type %s, procType %s but we do not cache\n",
15304        Tcl_GetCommandName(NULL, cmd), ObjStr(methodObj),
15305        methodObjTypePtr ? methodObjTypePtr->name : "NONE",
15306        CmdObjProcName(cmd));*/
15307   }
15308 }
15309 
15310 /*
15311  *----------------------------------------------------------------------
15312  * ObjectDispatch --
15313  *
15314  *    This function performs the method lookup and call all kind of
15315  *    methods. It checks, whether a filter or mixin has to be
15316  *    applied. In these cases, the effective method lookup is
15317  *    performed by "next".
15318  *
15319  * Results:
15320  *    Tcl result code.
15321  *
15322  * Side effects:
15323  *    Maybe side effects by the cmd called by ParameterCheck()
15324  *    or DispatchUnknownMethod()
15325  *
15326  *----------------------------------------------------------------------
15327  */
15328 NSF_INLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp,
15329                                      int objc, Tcl_Obj *const objv[],
15330                                      unsigned int flags)
15331   nonnull(1) nonnull(2) nonnull(4);
15332 
15333 NSF_INLINE static int
ObjectDispatch(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],unsigned int flags)15334 ObjectDispatch(
15335     ClientData clientData,
15336     Tcl_Interp *interp,
15337     int objc,
15338     Tcl_Obj *const objv[],
15339     unsigned int flags
15340 ) {
15341   int                    result = TCL_OK, shift;
15342   bool                   isValidCsc = NSF_TRUE;
15343   unsigned int           objflags;
15344   unsigned short         frameType = NSF_CSC_TYPE_PLAIN;
15345   register NsfObject    *object;
15346   const char            *methodName, *calledName;
15347   NsfObject             *calledObject;
15348   NsfClass              *class = NULL;
15349   Tcl_Obj               *cmdName, *methodObj;
15350   const Tcl_ObjType     *methodObjTypePtr;
15351   NsfColonCmdContext    *ccCtxPtr;
15352   const NsfRuntimeState *rst;
15353   NsfCallStackContent    csc, *cscPtr = NULL;
15354   Tcl_Command            cmd = NULL;
15355 
15356   nonnull_assert(clientData != NULL);
15357   nonnull_assert(interp != NULL);
15358   nonnull_assert(objv != NULL);
15359 
15360   object = (NsfObject *)clientData;
15361   cmdName = object->cmdName;
15362   rst = RUNTIME_STATE(interp);
15363 
15364   /*
15365    * None of the higher copy-flags must be passed
15366    */
15367   assert((flags & (NSF_CSC_COPY_FLAGS & 0x000FFF000U)) == 0u);
15368 
15369   /*
15370    * Do we have to shift the argument vector?
15371    */
15372   if (unlikely((flags & NSF_CM_NO_SHIFT) != 0u)) {
15373     shift = 0;
15374     methodObj = objv[0];
15375     methodName = MethodName(methodObj);
15376     calledName =  ObjStr(methodObj);;
15377 
15378   } else {
15379     assert(objc > 1);
15380     shift = 1;
15381     methodObj = objv[1];
15382     methodName = ObjStr(methodObj);
15383     calledName = methodName;
15384     if (unlikely(FOR_COLON_RESOLVER(methodName))) {
15385       return NsfPrintError(interp, "%s: method name '%s' must not start with a colon",
15386                            ObjectName_(object), methodName);
15387     }
15388   }
15389   methodObjTypePtr = methodObj->typePtr;
15390   ccCtxPtr = methodObj->internalRep.twoPtrValue.ptr2;
15391 
15392 
15393   assert(object->teardown != NULL);
15394 
15395 #if defined(METHOD_OBJECT_TRACE)
15396   fprintf(stderr, "method %p/%d '%s' type %p <%s>\n",
15397           methodObj, methodObj->refCount, methodName, methodObjTypePtr,
15398           (methodObjTypePtr != NULL) ? methodObjTypePtr->name : "");
15399 #endif
15400   /*fprintf(stderr, "==== ObjectDispatch obj = %s objc = %d 0=%s methodName=%s method-obj-type %s cmd %p shift %d\n",
15401           (object != NULL) ? ObjectName(object) : NULL,
15402           objc, objv[0] ? ObjStr(objv[0]) : NULL,
15403           methodName, methodObjTypePtr ? methodObjTypePtr->name : "NONE",
15404           (void*)cmd, shift);*/
15405 
15406   objflags = object->flags; /* avoid stalling */
15407 
15408   /*
15409    * Make sure, cmdName and obj survive this method until the end of
15410    * this function.
15411    */
15412   INCR_REF_COUNT(cmdName);
15413   NsfObjectRefCountIncr(object);
15414 
15415   /*fprintf(stderr, "obj refCount of %p after incr %d (ObjectDispatch) %s\n",
15416     object, object->refCount, methodName);*/
15417 
15418   if (unlikely((objflags & NSF_FILTER_ORDER_VALID) == 0u)) {
15419     FilterComputeDefined(interp, object);
15420     objflags = object->flags;
15421   }
15422 
15423   if (unlikely((objflags & NSF_MIXIN_ORDER_VALID) == 0u)) {
15424     MixinComputeDefined(interp, object);
15425     objflags = object->flags;
15426   }
15427 
15428   /*
15429    * Only start new filter chain, if
15430    *   (a) filters are defined and
15431    *   (b) the toplevel csc entry is not a filter on self
15432    */
15433 
15434   /*fprintf(stderr, "call %s, objflags %.6x, defined and valid %.6x doFilters %d guard count %d\n",
15435           methodName, objflags, NSF_FILTER_ORDER_DEFINED_AND_VALID,
15436           rst->doFilters, rst->guardCount);*/
15437 
15438   assert((flags & (NSF_CSC_MIXIN_STACK_PUSHED|NSF_CSC_FILTER_STACK_PUSHED)) == 0u);
15439 
15440   if (unlikely((objflags & NSF_FILTER_ORDER_DEFINED_AND_VALID) == NSF_FILTER_ORDER_DEFINED_AND_VALID)) {
15441     if (rst->doFilters && !rst->guardCount) {
15442       const NsfCallStackContent *cscPtr1 = CallStackGetTopFrame0(interp);
15443 
15444       if ((cscPtr1 == NULL)
15445           || (object != cscPtr1->self)
15446           || (cscPtr1->frameType != NSF_CSC_TYPE_ACTIVE_FILTER)
15447          ) {
15448         FilterStackPush(object, methodObj);
15449         flags |= NSF_CSC_FILTER_STACK_PUSHED;
15450 
15451         cmd = FilterSearchProc(interp, object, &object->filterStack->currentCmdPtr, &class);
15452         if (cmd != NULL) {
15453           /*fprintf(stderr, "*** filterSearchProc returned cmd %p\n", cmd);*/
15454           frameType = NSF_CSC_TYPE_ACTIVE_FILTER;
15455           methodName = (char *)Tcl_GetCommandName(interp, cmd);
15456           flags |= NSF_CM_IGNORE_PERMISSIONS;
15457         }
15458       }
15459     }
15460   }
15461 
15462   if (unlikely(cmd == NULL && ((flags & NSF_CM_LOCAL_METHOD) != 0u))) {
15463     /*
15464      * We require a local method. If the local method is found, we set always
15465      * the cmd and sometimes the class (if it is a class specific method).
15466      */
15467     const NsfCallStackContent *cscPtr1 = CallStackGetTopFrame0(interp);
15468 
15469     if (unlikely(cscPtr1 == NULL)) {
15470       return NsfPrintError(interp, "flag '-local' only allowed when called from a method body");
15471     }
15472     if (cscPtr1->cl != NULL) {
15473       cmd = FindMethod(cscPtr1->cl->nsPtr, methodName);
15474       if (cmd != NULL) {
15475         class = cscPtr1->cl;
15476       }
15477     } else if (object->nsPtr != NULL) {
15478       cmd = FindMethod(object->nsPtr, methodName);
15479     }
15480 
15481     /*fprintf(stderr, "ObjectDispatch NSF_CM_LOCAL_METHOD obj %s methodName %s => cl %p %s cmd %p \n",
15482             (object != NULL) ? ObjectName(object) : NULL,
15483             methodName, (void*)class, (class != NULL) ? ClassName(class) : "NONE", (void*)cmd);*/
15484 
15485   } else if (unlikely(*methodName == ':')) {
15486     NsfObject *regObject;
15487     bool       fromClassNS = NSF_FALSE;
15488 
15489     /*
15490      * We have fully qualified name provided. Determine the class and/or
15491      * object on which the method was registered.
15492      */
15493 
15494     INCR_REF_COUNT(methodObj);
15495     cmd = ResolveMethodName(interp, NULL, methodObj,
15496                             NULL, &regObject, NULL, NULL, &fromClassNS);
15497     DECR_REF_COUNT(methodObj);
15498 
15499     if (likely(cmd != NULL)) {
15500       if (CmdIsNsfObject(cmd)) {
15501         /*
15502          * Don't allow for calling objects as methods via fully qualified
15503          * names. Otherwise, in line [2] below, ::State (or any children of
15504          * it, e.g., ::Slot::child) is interpreted as a method candidate. As a
15505          * result, dispatch chaining occurs with ::State or ::State::child
15506          * being the receiver (instead of Class) of the method call
15507          * "-parameter". In such a dispatch chaining, the method "unknown"
15508          * won't be called on Class (in the XOTcl tradition), effectively
15509          * bypassing any unknown-based indirection mechanism (e.g., XOTcl's short-cutting
15510          * of object/class creations).
15511          *
15512          *  [1] Class ::State; Class ::State::child
15513          *  [2] Class ::State -parameter x; Class ::State::child -parameter x
15514          */
15515         NsfLog(interp, NSF_LOG_NOTICE,
15516                "Don't invoke object %s this way. Register object via alias ...",
15517                methodName);
15518         cmd = NULL;
15519       } else {
15520         if (regObject != NULL) {
15521           if (NsfObjectIsClass(regObject)) {
15522             class = (NsfClass *)regObject;
15523           }
15524         }
15525         /* fprintf(stderr, "fully qualified lookup of %s returned %p\n", ObjStr(methodObj), cmd); */
15526         /*
15527          * Ignore permissions for fully qualified method names.
15528          */
15529         flags |= NSF_CM_IGNORE_PERMISSIONS;
15530       }
15531       /*fprintf(stderr, "ObjectDispatch fully qualified obj %s methodName %s => cl %p cmd %p \n",
15532               (object != NULL) ? ObjectName(object) : NULL,
15533               methodName, (void*)cl, (void*)cmd);*/
15534     }
15535   }
15536 
15537   /*fprintf(stderr, "MixinStackPush check for %p %s.%s objflags %.6x == %d\n",
15538     object, ObjectName(object), methodName, objflags & NSF_MIXIN_ORDER_DEFINED_AND_VALID,
15539     (objflags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) == NSF_MIXIN_ORDER_DEFINED_AND_VALID);*/
15540   /*
15541    * Check whether a mixed in method has to be called. This is necessary, even when
15542    * cmd is already determined.
15543    */
15544   if (unlikely((objflags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) == NSF_MIXIN_ORDER_DEFINED_AND_VALID
15545                && (flags & (NSF_CM_SYSTEM_METHOD|NSF_CM_INTRINSIC_METHOD)) == 0u
15546                && ((flags & NSF_CM_LOCAL_METHOD) == 0u || class != NULL))
15547      ) {
15548     /*
15549      * The current logic allocates first an entry on the per-object
15550      * stack and searches then for a mixin. This could be improved by
15551      * allocating a stack entry just when a mixin is found. The same
15552      * holds for the filters above, but there, the hit-rate is much
15553      * larger.
15554      */
15555 
15556     MixinStackPush(object);
15557     flags |= NSF_CSC_MIXIN_STACK_PUSHED;
15558 
15559     if (frameType != NSF_CSC_TYPE_ACTIVE_FILTER) {
15560       Tcl_Command cmd1 = cmd;
15561       /*
15562        * The entry is just searched and pushed on the stack when we
15563        * have no filter; in the filter case, the search happens in
15564        * next.
15565        */
15566       result = MixinSearchProc(interp, object, methodName, &class,
15567                                &object->mixinStack->currentCmdPtr, &cmd1);
15568       if (unlikely(result != TCL_OK)) {
15569         /*fprintf(stderr, "mixinsearch returned an error for %p %s.%s\n",
15570           object, ObjectName(object), methodName);*/
15571         isValidCsc = NSF_FALSE;
15572         goto exit_object_dispatch;
15573       }
15574       if (cmd1 != NULL) {
15575         frameType = NSF_CSC_TYPE_ACTIVE_MIXIN;
15576         cmd = cmd1;
15577       }
15578     }
15579   }
15580 
15581   /*fprintf(stderr, "ObjectDispatch ordinary lookup %s.%s cmd %p\n",
15582     ObjectName(object), ObjStr(methodObj), (void*)cmd);*/
15583 
15584   /*
15585    * If no fully qualified method name/filter/mixin was found then perform
15586    * ordinary method lookup. First, try to resolve the method name as a
15587    * per-object method.
15588    */
15589 
15590   if (likely(cmd == NULL)) {
15591     NsfMethodContext *mcPtr = methodObj->internalRep.twoPtrValue.ptr1;
15592     unsigned int      nsfObjectMethodEpoch = rst->objectMethodEpoch;
15593 
15594     if (methodObjTypePtr == &NsfObjectMethodObjType
15595         && mcPtr->context == object
15596         && mcPtr->methodEpoch == nsfObjectMethodEpoch
15597         && mcPtr->flags == flags
15598         ) {
15599       cmd = mcPtr->cmd;
15600 
15601 #if defined(METHOD_OBJECT_TRACE)
15602       fprintf(stderr, "... use internal rep method %p %s cmd %p (objProc %p) cl %p %s\n",
15603               (void*)methodObj, ObjStr(methodObj),
15604               (void*)cmd, (cmd != NULL) ? (void*)((Command *)cmd)->objProc : 0,
15605               (void*)cl, (class != NULL) ? ClassName(class) : ObjectName(object));
15606 #endif
15607 
15608       assert((cmd != NULL) ? ((Command *)cmd)->objProc != NULL : 1);
15609 
15610     } else if (methodObjTypePtr == Nsf_OT_tclCmdNameType
15611                && ccCtxPtr != NULL
15612                && ccCtxPtr->context == object
15613                && ccCtxPtr->methodEpoch == nsfObjectMethodEpoch
15614                && ccCtxPtr->flags == flags
15615                ) {
15616       cmd = ccCtxPtr->cmd;
15617       class = ccCtxPtr ->class;
15618       ColonCmdCacheHit(ccCtxPtr);
15619 
15620     } else {
15621       /*
15622        * Check whether the call can be resolved against an object-specific method.
15623        */
15624       if (unlikely((object->nsPtr != NULL)
15625                    && (flags & (NSF_CM_NO_OBJECT_METHOD|NSF_CM_SYSTEM_METHOD)) == 0u)) {
15626         cmd = FindMethod(object->nsPtr, methodName);
15627         /*fprintf(stderr, "ObjectDispatch lookup for per-object method in obj %p method %s nsPtr %p"
15628                 " => %p objProc %p\n",
15629                 (void*)object, methodName, (void*)object->nsPtr, (void*)cmd,
15630                 (cmd != NULL) ? (void*)((Command *)cmd)->objProc : NULL);*/
15631 
15632         if (cmd != NULL) {
15633           /*
15634            * Reject resolved cmd when
15635            * a) trying to call a private method without the local flag or ignore permissions, or
15636            * b) trying to call an object with no method interface
15637            */
15638           if (((flags & (NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0u
15639                && ((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD) != 0u)
15640               ) {
15641             cmd = NULL;
15642           } else {
15643             CacheCmd(interp,
15644                      cmd, methodObj, &NsfObjectMethodObjType,
15645                      object, nsfObjectMethodEpoch, NULL, flags,
15646                      (*calledName == ':'));
15647           }
15648         }
15649       }
15650     }
15651 #if defined(INHERIT_CLASS_METHODS)
15652     /*
15653      * This is not optimized yet, since current class might be checked twice,
15654      * but easier to maintain.
15655      */
15656     if ((flags & NSF_CM_NO_OBJECT_METHOD) == 0u && cmd == NULL && NsfObjectIsClass(object)) {
15657       cmd = NsfFindClassMethod(interp, (NsfClass *)object, methodName);
15658     }
15659 #endif
15660 
15661     if (likely(cmd == NULL)) {
15662       /*
15663        * Check whether the call can be resolved against an instance method.
15664        */
15665       NsfClass           *currentClass = object->cl;
15666       NsfMethodContext   *mcPtr0 = methodObj->internalRep.twoPtrValue.ptr1;
15667       unsigned int        nsfInstanceMethodEpoch = rst->instanceMethodEpoch;
15668 
15669 #if defined(METHOD_OBJECT_TRACE)
15670       fprintf(stderr, "... method %p/%d '%s' type? %d context? %d nsfMethodEpoch %d => %d\n",
15671               methodObj, methodObj->refCount, ObjStr(methodObj),
15672               methodObjTypePtr == &NsfInstanceMethodObjType,
15673               methodObjTypePtr == &NsfInstanceMethodObjType ? mcPtr0->context == currentClass : 0,
15674               methodObjTypePtr == &NsfInstanceMethodObjType ? mcPtr0->methodEpoch : 0,
15675               nsfInstanceMethodEpoch );
15676 #endif
15677 
15678       if (methodObjTypePtr == &NsfInstanceMethodObjType
15679           && mcPtr0->context == currentClass
15680           && mcPtr0->methodEpoch == nsfInstanceMethodEpoch
15681           && mcPtr0->flags == flags
15682           ) {
15683         cmd = mcPtr0->cmd;
15684         class = mcPtr0->cl;
15685 
15686 #if defined(METHOD_OBJECT_TRACE)
15687         fprintf(stderr, "... use internal rep method %p %s cmd %p (objProc %p) cl %p %s\n",
15688                 (void*)methodObj, ObjStr(methodObj),
15689                 (void*)cmd, (cmd != NULL) ? (void*)((Command *)cmd)->objProc : NULL,
15690                 (void*)class, (class != NULL) ? ClassName(class) : ObjectName(object));
15691 #endif
15692         assert((cmd != NULL) ? ((Command *)cmd)->objProc != NULL : 1);
15693 
15694       } else if (methodObjTypePtr == Nsf_OT_tclCmdNameType
15695                  && ccCtxPtr != NULL
15696                  && ccCtxPtr->context == currentClass
15697                  && ccCtxPtr->methodEpoch == nsfInstanceMethodEpoch
15698                  && ccCtxPtr->flags == flags
15699           ) {
15700         cmd = ccCtxPtr->cmd;
15701         class = ccCtxPtr ->class;
15702         ColonCmdCacheHit(ccCtxPtr);
15703 
15704 #if defined(METHOD_OBJECT_TRACE)
15705         fprintf(stderr, "... use internal rep ptr2 method %p %s cmd %p (objProc %p) cl %p %s\n",
15706                 (void*)methodObj, ObjStr(methodObj),
15707                 (void*)cmd, (cmd != NULL) ? (void*)((Command *)cmd)->objProc : NULL,
15708                 (void*)class, (class != NULL) ? ClassName(class) : ObjectName(object));
15709 #endif
15710       } else {
15711 
15712         /*
15713          * We could call PrecedenceOrder(currentClass) to recompute
15714          * currentClass->order on demand, but by construction this is already
15715          * set here.
15716          */
15717         assert(currentClass->order);
15718 
15719         if (unlikely((flags & NSF_CM_SYSTEM_METHOD) != 0u)) {
15720           NsfClasses *classListPtr = currentClass->order;
15721 
15722           /*
15723            * Skip entries until the (first) base class.
15724            */
15725           do {
15726             if (IsBaseClass(&classListPtr->cl->object)) {
15727               break;
15728             }
15729             classListPtr = classListPtr->nextPtr;
15730           } while (classListPtr->nextPtr != NULL);
15731 
15732           class = SearchPLMethod(classListPtr, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD);
15733         } else {
15734           class = SearchPLMethod(currentClass->order, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD);
15735         }
15736 
15737         /*fprintf(stderr, "... check type of methodObj %s type %s check %d\n",
15738                 calledName, methodObjTypePtr ? methodObjTypePtr->name : "NONE",
15739                 (((methodObjTypePtr != Nsf_OT_tclCmdNameType) || *calledName == ':')
15740                  && methodObjTypePtr != Nsf_OT_parsedVarNameType
15741                  && likely(cmd != NULL)  )
15742                  );*/
15743         if (likely(cmd != NULL)) {
15744           CacheCmd(interp,
15745                    cmd, methodObj, &NsfInstanceMethodObjType,
15746                    currentClass, nsfInstanceMethodEpoch, class, flags,
15747                    (*calledName == ':'));
15748         }
15749       }
15750     }
15751   }
15752   calledObject = object;
15753 
15754   /*
15755    * If we have a command, check the permissions, unless
15756    * NSF_CM_IGNORE_PERMISSIONS is set. Note that NSF_CM_IGNORE_PERMISSIONS is
15757    * set currently for fully qualified cmd names and in nsf::object::dispatch.
15758    */
15759 
15760   if (likely((cmd != NULL) && (flags & NSF_CM_IGNORE_PERMISSIONS) == 0u)) {
15761     const unsigned int cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
15762 
15763 #if !defined(NDEBUG)
15764     if (unlikely(((cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u)
15765                  && ((flags & NSF_CM_LOCAL_METHOD) == 0u))
15766         ) {
15767       /*
15768        * Private methods can be only called with the "-local" flag. All cases
15769        * handling private methods should be covered above (e.g. by setting
15770        * NSF_CM_IGNORE_PERMISSIONS, or by filtering private methods in method
15771        * search. So, this branch should never by executed.
15772        */
15773 
15774       Tcl_Panic("Unexpected handling of private method; most likely a caching bug");
15775       cmd = NULL;
15776 
15777     } else
15778 #endif
15779     if (unlikely((cmdFlags & NSF_CMD_CALL_PROTECTED_METHOD) != 0u)) {
15780       const NsfObject *lastSelf = GetSelfObj(interp);
15781 
15782       /*
15783        * Protected methods can be called, when calling object == called object.
15784        */
15785 
15786       if (unlikely(object != lastSelf)) {
15787         NsfLog(interp, NSF_LOG_WARN, "'%s %s' fails since method %s.%s is protected",
15788                ObjectName(object), methodName,
15789                (class != NULL) ? ClassName(class) : ObjectName(object),
15790                methodName);
15791         /*
15792          * Reset cmd, since it is still unknown.
15793          */
15794         cmd = NULL;
15795       }
15796     }
15797   }
15798 
15799   assert(result == TCL_OK);
15800 
15801   if (likely(cmd != NULL)) {
15802     /*
15803      * We found the method to dispatch.
15804      */
15805     const Tcl_Command resolvedCmd = AliasDereference(interp, object, methodName, cmd);
15806     if (unlikely(resolvedCmd == NULL)) {
15807       isValidCsc = NSF_FALSE;
15808       goto exit_object_dispatch;
15809     }
15810 
15811     /*
15812      * cscAlloc uses resolvedCmd for allocating the call stack content and
15813      * sets the IS_NRE flag based on it. We use the original cmd in the
15814      * call-stack content structure for introspection.
15815      */
15816 
15817     cscPtr = CscAlloc(interp, &csc, resolvedCmd);
15818     CscInit(cscPtr, calledObject, class, cmd, frameType, flags, methodName);
15819 
15820     if (unlikely(cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER)) {
15821       /*
15822        * Run filters is not NRE enabled.
15823        */
15824       cscPtr->flags |= NSF_CSC_IMMEDIATE;
15825       /*
15826        * Setting cscPtr->objc and cscPtr->objv is needed for invoking UNKNOWN
15827        * from ProcMethodDispatchFinalize()
15828        */
15829       cscPtr->objc = objc - shift;
15830       cscPtr->objv = objv + shift;
15831     }
15832 
15833     /* fprintf(stderr, "MethodDispatchCsc %s.%s %p flags %.6x cscPtr %p method-obj-type %s\n",
15834             ObjectName(object), methodName, (void*)object->mixinStack, cscPtr->flags,
15835             (void*)cscPtr, methodObj->typePtr ? methodObj->typePtr->name : "NONE");*/
15836 
15837     result = MethodDispatchCsc(clientData, interp, objc - shift, objv + shift,
15838                                resolvedCmd, cscPtr, methodName, &isValidCsc);
15839     /* fprintf(stderr, "MethodDispatchCsc %s.%s %p flags %.6x cscPtr %p method-obj-type %s DONE\n",
15840             ObjectName(object), methodName, (void*)object->mixinStack, cscPtr->flags,
15841             (void*)cscPtr, methodObj->typePtr ? methodObj->typePtr->name : "NONE"); */
15842 
15843     if (unlikely(result == TCL_ERROR)) {
15844       /*fprintf(stderr, "Call ErrInProc cl = %p, cmd %p, methodName %s flags %.6x\n",
15845               class, (class != NULL) ? class->object.id : NULL, methodName, (class != NULL) ? class->object.flags : 0);*/
15846 
15847       result = NsfErrInProc(interp, cmdName,
15848                             (class != NULL && class->object.teardown) ? class->object.cmdName : NULL,
15849                             methodName);
15850     }
15851   } else {
15852     /*
15853      * The method to be dispatched is unknown
15854      */
15855     cscPtr = CscAlloc(interp, &csc, cmd);
15856     CscInit(cscPtr, object, class, cmd, frameType, flags, methodName);
15857     cscPtr->flags |= NSF_CSC_METHOD_IS_UNKNOWN;
15858     if ((flags & NSF_CM_NO_UNKNOWN) != 0u) {
15859       cscPtr->flags |= NSF_CSC_CALL_NO_UNKNOWN;
15860     }
15861     cscPtr->objc = objc - shift;
15862     cscPtr->objv = objv + shift;
15863   }
15864 
15865  exit_object_dispatch:
15866   if (likely(isValidCsc)) {
15867     /*
15868      * In every situation, we have a cscPtr containing all context information
15869      */
15870     assert(cscPtr != NULL);
15871 
15872     result = ObjectDispatchFinalize(interp, cscPtr, result /*, "immediate" , methodName*/);
15873     CscListRemove(interp, cscPtr, NULL);
15874     CscFinish(interp, cscPtr, result, "non-scripted finalize");
15875   }
15876 
15877   /*fprintf(stderr, "ObjectDispatch %s.%s returns %d\n",
15878     ObjectName(object), methodName, result);*/
15879 
15880   NsfCleanupObject(object, "ObjectDispatch");
15881   /*fprintf(stderr, "ObjectDispatch call NsfCleanupObject %p DONE\n", object);*/
15882   DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */
15883 
15884   return result;
15885 }
15886 
15887 /*
15888  *----------------------------------------------------------------------
15889  * DispatchDefaultMethod --
15890  *
15891  *    Dispatch the default method (when object is called without arguments)
15892  *    in case the object system has it defined.
15893  *
15894  * Results:
15895  *    result code.
15896  *
15897  * Side effects:
15898  *    indirect effects by calling Tcl code
15899  *
15900  *----------------------------------------------------------------------
15901  */
15902 static int
DispatchDefaultMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * obj,unsigned int flags)15903 DispatchDefaultMethod(Tcl_Interp *interp, NsfObject *object,
15904                       Tcl_Obj *obj, unsigned int flags) {
15905   int result;
15906   Tcl_Obj *methodObj;
15907 
15908   nonnull_assert(interp != NULL);
15909   nonnull_assert(object != NULL);
15910   nonnull_assert(obj != NULL);
15911 
15912   if (CallDirectly(interp, object, NSF_o_defaultmethod_idx, &methodObj)) {
15913 
15914     Tcl_SetObjResult(interp, object->cmdName);
15915     result = TCL_OK;
15916 
15917   } else {
15918     Tcl_Obj *tov[2];
15919 
15920     tov[0] = obj;
15921     tov[1] = methodObj;
15922     result = ObjectDispatch(object, interp, 2, tov,
15923                             flags|NSF_CM_NO_UNKNOWN|NSF_CM_IGNORE_PERMISSIONS);
15924   }
15925 
15926   return result;
15927 }
15928 
15929 
15930 /*
15931  *----------------------------------------------------------------------
15932  * DispatchDestroyMethod --
15933  *
15934  *    Dispatch the method "destroy" in case the object system has it
15935  *    defined. During the final cleanup of the object system, the
15936  *    destroy is called separately from deallocation. Normally,
15937  *    Object.destroy() calls dealloc, which is responsible for the
15938  *    physical deallocation.
15939  *
15940  * Results:
15941  *    result code
15942  *
15943  * Side effects:
15944  *    indirect effects by calling Tcl code
15945  *
15946  *----------------------------------------------------------------------
15947  */
15948 
15949 static int
DispatchDestroyMethod(Tcl_Interp * interp,NsfObject * object,unsigned int flags)15950 DispatchDestroyMethod(Tcl_Interp *interp, NsfObject *object, unsigned int flags) {
15951   int              result;
15952   NsfRuntimeState *rst;
15953 
15954   nonnull_assert(interp != NULL);
15955   nonnull_assert(object != NULL);
15956 
15957   rst = RUNTIME_STATE(interp);
15958   if (unlikely(rst == NULL)) {
15959 
15960     /*
15961      * There is no runtime state in this interpreter.
15962      */
15963     if ((Tcl_Interp_flags(interp) & DELETED)) {
15964 
15965       /*
15966        * The interpreter is already deleted, just ignore this call.
15967        */
15968       result = TCL_OK;
15969     } else {
15970       /*
15971        * In all other cases we expect a runtime state. If this is violated,
15972        * something substantial must be wrong, so panic.
15973        */
15974 
15975       Tcl_Panic("Runtime state is lost");
15976       result = TCL_OK;
15977     }
15978 
15979   } else {
15980 
15981     /*
15982      * Don't call destroy after exit handler started physical
15983      * destruction, or when it was called already before
15984      */
15985     if (rst->exitHandlerDestroyRound == NSF_EXITHANDLER_ON_PHYSICAL_DESTROY
15986         || (object->flags & NSF_DESTROY_CALLED) != 0u
15987        ) {
15988       result = TCL_OK;
15989 
15990     } else {
15991       Tcl_Obj *methodObj;
15992 
15993       /*
15994        * We can call destroy.
15995        */
15996 
15997       /*fprintf(stderr, "    DispatchDestroyMethod obj %p flags %.6x active %d\n",
15998         object, object->flags,  object->activationCount); */
15999 
16000       PRINTOBJ("DispatchDestroyMethod", object);
16001 
16002       /*
16003        * Flag that destroy was called and invoke the method.
16004        */
16005       object->flags |= NSF_DESTROY_CALLED;
16006 
16007       if (CallDirectly(interp, object, NSF_o_destroy_idx, &methodObj)) {
16008         NSF_PROFILE_TIME_DATA;
16009         NSF_PROFILE_CALL(interp, object, Nsf_SystemMethodOpts[NSF_o_destroy_idx]);
16010         result = NsfODestroyMethod(interp, object);
16011         NSF_PROFILE_EXIT(interp, object, Nsf_SystemMethodOpts[NSF_o_destroy_idx]);
16012 
16013       } else {
16014         result = CallMethod(object, interp, methodObj, 2, NULL,
16015                             NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE|flags);
16016       }
16017       if (unlikely(result != TCL_OK)) {
16018         /*
16019          * The object might be already gone here, since we have no stack frame.
16020          * Therefore, we can't even use nsf::current object safely.
16021          */
16022         NsfErrorContext(interp, "method destroy");
16023 
16024         if (++rst->errorCount > 20) {
16025           Tcl_Panic("too many destroy errors occurred. Endless loop?");
16026         }
16027       } else if (rst->errorCount > 0) {
16028         rst->errorCount--;
16029       }
16030 
16031 #ifdef OBJDELETION_TRACE
16032       fprintf(stderr, "DispatchDestroyMethod for %p exit\n", object);
16033 #endif
16034     }
16035   }
16036 
16037   return result;
16038 }
16039 
16040 /*
16041  *----------------------------------------------------------------------
16042  * DispatchInitMethod --
16043  *
16044 in case the object system has it
16045  *    defined and it was not already called on the object,
16046  *
16047  * Results:
16048  *    Result code.
16049  *
16050  * Side effects:
16051  *    Indirect effects by calling Tcl code
16052  *
16053  *----------------------------------------------------------------------
16054  */
16055 static int DispatchInitMethod(Tcl_Interp *interp, NsfObject *object,
16056                    int objc, Tcl_Obj *const objv[], unsigned int flags)
16057   nonnull(1) nonnull(2);
16058 
16059 static int
DispatchInitMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[],unsigned int flags)16060 DispatchInitMethod(Tcl_Interp *interp, NsfObject *object,
16061                    int objc, Tcl_Obj *const objv[], unsigned int flags) {
16062   int result;
16063   Tcl_Obj *methodObj;
16064 
16065   nonnull_assert(interp != NULL);
16066   nonnull_assert(object != NULL);
16067 
16068   /*
16069    * check, whether init was called already
16070    */
16071   if ((object->flags & (NSF_INIT_CALLED|NSF_DESTROY_CALLED)) == 0u) {
16072 
16073     /*
16074      * Flag the call to "init" before the dispatch, such that a call to
16075      * "configure" within init does not clear the already set instance
16076      * variables.
16077      */
16078 
16079     object->flags |= NSF_INIT_CALLED;
16080 
16081     if (CallDirectly(interp, object, NSF_o_init_idx, &methodObj)) {
16082       /*fprintf(stderr, "%s init directly\n", ObjectName(object));*/
16083       /*
16084        * Actually, nothing to do.
16085        */
16086       result = TCL_OK;
16087     } else {
16088       result = CallMethod(object, interp, methodObj, objc+2, objv,
16089                           flags|NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
16090     }
16091 
16092   } else {
16093     result = TCL_OK;
16094   }
16095 
16096   return result;
16097 }
16098 
16099 /*
16100  *----------------------------------------------------------------------
16101  * DispatchUnknownMethod --
16102  *
16103  *    Dispatch the method "unknown" in case the object system has it
16104  *    defined and the application program contains an unknown handler.
16105  *
16106  * Results:
16107  *    result code
16108  *
16109  * Side effects:
16110  *    There might be indirect effects by calling Tcl code; also,
16111  *    the interp's unknown-state is reset.
16112  *
16113  *----------------------------------------------------------------------
16114  */
16115 
16116 static int
DispatchUnknownMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[],Tcl_Obj * callInfoObj,Tcl_Obj * methodObj,unsigned int flags)16117 DispatchUnknownMethod(Tcl_Interp *interp, NsfObject *object,
16118                       int objc, Tcl_Obj *const objv[],
16119                       Tcl_Obj *callInfoObj, Tcl_Obj *methodObj, unsigned int flags) {
16120   int result;
16121   Tcl_Obj         *unknownObj;
16122   const char      *methodName;
16123   NsfRuntimeState *rst;
16124 
16125   nonnull_assert(interp != NULL);
16126   nonnull_assert(object != NULL);
16127   nonnull_assert(objv != NULL);
16128   nonnull_assert(methodObj != NULL);
16129 
16130   rst = RUNTIME_STATE(interp);
16131   methodName = MethodName(methodObj);
16132   unknownObj = NsfMethodObj(object, NSF_o_unknown_idx);
16133 
16134   /*fprintf(stderr, "compare unknownObj %p with methodObj %p '%s' %p %p %s -- %s\n",
16135     unknownObj, methodObj, ObjStr(methodObj), callInfoObj, (callInfoObj != NULL) ?objv[1]:NULL, (callInfoObj != NULL) ?ObjStr(objv[1]) : NULL,
16136     methodName);*/
16137 
16138   if ((unknownObj != NULL)
16139       && (methodObj != unknownObj)
16140       && (flags & NSF_CSC_CALL_NO_UNKNOWN) == 0u
16141      ) {
16142     /*
16143      * Back off and try unknown.
16144      */
16145     bool mustCopy = (*(ObjStr(methodObj)) == ':');
16146     ALLOC_ON_STACK(Tcl_Obj*, objc+3, tov);
16147 
16148     if (callInfoObj == NULL) {
16149       callInfoObj = (mustCopy ? Tcl_NewStringObj(methodName, -1) : methodObj);
16150     }
16151     INCR_REF_COUNT(callInfoObj);
16152 
16153     /*fprintf(stderr, "calling unknown for %s %s, flags=%.6x,%.6x/%.6x isClass=%d %p %s objc %d\n",
16154       ObjectName(object), ObjStr(methodObj), flags, NSF_CM_NO_UNKNOWN, NSF_CSC_CALL_NO_UNKNOWN,
16155       NsfObjectIsClass(object), object, ObjectName(object), objc);*/
16156 
16157     tov[0] = object->cmdName;
16158     tov[1] = unknownObj;
16159     tov[2] = callInfoObj;
16160     if (objc > 1) {
16161       memcpy(tov + 3, objv + 1, sizeof(Tcl_Obj *) * ((size_t)objc - 1u));
16162     }
16163 
16164     flags &= ~NSF_CM_NO_SHIFT;
16165 
16166     /*fprintf(stderr, "call unknown via dispatch mustCopy %d delegator %p method %s (%s)\n",
16167       mustCopy, delegator, ObjStr(tov[offset]), ObjStr(methodObj));*/
16168 
16169     result = ObjectDispatch(object, interp, objc+2, tov,
16170                             flags|NSF_CM_NO_UNKNOWN|NSF_CM_IGNORE_PERMISSIONS);
16171 
16172     DECR_REF_COUNT(callInfoObj);
16173     FREE_ON_STACK(Tcl_Obj*, tov);
16174 
16175   } else {
16176     Tcl_Obj *tailMethodObj = NULL;
16177 
16178     /*
16179      * No unknown called. This is the built-in unknown handler.
16180      */
16181 
16182     if (objc > 1 && ((*methodName) == '-' || (unknownObj && objv[0] == unknownObj))) {
16183       int length;
16184 
16185       tailMethodObj = objv[1];
16186       if ((((object->flags & NSF_KEEP_CALLER_SELF) != 0u) ||
16187            ((object->flags & NSF_PER_OBJECT_DISPATCH) != 0u)) &&
16188           Tcl_ListObjLength(interp, objv[1], &length) == TCL_OK) {
16189         if (length > 1) {
16190           Tcl_ListObjIndex(interp, objv[1], length - 1, &tailMethodObj);
16191         }
16192       }
16193     }
16194     result = NsfPrintError(interp, "%s: unable to dispatch method '%s'",
16195                            ObjectName_(object),
16196                            (tailMethodObj != NULL) ? MethodName(tailMethodObj) : methodName);
16197   }
16198 
16199   /*
16200    * Reset interp state, unknown has been fired.
16201    */
16202   rst->unknown = 0;
16203 
16204   return result;
16205 }
16206 
16207 /*
16208  *----------------------------------------------------------------------
16209  * NsfObjDispatch --
16210  *
16211  *    This function is called on every object dispatch (when an object
16212  *    is invoked). It calls either the passed method, or dispatches
16213  *    some default method.
16214  *
16215  * Results:
16216  *    Tcl result code.
16217  *
16218  * Side effects:
16219  *    Maybe side effects by the cmd called by ParameterCheck()
16220  *    or DispatchUnknownMethod()
16221  *
16222  *----------------------------------------------------------------------
16223  */
16224 #if defined(NRE)
16225 Tcl_ObjCmdProc NsfObjDispatchNRE;
16226 int
NsfObjDispatch(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])16227 NsfObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
16228 
16229   nonnull_assert(clientData != NULL);
16230   nonnull_assert(interp != NULL);
16231   nonnull_assert(objv != NULL);
16232 
16233   return Tcl_NRCallObjProc(interp, NsfObjDispatchNRE, clientData, objc, objv);
16234 }
16235 int NsfObjDispatchNRE(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
16236   nonnull(1) nonnull(2) nonnull(4);
16237 
16238 int
NsfObjDispatchNRE(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])16239 NsfObjDispatchNRE(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
16240 
16241 #else
16242 
16243 EXTERN int
16244 NsfObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
16245 
16246 #endif
16247 {
16248   int result;
16249 #ifdef STACK_TRACE
16250   NsfStackDump(interp);
16251 #endif
16252 
16253   nonnull_assert(clientData != NULL);
16254   nonnull_assert(interp != NULL);
16255   nonnull_assert(objv != NULL);
16256 
16257   if (likely(objc > 1)) {
16258     /*
16259      * Normal dispatch; we must not use NSF_CSC_IMMEDIATE here,
16260      * otherwise coroutines won't work.
16261      */
16262     result = ObjectDispatch(clientData, interp, objc, objv, 0u);
16263   } else {
16264     result = DispatchDefaultMethod(interp, (NsfObject *)clientData, objv[0], NSF_CSC_IMMEDIATE);
16265   }
16266   return result;
16267 }
16268 
16269 /*
16270  *  Proc-Creation
16271  */
16272 
16273 /*
16274  *----------------------------------------------------------------------
16275  * AddPrefixToBody --
16276  *
16277  *    Create a fresh TclObj* containing the body with a potential prefix.
16278  *    The caller has to decrement the ref-count on this Tcl_Obj*.
16279  *
16280  * Results:
16281  *    Tcl_Obj
16282  *
16283  * Side effects:
16284  *    None.
16285  *
16286  *----------------------------------------------------------------------
16287  */
16288 
16289 static Tcl_Obj * AddPrefixToBody(Tcl_Obj *body, bool useParamDefs, NsfParsedParam *paramPtr)
16290   nonnull(1) nonnull(3);
16291 
16292 static Tcl_Obj *
AddPrefixToBody(Tcl_Obj * body,bool useParamDefs,NsfParsedParam * paramPtr)16293 AddPrefixToBody(Tcl_Obj *body, bool useParamDefs, NsfParsedParam *paramPtr) {
16294   Tcl_Obj *resultBody = Tcl_NewObj();
16295 
16296   nonnull_assert(body != NULL);
16297   nonnull_assert(paramPtr != NULL);
16298 
16299   INCR_REF_COUNT2("resultBody", resultBody);
16300 
16301   if (useParamDefs && paramPtr->possibleUnknowns > 0) {
16302     Tcl_AppendStringsToObj(resultBody, "::nsf::__unset_unknown_args\n", (char *) NULL);
16303   }
16304 
16305   Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL);
16306   return resultBody;
16307 }
16308 
16309 /*
16310  *----------------------------------------------------------------------
16311  * NoMetaChars --
16312  *
16313  *    Check, of the provided string contains meta characters
16314  *    (i.e. "*", "?", or "[")
16315  *
16316  * Results:
16317  *    Boolean value
16318  *
16319  * Side effects:
16320  *    None.
16321  *
16322  *----------------------------------------------------------------------
16323  */
16324 NSF_INLINE static bool NoMetaChars(const char *pattern)
16325   nonnull(1) pure;
16326 
16327 NSF_INLINE static bool
NoMetaChars(const char * pattern)16328 NoMetaChars(const char *pattern) {
16329   register char c;
16330   bool          result = NSF_TRUE;
16331 
16332   nonnull_assert(pattern != NULL);
16333 
16334   for (c = *pattern; c; c = *++pattern) {
16335     if (c == '*' || c == '?' || c == '[') {
16336       result = NSF_FALSE;
16337       break;
16338     }
16339   }
16340   return result;
16341 }
16342 
16343 /***********************************************************************
16344  * Nsf_TypeConverter
16345  ***********************************************************************/
16346 
16347 /*
16348  *----------------------------------------------------------------------
16349  * Nsf_ConvertToString --
16350  *
16351  *    Minimal Nsf_TypeConverter setting the client data (passed to C
16352  *    functions) to the ObjStr of the object.
16353  *
16354  * Results:
16355  *    Tcl result code, *clientData and **outObjPtr
16356  *
16357  * Side effects:
16358  *    None.
16359  *
16360  *----------------------------------------------------------------------
16361  */
16362 
16363 int Nsf_ConvertToString(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
16364                         ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16365   nonnull(2) nonnull(4);
16366 
16367 int
Nsf_ConvertToString(Tcl_Interp * UNUSED (interp),Tcl_Obj * objPtr,const Nsf_Param * UNUSED (pPtr),ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16368 Nsf_ConvertToString(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
16369                     ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16370 
16371   nonnull_assert(objPtr != NULL);
16372   nonnull_assert(clientData != NULL);
16373 
16374   *clientData = (char *)ObjStr(objPtr);
16375 
16376   return TCL_OK;
16377 }
16378 
16379 /*
16380  *----------------------------------------------------------------------
16381  * ConvertToNothing --
16382  *
16383  *    Minimalistic Nsf_TypeConverter, even setting the client data (passed to
16384  *    C functions).
16385  *
16386  * Results:
16387  *    Tcl result code, **outObjPtr
16388  *
16389  * Side effects:
16390  *    None.
16391  *
16392  *----------------------------------------------------------------------
16393  */
16394 
16395 static int ConvertToNothing(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr,  const Nsf_Param *UNUSED(pPtr),
16396                             ClientData *UNUSED(clientData), Tcl_Obj **outObjPtr)
16397   nonnull(2) nonnull(5) pure;
16398 
16399 static int
ConvertToNothing(Tcl_Interp * UNUSED (interp),Tcl_Obj * objPtr,const Nsf_Param * UNUSED (pPtr),ClientData * UNUSED (clientData),Tcl_Obj ** outObjPtr)16400 ConvertToNothing(Tcl_Interp *UNUSED(interp), Tcl_Obj *objPtr,  const Nsf_Param *UNUSED(pPtr),
16401                  ClientData *UNUSED(clientData), Tcl_Obj **outObjPtr) {
16402 
16403   nonnull_assert(objPtr != NULL);
16404   nonnull_assert(outObjPtr != NULL);
16405   assert(*outObjPtr == objPtr);
16406 
16407   *outObjPtr = objPtr;
16408   return TCL_OK;
16409 }
16410 
16411 #ifdef NSF_WITH_TCL_OBJ_TYPES_AS_CONVERTER
16412 int Nsf_ConvertToTclObjType(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16413                         ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16414   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
16415 
16416 int
Nsf_ConvertToTclObjType(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** outObjPtr)16417 Nsf_ConvertToTclObjType(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16418                     ClientData *clientData, Tcl_Obj **outObjPtr) {
16419   int result = TCL_OK;
16420 
16421   nonnull_assert(interp != NULL);
16422   nonnull_assert(objPtr != NULL);
16423   nonnull_assert(pPtr != NULL);
16424   nonnull_assert(clientData != NULL);
16425 
16426   fprintf(stderr, "Nsf_ConvertToTclObjType: converterArg %p\n", (void*)pPtr->converterArg);
16427   if (unlikely(pPtr->converterArg != NULL)) {
16428     const Tcl_ObjType *tclObjType = pPtr->converterArg->internalRep.twoPtrValue.ptr1;
16429 
16430     if (tclObjType != NULL) {
16431       result = Tcl_ConvertToType(interp, objPtr, tclObjType);
16432       fprintf(stderr, "Nsf_ConvertToTclObjType:type  %p -> %d\n", (void*)tclObjType, result);
16433 
16434       if (result != TCL_OK) {
16435         Tcl_ResetResult(interp);
16436         result = NsfObjErrType(interp, NULL, objPtr, tclObjType->name, (Nsf_Param *)pPtr);
16437       }
16438     }
16439   }
16440   *outObjPtr = objPtr;
16441   /*
16442     nsf::proc foo {a:ns:mem_unit} {return $a}
16443     nsf::proc bar {a:ns:mem_unit} {return [expr {$a + 1}]}
16444     foo 1kB
16445     foo xxx
16446     bar 1kB
16447    */
16448   return result;
16449 }
16450 #endif
16451 
16452 /*
16453  *----------------------------------------------------------------------
16454  * Nsf_ConvertToTclobj --
16455  *
16456  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16457  *    passed Tcl_Obj. Optionally this converter checks if the Tcl_Obj has
16458  *    permissible content via the Tcl "string is" checkers.
16459  *
16460  * Results:
16461  *    Tcl result code, *clientData and **outObjPtr
16462  *
16463  * Side effects:
16464  *    None.
16465  *
16466  *----------------------------------------------------------------------
16467  */
16468 enum stringTypeIdx {StringTypeAlnum, StringTypeAlpha, StringTypeAscii, StringTypeBoolean, StringTypeControl,
16469                     StringTypeDigit, StringTypeDouble, StringTypeFalse, StringTypeGraph, StringTypeInteger,
16470                     StringTypeLower, StringTypePrint, StringTypePunct, StringTypeSpace, StringTypeTrue,
16471                     StringTypeUpper, StringTypeWideinteger, StringTypeWordchar, StringTypeXdigit };
16472 static const char *stringTypeOpts[] = {"alnum", "alpha", "ascii", "boolean", "control",
16473                                        "digit", "double", "false", "graph", "integer",
16474                                        "lower", "print", "punct", "space",  "true",
16475                                        "upper", "wideinteger", "wordchar", "xdigit",
16476                                        NULL};
16477 
16478 int Nsf_ConvertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16479                         ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16480   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
16481 
16482 int
Nsf_ConvertToTclobj(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16483 Nsf_ConvertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16484                     ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16485   int result;
16486 
16487   nonnull_assert(interp != NULL);
16488   nonnull_assert(objPtr != NULL);
16489   nonnull_assert(pPtr != NULL);
16490   nonnull_assert(clientData != NULL);
16491 
16492   if (unlikely(pPtr->converterArg != NULL)) {
16493     Tcl_Obj *objv[4];
16494     /*fprintf(stderr, "ConvertToTclobj %s (must be %s)\n", ObjStr(objPtr), ObjStr(pPtr->converterArg));*/
16495 
16496     objv[0] = NULL;
16497     objv[1] = pPtr->converterArg;
16498     objv[2] = NsfGlobalObjs[NSF_OPTION_STRICT];
16499     objv[3] = objPtr;
16500 
16501     result = NsfCallCommand(interp, NSF_STRING_IS, 4, objv);
16502     if (likely(result == TCL_OK)) {
16503       int success;
16504       Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &success);
16505       if (success == 1) {
16506         *clientData = objPtr;
16507       } else {
16508         Tcl_ResetResult(interp);
16509         result = NsfObjErrType(interp, NULL, objPtr, ObjStr(pPtr->converterArg), (Nsf_Param *)pPtr);
16510       }
16511     }
16512   } else {
16513     result = TCL_OK;
16514 
16515 #if defined(NSF_WITH_VALUE_WARNINGS)
16516     if (RUNTIME_STATE(interp)->logSeverity == NSF_LOG_DEBUG) {
16517       const char *value = ObjStr(objPtr);
16518 
16519       if (unlikely(*value == '-'
16520                    && (pPtr->flags & NSF_ARG_CHECK_NONPOS) != 0u
16521                    && isalpha(*(value+1))
16522                    && strchr(value+1, ' ') == NULL)
16523           ) {
16524         /*
16525          * In order to flag a warning, we set the error message and
16526          * return TCL_CONTINUE
16527          */
16528         (void)NsfPrintError(interp, "value '%s' of parameter '%s' could be a non-positional argument",
16529                       value, pPtr->name);
16530         result = TCL_CONTINUE;
16531       }
16532     }
16533 #endif
16534     *clientData = objPtr;
16535   }
16536   return result;
16537 }
16538 
16539 /*
16540  *----------------------------------------------------------------------
16541  * Nsf_ConvertToBoolean --
16542  *
16543  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16544  *    internal representation of a boolean. This converter checks the passed
16545  *    value via Tcl_GetBooleanFromObj().
16546  *
16547  * Results:
16548  *    Tcl result code, *clientData and **outObjPtr
16549  *
16550  * Side effects:
16551  *    None.
16552  *
16553  *----------------------------------------------------------------------
16554  */
16555 
16556 int Nsf_ConvertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16557                          ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16558   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
16559 
16560 int
Nsf_ConvertToBoolean(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16561 Nsf_ConvertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16562                      ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16563   int result, boolVal;
16564 
16565   nonnull_assert(interp != NULL);
16566   nonnull_assert(objPtr != NULL);
16567   nonnull_assert(pPtr != NULL);
16568   nonnull_assert(clientData != NULL);
16569 
16570   result = Tcl_GetBooleanFromObj(interp, objPtr, &boolVal);
16571   if (likely(result == TCL_OK)) {
16572     *clientData = (ClientData)INT2PTR(boolVal);
16573   } else {
16574     Tcl_ResetResult(interp);
16575     NsfObjErrType(interp, NULL, objPtr, "boolean", pPtr);
16576   }
16577 
16578   return result;
16579 }
16580 
16581 /*
16582  *----------------------------------------------------------------------
16583  * Nsf_ConvertToInt32 --
16584  *
16585  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16586  *    internal representation of an integer. This converter checks the passed
16587  *    value via Tcl_GetIntFromObj().
16588  *
16589  * Results:
16590  *    Tcl result code, *clientData and **outObjPtr
16591  *
16592  * Side effects:
16593  *    None.
16594  *
16595  *----------------------------------------------------------------------
16596  */
16597 int Nsf_ConvertToInt32(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16598                        ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16599   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
16600 
16601 int
Nsf_ConvertToInt32(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16602 Nsf_ConvertToInt32(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16603                    ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16604   int result, i;
16605 
16606   nonnull_assert(interp != NULL);
16607   nonnull_assert(objPtr != NULL);
16608   nonnull_assert(pPtr != NULL);
16609   nonnull_assert(clientData != NULL);
16610 
16611   result = Tcl_GetIntFromObj(interp, objPtr, &i);
16612 
16613   if (likely(result == TCL_OK)) {
16614     *clientData = (ClientData)INT2PTR(i);
16615   } else {
16616     Tcl_ResetResult(interp);
16617     NsfObjErrType(interp, NULL, objPtr, "int32", (Nsf_Param *)pPtr);
16618   }
16619   return result;
16620 }
16621 
16622 /*
16623  *----------------------------------------------------------------------
16624  * Nsf_ConvertToInteger --
16625  *
16626  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16627  *    Tcl_Obj containing the bignum value. This converter checks the passed
16628  *    value via Tcl_GetBignumFromObj().
16629  *
16630  * Results:
16631  *    Tcl result code, *clientData and **outObjPtr
16632  *
16633  * Side effects:
16634  *    None.
16635  *
16636  *----------------------------------------------------------------------
16637  */
16638 
16639 #include <tclTomMath.h>
16640 int Nsf_ConvertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16641                      ClientData *clientData, Tcl_Obj **outObjPtr)
16642   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
16643 
16644 int
Nsf_ConvertToInteger(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16645 Nsf_ConvertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16646                      ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16647   int result;
16648 
16649   nonnull_assert(interp != NULL);
16650   nonnull_assert(objPtr != NULL);
16651   nonnull_assert(pPtr != NULL);
16652   nonnull_assert(clientData != NULL);
16653 
16654   /*
16655    * Try to short_cut common cases to avoid conversion to bignums, since
16656    * Tcl_GetBignumFromObj returns a value, which has to be freed.
16657    */
16658   if (objPtr->typePtr == Nsf_OT_intType) {
16659     /*
16660      * We know already that the value is an int
16661      */
16662     result = TCL_OK;
16663   } else if (objPtr->typePtr == Nsf_OT_doubleType) {
16664     /*
16665      * We know already that the value is not an int
16666      */
16667     result = TCL_ERROR;
16668   } else {
16669     mp_int bignumValue;
16670 
16671     /*
16672      * We have to figure out, whether the value is an int. We perform this
16673      * test via Tcl_GetBignumFromObj(), which tries to keep the type small if
16674      * possible (e.g. it might return type "int" or "float" when appropriate.
16675      */
16676 
16677     /*if (objPtr->typePtr != NULL) {
16678       fprintf(stderr, "type is on call %p %s value %s \n",
16679           objPtr->typePtr, ObjTypeStr(objPtr), ObjStr(objPtr));
16680           }*/
16681 
16682     if ((result = Tcl_GetBignumFromObj(interp, objPtr, &bignumValue)) == TCL_OK) {
16683       mp_clear(&bignumValue);
16684     }
16685   }
16686 
16687   if (likely(result == TCL_OK)) {
16688     *clientData = (ClientData)objPtr;
16689   } else {
16690     Tcl_ResetResult(interp);
16691     NsfObjErrType(interp, NULL, objPtr, "integer", (Nsf_Param *)pPtr);
16692   }
16693   return result;
16694 }
16695 
16696 /*
16697  *----------------------------------------------------------------------
16698  * Nsf_ConvertToSwitch --
16699  *
16700  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16701  *    internal representation of an Boolean. This converter simply calls
16702  *    Tcl_ConvertToBoolean(). The distinction between "switch" and boolean is
16703  *    made on the semantics of which arguments/defaults are passed to the real
16704  *    converter.
16705  *
16706  * Results:
16707  *    Tcl result code, *clientData and **outObjPtr
16708  *
16709  * Side effects:
16710  *    None.
16711  *
16712  *----------------------------------------------------------------------
16713  */
16714 
16715 int Nsf_ConvertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
16716                         ClientData *clientData, Tcl_Obj **outObjPtr)
16717   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
16718 
16719 int
Nsf_ConvertToSwitch(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** outObjPtr)16720 Nsf_ConvertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
16721                     ClientData *clientData, Tcl_Obj **outObjPtr) {
16722   nonnull_assert(interp != NULL);
16723   nonnull_assert(objPtr != NULL);
16724   nonnull_assert(pPtr != NULL);
16725   nonnull_assert(clientData != NULL);
16726   nonnull_assert(outObjPtr != NULL);
16727 
16728   return Nsf_ConvertToBoolean(interp, objPtr, pPtr, clientData, outObjPtr);
16729 }
16730 
16731 /*
16732  *----------------------------------------------------------------------
16733  * Nsf_ConvertToObject --
16734  *
16735  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16736  *    internal representation of an object. This converter checks the passed
16737  *    value via IsObjectOfType().
16738  *
16739  * Results:
16740  *    Tcl result code, *clientData and **outObjPtr
16741  *
16742  * Side effects:
16743  *    None.
16744  *
16745  *----------------------------------------------------------------------
16746  */
16747 
16748 int Nsf_ConvertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
16749                         ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16750   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
16751 
16752 int
Nsf_ConvertToObject(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16753 Nsf_ConvertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
16754                     ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16755   int result;
16756 
16757   nonnull_assert(interp != NULL);
16758   nonnull_assert(objPtr != NULL);
16759   nonnull_assert(pPtr != NULL);
16760   nonnull_assert(clientData != NULL);
16761 
16762   if (likely(GetObjectFromObj(interp, objPtr, (NsfObject **)clientData) == TCL_OK)) {
16763     result = IsObjectOfType(interp, (NsfObject *)*clientData, "object", objPtr, pPtr);
16764   } else {
16765     result = NsfObjErrType(interp, NULL, objPtr, "object", (Nsf_Param *)pPtr);
16766   }
16767   return result;
16768 }
16769 
16770 /*
16771  *----------------------------------------------------------------------
16772  * Nsf_ConvertToClass --
16773  *
16774  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16775  *    internal representation of a class. This converter checks the passed
16776  *    value via IsObjectOfType().
16777  *
16778  * Results:
16779  *    Tcl result code, *clientData and **outObjPtr
16780  *
16781  * Side effects:
16782  *    None.
16783  *
16784  *----------------------------------------------------------------------
16785  */
16786 
16787 int Nsf_ConvertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16788                        ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16789   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
16790 
16791 int
Nsf_ConvertToClass(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16792 Nsf_ConvertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16793                    ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16794   bool withUnknown;
16795   int  result;
16796 
16797   nonnull_assert(interp != NULL);
16798   nonnull_assert(objPtr != NULL);
16799   nonnull_assert(pPtr != NULL);
16800   nonnull_assert(clientData != NULL);
16801 
16802   withUnknown = (RUNTIME_STATE(interp)->doClassConverterOmitUnknown == 0);
16803 
16804   if (likely(GetClassFromObj(interp, objPtr, (NsfClass **)clientData, withUnknown) == TCL_OK)) {
16805     result = IsObjectOfType(interp, (NsfObject *)*clientData, "class", objPtr, pPtr);
16806   } else {
16807     result = NsfObjErrType(interp, NULL, objPtr, "class", (Nsf_Param *)pPtr);
16808   }
16809   return result;
16810 }
16811 
16812 
16813 
16814 /*
16815  *----------------------------------------------------------------------
16816  * Nsf_ConvertToFilterreg --
16817  *
16818  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16819  *    Tcl_Obj. This nsf type converter checks the passed value via the
16820  *    NsfFilterregObjType tcl_obj converter, which provides an internal
16821  *    representation for the client function.
16822  *
16823  * Results:
16824  *    Tcl result code, *clientData and **outObjPtr
16825  *
16826  * Side effects:
16827  *    None.
16828  *
16829  *----------------------------------------------------------------------
16830  */
16831 
16832 int Nsf_ConvertToFilterreg(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16833                            ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16834   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
16835 
16836 int
Nsf_ConvertToFilterreg(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16837 Nsf_ConvertToFilterreg(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16838                        ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16839   int result;
16840 
16841   nonnull_assert(interp != NULL);
16842   nonnull_assert(objPtr != NULL);
16843   nonnull_assert(pPtr != NULL);
16844   nonnull_assert(clientData != NULL);
16845 
16846   result = Tcl_ConvertToType(interp, objPtr, &NsfFilterregObjType);
16847   if (likely(result == TCL_OK)) {
16848     *clientData = objPtr;
16849   } else {
16850     result = NsfObjErrType(interp, NULL, objPtr, "filterreg", (Nsf_Param *)pPtr);
16851   }
16852   return result;
16853 }
16854 
16855 /*
16856  *----------------------------------------------------------------------
16857  * Nsf_ConvertToMixinreg --
16858  *
16859  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16860  *    Tcl_Obj. This nsf type converter checks the passed value via the
16861  *    NsfMixinregObjType tcl_obj converter, which provides an internal
16862  *    representation for the client function.
16863  *
16864  * Results:
16865  *    Tcl result code, *clientData and **outObjPtr
16866  *
16867  * Side effects:
16868  *    None.
16869  *
16870  *----------------------------------------------------------------------
16871  */
16872 
16873 int Nsf_ConvertToMixinreg(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16874                           ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16875   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
16876 
16877 int
Nsf_ConvertToMixinreg(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16878 Nsf_ConvertToMixinreg(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16879                       ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16880   int result;
16881 
16882   nonnull_assert(interp != NULL);
16883   nonnull_assert(objPtr != NULL);
16884   nonnull_assert(pPtr != NULL);
16885   nonnull_assert(clientData != NULL);
16886 
16887   result = Tcl_ConvertToType(interp, objPtr, &NsfMixinregObjType);
16888   if (likely(result == TCL_OK)) {
16889     *clientData = objPtr;
16890   } else {
16891     result = NsfObjErrType(interp, NULL, objPtr, "mixinreg", (Nsf_Param *)pPtr);
16892   }
16893   return result;
16894 }
16895 
16896 /*
16897  *----------------------------------------------------------------------
16898  * Nsf_ConvertToParameter --
16899  *
16900  *    Nsf_TypeConverter setting the client data (passed to C functions) to the
16901  *    Tcl_Obj. This nsf type converter checks if the provided value could be a
16902  *    valid parameter spec (i.e. start with no ":", is not an unnamed spec
16903  *    "-:int"). This converter performs just a rough syntactic check.
16904  *
16905  * Results:
16906  *    Tcl result code, *clientData and **outObjPtr
16907  *
16908  * Side effects:
16909  *    None.
16910  *
16911  *----------------------------------------------------------------------
16912  */
16913 
16914 int Nsf_ConvertToParameter(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
16915                            ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr))
16916   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
16917 
16918 int
Nsf_ConvertToParameter(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** UNUSED (outObjPtr))16919 Nsf_ConvertToParameter(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *pPtr,
16920                        ClientData *clientData, Tcl_Obj **UNUSED(outObjPtr)) {
16921   const char *value;
16922   int         result;
16923 
16924   nonnull_assert(interp != NULL);
16925   nonnull_assert(objPtr != NULL);
16926   nonnull_assert(pPtr != NULL);
16927   nonnull_assert(clientData != NULL);
16928 
16929   value = ObjStr(objPtr);
16930   /*fprintf(stderr, "convert to parameter '%s' t '%s'\n", value, pPtr->type);*/
16931   if (*value == ':' ||  (*value == '-' && *(value + 1) == ':')) {
16932     result = NsfPrintError(interp, "leading colon in '%s' not allowed in parameter specification '%s'",
16933                            ObjStr(objPtr), pPtr->name);
16934   } else {
16935     *clientData = (char *)ObjStr(objPtr);
16936     result = TCL_OK;
16937   }
16938 
16939   return result;
16940 }
16941 
16942 /*
16943  *----------------------------------------------------------------------
16944  * ConvertViaCmd --
16945  *
16946  *    Nsf_TypeConverter calling a used-defined checking/conversion
16947  *    function. It sets the client data (passed to C functions) to the
16948  *    Tcl_Obj.
16949  *
16950  * Results:
16951  *    Tcl result code, *clientData and **outObjPtr
16952  *
16953  * Side effects:
16954  *    None.
16955  *
16956  *----------------------------------------------------------------------
16957  */
16958 
16959 static int ConvertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16960               ClientData *clientData, Tcl_Obj **outObjPtr)
16961   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5);
16962 
16963 static int
ConvertViaCmd(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * pPtr,ClientData * clientData,Tcl_Obj ** outObjPtr)16964 ConvertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,  const Nsf_Param *pPtr,
16965               ClientData *clientData, Tcl_Obj **outObjPtr) {
16966   Tcl_Obj *ov[5], *savedResult;
16967   NsfObject *object;
16968   int result, oc;
16969 
16970   nonnull_assert(interp != NULL);
16971   nonnull_assert(objPtr != NULL);
16972   nonnull_assert(pPtr != NULL);
16973   nonnull_assert(clientData != NULL);
16974   nonnull_assert(outObjPtr != NULL);
16975 
16976   /*
16977    * In general, when the converter is used e.g. for result checking,
16978    * we do not want to alter the result just when the converter sets a
16979    * result. So, for non-converter, we save the old result and restore
16980    * it before the return in case of success. Strictly speaking,
16981    * result-overwriting just harms for result-converters, but saving is
16982    * always semantically correct.
16983    */
16984   if (unlikely((pPtr->flags & NSF_ARG_IS_CONVERTER) == 0u)) {
16985     savedResult = Tcl_GetObjResult(interp); /* save the result */
16986     INCR_REF_COUNT(savedResult);
16987   } else {
16988     savedResult = NULL;
16989   }
16990 
16991   ov[0] = (pPtr->slotObj != NULL) ? pPtr->slotObj : NsfGlobalObjs[NSF_METHOD_PARAMETER_SLOT_OBJ];
16992   ov[1] = pPtr->converterName;
16993   ov[2] = pPtr->nameObj;
16994   ov[3] = objPtr;
16995 
16996   oc = 4;
16997   if (pPtr->converterArg != NULL) {
16998     ov[4] = pPtr->converterArg;
16999     oc++;
17000   }
17001 
17002   /*fprintf(stderr, "ConvertViaCmd call converter %s (refCount %d) on %s paramPtr %p arg %p oc %d\n",
17003           ObjStr(pPtr->converterName), pPtr->converterName->refCount, ObjStr(ov[0]),
17004           pPtr, pPtr->converterArg, oc);*/
17005 
17006   INCR_REF_COUNT(ov[1]);
17007   INCR_REF_COUNT(ov[2]);
17008 
17009   /* result = Tcl_EvalObjv(interp, oc, ov, 0); */
17010   result = GetObjectFromObj(interp, ov[0], &object);
17011   if(likely(result == TCL_OK)) {
17012     result = ObjectDispatch(object, interp, oc, ov, NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
17013   }
17014 
17015   DECR_REF_COUNT(ov[1]);
17016   DECR_REF_COUNT(ov[2]);
17017 
17018   /*
17019    * Per default, the input arg is the output arg.
17020    */
17021   assert(*outObjPtr == objPtr);
17022 
17023   if (likely(result == TCL_OK)) {
17024     /*fprintf(stderr, "ConvertViaCmd could convert %s to '%s' paramPtr %p, is_converter %d\n",
17025             ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)), pPtr,
17026             pPtr->flags & NSF_ARG_IS_CONVERTER);*/
17027     if ((pPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) {
17028       Tcl_Obj *resultObj;
17029 
17030       /*
17031        * If we want to convert, the resulting obj is the result of the
17032        * converter. The increment of the refCount is necessary e.g. for
17033        *
17034        *     return [expr {$value + 1}]
17035        *
17036        * The conversion is just needed, when resultObj differs from the actual
17037        * value in the output vector. Otherwise the conversion and the value
17038        * increment happened already before (and is already recorded in the
17039        * parse context).
17040        */
17041       resultObj = Tcl_GetObjResult(interp);
17042 
17043       if (*outObjPtr != resultObj) {
17044         INCR_REF_COUNT2("valueObj", resultObj);
17045         *outObjPtr = resultObj;
17046       }
17047       /*fprintf(stderr, "**** NSF_ARG_IS_CONVERTER %p\n", *outObjPtr);*/
17048     }
17049     *clientData = (ClientData) *outObjPtr;
17050 
17051     if (savedResult != NULL) {
17052       /*fprintf(stderr, "restore savedResult %p\n", savedResult);*/
17053       Tcl_SetObjResult(interp, savedResult);  /* restore the result */
17054     }
17055   }
17056 
17057   if (savedResult != NULL) {
17058     DECR_REF_COUNT(savedResult);
17059   }
17060 
17061   return result;
17062 }
17063 
17064 /*
17065  *----------------------------------------------------------------------
17066  * ConvertToObjpattern --
17067  *
17068  *    This function obtains a Tcl_Obj *, which contains the pattern if a Next
17069  *    Scripting Object. When this pattern contains no meta characters, we
17070  *    check whether the object exists. If it exists, the Tcl_Obj is converted to
17071  *    the cmd-type. If it does not exit, the function using this pattern will
17072  *    fail. If the pattern contains meta characters, we prepend to the pattern
17073  *    "::" if necessary to avoid errors, if one specifies a pattern object
17074  *    without the prefix. In this case, the patternObj is of plain type.
17075  *    The resulting patternObj has always the refCount incremented, which has
17076  *    to be decremented by the caller.x
17077  *
17078  * Results:
17079  *    Tcl result code.
17080  *
17081  * Side effects:
17082  *    Incremented refCount for the patternObj.
17083  *
17084  *----------------------------------------------------------------------
17085  */
17086 static int ConvertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
17087                     ClientData *clientData, Tcl_Obj **outObjPtr)
17088   nonnull(1) nonnull(2) nonnull(4) nonnull(5);
17089 
17090 static int
ConvertToObjpattern(Tcl_Interp * interp,Tcl_Obj * objPtr,const Nsf_Param * UNUSED (pPtr),ClientData * clientData,Tcl_Obj ** outObjPtr)17091 ConvertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, const Nsf_Param *UNUSED(pPtr),
17092                     ClientData *clientData, Tcl_Obj **outObjPtr) {
17093   Tcl_Obj    *patternObj;
17094   const char *pattern;
17095 
17096   nonnull_assert(interp != NULL);
17097   nonnull_assert(objPtr != NULL);
17098   nonnull_assert(clientData != NULL);
17099   nonnull_assert(outObjPtr != NULL);
17100 
17101   patternObj = objPtr;
17102   pattern = ObjStr(objPtr);
17103   if (NoMetaChars(pattern)) {
17104     /*
17105      * We have no meta characters, we try to check for an existing object
17106      */
17107     NsfObject *object = NULL;
17108 
17109     if (GetObjectFromObj(interp, objPtr, &object) == TCL_OK && object != NULL) {
17110       patternObj = object->cmdName;
17111     }
17112   } else {
17113     /*
17114      * We have a pattern and meta characters, we might have
17115      * to prefix it to ovoid obvious errors: since all object
17116      * names are prefixed with ::, we add this prefix automatically
17117      * to the match pattern, if it does not exist.
17118      */
17119     if (*pattern != ':' && *pattern+1 != ':') {
17120       patternObj = Tcl_NewStringObj("::", 2);
17121       Tcl_AppendLimitedToObj(patternObj, pattern, -1, INT_MAX, NULL);
17122     }
17123   }
17124   if (patternObj != NULL) {
17125     INCR_REF_COUNT2("patternObj", patternObj);
17126   }
17127   *clientData = (ClientData)patternObj;
17128   /* The following assert does not hold here, since we
17129      have a direct call to the converter
17130      assert(*outObjPtr == objPtr); */
17131 
17132   *outObjPtr = objPtr;
17133   return TCL_OK;
17134 }
17135 
17136 /*
17137  *----------------------------------------------------------------------
17138  * ParamCheckObj --
17139  *
17140  *    This function returns a fresh Tcl_Obj in the form of a method name for a
17141  *    checker method.
17142  *
17143  * Results:
17144  *    Tcl_Obj
17145  *
17146  * Side effects:
17147  *    None
17148  *
17149  *----------------------------------------------------------------------
17150  */
17151 
17152 static Tcl_Obj *ParamCheckObj(const char *start, size_t len)
17153   nonnull(1) returns_nonnull;
17154 
17155 static Tcl_Obj *
ParamCheckObj(const char * start,size_t len)17156 ParamCheckObj(const char *start, size_t len) {
17157   Tcl_Obj *checker = Tcl_NewStringObj("type=", 5);
17158 
17159   nonnull_assert(start != NULL);
17160 
17161   Tcl_AppendLimitedToObj(checker, start, (int)len, INT_MAX, NULL);
17162   return checker;
17163 }
17164 
17165 /*
17166  *----------------------------------------------------------------------
17167  * ParamOptionSetConverter --
17168  *
17169  *    Fill in the fields int to the specified paramPtr structure
17170  *    checker method and perform sanity checking.
17171  *
17172  * Results:
17173  *    Standard result code
17174  *
17175  * Side effects:
17176  *    None
17177  *
17178  *----------------------------------------------------------------------
17179  */
17180 static int ParamOptionSetConverter(Tcl_Interp *interp, Nsf_Param *paramPtr,
17181                         const char *typeName, Nsf_TypeConverter *converter)
17182   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
17183 
17184 static int
ParamOptionSetConverter(Tcl_Interp * interp,Nsf_Param * paramPtr,const char * typeName,Nsf_TypeConverter * converter)17185 ParamOptionSetConverter(Tcl_Interp *interp, Nsf_Param *paramPtr,
17186                         const char *typeName, Nsf_TypeConverter *converter) {
17187   int result;
17188 
17189   nonnull_assert(interp != NULL);
17190   nonnull_assert(paramPtr != NULL);
17191   nonnull_assert(typeName != NULL);
17192   nonnull_assert(converter != NULL);
17193 
17194   if (paramPtr->converter != NULL) {
17195     result = NsfPrintError(interp, "refuse to redefine parameter type of '%s' from type '%s' to type '%s'",
17196                            paramPtr->name, paramPtr->type, typeName);
17197   } else {
17198     paramPtr->converter = converter;
17199     paramPtr->nrArgs = 1;
17200     paramPtr->type = typeName;
17201     result = TCL_OK;
17202   }
17203   return result;
17204 }
17205 
17206 
17207 /*
17208  *----------------------------------------------------------------------
17209  * Unescape --
17210  *
17211  *    Unescape double commas in the provided Tcl_Obj.
17212  *
17213  * Results:
17214  *    None
17215  *
17216  * Side effects:
17217  *    Potentially shortened string content
17218  *
17219  *----------------------------------------------------------------------
17220  */
17221 
17222 static void Unescape(Tcl_Obj *objPtr)
17223   nonnull(1);
17224 
17225 static void
Unescape(Tcl_Obj * objPtr)17226 Unescape(Tcl_Obj *objPtr) {
17227   int i, j, l;
17228   char *string;
17229 
17230   nonnull_assert(objPtr != NULL);
17231 
17232   l = Tcl_GetCharLength(objPtr);
17233   string = ObjStr(objPtr);
17234 
17235   for (i = 0; i < l; i++) {
17236     if (string[i] == ',' && string[i+1] == ',') {
17237       for (j = i+1; j < l; j++) {
17238         string[j] = string[j+1];
17239       }
17240       l--;
17241       i++;
17242     }
17243   }
17244   Tcl_SetObjLength(objPtr, l);
17245 }
17246 
17247 /*
17248  *----------------------------------------------------------------------
17249  * ParamOptionParse --
17250  *
17251  *    Parse a single parameter option of a parameter. The parameter option
17252  *    string is passed in as second argument, the sizes start and remainder
17253  *    flag the offsets in the string follow. As a result, the fields of the
17254  *    parameter structure are updated.
17255  *
17256  * Results:
17257  *    Tcl result code, updated fields in the Nsf_Param structure.
17258  *
17259  * Side effects:
17260  *    None.
17261  *
17262  *----------------------------------------------------------------------
17263  */
17264 
17265 static int ParamOptionParse(Tcl_Interp *interp, const char *argString,
17266                             size_t start, size_t optionLength,
17267                             unsigned int disallowedOptions, Nsf_Param *paramPtr,
17268                             bool unescape, const char *qualifier)
17269   nonnull(1) nonnull(2) nonnull(6);
17270 
17271 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)17272 ParamOptionParse(Tcl_Interp *interp, const char *argString,
17273                  size_t start, size_t optionLength,
17274                  unsigned int disallowedOptions, Nsf_Param *paramPtr,
17275                  bool unescape, const char *qualifier) {
17276   const char *dotdot, *option;
17277   char        firstChar;
17278   int         result = TCL_OK;
17279 
17280   nonnull_assert(interp != NULL);
17281   nonnull_assert(argString != NULL);
17282   nonnull_assert(paramPtr != NULL);
17283 
17284   option = argString + start;
17285   firstChar = *option;
17286 
17287   /*fprintf(stderr, "ParamOptionParse name %s, option '%s' (%ld) disallowed %.6x\n",
17288     paramPtr->name, option, start, disallowedOptions);*/
17289 
17290   if (firstChar == 'r' && strncmp(option, "required", NsfMax(3, optionLength)) == 0) {
17291     paramPtr->flags |= NSF_ARG_REQUIRED;
17292 
17293   } else if (firstChar == 'o' && strncmp(option, "optional",  NsfMax(3, optionLength)) == 0) {
17294     paramPtr->flags &= ~NSF_ARG_REQUIRED;
17295 
17296   } else if (firstChar == 's'
17297              && strncmp(option, "substdefault", 12) == 0
17298              ) {
17299     int  substDefaultFlags = 0;
17300     char trailingChar = *(option+12);
17301 
17302     if (trailingChar == '=') {
17303       Tcl_Obj *ov[2];
17304 
17305       ov[0] = NULL;
17306       ov[1] = Tcl_NewStringObj(option + 13, (int)optionLength - 13);
17307       INCR_REF_COUNT(ov[1]);
17308       result = Nsf_ExprObjCmd(NULL, interp, 2, ov);
17309       DECR_REF_COUNT(ov[1]);
17310 
17311       if (result == TCL_OK) {
17312         Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
17313 
17314         if ((Tcl_GetIntFromObj(interp, resultObj, &substDefaultFlags) != TCL_OK)
17315             || (substDefaultFlags < 0) || (substDefaultFlags > 7)
17316             ) {
17317           return NsfPrintError(interp,
17318                                "parameter option 'substdefault=' must be a value between 0b000 and 0b111: %s",
17319                                option);
17320         }
17321       } else {
17322         return NsfPrintError(interp, "substdefault expression failed: %s", ObjStr(Tcl_GetObjResult(interp)));
17323       }
17324     } else if (trailingChar == '\0' || trailingChar == ',') {
17325       substDefaultFlags = 7;
17326     } else {
17327       return NsfPrintError(interp, "unexpected character %c (%d) after 'substdefault'", trailingChar, trailingChar);
17328     }
17329     paramPtr->flags |= NSF_ARG_SUBST_DEFAULT;
17330     paramPtr->flags |= ((unsigned int)substDefaultFlags << 28);
17331 
17332   } else if (firstChar == 'c' && strncmp(option, "convert", 7) == 0) {
17333     paramPtr->flags |= NSF_ARG_IS_CONVERTER;
17334 
17335   } else if (firstChar == 'i' && strncmp(option, "initcmd", 7) == 0) {
17336     if (unlikely((paramPtr->flags & (NSF_ARG_CMD|NSF_ARG_ALIAS|NSF_ARG_FORWARD)) != 0u)) {
17337       return NsfPrintError(interp, "parameter option 'initcmd' not valid in this option combination");
17338     }
17339     paramPtr->flags |= NSF_ARG_INITCMD;
17340 
17341   } else if (firstChar == 'c' && strncmp(option, "cmd", 3) == 0) {
17342     if (unlikely((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_ALIAS|NSF_ARG_FORWARD)) != 0u)) {
17343       return NsfPrintError(interp, "parameter option 'cmd' not valid in this option combination");
17344     }
17345     paramPtr->flags |= NSF_ARG_CMD;
17346 
17347   } else if (firstChar == 'a' && strncmp(option, "alias", 5) == 0) {
17348     if (unlikely((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_CMD|NSF_ARG_FORWARD)) != 0u)) {
17349       return NsfPrintError(interp, "parameter option 'alias' not valid in this option combination");
17350     }
17351     paramPtr->flags |= NSF_ARG_ALIAS;
17352 
17353   } else if (firstChar == 'f' && strncmp(option, "forward", 7) == 0) {
17354     if (unlikely((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_CMD|NSF_ARG_ALIAS)) != 0u)) {
17355       return NsfPrintError(interp, "parameter option 'forward' not valid in this option combination");
17356     }
17357     paramPtr->flags |= NSF_ARG_FORWARD;
17358 
17359   } else if (firstChar == 's' && strncmp(option, "slotset", 7) == 0) {
17360     if (unlikely(paramPtr->slotObj == NULL)) {
17361       return NsfPrintError(interp, "parameter option 'slotset' must follow 'slot='");
17362     }
17363     paramPtr->flags |= NSF_ARG_SLOTSET;
17364 
17365   } else if (firstChar == 's' && strncmp(option, "slotinitialize", 14) == 0) {
17366     if (unlikely(paramPtr->slotObj == NULL)) {
17367       return NsfPrintError(interp, "parameter option 'slotinit' must follow 'slot='");
17368     }
17369     paramPtr->flags |= NSF_ARG_SLOTINITIALIZE;
17370 
17371   } else if ((dotdot = strnstr(option, "..", optionLength-1))) {
17372     /*
17373      * Check lower bound.
17374      */
17375     if (*option == '0') {
17376       paramPtr->flags |= NSF_ARG_ALLOW_EMPTY;
17377     } else if (unlikely(*option != '1')) {
17378       return NsfPrintError(interp, "lower bound of multiplicity in %s not supported", argString);
17379     }
17380     /*
17381      * Check upper bound.
17382      */
17383     option = dotdot + 2;
17384     if (*option == '*' || *option == 'n') {
17385       if (unlikely((paramPtr->flags & (NSF_ARG_SWITCH)) != 0u)) {
17386         return NsfPrintError(interp,
17387                              "upper bound of multiplicity of '%c' not allowed for \"switch\"\n", *option);
17388       }
17389       paramPtr->flags |= NSF_ARG_MULTIVALUED;
17390     } else if (*option != '1') {
17391       return NsfPrintError(interp, "upper bound of multiplicity in %s not supported", argString);
17392     }
17393 
17394   } else if (firstChar == 'n' && strncmp(option, "noarg", 5) == 0) {
17395     if ((paramPtr->flags & NSF_ARG_ALIAS) == 0u) {
17396       return NsfPrintError(interp, "parameter option \"noarg\" only allowed for parameter type \"alias\"");
17397     }
17398     paramPtr->flags |= NSF_ARG_NOARG;
17399     paramPtr->nrArgs = 0;
17400 
17401   } else if (firstChar == 'n' && strncmp(option, "nodashalnum", 11) == 0) {
17402     if (*paramPtr->name == '-') {
17403       return NsfPrintError(interp, "parameter option 'nodashalnum' only allowed for positional parameters");
17404     }
17405     paramPtr->flags |= NSF_ARG_NODASHALNUM;
17406 
17407   } else if (firstChar == 'n' && strncmp(option, "noconfig", 8) == 0) {
17408     if (disallowedOptions != NSF_DISALLOWED_ARG_OBJECT_PARAMETER) {
17409       return NsfPrintError(interp, "parameter option 'noconfig' only allowed for object parameters");
17410     }
17411     paramPtr->flags |= NSF_ARG_NOCONFIG;
17412 
17413   } else if (firstChar == 'a' && strncmp(option, "args", 4) == 0) {
17414     if ((paramPtr->flags & NSF_ARG_ALIAS) == 0u) {
17415       return NsfPrintError(interp, "parameter option \"args\" only allowed for parameter type \"alias\"");
17416     }
17417     result = ParamOptionSetConverter(interp, paramPtr, "args", ConvertToNothing);
17418 
17419   } else if (firstChar == 'a' && optionLength >= 4 && strncmp(option, "arg=", 4) == 0) {
17420     if (paramPtr->converter != ConvertViaCmd) {
17421       return NsfPrintError(interp,
17422                            "parameter option 'arg=' only allowed for user-defined converter");
17423     }
17424     if (paramPtr->converterArg != NULL) {
17425       DECR_REF_COUNT(paramPtr->converterArg);
17426     }
17427     paramPtr->converterArg = Tcl_NewStringObj(option + 4, (int)optionLength - 4);
17428     /*
17429      * In case, we know that we have to unescape double commas, do it here...
17430      */
17431     if (unlikely(unescape)) {
17432       Unescape(paramPtr->converterArg);
17433     }
17434     INCR_REF_COUNT(paramPtr->converterArg);
17435 
17436   } else if (firstChar == 's' && strncmp(option, "switch", 6) == 0) {
17437     if (*paramPtr->name != '-') {
17438       return NsfPrintError(interp,
17439                            "invalid parameter type \"switch\" for argument \"%s\"; "
17440                            "type \"switch\" only allowed for non-positional arguments",
17441                            paramPtr->name);
17442     } else if ((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) != 0u) {
17443       return NsfPrintError(interp, "parameter invocation types cannot be used with option 'switch'");
17444     }
17445     result = ParamOptionSetConverter(interp, paramPtr, "switch", Nsf_ConvertToSwitch);
17446     paramPtr->flags |= NSF_ARG_SWITCH;
17447     paramPtr->nrArgs = 0;
17448     assert(paramPtr->defaultValue == NULL);
17449     paramPtr->defaultValue = Tcl_NewBooleanObj(0);
17450     INCR_REF_COUNT(paramPtr->defaultValue);
17451 
17452   } else if (firstChar == 'i' && strncmp(option, "integer", NsfMax(3, optionLength)) == 0) {
17453     result = ParamOptionSetConverter(interp, paramPtr, "integer", Nsf_ConvertToInteger);
17454 
17455   } else if (firstChar == 'i' && strncmp(option, "int32", 5) == 0) {
17456     result = ParamOptionSetConverter(interp, paramPtr, "int32", Nsf_ConvertToInt32);
17457 
17458   } else if (firstChar == 'b' && strncmp(option, "boolean", 7) == 0) {
17459     result = ParamOptionSetConverter(interp, paramPtr, "boolean", Nsf_ConvertToBoolean);
17460 
17461   } else if (firstChar == 'o' && strncmp(option, "object", 6) == 0) {
17462     result = ParamOptionSetConverter(interp, paramPtr, "object", Nsf_ConvertToObject);
17463 
17464   } else if (firstChar == 'c' && strncmp(option, "class", 5) == 0) {
17465     result = ParamOptionSetConverter(interp, paramPtr, "class", Nsf_ConvertToClass);
17466 
17467   } else if (firstChar == 'm' && strncmp(option, "metaclass", 9) == 0) {
17468     result = ParamOptionSetConverter(interp, paramPtr, "class", Nsf_ConvertToClass);
17469     paramPtr->flags |= NSF_ARG_METACLASS;
17470 
17471   } else if (firstChar == 'b' && strncmp(option, "baseclass", 9) == 0) {
17472     result = ParamOptionSetConverter(interp, paramPtr, "class", Nsf_ConvertToClass);
17473     paramPtr->flags |= NSF_ARG_BASECLASS;
17474 
17475   } else if (firstChar == 'm' && strncmp(option, "mixinreg", 8) == 0) {
17476     result = ParamOptionSetConverter(interp, paramPtr, "mixinreg", Nsf_ConvertToMixinreg);
17477 
17478   } else if (firstChar == 'f' && strncmp(option, "filterreg", 9) == 0) {
17479     result = ParamOptionSetConverter(interp, paramPtr, "filterreg", Nsf_ConvertToFilterreg);
17480 
17481   } else if (firstChar == 'p' && strncmp(option, "parameter", 9) == 0) {
17482     result = ParamOptionSetConverter(interp, paramPtr, "parameter", Nsf_ConvertToParameter);
17483 
17484   } else if (firstChar == 't' && optionLength >= 6 && strncmp(option, "type=", 5) == 0) {
17485     const char* typeValue = option + 5;
17486     int         typeValueLength = (int)optionLength - 5;
17487 
17488     if (paramPtr->converter != Nsf_ConvertToObject
17489         && paramPtr->converter != Nsf_ConvertToClass ) {
17490       return NsfPrintError(interp, "parameter option 'type=' only allowed for parameter types 'object' and 'class'");
17491     }
17492     if (paramPtr->converterArg != NULL) {
17493       DECR_REF_COUNT(paramPtr->converterArg);
17494     }
17495 
17496     if (qualifier != NULL && !isAbsolutePath(typeValue) &&
17497         isAbsolutePath(qualifier)) {
17498       Tcl_DString ds, *dsPtr = &ds;
17499       Tcl_DStringInit(dsPtr);
17500       Tcl_DStringAppend(dsPtr, qualifier, -1);
17501       if (Tcl_DStringLength(dsPtr) > 2) {
17502         Tcl_DStringAppend(dsPtr, "::", 2);
17503       }
17504       Tcl_DStringAppend(dsPtr, typeValue, typeValueLength);
17505       paramPtr->converterArg = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
17506       Tcl_DStringFree(dsPtr);
17507     } else {
17508       paramPtr->converterArg = Tcl_NewStringObj(typeValue, typeValueLength);
17509     }
17510 
17511     if (unlikely(unescape)) {
17512       Unescape(paramPtr->converterArg);
17513     }
17514     INCR_REF_COUNT(paramPtr->converterArg);
17515 
17516   } else if (firstChar == 's' && optionLength >= 6 && strncmp(option, "slot=", 5) == 0) {
17517     if (paramPtr->slotObj != NULL) {
17518       DECR_REF_COUNT(paramPtr->slotObj);
17519     }
17520     paramPtr->slotObj = Tcl_NewStringObj(option + 5,  (int)optionLength - 5);
17521     if (unlikely(unescape)) {
17522       Unescape(paramPtr->slotObj);
17523     }
17524     INCR_REF_COUNT(paramPtr->slotObj);
17525 
17526   } else if (firstChar == 'm' && optionLength >= 6 && strncmp(option, "method=", 7) == 0) {
17527     if ((paramPtr->flags & (NSF_ARG_ALIAS|NSF_ARG_FORWARD|NSF_ARG_SLOTSET)) == 0u) {
17528       return NsfPrintError(interp, "parameter option 'method=' only allowed for parameter "
17529                            "types 'alias', 'forward' and 'slotset'");
17530     }
17531     if (paramPtr->method != NULL) {
17532       DECR_REF_COUNT(paramPtr->method);
17533     }
17534     paramPtr->method = Tcl_NewStringObj(option + 7,  (int)optionLength - 7);
17535     if (unlikely(unescape)) {
17536       Unescape(paramPtr->method);
17537     }
17538     INCR_REF_COUNT(paramPtr->method);
17539 
17540   } else if ((firstChar == 'v') &&
17541              ((strncmp(option, "virtualobjectargs", 17) == 0) ||
17542               (strncmp(option, "virtualclassargs", 16) == 0))) {
17543     result = ParamOptionSetConverter(interp, paramPtr, option, ConvertToNothing);
17544   } else {
17545     Tcl_DString ds, *dsPtr = &ds;
17546 #ifdef  NSF_WITH_TCL_OBJ_TYPES_AS_CONVERTER
17547     const Tcl_ObjType *tclObjType;
17548 #endif
17549 
17550     if (option[0] == '\0') {
17551       NsfLog(interp, NSF_LOG_WARN, "empty parameter option ignored");
17552       return TCL_OK;
17553     }
17554 
17555     Tcl_DStringInit(dsPtr);
17556     Tcl_DStringAppend(dsPtr, option,  (int)optionLength);
17557 
17558     if (unlikely(paramPtr->converter != NULL)) {
17559       NsfPrintError(interp, "parameter option '%s' unknown for parameter type '%s'",
17560                     Tcl_DStringValue(dsPtr), paramPtr->type);
17561       Tcl_DStringFree(dsPtr);
17562       return TCL_ERROR;
17563     }
17564 
17565     /*fprintf(stderr, "HAV TYPE converter for <%s> ?\n", option);*/
17566 
17567     if (Nsf_PointerTypeLookup(Tcl_DStringValue(dsPtr))) {
17568       /*
17569        * Check whether the option refers to a pointer converter.
17570        */
17571       ParamOptionSetConverter(interp, paramPtr,  Tcl_DStringValue(dsPtr), Nsf_ConvertToPointer);
17572       Tcl_DStringFree(dsPtr);
17573 
17574 #ifdef NSF_WITH_TCL_OBJ_TYPES_AS_CONVERTER
17575     } else if ((tclObjType = Tcl_GetObjType(option)) != NULL) {
17576       /*fprintf(stderr, "SET TYPE converter for <%s>\n", option);*/
17577       result = ParamOptionSetConverter(interp, paramPtr,  Tcl_DStringValue(dsPtr), Nsf_ConvertToTclObjType);
17578       if (paramPtr->converterArg != NULL) {
17579           DECR_REF_COUNT(paramPtr->converterArg);
17580         }
17581         paramPtr->converterArg = Tcl_NewObj();
17582         paramPtr->converterArg->internalRep.twoPtrValue.ptr1 = (void *)tclObjType;
17583         INCR_REF_COUNT(paramPtr->converterArg);
17584 #endif
17585     } else {
17586       int i, found = -1;
17587 
17588       /*
17589        * The option is still unknown, check the Tcl string-is checkers
17590        */
17591       Tcl_DStringFree(dsPtr);
17592 
17593       for (i = 0; stringTypeOpts[i]; i++) {
17594         /*
17595          * Do not allow abbreviations, so the additional strlen() checks
17596          * for a full match.
17597          */
17598         if (strncmp(option, stringTypeOpts[i], optionLength) == 0
17599             && strlen(stringTypeOpts[i]) == optionLength) {
17600           found = i;
17601           break;
17602         }
17603       }
17604 
17605       if (found > -1) {
17606         /*
17607          * Converter is stringType.
17608          */
17609         result = ParamOptionSetConverter(interp, paramPtr, "stringtype", Nsf_ConvertToTclobj);
17610         if (paramPtr->converterArg != NULL) {
17611           DECR_REF_COUNT(paramPtr->converterArg);
17612         }
17613         paramPtr->converterArg = Tcl_NewStringObj(stringTypeOpts[i], -1);
17614         INCR_REF_COUNT(paramPtr->converterArg);
17615       } else {
17616 
17617         /*
17618          * The parameter option is still unknown. We assume that the parameter
17619          * option identifies a user-defined argument checker, implemented as a
17620          * method.
17621          */
17622         if (paramPtr->converterName != NULL) {
17623           DECR_REF_COUNT2("converterNameObj", paramPtr->converterName);
17624         }
17625         paramPtr->converterName = ParamCheckObj(option, optionLength);
17626         INCR_REF_COUNT2("converterNameObj", paramPtr->converterName);
17627         result = ParamOptionSetConverter(interp, paramPtr, ObjStr(paramPtr->converterName), ConvertViaCmd);
17628       }
17629     }
17630   }
17631 
17632   if ((paramPtr->flags & disallowedOptions) != 0u) {
17633     return NsfPrintError(interp, "parameter option '%s' not allowed", option);
17634   }
17635 
17636   if (unlikely(((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) != 0u)
17637                && ((paramPtr->flags & NSF_ARG_NOCONFIG)) != 0u)) {
17638     return NsfPrintError(interp, "parameter option 'noconfig' cannot used together with this type of object parameter");
17639   }
17640 
17641   return result;
17642 }
17643 
17644 /*
17645  *----------------------------------------------------------------------
17646  * ParamDefinitionParse --
17647  *
17648  *    Parse a single parameter definition with a possible default provided in
17649  *    the form of a Tcl_Obj.
17650  *
17651  * Results:
17652  *    Tcl result code
17653  *
17654  * Side effects:
17655  *    None.
17656  *
17657  *----------------------------------------------------------------------
17658  */
17659 
17660 static int ParamDefinitionParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *arg,
17661                                 unsigned int disallowedFlags,
17662                                 Nsf_Param *paramPtr, int *possibleUnknowns, int *plainParams,
17663                                 int *nrNonposArgs, const char *qualifier)
17664   nonnull(1) nonnull(3) nonnull(5) nonnull(6) nonnull(7) nonnull(8);
17665 
17666 static int
ParamDefinitionParse(Tcl_Interp * interp,Tcl_Obj * procNameObj,Tcl_Obj * arg,unsigned int disallowedFlags,Nsf_Param * paramPtr,int * possibleUnknowns,int * plainParams,int * nrNonposArgs,const char * qualifier)17667 ParamDefinitionParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *arg, unsigned int disallowedFlags,
17668                      Nsf_Param *paramPtr, int *possibleUnknowns, int *plainParams, int *nrNonposArgs,
17669                      const char *qualifier) {
17670   const char  *argString, *argName;
17671   int          result, npac, isNonposArgument, parensCount;
17672   size_t       length, j;
17673   Tcl_Obj    **npav;
17674 
17675   nonnull_assert(interp != NULL);
17676   nonnull_assert(arg != NULL);
17677   nonnull_assert(paramPtr != NULL);
17678   nonnull_assert(possibleUnknowns != NULL);
17679   nonnull_assert(plainParams != NULL);
17680   nonnull_assert(nrNonposArgs != NULL);
17681 
17682   paramPtr->paramObj = arg;
17683   INCR_REF_COUNT(paramPtr->paramObj);
17684 
17685   result = Tcl_ListObjGetElements(interp, paramPtr->paramObj, &npac, &npav);
17686   if (unlikely(result != TCL_OK || npac < 1 || npac > 2)) {
17687     if (procNameObj != NULL) {
17688       result = NsfPrintError(interp,
17689                              "wrong # of elements in parameter definition "
17690                              "of method '%s'. "
17691                              "Should be a list of 1 or 2 elements, but got: '$s'",
17692                              ObjStr(procNameObj), ObjStr(paramPtr->paramObj));
17693     } else {
17694       result = NsfPrintError(interp,
17695                              "wrong # of elements in parameter definition. "
17696                              "Should be a list of 1 or 2 elements, but got: '%s'",
17697                              ObjStr(paramPtr->paramObj));
17698     }
17699     DECR_REF_COUNT(paramPtr->paramObj);
17700     return result;
17701   }
17702 
17703   argString = ObjStr(npav[0]);
17704   length = strlen(argString);
17705   /*
17706      For whatever reason, the snippet above seems to be faster than:
17707 
17708      argString = TclGetStringFromObj(npav[0], &result);
17709      length    = (size_t) result;
17710   */
17711 
17712   /*
17713    * Per default parameter have exactly one argument; types without arguments
17714    * (like "switch") have to set their nrArgs explicitly.
17715    */
17716   paramPtr->nrArgs = 1;
17717 
17718   isNonposArgument = *argString == '-';
17719   if (isNonposArgument != 0) {
17720     argName = argString+1;
17721     (*nrNonposArgs) ++;
17722   } else {
17723     argName = argString;
17724     paramPtr->flags |= NSF_ARG_REQUIRED; /* positional arguments are required unless we have a default */
17725   }
17726 
17727   /*fprintf(stderr, "... parsing '%s', name '%s' argString '%s' \n",
17728     ObjStr(arg), argName, argString);*/
17729 
17730   /*
17731    * Find the first ':' outside of parens; the name of the parameter might be
17732    * in array syntax, the array index might contain ":", "," etc.
17733    */
17734   parensCount = 0;
17735   for (j = 0; j < length; j++) {
17736     if (parensCount > 0 && argString[j] == ')') {
17737       parensCount --;
17738       continue;
17739     }
17740     if (argString[j] == '(') {
17741       parensCount ++;
17742       continue;
17743     }
17744     if (parensCount == 0 && argString[j] == ':') {
17745       break;
17746     }
17747   }
17748 
17749   if (argString[j] == ':') {
17750     /*
17751      * We found a ':'
17752      */
17753     size_t l, start, end;
17754     bool   unescape = NSF_FALSE;
17755 
17756     /*
17757      * Get parameter name
17758      */
17759     STRING_NEW(paramPtr->name, argString, j);
17760     paramPtr->nameObj = Tcl_NewStringObj(argName, (isNonposArgument != 0) ? (int)j-1 : (int)j);
17761     INCR_REF_COUNT(paramPtr->nameObj);
17762 
17763     /*
17764      * Skip space at begin
17765      */
17766     for (start = j+1; start<length && isspace((int)argString[start]); start++) {
17767       ;
17768     }
17769 
17770     /*
17771      * Search for unescaped ','
17772      */
17773     for (l = start; l < length; l++) {
17774       if (unlikely(argString[l] == ',')) {
17775         if (likely(argString[l+1]) == ',') {
17776           l++;
17777           unescape = NSF_TRUE;
17778           continue;
17779         }
17780         /*
17781          * Skip space from end.
17782          */
17783         for (end = l; end > 0 && isspace((int)argString[end-1]); end--);
17784         result = ParamOptionParse(interp, argString, start, end-start, disallowedFlags, paramPtr, unescape,
17785                                   qualifier);
17786         unescape = NSF_FALSE;
17787         if (unlikely(result != TCL_OK)) {
17788           goto param_error;
17789         }
17790         l++;
17791         /*
17792          * Skip space from begin.
17793          */
17794         for (start = l; start<length && isspace((int)argString[start]); start++) {
17795           ;
17796         }
17797       }
17798     }
17799     /*
17800      * skip space from end
17801      */
17802     for (end = l; end > 0 && isspace((int)argString[end-1]); end--);
17803 
17804     /*
17805      * process last option
17806      */
17807     if (end-start > 0) {
17808       result = ParamOptionParse(interp, argString, start, end-start, disallowedFlags, paramPtr, unescape,
17809                                 qualifier);
17810       if (unlikely(result != TCL_OK)) {
17811         goto param_error;
17812       }
17813     }
17814 
17815   } else {
17816     /*
17817      * No ':', the whole arg is the name, we have no options
17818      */
17819     STRING_NEW(paramPtr->name, argString, length);
17820     if (isNonposArgument != 0) {
17821       paramPtr->nameObj = Tcl_NewStringObj(argName, (int)length-1);
17822     } else {
17823       (*plainParams) ++;
17824       paramPtr->nameObj = Tcl_NewStringObj(argName, (int)length);
17825     }
17826     INCR_REF_COUNT(paramPtr->nameObj);
17827   }
17828 
17829   /*
17830    * If we have two arguments in the list, the second one is a default value
17831    */
17832   if (npac == 2) {
17833 
17834     if ((disallowedFlags & NSF_ARG_HAS_DEFAULT) != 0u) {
17835       NsfPrintError(interp, "parameter specification for \"%s\" is not allowed to have default \"%s\"",
17836                     argString, ObjStr(npav[1]));
17837       goto param_error;
17838     }
17839 
17840     /*
17841      * If we have for some reason already a default value, free it
17842      */
17843     if (paramPtr->defaultValue != NULL) {
17844       DECR_REF_COUNT(paramPtr->defaultValue);
17845     }
17846     paramPtr->defaultValue = Tcl_DuplicateObj(npav[1]);
17847     INCR_REF_COUNT(paramPtr->defaultValue);
17848     /*
17849      * The argument will be not required for an invocation, since we
17850      * have a default.
17851      */
17852     paramPtr->flags &= ~NSF_ARG_REQUIRED;
17853   } else if ((paramPtr->flags & NSF_ARG_SUBST_DEFAULT) != 0u) {
17854     NsfPrintError(interp,
17855                   "parameter option substdefault specified for parameter \"%s\""
17856                   " without default value", paramPtr->name);
17857     goto param_error;
17858   }
17859 
17860   /*
17861    * Postprocessing the parameter options
17862    */
17863 
17864   if (paramPtr->converter == NULL) {
17865     /*
17866      * If no converter is set, use the default converter
17867      */
17868     paramPtr->converter = Nsf_ConvertToTclobj;
17869   } else if (
17870       paramPtr->converter == ConvertToNothing
17871       && (paramPtr->flags & (NSF_ARG_ALLOW_EMPTY|NSF_ARG_MULTIVALUED)) != 0u
17872   ) {
17873       NsfPrintError(interp,
17874                     "multiplicity settings for variable argument parameter \"%s\" not allowed",
17875                     paramPtr->name);
17876       goto param_error;
17877   }
17878 
17879   /*
17880    * Check for application specific value checkers and converters
17881    */
17882   /*fprintf(stderr, "parm %s: slotObj %p viaCmd? %d\n",
17883           paramPtr->name, paramPtr->slotObj, paramPtr->converter == ConvertViaCmd);*/
17884 
17885   if ((paramPtr->slotObj || paramPtr->converter == ConvertViaCmd) && paramPtr->type) {
17886     const char *converterNameString;
17887     Tcl_Obj    *converterNameObj, *slotObj;
17888     NsfObject  *paramObject;
17889     Tcl_Command cmd;
17890     NsfClass   *paramClass = NULL;
17891 
17892     slotObj = (paramPtr->slotObj != NULL) ? paramPtr->slotObj : NsfGlobalObjs[NSF_METHOD_PARAMETER_SLOT_OBJ];
17893     result = GetObjectFromObj(interp, slotObj, &paramObject);
17894     if (unlikely(result != TCL_OK)) {
17895       NsfPrintError(interp, "non-existing slot object \"%s\"", ObjStr(slotObj));
17896       goto param_error;
17897     }
17898     if (paramPtr->converterName == NULL) {
17899       converterNameObj = ParamCheckObj(paramPtr->type, strlen(paramPtr->type));
17900       INCR_REF_COUNT2("converterNameObj", converterNameObj);
17901     } else {
17902       converterNameObj = paramPtr->converterName;
17903     }
17904     converterNameString = ObjStr(converterNameObj);
17905 
17906     cmd = ObjectFindMethod(interp, paramObject, converterNameObj, &paramClass);
17907     /*fprintf(stderr, "locating %s on %s returns %p (%s)\n",
17908       ObjStr(converterNameObj), ObjectName(paramObject), cmd, ClassName(paramClass));*/
17909     if (cmd == NULL) {
17910       if (paramPtr->converter == ConvertViaCmd) {
17911 
17912         NsfLog(interp, NSF_LOG_WARN, "Could not find value checker %s defined on %s",
17913                converterNameString, ObjectName(paramObject));
17914 
17915         paramPtr->flags |= NSF_ARG_CURRENTLY_UNKNOWN;
17916         /* TODO: for the time being, we do not return an error here */
17917       }
17918     } else if (paramPtr->converter != ConvertViaCmd &&
17919                paramPtr->slotObj &&
17920                strcmp(ObjStr(paramPtr->slotObj),
17921                       NsfGlobalStrings[NSF_METHOD_PARAMETER_SLOT_OBJ]) != 0) {
17922 
17923       NsfLog(interp, NSF_LOG_WARN, "Checker method %s defined on %s shadows built-in converter",
17924              converterNameString, ObjectName(paramObject));
17925 
17926       if (paramPtr->converterName == NULL) {
17927         paramPtr->converterName = converterNameObj;
17928         paramPtr->converter = NULL;
17929         result = ParamOptionSetConverter(interp, paramPtr, converterNameString, ConvertViaCmd);
17930         if (unlikely(result != TCL_OK)) {
17931           if (converterNameObj != paramPtr->converterName) {
17932             DECR_REF_COUNT2("converterNameObj", converterNameObj);
17933           }
17934           goto param_error;
17935         }
17936       }
17937     }
17938     if (((paramPtr->flags & NSF_ARG_IS_CONVERTER) != 0u)
17939         && paramPtr->converter != ConvertViaCmd) {
17940       NsfPrintError(interp, "option 'convert' only allowed for application-defined converters");
17941       if (converterNameObj != paramPtr->converterName) {
17942         DECR_REF_COUNT2("converterNameObj", converterNameObj);
17943       }
17944       goto param_error;
17945     }
17946 
17947     if (converterNameObj != paramPtr->converterName) {
17948       DECR_REF_COUNT2("converterNameObj", converterNameObj);
17949     }
17950   }
17951 
17952   /*
17953    * If the argument has no arguments and it is positional, it can't be
17954    * required.
17955    */
17956   if (paramPtr->nrArgs == 0
17957       && *paramPtr->name != '-'
17958       && (paramPtr->flags & NSF_ARG_REQUIRED) != 0u
17959       ) {
17960     paramPtr->flags &= ~NSF_ARG_REQUIRED;
17961   }
17962 
17963   /*
17964    * If the argument is not required and no default value is specified, we
17965    * have to handle in the client code (e.g. in the canonical arg handlers for
17966    * scripted methods) the unknown value (e.g. don't set/unset a variable)
17967    */
17968   if ((paramPtr->flags & NSF_ARG_REQUIRED) == 0u && paramPtr->defaultValue == NULL) {
17969     (*possibleUnknowns)++;
17970   }
17971   return TCL_OK;
17972 
17973  param_error:
17974   ParamFree(paramPtr);
17975   paramPtr->name = NULL;
17976 
17977 #if !defined(NDEBUG)
17978   /*
17979    * Whenever we return a TCL_ERROR, we expect that the interp result contains
17980    * an error message.
17981    */
17982   {
17983     const char *errStr = ObjStr(Tcl_GetObjResult(interp));
17984     assert(*errStr != '\0');
17985   }
17986 #endif
17987 
17988   return TCL_ERROR;
17989 }
17990 
17991 /*
17992  *----------------------------------------------------------------------
17993  * ParamDefsParse --
17994  *
17995  *    Parse a list of parameters in the form of Tcl_Objs into a parsedParamPtr
17996  *    structure (last argument). The argument allowedOptions is used to flag,
17997  *    what parameter options are generally allowed (typically different for
17998  *    method and object parameters). Unless forceParamdefs is set, the parsed
17999  *    parameter structure is only returned when needed (i.e. when not all
18000  *    parameters are plain parameters).
18001  *
18002  * Results:
18003  *    Tcl result code, parsedParameter structure in last argument (allocated
18004  *    by the caller).
18005  *
18006  * Side effects:
18007  *    None.
18008  *
18009  *----------------------------------------------------------------------
18010  */
18011 
18012 static int ParamDefsParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *paramSpecObjs,
18013                           unsigned int allowedOptions, bool forceParamdefs, NsfParsedParam *parsedParamPtr,
18014                           const char *qualifier)
18015   nonnull(1) nonnull(3) nonnull(6);
18016 
ParamDefsParse(Tcl_Interp * interp,Tcl_Obj * procNameObj,Tcl_Obj * paramSpecObjs,unsigned int allowedOptions,bool forceParamdefs,NsfParsedParam * parsedParamPtr,const char * qualifier)18017 static int ParamDefsParse(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Obj *paramSpecObjs,
18018                           unsigned int allowedOptions, bool forceParamdefs, NsfParsedParam *parsedParamPtr,
18019                           const char *qualifier) {
18020   Tcl_Obj **argsv;
18021   int result, argsc;
18022 
18023   nonnull_assert(interp != NULL);
18024   nonnull_assert(paramSpecObjs != NULL);
18025   nonnull_assert(parsedParamPtr != NULL);
18026 
18027   parsedParamPtr->paramDefs = NULL;
18028   parsedParamPtr->possibleUnknowns = 0;
18029 
18030   result = Tcl_ListObjGetElements(interp, paramSpecObjs, &argsc, &argsv);
18031   if (unlikely(result != TCL_OK)) {
18032     return NsfPrintError(interp, "cannot break down non-positional args: %s", ObjStr(paramSpecObjs));
18033   }
18034 
18035   if (argsc > 0) {
18036     Nsf_Param *paramsPtr, *paramPtr, *lastParamPtr;
18037     int i, possibleUnknowns = 0, plainParams = 0, nrNonposArgs = 0;
18038     NsfParamDefs *paramDefs;
18039 
18040     paramPtr = paramsPtr = ParamsNew((size_t)argsc);
18041 
18042     for (i = 0; i < argsc; i++, paramPtr++) {
18043       result = ParamDefinitionParse(interp, procNameObj, argsv[i], allowedOptions,
18044                                     paramPtr, &possibleUnknowns, &plainParams, &nrNonposArgs,
18045                                     qualifier);
18046 
18047       if (result == TCL_OK) {
18048         if (paramPtr->converter == ConvertToNothing && i < argsc-1) {
18049           result = NsfPrintError(interp,
18050                                  "parameter option \"args\" invalid for parameter \"%s\"; only allowed for last parameter",
18051                                  paramPtr->name);
18052         }
18053 
18054         /* fprintf(stderr, "qual %s\n", qualifier);
18055            if (qualifier != NULL &&
18056            (paramPtr->converter == Nsf_ConvertToObject ||
18057            paramPtr->converter == Nsf_ConvertToClass) &&
18058            paramPtr->converterArg != NULL) {
18059            fprintf(stderr, "qual %s\n", qualifier);
18060            const char *carg = ObjStr(paramPtr->converterArg);
18061            if (*carg != ':') {
18062            Tcl_Obj *qualifiedConverterArg = Tcl_NewStringObj(qualifier, -1);
18063            Tcl_AppendToObj(qualifiedConverterArg, "::", 2);
18064            Tcl_AppendObjToObj(qualifiedConverterArg, paramPtr->converterArg);
18065            DECR_REF_COUNT(paramPtr->converterArg);
18066            paramPtr->converterArg = qualifiedConverterArg;
18067            INCR_REF_COUNT(qualifiedConverterArg);
18068            fprintf(stderr, ">>> converterArg %s qualifier %s\n", ObjStr(paramPtr->converterArg), qualifier);
18069            }
18070            }*/
18071       }
18072       if (unlikely(result != TCL_OK)) {
18073         ParamsFree(paramsPtr);
18074         return result;
18075       }
18076       /*
18077        * Every parameter must have at least a name set.
18078        */
18079       assert(paramPtr->name);
18080     }
18081 #if defined(NSF_WITH_VALUE_WARNINGS)
18082     if (nrNonposArgs > 0 && argsc > 1) {
18083       for (i = 0; i < argsc; i++) {
18084         (paramsPtr + i)->flags |= NSF_ARG_CHECK_NONPOS;
18085       }
18086     }
18087 #endif
18088 
18089     /*
18090      * If all arguments are good old Tcl arguments, there is no need
18091      * to use the parameter definition structure, unless we force it.
18092      */
18093     if (plainParams == argsc && !forceParamdefs) {
18094       ParamsFree(paramsPtr);
18095       return TCL_OK;
18096     }
18097 
18098     /*fprintf(stderr, "we need param definition structure for {%s}, argsc %d plain %d\n",
18099       ObjStr(paramSpecObjs), argsc, plainParams);*/
18100 
18101     /*
18102      * Check the last argument. If the last argument is named 'args',
18103      * force converter and make it non-required.
18104      */
18105     lastParamPtr = paramPtr - 1;
18106     if (isArgsString(lastParamPtr->name)) {
18107       lastParamPtr->converter = ConvertToNothing;
18108       lastParamPtr->flags &= ~NSF_ARG_REQUIRED;
18109     }
18110 
18111     paramDefs = ParamDefsNew();
18112     paramDefs->paramsPtr = paramsPtr;
18113     paramDefs->nrParams = (int)(paramPtr - paramsPtr);
18114     /*fprintf(stderr, "method %s serial %d paramDefs %p ifsize %ld, possible unknowns = %d,\n",
18115       ObjStr(procNameObj), paramDefs->serial,
18116       paramDefs, paramPtr-paramsPtr, possibleUnknowns);*/
18117     parsedParamPtr->paramDefs = paramDefs;
18118     parsedParamPtr->possibleUnknowns = possibleUnknowns;
18119   }
18120   return TCL_OK;
18121 }
18122 
18123 /*
18124  *----------------------------------------------------------------------
18125  * ParameterMethodForwardDispatch --
18126  *
18127  *    Dispatch a forwarding method provided via parameter definition.
18128  *
18129  *    The current implementation performs for every object
18130  *    parameter forward the full cycle of
18131  *
18132  *     (a) splitting the spec,
18133  *     (b) convert it to a the client data structure,
18134  *     (c) invoke forward,
18135  *     (d) free client data structure
18136  *
18137  *    In the future, it should convert to the client data
18138  *    structure just once and free it with the disposal of the
18139  *    parameter. This could be achieved
18140  *
18141  * Results:
18142  *    Tcl result code
18143  *
18144  * Side effects:
18145  *    The called function might side-effect.
18146  *
18147  *----------------------------------------------------------------------
18148  */
18149 static int ParameterMethodForwardDispatch(Tcl_Interp *interp, NsfObject *object,
18150                                           const Nsf_Param *paramPtr, Tcl_Obj *newValue,
18151                                           NsfCallStackContent *cscPtr)
18152   nonnull(1) nonnull(2) nonnull(3);
18153 
18154 static int
ParameterMethodForwardDispatch(Tcl_Interp * interp,NsfObject * object,const Nsf_Param * paramPtr,Tcl_Obj * newValue,NsfCallStackContent * cscPtr)18155 ParameterMethodForwardDispatch(Tcl_Interp *interp, NsfObject *object,
18156                                const Nsf_Param *paramPtr, Tcl_Obj *newValue,
18157                                NsfCallStackContent *cscPtr) {
18158   Tcl_Obj **nobjv, *ov[3], *methodObj, *forwardSpec;
18159   ForwardCmdClientData *tcd = NULL;
18160   int result, oc, nobjc;
18161 
18162   nonnull_assert(interp != NULL);
18163   nonnull_assert(object != NULL);
18164   nonnull_assert(paramPtr != NULL);
18165   assert((paramPtr->flags & NSF_ARG_FORWARD) != 0u);
18166 
18167   forwardSpec = (paramPtr->method != NULL) ? paramPtr->method : NULL; /* different default? */
18168   if (forwardSpec == NULL) {
18169     return NsfPrintError(interp, "forward: no spec available\n");
18170   }
18171 
18172   result = Tcl_ListObjGetElements(interp, forwardSpec, &nobjc, &nobjv);
18173   if (unlikely(result != TCL_OK)) {
18174     return result;
18175   }
18176 
18177   methodObj = paramPtr->nameObj;
18178   result = ForwardProcessOptions(interp, methodObj,
18179                                  NULL /*withDefault*/,
18180                                  0 /*withEarlybinding*/,
18181                                  NULL /*withOnerror*/,
18182                                  NULL /*withMethodprefix*/,
18183                                  0 /*withFrame*/,
18184                                  NSF_FALSE /*withVerbose*/,
18185                                  nobjv[0], nobjc-1, nobjv+1, &tcd);
18186   if (unlikely(result != TCL_OK)) {
18187     if (tcd != NULL) {
18188       ForwardCmdDeleteProc(tcd);
18189     }
18190     return result;
18191   }
18192 
18193   /*fprintf(stderr, "parameter %s forward spec <%s> After Options obj %s method %s\n",
18194           ObjStr(paramPtr->nameObj), ObjStr(forwardSpec),
18195           ObjectName(object), ObjStr(methodObj));*/
18196 
18197   tcd->object = object;
18198   oc = 1;
18199   ov[0] = methodObj;
18200   if (paramPtr->nrArgs == 1 && newValue) {
18201     ov[oc] = newValue;
18202     oc ++;
18203   }
18204 
18205   /*
18206    * Mark the intermittent CSC frame as INACTIVE, so that, e.g.,
18207    * call-stack traversals seeking active frames ignore it.
18208    */
18209   if (cscPtr != NULL) {
18210     cscPtr->frameType = NSF_CSC_TYPE_INACTIVE;
18211   }
18212 
18213   result = NsfForwardMethod(tcd, interp, oc, ov);
18214   ForwardCmdDeleteProc(tcd);
18215 
18216   return result;
18217 }
18218 
18219 
18220 /*
18221  *----------------------------------------------------------------------
18222  * ParameterMethodDispatch --
18223  *
18224  *    Dispatch a method provided via parameter definition. The function checks
18225  *    the parameter definition, builds a argument list for the function call
18226  *    and invokes finally the configured cmd.  This function is typically
18227  *    called from configure.
18228  *
18229  * Results:
18230  *    Tcl result code
18231  *
18232  * Side effects:
18233  *    The called function might side-effect.
18234  *
18235  *----------------------------------------------------------------------
18236  */
18237 static int ParameterMethodDispatch(
18238     Tcl_Interp *interp, NsfObject *object,
18239     Nsf_Param *paramPtr, Tcl_Obj *newValue,
18240     CallFrame *uplevelVarFramePtr,
18241     const char *initString,
18242     Tcl_Obj **nextObjPtr,
18243     int nrRemainingArgs
18244 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(6) nonnull(7);
18245 
18246 static int
ParameterMethodDispatch(Tcl_Interp * interp,NsfObject * object,Nsf_Param * paramPtr,Tcl_Obj * newValue,CallFrame * uplevelVarFramePtr,const char * initString,Tcl_Obj ** nextObjPtr,int nrRemainingArgs)18247 ParameterMethodDispatch(
18248     Tcl_Interp *interp, NsfObject *object,
18249     Nsf_Param *paramPtr, Tcl_Obj *newValue,
18250     CallFrame *uplevelVarFramePtr,
18251     const char *initString,
18252     Tcl_Obj **nextObjPtr,
18253     int nrRemainingArgs
18254 ) {
18255   CallFrame           *varFramePtr;
18256   NsfCallStackContent  csc, *cscPtr = &csc;
18257   CallFrame            frame2, *framePtr2 = &frame2;
18258   int                  result = TCL_OK;
18259 
18260   nonnull_assert(interp != NULL);
18261   nonnull_assert(object != NULL);
18262   nonnull_assert(paramPtr != NULL);
18263   nonnull_assert(newValue != NULL);
18264   nonnull_assert(initString != NULL);
18265   nonnull_assert(nextObjPtr != NULL);
18266 
18267 #if 0
18268   {int i;
18269   fprintf(stderr, "ParameterMethodDispatch %s flags %06x nrRemainingArgs %d ",
18270           paramPtr->name, paramPtr->flags, nrRemainingArgs);
18271   for(i = 0; i < nrRemainingArgs; i++) {
18272     fprintf(stderr, " [%d]=%p %s,", i, &nextObjPtr[i], ObjStr(nextObjPtr[i]));
18273   }
18274   fprintf(stderr, "\n");
18275   }
18276 #endif
18277 
18278   /*
18279    * The current call-frame of configure uses an obj-frame, such
18280    * that setvar etc.  are able to access variables like "a" as a
18281    * local variable.  However, in the init block, we do not like
18282    * that behavior, since this should look like a proc body.
18283    * So we push yet another call-frame without providing the
18284    * var-frame.
18285    *
18286    * The new frame will have the namespace of the caller to avoid
18287    * the current obj-frame. Nsf_PushFrameCsc() will establish a
18288    * CMETHOD frame.
18289    */
18290   varFramePtr = Tcl_Interp_varFramePtr(interp);
18291   Tcl_Interp_varFramePtr(interp) = varFramePtr->callerVarPtr;
18292 
18293   cscPtr->flags = 0;
18294   CscInit(cscPtr, object, object->cl /*cl*/, NULL /*cmd*/,
18295           NSF_CSC_TYPE_PLAIN, 0, NsfGlobalStrings[NSF_CONFIGURE]);
18296   Nsf_PushFrameCsc(interp, cscPtr, framePtr2);
18297 
18298   if ((paramPtr->flags & (NSF_ARG_INITCMD|NSF_ARG_CMD)) != 0u) {
18299     /* cscPtr->cmdPtr = NSFindCommand(interp, "::eval"); */
18300     result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT);
18301 
18302   } else if ((paramPtr->flags & NSF_ARG_ALIAS) != 0u) {
18303     Tcl_Obj *methodObj, **ovPtr, *ov0;
18304     static Tcl_Obj *constantObj = NULL;
18305     const char *methodString;
18306     int oc = 0;
18307 
18308     /*
18309      * Restore the variable frame context as found at the original call
18310      * site of configure(). Note that we do not have to revert this
18311      * context change when leaving this configure() context because a
18312      * surrounding [uplevel] will correct the call-stack context for us ...
18313      */
18314     if (uplevelVarFramePtr != NULL) {
18315       Tcl_Interp_varFramePtr(interp) = uplevelVarFramePtr;
18316     }
18317 
18318     /*
18319      * Mark the intermittent CSC frame as INACTIVE, so that, e.g.,
18320      * call-stack traversals seeking active frames ignore it.
18321      */
18322     cscPtr->frameType = NSF_CSC_TYPE_INACTIVE;
18323 
18324     /*
18325      * If parameter option "method=" was given, use it as method name
18326      */
18327     methodObj = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
18328     methodString = ObjStr(methodObj);
18329 
18330     /*fprintf(stderr, "ALIAS %s, nrargs %d converter %p ConvertToNothing %d oc %d\n",
18331             paramPtr->name, paramPtr->nrArgs, paramPtr->converter,
18332             paramPtr->converter == ConvertToNothing,
18333             oc);*/
18334 
18335     if (paramPtr->converter == ConvertToNothing) {
18336       /*
18337        * We are using the varargs interface; pass all remaining args into
18338        * the called method.
18339        */
18340       if (newValue == paramPtr->defaultValue) {
18341         /*
18342          * Use the default.
18343          */
18344         if (Tcl_ListObjGetElements(interp, paramPtr->defaultValue, &oc, &ovPtr) != TCL_OK) {
18345           goto method_arg_done;
18346         }
18347         ov0 = *ovPtr;
18348         ovPtr ++;
18349       } else {
18350         /*
18351          * Use actual args.
18352          */
18353         ov0 = *nextObjPtr;
18354         /*fprintf(stderr, "ALIAS use actual args oc %d ov0 <%s> nextObjPtr %p %p\n",
18355           nrRemainingArgs, ObjStr(ov0), nextObjPtr, nextObjPtr+1);*/
18356         ovPtr = nextObjPtr+1;
18357         oc = nrRemainingArgs;
18358       }
18359     } else {
18360       /*
18361        * A simple alias, receives no arg (when noarg was specified) or a
18362        * single argument (which might be the default value).
18363        */
18364       int       moc = 1;
18365       Tcl_Obj **movPtr = NULL;
18366 
18367       ov0 = NULL;
18368       ovPtr = &constantObj;
18369 
18370       if (Tcl_ListObjGetElements(interp, methodObj, &moc, &movPtr) == TCL_OK) {
18371         if (moc != 2) {
18372           oc = 0;
18373           if (unlikely(moc > 2)) {
18374             NsfLog(interp, NSF_LOG_WARN, "max 2 words are currently allowed in methodName <%s>", methodString);
18375           }
18376         } else {
18377           oc = 1;
18378           methodObj = movPtr[0];
18379           ov0 = movPtr[1];
18380         }
18381       }
18382       if (paramPtr->nrArgs == 1) {
18383         oc++;
18384         if (oc == 1) {
18385           ov0 = newValue;
18386         } else {
18387           ovPtr = &newValue;
18388         }
18389       }
18390     }
18391 
18392     /*
18393      * Check whether we have an object parameter alias for the constructor.
18394      * Since we require the object system for the current object to determine
18395      * its object system configuration, we can't do this at parameter compile
18396      * time.
18397      */
18398     if (*initString == *methodString && strcmp(initString, methodString) == 0) {
18399       result = DispatchInitMethod(interp, object, oc, &ov0, 0u);
18400     } else {
18401 
18402       /*fprintf(stderr, "... call alias %s with methodObj %s.%s oc %d, nrArgs %d '%s'\n",
18403               paramPtr->name, ObjectName(object), ObjStr(methodObj), oc,
18404               paramPtr->nrArgs, ObjStr(newValue));*/
18405 #if !defined(NDEBUG)
18406       if (oc > 2) {
18407         assert(ovPtr != NULL);
18408         assert(ovPtr != &constantObj);
18409         assert(ISOBJ(ovPtr[oc-2]));
18410       }
18411 #endif
18412       Tcl_ResetResult(interp);
18413       result = NsfCallMethodWithArgs(interp, (Nsf_Object*)object, methodObj,
18414                                      ov0, oc, ovPtr,
18415                                      NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
18416     }
18417   } else {
18418     /*
18419      * must be NSF_ARG_FORWARD
18420      */
18421     assert((paramPtr->flags & NSF_ARG_FORWARD) != 0u);
18422 
18423     result = ParameterMethodForwardDispatch(interp, object,
18424                                             paramPtr, newValue, cscPtr);
18425   }
18426  method_arg_done:
18427   /*
18428    * Pop previously stacked frame for eval context and set the
18429    * varFramePtr to the previous value.
18430    */
18431   Nsf_PopFrameCsc(interp, framePtr2);
18432   CscListRemove(interp, cscPtr, NULL);
18433   CscFinish(interp, cscPtr, result, "converter object frame");
18434   Tcl_Interp_varFramePtr(interp) = varFramePtr;
18435 
18436   /* fprintf(stderr, "NsfOConfigureMethod_ attribute %s evaluated %s => (%d)\n",
18437      ObjStr(paramPtr->nameObj), ObjStr(newValue), result);*/
18438 
18439   if (likely(result == TCL_OK)) {
18440     if ((paramPtr->flags & NSF_ARG_CMD) != 0u
18441         && RUNTIME_STATE(interp)->doKeepcmds
18442         ) {
18443       Tcl_Obj *resultObj;
18444 
18445       resultObj = Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_ARRAY_CMD], paramPtr->nameObj, newValue, TCL_LEAVE_ERR_MSG);
18446       if (unlikely(resultObj == NULL)) {
18447         result = TCL_ERROR;
18448       }
18449     }
18450   }
18451 
18452   return result;
18453 }
18454 
18455 /*
18456  *----------------------------------------------------------------------
18457  * MakeProc --
18458  *
18459  *    Define a scripted function via the ObjCmd "proc".
18460  *
18461  * Results:
18462  *    Tcl result code
18463  *
18464  * Side effects:
18465  *    Defined function or exception.
18466  *
18467  *----------------------------------------------------------------------
18468  */
18469 static int MakeProc(Tcl_Namespace *nsPtr, NsfAssertionStore *aStore, Tcl_Interp *interp,
18470     Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition,
18471     Tcl_Obj *postcondition, NsfObject *defObject, NsfObject *regObject,
18472     int withPer_object, int withInner_namespace, unsigned int checkAlwaysFlag
18473 ) nonnull(1) nonnull(3) nonnull(4) nonnull(5) nonnull(6) nonnull(9);
18474 
18475 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)18476 MakeProc(
18477     Tcl_Namespace *nsPtr, NsfAssertionStore *aStore, Tcl_Interp *interp,
18478     Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition,
18479     Tcl_Obj *postcondition, NsfObject *defObject, NsfObject *regObject,
18480     int withPer_object, int withInner_namespace, unsigned int checkAlwaysFlag
18481 ) {
18482   const char     *methodName;
18483   NsfParsedParam  parsedParam;
18484   Tcl_Obj        *ov[4], *fullyQualifiedNameObj;
18485   int             result;
18486 
18487   nonnull_assert(nsPtr != NULL);
18488   nonnull_assert(interp != NULL);
18489   nonnull_assert(nameObj != NULL);
18490   nonnull_assert(args != NULL);
18491   nonnull_assert(body != NULL);
18492   nonnull_assert(defObject != NULL);
18493 
18494   methodName = ObjStr(nameObj);
18495 
18496   /*
18497    * Tcl (at least in newer versions) will raise an error in cases, where
18498    * the methodName starts with a colon.
18499    */
18500   if (regObject == NULL) {
18501     regObject = defObject;
18502   }
18503 
18504   /*
18505    * Check whether we are allowed to redefine the method.
18506    */
18507   result = CanRedefineCmd(interp, nsPtr, defObject, methodName, 0u);
18508   if (likely(result == TCL_OK)) {
18509     /*
18510      * Yes, we can! ...so obtain the method parameter definition.
18511      */
18512     Tcl_Namespace *nsPtr1 = Tcl_Command_nsPtr(defObject->id);
18513 
18514     result = ParamDefsParse(interp, nameObj, args,
18515                             NSF_DISALLOWED_ARG_METHOD_PARAMETER, NSF_FALSE,
18516                             &parsedParam,
18517                             nsPtr1 != NULL ? nsPtr1->fullName : NULL);
18518   }
18519 
18520   if (unlikely(result != TCL_OK)) {
18521     return result;
18522   }
18523 
18524   if (isAbsolutePath(methodName)) {
18525     fullyQualifiedNameObj = nameObj;
18526   } else {
18527     fullyQualifiedNameObj = NameInNamespaceObj(methodName, nsPtr);
18528     INCR_REF_COUNT2("fullyQualifiedName", fullyQualifiedNameObj);
18529   }
18530 
18531   ov[0] = NULL;
18532   ov[1] = fullyQualifiedNameObj;
18533 
18534   if (parsedParam.paramDefs != NULL) {
18535     Nsf_Param *pPtr;
18536     Tcl_Obj *argList = Tcl_NewListObj(0, NULL);
18537 
18538     for (pPtr = parsedParam.paramDefs->paramsPtr; pPtr->name != NULL; pPtr++) {
18539       if (*pPtr->name == '-') {
18540         Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name+1, -1));
18541       } else {
18542         Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(pPtr->name, -1));
18543       }
18544     }
18545     ov[2] = argList;
18546     INCR_REF_COUNT(ov[2]);
18547     /*fprintf(stderr, "final arglist = <%s>\n", ObjStr(argList)); */
18548     ov[3] = AddPrefixToBody(body, NSF_TRUE, &parsedParam);
18549   } else { /* no parameter handling needed */
18550     ov[2] = args;
18551     ov[3] = AddPrefixToBody(body, NSF_FALSE, &parsedParam);
18552   }
18553 
18554   /*
18555    * Check whether the cmd exists already in the namespace. If so, delete it
18556    * from there.
18557    */
18558   {
18559     Tcl_Command cmdPtr = FindMethod(nsPtr, methodName);
18560     if (cmdPtr != NULL) {
18561       Tcl_DeleteCommandFromToken(interp, cmdPtr);
18562     }
18563   }
18564 
18565   /*
18566    * Create the method in the provided namespace.
18567    */
18568 
18569   result = Tcl_ProcObjCmd(NULL, interp, 4, ov);
18570 
18571   if (likely(result == TCL_OK)) {
18572     /*
18573      * Retrieve the newly defined proc
18574      */
18575     Proc *procPtr = FindProcMethod(nsPtr, methodName);
18576 
18577     if (procPtr != NULL) {
18578       Namespace *execNsPtr;
18579 
18580       if (withInner_namespace == 1) {
18581         /*
18582          * Set the execution namespace to the registration object (e.g. same
18583          * as the class).
18584          */
18585         if (regObject->nsPtr == NULL) {
18586           MakeObjNamespace(interp, regObject);
18587         }
18588         /*fprintf(stderr, "obj %s\n", ObjectName(defObject));
18589         fprintf(stderr, "ns %p defObject->ns %p\n", nsPtr, defObject->nsPtr);
18590         fprintf(stderr, "ns %s defObject->ns %s\n", nsPtr->fullName, defObject->nsPtr->fullName);
18591         fprintf(stderr, "old %s\n", procPtr->cmdPtr->nsPtr->fullName);*/
18592         execNsPtr =  (Namespace *)regObject->nsPtr;
18593       } else {
18594         /*
18595          * Set the execution namespace of the method to the same namespace the
18596          * cmd of the defObject has.
18597          */
18598         execNsPtr = ((Command *)regObject->id)->nsPtr;
18599       }
18600 
18601       ParamDefsStore((Tcl_Command)procPtr->cmdPtr, parsedParam.paramDefs, checkAlwaysFlag,
18602                      (Tcl_Namespace *)execNsPtr);
18603       Tcl_SetObjResult(interp, MethodHandleObj(defObject, withPer_object, methodName));
18604       result = TCL_OK;
18605 
18606     } else {
18607       result = TCL_ERROR;
18608       NsfLog(interp, NSF_LOG_WARN,
18609              "cannot retrieve newly defined method %s from namespace %s",
18610              methodName, nsPtr->fullName);
18611       if (*methodName == ':') {
18612         NsfPrintError(interp, "can't create procedure \"%s\" in non-global namespace"
18613                       " with name starting with \":\"",
18614                       methodName);
18615       } else {
18616         NsfPrintError(interp, "can't create procedure \"%s\" in non-global namespace",
18617                       methodName);
18618       }
18619     }
18620   }
18621 
18622 #if defined(NSF_WITH_ASSERTIONS)
18623   if (result == TCL_OK && aStore != NULL /* (precondition || postcondition)*/) {
18624     AssertionAddProc(interp, methodName, aStore, precondition, postcondition);
18625   }
18626 #endif
18627 
18628   if (parsedParam.paramDefs != NULL) {
18629     DECR_REF_COUNT(ov[2]);
18630   }
18631   DECR_REF_COUNT2("resultBody", ov[3]);
18632   if (fullyQualifiedNameObj != nameObj) {
18633     DECR_REF_COUNT2("fullyQualifiedName", fullyQualifiedNameObj);
18634   }
18635 
18636 
18637   return result;
18638 }
18639 
18640 /*
18641  *----------------------------------------------------------------------
18642  * MakeMethod --
18643  *
18644  *    Define a scripted method to be defined on defObject and registered on
18645  *    regObject (if specified). This function handles as well assertions.
18646  *
18647  * Results:
18648  *    Tcl result code
18649  *
18650  * Side effects:
18651  *    Defined method or exception.
18652  *
18653  *----------------------------------------------------------------------
18654  */
18655 static int MakeMethod(Tcl_Interp *interp, NsfObject *defObject, NsfObject *regObject,
18656                       NsfClass *class, Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body,
18657                       Tcl_Obj *precondition, Tcl_Obj *postcondition,
18658                       int withInner_namespace, unsigned int checkAlwaysFlag)
18659   nonnull(1) nonnull(2) nonnull(5) nonnull(6) nonnull(7);
18660 
18661 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)18662 MakeMethod(Tcl_Interp *interp, NsfObject *defObject, NsfObject *regObject,
18663            NsfClass *class, Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body,
18664            Tcl_Obj *precondition, Tcl_Obj *postcondition,
18665            int withInner_namespace, unsigned int checkAlwaysFlag) {
18666   const char *argsStr, *bodyStr, *nameStr;
18667   int   result;
18668 
18669   nonnull_assert(interp != NULL);
18670   nonnull_assert(defObject != NULL);
18671   nonnull_assert(nameObj != NULL);
18672   nonnull_assert(args != NULL);
18673   nonnull_assert(body != NULL);
18674 
18675   nameStr = ObjStr(nameObj);
18676 
18677   if (*nameStr == '\0' || NsfHasTclSpace(nameStr)) {
18678     return NsfPrintError(interp, "invalid method name '%s'", nameStr);
18679   }
18680 
18681   if (precondition != NULL && postcondition == NULL) {
18682     return NsfPrintError(interp, "%s method '%s'; when specifying a precondition (%s)"
18683                          " a postcondition must be specified as well",
18684                          ClassName(class), nameStr, ObjStr(precondition));
18685   }
18686 
18687   argsStr = ObjStr(args);
18688   bodyStr = ObjStr(body);
18689   if (*argsStr == 0 && *bodyStr == 0) {
18690     /*
18691      * Both, args and body are empty strings. This means we should delete the
18692      * method.
18693      */
18694     if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
18695       /*
18696        * Don't delete methods via scripting during shutdown
18697        */
18698       result = (class != NULL) ?
18699         NsfRemoveClassMethod(interp, (Nsf_Class *)class, nameStr) :
18700         NsfRemoveObjectMethod(interp, (Nsf_Object *)defObject, nameStr);
18701     } else {
18702       /* fprintf(stderr, "don't delete method %s during shutdown\n", nameStr); */
18703       result = TCL_OK;
18704     }
18705 
18706   } else {
18707 #if defined(NSF_WITH_ASSERTIONS)
18708     NsfAssertionStore *aStore = NULL;
18709 
18710     if (precondition != NULL || postcondition != NULL) {
18711       if (class != NULL) {
18712         NsfClassOpt *opt = NsfRequireClassOpt(class);
18713 
18714         if (opt->assertions == NULL) {
18715           opt->assertions = AssertionCreateStore();
18716         }
18717         aStore = opt->assertions;
18718       } else {
18719         NsfObjectOpt *opt = NsfRequireObjectOpt(defObject);
18720 
18721         if (opt->assertions == NULL) {
18722           opt->assertions = AssertionCreateStore();
18723         }
18724         aStore = opt->assertions;
18725       }
18726     }
18727     result = MakeProc((class != NULL) ? class->nsPtr : defObject->nsPtr, aStore,
18728                       interp, nameObj, args, body, precondition, postcondition,
18729                       defObject, regObject, class == NULL, withInner_namespace,
18730                       checkAlwaysFlag);
18731 #else
18732     if (precondition != NULL) {
18733       NsfLog(interp, NSF_LOG_WARN, "Precondition %s provided, but not compiled with assertion enabled",
18734              ObjStr(precondition));
18735     } else if (postcondition != NULL) {
18736       NsfLog(interp, NSF_LOG_WARN, "Postcondition %s provided, but not compiled with assertion enabled",
18737              ObjStr(postcondition));
18738     }
18739     result = MakeProc((class != NULL) ? class->nsPtr : defObject->nsPtr, NULL,
18740                       interp, nameObj, args, body, NULL, NULL,
18741                       defObject, regObject, class == NULL, withInner_namespace,
18742                       checkAlwaysFlag);
18743 #endif
18744   }
18745 
18746   if (class != NULL) {
18747     NsfInstanceMethodEpochIncr("MakeMethod");
18748     /*
18749      * Could be a filter or filter inheritance ... update filter orders.
18750      */
18751     if (FilterIsActive(interp, nameStr)) {
18752       NsfClasses *subClasses = TransitiveSubClasses(class);
18753       if (subClasses != NULL) {
18754         FilterInvalidateObjOrders(interp, subClasses);
18755         NsfClassListFree(subClasses);
18756       }
18757     }
18758   } else {
18759     NsfObjectMethodEpochIncr("MakeMethod");
18760     /*
18761      * Could be a filter => recompute filter order.
18762      */
18763     FilterComputeDefined(interp, defObject);
18764   }
18765 
18766   return result;
18767 }
18768 
18769 /**************************************************************************
18770  * Begin Definition of nsf::proc (Tcl Procs with Parameter handling)
18771  **************************************************************************/
18772 /*
18773  *----------------------------------------------------------------------
18774  * NsfProcStubDeleteProc --
18775  *
18776  *    Tcl_CmdDeleteProc for NsfProcStubs. Is called, whenever a
18777  *    NsfProcStub is deleted and frees the associated client data.
18778  *
18779  * Results:
18780  *    None.
18781  *
18782  * Side effects:
18783  *    Frees client-data
18784  *
18785  *----------------------------------------------------------------------
18786  */
18787 static void
NsfProcStubDeleteProc(ClientData clientData)18788 NsfProcStubDeleteProc(ClientData clientData) {
18789   NsfProcClientData *tcd = clientData;
18790 
18791   /* fprintf(stderr, "NsfProcStubDeleteProc received %p\n", clientData);
18792   fprintf(stderr, "... procName %s paramDefs %p\n", ObjStr(tcd->procName), tcd->paramDefs);*/
18793 
18794   DECR_REF_COUNT2("procNameObj", tcd->procName);
18795   if (tcd->cmd != NULL) {
18796     Tcl_DeleteCommandFromToken(tcd->interp, tcd->cmd);
18797     NsfCommandRelease(tcd->cmd);
18798   }
18799   /* tcd->paramDefs is freed by NsfProcDeleteProc() */
18800   FREE(NsfProcClientData, tcd);
18801 }
18802 
18803 /*
18804  *----------------------------------------------------------------------
18805  * InvokeShadowedProc --
18806  *
18807  *    Call the proc specified in objc/objv; procNameObj should be used
18808  *    for error messages.
18809  *
18810  * Results:
18811  *    Tcl result code.
18812  *
18813  * Side effects:
18814  *    None.
18815  *
18816  *----------------------------------------------------------------------
18817  */
18818 static int InvokeShadowedProc(Tcl_Interp *interp, Tcl_Obj *procNameObj,
18819                               Tcl_Command cmd, ParseContext *pcPtr,
18820                               struct Tcl_Time *trtPtr, unsigned int cmdFlags,
18821                               Tcl_Namespace *execNsPtr)
18822   nonnull(1) nonnull(2) nonnull(4) nonnull(3) nonnull(4) nonnull(5);
18823 
18824 static int
InvokeShadowedProc(Tcl_Interp * interp,Tcl_Obj * procNameObj,Tcl_Command cmd,ParseContext * pcPtr,struct Tcl_Time * trtPtr,unsigned int cmdFlags,Tcl_Namespace * execNsPtr)18825 InvokeShadowedProc(Tcl_Interp *interp, Tcl_Obj *procNameObj,
18826                    Tcl_Command cmd, ParseContext *pcPtr,
18827                    struct Tcl_Time  *trtPtr, unsigned int cmdFlags,
18828                    Tcl_Namespace *execNsPtr) {
18829   Tcl_Obj       *const *objv;
18830   int            objc, result, includeTiming;
18831   const char    *fullMethodName;
18832   Tcl_CallFrame *framePtr;
18833   Proc          *procPtr;
18834   Tcl_Time      *ttPtr;
18835 
18836   nonnull_assert(interp != NULL);
18837   nonnull_assert(procNameObj != NULL);
18838   nonnull_assert(cmd != NULL);
18839   nonnull_assert(pcPtr != NULL);
18840   nonnull_assert(trtPtr != NULL);
18841 
18842   objv = pcPtr->full_objv;
18843   objc = pcPtr->objc+1;
18844 
18845   fullMethodName = ObjStr(procNameObj);
18846   CheckCStack(interp, "nsfProc", fullMethodName);
18847   /* fprintf(stderr, "=== InvokeShadowedProc %s objc %d\n", fullMethodName, objc); */
18848 
18849   /*
18850    * The code below is derived from the scripted method dispatch and just
18851    * slightly adapted to remove object dependencies.
18852    */
18853 
18854   procPtr = (Proc *)Tcl_Command_objClientData(cmd);
18855   result = TclPushStackFrame(interp, &framePtr,
18856                              execNsPtr /* procPtr->cmdPtr->nsPtr */,
18857                              (FRAME_IS_PROC));
18858 
18859   if (likely(result == TCL_OK)) {
18860     unsigned int dummy = 0;
18861     result = ByteCompiled(interp, &dummy, procPtr,  (Namespace *)execNsPtr,
18862                           fullMethodName);
18863   }
18864   if (unlikely(result != TCL_OK)) {
18865     /* todo: really? error msg? */
18866     return result;
18867   }
18868 
18869   includeTiming = ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u);
18870 
18871 #if defined(NSF_PROFILE)
18872   if (includeTiming == 0) {
18873     NsfRuntimeState *rst = RUNTIME_STATE(interp);
18874 
18875     /*fprintf(stderr, "InvokeShadowedProc %s cmdFlags %.6lx\n", fullMethodName, cmdFlags);*/
18876     includeTiming = rst->doProfile;
18877   }
18878 #endif
18879 
18880   Tcl_CallFrame_objc(framePtr) = objc;
18881   Tcl_CallFrame_objv(framePtr) = objv;
18882   Tcl_CallFrame_procPtr(framePtr) = procPtr;
18883 
18884   if (includeTiming) {
18885     ttPtr = (Tcl_Time *) ckalloc(sizeof(Tcl_Time));
18886     memcpy(ttPtr, trtPtr, sizeof(Tcl_Time));
18887   } else {
18888     ttPtr = NULL;
18889   }
18890 
18891 #if defined(NRE)
18892   /* fprintf(stderr, "CALL TclNRInterpProcCore proc '%s' %s nameObj %p %s\n",
18893      ObjStr(objv[0]), fullMethodName, procNameObj, ObjStr(procNameObj)); */
18894 
18895   Tcl_NRAddCallback(interp, ProcDispatchFinalize,
18896                     (ClientData)fullMethodName, pcPtr,
18897                     (ClientData)ttPtr,
18898                     (ClientData)UINT2PTR(cmdFlags)
18899                     );
18900   result = TclNRInterpProcCore(interp, procNameObj, 1, &MakeProcError);
18901 #else
18902   {
18903   ClientData data[4] = {
18904     (ClientData)fullMethodName,
18905     pcPtr,
18906     (ClientData)ttPtr,
18907     (ClientData)UINT2PTR(cmdFlags)
18908   };
18909   result = TclObjInterpProcCore(interp, procNameObj, 1, &MakeProcError);
18910   result = ProcDispatchFinalize(data, interp, result);
18911   }
18912 #endif
18913   return result;
18914 }
18915 
18916 /*
18917  *----------------------------------------------------------------------
18918  * NsfProcStub --
18919  *
18920  *    Tcl_ObjCmdProc implementing Proc Stubs. This function processes
18921  *    the argument list in accordance with the parameter definitions
18922  *    and calls in case of success the shadowed proc.
18923  *
18924  * Results:
18925  *    Tcl return code.
18926  *
18927  * Side effects:
18928  *    None.
18929  *
18930  *----------------------------------------------------------------------
18931  */
18932 
18933 int
NsfProcStub(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])18934 NsfProcStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
18935   NsfProcClientData *tcd;
18936   int result;
18937   ParseContext *pcPtr;
18938 
18939   nonnull_assert(clientData != NULL);
18940   nonnull_assert(interp != NULL);
18941   nonnull_assert(objv != NULL);
18942 
18943   tcd = clientData;
18944   assert(tcd->cmd != NULL);
18945 
18946   /*fprintf(stderr, "NsfProcStub %s is called, tcd %p, paramDefs %p\n", ObjStr(objv[0]), tcd, tcd ? tcd->paramDefs : NULL);*/
18947 
18948   if ((((unsigned int)Tcl_Command_flags(tcd->cmd) & CMD_IS_DELETED) == 0u) ||
18949       Tcl_Command_cmdEpoch(tcd->cmd) != 0) {
18950     /*
18951      * It seems as if the (cached) command was deleted (e.g., rename), or
18952      * someone messed around with the shadowed proc.
18953      *
18954      * We must refetch the command ...
18955      */
18956 
18957     Tcl_Command newCmdPtr = Tcl_GetCommandFromObj(interp, tcd->procName);
18958 
18959     if (unlikely(newCmdPtr == NULL)) {
18960       return NsfPrintError(interp, "cannot lookup command '%s'",
18961                              ObjStr(tcd->procName));
18962 
18963     } else if (unlikely(!CmdIsProc(newCmdPtr))) {
18964       return NsfPrintError(interp, "command '%s' is not a proc",
18965                              ObjStr(tcd->procName));
18966     }
18967 
18968     /*
18969      * ... and update the refCounts and cmd in ClientData
18970      */
18971     NsfCommandRelease(tcd->cmd);
18972     tcd->cmd = newCmdPtr;
18973     NsfCommandPreserve(tcd->cmd);
18974   }
18975 
18976   pcPtr = (ParseContext *) NsfTclStackAlloc(interp, sizeof(ParseContext),
18977                                             "parse context");
18978 
18979   if (likely(tcd->paramDefs != NULL && tcd->paramDefs->paramsPtr)) {
18980     /*
18981      * We have a parameter definition, parse the provided objv against the
18982      * parameter definition.
18983      */
18984     result = ProcessMethodArguments(pcPtr, interp, NULL,
18985                                     (((tcd->flags & NSF_PROC_FLAG_CHECK_ALWAYS) != 0u) ?
18986                                      NSF_ARGPARSE_CHECK : 0u)
18987                                     |NSF_ARGPARSE_FORCE_REQUIRED,
18988                                     tcd->paramDefs, objv[0],
18989                                     objc, objv);
18990   } else {
18991     /*
18992      * In case we have no parameter definition (e.g. no arguments, or no
18993      * arguments), just pass the objv along.
18994      */
18995     pcPtr->full_objv = (Tcl_Obj**)objv;
18996     pcPtr->objc = objc-1;
18997     pcPtr->status = 0;
18998     result = TCL_OK;
18999   }
19000 
19001   /*
19002    * Check whether the argument parsing was ok.
19003    */
19004   if (likely(result == TCL_OK)) {
19005     Tcl_Command     cmd = tcd->wrapperCmd;
19006     unsigned int    cmdFlags;
19007     struct Tcl_Time trt;
19008 
19009     assert(cmd != NULL);
19010 
19011     cmdFlags = (unsigned int)Tcl_Command_flags(cmd);
19012 
19013 #if defined(NSF_PROFILE)
19014     Tcl_GetTime(&trt);
19015 
19016     if (RUNTIME_STATE(interp)->doTrace) {
19017       NsfProfileTraceCallAppend(interp, ObjStr(objv[0]));
19018     }
19019     if ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u) {
19020       NsfProfileDebugCall(interp, NULL, NULL, ObjStr(objv[0]), objc-1, (Tcl_Obj **)objv+1);
19021     }
19022 #else
19023     if ((cmdFlags & NSF_CMD_DEBUG_METHOD) != 0u) {
19024       Tcl_GetTime(&trt);
19025 
19026       NsfProfileDebugCall(interp, NULL, NULL, ObjStr(objv[0]), objc-1, (Tcl_Obj **)objv+1);
19027     } else {
19028       trt.sec = 0;
19029       trt.usec = 0;
19030     }
19031 #endif
19032 
19033     if ((cmdFlags & NSF_CMD_DEPRECATED_METHOD) != 0u) {
19034       NsfDeprecatedCmd(interp, "proc", ObjStr(objv[0]), "");
19035     }
19036 
19037     result = InvokeShadowedProc(interp, tcd->procName, tcd->cmd, pcPtr, &trt,
19038                                 cmdFlags, Tcl_Command_nsPtr(cmd));
19039 
19040   } else {
19041     /*
19042      * Result is already set to TCL_ERROR, the error message should be already
19043      * provided.
19044      */
19045     ParseContextRelease(pcPtr);
19046     NsfTclStackFree(interp, pcPtr, "release parse context");
19047   }
19048 
19049   return result;
19050 }
19051 
19052 /*
19053  *----------------------------------------------------------------------
19054  * NsfProcAdd --
19055  *
19056  *    Add a command for implementing a Tcl proc with next scripting
19057  *    parameter handling.
19058  *
19059  *    For the time being, this function adds two things, (a) a Tcl cmd
19060  *    functioning as a stub for the argument processing (in accordance
19061  *    with the parameter definitions) and (b) the shadowed Tcl proc
19062  *    with a mutated name.
19063  *
19064  *    TODO: the current 1 cmd + 1 proc implementation is not robust
19065  *    against renaming and partial deletions (deletion of the
19066  *    stub).
19067  *
19068  * Results:
19069  *    Tcl return code.
19070  *
19071  * Side effects:
19072  *    Adding one Tcl command and one Tcl proc
19073  *
19074  *----------------------------------------------------------------------
19075  */
19076 static int NsfProcAdd(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr,
19077                       const char *procName, Tcl_Obj *body,
19078                       int with_ad, int with_checkAlways, int with_Debug, int with_Deprecated)
19079   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
19080 
19081 static int
NsfProcAdd(Tcl_Interp * interp,NsfParsedParam * parsedParamPtr,const char * procName,Tcl_Obj * body,int with_ad,int with_checkAlways,int with_Debug,int with_Deprecated)19082 NsfProcAdd(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr,
19083            const char *procName, Tcl_Obj *body,
19084            int with_ad, int with_checkAlways, int with_Debug, int with_Deprecated) {
19085   NsfParamDefs      *paramDefs;
19086   NsfProcClientData *tcd;
19087   Tcl_Namespace     *cmdNsPtr;
19088   Tcl_Obj           *argList, *procNameObj, *ov[4];
19089   Tcl_DString        ds, *dsPtr = &ds;
19090   int                result;
19091   unsigned int       checkAlwaysFlag;
19092   Tcl_Command        cmd;
19093 
19094   nonnull_assert(interp != NULL);
19095   nonnull_assert(parsedParamPtr != NULL);
19096   nonnull_assert(procName != NULL);
19097   nonnull_assert(body != NULL);
19098 
19099   Tcl_DStringInit(dsPtr);
19100 
19101   /*
19102    * Create a fully qualified procName
19103    */
19104   if (*procName != ':') {
19105     DStringAppendQualName(dsPtr, Tcl_GetCurrentNamespace(interp), procName);
19106     procName = Tcl_DStringValue(dsPtr);
19107   }
19108   /*
19109    * Create first the ProcStub to obtain later its namespace, which is
19110    * needed as the inner namespace of the shadowed proc.
19111    */
19112   tcd = NEW(NsfProcClientData);
19113   cmd = Tcl_CreateObjCommand(interp, procName, NsfProcStub,
19114                              tcd, NsfProcStubDeleteProc);
19115   if (unlikely(cmd == NULL)) {
19116     /*
19117      * For some reason, the command could not be created. Let us hope,
19118      * we have a useful error message.
19119      */
19120     Tcl_DStringFree(dsPtr);
19121     FREE(NsfProcClientData, tcd);
19122     return TCL_ERROR;
19123   }
19124 
19125   checkAlwaysFlag = (with_checkAlways != 0) ? NSF_ARGPARSE_CHECK : 0u;
19126   cmdNsPtr = Tcl_Command_nsPtr(cmd);
19127 
19128   /*
19129    * Storing param definitions is not needed for running the proc, since the
19130    * stub receives parameters + flag via client data... but it is needed for
19131    * introspection.
19132    *
19133    * TODO: For now, we provide no means to set the execNsPtr via interface.
19134    */
19135   paramDefs = parsedParamPtr->paramDefs;
19136   ParamDefsStore(cmd, paramDefs, checkAlwaysFlag, NULL);
19137 
19138   /*fprintf(stderr, "NsfProcAdd procName '%s' define cmd '%s' %p in namespace %s\n",
19139     procName, Tcl_GetCommandName(interp, cmd), cmd, cmdNsPtr->fullName);*/
19140 
19141   /*
19142    * Let us create the shadowed Tcl proc, which is stored under
19143    * ::nsf::procs::*. First build the fully qualified name procNameObj.
19144    */
19145   Tcl_DStringSetLength(dsPtr, 0);
19146   Tcl_DStringAppend(dsPtr, "::nsf::procs", -1);
19147   DStringAppendQualName(dsPtr, cmdNsPtr, Tcl_GetCommandName(interp, cmd));
19148   procNameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
19149                                  Tcl_DStringLength(dsPtr));
19150 
19151   INCR_REF_COUNT2("procNameObj", procNameObj); /* will be freed, when NsfProcStub is deleted */
19152 
19153   /*
19154    * Make sure to create the target namespace under "::nsf::procs::", if
19155    * it does not exist.
19156    */
19157   {
19158     Namespace  *nsPtr, *dummy1Ptr, *dummy2Ptr;
19159     const char *dummy;
19160 
19161     /*
19162      * Create the target namespace, if it does not exist.
19163      */
19164     TclGetNamespaceForQualName(interp, ObjStr(procNameObj), NULL, TCL_CREATE_NS_IF_UNKNOWN,
19165                                &nsPtr, &dummy1Ptr,
19166                                &dummy2Ptr, &dummy);
19167   }
19168 
19169   /*
19170    * Create the client data, which links the stub cmd with the proc.
19171    */
19172   tcd->procName = procNameObj;
19173   tcd->paramDefs = paramDefs;
19174   tcd->flags = (checkAlwaysFlag != 0u ? NSF_PROC_FLAG_CHECK_ALWAYS : 0u) | (with_ad != 0 ? NSF_PROC_FLAG_AD : 0u);
19175   tcd->cmd = NULL;
19176   tcd->wrapperCmd = cmd;  /* TODO should we preserve? */
19177   tcd->interp = interp; /* for deleting the shadowed proc */
19178 
19179   /*fprintf(stderr, "NsfProcAdd %s tcd %p paramdefs %p\n",
19180     ObjStr(procNameObj), tcd, tcd->paramDefs);*/
19181 
19182   /*
19183    * Build an argument list for the shadowed proc.
19184    */
19185   argList = Tcl_NewListObj(0, NULL);
19186   INCR_REF_COUNT(argList);
19187 
19188   if (paramDefs != NULL) {
19189     Nsf_Param *paramPtr;
19190 
19191     for (paramPtr = paramDefs->paramsPtr; paramPtr->name != NULL; paramPtr++) {
19192       if (*paramPtr->name == '-') {
19193         Tcl_Obj *varNameObj = Tcl_NewStringObj(paramPtr->name+1, -1);
19194 
19195         /*
19196          * If we have the -ad (for ars digita) flag set, we provide the
19197          * OpenACS semantics. This is (a) to use the name "boolean" for
19198          * a switch and (b) to name the automatic variable with the
19199          * prefix "_p".
19200          */
19201         if (with_ad && paramPtr->converter == Nsf_ConvertToBoolean && paramPtr->nrArgs == 1) {
19202           /*fprintf(stderr, "... ad handling: proc %s param %s type %s nrargs %d default %p\n",
19203             procName, paramPtr->name, paramPtr->type, paramPtr->nrArgs, paramPtr->defaultValue);*/
19204           paramPtr->nrArgs = 0;
19205           /*paramPtr->converter = Nsf_ConvertToSwitch;*/
19206           Tcl_AppendToObj(varNameObj, "_p", 2);
19207           if (paramPtr->defaultValue == NULL) {
19208             paramPtr->defaultValue = Tcl_NewBooleanObj(0);
19209             INCR_REF_COUNT(paramPtr->defaultValue);
19210           }
19211         }
19212         Tcl_ListObjAppendElement(interp, argList, varNameObj);
19213       } else {
19214         Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(paramPtr->name, -1));
19215       }
19216     }
19217   }
19218 
19219   ov[0] = NULL;
19220   ov[1] = procNameObj;
19221   ov[2] = argList;
19222   ov[3] = AddPrefixToBody(body, NSF_TRUE, parsedParamPtr);
19223 
19224   /*fprintf(stderr, "NsfProcAdd define proc %s arglist '%s'\n",
19225     ObjStr(ov[1]), ObjStr(ov[2])); */
19226 
19227   result = Tcl_ProcObjCmd(0, interp, 4, ov);
19228   DECR_REF_COUNT(argList);
19229   DECR_REF_COUNT2("resultBody", ov[3]);
19230 
19231   if (likely(result == TCL_OK)) {
19232     /*
19233      * The shadowed proc was created successfully. Retrieve the defined proc
19234      * and set its namespace to the namespace of the stub cmd.
19235      */
19236     Tcl_Command procCmd = Tcl_GetCommandFromObj(interp, procNameObj);
19237 
19238     assert(procCmd != NULL);
19239 
19240     tcd->cmd = procCmd;
19241     NsfCommandPreserve(tcd->cmd);
19242 
19243     if (with_Debug) {
19244       Tcl_Command_flags(cmd) |= NSF_CMD_DEBUG_METHOD;
19245     }
19246     if (with_Deprecated) {
19247       Tcl_Command_flags(cmd) |= NSF_CMD_DEPRECATED_METHOD;
19248     }
19249 
19250 
19251   } else {
19252     /*
19253      * We could not define the shadowed proc. In this case, cleanup by
19254      * removing the stub cmd.
19255      */
19256     Tcl_DeleteCommandFromToken(interp, cmd);
19257   }
19258 
19259   Tcl_DStringFree(dsPtr);
19260   return result;
19261 }
19262 
19263 /*
19264  *----------------------------------------------------------------------
19265  * ProcessMethodArguments --
19266  *
19267  *    Process the arguments provided to a method call. It parses the argument
19268  *    vector objv, disallows certain parameter types and updates the parse
19269  *    context.
19270  *
19271  * Results:
19272  *    Tcl return code.
19273  *
19274  * Side effects:
19275  *    Updates parameter context
19276  *
19277  *----------------------------------------------------------------------
19278  */
19279 static int
ProcessMethodArguments(ParseContext * pcPtr,Tcl_Interp * interp,NsfObject * object,unsigned int processFlags,NsfParamDefs * paramDefs,Tcl_Obj * methodNameObj,int objc,Tcl_Obj * const objv[])19280 ProcessMethodArguments(ParseContext *pcPtr, Tcl_Interp *interp,
19281                        NsfObject *object, unsigned int processFlags, NsfParamDefs *paramDefs,
19282                        Tcl_Obj *methodNameObj, int objc, Tcl_Obj *const objv[]) {
19283   int result;
19284   CallFrame frame, *framePtr = &frame;
19285 
19286   nonnull_assert(pcPtr != NULL);
19287   nonnull_assert(interp != NULL);
19288   nonnull_assert(paramDefs != NULL);
19289   nonnull_assert(methodNameObj != NULL);
19290   nonnull_assert(objv != NULL);
19291 
19292   if (object != NULL && (processFlags & NSF_ARGPARSE_METHOD_PUSH) != 0u ) {
19293     Nsf_PushFrameObj(interp, object, framePtr);
19294   }
19295 
19296 #if 0
19297   {int i;
19298     fprintf(stderr, "ProcessMethodArguments before ArgumentParse %s (flags %.6x objc %d): ", ObjStr(methodNameObj), processFlags, objc);
19299     for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
19300     fprintf(stderr, "\n");
19301 
19302     Tcl_Obj *listObj = ParamDefsList(interp, paramDefs->paramsPtr, NULL, NULL);
19303     fprintf(stderr, "... got params <%s>\n", ObjStr(listObj));
19304   }
19305 #endif
19306 
19307   result = ArgumentParse(interp, objc, objv, object, methodNameObj,
19308                          paramDefs->paramsPtr, paramDefs->nrParams, paramDefs->serial,
19309                          processFlags|RUNTIME_STATE(interp)->doCheckArguments,
19310                          pcPtr);
19311 #if 0
19312   {
19313     int i, fromArg, toArg;
19314     fprintf(stderr, "ProcessMethodArguments after ArgumentParse %s pcPtr->objc %d result %d\n",
19315             ObjStr(methodNameObj), pcPtr->objc, result);
19316     if (result == TCL_OK) {
19317       if ((processFlags & NSF_ARGPARSE_START_ZERO) != 0u) {
19318         fromArg = 0;
19319         toArg = pcPtr->objc;
19320       } else {
19321         fromArg = 1;
19322         toArg = pcPtr->objc;
19323       }
19324       for (i = fromArg; i < toArg; i++) {
19325         fprintf(stderr, "... pcPtr %p [%d] obj %p refCount %d (%s) flags %.6x & %p\n",
19326                 (void*)pcPtr, i,
19327                 pcPtr->objv[i] ? (void*)pcPtr->objv[i] : NULL,
19328                 pcPtr->objv[i] ? pcPtr->objv[i]->refCount : -1,
19329                 pcPtr->objv[i] ? ObjStr(pcPtr->objv[i]) : "(null)", pcPtr->flags[i],
19330                 (void*)&(pcPtr->flags[i]));
19331       }
19332     }
19333   }
19334 #endif
19335 
19336   if (object != NULL && ((processFlags & NSF_ARGPARSE_METHOD_PUSH) != 0u)) {
19337     Nsf_PopFrameObj(interp, framePtr);
19338   }
19339 
19340   /*
19341    * Set objc of the parse context to the number of defined parameters.
19342    * pcPtr->objc and paramDefs->nrParams will be equivalent in cases
19343    * where argument values are passed to the call in absence of var
19344    * args ('args'). Treating "args is more involved (see below).
19345    */
19346 
19347   if (unlikely(result != TCL_OK)) {
19348     return result;
19349   }
19350 
19351   if (pcPtr->varArgs) {
19352     /*
19353      * The last argument was "args".
19354      */
19355     int elts = objc - pcPtr->lastObjc;
19356 
19357     if (elts == 0) {
19358       /*
19359        * No arguments were passed to "args".  We simply decrement objc.
19360        */
19361       pcPtr->objc--;
19362     } else if (elts > 1) {
19363       /*
19364        * Multiple arguments were passed to "args". The array pcPtr->objv is
19365        * pointing to the first of the var args. We have to copy the remaining
19366        * actual argument vector objv to the parse context.
19367        */
19368 
19369       /*NsfPrintObjv("actual:  ", objc, objv);*/
19370       ParseContextExtendObjv(pcPtr, (unsigned)paramDefs->nrParams, (unsigned)elts-1u, objv + 1u + pcPtr->lastObjc);
19371     } else {
19372       /*
19373        * A single argument was passed to "args". There is no need to
19374        * mutate the pcPtr->objv, because this has been achieved in
19375        * ArgumentParse (i.e., pcPtr->objv[i] contains this element).
19376        */
19377     }
19378   }
19379 
19380   return TCL_OK;
19381 }
19382 /**************************************************************************
19383  * End Definition of nsf::proc  (Tcl Procs with Parameter handling)
19384  **************************************************************************/
19385 
19386 /*
19387  *----------------------------------------------------------------------
19388  * ForwardCmdDeleteProc --
19389  *
19390  *    This Tcl_CmdDeleteProc is called, when a forward method is deleted
19391  *
19392  * Results:
19393  *    None.
19394  *
19395  * Side effects:
19396  *    Frees client data of the setter command.
19397  *
19398  *----------------------------------------------------------------------
19399  */
19400 
19401 static void
ForwardCmdDeleteProc(ClientData clientData)19402 ForwardCmdDeleteProc(ClientData clientData) {
19403   ForwardCmdClientData *tcd;
19404 
19405   nonnull_assert(clientData != NULL);
19406 
19407   tcd = (ForwardCmdClientData *)clientData;
19408   if (tcd->cmdName != NULL)     {DECR_REF_COUNT(tcd->cmdName);}
19409   if (tcd->subcommands != NULL) {DECR_REF_COUNT(tcd->subcommands);}
19410 #if defined(NSF_FORWARD_WITH_ONERROR)
19411   if (tcd->onerror != NULL)     {DECR_REF_COUNT(tcd->onerror);}
19412 #endif
19413   if (tcd->prefix != NULL)      {DECR_REF_COUNT(tcd->prefix);}
19414   if (tcd->args != NULL)        {DECR_REF_COUNT(tcd->args);}
19415   FREE(ForwardCmdClientData, tcd);
19416 }
19417 
19418 
19419 /*
19420  *----------------------------------------------------------------------
19421  * SetterCmdDeleteProc --
19422  *
19423  *    This Tcl_CmdDeleteProc is called, when a setter method is deleted
19424  *
19425  * Results:
19426  *    None.
19427  *
19428  * Side effects:
19429  *    Frees client data of the setter command.
19430  *
19431  *----------------------------------------------------------------------
19432  */
19433 static void SetterCmdDeleteProc(ClientData clientData)
19434   nonnull(1);
19435 
19436 static void
SetterCmdDeleteProc(ClientData clientData)19437 SetterCmdDeleteProc(ClientData clientData) {
19438   SetterCmdClientData *setterClientData;
19439 
19440   nonnull_assert(clientData != NULL);
19441 
19442   setterClientData = (SetterCmdClientData *)clientData;
19443   if (setterClientData->paramsPtr != NULL) {
19444     ParamsFree(setterClientData->paramsPtr);
19445   }
19446   FREE(SetterCmdClientData, setterClientData);
19447 }
19448 
19449 
19450 /*
19451  *----------------------------------------------------------------------
19452  * AliasCmdDeleteProc --
19453  *
19454  *    This Tcl_CmdDeleteProc is called, when an alias method is deleted
19455  *
19456  * Results:
19457  *    None.
19458  *
19459  * Side effects:
19460  *    Frees client data of the setter command.
19461  *
19462  *----------------------------------------------------------------------
19463  */
19464 static void AliasCmdDeleteProc(ClientData clientData)
19465   nonnull(1);
19466 
19467 static void
AliasCmdDeleteProc(ClientData clientData)19468 AliasCmdDeleteProc(ClientData clientData) {
19469   AliasCmdClientData *tcd;
19470 
19471   nonnull_assert(clientData != NULL);
19472 
19473   /*
19474    * Since we just get the clientData, we have to obtain interp,
19475    * object, methodName and per-object from tcd; the obj might be
19476    * deleted already. We need as well at least still the global
19477    * namespace.
19478    */
19479   tcd = (AliasCmdClientData *)clientData;
19480   if ((tcd->interp != NULL)
19481       && (((Interp *)(tcd->interp))->globalNsPtr != NULL)
19482       && RUNTIME_STATE(tcd->interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_ON_PHYSICAL_DESTROY
19483      ) {
19484     const char *methodName = Tcl_GetCommandName(tcd->interp, tcd->aliasCmd);
19485 
19486     AliasDelete(tcd->interp, tcd->cmdName, methodName, tcd->class == NULL);
19487   }
19488 
19489   /*fprintf(stderr, "AliasCmdDeleteProc aliasedCmd %p\n", tcd->aliasedCmd);*/
19490   if (tcd->cmdName != NULL) {
19491     DECR_REF_COUNT(tcd->cmdName);
19492   }
19493   if (tcd->aliasedCmd != NULL) {
19494 
19495 #if defined(WITH_IMPORT_REFS)
19496     ImportRef *refPtr, *prevPtr = NULL;
19497     Command *aliasedCmd = (Command *)(tcd->aliasedCmd);
19498 
19499     /*fprintf(stderr, "AliasCmdDeleteProc aliasedCmd %p epoch %d refCount %d\n",
19500       aliasedCmd, Tcl_Command_cmdEpoch(tcd->aliasedCmd), aliasedCmd->refCount);*/
19501     /*
19502      * Clear the aliasCmd from the imported-ref chain of the aliased
19503      * (or real) cmd.  This widely resembles what happens in the
19504      * DeleteImportedCmd() (see tclNamesp.c), however, as we do not
19505      * provide for ImportedCmdData client data etc., we cannot
19506      * directly use it.
19507      */
19508     for (refPtr = aliasedCmd->importRefPtr; refPtr != NULL; refPtr = refPtr->nextPtr) {
19509       if (refPtr->importedCmdPtr == (Command *) tcd->aliasCmd) {
19510         if (prevPtr == NULL) {
19511           aliasedCmd->importRefPtr = refPtr->nextPtr;
19512         } else {
19513           prevPtr->nextPtr = refPtr->nextPtr;
19514         }
19515         ckfree((char *) refPtr);
19516         break;
19517       }
19518       prevPtr = refPtr;
19519     }
19520 #endif
19521     NsfCommandRelease(tcd->aliasedCmd);
19522   }
19523   FREE(AliasCmdClientData, tcd);
19524 }
19525 
19526 /*
19527  *----------------------------------------------------------------------
19528  * GetMatchObject --
19529  *
19530  *    Helper method used by nsfAPI.h and the info methods to check whether the
19531  *    Tcl_Obj patternObj was provided and can be looked up. If this is the
19532  *    case, wild card matching etc. does not have to be performed, but just
19533  *    the properties of the object have to be tested.
19534  *
19535  * Results:
19536  *    0 or 1 or -1, potentially the matchObject (when 0 is returned)
19537  *    0: we have wild-card characters, iterate to get matches
19538  *    1: we have an existing object
19539  *   -1: we no wild-card characters and a non-existing object
19540  *
19541  * Side effects:
19542  *    None.
19543  *
19544  *----------------------------------------------------------------------
19545  */
19546 
19547 static int
GetMatchObject(Tcl_Interp * interp,Tcl_Obj * patternObj,Tcl_Obj * origObj,NsfObject ** matchObjectPtr,const char ** patternPtr)19548 GetMatchObject(Tcl_Interp *interp, Tcl_Obj *patternObj, Tcl_Obj *origObj,
19549                 NsfObject **matchObjectPtr, const char **patternPtr) {
19550 
19551   nonnull_assert(interp != NULL);
19552   nonnull_assert(matchObjectPtr != NULL);
19553   nonnull_assert(patternPtr != NULL);
19554 
19555   if (patternObj != NULL) {
19556     *patternPtr = ObjStr(patternObj);
19557     if (TclObjIsNsfObject(interp, patternObj, matchObjectPtr)) {
19558       return 1;
19559     }
19560     if (patternObj == origObj && **patternPtr != ':') {
19561       return -1;
19562     }
19563   }
19564 
19565   return 0;
19566 }
19567 
19568 
19569 /*
19570  *----------------------------------------------------------------------
19571  * ForwardProcessOptions --
19572  *
19573  *    Process the options provided by the forward method and turn these into
19574  *    the ForwardCmdClientData structure.
19575  *
19576  * Results:
19577  *    Tcl result code.
19578  *
19579  * Side effects:
19580  *    Allocated and initialized ForwardCmdClientData
19581  *
19582  *----------------------------------------------------------------------
19583  */
19584 
19585 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,int objc,Tcl_Obj * const objv[],ForwardCmdClientData ** tcdPtr)19586 ForwardProcessOptions(Tcl_Interp *interp, Tcl_Obj *nameObj,
19587                       Tcl_Obj *withDefault,
19588                       int withEarlybinding,
19589                       Tcl_Obj *withOnerror,
19590                       Tcl_Obj *withMethodprefix,
19591                       int withFrame,
19592                       bool withVerbose,
19593                       Tcl_Obj *target, int objc, Tcl_Obj * const objv[],
19594                        ForwardCmdClientData **tcdPtr) {
19595   ForwardCmdClientData *tcd;
19596   int i, result = 0;
19597 
19598   nonnull_assert(interp != NULL);
19599   nonnull_assert(nameObj != NULL);
19600   nonnull_assert(objv != NULL);
19601 
19602   tcd = NEW(ForwardCmdClientData);
19603   memset(tcd, 0, sizeof(ForwardCmdClientData));
19604 
19605   if (withDefault != 0) {
19606     Tcl_DString ds, *dsPtr = &ds;
19607     DSTRING_INIT(dsPtr);
19608     Tcl_DStringAppend(dsPtr, "%1 {", 4);
19609     Tcl_DStringAppend(dsPtr, ObjStr(withDefault), -1);
19610     Tcl_DStringAppend(dsPtr, "}", 1);
19611     NsfDeprecatedCmd(interp, "forward option", "-default ...", Tcl_DStringValue(dsPtr));
19612     DSTRING_FREE(dsPtr);
19613 
19614     tcd->subcommands = withDefault;
19615     result = Tcl_ListObjLength(interp, withDefault, &tcd->nr_subcommands);
19616     INCR_REF_COUNT(tcd->subcommands);
19617   }
19618   if (withMethodprefix != 0) {
19619     tcd->prefix = withMethodprefix;
19620     INCR_REF_COUNT(tcd->prefix);
19621   }
19622 #if defined(NSF_FORWARD_WITH_ONERROR)
19623   if (withOnerror != 0) {
19624     tcd->onerror = withOnerror;
19625     INCR_REF_COUNT(tcd->onerror);
19626   }
19627 #endif
19628   tcd->frame = withFrame;
19629   tcd->verbose = withVerbose;
19630   tcd->needobjmap = NSF_FALSE;
19631   tcd->cmdName = target;
19632   /*fprintf(stderr, "...forwardprocess objc %d, cmdName %p %s\n", objc, target, ObjStr(target));*/
19633 
19634   for (i = 0; i < objc; i++) {
19635     const char *element = ObjStr(objv[i]);
19636     /*fprintf(stderr, "... [%d] forwardprocess element '%s'\n", i, element);*/
19637     tcd->needobjmap = (tcd->needobjmap || (*element == '%' && *(element+1) == '@'));
19638     tcd->hasNonposArgs = (tcd->hasNonposArgs || (*element == '%' && *(element+1) == '-'));
19639     if (tcd->args == NULL) {
19640       tcd->args = Tcl_NewListObj(1, &objv[i]);
19641       tcd->nr_args++;
19642       INCR_REF_COUNT(tcd->args);
19643     } else {
19644       Tcl_ListObjAppendElement(interp, tcd->args, objv[i]);
19645       tcd->nr_args++;
19646     }
19647   }
19648 
19649   if (tcd->cmdName == NULL) {
19650     tcd->cmdName = nameObj;
19651   }
19652 
19653   /*fprintf(stderr, "+++ cmdName = %s, args = %s, # = %d\n",
19654     ObjStr(tcd->cmdName), (tcd->args != NULL) ?ObjStr(tcd->args):"NULL", tcd->nr_args);*/
19655 
19656   if (tcd->frame == FrameObjectIdx) {
19657     /*
19658      * When we evaluating objscope, and define ...
19659      *     o forward append -frame object append
19660      *  a call to
19661      *     o append ...
19662      *  would lead to a recursive call; so we add the appropriate namespace.
19663      */
19664     const char *nameString = ObjStr(tcd->cmdName);
19665 
19666     if (!isAbsolutePath(nameString)) {
19667       tcd->cmdName = NameInNamespaceObj(nameString, CallingNameSpace(interp));
19668       /*fprintf(stderr, "+++ name %s not absolute, therefore qualifying %s\n", nameString,
19669         ObjStr(tcd->cmdName));*/
19670     }
19671   }
19672   INCR_REF_COUNT(tcd->cmdName);
19673 
19674   if (withEarlybinding != 0) {
19675     Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName);
19676     if (cmd == NULL) {
19677       result = NsfPrintError(interp, "cannot lookup command '%s'", ObjStr(tcd->cmdName));
19678       goto forward_process_options_exit;
19679     }
19680     if (CmdIsNsfObject(cmd)     /* don't do direct invoke on nsf objects */
19681         || Tcl_Command_objProc(cmd) == TclObjInterpProc  /* don't do direct invoke on Tcl procs */
19682         ) {
19683       /*
19684        * Silently ignore earlybinding flag
19685        */
19686       tcd->objProc = NULL;
19687     } else {
19688       tcd->objProc = Tcl_Command_objProc(cmd);
19689       tcd->clientData = Tcl_Command_objClientData(cmd);
19690     }
19691   }
19692 
19693   tcd->passthrough = (tcd->args == NULL && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc);
19694 
19695  forward_process_options_exit:
19696   /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/
19697   if (likely(result == TCL_OK)) {
19698     *tcdPtr = tcd;
19699   } else {
19700     ForwardCmdDeleteProc(tcd);
19701   }
19702   return result;
19703 }
19704 
19705 /*
19706  *----------------------------------------------------------------------
19707  * StripBodyPrefix --
19708  *
19709  *    Strip the prefix of the body, which might have been added by nsf.
19710  *
19711  * Results:
19712  *    The string of the body without the prefix.
19713  *
19714  * Side effects:
19715  *    None.
19716  *
19717  *----------------------------------------------------------------------
19718  */
19719 
19720 static const char * StripBodyPrefix(const char *body)
19721   nonnull(1) pure;
19722 
19723 static const char *
StripBodyPrefix(const char * body)19724 StripBodyPrefix(const char *body) {
19725 
19726   nonnull_assert(body != NULL);
19727 
19728   if (strncmp(body, "::nsf::__unset_unknown_args\n", 28) == 0) {
19729     body += 28;
19730   }
19731   return body;
19732 }
19733 
19734 
19735 /*
19736  *----------------------------------------------------------------------
19737  * AddSlotObjects --
19738  *
19739  *    Compute the slot objects (children of the slot container) for a provided
19740  *    object. The objects can be filtered via a pattern.
19741  *
19742  * Results:
19743  *    The function appends results to the provide listObj
19744  *
19745  * Side effects:
19746  *    Might add as well to the hash-table to avoid duplicates.
19747  *
19748  *----------------------------------------------------------------------
19749  */
19750 static void AddSlotObjects(Tcl_Interp *interp, NsfObject *parent, const char *prefix,
19751                            Tcl_HashTable *slotTablePtr, NsfClass *typeClass,
19752                            const char *pattern, Tcl_Obj *listObj)
19753   nonnull(1) nonnull(2) nonnull(3) nonnull(7);
19754 
19755 static void
AddSlotObjects(Tcl_Interp * interp,NsfObject * parent,const char * prefix,Tcl_HashTable * slotTablePtr,NsfClass * typeClass,const char * pattern,Tcl_Obj * listObj)19756 AddSlotObjects(Tcl_Interp *interp, NsfObject *parent, const char *prefix,
19757                Tcl_HashTable *slotTablePtr,
19758                NsfClass *typeClass, const char *pattern,
19759                Tcl_Obj *listObj) {
19760   NsfObject   *slotContainerObject;
19761   Tcl_DString  ds, *dsPtr = &ds;
19762   bool         isFullQualPattern = ((pattern != NULL) && *pattern == ':' && *(pattern+1) == ':');
19763 
19764   nonnull_assert(interp != NULL);
19765   nonnull_assert(parent != NULL);
19766   nonnull_assert(prefix != NULL);
19767   nonnull_assert(listObj != NULL);
19768 
19769   /*fprintf(stderr, "AddSlotObjects parent %s prefix %s type %p %s\n",
19770     ObjectName(parent), prefix, type, (type != NULL) ? ClassName(type) : "");*/
19771 
19772   DSTRING_INIT(dsPtr);
19773   Tcl_DStringAppend(dsPtr, ObjectName_(parent), -1);
19774   Tcl_DStringAppend(dsPtr, prefix, -1);
19775   slotContainerObject = GetObjectFromString(interp, Tcl_DStringValue(dsPtr));
19776 
19777   if (slotContainerObject != NULL && slotContainerObject->nsPtr
19778       && ((slotContainerObject->flags & NSF_IS_SLOT_CONTAINER) != 0u)) {
19779     Tcl_HashSearch       hSrch;
19780     const Tcl_HashEntry *hPtr;
19781     Tcl_HashTable       *cmdTablePtr = Tcl_Namespace_cmdTablePtr(slotContainerObject->nsPtr);
19782     Tcl_Command          cmd;
19783 
19784     hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
19785     for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
19786       const char *key = Tcl_GetHashKey(cmdTablePtr, hPtr);
19787       NsfObject *childObject;
19788 
19789       if (slotTablePtr != NULL) {
19790         int new;
19791         /*
19792          * Check whether we have and entry with this key already processed. We
19793          * never want to report shadowed entries.
19794          */
19795         Tcl_CreateHashEntry(slotTablePtr, key, &new);
19796         if (new == 0) {
19797           continue;
19798         }
19799       }
19800 
19801       /*
19802        * Obtain the childObject
19803        */
19804       cmd = (Tcl_Command) Tcl_GetHashValue(hPtr);
19805       childObject = NsfGetObjectFromCmdPtr(cmd);
19806 
19807       /*
19808        * Report just the already fully initialized slot objects, not the one
19809        * being right now created.
19810        */
19811       if (childObject == NULL || (childObject->flags & NSF_INIT_CALLED) == 0u) {
19812         /* fprintf(stderr, "....... key %s unfinished\n", key);*/
19813         continue;
19814       }
19815 
19816       /*
19817        * Check the pattern.
19818        */
19819       if (pattern != NULL) {
19820         int isMatch;
19821         /*
19822          * If the pattern looks like fully qualified, we match against the
19823          * fully qualified name.
19824          */
19825 
19826         if (isFullQualPattern) {
19827           isMatch = Tcl_StringMatch(ObjectName(childObject), pattern);
19828         } else {
19829           /*
19830            * do we have a mangled name of a private property/variable?
19831            */
19832           if (*key == '_' && *(key+1) == '_' && *(key+2) == '_' && *(key+3) == '_') {
19833             Tcl_Obj *value = Nsf_ObjGetVar2((Nsf_Object *)childObject, interp,
19834                                             NsfGlobalObjs[NSF_SETTERNAME], NULL, 0);
19835 
19836             isMatch = (value != NULL) ? Tcl_StringMatch(ObjStr(value), pattern) : 0;
19837 
19838             /*fprintf(stderr, "pattern <%s> isFullQualPattern %d child %s key %s %p <%s> match %d\n",
19839               pattern, isFullQualPattern, ObjectName(childObject), key,
19840               value, (value != NULL) ? ObjStr(value) : "", match);*/
19841           } else {
19842             isMatch = Tcl_StringMatch(key, pattern);
19843           }
19844         }
19845         if (isMatch == 0) {
19846           continue;
19847         }
19848       }
19849 
19850       /*
19851        * Check whether the entry is from the right type.
19852        */
19853       if (typeClass != NULL && !IsSubType(childObject->cl, typeClass)) {
19854         continue;
19855       }
19856 
19857       /*
19858        * Add finally the entry to the returned list.
19859        */
19860       Tcl_ListObjAppendElement(interp, listObj, childObject->cmdName);
19861     }
19862   }
19863   DSTRING_FREE(dsPtr);
19864 }
19865 
19866 /*
19867  *----------------------------------------------------------------------
19868  * FindCalledClass --
19869  *
19870  *    Find the called class of the called proc on the call-stack.
19871  *
19872  * Results:
19873  *    NsfClass * or NULL
19874  *
19875  * Side effects:
19876  *    None.
19877  *
19878  *----------------------------------------------------------------------
19879  */
19880 static NsfClass *FindCalledClass(Tcl_Interp *interp, NsfObject *object)
19881   nonnull(1) nonnull(2);
19882 
19883 static NsfClass *
FindCalledClass(Tcl_Interp * interp,NsfObject * object)19884 FindCalledClass(Tcl_Interp *interp, NsfObject *object) {
19885   NsfCallStackContent *cscPtr;
19886   NsfClass            *result;
19887 
19888   nonnull_assert(interp != NULL);
19889   nonnull_assert(object != NULL);
19890 
19891   cscPtr = CallStackGetTopFrame0(interp);
19892   if (unlikely(cscPtr == NULL)) {
19893     result = NULL;
19894 
19895   } else {
19896     if (cscPtr->frameType == NSF_CSC_TYPE_PLAIN) {
19897       result = cscPtr->cl;
19898     } else {
19899       const char *methodName;
19900 
19901       if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) {
19902         methodName = MethodName(cscPtr->filterStackEntry->calledProc);
19903       } else if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN && object->mixinStack != NULL) {
19904         methodName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
19905       } else {
19906         methodName = NULL;
19907       }
19908 
19909       if (unlikely(methodName == NULL)) {
19910         result = NULL;
19911 
19912       } else if (object->nsPtr != NULL && FindMethod(object->nsPtr, methodName) != NULL) {
19913         /*
19914          * An object specific method was called.
19915          */
19916         result = NULL;
19917       } else {
19918         Tcl_Command  cmd;
19919 
19920         result = SearchCMethod(object->cl, methodName, &cmd);
19921       }
19922     }
19923   }
19924   return result;
19925 }
19926 
19927 /*
19928  * Next Primitive Handling
19929  */
19930 /*
19931  *----------------------------------------------------------------------
19932  * NextSearchMethod --
19933  *
19934  *    Determine the method to be called via "next". The function returns on
19935  *    success the found cmd and information like method name, was it from a
19936  *    mixin, filter, or was the end of the filter chain reached.
19937  *
19938  * Results:
19939  *    Tcl result code
19940  *
19941  * Side effects:
19942  *    None.
19943  *
19944  *----------------------------------------------------------------------
19945  */
19946 NSF_INLINE static int NextSearchMethod(
19947     NsfObject *object, Tcl_Interp *interp, const NsfCallStackContent *cscPtr,
19948     NsfClass **classPtr, const char **methodNamePtr, Tcl_Command *cmdPtr,
19949     bool *isMixinEntry, bool *isFilterEntry,
19950     bool *endOfFilterChain, Tcl_Command *currentCmdPtr
19951 ) nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8) nonnull(9) nonnull(10);
19952 
19953 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)19954 NextSearchMethod(
19955     NsfObject *object, Tcl_Interp *interp, const NsfCallStackContent *cscPtr,
19956     NsfClass **classPtr, const char **methodNamePtr, Tcl_Command *cmdPtr,
19957     bool *isMixinEntry, bool *isFilterEntry,
19958     bool *endOfFilterChain, Tcl_Command *currentCmdPtr
19959 ) {
19960   bool         endOfChain = NSF_FALSE;
19961   unsigned int objflags;
19962 
19963   nonnull_assert(object != NULL);
19964   nonnull_assert(interp != NULL);
19965   nonnull_assert(cscPtr != NULL);
19966   nonnull_assert(classPtr != NULL);
19967   nonnull_assert(methodNamePtr != NULL);
19968   nonnull_assert(cmdPtr != NULL);
19969   nonnull_assert(isMixinEntry != NULL);
19970   nonnull_assert(isFilterEntry != NULL);
19971   nonnull_assert(endOfFilterChain != NULL);
19972   nonnull_assert(currentCmdPtr != NULL);
19973 
19974   /*fprintf(stderr, "NextSearchMethod for %s called with cl %p\n", *methodNamePtr, *classPtr);*/
19975 
19976   /*
19977    *  Next in filters
19978    */
19979 
19980   objflags = object->flags; /* avoid stalling */
19981   if ((objflags & NSF_MIXIN_ORDER_VALID) == 0u) {
19982     MixinComputeDefined(interp, object);
19983     objflags = object->flags; /* avoid stalling */
19984   }
19985 
19986   if ((objflags & NSF_FILTER_ORDER_VALID) != 0u
19987       && (object->filterStack != NULL)
19988       && object->filterStack->currentCmdPtr) {
19989     *cmdPtr = FilterSearchProc(interp, object, currentCmdPtr, classPtr);
19990 
19991     /*fprintf(stderr, "FilterSearchProc returned cmd %p\n", *cmdPtr);
19992       NsfShowStack(interp);*/
19993 
19994     if (*cmdPtr == NULL) {
19995       if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) {
19996         /*
19997          * Reset the information to the values of method, classPtr
19998          * to the values they had before calling the filters.
19999          */
20000         *methodNamePtr = MethodName(object->filterStack->calledProc);
20001         endOfChain = NSF_TRUE;
20002         *endOfFilterChain = NSF_TRUE;
20003         *classPtr = NULL;
20004         /*fprintf(stderr, "EndOfChain resetting cl\n");*/
20005       }
20006     } else {
20007       *methodNamePtr = (char *) Tcl_GetCommandName(interp, *cmdPtr);
20008       *endOfFilterChain = NSF_FALSE;
20009       *isFilterEntry = NSF_TRUE;
20010       return TCL_OK;
20011     }
20012   }
20013 
20014   /*
20015    *  Next in Mixins requires that we have already a mixinStack, and the
20016    *  current frame is not a plain frame.
20017    */
20018   assert((objflags & NSF_MIXIN_ORDER_VALID) != 0u);
20019 
20020   if ((object->mixinStack != NULL) && cscPtr->frameType) {
20021     int result = MixinSearchProc(interp, object, *methodNamePtr,
20022                                  classPtr, currentCmdPtr, cmdPtr);
20023 
20024     /* fprintf(stderr, "next in mixins %s frameType %.6x\n", *methodNamePtr, cscPtr->frameType); */
20025 
20026     if (unlikely(result != TCL_OK)) {
20027       return result;
20028     }
20029 
20030     if (*cmdPtr == NULL) {
20031       if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN) {
20032         endOfChain = NSF_TRUE;
20033         *classPtr = NULL;
20034       }
20035     } else {
20036       *isMixinEntry = NSF_TRUE;
20037       return TCL_OK;
20038     }
20039   }
20040 
20041   /*fprintf(stderr, "nextsearch: object %s nsPtr %p endOfChain %d\n",
20042     ObjectName(object), object->nsPtr, endOfChain);*/
20043 
20044   /*
20045    * Otherwise: normal method dispatch
20046    *
20047    * If we are already in the precedence ordering, then advance
20048    * past our last point; otherwise (if classPtr == NULL) begin from the start.
20049    *
20050    * When a mixin or filter chain reached its end, we have to check for
20051    * fully qualified method names and search the obj-specific methods as well.
20052    */
20053   if (endOfChain) {
20054     if (**methodNamePtr == ':') {
20055       *cmdPtr = Tcl_FindCommand(interp, *methodNamePtr, NULL, TCL_GLOBAL_ONLY);
20056       /* fprintf(stderr, "NEXT found absolute cmd %s => %p\n", *methodNamePtr, *cmdPtr); */
20057     } else if (object->nsPtr != NULL) {
20058       *cmdPtr = FindMethod(object->nsPtr, *methodNamePtr);
20059       if ((*cmdPtr != NULL)
20060           && ((unsigned int)Tcl_Command_flags(*cmdPtr) & NSF_CMD_CALL_PRIVATE_METHOD) != 0u
20061           ) {
20062         /*fprintf(stderr, "NEXT found private cmd %s => %p\n", *methodNamePtr, *cmdPtr);*/
20063         *cmdPtr = NULL;
20064       }
20065     } else {
20066       *cmdPtr = NULL;
20067     }
20068   } else {
20069     *cmdPtr = NULL;
20070   }
20071 
20072   /*fprintf(stderr, "NEXT methodName %s *classPtr %p %s *cmd %p cscPtr->flags %.6x\n",
20073    *methodNamePtr, *classPtr, ClassName((*classPtr)), *cmdPtr, cscPtr->flags); */
20074 
20075   if (*cmdPtr == NULL) {
20076     const NsfClasses *pl = PrecedenceOrder(object->cl);
20077     const NsfClass   *class = *classPtr;
20078 
20079     if (class != NULL) {
20080       /*
20081        * Skip until actual class
20082        */
20083       for ( ; pl != NULL; pl = pl->nextPtr) {
20084         if (pl->cl == class) {
20085           pl = pl->nextPtr;
20086           break;
20087         }
20088       }
20089     }
20090 
20091     if (pl != NULL) {
20092       /*
20093        * Search for a further class method. When we are called from an active
20094        * filter and the call had the "-local" flag set, then allow one to call
20095        * private methods.
20096        */
20097       *classPtr = SearchPLMethod(pl, *methodNamePtr, cmdPtr,
20098                                  ((cscPtr->flags & NSF_CM_LOCAL_METHOD) != 0u &&
20099                                   (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) != 0u)
20100                                  ? 0 : NSF_CMD_CALL_PRIVATE_METHOD);
20101     } else {
20102     *classPtr = NULL;
20103     }
20104 
20105   } else {
20106     *classPtr = NULL;
20107   }
20108 
20109   return TCL_OK;
20110 }
20111 
20112 /*
20113  *----------------------------------------------------------------------
20114  * NextGetArguments --
20115  *
20116  *    Obtain arguments for a method invoked via next either from the argument
20117  *    vector or from the stack (call stack content or Tcl stack). In case of
20118  *    ensemble calls the stack entries of the ensemble invocation are
20119  *    used. The function returns the arguments 4 to 8.
20120  *
20121  * Results:
20122  *    Tcl return code
20123  *
20124  * Side effects:
20125  *    none
20126  *
20127  *----------------------------------------------------------------------
20128  */
20129 static int NextGetArguments(
20130     Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
20131     NsfCallStackContent **cscPtrPtr, const char **methodNamePtr,
20132     int *outObjc, Tcl_Obj ***outObjv, bool *freeArgumentVector
20133 ) nonnull(1) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8);
20134 
20135 static int
NextGetArguments(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],NsfCallStackContent ** cscPtrPtr,const char ** methodNamePtr,int * outObjc,Tcl_Obj *** outObjv,bool * freeArgumentVector)20136 NextGetArguments(
20137     Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
20138     NsfCallStackContent **cscPtrPtr, const char **methodNamePtr,
20139     int *outObjc, Tcl_Obj ***outObjv, bool *freeArgumentVector
20140 ) {
20141   Tcl_Obj            **nobjv;
20142   int                  nobjc, oc;
20143   bool                 inEnsemble;
20144   Tcl_CallFrame       *framePtr;
20145   NsfCallStackContent *cscPtr;
20146 
20147   nonnull_assert(interp != NULL);
20148   nonnull_assert(cscPtrPtr != NULL);
20149   nonnull_assert(methodNamePtr != NULL);
20150   nonnull_assert(outObjc != NULL);
20151   nonnull_assert(outObjv != NULL);
20152   nonnull_assert(freeArgumentVector != NULL);
20153 
20154   /*
20155    * Initialize to zero to make sure, we only decrement when necessary.
20156    */
20157   *freeArgumentVector = NSF_FALSE;
20158 
20159   cscPtr = CallStackGetTopFrame(interp, &framePtr);
20160   if (cscPtr == NULL) {
20161     return NsfPrintError(interp, "next: can't find self");
20162   }
20163 
20164   if (cscPtr->cmdPtr == NULL) {
20165     return NsfPrintError(interp, "next: no executing proc");
20166   }
20167 
20168   oc = Tcl_CallFrame_objc(framePtr);
20169 
20170   if ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE)) {
20171     /*
20172      * We are in an ensemble method. The next works here not on the
20173      * actual methodName + frame, but on the ensemble above it. We
20174      * locate the appropriate call-stack content and continue next on
20175      * that.
20176      */
20177     cscPtr = CallStackFindEnsembleCsc(framePtr, &framePtr);
20178     assert(cscPtr != NULL);
20179     inEnsemble = NSF_TRUE;
20180     *methodNamePtr = MethodName(cscPtr->objv[0]);
20181   } else {
20182     inEnsemble = NSF_FALSE;
20183     *methodNamePtr = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
20184   }
20185 
20186   /*fprintf(stderr, "NextGetArguments oc %d objc %d inEnsemble %d objv %p\n",
20187     oc, objc, inEnsemble, cscPtr->objv); */
20188 
20189   if (objc > -1) {
20190     int methodNameLength;
20191     /*
20192      * Arguments were provided. We have to construct an argument
20193      * vector with the first argument(s) as the method name. In an
20194      * ensemble, we have to insert the objs of the full ensemble name.
20195      */
20196     if (inEnsemble) {
20197       methodNameLength = 1 + cscPtr->objc - oc;
20198       nobjc = objc + methodNameLength;
20199       nobjv = (Tcl_Obj **)ckalloc((unsigned)sizeof(Tcl_Obj *) * (unsigned)nobjc);
20200       MEM_COUNT_ALLOC("nextArgumentVector", nobjv);
20201       /*
20202        * Copy the ensemble path name
20203        */
20204       memcpy((char *)nobjv, cscPtr->objv, sizeof(Tcl_Obj *) * (size_t)methodNameLength);
20205 
20206      } else {
20207       methodNameLength = 1;
20208       nobjc = objc + methodNameLength;
20209       nobjv = (Tcl_Obj **)ckalloc((unsigned)sizeof(Tcl_Obj *) * (unsigned)nobjc);
20210       MEM_COUNT_ALLOC("nextArgumentVector", nobjv);
20211       /*
20212        * Copy the method name
20213        */
20214       if (cscPtr->objv != NULL) {
20215         nobjv[0] = cscPtr->objv[0];
20216       } else if (Tcl_CallFrame_objv(framePtr)) {
20217         nobjv[0] = Tcl_CallFrame_objv(framePtr)[0];
20218       }
20219     }
20220 
20221     if (objc > 0 && (objv != NULL || cscPtr->objv != NULL)) {
20222       /*
20223        * Copy the remaining argument vector
20224        */
20225       memcpy(nobjv + methodNameLength, objv == NULL ? cscPtr->objv : objv, sizeof(Tcl_Obj *) * (size_t)objc);
20226     }
20227 
20228     INCR_REF_COUNT(nobjv[0]); /* we seem to need this here */
20229     *freeArgumentVector = NSF_TRUE;
20230   } else {
20231     /*
20232      * No arguments were provided
20233      */
20234     if (cscPtr->objv != NULL) {
20235       nobjv = (Tcl_Obj **)cscPtr->objv;
20236       nobjc = cscPtr->objc;
20237     } else {
20238       nobjc = Tcl_CallFrame_objc(framePtr);
20239       nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(framePtr);
20240     }
20241   }
20242 
20243   *cscPtrPtr = cscPtr;
20244   *outObjc = nobjc;
20245   *outObjv = nobjv;
20246 
20247   return TCL_OK;
20248 }
20249 
20250 /*
20251  *----------------------------------------------------------------------
20252  * NextInvokeFinalize --
20253  *
20254  *    This finalize function is either called via NRE callback or
20255  *    directly (from NextSearchAndInvoke). It resets after a successful
20256  *    lookup and invocation the continuation context (filter flags etc)
20257  *    and cleans up optionally the argument vector (inverse operation
20258  *    of NextGetArguments).
20259  *
20260  * Results:
20261  *    Tcl return code
20262  *
20263  * Side effects:
20264  *    freeing memory
20265  *
20266  *----------------------------------------------------------------------
20267  */
20268 NSF_INLINE static int NextInvokeFinalize(ClientData data[], Tcl_Interp *interp, int result)
20269   nonnull(1) nonnull(2);
20270 
20271 NSF_INLINE static int
NextInvokeFinalize(ClientData data[],Tcl_Interp * interp,int result)20272 NextInvokeFinalize(ClientData data[], Tcl_Interp *interp, int result) {
20273   Tcl_Obj             **nobjv;
20274   NsfCallStackContent  *cscPtr;
20275 
20276   nonnull_assert(data != NULL);
20277   nonnull_assert(interp != NULL);
20278 
20279   nobjv = data[0];
20280   cscPtr = data[1];
20281 
20282   /*fprintf(stderr, "***** NextInvokeFinalize cscPtr %p flags %.6x is next %d result %d unk %d\n",
20283           cscPtr, cscPtr->flags, cscPtr->flags & NSF_CSC_CALL_IS_NEXT, result,
20284           RUNTIME_STATE(interp)->unknown);*/
20285 
20286   if ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u) {
20287     /* fprintf(stderr, "..... it was a successful next\n"); */
20288     cscPtr->flags &= ~NSF_CSC_CALL_IS_NEXT;
20289 
20290     if (cscPtr->frameType == NSF_CSC_TYPE_INACTIVE_FILTER) {
20291       cscPtr->frameType = NSF_CSC_TYPE_ACTIVE_FILTER;
20292     } else if (cscPtr->frameType == NSF_CSC_TYPE_INACTIVE_MIXIN) {
20293       cscPtr->frameType = NSF_CSC_TYPE_ACTIVE_MIXIN;
20294     }
20295   }
20296 
20297   if (nobjv != NULL) {
20298     DECR_REF_COUNT(nobjv[0]);
20299     MEM_COUNT_FREE("nextArgumentVector", nobjv);
20300     ckfree((char *)nobjv);
20301   }
20302 
20303   if (result == TCL_ERROR && RUNTIME_STATE(interp)->unknown) {
20304     /* fprintf(stderr, "don't report unknown error\n"); */
20305     /*
20306      * Don't report "unknown" errors via next.
20307      */
20308     result = TCL_OK;
20309   }
20310 
20311   return result;
20312 }
20313 
20314 /*
20315  *----------------------------------------------------------------------
20316  * NextSearchAndInvoke --
20317  *
20318  *    The function is called with a final argument vector and searches for a
20319  *    possibly shadowed method. If a target method is found, this dispatcher
20320  *    function updates the continuation context (filter flags etc.), invokes
20321  *    upon the target method, and performs a cleanup.
20322  *
20323  * Results:
20324  *    Tcl return code
20325  *
20326  * Side effects:
20327  *    The invoked method might produce side effects. Also, the interp's unknown
20328  *    state may be modified.
20329  *
20330  *----------------------------------------------------------------------
20331  */
20332 static int
NextSearchAndInvoke(Tcl_Interp * interp,const char * methodName,int objc,Tcl_Obj * const objv[],NsfCallStackContent * cscPtr,bool freeArgumentVector)20333 NextSearchAndInvoke(
20334     Tcl_Interp *interp, const char *methodName,
20335     int objc, Tcl_Obj *const objv[],
20336     NsfCallStackContent *cscPtr,
20337     bool freeArgumentVector
20338 ) {
20339   Tcl_Command      cmd = NULL, currentCmd = NULL;
20340   int              result;
20341   bool             endOfFilterChain = NSF_FALSE,
20342                    isMixinEntry = NSF_FALSE,
20343                    isFilterEntry = NSF_FALSE;
20344   NsfRuntimeState *rst;
20345   NsfObject       *object;
20346   NsfClass        *class;
20347 
20348   nonnull_assert(interp != NULL);
20349   nonnull_assert(methodName != NULL);
20350   nonnull_assert(cscPtr != NULL);
20351 
20352   rst = RUNTIME_STATE(interp);
20353   /*
20354    * Search the next method & compute its method data
20355    */
20356   class = cscPtr->cl;
20357   object = cscPtr->self;
20358   result = NextSearchMethod(object, interp, cscPtr, &class, &methodName, &cmd,
20359                             &isMixinEntry, &isFilterEntry, &endOfFilterChain, &currentCmd);
20360 
20361   /*fprintf(stderr, "NEXT search on %s.%s cl %p cmd %p endOfFilterChain %d result %d IS OK %d\n",
20362           ObjectName(object), methodName, (void*)class, (void*)cmd, endOfFilterChain,
20363           result, (result == TCL_OK));*/
20364 
20365   if (unlikely(result != TCL_OK)) {
20366     goto next_search_and_invoke_cleanup;
20367   }
20368 
20369 #if 0
20370   Tcl_ResetResult(interp); /* needed for bytecode support */
20371 #endif
20372   if (cmd != NULL) {
20373     unsigned short frameType = NSF_CSC_TYPE_PLAIN;
20374 
20375     /*
20376      * Change mixin state.
20377      */
20378     if (object->mixinStack != NULL) {
20379       if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN) {
20380         cscPtr->frameType = NSF_CSC_TYPE_INACTIVE_MIXIN;
20381       }
20382       /*
20383        * Otherwise move the command pointer forward.
20384        */
20385       if (isMixinEntry) {
20386         frameType = NSF_CSC_TYPE_ACTIVE_MIXIN;
20387         object->mixinStack->currentCmdPtr = currentCmd;
20388       }
20389     }
20390 
20391     /*
20392      * Change filter state
20393      */
20394     if (object->filterStack != NULL) {
20395       if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) {
20396         /*fprintf(stderr, "next changes filter state\n");*/
20397         cscPtr->frameType = NSF_CSC_TYPE_INACTIVE_FILTER;
20398       }
20399 
20400       /*
20401        * Otherwise move the command pointer forward.
20402        */
20403       if (isFilterEntry) {
20404         /*fprintf(stderr, "next moves filter forward\n");*/
20405         frameType = NSF_CSC_TYPE_ACTIVE_FILTER;
20406         object->filterStack->currentCmdPtr = currentCmd;
20407       }
20408     }
20409 
20410     /*
20411      * Now actually call the "next" method.
20412      */
20413     cscPtr->flags |= NSF_CSC_CALL_IS_NEXT;
20414     rst->unknown = 0;
20415 #if defined(NRE)
20416     { unsigned int flags;
20417       /*
20418        * Allow call only without immediate flag, when caller has NRE without
20419        * immediate.
20420        */
20421       flags = NsfImmediateFromCallerFlags(cscPtr->flags);
20422 
20423       /*fprintf(stderr, "MethodDispatch in next flags %.6x NRE %d immediate %d next-flags %.6x\n",
20424         cscPtr->flags,
20425         (cscPtr->flags & NSF_CSC_CALL_IS_NRE) != 0,
20426         (cscPtr->flags & NSF_CSC_IMMEDIATE) != 0,
20427         flags);*/
20428 
20429       if (flags == 0) {
20430         /*
20431          * The call is NRE-enabled. We register the callback and return
20432          * here immediately.  All other forms of this function have
20433          * to call NextInvokeFinalize() manually on return.
20434          */
20435         Tcl_NRAddCallback(interp, NextInvokeFinalize,
20436                           freeArgumentVector ? (ClientData)objv : NULL,
20437                           cscPtr, NULL, NULL);
20438         return MethodDispatch(interp, objc, objv, cmd,
20439                               object, class, methodName, frameType, flags);
20440       } else {
20441         result = MethodDispatch(interp, objc, objv, cmd,
20442                                 object, class, methodName, frameType, flags);
20443       }
20444     }
20445 #else
20446     /*fprintf(stderr, "NextSearchAndWinvoke calls cmd %p methodName %s cscPtr->flags %.8x\n",
20447       cmd, methodName, cscPtr->flags);*/
20448     result = MethodDispatch(interp, objc, objv, cmd,
20449                             object, class, methodName, frameType, cscPtr->flags);
20450 #endif
20451   } else if (likely(result == TCL_OK)) {
20452     NsfCallStackContent *topCscPtr;
20453     Tcl_CallFrame       *varFramePtr = NULL;
20454     int                  isLeafNext;
20455 
20456     /*
20457      * We could not find a cmd, yet the dispatch attempt did not result
20458      * in an error. This means that we find ourselves in either of three
20459      * situations at this point:
20460      *
20461      * 1) An explicit "next" cmd (NsfNextCmd()) at the end of a filter chain:
20462      * Dispatch to unknown as there is no implementation for the requested
20463      * call available.
20464      *
20465      * 2) An explicit "next" cmd from within a leaf sub-method (a "leaf
20466      * next"): Remain silent, do not dispatch to unknown.
20467 
20468      * 3) An implicit "next" triggered for unresolved sub-methods that might be
20469      * resolved along the next path: Dispatch to unknown, the requested
20470      * sub-cmd is not resolvable to a cmd.
20471      *
20472      * For the cases 1) and 3), set the interp's unknown flag signaling to
20473      * higher levels (e.g., in MethodDispatchCsc(), in NsfNextCmd()) the need
20474      * for dispatching to unknown.
20475      */
20476 
20477     /* NsfShowStack(interp);*/
20478 
20479     topCscPtr = CallStackGetTopFrame(interp, &varFramePtr);
20480     assert(topCscPtr != NULL);
20481     assert(varFramePtr != NULL);
20482 
20483     /*
20484      * Find the appropriate frame pointing to the start of the ensemble, in
20485      * case we are in the middle of an ensemble.
20486      */
20487     /*fprintf(stderr, "######## cscPtr %p topCscPtr %p\n", cscPtr, topCscPtr);*/
20488     if ( cscPtr != topCscPtr
20489          && (cscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) != 0u
20490          && (topCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) != 0u) {
20491 
20492       for (; varFramePtr != NULL; varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr)) {
20493         topCscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr);
20494         assert(topCscPtr != NULL);
20495         /*fprintf(stderr, "######## cscPtr %p topCscPtr %p topCscPtr->flags %8x\n",
20496           cscPtr, topCscPtr, (topCscPtr != NULL) ? topCscPtr->flags : 0);*/
20497         if ((topCscPtr->flags & NSF_CM_ENSEMBLE_UNKNOWN) != 0u) {
20498           break;
20499         }
20500       }
20501 
20502       if (varFramePtr != NULL) {
20503         varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr);
20504         if (((unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) {
20505           topCscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr);
20506           assert(topCscPtr != NULL);
20507         }
20508       }
20509     }
20510 
20511     /* case 2 */
20512     isLeafNext = (cscPtr != topCscPtr)
20513       && (topCscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u
20514       && (topCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0u;
20515 
20516     /*fprintf(stderr, "******** isleavenext %d based on %d && %d && %d <%s>\n",
20517             isLeafNext,
20518             (cscPtr != topCscPtr),
20519             (topCscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u,
20520             (topCscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0u);*/
20521 
20522     /*
20523      * If we are in an ENSEMBLE_UNKNOWN we have to identify a special variant
20524      * of case 2: When "next" is called from an ensemble method (e.g. from a
20525      * method "i s") the call of "next" has to start over from "i" to search
20526      * for the next method (the next "i s") of the shadowed methods. If there
20527      * is none, we reach the ENSEMBLE_UNKNOWN state. But we reach the state
20528      * not immediately after the "next" call, the other checks for handling
20529      * this case fails, and we would run into the unknown handler, although
20530      * being called from "next".
20531      *
20532      * Therefore, we check in the call-stack whether we are were called inside
20533      * an ensemble setup on a path leading to an invocation of "next".
20534      *
20535      * Such a situation is e.g. (simplified stack view, then with flag names)
20536      *
20537      *        varFrame  flags lvl csc          frameType flags
20538      *  0x7ffeeb7b1698 040001  5  0x7ffeeb7b1870    0000 8000104 (::b.0x7fa756821490 i)
20539      *  0x7fa75480eda0 020001  4  0x7fa75480ed40    0020 002100 (::b.0x7fa756821e10 s)
20540      *  0x7ffeeb7b2028 040001  3  0x7ffeeb7b2370    0000 000005 (::b.0x7fa756821c10 i)
20541      *
20542      * topcsc 0x7ffeeb7b1870
20543      * 0x7ffeeb7b1698   flags NSF_CSC_CALL_IS_ENSEMBLE|NSF_CSC_IMMEDIATE|NSF_CM_ENSEMBLE_UNKNOWN
20544      * 0x7fa75480eda0   flags NSF_CSC_IMMEDIATE|NSF_CSC_CALL_IS_NRE frametype NSF_CSC_TYPE_ENSEMBLE
20545      * 0x7ffeeb7b2028   flags NSF_CSC_CALL_IS_NEXT|NSF_CSC_CALL_IS_ENSEMBLE
20546      *
20547      */
20548     if (!isLeafNext && (topCscPtr->flags & NSF_CM_ENSEMBLE_UNKNOWN) != 0u) {
20549 
20550       for (;;) {
20551         varFramePtr = Tcl_CallFrame_callerPtr(varFramePtr);
20552         if (((unsigned int)Tcl_CallFrame_isProcCallFrame(varFramePtr) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) == 0) {
20553           /*
20554            * Parent frame is not an NSF frame.
20555            */
20556           /*fprintf(stderr, "******** parent frame ptr is not an NSF frame %p\n", (void*)varFramePtr);*/
20557           break;
20558         }
20559         topCscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(varFramePtr);
20560         if ((topCscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) == 0u) {
20561           /*
20562            * Call stack content not of type ensemble.
20563            */
20564           /*fprintf(stderr, "******** topCscPtr not type ensemble %p\n", (void*)topCscPtr);*/
20565           break;
20566         }
20567       }
20568 
20569       isLeafNext = (
20570           (topCscPtr->flags & (NSF_CSC_CALL_IS_NEXT|NSF_CSC_CALL_IS_ENSEMBLE)) == (NSF_CSC_CALL_IS_NEXT|NSF_CSC_CALL_IS_ENSEMBLE) &&
20571           (topCscPtr->flags & NSF_CM_ENSEMBLE_UNKNOWN) == 0u
20572       );
20573       /*fprintf(stderr, "******** alternate isleavenext %d based on topcscptr %p flags %.6x\n",
20574         isLeafNext,
20575         (void*)topCscPtr,
20576         (topCscPtr != NULL ? topCscPtr->flags : 0));*/
20577     }
20578 
20579     rst->unknown =
20580       /* case 1 */ endOfFilterChain ||
20581       /* case 3 */ (!isLeafNext && ((cscPtr->flags & NSF_CSC_CALL_IS_ENSEMBLE) != 0u));
20582 
20583     /*NsfShowStack(interp);*/
20584 
20585     /*fprintf(stderr, "******** setting unknown to %d isLeafNext %d topCscPtr %p endOfFilterChain %d\n",
20586       rst->unknown, isLeafNext, (void *)topCscPtr, endOfFilterChain);*/
20587   }
20588 
20589  next_search_and_invoke_cleanup:
20590   /*
20591    * We come here, whenever the NRE callback is NOT registered
20592    */
20593   {ClientData data[2] = {
20594       freeArgumentVector ? (ClientData)objv : NULL,
20595       cscPtr
20596     };
20597 
20598     return NextInvokeFinalize(data, interp, result);
20599   }
20600 }
20601 
20602 /*
20603  *----------------------------------------------------------------------
20604  * NsfNextObjCmd --
20605  *
20606  *    nsf::xotclnext is for backwards compatibility to the next
20607  *    implementation in XOTcl.  It receives an argument vector which
20608  *    is used for the invocation. If no argument vector is provided,
20609  *    the argument vector of the last invocation is used. If the
20610  *    argument vector starts with "--noArgs", then no arguments are
20611  *    passed to the shadowed method.
20612  *
20613  *    TODO: On the longer range, this function should go into an external
20614  *    library (e.g. XOTcl compatibility library)
20615  *
20616  * Results:
20617  *    Tcl return code
20618  *
20619  * Side effects:
20620  *    The invoked method might produce side effects
20621  *
20622  *----------------------------------------------------------------------
20623  */
20624 static int
20625 NsfNextObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
20626   nonnull(2) nonnull(4);
20627 
20628 static int
NsfNextObjCmd(ClientData UNUSED (clientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])20629 NsfNextObjCmd(ClientData UNUSED(clientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
20630   int                  result, nobjc = 0;
20631   bool                 freeArgumentVector;
20632   const char          *methodName = NULL;
20633   NsfCallStackContent *cscPtr;
20634   Tcl_Obj            **nobjv;
20635 
20636   nonnull_assert(interp != NULL);
20637   nonnull_assert(objv != NULL);
20638 
20639   if (likely(objc < 2)) {
20640     /*
20641      * No arguments were provided.
20642      */
20643     objc = 0;
20644   } else {
20645     /*
20646      * In case "--noArgs" is used, remove the flag and provide an empty
20647      * argument list.
20648      */
20649     const char *arg1String = ObjStr(objv[1]);
20650 
20651     if (*arg1String == '-' && !strcmp(arg1String, "--noArgs")) {
20652       objc = 1;
20653     }
20654   }
20655 
20656   result = NextGetArguments(interp, objc-1, &objv[1], &cscPtr, &methodName,
20657                             &nobjc, &nobjv, &freeArgumentVector);
20658   if (likely(result == TCL_OK)) {
20659     assert(nobjc > 0);
20660     result = NextSearchAndInvoke(interp, methodName, nobjc, nobjv, cscPtr, freeArgumentVector);
20661   }
20662   return result;
20663 }
20664 
20665 /*
20666  *----------------------------------------------------------------------
20667  * FindNextMethod --
20668  *
20669  *    This function is called via [current nextmethod] to resolve the method
20670  *    to be invoked by [next]. If there is a next method found on the
20671  *    precedence path, a method handle (Tcl_Obj) will be returned. The caller is
20672  *    responsible for managing the resulting Tcl_Obj, if any.
20673  *
20674  * Results:
20675  *    Tcl_Obj; NULL otherwise (no next method or called from outside of NSF)
20676  *
20677  * Side effects:
20678  *    None.
20679  *
20680  *----------------------------------------------------------------------
20681  */
20682 
20683 static Tcl_Obj *FindNextMethod(Tcl_Interp *interp, Tcl_CallFrame *framePtr)
20684   nonnull(1) nonnull(2);
20685 
FindNextMethod(Tcl_Interp * interp,Tcl_CallFrame * framePtr)20686 static Tcl_Obj *FindNextMethod(Tcl_Interp *interp, Tcl_CallFrame *framePtr) {
20687   Tcl_Obj             *result;
20688   NsfCallStackContent *cscPtr;
20689 
20690   nonnull_assert(interp != NULL);
20691   nonnull_assert(framePtr != NULL);
20692 
20693   cscPtr = Tcl_CallFrame_clientData(framePtr);
20694   if (unlikely(cscPtr == NULL)) {
20695     result = NULL;
20696 
20697   } else {
20698     bool         isEnsemble,
20699                  isMixinEntry = NSF_FALSE,
20700                  isFilterEntry = NSF_FALSE,
20701                  endOfFilterChain = NSF_FALSE;
20702     Tcl_Command  cmd = NULL, currentCmd = NULL;
20703     const char  *lookupMethodName, *methodName;
20704     NsfClass    *class;
20705     NsfObject   *object;
20706 
20707     isEnsemble = ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u);
20708 
20709     methodName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
20710     if (isEnsemble) {
20711       NsfCallStackContent *cscPtr1 = CallStackFindEnsembleCsc(framePtr, &framePtr);
20712 
20713       lookupMethodName = MethodName(cscPtr1->objv[0]);
20714     } else {
20715       lookupMethodName = methodName;
20716     }
20717 
20718     class = cscPtr->cl;
20719     object = cscPtr->self;
20720 
20721     if (NextSearchMethod(object, interp, cscPtr,
20722                          &class, &lookupMethodName, &cmd, &isMixinEntry, &isFilterEntry,
20723                          &endOfFilterChain, &currentCmd) == TCL_OK
20724         && cmd != NULL) {
20725       Tcl_Obj *pathObj = NsfMethodNamePath(interp, framePtr, methodName);
20726       INCR_REF_COUNT(pathObj);
20727 
20728       methodName = isEnsemble ? ObjStr(pathObj) : lookupMethodName;
20729       result = MethodHandleObj((class != NULL) ? (NsfObject *)class : object, (class == NULL), methodName);
20730       DECR_REF_COUNT(pathObj);
20731     } else {
20732       result = NULL;
20733     }
20734   }
20735   return result;
20736 }
20737 
20738 
20739 /*
20740  *----------------------------------------------------------------------
20741  * ComputeLevelObj --
20742  *
20743  *    This function computes a fresh Tcl_Obj referring to the interp level. The
20744  *    caller has to care about freeing the returned Tcl_Obj.
20745  *
20746  * Results:
20747  *    Tcl_Obj *
20748  *
20749  * Side effects:
20750  *    Allocates a new Tcl_Obj
20751  *
20752  *----------------------------------------------------------------------
20753  */
20754 
20755 static Tcl_Obj * ComputeLevelObj(Tcl_Interp *interp, CallStackLevel level)
20756   nonnull(1) returns_nonnull;
20757 
20758 static Tcl_Obj *
ComputeLevelObj(Tcl_Interp * interp,CallStackLevel level)20759 ComputeLevelObj(Tcl_Interp *interp, CallStackLevel level) {
20760   Tcl_CallFrame *framePtr;
20761   Tcl_Obj       *resultObj;
20762 
20763   nonnull_assert(interp != NULL);
20764 
20765   switch (level) {
20766   case CALLING_LEVEL: {
20767     Tcl_CallFrame *callingFramePtr = NULL;
20768 
20769     /*
20770      * NsfCallStackFindCallingContext() sets always the framePtr, but
20771      * initialize framePtr explicitly to silence static checkers, since
20772      * ComputeLevelObj() is not performance critical.
20773      */
20774     framePtr = NULL;
20775     NsfCallStackFindCallingContext(interp, 1, &framePtr, &callingFramePtr);
20776     if (framePtr == NULL) {
20777       framePtr = callingFramePtr;
20778     }
20779     break;
20780   }
20781   case ACTIVE_LEVEL:
20782     NsfCallStackFindActiveFrame(interp,    1, &framePtr);
20783     break;
20784   default:
20785     framePtr = NULL;
20786     break; /* silence compiler */
20787   }
20788 
20789   if (framePtr != NULL) {
20790     /*
20791      * The call was from an NSF frame, return absolute frame number.
20792      */
20793     char buffer[LONG_AS_STRING];
20794     int  l;
20795 
20796     buffer[0] = '#';
20797     Nsf_ltoa(buffer+1, (long)Tcl_CallFrame_level(framePtr), &l);
20798     resultObj = Tcl_NewStringObj(buffer, l+1);
20799   } else {
20800     /*
20801      * If not called from an NSF frame, return #0 as default.
20802      *
20803      * TODO: With NsfCallStackFindCallingContext in place, this cannot (should
20804      * not) be reachable. Need to check NsfCallStackFindActiveFrame. When in
20805      * the "clear", provide for a warning here?
20806      *
20807      */
20808     resultObj = Tcl_NewStringObj("#0", 2);
20809   }
20810 
20811   return resultObj;
20812 }
20813 
20814 /*
20815   int
20816   NsfKObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
20817   if (objc < 2) {
20818     return NsfPrintError(interp, "wrong # of args for K");
20819   }
20820 
20821   Tcl_SetObjResult(interp, objv[1]);
20822   return TCL_OK;
20823   }
20824 */
20825 
20826 /*
20827  * object creation & destruction
20828  */
20829 
20830 /*
20831  *----------------------------------------------------------------------
20832  * UnsetInAllNamespaces --
20833  *
20834  *    Try to unset a variable, searching for the variable in all
20835  *    name-spaces. This function is used by volatile to unset the automatic
20836  *    variable used for the destroy trace.
20837  *
20838  * Results:
20839  *    Tcl return code
20840  *
20841  * Side effects:
20842  *    Might unset variable
20843  *
20844  *----------------------------------------------------------------------
20845  */
20846 
20847 static int UnsetInAllNamespaces(
20848     Tcl_Interp *interp, const Tcl_Namespace *nsPtr, const char *name
20849 ) nonnull(1) nonnull(2) nonnull(3);
20850 
20851 static int
UnsetInAllNamespaces(Tcl_Interp * interp,const Tcl_Namespace * nsPtr,const char * name)20852 UnsetInAllNamespaces(
20853     Tcl_Interp *interp, const Tcl_Namespace *nsPtr, const char *name
20854 ) {
20855   int            rc = 0;
20856   Tcl_HashSearch search;
20857   Tcl_HashEntry *entryPtr;
20858   const Tcl_Var *varPtr;
20859 
20860   nonnull_assert(interp != NULL);
20861   nonnull_assert(nsPtr != NULL);
20862   nonnull_assert(name != NULL);
20863 
20864   /*fprintf(stderr, "### UnsetInAllNamespaces variable '%s', current namespace '%s'\n",
20865           name, (nsPtr != NULL) ? nsPtr->fullName : "NULL");*/
20866 
20867   entryPtr = Tcl_FirstHashEntry(Tcl_Namespace_childTablePtr(nsPtr), &search);
20868   varPtr = (Tcl_Var *) Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *)nsPtr, 0);
20869   /*fprintf(stderr, "found %s in %s -> %p\n", name, nsPtr->fullName, varPtr);*/
20870   if (varPtr != NULL) {
20871     Tcl_DString dFullname, *dsPtr = &dFullname;
20872     int         result;
20873 
20874     Tcl_DStringInit(dsPtr);
20875     Tcl_DStringAppend(dsPtr, "unset ", -1);
20876     DStringAppendQualName(dsPtr, nsPtr, name);
20877 
20878     result = Tcl_Eval(interp, Tcl_DStringValue(dsPtr));
20879     /* fprintf(stderr, "fqName = '%s' unset => %d %d\n", Tcl_DStringValue(dsPtr), rc, TCL_OK);*/
20880     if (likely(result == TCL_OK)) {
20881       rc = 1;
20882     } else {
20883       Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
20884       fprintf(stderr, "   err = '%s'\n", ObjStr(resultObj));
20885     }
20886     Tcl_DStringFree(dsPtr);
20887   }
20888 
20889   while ((rc == 0) && (entryPtr != NULL)) {
20890     Tcl_Namespace *childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
20891     /*fprintf(stderr, "child = %s\n", childNsPtr->fullName);*/
20892     entryPtr = Tcl_NextHashEntry(&search);
20893     rc |= UnsetInAllNamespaces(interp, childNsPtr, name);
20894   }
20895 
20896   return rc;
20897 }
20898 
20899 /*
20900  *----------------------------------------------------------------------
20901  * FreeUnsetTraceVariable --
20902  *
20903  *    Unset trace variable.
20904  *
20905  * Results:
20906  *    Tcl return code
20907  *
20908  * Side effects:
20909  *    Might unset variable
20910  *
20911  *----------------------------------------------------------------------
20912  */
20913 
20914 static int FreeUnsetTraceVariable(Tcl_Interp *interp, const NsfObject *object)
20915   nonnull(1) nonnull(2);
20916 
20917 static int
FreeUnsetTraceVariable(Tcl_Interp * interp,const NsfObject * object)20918 FreeUnsetTraceVariable(Tcl_Interp *interp, const NsfObject *object) {
20919 
20920   nonnull_assert(interp != NULL);
20921   nonnull_assert(object != NULL);
20922 
20923   if (object->opt != NULL && (object->opt->volatileVarName != NULL)) {
20924     int result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, 0);
20925 
20926     /*
20927      * Somebody destroys a volatile object manually while the var-trace is
20928      * still active. Destroying the object will be a problem in case the
20929      * variable is deleted later and fires the trace. So, we unset the
20930      * variable here which will cause a destroy via var-trace, which in turn
20931      * clears the volatileVarName flag.
20932      */
20933     /* fprintf(stderr, "### FreeUnsetTraceVariable %s\n", object->opt->volatileVarName);*/
20934 
20935     if (unlikely(result != TCL_OK)) {
20936       result = Tcl_UnsetVar2(interp, object->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY);
20937 
20938       if (unlikely(result != TCL_OK)) {
20939         Tcl_Namespace *nsPtr = Tcl_GetCurrentNamespace(interp);
20940         if (UnsetInAllNamespaces(interp, nsPtr, object->opt->volatileVarName) == 0) {
20941           fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n",
20942                   object->opt->volatileVarName);
20943           /*
20944            * Return always success, since an error during destroy does not
20945            * help at all
20946            */
20947         }
20948       }
20949     }
20950     /*fprintf(stderr, "### FreeUnsetTraceVariable returns %d OK %d\n", result, TCL_OK);*/
20951   }
20952 
20953   return TCL_OK;
20954 }
20955 
20956 /*
20957  *----------------------------------------------------------------------
20958  * NsfUnsetTrace --
20959  *
20960  *    Function to be triggered whenever the trigger variable is
20961  *    deleted. Typically, this function deletes the associated object.
20962  *
20963  * Results:
20964  *    Result msg or null.
20965  *
20966  * Side effects:
20967  *    Might delete associated object.
20968  *
20969  *----------------------------------------------------------------------
20970  */
20971 
20972 static const char *NsfUnsetTrace(
20973     ClientData clientData, Tcl_Interp *interp,
20974     const char *UNUSED(name), const char *UNUSED(name2), unsigned int flags
20975 ) nonnull(1) nonnull(2);
20976 
20977 static const char *
NsfUnsetTrace(ClientData clientData,Tcl_Interp * interp,const char * UNUSED (name),const char * UNUSED (name2),unsigned int flags)20978 NsfUnsetTrace(
20979     ClientData clientData, Tcl_Interp *interp,
20980     const char *UNUSED(name), const char *UNUSED(name2), unsigned int flags
20981 ) {
20982   Tcl_Obj    *objPtr = (Tcl_Obj *)clientData;
20983   NsfObject  *object;
20984   const char *resultMsg = NULL;
20985 
20986   nonnull_assert(clientData != NULL);
20987   nonnull_assert(interp != NULL);
20988 
20989   /*fprintf(stderr, "NsfUnsetTrace %s flags %.4x %.4x\n", name, flags,
20990     flags & TCL_INTERP_DESTROYED);*/
20991 
20992   if ((flags & TCL_INTERP_DESTROYED) == 0u) {
20993     if (GetObjectFromObj(interp, objPtr, &object) == TCL_OK) {
20994       Tcl_Obj *savedResultObj = Tcl_GetObjResult(interp); /* save the result */
20995 
20996       INCR_REF_COUNT(savedResultObj);
20997 
20998       /*
20999        * Clear variable, destroy is called from trace.
21000        */
21001       if (object->opt != NULL && object->opt->volatileVarName) {
21002         object->opt->volatileVarName = NULL;
21003       }
21004 
21005       if (DispatchDestroyMethod(interp, object, 0u) != TCL_OK) {
21006         resultMsg = "Destroy for volatile object failed";
21007       } else {
21008         resultMsg = "No NSF Object passed";
21009       }
21010 
21011       Tcl_SetObjResult(interp, savedResultObj);  /* restore the result */
21012       DECR_REF_COUNT(savedResultObj);
21013     }
21014     DECR_REF_COUNT(objPtr);
21015   } else {
21016     /*fprintf(stderr, "omitting destroy on %s %p\n", name);*/
21017   }
21018   return resultMsg;
21019 }
21020 
21021 /*
21022  *----------------------------------------------------------------------
21023  * CleanupDestroyObject --
21024  *
21025  *    Perform cleanup of object; after the function is executed, the object is
21026  *    in the same fresh state as after initialization.
21027  *
21028  * Results:
21029  *    None.
21030  *
21031  * Side effects:
21032  *    Possibly freeing memory.
21033  *
21034  *----------------------------------------------------------------------
21035  */
21036 static void CleanupDestroyObject(Tcl_Interp *interp, NsfObject *object, bool softrecreate)
21037   nonnull(1) nonnull(2);
21038 
21039 static void
CleanupDestroyObject(Tcl_Interp * interp,NsfObject * object,bool softrecreate)21040 CleanupDestroyObject(Tcl_Interp *interp, NsfObject *object, bool softrecreate) {
21041 
21042   nonnull_assert(interp != NULL);
21043   nonnull_assert(object != NULL);
21044 
21045   /*fprintf(stderr, "CleanupDestroyObject obj %p softrecreate %d nsPtr %p\n",
21046     object, softrecreate, object->nsPtr);*/
21047 
21048   /*
21049    * The object pointer is guaranteed to point to the same object, so it is
21050    * not sufficient for methodObj validation. Therefore, for objects
21051    * containing per-object methods, we increment the objectMethodEpoch.
21052    */
21053   if (object->nsPtr != NULL) {
21054     NsfObjectMethodEpochIncr("CleanupDestroyObject");
21055   }
21056 
21057   /*
21058    * Remove the instance, but not for ::Class/::Object
21059    */
21060   if (!IsBaseClass(object)) {
21061 
21062     if (!softrecreate) {
21063       RemoveInstance(object, object->cl);
21064     }
21065   }
21066 
21067   /*
21068    * Unset object variables with unset traces preemptively.
21069    */
21070   UnsetTracedVars(interp, object);
21071 
21072   if (object->nsPtr != NULL) {
21073     NSCleanupNamespace(interp, object->nsPtr);
21074     NSDeleteChildren(interp, object->nsPtr);
21075   }
21076 
21077   if (object->varTablePtr != NULL) {
21078     /*
21079      * Any unset-traced variable has been deleted before (UnsetTracedVars).
21080      */
21081     TclDeleteVars(((Interp *)interp), object->varTablePtr);
21082 
21083     ckfree((char *)object->varTablePtr);
21084     /*FREE(obj->varTablePtr, obj->varTablePtr);*/
21085     object->varTablePtr = 0;
21086   }
21087 
21088   if (object->opt != NULL) {
21089     NsfObjectOpt *opt = object->opt;
21090 #if defined(NSF_WITH_ASSERTIONS)
21091     if (opt->assertions != NULL) {
21092       AssertionRemoveStore(opt->assertions);
21093       opt->assertions = NULL;
21094     }
21095 #endif
21096 
21097 #if defined(PER_OBJECT_PARAMETER_CACHING)
21098     if (object->opt->parsedParamPtr != NULL) {
21099       NsfParameterCacheObjectInvalidateCmd(interp, object);
21100     }
21101 #endif
21102 
21103     if (!softrecreate) {
21104       /*
21105        * Remove this object from all per object mixin lists and clear the
21106        * mixin list.
21107        */
21108       if (opt->objMixins != NULL) {
21109         RemoveFromObjectMixinsOf(object->id, opt->objMixins);
21110       }
21111 
21112       CmdListFree(&opt->objMixins, GuardDel);
21113       CmdListFree(&opt->objFilters, GuardDel);
21114       FREE(NsfObjectOpt, opt);
21115       object->opt = NULL;
21116     }
21117   }
21118 
21119   object->flags &= ~NSF_MIXIN_ORDER_VALID;
21120   if (object->mixinOrder != NULL) {
21121     MixinResetOrder(object);
21122   }
21123   object->flags &= ~NSF_FILTER_ORDER_VALID;
21124   if (object->filterOrder != NULL) {
21125     FilterResetOrder(object);
21126   }
21127 }
21128 
21129 /*
21130  * obj initialization & namespace creation
21131  */
21132 
21133 /*
21134  *----------------------------------------------------------------------
21135  * CleanupInitObject --
21136  *
21137  *    Perform the initialization of an object in a virgin state.
21138  *    During bootstrap, cl might be NULL.
21139  *
21140  * Results:
21141  *    None.
21142  *
21143  * Side effects:
21144  *    Updating the object structure
21145  *
21146  *----------------------------------------------------------------------
21147  */
21148 static void CleanupInitObject(
21149     Tcl_Interp *interp, NsfObject *object,
21150     NsfClass *class, Tcl_Namespace *nsPtr, bool softrecreate
21151 ) nonnull(1) nonnull(2);
21152 
21153 static void
CleanupInitObject(Tcl_Interp * interp,NsfObject * object,NsfClass * class,Tcl_Namespace * nsPtr,bool softrecreate)21154 CleanupInitObject(
21155     Tcl_Interp *interp, NsfObject *object,
21156     NsfClass *class, Tcl_Namespace *nsPtr, bool softrecreate
21157 ) {
21158 
21159   nonnull_assert(interp != NULL);
21160   nonnull_assert(object != NULL);
21161 
21162 #ifdef OBJDELETION_TRACE
21163   fprintf(stderr, "+++ CleanupInitObject\n");
21164 #endif
21165   object->teardown = interp;
21166   object->nsPtr = nsPtr;
21167 
21168   if (!softrecreate && class != NULL) {
21169     AddInstance(object, class);
21170   }
21171   if ((object->flags & NSF_RECREATE) != 0u) {
21172     object->opt = NULL;
21173     object->varTablePtr = NULL;
21174     object->mixinOrder = NULL;
21175     object->filterOrder = NULL;
21176     object->flags = 0;
21177   }
21178   /*
21179     fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", (obj->cmdName != NULL) ? ObjectName(object) : "", object, object->cl);*/
21180 }
21181 
21182 /*
21183  *----------------------------------------------------------------------
21184  * PrimitiveDestroy --
21185  *
21186  *    Dispatch either PrimitiveCDestroy or PrimitiveODestroy
21187  *    depending on whether the object is a class
21188  *
21189  * Results:
21190  *    None.
21191  *
21192  * Side effects:
21193  *    None.
21194  *
21195  *----------------------------------------------------------------------
21196  */
21197 static void
PrimitiveDestroy(ClientData clientData)21198 PrimitiveDestroy(ClientData clientData) {
21199 
21200   nonnull_assert(clientData != NULL);
21201 
21202   if (NsfObjectIsClass((NsfObject *)clientData)) {
21203     PrimitiveCDestroy(clientData);
21204   } else {
21205     PrimitiveODestroy(clientData);
21206   }
21207 }
21208 
21209 /*
21210  *----------------------------------------------------------------------
21211  * TclDeletesObject --
21212  *
21213  *    Function to be called, when Tcl deletes the command which has an
21214  *    object/class associated. This happens, when e.g. a namespace is deleted.
21215  *
21216  * Results:
21217  *    None.
21218  *
21219  * Side effects:
21220  *    None.
21221  *
21222  *----------------------------------------------------------------------
21223  */
21224 static void TclDeletesObject(ClientData clientData)
21225   nonnull(1);
21226 
21227 static void
TclDeletesObject(ClientData clientData)21228 TclDeletesObject(ClientData clientData) {
21229   NsfObject *object;
21230 
21231   nonnull_assert(clientData != NULL);
21232 
21233   object = (NsfObject *)clientData;
21234 
21235   /*
21236    * TODO: Actually, it seems like a good idea to flag a deletion from Tcl by
21237    * setting object->id to NULL. However, we seem to have some dependencies
21238    * avoiding this currently, so we use the flag.
21239    */
21240   object->flags |= NSF_TCL_DELETE;
21241 
21242   /*fprintf(stderr, "cmd dealloc %p TclDeletesObject (%d)\n",
21243     object->id,  Tcl_Command_refCount(object->id));*/
21244 
21245 #ifdef OBJDELETION_TRACE
21246   fprintf(stderr, "TclDeletesObject %p obj->id %p flags %.6x\n", object, object->id, object->flags);
21247 #endif
21248   if (unlikely((object->flags & NSF_DURING_DELETE) == 0u)
21249       && (object->teardown != NULL)
21250       ) {
21251 
21252 # ifdef OBJDELETION_TRACE
21253     fprintf(stderr, "... %p %s\n", object, ObjectName(object));
21254 # endif
21255 
21256     CallStackDestroyObject(object->teardown, object);
21257   }
21258 }
21259 
21260 
21261 /*
21262  *----------------------------------------------------------------------
21263  * PrimitiveODestroy --
21264  *
21265  *    Delete an object with its namespace and associated data structures
21266  *    (mixin stack, filter stack). The physical deallocation is handled by
21267  *    NsfCleanupObject() which performs reference counting.
21268  *
21269  * Results:
21270  *    None.
21271  *
21272  * Side effects:
21273  *    Free object contents.
21274  *
21275  *----------------------------------------------------------------------
21276  */
21277 static void
PrimitiveODestroy(ClientData clientData)21278 PrimitiveODestroy(ClientData clientData) {
21279   NsfObject  *object;
21280   Tcl_Interp *interp;
21281 
21282   nonnull_assert(clientData != NULL);
21283 
21284   object = (NsfObject *)clientData;
21285   assert(object->teardown != NULL);
21286 
21287   /*fprintf(stderr, "****** PrimitiveODestroy %p cmd %p flags %.6x\n",
21288     (void *)object, (void *)object->id, object->flags);*/
21289 
21290   /*
21291    * We assume, the object was not yet deleted, but destroy was called
21292    * already.
21293    */
21294   assert((object->flags & NSF_DELETED) == 0u);
21295   assert((object->flags & NSF_DESTROY_CALLED) != 0u);
21296 
21297   /*
21298    * Check and latch against recurrent calls with object->teardown.
21299    */
21300   PRINTOBJ("PrimitiveODestroy", object);
21301   interp = object->teardown;
21302 
21303   /*
21304    * Don't destroy, if the interpreter is destroyed already
21305    * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed
21306    */
21307   if (!Tcl_InterpDeleted(interp)) {
21308 
21309 #ifdef OBJDELETION_TRACE
21310     {Command *cmdPtr = object->id;
21311       fprintf(stderr, "  physical delete of %p id=%p (cmd->refCount %d) destroyCalled=%d '%s'\n",
21312               object, object->id, cmdPtr->refCount, (object->flags & NSF_DESTROY_CALLED), ObjectName(object));
21313     }
21314 #endif
21315     CleanupDestroyObject(interp, object, NSF_FALSE);
21316 
21317     while (object->mixinStack != NULL) {
21318       MixinStackPop(object);
21319     }
21320 
21321     while (object->filterStack != NULL) {
21322       FilterStackPop(object);
21323     }
21324 
21325     /*
21326      * Object is now mostly dead, but still allocated. However, since
21327      * Nsf_DeleteNamespace might delegate to the parent (e.g. slots) we clear
21328      * teardown after the deletion of the children.
21329      */
21330     if (object->nsPtr != NULL) {
21331       /*fprintf(stderr, "PrimitiveODestroy calls deleteNamespace for object %p nsPtr %p\n", (void*)object, object->nsPtr);*/
21332       Nsf_DeleteNamespace(interp, object->nsPtr);
21333       object->nsPtr = NULL;
21334     }
21335     object->teardown = NULL;
21336 
21337     /*fprintf(stderr, " +++ OBJ/CLS free: %p %s\n", (void *)object, ObjectName(object));*/
21338 
21339     object->flags |= NSF_DELETED;
21340     ObjTrace("ODestroy", object);
21341 
21342     DECR_REF_COUNT(object->cmdName);
21343     NsfCleanupObject(object, "PrimitiveODestroy");
21344   }
21345 }
21346 
21347 /*
21348  *----------------------------------------------------------------------
21349  * DoDealloc --
21350  *
21351  *    Perform deallocation of an object/class. This function is called
21352  *    from the dealloc method and internally to get rid of an
21353  *    abject. It cares about volatile and frees/triggers free
21354  *    operation depending on the stack references.
21355  *
21356  * Results:
21357  *    Tcl return code
21358  *
21359  * Side effects:
21360  *    freed object or object is marked to be freed.
21361  *
21362  *----------------------------------------------------------------------
21363  */
21364 static int DoDealloc(Tcl_Interp *interp, NsfObject *object)
21365   nonnull(1) nonnull(2);
21366 
21367 static int
DoDealloc(Tcl_Interp * interp,NsfObject * object)21368 DoDealloc(Tcl_Interp *interp, NsfObject *object) {
21369   int result;
21370 
21371   nonnull_assert(interp != NULL);
21372   nonnull_assert(object != NULL);
21373 
21374   /*fprintf(stderr, "DoDealloc obj= %s %p flags %.6x activation %d cmd %p opt=%p\n",
21375           ObjectName(object), object, object->flags, object->activationCount,
21376           object->id, object->opt);*/
21377 
21378   result = FreeUnsetTraceVariable(interp, object);
21379   if (unlikely(result == TCL_OK)) {
21380 
21381     /*
21382      * Latch, and call delete command if not already in progress.
21383      */
21384     if (RUNTIME_STATE(interp)->exitHandlerDestroyRound !=
21385         NSF_EXITHANDLER_ON_SOFT_DESTROY) {
21386       CallStackDestroyObject(interp, object);
21387     }
21388   }
21389 
21390   return result;
21391 }
21392 
21393 
21394 /*
21395  *----------------------------------------------------------------------
21396  * MarkUndestroyed --
21397  *
21398  *    Mark an object as if destroy was not called. This function is e.g. used
21399  *    from recreate.
21400  *
21401  * Results:
21402  *    None
21403  *
21404  * Side effects:
21405  *    Setting object flag.
21406  *
21407  *----------------------------------------------------------------------
21408  */
21409 static void MarkUndestroyed(NsfObject *object)
21410   nonnull(1);
21411 
21412 static void
MarkUndestroyed(NsfObject * object)21413 MarkUndestroyed(NsfObject *object) {
21414 
21415   nonnull_assert(object != NULL);
21416 
21417   object->flags &= ~NSF_DESTROY_CALLED;
21418 }
21419 
21420 /*
21421  *----------------------------------------------------------------------
21422  * PrimitiveOInit --
21423  *
21424  *    Set/reset the object to a fresh, un-destroyed state
21425  *
21426  * Results:
21427  *    Tcl return code
21428  *
21429  * Side effects:
21430  *    initializing object structure
21431  *
21432  *----------------------------------------------------------------------
21433  */
21434 static void PrimitiveOInit(NsfObject *object, Tcl_Interp *interp, const char *name,
21435                            Tcl_Namespace *nsPtr, NsfClass *class)
21436   nonnull(1) nonnull(2) nonnull(3);
21437 
21438 static void
PrimitiveOInit(NsfObject * object,Tcl_Interp * interp,const char * name,Tcl_Namespace * nsPtr,NsfClass * class)21439 PrimitiveOInit(NsfObject *object, Tcl_Interp *interp, const char *name,
21440                Tcl_Namespace *nsPtr, NsfClass *class) {
21441 
21442   nonnull_assert(object != NULL);
21443   nonnull_assert(interp != NULL);
21444   nonnull_assert(name != NULL);
21445 
21446 #ifdef OBJDELETION_TRACE
21447   fprintf(stderr, "+++ PrimitiveOInit\n");
21448 #endif
21449 
21450 #ifdef NSFOBJ_TRACE
21451   fprintf(stderr, "OINIT %s = %p\n", name, object);
21452 #endif
21453   NsfObjectRefCountIncr(object);
21454   MarkUndestroyed(object);
21455 
21456   /*
21457    * There might be already a namespace with the provided name; if this is the
21458    * case, use this namespace as object namespace. The preexisting namespace
21459    * might contain Next Scripting objects. If we would not use the namespace
21460    * as child namespace, we would not recognize the objects as child objects,
21461    * deletions of the object might lead to a crash.
21462    *
21463    * We can use here the provided nsPtr, except in cases, where this
21464    * namespaces is being destroyed (e.g. recreate a new object from a
21465    * different object system).
21466    */
21467 
21468   if (nsPtr != NULL && (((Namespace *)nsPtr)->flags & NS_DYING) != 0u) {
21469     Namespace  *dummy1Ptr, *dummy2Ptr, *nsPtr1 = (Namespace *)nsPtr;
21470     const char *dummy;
21471     TclGetNamespaceForQualName(interp, name,
21472                                NULL, TCL_GLOBAL_ONLY|TCL_FIND_ONLY_NS,
21473                                &nsPtr1, &dummy1Ptr, &dummy2Ptr, &dummy);
21474     nsPtr = (Tcl_Namespace *)nsPtr1;
21475     /*fprintf(stderr, "PrimitiveOInit %p calls TclGetNamespaceForQualName with %s => %p given %p object->nsPtr %p\n",
21476             object, name,
21477             nsPtr, nsPtr, object->nsPtr);*/
21478   }
21479 
21480   if (nsPtr != NULL) {
21481     NsfNamespaceInit(nsPtr);
21482   }
21483 
21484   /* fprintf(stderr, "PrimitiveOInit %p %s, ns %p\n", object, name, nsPtr); */
21485   CleanupInitObject(interp, object, class, nsPtr, NSF_FALSE);
21486 
21487   /*
21488    * TODO: would be nice, if we could init object flags.
21489    */
21490   /* object->flags = NSF_MIXIN_ORDER_VALID | NSF_FILTER_ORDER_VALID;*/
21491   object->mixinStack = NULL;
21492   object->filterStack = NULL;
21493 }
21494 
21495 /*
21496  *----------------------------------------------------------------------
21497  * PrimitiveOCreate --
21498  *
21499  *    Allocate memory for an object, create the object name and the associated
21500  *    Tcl command and call the initialization functions.
21501  *
21502  * Results:
21503  *    NsfObject*
21504  *
21505  * Side effects:
21506  *    Allocating memory
21507  *
21508  *----------------------------------------------------------------------
21509  */
21510 static NsfObject * PrimitiveOCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr, NsfClass *class)
21511   nonnull(1) nonnull(2) nonnull(4) returns_nonnull;
21512 
21513 static NsfObject *
PrimitiveOCreate(Tcl_Interp * interp,Tcl_Obj * nameObj,Tcl_Namespace * parentNsPtr,NsfClass * class)21514 PrimitiveOCreate(Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr, NsfClass *class) {
21515   const char    *nameString;
21516   Tcl_Namespace *nsPtr;
21517   NsfObject     *object;
21518 
21519   nonnull_assert(interp != NULL);
21520   nonnull_assert(nameObj != NULL);
21521   nonnull_assert(class != NULL);
21522 
21523   object = (NsfObject *)ckalloc((int)sizeof(NsfObject));
21524   MEM_COUNT_ALLOC("NsfObject/NsfClass", object);
21525   assert(object != NULL); /* ckalloc panics, if malloc fails */
21526 
21527   memset(object, 0, sizeof(NsfObject));
21528 
21529   nameString = ObjStr(nameObj);
21530   assert(isAbsolutePath(nameString));
21531 
21532 #if defined(NSFOBJ_TRACE)
21533   fprintf(stderr, "CKALLOC Object %p %s\n", object, nameString);
21534 #endif
21535 #ifdef OBJDELETION_TRACE
21536   fprintf(stderr, "+++ PrimitiveOCreate\n");
21537 #endif
21538 
21539   nsPtr = NSCheckNamespace(interp, nameString, parentNsPtr);
21540   if (nsPtr != NULL) {
21541     NSNamespacePreserve(nsPtr);
21542   }
21543 #if defined(NRE)
21544   object->id = Tcl_NRCreateCommand(interp, nameString,
21545                                    NsfObjDispatch,
21546                                    NsfObjDispatchNRE,
21547                                    object, TclDeletesObject);
21548 #else
21549   object->id = Tcl_CreateObjCommand(interp, nameString, NsfObjDispatch,
21550                                     object, TclDeletesObject);
21551 #endif
21552 
21553   /*fprintf(stderr, "cmd alloc %p %d (%s)\n", object->id,
21554     Tcl_Command_refCount(object->id), nameString);*/
21555 
21556   PrimitiveOInit(object, interp, nameString, nsPtr, class);
21557   if (nsPtr != NULL) {
21558     NSNamespaceRelease(nsPtr);
21559   }
21560 
21561   object->cmdName = nameObj;
21562   INCR_REF_COUNT(object->cmdName);
21563 
21564   ObjTrace("PrimitiveOCreate", object);
21565 
21566   return object;
21567 }
21568 
21569 /*
21570  *----------------------------------------------------------------------
21571  * DefaultSuperClass --
21572  *
21573  *    Determine the default superclass of the class (specified as
21574  *    second argument) and metaclass (third argument). The function
21575  *    searches for the variable NSF_DEFAULTMETACLASS or
21576  *    NSF_DEFAULTSUPERCLASS and uses it if present.
21577  *
21578  * Results:
21579  *    Default superclass or NULL
21580  *
21581  * Side effects:
21582  *    None.
21583  *
21584  *----------------------------------------------------------------------
21585  */
21586 static NsfClass *
DefaultSuperClass(Tcl_Interp * interp,const NsfClass * class,const NsfClass * metaClass,bool isMeta)21587 DefaultSuperClass(Tcl_Interp *interp, const NsfClass *class, const NsfClass *metaClass, bool isMeta) {
21588   NsfClass *resultClass = NULL;
21589   Tcl_Obj  *resultObj;
21590 
21591   nonnull_assert(interp != NULL);
21592   nonnull_assert(class != NULL);
21593   nonnull_assert(metaClass != NULL);
21594 
21595   /*fprintf(stderr, "DefaultSuperClass cl %s, mcl %s, isMeta %d\n",
21596     ClassName(class), ClassName(metaClass), isMeta );*/
21597 
21598   resultObj = Nsf_ObjGetVar2((Nsf_Object *)metaClass, interp, (isMeta != 0) ?
21599                              NsfGlobalObjs[NSF_DEFAULTMETACLASS] :
21600                              NsfGlobalObjs[NSF_DEFAULTSUPERCLASS], NULL, 0);
21601 
21602   if (resultObj != NULL) {
21603     if (unlikely(GetClassFromObj(interp, resultObj, &resultClass, NSF_FALSE) != TCL_OK)) {
21604       NsfPrintError(interp, "default superclass is not a class");
21605     }
21606     /*fprintf(stderr, "DefaultSuperClass for %s got from var %s => %s\n",
21607             ClassName(class),
21608             ObjStr((isMeta != 0) ? NsfGlobalObjs[NSF_DEFAULTMETACLASS] : NsfGlobalObjs[NSF_DEFAULTSUPERCLASS]),
21609             ClassName(resultClass));*/
21610   } else {
21611     const NsfClasses *sc;
21612 
21613     /*fprintf(stderr, "DefaultSuperClass for %s: search in superClasses starting with %p meta %d\n",
21614       ClassName(class), cl->super, isMeta);*/
21615 
21616     if (isMeta != 0) {
21617       /*
21618        * Is this already the root metaclass ?
21619        */
21620       if (IsRootMetaClass(metaClass->object.cl)) {
21621         return metaClass->object.cl;
21622       }
21623     }
21624 
21625     /*
21626      * Check superClasses of metaclass
21627      */
21628     for (sc = metaClass->super; sc && sc->cl != class; sc = sc->nextPtr) {
21629       /* fprintf(stderr, "  ... check ismeta %d %s root mcl %d root cl %d\n",
21630          isMeta, ClassName(sc->cl),
21631          sc->cl->object.flags & NSF_IS_ROOT_META_CLASS,
21632          sc->cl->object.flags & NSF_IS_ROOT_CLASS); */
21633       if (isMeta != 0) {
21634         if (IsRootMetaClass(sc->cl)) {
21635           return sc->cl;
21636         }
21637       } else {
21638         if (IsRootClass(sc->cl)) {
21639           /* fprintf(stderr, "found root-class %p %s\n", sc->cl, ClassName(sc->cl)); */
21640           return sc->cl;
21641         }
21642       }
21643 
21644       resultClass = DefaultSuperClass(interp, class, sc->cl, isMeta);
21645       if (resultClass != NULL) {
21646         break;
21647       }
21648     }
21649   }
21650 
21651   return resultClass;
21652 }
21653 
21654 /*
21655  *----------------------------------------------------------------------
21656  * CleanupDestroyClass --
21657  *
21658  *    Cleanup class in a destroy call.  Remove filters, mixins, assertions,
21659  *    instances and remove finally class from class hierarchy. In the recreate
21660  *    case, it preserves the pointers from other class structures.
21661  *
21662  * Results:
21663  *    None.
21664  *
21665  * Side effects:
21666  *    Updated class structures.
21667  *
21668  *----------------------------------------------------------------------
21669  */
21670 
21671 static void CleanupDestroyClass(Tcl_Interp *interp, NsfClass *class, bool softrecreate, bool recreate)
21672   nonnull(1) nonnull(2);
21673 
21674 static void
CleanupDestroyClass(Tcl_Interp * interp,NsfClass * class,bool softrecreate,bool recreate)21675 CleanupDestroyClass(Tcl_Interp *interp, NsfClass *class, bool softrecreate, bool recreate) {
21676   NsfClassOpt *clopt;
21677   NsfClass    *baseClass = NULL;
21678   NsfClasses  *subClasses;
21679 
21680   nonnull_assert(interp != NULL);
21681   nonnull_assert(class != NULL);
21682 
21683   PRINTOBJ("CleanupDestroyClass", (NsfObject *)class);
21684   assert(softrecreate ? recreate : NSF_TRUE);
21685 
21686   clopt = class->opt;
21687   /*fprintf(stderr, "CleanupDestroyClass %p %s (ismeta=%d) softrecreate=%d, recreate=%d, %p\n",
21688           class, ClassName(class), IsMetaClass(interp, cl, NSF_TRUE),
21689           softrecreate, recreate, clopt);*/
21690 
21691   subClasses = DependentSubClasses(class);
21692   if (subClasses != NULL) {
21693 
21694     /*
21695      * Perform the next steps even with clopt == NULL, since the class
21696      * might be used as a superclass of a per object mixin, so it might
21697      * have no clopt...
21698      */
21699     MixinInvalidateObjOrders(subClasses);
21700     if (FiltersDefined(interp) > 0) {
21701       FilterInvalidateObjOrders(interp, subClasses);
21702     }
21703   }
21704 
21705   if (clopt != NULL) {
21706     /*
21707      *  Remove this class from all isClassMixinOf lists and clear the
21708      *  class mixin list
21709      */
21710     if (clopt->classMixins != NULL) {
21711       RemoveFromClassMixinsOf(clopt->id, clopt->classMixins);
21712     }
21713 
21714     CmdListFree(&clopt->classMixins, GuardDel);
21715     CmdListFree(&clopt->classFilters, GuardDel);
21716 
21717     if (clopt->mixinRegObjs != NULL) {
21718       NsfMixinregInvalidate(interp, clopt->mixinRegObjs);
21719       DECR_REF_COUNT2("mixinRegObjs", clopt->mixinRegObjs);
21720       clopt->mixinRegObjs = NULL;
21721     }
21722 
21723     if (!recreate) {
21724       /*
21725        *  Remove this class from all mixin lists and clear the isObjectMixinOf list
21726        */
21727       if (clopt->isObjectMixinOf != 0) {
21728         RemoveFromObjectMixins(clopt->id, clopt->isObjectMixinOf);
21729       }
21730       CmdListFree(&clopt->isObjectMixinOf, GuardDel);
21731 
21732       /*
21733        *  Remove this class from all class mixin lists and clear the
21734        *  isClassMixinOf list
21735        */
21736       if (clopt->isClassMixinOf != 0) {
21737         RemoveFromClassmixins(clopt->id, clopt->isClassMixinOf);
21738       }
21739       CmdListFree(&clopt->isClassMixinOf, GuardDel);
21740     }
21741 
21742     /*
21743      * Remove dependent filters of this class from all subclasses
21744      */
21745     if (subClasses != NULL) {
21746       FilterRemoveDependentFilterCmds(class, subClasses);
21747     }
21748 
21749 #if defined(NSF_WITH_ASSERTIONS)
21750     if (clopt->assertions != NULL) {
21751         AssertionRemoveStore(clopt->assertions);
21752         clopt->assertions = NULL;
21753       }
21754 #endif
21755 
21756 #ifdef NSF_OBJECTDATA
21757     NsfFreeObjectData(class);
21758 #endif
21759   }
21760 
21761   NSCleanupNamespace(interp, class->nsPtr);
21762   NSDeleteChildren(interp, class->nsPtr);
21763 
21764   if (!softrecreate) {
21765 
21766     /*
21767      * Reclass all instances of the current class to the appropriate
21768      * most general class ("baseClass"). The most general class of a
21769      * metaclass is the root metaclass, the most general class of an
21770      * object is the root-class. Instances of metaclasses can be only
21771      * reset to the root metaclass (and not to the root base
21772      * class).
21773      */
21774     baseClass = DefaultSuperClass(interp, class, class->object.cl,
21775                                   IsMetaClass(interp, class, NSF_TRUE));
21776     /*
21777      * We do not have to reclassing in case, cl is a root-class
21778      */
21779     if (!IsRootClass(class)) {
21780       Tcl_HashTable       *instanceTablePtr = &class->instances;
21781       Tcl_HashSearch       hSrch;
21782       const Tcl_HashEntry *hPtr;
21783 
21784       for (hPtr = Tcl_FirstHashEntry(instanceTablePtr, &hSrch); hPtr != NULL;
21785            hPtr = Tcl_NextHashEntry(&hSrch)) {
21786         NsfObject *inst = (NsfObject *)Tcl_GetHashKey(instanceTablePtr, hPtr);
21787 
21788         /*fprintf(stderr, "    inst %p %s flags %.6x id %p baseClass %p %s\n",
21789           inst, ObjectName(inst), inst->flags, inst->id, baseClass, ClassName(baseClass));*/
21790         if ((inst != NULL)
21791             && (inst != (NsfObject *)class)
21792             && likely((inst->flags & NSF_DURING_DELETE) == 0u) /*inst->id*/
21793             ) {
21794           if (inst != &(baseClass->object)) {
21795             AddInstance(inst, baseClass);
21796           }
21797         }
21798       }
21799     }
21800     Tcl_DeleteHashTable(&class->instances);
21801     MEM_COUNT_FREE("Tcl_InitHashTable", &class->instances);
21802   }
21803 
21804   if (clopt != NULL && !recreate) {
21805     FREE(NsfClassOpt, clopt);
21806     class->opt = NULL;
21807   }
21808 
21809   if (subClasses != NULL) {
21810     /*
21811      * On a recreate, it might be possible that the newly created class
21812      * has a different superclass. So we have to flush the precedence
21813      * list on a recreate as well.
21814      */
21815     FlushPrecedences(subClasses);
21816     NsfClassListFree(subClasses);
21817   }
21818 
21819   while (class->super != NULL) {
21820     (void)RemoveSuper(class, class->super->cl);
21821   }
21822 
21823   if (!softrecreate) {
21824     /*
21825      * Flush all caches, unlink superClasses.
21826      */
21827 
21828     while (class->sub != NULL) {
21829       NsfClass *subClass = class->sub->cl;
21830 
21831       (void)RemoveSuper(subClass, class);
21832       /*
21833        * If there are no more superclasses add the Object
21834        * class as superClasses
21835        * -> don't do that for Object itself!
21836        */
21837       if (subClass->super == NULL && !IsRootClass(class)) {
21838         /* fprintf(stderr, "subClass %p %s baseClass %p %s\n",
21839            class, ClassName(class), baseClass, ClassName(baseClass)); */
21840         AddSuper(subClass, baseClass);
21841       }
21842     }
21843   }
21844 
21845 }
21846 
21847 /*
21848  *----------------------------------------------------------------------
21849  * CleanupInitClass --
21850  *
21851  *    Basic initialization of a class, setting namespace, super- and
21852  *    subclasses, and setup optionally instances table.
21853  *
21854  * Results:
21855  *    None.
21856  *
21857  * Side effects:
21858  *    Makes a class structure usable.
21859  *
21860  *----------------------------------------------------------------------
21861  */
21862 static void CleanupInitClass(
21863     Tcl_Interp *interp, NsfClass *class, Tcl_Namespace *nsPtr,
21864     bool softrecreate, bool recreate
21865 ) nonnull(1) nonnull(2) nonnull(3);
21866 
21867 static void
CleanupInitClass(Tcl_Interp * interp,NsfClass * class,Tcl_Namespace * nsPtr,bool softrecreate,bool recreate)21868 CleanupInitClass(
21869     Tcl_Interp *interp, NsfClass *class, Tcl_Namespace *nsPtr,
21870     bool softrecreate, bool recreate
21871 ) {
21872   NsfClass *defaultSuperclass;
21873 
21874   nonnull_assert(interp != NULL);
21875   nonnull_assert(class != NULL);
21876   nonnull_assert(nsPtr != NULL);
21877   assert((softrecreate) ? recreate : NSF_TRUE);
21878 
21879 #ifdef OBJDELETION_TRACE
21880   fprintf(stderr, "+++ CleanupInitClass\n");
21881 #endif
21882 
21883   /*
21884    * Record, that cl is a class and set its namespace
21885    */
21886   NsfObjectSetClass((NsfObject *)class);
21887   class->nsPtr = nsPtr;
21888 
21889   if (!softrecreate) {
21890     /*
21891      * Subclasses are preserved during recreate, superClasses not (since the
21892      * creation statement defined the superclass, might be different the
21893      * second time).
21894      */
21895     class->sub = NULL;
21896   }
21897   class->super = NULL;
21898 
21899   /*
21900    * We can the default superclass from the metaclass, if this exists.
21901    */
21902   if (class->object.cl != NULL) {
21903     /*
21904      * Look for a configured default superclass.
21905      */
21906     defaultSuperclass = DefaultSuperClass(interp, class, class->object.cl, NSF_FALSE);
21907   } else {
21908     defaultSuperclass = NULL;
21909   }
21910   if (class != defaultSuperclass) {
21911     AddSuper(class, defaultSuperclass);
21912   }
21913 
21914   class->color = WHITE;
21915   class->order = NULL;
21916 
21917   if (!softrecreate) {
21918     Tcl_InitHashTable(&class->instances, TCL_ONE_WORD_KEYS);
21919     MEM_COUNT_ALLOC("Tcl_InitHashTable", &class->instances);
21920   }
21921 
21922   if (!recreate) {
21923     class->opt = NULL;
21924   }
21925 }
21926 
21927 /*
21928  *----------------------------------------------------------------------
21929  * PrimitiveCDestroy --
21930  *
21931  *    Delete a class with its namespace and associated data structures. The
21932  *    physical deallocation is handled by PrimitiveODestroy().
21933  *
21934  * Results:
21935  *    None.
21936  *
21937  * Side effects:
21938  *    Free object contents.
21939  *
21940  *----------------------------------------------------------------------
21941  */
21942 static void
PrimitiveCDestroy(ClientData clientData)21943 PrimitiveCDestroy(ClientData clientData) {
21944   NsfClass      *class;
21945 
21946   nonnull_assert(clientData != NULL);
21947 
21948   class = (NsfClass *)clientData;
21949   PRINTOBJ("PrimitiveCDestroy", class);
21950 
21951   /*
21952    * Check and latch against recurrent calls with obj->teardown
21953    */
21954   if (class != NULL && class->object.teardown != NULL) {
21955     Tcl_Interp *interp;
21956 
21957     interp = class->object.teardown;
21958 
21959     /*
21960      * Don't destroy, if the interpreted is destroyed already
21961      * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed
21962      */
21963     if (!Tcl_InterpDeleted(interp)) {
21964       Tcl_Namespace *saved;
21965 
21966       /*
21967        * Call and latch user destroy with object->id if we haven't
21968        */
21969       /*fprintf(stderr, "PrimitiveCDestroy %s flags %.6x\n", ObjectName(object), object->flags);*/
21970 
21971       class->object.teardown = NULL;
21972       CleanupDestroyClass(interp, class, NSF_FALSE, NSF_FALSE);
21973 
21974       /*
21975        * handoff the primitive teardown
21976        */
21977       saved = class->nsPtr;
21978       class->object.teardown = interp;
21979 
21980       /*
21981        * class object destroy + physical destroy
21982        */
21983       PrimitiveODestroy(clientData);
21984 
21985       /*fprintf(stderr, "primitive cdestroy calls delete namespace for obj %p, nsPtr %p flags %.6x\n",
21986         cl, saved, ((Namespace *)saved)->flags);*/
21987       Nsf_DeleteNamespace(interp, saved);
21988       /*fprintf(stderr, "primitive cdestroy %p DONE\n", class);*/
21989     }
21990   }
21991   return;
21992 }
21993 
21994 /*
21995  *----------------------------------------------------------------------
21996  * PrimitiveCInit --
21997  *
21998  *    Set/reset a class to a fresh, un-destroyed state
21999  *
22000  * Results:
22001  *    Tcl return code
22002  *
22003  * Side effects:
22004  *    initializing object structure
22005  *
22006  *----------------------------------------------------------------------
22007  */
22008 static void PrimitiveCInit(NsfClass *class, Tcl_Interp *interp, const char *name)
22009   nonnull(1) nonnull(2) nonnull(3);
22010 
22011 static void
PrimitiveCInit(NsfClass * class,Tcl_Interp * interp,const char * name)22012 PrimitiveCInit(NsfClass *class, Tcl_Interp *interp, const char *name) {
22013   Tcl_CallFrame frame, *framePtr = &frame;
22014 
22015   nonnull_assert(class != NULL);
22016   nonnull_assert(interp != NULL);
22017   nonnull_assert(name != NULL);
22018 
22019   /*
22020    * Ensure that namespace is newly created during CleanupInitClass. Kill it,
22021    * if it exists already
22022    */
22023   if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr,
22024                         RUNTIME_STATE(interp)->NsfClassesNS, 0) == TCL_OK) {
22025     Tcl_Namespace *nsPtr;
22026 
22027     nsPtr = NSGetFreshNamespace(interp, &class->object, name);
22028     Tcl_PopCallFrame(interp);
22029     CleanupInitClass(interp, class, nsPtr, NSF_FALSE, NSF_FALSE);
22030   }
22031 
22032   return;
22033 }
22034 
22035 
22036 /*
22037  *----------------------------------------------------------------------
22038  * PrimitiveCCreate --
22039  *
22040  *    Allocate memory for a class, initialize the class specific data
22041  *    structure (e.g. class namespace) and call PrimitiveOCreate() for the
22042  *    object specific initialization.
22043  *
22044  * Results:
22045  *    NsfClass*
22046  *
22047  * Side effects:
22048  *    Allocating memory
22049  *
22050  *----------------------------------------------------------------------
22051  */
22052 static NsfClass *PrimitiveCCreate(
22053     Tcl_Interp *interp, Tcl_Obj *nameObj,
22054     Tcl_Namespace *parentNsPtr, NsfClass *metaClass
22055 ) nonnull(1) nonnull(2) returns_nonnull;
22056 
22057 static NsfClass *
PrimitiveCCreate(Tcl_Interp * interp,Tcl_Obj * nameObj,Tcl_Namespace * parentNsPtr,NsfClass * metaClass)22058 PrimitiveCCreate(
22059     Tcl_Interp *interp, Tcl_Obj *nameObj,
22060     Tcl_Namespace *parentNsPtr, NsfClass *metaClass
22061 ) {
22062   Tcl_Namespace *nsPtr;
22063   const char    *nameString;
22064   NsfObject     *object;
22065   NsfClass      *class;
22066 
22067   nonnull_assert(interp != NULL);
22068   nonnull_assert(nameObj != NULL);
22069 
22070   class = (NsfClass *)ckalloc((int)sizeof(NsfClass));
22071   nameString = ObjStr(nameObj);
22072   object = (NsfObject *)class;
22073 
22074 #if defined(NSFOBJ_TRACE)
22075   fprintf(stderr, "CKALLOC Class %p %s\n", class, nameString);
22076 #endif
22077 
22078   memset(class, 0, sizeof(NsfClass));
22079   MEM_COUNT_ALLOC("NsfObject/NsfClass", class);
22080 
22081   /*
22082    * Pass object system from metaclass.
22083    */
22084   if (metaClass != NULL) {
22085     class->osPtr = metaClass->osPtr;
22086   }
22087 
22088   assert(isAbsolutePath(nameString));
22089   /*
22090     fprintf(stderr, "Class alloc %p '%s'\n", cl, nameString);
22091   */
22092   nsPtr = NSCheckNamespace(interp, nameString, parentNsPtr);
22093   if (nsPtr != NULL) {
22094     NSNamespacePreserve(nsPtr);
22095   }
22096 #if defined(NRE)
22097   object->id = Tcl_NRCreateCommand(interp, nameString,
22098                                    NsfObjDispatch,
22099                                    NsfObjDispatchNRE,
22100                                    class, TclDeletesObject);
22101 #else
22102   object->id = Tcl_CreateObjCommand(interp, nameString, NsfObjDispatch,
22103                                     class, TclDeletesObject);
22104 #endif
22105   PrimitiveOInit(object, interp, nameString, nsPtr, metaClass);
22106 
22107   if (nsPtr != NULL) {
22108     NSNamespaceRelease(nsPtr);
22109   }
22110   object->cmdName = nameObj;
22111 
22112   INCR_REF_COUNT(object->cmdName);
22113   PrimitiveCInit(class, interp, nameString+2);
22114 
22115   ObjTrace("PrimitiveCCreate", object);
22116   return class;
22117 }
22118 
22119 
22120 /*
22121  *----------------------------------------------------------------------
22122  * ChangeClass --
22123  *
22124  *    Change class of a Next Scripting object. This function takes
22125  *    care that one tries not to change an object into a class or vice
22126  *    versa. Changing metaclass to metaclass, or class to class, or
22127  *    object to object is fine, but upgrading/downgrading is not
22128  *    allowed.
22129  *
22130  * Results:
22131  *    Tcl return code
22132  *
22133  * Side effects:
22134  *    Changes class of object if possible and updates instance relation.
22135  *
22136  *----------------------------------------------------------------------
22137  */
22138 NSF_INLINE static int ChangeClass(Tcl_Interp *interp, NsfObject *object, NsfClass *class)
22139   nonnull(1) nonnull(2) nonnull(3);
22140 
22141 NSF_INLINE static int
ChangeClass(Tcl_Interp * interp,NsfObject * object,NsfClass * class)22142 ChangeClass(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
22143 
22144   nonnull_assert(interp != NULL);
22145   nonnull_assert(object != NULL);
22146   nonnull_assert(class != NULL);
22147 
22148   NsfInstanceMethodEpochIncr("ChangeClass");
22149 
22150   /*fprintf(stderr, "changing %s to class %s ismeta %d\n",
22151           ObjectName(object), ClassName(class),
22152           IsMetaClass(interp, cl, NSF_TRUE));*/
22153 
22154   if (class != object->cl) {
22155     if (IsMetaClass(interp, class, NSF_TRUE)) {
22156       /*
22157        * Do not allow upgrading from a class to a metaclass (in other words,
22158        * don't make an object to a class). To allow this, it would be
22159        * necessary to reallocate the base structures.
22160        */
22161       if (!IsMetaClass(interp, object->cl, NSF_TRUE)) {
22162         return NsfPrintError(interp, "cannot turn object into a class");
22163       }
22164     } else {
22165       /*
22166        * The target class is not a metaclass.
22167        */
22168       /*fprintf(stderr, "target class %s not a metaclass, am i a class %d\n",
22169         ClassName(class), NsfObjectIsClass(object) );*/
22170 
22171       if (NsfObjectIsClass(object)) {
22172         return NsfPrintError(interp, "cannot turn class into an object ");
22173       }
22174     }
22175     RemoveInstance(object, object->cl);
22176     AddInstance(object, class);
22177 
22178     MixinComputeDefined(interp, object);
22179     FilterComputeDefined(interp, object);
22180   }
22181   return TCL_OK;
22182 }
22183 
22184 
22185 /*
22186  *----------------------------------------------------------------------
22187  * DoObjInitialization --
22188  *
22189  *    Perform the object initialization: first call "configure" and the
22190  *    constructor "init", if not called already from configure. The function
22191  *    will make sure that the called methods do not change the result passed
22192  *    into this function.
22193  *
22194  * Results:
22195  *    Tcl return code
22196  *
22197  * Side effects:
22198  *    Indirect effects by calling Tcl code
22199  *
22200  *----------------------------------------------------------------------
22201  */
22202 static int DoObjInitialization(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[])
22203   nonnull(1) nonnull(2) nonnull(4);
22204 
22205 static int
DoObjInitialization(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[])22206 DoObjInitialization(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[]) {
22207   Tcl_Obj *methodObj, *savedObjResult;
22208   int result;
22209 
22210   nonnull_assert(interp != NULL);
22211   nonnull_assert(object != NULL);
22212   nonnull_assert(objv != NULL);
22213   assert(objc >= 0);
22214 
22215 #if 0
22216   { int i;
22217     fprintf(stderr, "DoObjInitialization objc %d: ", objc);
22218     for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
22219     fprintf(stderr, "\n");
22220   }
22221 #endif
22222 
22223   /*
22224    * Save the result we have so far to return it in case of success
22225    */
22226   savedObjResult = Tcl_GetObjResult(interp);
22227   INCR_REF_COUNT(savedObjResult);
22228 
22229   /*
22230    * clear INIT_CALLED flag
22231    */
22232   object->flags &= ~NSF_INIT_CALLED;
22233   /*
22234    * Make sure, the object survives initialization; the cmd/initcmd might
22235    * destroy it.
22236    */
22237   NsfObjectRefCountIncr(object);
22238 
22239   /*
22240    * Call configure method
22241    */
22242   if (CallDirectly(interp, object, NSF_o_configure_idx, &methodObj)) {
22243     NSF_PROFILE_TIME_DATA;
22244     if (methodObj == NULL) {
22245       methodObj = NsfGlobalObjs[NSF_CONFIGURE];
22246     }
22247     assert(methodObj != NULL);
22248     /*
22249      * The methodObj is just used for error reporting.
22250      */
22251     NSF_PROFILE_CALL(interp, object, ObjStr(methodObj));
22252     result = NsfOConfigureMethod(interp, object, objc, objv, methodObj);
22253     NSF_PROFILE_EXIT(interp, object, ObjStr(methodObj));
22254   } else {
22255     result = CallMethod(object, interp, methodObj, objc+2, objv, NSF_CSC_IMMEDIATE);
22256   }
22257 
22258   if (likely(result == TCL_OK)) {
22259     /*
22260      * Call constructor when needed
22261      */
22262     if ((object->flags & (NSF_INIT_CALLED|NSF_DESTROY_CALLED)) == 0u) {
22263       result = DispatchInitMethod(interp, object, 0, NULL, 0u);
22264     }
22265 
22266     if (likely(result == TCL_OK)) {
22267       Tcl_SetObjResult(interp, savedObjResult);
22268     }
22269   } else {
22270     /*
22271      * Configure failed and might have left the object in a bogus state. To
22272      * avoid strange errors, we delete the half-baked object.
22273      */
22274     Tcl_Obj *errObj;
22275 
22276     /*
22277      *        Preserve the outer error message, calls triggered by
22278      *  DispatchDestroyMethod() can cause the interp result to be reset
22279      */
22280 
22281     errObj = Tcl_GetObjResult(interp);
22282     INCR_REF_COUNT(errObj);
22283 
22284     DispatchDestroyMethod(interp, (NsfObject *)object, 0u);
22285 
22286     Tcl_SetObjResult(interp, errObj);
22287     DECR_REF_COUNT(errObj);
22288   }
22289 
22290   NsfCleanupObject(object, "obj init");
22291   DECR_REF_COUNT(savedObjResult);
22292   return result;
22293 }
22294 
22295 /*
22296  *----------------------------------------------------------------------
22297  * IsRootMetaClass --
22298  *
22299  *    Check, of the class has the root metaclass flag set.
22300  *
22301  * Results:
22302  *    Boolean
22303  *
22304  * Side effects:
22305  *    None
22306  *
22307  *----------------------------------------------------------------------
22308  */
22309 static bool
IsRootMetaClass(const NsfClass * class)22310 IsRootMetaClass(const NsfClass *class) {
22311 
22312   nonnull_assert(class != NULL);
22313 
22314   return ((class->object.flags & NSF_IS_ROOT_META_CLASS) != 0u);
22315 }
22316 
22317 /*
22318  *----------------------------------------------------------------------
22319  * IsBaseClass --
22320  *
22321  *    Check, whether the object is a base class.
22322  *
22323  * Results:
22324  *    Boolean
22325  *
22326  * Side effects:
22327  *    none
22328  *
22329  *----------------------------------------------------------------------
22330  */
22331 static bool
IsBaseClass(const NsfObject * object)22332 IsBaseClass(const NsfObject *object) {
22333 
22334   nonnull_assert(object != NULL);
22335 
22336   return ((object->flags & (NSF_IS_ROOT_CLASS|NSF_IS_ROOT_META_CLASS)) != 0u);
22337 }
22338 
22339 /*
22340  *----------------------------------------------------------------------
22341  * IsRootClass --
22342  *
22343  *    Check, whether the object is a root-class.
22344  *
22345  * Results:
22346  *    Boolean
22347  *
22348  * Side effects:
22349  *    none
22350  *
22351  *----------------------------------------------------------------------
22352  */
22353 static bool
IsRootClass(const NsfClass * class)22354 IsRootClass(const NsfClass *class) {
22355 
22356   nonnull_assert(class != NULL);
22357 
22358   return ((class->object.flags & (NSF_IS_ROOT_CLASS)) != 0u);
22359 }
22360 
22361 
22362 /*
22363  *----------------------------------------------------------------------
22364  * IsMetaClass --
22365  *
22366  *    Check, whether the object is a metaclass. Optionally, mixins are
22367  *    checked as well.
22368  *
22369  * Results:
22370  *    Boolean
22371  *
22372  * Side effects:
22373  *    none
22374  *
22375  *----------------------------------------------------------------------
22376  */
22377 static bool
IsMetaClass(Tcl_Interp * interp,NsfClass * class,bool withMixins)22378 IsMetaClass(Tcl_Interp *interp, NsfClass *class, bool withMixins) {
22379   NsfClasses *pl;
22380   bool        result = NSF_FALSE;
22381 
22382   nonnull_assert(interp != NULL);
22383   nonnull_assert(class != NULL);
22384 
22385   /*
22386    * Is the class the most general metaclass?
22387    */
22388   if (IsRootMetaClass(class)) {
22389     return NSF_TRUE;
22390   }
22391 
22392   /*
22393    * Is the class a subclass of a metaclass?
22394    */
22395   for (pl = PrecedenceOrder(class); pl != NULL; pl = pl->nextPtr) {
22396     if (IsRootMetaClass(pl->cl)) {
22397       return NSF_TRUE;
22398     }
22399   }
22400 
22401   if (withMixins) {
22402     NsfClasses *checkList = NULL, *mixinClasses = NULL, *mc;
22403 
22404     /*
22405      * Has the class metaclass mixed in?
22406      */
22407     NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
22408 
22409     for (mc = mixinClasses; mc != NULL; mc = mc->nextPtr) {
22410       if (IsMetaClass(interp, mc->cl, NSF_FALSE)) {
22411         result = NSF_TRUE;
22412         break;
22413       }
22414     }
22415     if (mixinClasses != NULL) {
22416       NsfClassListFree(mixinClasses);
22417     }
22418     if (checkList != NULL) {
22419       NsfClassListFree(checkList);
22420     }
22421     /*fprintf(stderr, "has MC returns %d, mixinClasses = %p\n",
22422       result, mixinClasses);*/
22423   }
22424   return result;
22425 }
22426 
22427 /*
22428  *----------------------------------------------------------------------
22429  * IsSubType --
22430  *
22431  *    Check, whether a class is a subclass of another class
22432  *
22433  * Results:
22434  *    Boolean
22435  *
22436  * Side effects:
22437  *    none
22438  *
22439  *----------------------------------------------------------------------
22440  */
22441 static bool
IsSubType(NsfClass * subClass,const NsfClass * class)22442 IsSubType(NsfClass *subClass, const NsfClass *class) {
22443   bool result;
22444 
22445   nonnull_assert(subClass != NULL);
22446   nonnull_assert(class != NULL);
22447 
22448   if (class != subClass) {
22449     result = (NsfClassListFind(PrecedenceOrder(subClass), class) != NULL);
22450   } else {
22451     result = NSF_TRUE;
22452   }
22453   return result;
22454 }
22455 
22456 /*
22457  *----------------------------------------------------------------------
22458  * HasMixin --
22459  *
22460  *    Check, whether the specified object the specified class as mixin.
22461  *
22462  * Results:
22463  *    Boolean
22464  *
22465  * Side effects:
22466  *    none
22467  *
22468  *----------------------------------------------------------------------
22469  */
22470 static bool HasMixin(Tcl_Interp *interp, NsfObject *object, NsfClass *class)
22471   nonnull(1) nonnull(2) nonnull(3);
22472 
22473 static bool
HasMixin(Tcl_Interp * interp,NsfObject * object,NsfClass * class)22474 HasMixin(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
22475 
22476   nonnull_assert(interp != NULL);
22477   nonnull_assert(object != NULL);
22478   nonnull_assert(class != NULL);
22479 
22480   if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
22481     MixinComputeDefined(interp, object);
22482   }
22483   if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
22484     NsfCmdList *ml;
22485 
22486     for (ml = object->mixinOrder; ml != NULL; ml = ml->nextPtr) {
22487       NsfClass *mixinClass = NsfGetClassFromCmdPtr(ml->cmdPtr);
22488 
22489       if (mixinClass == class) {
22490         return NSF_TRUE;
22491       }
22492     }
22493   }
22494   return NSF_FALSE;
22495 }
22496 
22497 /*
22498  *----------------------------------------------------------------------
22499  * ImportInstVarIntoCurrentScope --
22500  *
22501  *    Import an instance variable into the current variable scope
22502  *    (e.g. function scope).
22503  *
22504  * Results:
22505  *    Standard Tcl result
22506  *
22507  * Side effects:
22508  *    none
22509  *
22510  *----------------------------------------------------------------------
22511  */
22512 static int ImportInstVarIntoCurrentScope(Tcl_Interp *interp, const char *cmdName, NsfObject *object,
22513                                          Tcl_Obj *varName, Tcl_Obj *newName)
22514   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
22515 
22516 static int
ImportInstVarIntoCurrentScope(Tcl_Interp * interp,const char * cmdName,NsfObject * object,Tcl_Obj * varName,Tcl_Obj * newName)22517 ImportInstVarIntoCurrentScope(Tcl_Interp *interp, const char *cmdName, NsfObject *object,
22518                               Tcl_Obj *varName, Tcl_Obj *newName) {
22519   Var           *otherPtr = NULL, *arrayPtr;
22520   unsigned int   flogs = TCL_LEAVE_ERR_MSG;
22521   Tcl_CallFrame *varFramePtr;
22522   CallFrame      frame, *framePtr = &frame;
22523   const char    *varNameString;
22524 
22525   nonnull_assert(interp != NULL);
22526   nonnull_assert(cmdName != NULL);
22527   nonnull_assert(object != NULL);
22528   nonnull_assert(varName != NULL);
22529 
22530   if (unlikely(CheckVarName(interp, ObjStr(varName)) != TCL_OK)) {
22531     return TCL_ERROR;
22532   }
22533 
22534   Nsf_PushFrameObj(interp, object, framePtr);
22535   if (object->nsPtr != NULL) {
22536     flogs = flogs|TCL_NAMESPACE_ONLY;
22537   }
22538 
22539   otherPtr = TclObjLookupVar(interp, varName, NULL, (int)flogs, "define",
22540                              /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
22541   Nsf_PopFrameObj(interp, framePtr);
22542 
22543   if (unlikely(otherPtr == NULL)) {
22544     return NsfPrintError(interp, "can't import variable %s into method scope: "
22545                          "can't find variable on %s",
22546                          ObjStr(varName), ObjectName_(object));
22547   }
22548 
22549   /*
22550    * if newName == NULL -> there is no alias, use varName
22551    * as target link name
22552    */
22553   if (newName == NULL) {
22554     /*
22555      * Variable link into namespace cannot be an element in an array.
22556      * see Tcl_VariableObjCmd ...
22557      */
22558     if (arrayPtr != NULL) {
22559       return NsfPrintError(interp, "can't make instance variable %s on %s: "
22560                            "Variable cannot be an element in an array; use e.g. an alias.",
22561                            ObjStr(varName), ObjectName_(object));
22562     }
22563 
22564     newName = varName;
22565   }
22566   varNameString = ObjStr(newName);
22567   varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
22568 
22569   /*
22570    * If we are executing inside a Tcl procedure, create a local
22571    * variable linked to the new namespace variable "varName".
22572    */
22573   if (varFramePtr != NULL && (Tcl_CallFrame_isProcCallFrame(varFramePtr) & FRAME_IS_PROC)) {
22574     Var *varPtr = (Var *)CompiledLocalsLookup((CallFrame *)varFramePtr, varNameString);
22575     int new = 0;
22576 
22577     if (varPtr == NULL) {
22578       /*
22579        * Look in frame's local var hash-table.
22580        */
22581       TclVarHashTable *varTablePtr = Tcl_CallFrame_varTablePtr(varFramePtr);
22582 
22583       if (varTablePtr == NULL) {
22584         /*
22585          * The variable table does not exist. This seems to be is the
22586          * first access to a variable on this frame. We create the and
22587          * initialize the variable hash-table and update the object
22588          */
22589         /*fprintf(stderr, "+++ create varTable in ImportInstVarIntoCurrentScope\n");*/
22590         Tcl_CallFrame_varTablePtr(varFramePtr) = varTablePtr = VarHashTableCreate();
22591       }
22592       varPtr = VarHashCreateVar(varTablePtr, newName, &new);
22593     }
22594 
22595     /*
22596      * If we define an alias (newName != varName), be sure that
22597      * the target does not exist already.
22598      */
22599     if (new == 0) {
22600       /*fprintf(stderr, "GetIntoScope create alias\n");*/
22601       if (unlikely(varPtr == otherPtr)) {
22602         return NsfPrintError(interp, "can't instvar to variable itself");
22603       }
22604       if (TclIsVarLink(varPtr)) {
22605         /*
22606          * We try to make the same instvar again ... this is ok
22607          */
22608         Var *linkPtr = TclVarValue(Var, varPtr, linkPtr);
22609         if (linkPtr == otherPtr) {
22610           return TCL_OK;
22611         }
22612 
22613         /*fprintf(stderr, "linkvar flags=%x\n", linkPtr->flags);
22614           Tcl_Panic("new linkvar %s... When does this happen?", ObjStr(newName), NULL);*/
22615 
22616         /*
22617          * We have already a variable with the same name imported
22618          * from a different object. Get rid of this old variable.
22619          */
22620         VarHashRefCount(linkPtr)--;
22621         if (TclIsVarUndefined(linkPtr)) {
22622           TclCleanupVar(linkPtr, (Var *) NULL);
22623         }
22624 
22625       } else if (unlikely(TclIsVarUndefined(varPtr) == 0)) {
22626         return NsfPrintError(interp, "varName '%s' exists already", varNameString);
22627       } else if (unlikely(TclIsVarTraced(varPtr) != 0)) {
22628         return NsfPrintError(interp, "varName '%s' has traces: can't use for instvar", varNameString);
22629       }
22630     }
22631 
22632     TclSetVarLink(varPtr);
22633     TclClearVarUndefined(varPtr);
22634     varPtr->value.linkPtr = otherPtr;
22635     VarHashRefCount(otherPtr)++;
22636 
22637     /* fprintf(stderr, "defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n",
22638             ObjStr(newName), ObjectName(object),
22639             0,
22640             varPtr->flags,
22641             TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr));
22642     */
22643   } else {
22644     return NsfPrintError(interp, "%s cannot import variable '%s' into method scope; "
22645                          "not called from a method frame", cmdName, varNameString);
22646   }
22647   return TCL_OK;
22648 }
22649 
22650 
22651 
22652 /*
22653  *----------------------------------------------------------------------
22654  * SetInstVar --
22655  *
22656  *    Set an instance variable of the specified object to the given value.
22657  *
22658  * Results:
22659  *    Tcl result code.
22660  *
22661  * Side effects:
22662  *    Set instance variable.
22663  *
22664  *----------------------------------------------------------------------
22665  */
22666 static int
SetInstVar(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * nameObj,Tcl_Obj * valueObj,unsigned int flags)22667 SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj, unsigned int flags) {
22668   CallFrame frame, *framePtr = &frame;
22669   Tcl_Obj *resultObj;
22670 
22671   nonnull_assert(interp != NULL);
22672   nonnull_assert(object != NULL);
22673   nonnull_assert(nameObj != NULL);
22674 
22675   Nsf_PushFrameObj(interp, object, framePtr);
22676 
22677   if ((flags & NSF_VAR_TRIGGER_TRACE) != 0u) {
22678     int tclVarFlags;
22679     /*
22680      * The command should trigger traces, use therefore the high-level Tcl_Obj*
22681      * interface.
22682      */
22683 
22684     tclVarFlags = (object->nsPtr != NULL) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG;
22685     if (likely(valueObj == NULL)) {
22686       resultObj = Tcl_ObjGetVar2(interp, nameObj, NULL, tclVarFlags);
22687     } else {
22688       resultObj = Tcl_ObjSetVar2(interp, nameObj, NULL, valueObj, tclVarFlags);
22689     }
22690   } else {
22691     /*
22692      * The command should not trigger traces, use the low-level TclLookupVar()
22693      * interface.
22694      */
22695     Var *arrayPtr, *varPtr;
22696 
22697     if (likely(valueObj == NULL)) {
22698 
22699       varPtr = TclLookupVar(interp, ObjStr(nameObj), NULL, TCL_LEAVE_ERR_MSG, "access",
22700                             /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
22701       if (likely(varPtr != NULL)) {
22702         resultObj = varPtr->value.objPtr;
22703       } else {
22704         resultObj = NULL;
22705       }
22706 
22707     } else {
22708       Tcl_Obj *oldValuePtr;
22709 
22710       varPtr = TclLookupVar(interp, ObjStr(nameObj), NULL, TCL_LEAVE_ERR_MSG, "access",
22711                             /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
22712       oldValuePtr = varPtr->value.objPtr;
22713       INCR_REF_COUNT2("SetInstVar", valueObj);
22714       varPtr->value.objPtr = valueObj;
22715       if (oldValuePtr != NULL) {
22716         DECR_REF_COUNT2("SetInstVar", oldValuePtr);
22717       }
22718       resultObj = valueObj;
22719     }
22720   }
22721   Nsf_PopFrameObj(interp, framePtr);
22722 
22723   if (likely(resultObj != NULL)) {
22724     Tcl_SetObjResult(interp, resultObj);
22725     return TCL_OK;
22726   }
22727 
22728   return TCL_ERROR;
22729 }
22730 
22731 /*
22732  *----------------------------------------------------------------------
22733  * SetInstArray --
22734  *
22735  *    Set an instance variable array of the specified object to the given
22736  *    value. This function performs essentially an "array set" or "array get"
22737  *    operation.
22738  *
22739  * Results:
22740  *    Tcl result code.
22741  *
22742  * Side effects:
22743  *    Set instance variable.
22744  *
22745  *----------------------------------------------------------------------
22746  */
22747 static int SetInstArray(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arrayNameObj, Tcl_Obj *valueObj)
22748   nonnull(1) nonnull(2) nonnull(3);
22749 
22750 static int
SetInstArray(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * arrayNameObj,Tcl_Obj * valueObj)22751 SetInstArray(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *arrayNameObj, Tcl_Obj *valueObj) {
22752   CallFrame frame, *framePtr = &frame;
22753   int result;
22754   Tcl_Obj *ov[4];
22755 
22756   nonnull_assert(interp != NULL);
22757   nonnull_assert(object != NULL);
22758   nonnull_assert(arrayNameObj != NULL);
22759 
22760   Nsf_PushFrameObj(interp, object, framePtr);
22761 
22762   ov[0] = NsfGlobalObjs[NSF_ARRAY];
22763   ov[2] = arrayNameObj;
22764 
22765   INCR_REF_COUNT(arrayNameObj);
22766   if (valueObj == NULL) {
22767     /*
22768      * Perform an "array get"
22769      */
22770     ov[1] = NsfGlobalObjs[NSF_GET];
22771     result = Tcl_EvalObjv(interp, 3, ov, 0);
22772   } else {
22773     /*
22774      * Perform an "array set"
22775      */
22776     ov[1] = NsfGlobalObjs[NSF_SET];
22777     ov[3] = valueObj;
22778     INCR_REF_COUNT(valueObj);
22779     result = Tcl_EvalObjv(interp, 4, ov, 0);
22780     DECR_REF_COUNT(valueObj);
22781   }
22782   DECR_REF_COUNT(arrayNameObj);
22783   Nsf_PopFrameObj(interp, framePtr);
22784 
22785   return result;
22786 }
22787 
22788 
22789 /*
22790  *----------------------------------------------------------------------
22791  * UnsetInstVar --
22792  *
22793  *    Unset an instance variable of the specified object.
22794  *
22795  * Results:
22796  *    Tcl result code.
22797  *
22798  * Side effects:
22799  *    Variable unset.
22800  *
22801  *----------------------------------------------------------------------
22802  */
22803 
22804 static int
UnsetInstVar(Tcl_Interp * interp,int withNocomplain,NsfObject * object,const char * name)22805 UnsetInstVar(Tcl_Interp *interp, int withNocomplain, NsfObject *object, const char *name) {
22806   CallFrame frame, *framePtr = &frame;
22807   unsigned int flags;
22808   int result;
22809 
22810   nonnull_assert(interp != NULL);
22811   nonnull_assert(object != NULL);
22812   nonnull_assert(name != NULL);
22813 
22814   flags = (withNocomplain != 0) ? 0 : TCL_LEAVE_ERR_MSG;
22815   if (object->nsPtr != NULL) {
22816     flags |= TCL_NAMESPACE_ONLY;
22817   }
22818 
22819   Nsf_PushFrameObj(interp, object, framePtr);
22820   result = Tcl_UnsetVar2(interp, name, NULL, (int)flags);
22821   Nsf_PopFrameObj(interp, framePtr);
22822 
22823   return (withNocomplain != 0) ? TCL_OK : result;
22824 }
22825 
22826 /*
22827  *----------------------------------------------------------------------
22828  * NsfSetterMethod --
22829  *
22830  *    This Tcl_ObjCmdProc is called, when a setter method is invoked. A setter
22831  *    is a method that accesses/modifies a same-named instance variable. If
22832  *    the setter is called without arguments, it returns the values, if it is
22833  *    called with one argument, the argument is used as new value.
22834  *
22835  * Results:
22836  *    Tcl result code.
22837  *
22838  * Side effects:
22839  *    Can set an instance variable.
22840  *
22841  *----------------------------------------------------------------------
22842  */
22843 static int NsfSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
22844   nonnull(1) nonnull(2) nonnull(4);
22845 
22846 static int
NsfSetterMethod(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])22847 NsfSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
22848   SetterCmdClientData *cd;
22849   NsfObject           *object;
22850   int                  result;
22851 
22852   nonnull_assert(clientData != NULL);
22853   nonnull_assert(interp != NULL);
22854   nonnull_assert(objv != NULL);
22855 
22856   cd = (SetterCmdClientData *)clientData;
22857   object = cd->object;
22858 
22859   if (objc > 2) {
22860     Tcl_Obj *pathObj = NsfMethodNamePath(interp,
22861                                          CallStackGetTclFrame(interp, NULL, 1),
22862                                          NsfMethodName(objv[0]));
22863     INCR_REF_COUNT(pathObj);
22864     result = NsfObjWrongArgs(interp, "wrong # args", object->cmdName,
22865                              pathObj, "?value?");
22866     DECR_REF_COUNT(pathObj);
22867   } else if (object == NULL) {
22868     result = NsfDispatchClientDataError(interp, clientData, "object", ObjStr(objv[0]));
22869 
22870   } else {
22871     Tcl_Obj    *nameObj;
22872     const char *nameString = ObjStr(objv[0]);
22873 
22874     /*
22875      * When the setter method is called with a leading colon, pass plain
22876      * object to SetInstVar(), otherwise we might run into shimmering with
22877      * tclCmds.
22878      */
22879     if (FOR_COLON_RESOLVER(nameString)) {
22880       nameString ++;
22881       nameObj = Tcl_NewStringObj(nameString, -1);
22882       INCR_REF_COUNT(nameObj);
22883     } else {
22884       nameObj = objv[0];
22885     }
22886 
22887     if (cd->paramsPtr != NULL && objc == 2) {
22888       Tcl_Obj   *outObjPtr;
22889       unsigned   flags = 0u;
22890       ClientData checkedData;
22891 
22892       result = ArgumentCheck(interp, objv[1], cd->paramsPtr,
22893                              RUNTIME_STATE(interp)->doCheckArguments,
22894                              &flags, &checkedData, &outObjPtr);
22895 
22896       if (likely(result == TCL_OK)) {
22897         result = SetInstVar(interp, object, nameObj, outObjPtr, NSF_VAR_TRIGGER_TRACE);
22898       }
22899 
22900       if ((flags & NSF_PC_MUST_DECR) != 0u) {
22901         DECR_REF_COUNT2("valueObj", outObjPtr);
22902       }
22903     } else {
22904       result = SetInstVar(interp, object, nameObj, objc == 2 ? objv[1] : NULL, NSF_VAR_TRIGGER_TRACE);
22905     }
22906     if (nameObj != objv[0]) {
22907       DECR_REF_COUNT(nameObj);
22908     }
22909   }
22910   return result;
22911 }
22912 
22913 
22914 /*
22915  *----------------------------------------------------------------------
22916  * NsfForwardPrintError --
22917  *
22918  *    Helper function to print either an error message directly to call the
22919  *    forwarder specific callback method specified in
22920  *    tcd->onerror. Background: ForwardArg() is called at runtime to
22921  *    substitute the argument list. Catching such errors is not conveniently
22922  *    doable via catch, since it would be necessary to wrap every possible
22923  *    usage of a forwarder in a catch. Therefore, the callback function can be
22924  *    used to give a sensible error message appropriate for each context.
22925  *
22926  * Results:
22927  *    Tcl result code.
22928  *
22929  * Side effects:
22930  *    Potential side effects through the script.
22931  *
22932  *----------------------------------------------------------------------
22933  */
22934 static int
22935 NsfForwardPrintError(Tcl_Interp *interp, ForwardCmdClientData *tcd,
22936                      int objc, Tcl_Obj *const objv[],
22937                      const char *fmt, ...)
22938   nonnull(1) nonnull(2) nonnull(5) NSF_attribute_format((printf,5,6));
22939 
22940 static int
NsfForwardPrintError(Tcl_Interp * interp,ForwardCmdClientData * tcd,int objc,Tcl_Obj * const objv[],const char * fmt,...)22941 NsfForwardPrintError(Tcl_Interp *interp, ForwardCmdClientData *tcd,
22942                      int objc, Tcl_Obj *const objv[],
22943                      const char *fmt, ...) {
22944   Tcl_DString ds;
22945   va_list ap;
22946   int result;
22947 
22948   nonnull_assert(interp != NULL);
22949   nonnull_assert(tcd != NULL);
22950   nonnull_assert(fmt != NULL);
22951 
22952   Tcl_DStringInit(&ds);
22953 
22954   va_start(ap, fmt);
22955   NsfDStringVPrintf(&ds, fmt, ap);
22956   va_end(ap);
22957 
22958   if (tcd->onerror != NULL) {
22959     Tcl_Obj *script = Tcl_DuplicateObj(tcd->onerror);
22960     Tcl_Obj *cmd;
22961 
22962     if (tcd->object != NULL) {
22963       cmd = Tcl_DuplicateObj(tcd->object->cmdName);
22964       if (objc > 0) {
22965         Tcl_Obj *methodObjPath = NsfMethodNamePath(interp,
22966                                                    CallStackGetTclFrame(interp, NULL, 1),
22967                                                    MethodName(objv[0]));
22968         INCR_REF_COUNT(methodObjPath);
22969         Tcl_ListObjAppendList(interp, cmd, methodObjPath);
22970         DECR_REF_COUNT(methodObjPath);
22971 
22972         if (objc > 1) {
22973           Tcl_ListObjAppendElement(interp, cmd,  Tcl_NewListObj(objc-1, objv+1));
22974         }
22975       }
22976     } else {
22977       cmd = Tcl_NewListObj(objc, objv);
22978     }
22979 
22980     Tcl_ListObjAppendElement(interp, script,  cmd);
22981     Tcl_ListObjAppendElement(interp, script,
22982                              Tcl_NewStringObj(Tcl_DStringValue(&ds),
22983                                               Tcl_DStringLength(&ds)));
22984     INCR_REF_COUNT(script);
22985     result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT);
22986     DECR_REF_COUNT(script);
22987   } else {
22988     result = NsfPrintError(interp, "%s", Tcl_DStringValue(&ds));
22989   }
22990 
22991   Tcl_DStringFree(&ds);
22992   return result;
22993 }
22994 
22995 /*
22996  *----------------------------------------------------------------------
22997  * ForwardArg --
22998  *
22999  *    This function is a helper function of NsfForwardMethod() and processes a
23000  *    single entry (ForwardArgObj) of the forward spec. Essentially, it
23001  *    performs the percent substitution of the forward spec.
23002  *
23003  * Results:
23004  *    Tcl result code.
23005  *
23006  * Side effects:
23007  *    Updates the provided output arguments.
23008  *
23009  *----------------------------------------------------------------------
23010  */
23011 static int ForwardArg(
23012     Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
23013     Tcl_Obj *forwardArgObj, ForwardCmdClientData *tcd, Tcl_Obj **out,
23014     Tcl_Obj **freeListObjPtr, int *inputArg, long *mapvalue,
23015     int firstPosArg, int *outputincr
23016 ) nonnull(1) nonnull(3) nonnull(4) nonnull(5) nonnull(6) nonnull(7) nonnull(8) nonnull(9) nonnull(11);
23017 
23018 static int
ForwardArg(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],Tcl_Obj * forwardArgObj,ForwardCmdClientData * tcd,Tcl_Obj ** out,Tcl_Obj ** freeListObjPtr,int * inputArg,long * mapvalue,int firstPosArg,int * outputincr)23019 ForwardArg(
23020     Tcl_Interp *interp,
23021     int objc, Tcl_Obj *const objv[],
23022     Tcl_Obj *forwardArgObj,
23023     ForwardCmdClientData *tcd,
23024     Tcl_Obj **out,
23025     Tcl_Obj **freeListObjPtr,
23026     int *inputArg,
23027     long *mapvalue,
23028     int firstPosArg,
23029     int *outputincr
23030 ) {
23031   const char *ForwardArgString, *p;
23032   int         totalargs, result = TCL_OK;
23033   char        c;
23034 
23035   nonnull_assert(interp != NULL);
23036   nonnull_assert(objv != NULL);
23037   nonnull_assert(forwardArgObj != NULL);
23038   nonnull_assert(tcd != NULL);
23039   nonnull_assert(out != NULL);
23040   nonnull_assert(freeListObjPtr != NULL);
23041   nonnull_assert(inputArg != NULL);
23042   nonnull_assert(mapvalue != NULL);
23043   nonnull_assert(outputincr != NULL);
23044 
23045   assert(objc >= 1);
23046 
23047   totalargs = objc + tcd->nr_args - 1;
23048   /*
23049    * Per default every ForwardArgString from the processed list corresponds to
23050    * exactly one ForwardArgString in the computed final list.
23051    */
23052   *outputincr = 1;
23053   ForwardArgString = ObjStr(forwardArgObj);
23054   p = ForwardArgString;
23055 
23056   /* fprintf(stderr, "ForwardArg: processing '%s'\n", ForwardArgString);*/
23057 
23058   c = *ForwardArgString;
23059   if (c == '%' && *(ForwardArgString+1) == '@') {
23060     char *remainder = NULL;
23061     long  pos;
23062 
23063     ForwardArgString += 2;
23064     pos = strtol(ForwardArgString, &remainder, 0);
23065     if (ForwardArgString == remainder && *ForwardArgString == 'e'
23066         && !strncmp(ForwardArgString, "end", 3)) {
23067       pos = -1;
23068       remainder += 3;
23069     } else if (pos < 0) {
23070       pos --;
23071     }
23072     if (ForwardArgString == remainder || labs(pos) > totalargs) {
23073       return NsfForwardPrintError(interp, tcd, objc, objv,
23074                                   "forward: invalid index specified in argument %s",
23075                                   ObjStr(forwardArgObj));
23076     }
23077     if (!remainder || *remainder != ' ') {
23078       return NsfForwardPrintError(interp, tcd, objc, objv,
23079                                   "forward: invalid syntax in '%s'; use: %%@<pos> <cmd>",
23080                                   ObjStr(forwardArgObj));
23081     }
23082 
23083     ForwardArgString = remainder + 1;
23084     /*
23085      * In case we address from the end, we reduce further to distinguish from
23086      * -1 (void)
23087      */
23088     if (pos < 0) {
23089       pos--;
23090     }
23091     /*fprintf(stderr, "remainder = '%s' pos = %ld\n", remainder, pos);*/
23092     *mapvalue = pos;
23093     c = *ForwardArgString;
23094   }
23095 
23096   if (c == '%') {
23097     Tcl_Obj    *listObj = NULL, **listElements = NULL;
23098     int         nrArgs = objc-1, nrPosArgs = objc - firstPosArg, nrElements = 0;
23099     char        c1, *firstActualArgument = nrArgs > 0 ? ObjStr(objv[1]) : NULL;
23100     const char *c1Ptr;
23101 
23102     assert(nrPosArgs >= 0);
23103     assert(nrArgs >= 0);
23104 
23105     c = *++ForwardArgString;
23106     c1Ptr = ForwardArgString + 1;
23107     c1 = *c1Ptr;
23108 
23109     if (c == 's' && !strcmp(ForwardArgString, "self")) {
23110       *out = tcd->object->cmdName;
23111     } else if ((c == 'p' && !strcmp(ForwardArgString, "proc"))
23112                || (c == 'm' && !strcmp(ForwardArgString, "method"))
23113                ) {
23114       const char *methodName = ObjStr(objv[0]);
23115 
23116       /*
23117        * If we dispatch a method via ".", we do not want to see the "." in the
23118        * %proc, e.g. for the interceptor slots (such as mixin, ...)
23119        */
23120       if (FOR_COLON_RESOLVER(methodName)) {
23121         *out = Tcl_NewStringObj(methodName + 1, -1);
23122       } else {
23123         *out = objv[0];
23124       }
23125       AddObjToTclList(interp, freeListObjPtr, *out);
23126     } else if (c == '1' && (c1 == '\0' || NsfHasTclSpace(c1Ptr))) {
23127 
23128       if (c1 != '\0') {
23129         if (unlikely(Tcl_ListObjIndex(interp, forwardArgObj, 1, &listObj) != TCL_OK)) {
23130           return NsfForwardPrintError(interp, tcd, objc, objv,
23131                                       "forward: %%1 must be followed by a valid list, given: '%s'",
23132                                       ObjStr(forwardArgObj));
23133         }
23134         if (unlikely(Tcl_ListObjGetElements(interp, listObj, &nrElements, &listElements) != TCL_OK)) {
23135           return NsfForwardPrintError(interp, tcd, objc, objv,
23136                                       "forward: %%1 contains invalid list '%s'",
23137                                       ObjStr(listObj));
23138         }
23139       } else if (unlikely(tcd->subcommands != NULL)) {
23140         /*
23141          * This is a deprecated part, kept for backwards compatibility.
23142          */
23143         if (Tcl_ListObjGetElements(interp, tcd->subcommands, &nrElements, &listElements) != TCL_OK) {
23144           return NsfForwardPrintError(interp, tcd, objc, objv,
23145                                       "forward: %%1 contains invalid list '%s'",
23146                                       ObjStr(tcd->subcommands));
23147         }
23148       } else {
23149         assert(nrElements <= nrPosArgs);
23150       }
23151       /*fprintf(stderr, "nrElements=%d, nra=%d firstPos %d objc %d\n",
23152         nrElements, nrArgs, firstPosArg, objc);*/
23153 
23154       if (nrElements > nrPosArgs) {
23155         /*
23156          * Insert default subcommand depending on number of arguments.
23157          */
23158         assert(listElements != NULL);
23159         /*fprintf(stderr, "inserting listElements[%d] '%s'\n", nrPosArgs,
23160           ObjStr(listElements[nrPosArgs]));*/
23161         *out = listElements[nrPosArgs];
23162       } else if (objc <= 1) {
23163 
23164         result = NsfForwardPrintError(interp, tcd, objc, objv,
23165                                       "%%1 requires argument; should be \"%s arg ...\"",
23166                                       ObjStr(objv[0]));
23167       } else {
23168         /*fprintf(stderr, "copying %%1: '%s'\n", ObjStr(objv[firstPosArg]));*/
23169         *out = objv[firstPosArg];
23170         *inputArg = firstPosArg+1;
23171       }
23172     } else if (c == '-') {
23173       const char *firstElementString;
23174       int         insertRequired;
23175       bool        done = NSF_FALSE;
23176 
23177       /*fprintf(stderr, "process flag '%s'\n", firstActualArgument);*/
23178       if (Tcl_ListObjGetElements(interp, forwardArgObj, &nrElements, &listElements) != TCL_OK) {
23179         return NsfForwardPrintError(interp, tcd, objc, objv,
23180                                     "forward: '%s' is not a valid list",
23181                                     ForwardArgString);
23182       }
23183       if (nrElements < 1 || nrElements > 2) {
23184         return NsfForwardPrintError(interp, tcd, objc, objv,
23185                                     "forward: '%s': must contain 1 or 2 arguments",
23186                                     ForwardArgString);
23187       }
23188       firstElementString = ObjStr(listElements[0]);
23189       firstElementString++; /* we skip the dash */
23190 
23191       if (firstActualArgument && *firstActualArgument == '-') {
23192         int i;
23193 
23194         /*fprintf(stderr, "we have a flag in first argument '%s'\n", firstActualArgument);*/
23195         for (i = 1; i < firstPosArg; i++) {
23196           if (strcmp(firstElementString, ObjStr(objv[i])) == 0) {
23197             /*fprintf(stderr, "We have a MATCH for '%s' oldInputArg %d\n", ForwardArgString, *inputArg);*/
23198             *out = objv[i];
23199             /* %1 will start at a different place. Proceed if necessary to firstPosArg */
23200             if (*inputArg < firstPosArg) {
23201               *inputArg = firstPosArg;
23202             }
23203             done = NSF_TRUE;
23204             break;
23205           }
23206         }
23207       }
23208 
23209       if (! done) {
23210         /*
23211          * We have a flag in the actual arguments that does not match.  We
23212          * proceed to the actual arguments without dashes.
23213          */
23214         if (*inputArg < firstPosArg) {
23215           *inputArg = firstPosArg;
23216         }
23217         /*
23218          * If the user requested we output the argument also when not
23219          * given in the argument list.
23220          */
23221         if (nrElements == 2
23222             && Tcl_GetIntFromObj(interp, listElements[1], &insertRequired) == TCL_OK
23223             && insertRequired) {
23224           /*
23225            * No match, but insert of flag is required.
23226            */
23227           /*fprintf(stderr, "no match, but insert of %s required\n", firstElementString);*/
23228           *out = Tcl_NewStringObj(firstElementString, -1);
23229           *outputincr = 1;
23230 
23231           AddObjToTclList(interp, freeListObjPtr, *out);
23232         } else {
23233           /*
23234            * No match, no insert of flag required, we skip the forwarder
23235            * option and output nothing.
23236            */
23237           /*fprintf(stderr, "no match, nrElements %d insert req %d\n", nrElements, insertRequired);*/
23238           *outputincr = 0;
23239         }
23240       }
23241 
23242     } else if (c == 'a' && !strncmp(ForwardArgString, "argcl", 4)) {
23243 
23244       if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &listObj) != TCL_OK) {
23245         result = NsfForwardPrintError(interp, tcd, objc, objv,
23246                                       "forward: %%argclindex must by a valid list, given: '%s'",
23247                                       ForwardArgString);
23248 
23249       } else if (Tcl_ListObjGetElements(interp, listObj, &nrElements, &listElements) != TCL_OK) {
23250         result = NsfForwardPrintError(interp, tcd, objc, objv,
23251                                       "forward: %%argclindex contains invalid list '%s'",
23252                                       ObjStr(listObj));
23253 
23254       } else if (nrArgs >= nrElements) {
23255         result = NsfForwardPrintError(interp, tcd, objc, objv,
23256                                       "forward: not enough elements in specified list of ARGC argument %s",
23257                                       ForwardArgString);
23258       } else {
23259         *out = listElements[nrArgs];
23260       }
23261     } else if (c == '%') {
23262       Tcl_Obj *newarg = Tcl_NewStringObj(ForwardArgString, -1);
23263 
23264       *out = newarg;
23265       AddObjToTclList(interp, freeListObjPtr, *out);
23266 
23267     } else {
23268       /*
23269        * Evaluate the given command.
23270        */
23271       /*fprintf(stderr, "evaluating '%s'\n", ForwardArgString);*/
23272       result = Tcl_EvalEx(interp, ForwardArgString, -1, 0);
23273       if (likely(result == TCL_OK)) {
23274         *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
23275         AddObjToTclList(interp, freeListObjPtr, *out);
23276         /*fprintf(stderr, "result = '%s'\n", ObjStr(*out));*/
23277       }
23278     }
23279   } else {
23280     if (likely(p == ForwardArgString)) {
23281       *out = forwardArgObj;
23282     } else {
23283       Tcl_Obj *newarg = Tcl_NewStringObj(ForwardArgString, -1);
23284 
23285       *out = newarg;
23286       AddObjToTclList(interp, freeListObjPtr, *out);
23287     }
23288   }
23289   return result;
23290 }
23291 
23292 /*
23293  *----------------------------------------------------------------------
23294  * CallForwarder --
23295  *
23296  *    Invoke the method to which the forwarder points. This function receives
23297  *    the already transformed argument vector, calls the method and performs
23298  *    error handling.
23299  *
23300  * Results:
23301  *    Tcl result code.
23302  *
23303  * Side effects:
23304  *    Maybe through the invoked command.
23305  *
23306  *----------------------------------------------------------------------
23307  */
23308 
23309 static int CallForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
23310   nonnull(1) nonnull(2) nonnull(4);
23311 
23312 static int
CallForwarder(ForwardCmdClientData * tcd,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])23313 CallForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
23314   int        result;
23315   NsfObject *object;
23316   CallFrame  frame, *framePtr = &frame;
23317 
23318   nonnull_assert(tcd != NULL);
23319   nonnull_assert(interp != NULL);
23320   nonnull_assert(objv != NULL);
23321 
23322   object = tcd->object;
23323   tcd->object = NULL;
23324 
23325   if (unlikely(tcd->verbose)) {
23326     Tcl_Obj *cmd = Tcl_NewListObj(objc, objv);
23327 
23328     NsfLog(interp, NSF_LOG_DEBUG, "forwarder calls '%s'",  ObjStr(cmd));
23329     DECR_REF_COUNT(cmd);
23330   }
23331   if (tcd->frame == FrameObjectIdx) {
23332     Nsf_PushFrameObj(interp, object, framePtr);
23333   }
23334   if (tcd->objProc != NULL) {
23335     /*fprintf(stderr, "CallForwarder Tcl_NRCallObjProc %p\n", tcd->clientData);*/
23336     result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv);
23337   } else if (TclObjIsNsfObject(interp, tcd->cmdName, &object)) {
23338     /*fprintf(stderr, "CallForwarder NsfObjDispatch object %s, objc=%d\n",
23339       ObjStr(tcd->cmdName), objc);*/
23340     if (likely(objc > 1)) {
23341       result = ObjectDispatch(object, interp, objc, objv, NSF_CSC_IMMEDIATE);
23342     } else {
23343       result = DispatchDefaultMethod(interp, object, objv[0], NSF_CSC_IMMEDIATE);
23344     }
23345   } else {
23346     /*fprintf(stderr, "CallForwarder: no nsf object %s [0] %s\n", ObjStr(tcd->cmdName), ObjStr(objv[0]));*/
23347     result = Tcl_EvalObjv(interp, objc, objv, 0);
23348   }
23349 
23350   if (tcd->frame == FrameObjectIdx) {
23351     Nsf_PopFrameObj(interp, framePtr);
23352   }
23353 
23354 #if defined(NSF_FORWARD_WITH_ONERROR)
23355   if (unlikely(result == TCL_ERROR && tcd->onerror)) {
23356     result = NsfForwardPrintError(interp, tcd, objc, objv, "%s",
23357                                   ObjStr(Tcl_GetObjResult(interp)));
23358   }
23359 #endif
23360 
23361   return result;
23362 }
23363 
23364 /*
23365  *----------------------------------------------------------------------
23366  * NsfForwardMethod --
23367  *
23368  *    This Tcl_ObjCmdProc is called, when a forwarder is invoked. It performs
23369  *    argument substitution through ForwardArg() and calls finally the method,
23370  *    to which the call was forwarded via CallForwarder().
23371  *
23372  * Results:
23373  *    Tcl result code.
23374  *
23375  * Side effects:
23376  *    Maybe through the invoked command.
23377  *
23378  *----------------------------------------------------------------------
23379  */
23380 
23381 static int NsfForwardMethod(ClientData clientData, Tcl_Interp *interp,
23382                             int objc, Tcl_Obj *const objv[])
23383   nonnull(1) nonnull(2) nonnull(4);
23384 
23385 static int
NsfForwardMethod(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])23386 NsfForwardMethod(ClientData clientData, Tcl_Interp *interp,
23387                    int objc, Tcl_Obj *const objv[]) {
23388   ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData;
23389   int                   result, inputArg = 1;
23390 
23391   nonnull_assert(clientData != NULL);
23392   nonnull_assert(interp != NULL);
23393   nonnull_assert(objv != NULL);
23394 
23395   if (unlikely(!tcd || !tcd->object)) {
23396     return NsfDispatchClientDataError(interp, tcd, "object",
23397                                       objc > 0 ? ObjStr(objv[0]) : "forwarder");
23398   }
23399 
23400   /*
23401    * First, we handle two short cuts for simple cases.
23402    */
23403 
23404   if (tcd->passthrough) {
23405     /*
23406      * This is set for early binding. This means, that the cmd is already
23407      * resolved, we have to care only for objscope.
23408      */
23409     return CallForwarder(tcd, interp, objc, objv);
23410 
23411   } else if (tcd->args == NULL && *(ObjStr(tcd->cmdName)) != '%') {
23412     /*
23413      * We have no args, therefore we have only to replace the method name
23414      * with the given cmd name.
23415      */
23416     ALLOC_ON_STACK(Tcl_Obj*, objc, ov);
23417     /*fprintf(stderr, "+++ forwardMethod must subst oc=%d <%s>\n",
23418       objc, ObjStr(tcd->cmdName));*/
23419     memcpy(ov, objv, sizeof(Tcl_Obj *) * (size_t)objc);
23420     ov[0] = tcd->cmdName;
23421     result = CallForwarder(tcd, interp, objc, ov);
23422     FREE_ON_STACK(Tcl_Obj *, ov);
23423     return result;
23424 
23425   } else {
23426     Tcl_Obj **ov, *freeList = NULL;
23427     int       j, outputincr, outputArg = 0, firstPosArg=1,
23428               totalargs = objc + tcd->nr_args + 3;
23429 
23430     ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV);
23431     {
23432       ALLOC_ON_STACK(long, totalargs, objvmap);
23433 
23434       /*fprintf(stderr, "+++ forwardMethod standard case, allocated %d args, tcd->args %s\n",
23435         totalargs, ObjStr(tcd->args));*/
23436 
23437       ov = &OV[1];
23438       if (tcd->needobjmap) {
23439         memset(objvmap, -1, sizeof(long) * (size_t)totalargs);
23440       }
23441 
23442       /*
23443        * The first argument is always the command, to which we forward.
23444        */
23445       if ((result = ForwardArg(interp, objc, objv, tcd->cmdName, tcd,
23446                                &ov[outputArg], &freeList, &inputArg,
23447                                &objvmap[outputArg],
23448                                firstPosArg, &outputincr)) != TCL_OK) {
23449         goto exitforwardmethod;
23450       }
23451       outputArg += outputincr;
23452 
23453       /*
23454        * If we have non-pos args, determine the first positional arg position
23455        * for %1
23456        */
23457       if (tcd->hasNonposArgs) {
23458         firstPosArg = objc;
23459         for (j = outputArg; j < objc; j++) {
23460           const char *arg = ObjStr(objv[j]);
23461           if (*arg != '-') {
23462             firstPosArg = j;
23463             break;
23464           }
23465         }
23466       }
23467 
23468       if (tcd->args != NULL) {
23469         Tcl_Obj **listElements;
23470         int       nrElements;
23471 
23472         /*
23473          * Copy argument list from the definitions.
23474          */
23475         Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements);
23476 
23477         for (j = 0; j < nrElements; j++, outputArg += outputincr) {
23478           if ((result = ForwardArg(interp, objc, objv, listElements[j], tcd,
23479                                    &ov[outputArg], &freeList, &inputArg,
23480                                    &objvmap[outputArg],
23481                                    firstPosArg, &outputincr)) != TCL_OK) {
23482             goto exitforwardmethod;
23483           }
23484         }
23485       }
23486 
23487       /*fprintf(stderr, "objc=%d, tcd->nr_subcommands=%d size=%d\n",
23488         objc, tcd->nr_subcommands, objc+ 2            );*/
23489 
23490       if (objc-inputArg > 0) {
23491         /*fprintf(stderr, "  copying remaining %d args starting at [%d]\n",
23492           objc-inputArg, outputArg);*/
23493         memcpy(ov+outputArg, objv+inputArg, sizeof(Tcl_Obj *) * ((size_t)objc - (size_t)inputArg));
23494       } else {
23495         /*fprintf(stderr, "  nothing to copy, objc=%d, inputArg=%d\n", objc, inputArg);*/
23496       }
23497       if (tcd->needobjmap) {
23498         /*
23499          * The objmap can shuffle the argument list. We have to set the
23500          * addressing relative from the end; -2 means last, -3 element before
23501          * last, etc.
23502          */
23503         int max = objc + tcd->nr_args - inputArg;
23504 
23505         for (j = 0; j < totalargs; j++) {
23506           if (objvmap[j] < -1) {
23507             /*fprintf(stderr, "must reduct, v=%d\n", objvmap[j]);*/
23508             objvmap[j] = max + objvmap[j] + 2;
23509             /*fprintf(stderr, "... new value=%d, max = %d\n", objvmap[j], max);*/
23510           }
23511         }
23512       }
23513       objc += outputArg - inputArg;
23514 
23515 #if 0
23516       for(j = 0; j < objc; j++) {
23517         /*fprintf(stderr, "  ov[%d]=%p, objc=%d\n", j, ov[j], objc);*/
23518         fprintf(stderr, " o[%d]=%p %s (%d),", j, ov[j], ov[j] ? ObjStr(ov[j]) : "NADA", objvmap[j]);
23519       }
23520       fprintf(stderr, "\n");
23521 #endif
23522 
23523       if (tcd->needobjmap) {
23524 
23525         for (j = 0; j < totalargs; j++) {
23526           Tcl_Obj *tmp;
23527           long     pos = objvmap[j], i;
23528 
23529           if (pos == -1 || pos == j) {
23530             continue;
23531           }
23532           tmp = ov[j];
23533           if (j > pos) {
23534             for(i = j; i > pos; i--) {
23535               /*fprintf(stderr, "...moving right %d to %d\n", i-1, i);*/
23536               ov[i] = ov[i-1];
23537               objvmap[i] = objvmap[i-1];
23538             }
23539           } else {
23540             for(i = j; i < pos; i++) {
23541               /*fprintf(stderr, "...moving left %d to %d\n", i+1, i);*/
23542               ov[i] = ov[i+1];
23543               objvmap[i] = objvmap[i+1];
23544             }
23545           }
23546           /*fprintf(stderr, "...setting at %d -> %s\n", pos, ObjStr(tmp));*/
23547           ov[pos] = tmp;
23548           objvmap[pos] = -1;
23549         }
23550       }
23551 
23552       /*
23553         If a prefix is provided, it will be prepended to the 2nd argument. This
23554         allows for avoiding name clashes if the 2nd argument denotes a
23555         subcommand, for example.
23556 
23557         Make sure that the prefix is only prepended, if a second argument is
23558         actually available! Otherwise, the requested prefix has no effect.
23559       */
23560       if (tcd->prefix && objc > 1) {
23561         Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix);
23562 
23563         Tcl_AppendObjToObj(methodName, ov[1]);
23564         ov[1] = methodName;
23565         INCR_REF_COUNT(ov[1]);
23566       }
23567 
23568 #if 0
23569       for(j = 0; j < objc; j++) {
23570         /*fprintf(stderr, "  ov[%d]=%p, objc=%d\n", j, ov[j], objc);*/
23571         fprintf(stderr, "  ov[%d]=%p '%s' map=%d\n", j, ov[j], ov[j] ? ObjStr(ov[j]) : "NADA", objvmap[j]);
23572       }
23573 #endif
23574 
23575       OV[0] = tcd->cmdName;
23576 
23577       result = CallForwarder(tcd, interp, objc, ov);
23578 
23579       if (tcd->prefix && objc > 1) {
23580         DECR_REF_COUNT(ov[1]);
23581       }
23582     exitforwardmethod:
23583       if (freeList != NULL) {
23584         DECR_REF_COUNT2("AddObjToTclList", freeList);
23585       }
23586 
23587       FREE_ON_STACK(long, objvmap);
23588     }
23589     FREE_ON_STACK(Tcl_Obj*, OV);
23590   }
23591   return result;
23592 }
23593 
23594 
23595 /*
23596  *----------------------------------------------------------------------
23597  * NsfProcAliasMethod --
23598  *
23599  *    Since alias-resolving happens in dispatch, this Tcl_ObjCmdProc should
23600  *    never be called during normal operations. The only way to invoke this
23601  *    could happen via directly calling the handle.
23602  *
23603  * Results:
23604  *    TCL_ERROR
23605  *
23606  * Side effects:
23607  *    None.
23608  *
23609  *----------------------------------------------------------------------
23610  */
23611 
23612 static int NsfProcAliasMethod(ClientData clientData,
23613                               Tcl_Interp *interp, int UNUSED(objc),
23614                               Tcl_Obj *const UNUSED(objv[]))
23615   nonnull(1) nonnull(2) nonnull(4);
23616 
23617 static int
NsfProcAliasMethod(ClientData clientData,Tcl_Interp * interp,int UNUSED (objc),Tcl_Obj * const UNUSED (objv[]))23618 NsfProcAliasMethod(ClientData clientData,
23619                    Tcl_Interp *interp, int UNUSED(objc),
23620                    Tcl_Obj *const UNUSED(objv[])) {
23621   AliasCmdClientData *tcd;
23622 
23623   nonnull_assert(clientData != NULL);
23624   nonnull_assert(interp != NULL);
23625 
23626   tcd = (AliasCmdClientData *)clientData;
23627   return NsfDispatchClientDataError(interp, NULL, "object",
23628                                     Tcl_GetCommandName(interp, tcd->aliasCmd));
23629 }
23630 
23631 
23632 /*
23633  *----------------------------------------------------------------------
23634  * NsfObjscopedMethod --
23635  *
23636  *    This Tcl_ObjCmdProc is called, when an obj-scoped alias is invoked.
23637  *
23638  * Results:
23639  *    Tcl result code.
23640  *
23641  * Side effects:
23642  *    Maybe through the invoked command.
23643  *
23644  *----------------------------------------------------------------------
23645  */
23646 
23647 static int NsfObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
23648   nonnull(1) nonnull(2) nonnull(4);
23649 
23650 static int
NsfObjscopedMethod(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])23651 NsfObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
23652   AliasCmdClientData *tcd;
23653   NsfObject          *object;
23654   CallFrame           frame, *framePtr = &frame;
23655   int                 result;
23656 
23657   nonnull_assert(clientData != NULL);
23658   nonnull_assert(interp != NULL);
23659   nonnull_assert(objv != NULL);
23660 
23661   tcd = (AliasCmdClientData *)clientData;
23662   /*fprintf(stderr, "objscopedMethod obj=%p %s, ptr=%p\n", object, ObjectName(object), tcd->objProc);*/
23663 
23664   object = tcd->object;
23665   tcd->object = NULL;
23666 
23667   Nsf_PushFrameObj(interp, object, framePtr);
23668   result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv);
23669   Nsf_PopFrameObj(interp, framePtr);
23670 
23671   return result;
23672 }
23673 
23674 /*
23675  *----------------------------------------------------------------------
23676  * IsDashArg --
23677  *
23678  *    Check, whether the provided argument (pointed to be the index isFirstArg)
23679  *    starts with a "-", or is a list starting with a "-". The method returns
23680  *    via **methodName the name of the dashed argument (without the dash).
23681  *
23682  * Results:
23683  *    Enum value dashArgType.
23684  *
23685  * Side effects:
23686  *    None.
23687  *
23688  *----------------------------------------------------------------------
23689  */
23690 
23691 typedef enum {NO_DASH, SCALAR_DASH, LIST_DASH} dashArgType;
23692 
23693 static dashArgType IsDashArg(Tcl_Interp *interp, Tcl_Obj *obj, int isFirstArg, const char **methodName,
23694                              int *objcPtr, Tcl_Obj **objvPtr[])
23695   nonnull(1) nonnull(2) nonnull(4) nonnull(5) nonnull(6);
23696 
23697 static dashArgType
IsDashArg(Tcl_Interp * interp,Tcl_Obj * obj,int isFirstArg,const char ** methodName,int * objcPtr,Tcl_Obj ** objvPtr[])23698 IsDashArg(Tcl_Interp *interp, Tcl_Obj *obj, int isFirstArg, const char **methodName,
23699           int *objcPtr, Tcl_Obj **objvPtr[]) {
23700   const char *flag;
23701 
23702   nonnull_assert(interp != NULL);
23703   nonnull_assert(obj != NULL);
23704   nonnull_assert(methodName != NULL);
23705   nonnull_assert(objcPtr != NULL);
23706   nonnull_assert(objvPtr != NULL);
23707 
23708   if (obj->typePtr == Nsf_OT_listType) {
23709     if (Tcl_ListObjGetElements(interp, obj, objcPtr, objvPtr) == TCL_OK && *objcPtr > 1) {
23710       flag = ObjStr(*objvPtr[0]);
23711       /*fprintf(stderr, "we have a list starting with '%s'\n", flag);*/
23712       if (*flag == '-') {
23713         *methodName = flag+1;
23714         return LIST_DASH;
23715       }
23716     }
23717   }
23718   flag = ObjStr(obj);
23719   /*fprintf(stderr, "we have a scalar '%s' isFirstArg %d\n", flag, isFirstArg);*/
23720 
23721   if ((*flag == '-') && isalpha(*((flag)+1))) {
23722     if (isFirstArg == 1) {
23723       /*
23724        * If the argument contains a space, try to split.
23725        */
23726       const char *p = flag+1;
23727 
23728       while (*p != '\0' && !NsfHasTclSpace(p)) p++;
23729       if (NsfHasTclSpace(p)) {
23730         if (Tcl_ListObjGetElements(interp, obj, objcPtr, objvPtr) == TCL_OK) {
23731           *methodName = ObjStr(*objvPtr[0]);
23732           if (**methodName == '-') {
23733             (*methodName)++ ;
23734           }
23735           return LIST_DASH;
23736         }
23737       }
23738     }
23739     *methodName = flag+1;
23740     *objcPtr = 1;
23741     return SCALAR_DASH;
23742   }
23743   return NO_DASH;
23744 }
23745 
23746 /*
23747  *----------------------------------------------------------------------
23748  * CallConfigureMethod --
23749  *
23750  *    Call a method identified by a string selector; or provide an error
23751  *    message. This dispatcher function records as well constructor (init)
23752  *    calls via this interface. The dispatcher is used in XOTcl's
23753  *    configure(), interpreting arguments with a leading dash as method dispatches.
23754  *    This behavior is now implemented in NsfOResidualargsMethod().
23755  *
23756  * Results:
23757  *    Tcl result code.
23758  *
23759  * Side effects:
23760  *    Maybe side effects from the called methods.
23761  *
23762  *----------------------------------------------------------------------
23763  */
23764 static int CallConfigureMethod(Tcl_Interp *interp, NsfObject *object, const char *initString,
23765                                const char *methodName,
23766                                int argc, Tcl_Obj *const argv[])
23767   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
23768 
23769 static int
CallConfigureMethod(Tcl_Interp * interp,NsfObject * object,const char * initString,const char * methodName,int argc,Tcl_Obj * const argv[])23770 CallConfigureMethod(Tcl_Interp *interp, NsfObject *object, const char *initString,
23771                     const char *methodName,
23772                     int argc, Tcl_Obj *const argv[]) {
23773   int result;
23774   Tcl_Obj *methodObj = Tcl_NewStringObj(methodName, -1);
23775 
23776   nonnull_assert(interp != NULL);
23777   nonnull_assert(object != NULL);
23778   nonnull_assert(initString != NULL);
23779   nonnull_assert(methodName != NULL);
23780 
23781   /*
23782    * When configure gets "-init" passed, we call "init" and notice the fact it
23783    * in the object's flags.
23784    */
23785 
23786   if (*initString == *methodName && strcmp(methodName, initString) == 0) {
23787     object->flags |= NSF_INIT_CALLED;
23788   }
23789 
23790   Tcl_ResetResult(interp);
23791   INCR_REF_COUNT(methodObj);
23792   result = CallMethod(object, interp, methodObj, argc, argv,
23793                       NSF_CM_NO_UNKNOWN|NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
23794   DECR_REF_COUNT(methodObj);
23795 
23796   /*fprintf(stderr, "method  '%s' called args: %d o=%p, result=%d %d\n",
23797     methodName, argc+1, object, result, TCL_ERROR);*/
23798 
23799   if (unlikely(result != TCL_OK)) {
23800     Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */
23801 
23802     INCR_REF_COUNT(res);
23803     NsfPrintError(interp, "%s during '%s.%s'", ObjStr(res), ObjectName_(object), methodName);
23804     DECR_REF_COUNT(res);
23805   }
23806 
23807   return result;
23808 }
23809 
23810 
23811 /*
23812  * class method implementations
23813  */
23814 
23815 /*
23816  *----------------------------------------------------------------------
23817  * IsRootNamespace --
23818  *
23819  *    Check whether the provided namespace is the namespace of the base
23820  *    class of an object system.
23821  *
23822  * Results:
23823  *    Boolean value.
23824  *
23825  * Side effects:
23826  *    None.
23827  *
23828  *----------------------------------------------------------------------
23829  */
23830 static bool IsRootNamespace(const Tcl_Interp *interp, const Tcl_Namespace *nsPtr)
23831   nonnull(1) nonnull(2) pure;
23832 
23833 static bool
IsRootNamespace(const Tcl_Interp * interp,const Tcl_Namespace * nsPtr)23834 IsRootNamespace(const Tcl_Interp *interp, const Tcl_Namespace *nsPtr) {
23835   const NsfObjectSystem *osPtr;
23836 
23837   nonnull_assert(interp != NULL);
23838   nonnull_assert(nsPtr != NULL);
23839 
23840   for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
23841     const Tcl_Command cmd = osPtr->rootClass->object.id;
23842     if ((Tcl_Namespace *)((Command *)cmd)->nsPtr == nsPtr) {
23843       return NSF_TRUE;
23844     }
23845   }
23846   return NSF_FALSE;
23847 }
23848 
23849 /*
23850  *----------------------------------------------------------------------
23851  * CallingNameSpace --
23852  *
23853  *    Find the last invocation outside the Next Scripting system
23854  *    namespaces. This function return the namespace of the caller but
23855  *    skips system-specific namespaces (e.g. the namespaces of the
23856  *    pre-defined slot handlers for mixin and class
23857  *    registration. etc.) If we would use such namespaces, we would
23858  *    resolve non-fully-qualified names against the root namespace).
23859  *
23860  * Results:
23861  *    Tcl_Namespace or NULL
23862  *
23863  * Side effects:
23864  *    None.
23865  *
23866  *----------------------------------------------------------------------
23867  */
23868 static Tcl_Namespace *
CallingNameSpace(Tcl_Interp * interp)23869 CallingNameSpace(Tcl_Interp *interp) {
23870   Tcl_CallFrame *framePtr;
23871   Tcl_Namespace *nsPtr = NULL;
23872 
23873   nonnull_assert(interp != NULL);
23874 
23875   /*NsfShowStack(interp);*/
23876   framePtr = CallStackGetActiveProcFrame((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp));
23877   /* framePtr = BeginOfCallChain(interp, GetSelfObj(interp));*/
23878 
23879   for (; likely(framePtr != NULL); framePtr = Tcl_CallFrame_callerVarPtr(framePtr)) {
23880     nsPtr = Tcl_CallFrame_nsPtr(framePtr);
23881 
23882     if (IsRootNamespace(interp, nsPtr)) {
23883       /*fprintf(stderr, "... %p skip %s\n", framePtr, nsPtr->fullName);*/
23884       continue;
23885     }
23886     /*fprintf(stderr, "... %p take %s\n", framePtr, nsPtr->fullName); */
23887     break;
23888   }
23889 
23890   if (framePtr == NULL) {
23891     nsPtr = Tcl_GetGlobalNamespace(interp);
23892   }
23893 
23894   /*fprintf(stderr, " **** CallingNameSpace: returns %p %s framePtr %p\n",
23895     nsPtr, (nsPtr != NULL) ? nsPtr->fullName:"(null)", framePtr);*/
23896   return nsPtr;
23897 }
23898 
23899 /***********************************
23900  * argument handling
23901  ***********************************/
23902 
23903 static void ArgumentResetRefCounts(const struct Nsf_Param *pPtr, Tcl_Obj *valueObj)
23904   nonnull(1) nonnull(2);
23905 
23906 static void
ArgumentResetRefCounts(const struct Nsf_Param * pPtr,Tcl_Obj * valueObj)23907 ArgumentResetRefCounts(const struct Nsf_Param *pPtr, Tcl_Obj *valueObj) {
23908 
23909   nonnull_assert(pPtr != NULL);
23910   nonnull_assert(valueObj != NULL);
23911 
23912   if ((pPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) {
23913     DECR_REF_COUNT2("valueObj", valueObj);
23914   }
23915 }
23916 
23917 /*
23918  *----------------------------------------------------------------------
23919  * ArgumentCheckHelper --
23920  *
23921  *    Helper function for ArgumentCheck() called when argument checking leads
23922  *    to a different output element (non-pure checking).
23923  *
23924  * Results:
23925  *    Tcl result code.
23926  *
23927  * Side effects:
23928  *    None.
23929  *
23930  *----------------------------------------------------------------------
23931  */
23932 static int ArgumentCheckHelper(Tcl_Interp *interp, Tcl_Obj *objPtr, const struct Nsf_Param *pPtr, unsigned int *flags,
23933                                ClientData *clientData, Tcl_Obj **outObjPtr)
23934   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6);
23935 
23936 static int
ArgumentCheckHelper(Tcl_Interp * interp,Tcl_Obj * objPtr,const struct Nsf_Param * pPtr,unsigned int * flags,ClientData * clientData,Tcl_Obj ** outObjPtr)23937 ArgumentCheckHelper(Tcl_Interp *interp,
23938                     Tcl_Obj *objPtr,
23939                     const struct Nsf_Param *pPtr,
23940                     unsigned int *flags,
23941                     ClientData *clientData,
23942                     Tcl_Obj **outObjPtr) {
23943   int       objc, i, result;
23944   Tcl_Obj **ov;
23945 
23946   nonnull_assert(interp != NULL);
23947   nonnull_assert(objPtr != NULL);
23948   nonnull_assert(pPtr != NULL);
23949   nonnull_assert(flags != NULL);
23950   nonnull_assert(clientData != NULL);
23951   nonnull_assert(outObjPtr != NULL);
23952   assert((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u);
23953   assert((*flags & NSF_PC_MUST_DECR) != 0u);
23954 
23955   result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov);
23956   if (unlikely(result != TCL_OK)) {
23957     return result;
23958   }
23959 
23960   *outObjPtr = Tcl_NewListObj(0, NULL);
23961   INCR_REF_COUNT2("valueObj", *outObjPtr);
23962 
23963   for (i = 0; i < objc; i++) {
23964     Tcl_Obj    *elementObjPtr = ov[i];
23965     const char *valueString = ObjStr(elementObjPtr);
23966 
23967     if ((pPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u && *valueString == '\0') {
23968       result = Nsf_ConvertToString(interp, elementObjPtr, pPtr, clientData, &elementObjPtr);
23969     } else {
23970       result = (*pPtr->converter)(interp, elementObjPtr, pPtr, clientData, &elementObjPtr);
23971     }
23972 
23973     /*fprintf(stderr, "ArgumentCheckHelper convert %s result %d (%s)\n",
23974       valueString, result, ObjStr(elementObjPtr));*/
23975 
23976     if (result == TCL_OK || result == TCL_CONTINUE) {
23977       Tcl_ListObjAppendElement(interp, *outObjPtr, elementObjPtr);
23978       /*
23979        * If the refCount of the valueObj was already incremented, we have to
23980        * decrement it here, since we want the valueObj reclaimed when the list
23981        * containing the valueObj is freed.
23982        */
23983       ArgumentResetRefCounts(pPtr, elementObjPtr);
23984     } else {
23985       Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
23986 
23987       INCR_REF_COUNT(resultObj);
23988       NsfPrintError(interp, "invalid value in \"%s\": %s", ObjStr(objPtr), ObjStr(resultObj));
23989       *flags &= ~NSF_PC_MUST_DECR;
23990       *outObjPtr = objPtr;
23991       DECR_REF_COUNT2("valueObj", *outObjPtr);
23992       DECR_REF_COUNT(resultObj);
23993 
23994       break;
23995     }
23996   }
23997   return result;
23998 }
23999 
24000 
24001 /*
24002  *----------------------------------------------------------------------
24003  * ArgumentCheck --
24004  *
24005  *    Check a single argument (2nd argument) against the parameter structure
24006  *    when argument checking is turned on (default).
24007  *
24008  * Results:
24009  *    Standard Tcl result
24010  *
24011  * Side effects:
24012  *    None.
24013  *
24014  *----------------------------------------------------------------------
24015  */
24016 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)24017 ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, const struct Nsf_Param *pPtr,
24018               unsigned int doCheckArguments,
24019               unsigned int *flags, ClientData *clientData, Tcl_Obj **outObjPtr) {
24020   int result;
24021 
24022   nonnull_assert(interp != NULL);
24023   nonnull_assert(objPtr != NULL);
24024   nonnull_assert(pPtr != NULL);
24025   nonnull_assert(flags != NULL);
24026   nonnull_assert(clientData != NULL);
24027   nonnull_assert(outObjPtr != NULL);
24028 
24029   /*
24030    * Default assumption: outObjPtr is not modified.
24031    */
24032   *outObjPtr = objPtr;
24033 
24034   /*
24035    * Omit argument checking, provided that ...
24036    * ... argument checking is turned off *and* no converter is specified, or
24037    * ... the ruling parameter option is 'initcmd'
24038    * ... slotset is active
24039    */
24040   if ((unlikely((doCheckArguments & NSF_ARGPARSE_CHECK) == 0u) && (pPtr->flags & (NSF_ARG_IS_CONVERTER)) == 0u) ||
24041       ((pPtr->flags & (NSF_ARG_CMD)) != 0u) ||
24042       ((pPtr->flags & (NSF_ARG_SLOTSET)) != 0u)) {
24043     /* fprintf(stderr, "*** omit  argument check for arg %s flags %.6x\n", pPtr->name, pPtr->flags); */
24044     *clientData = ObjStr(objPtr);
24045     return TCL_OK;
24046   }
24047 
24048   /*
24049    * If the argument is multivalued, perform the check for every element of
24050    * the list (pure checker), or we have to build a new list of values (in
24051    * case, the converter alters the values).
24052    */
24053   if (unlikely((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u)) {
24054     int objc, i;
24055     Tcl_Obj **ov;
24056 
24057     result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov);
24058     if (unlikely(result != TCL_OK)) {
24059       return result;
24060     }
24061 
24062     if (objc == 0 && ((pPtr->flags & NSF_ARG_ALLOW_EMPTY) == 0u)) {
24063       return NsfPrintError(interp,
24064                            "invalid value for parameter '%s': list is not allowed to be empty",
24065                            pPtr->name);
24066     }
24067 
24068     /*
24069      * In cases where necessary (the output element changed), switch to the
24070      * helper function
24071      */
24072     for (i = 0; i < objc; i++) {
24073       Tcl_Obj *elementObjPtr = ov[i];
24074 
24075       result = (*pPtr->converter)(interp, elementObjPtr, pPtr, clientData, &elementObjPtr);
24076       if (likely(result == TCL_OK || result == TCL_CONTINUE)) {
24077         if (ov[i] != elementObjPtr) {
24078           /*fprintf(stderr, "ArgumentCheck: switch to output list construction for value %s\n",
24079             ObjStr(elementObjPtr));*/
24080           /*
24081            * The elementObjPtr differs from the input Tcl_Obj, we switch to
24082            * the version of this handler building an output list. But first,
24083            * we have to reset the ref-counts from the first conversion.
24084            */
24085           ArgumentResetRefCounts(pPtr, elementObjPtr);
24086           *flags |= NSF_PC_MUST_DECR;
24087           result = ArgumentCheckHelper(interp, objPtr, pPtr, flags, clientData, outObjPtr);
24088           break;
24089         }
24090       } else {
24091         Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
24092         INCR_REF_COUNT(resultObj);
24093         NsfPrintError(interp, "invalid value in \"%s\": %s", ObjStr(objPtr), ObjStr(resultObj));
24094         DECR_REF_COUNT(resultObj);
24095         break;
24096       }
24097     }
24098   } else {
24099     assert(objPtr == *outObjPtr);
24100     if ((pPtr->flags & NSF_ARG_ALLOW_EMPTY) != 0u && *(ObjStr(objPtr)) == '\0') {
24101       result = Nsf_ConvertToString(interp, objPtr, pPtr, clientData, outObjPtr);
24102     } else {
24103       result = (*pPtr->converter)(interp, objPtr, pPtr, clientData, outObjPtr);
24104     }
24105 
24106     /*fprintf(stderr, "ArgumentCheck param %s type %s is converter %d flags %.6x "
24107             "outObj changed %d (%p %p) isok %d\n",
24108             pPtr->name, pPtr->type, pPtr->flags & NSF_ARG_IS_CONVERTER, pPtr->flags,
24109             objPtr != *outObjPtr, objPtr, *outObjPtr, result == TCL_OK);*/
24110 
24111     if (unlikely((pPtr->flags & NSF_ARG_IS_CONVERTER) != 0u) && objPtr != *outObjPtr) {
24112       *flags |= NSF_PC_MUST_DECR;
24113     } else {
24114       /*
24115        * If the output obj differs from the input obj, ensure we have
24116        * MUST_DECR set.
24117        */
24118       assert( (*flags & NSF_PC_MUST_DECR) != 0u || objPtr == *outObjPtr );
24119     }
24120   }
24121 
24122   if (unlikely(result == TCL_CONTINUE)) {
24123     *flags |= NSF_ARG_WARN;
24124     result = TCL_OK;
24125   }
24126 
24127   return result;
24128 }
24129 
24130 /*
24131  *----------------------------------------------------------------------
24132  * ArgumentDefaults --
24133  *
24134  *    Process the argument vector and set defaults in parse context if
24135  *    provided and necessary.
24136  *
24137  * Results:
24138  *    Standard Tcl result
24139  *
24140  * Side effects:
24141  *    None.
24142  *
24143  *----------------------------------------------------------------------
24144  */
24145 static int ArgumentDefaults(ParseContext *pcPtr, Tcl_Interp *interp,
24146                             const Nsf_Param *ifd, int nrParams, unsigned int processFlags)
24147   nonnull(1) nonnull(2) nonnull(3);
24148 
24149 static int
ArgumentDefaults(ParseContext * pcPtr,Tcl_Interp * interp,const Nsf_Param * ifd,int nrParams,unsigned int processFlags)24150 ArgumentDefaults(ParseContext *pcPtr, Tcl_Interp *interp,
24151                  const Nsf_Param *ifd, int nrParams, unsigned int processFlags) {
24152   const Nsf_Param *pPtr;
24153   int i;
24154 
24155   nonnull_assert(pcPtr != NULL);
24156   nonnull_assert(interp != NULL);
24157   nonnull_assert(ifd != NULL);
24158 
24159   for (pPtr = ifd, i = 0; i < nrParams; pPtr++, i++) {
24160     /*fprintf(stderr, "ArgumentDefaults got for arg %s (req %d, nrArgs %d) %p => %p %p, default '%s' \n",
24161             pPtr->name, pPtr->flags & NSF_ARG_REQUIRED, pPtr->nrArgs, pPtr,
24162             pcPtr->clientData[i], pcPtr->objv[i],
24163             (pPtr->defaultValue != NULL) ? ObjStr(pPtr->defaultValue) : "NONE");*/
24164 
24165     if (pcPtr->objv[i] != NULL) {
24166       /*
24167        * We got an actual value, which was already checked by ArgumentParse().
24168        * In case the value is a switch and NSF_PC_INVERT_DEFAULT is set, we
24169        * take the default and invert the value in place.
24170        */
24171       if (unlikely((pcPtr->flags[i] & NSF_PC_INVERT_DEFAULT) != 0u)) {
24172         int boolVal;
24173 
24174         assert(pPtr->defaultValue != NULL);
24175 
24176         Tcl_GetBooleanFromObj(interp, pPtr->defaultValue, &boolVal);
24177         pcPtr->objv[i] = Tcl_NewBooleanObj(boolVal == 0);
24178         /*
24179          * Perform bookkeeping to avoid that someone releases the new obj
24180          * before we are done. The according DECR is performed by
24181          * ParseContextRelease()
24182          */
24183         INCR_REF_COUNT2("valueObj", pcPtr->objv[i]);
24184         pcPtr->flags[i] |= NSF_PC_MUST_DECR;
24185         pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
24186       }
24187     } else {
24188       /*
24189        * No valued was passed, check whether a default is available.
24190        */
24191 
24192       if (pPtr->defaultValue != NULL) {
24193         int mustDecrNewValue;
24194         Tcl_Obj *newValue = pPtr->defaultValue;
24195         ClientData checkedData;
24196 
24197         /*
24198          * We have a default value for the argument.  Mark that this argument
24199          * gets the default value.
24200          */
24201         pcPtr->flags[i] |= NSF_PC_IS_DEFAULT;
24202 
24203         /*
24204          * Does the user want to substitute in the default value?
24205          */
24206         if (unlikely((pPtr->flags & NSF_ARG_SUBST_DEFAULT) != 0u)) {
24207           int      tclOptions = 0;
24208           Tcl_Obj *obj;
24209 
24210           if ((pPtr->flags & NSF_ARG_SUBST_DEFAULT_VARIABLES) != 0u) {
24211             tclOptions |= TCL_SUBST_VARIABLES;
24212           }
24213           if ((pPtr->flags & NSF_ARG_SUBST_DEFAULT_COMMANDS) != 0u) {
24214             tclOptions |= TCL_SUBST_COMMANDS;
24215           }
24216           if ((pPtr->flags & NSF_ARG_SUBST_DEFAULT_BACKSLASHES) != 0u) {
24217             tclOptions |= TCL_SUBST_BACKSLASHES;
24218           }
24219           /* fprintf(stderr, "SUBST tclOptions %.4x\n", tclOptions);*/
24220           obj = Tcl_SubstObj(interp, newValue, tclOptions);
24221 
24222           if (likely(obj != NULL)) {
24223              newValue = obj;
24224           } else {
24225             pcPtr->flags[i] = 0u;
24226             return TCL_ERROR;
24227           }
24228 
24229           /*
24230            * The matching DECR is performed by ParseContextRelease().
24231            */
24232           INCR_REF_COUNT2("valueObj", newValue);
24233           /*fprintf(stderr, "SUBST_DEFAULT increments %p refCount %d\n",
24234             newValue, newValue->refCount);*/
24235           mustDecrNewValue = 1;
24236           pcPtr->flags[i] |= NSF_PC_MUST_DECR;
24237           pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
24238         } else {
24239           mustDecrNewValue = 0;
24240         }
24241 
24242         pcPtr->objv[i] = newValue;
24243         /*fprintf(stderr, "==> setting default value '%s' for var '%s' flag %d type %s conv %p\n",
24244                 ObjStr(newValue), pPtr->name, pPtr->flags & NSF_ARG_INITCMD,
24245                 pPtr->type, pPtr->converter);*/
24246         /*
24247          * Check the default value if necessary
24248          */
24249         if (pPtr->type != NULL || unlikely((pPtr->flags & NSF_ARG_MULTIVALUED) != 0u)) {
24250           unsigned int mustDecrList = 0;
24251 
24252           if (unlikely((pPtr->flags & NSF_ARG_INITCMD) == 0u &&
24253                        ArgumentCheck(interp, newValue, pPtr,
24254                                      RUNTIME_STATE(interp)->doCheckArguments,
24255                                      &mustDecrList, &checkedData, &pcPtr->objv[i]) != TCL_OK)) {
24256             if (mustDecrNewValue == 1) {
24257               DECR_REF_COUNT2("valueObj", newValue);
24258               pcPtr->flags[i] &= ~NSF_PC_MUST_DECR;
24259             }
24260             return TCL_ERROR;
24261           }
24262 
24263           if (unlikely(pcPtr->objv[i] != newValue)) {
24264             /*
24265              * The output Tcl_Obj differs from the input, so the Tcl_Obj was
24266              * converted; in case we have set previously the flag
24267              * NSF_PC_MUST_DECR on newValue, we decrement the refCount on
24268              * newValue here and clear the flag.
24269              */
24270             if (mustDecrNewValue == 1) {
24271               DECR_REF_COUNT2("valueObj", newValue);
24272               pcPtr->flags[i] &= ~NSF_PC_MUST_DECR;
24273             }
24274             /*
24275              * The new output value itself might require a decrement, so set
24276              * the flag here if required; this is just necessary for
24277              * multivalued converted output.
24278              */
24279             if (mustDecrList == 1) {
24280               pcPtr->flags[i] |= NSF_PC_MUST_DECR;
24281               pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
24282             }
24283           }
24284         } else {
24285           /*fprintf(stderr, "Param %s default %s type %s\n",
24286             pPtr->name, ObjStr(pPtr->defaultValue), pPtr->type);*/
24287           assert((pPtr->type != NULL) ? pPtr->defaultValue == NULL : 1);
24288         }
24289       } else if (unlikely((pPtr->flags & NSF_ARG_REQUIRED) != 0u)
24290                  && ((processFlags & NSF_ARGPARSE_FORCE_REQUIRED) != 0u)) {
24291         Tcl_Obj *paramDefsObj = NsfParamDefsSyntax(interp, ifd, pcPtr->object, NULL);
24292         Tcl_Obj *methodPathObj = NsfMethodNamePath(interp,
24293                                                    CallStackGetTclFrame(interp, NULL, 1),
24294                                                    MethodName(pcPtr->full_objv[0]));
24295 
24296         INCR_REF_COUNT2("methodPathObj", methodPathObj);
24297 
24298         NsfPrintError(interp, "required argument '%s' is missing, should be:\n\t%s%s%s %s",
24299                       (pPtr->nameObj != NULL) ? ObjStr(pPtr->nameObj) : pPtr->name,
24300                       (pcPtr->object != NULL) ? ObjectName(pcPtr->object) : "", (pcPtr->object != NULL) ? " " : "",
24301                       ObjStr(methodPathObj),
24302                       ObjStr(paramDefsObj));
24303 
24304         DECR_REF_COUNT2("paramDefsObj", paramDefsObj);
24305         DECR_REF_COUNT2("methodPathObj", methodPathObj);
24306 
24307         return TCL_ERROR;
24308 
24309       } else {
24310         /*
24311          * Use as dummy default value an arbitrary symbol, which must
24312          * not be returned to the Tcl level level; this value is unset
24313          * later typically by NsfUnsetUnknownArgsCmd().
24314          */
24315         pcPtr->objv[i] = NsfGlobalObjs[NSF___UNKNOWN__];
24316       }
24317     }
24318   }
24319   return TCL_OK;
24320 }
24321 
24322 
24323 /*
24324  *----------------------------------------------------------------------
24325  * ArgumentParse --
24326  *
24327  *    Parse the argument vector based on the parameter definitions.
24328  *    The parsed argument vector is returned in a normalized order
24329  *    in the parse context.
24330  *
24331  * Results:
24332  *    Tcl return code.
24333  *
24334  * Side effects:
24335  *    None.
24336  *
24337  *----------------------------------------------------------------------
24338  */
24339 int
Nsf_ArgumentParse(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],Nsf_Object * object,Tcl_Obj * procNameObj,const Nsf_Param * paramPtr,int nrParams,int serial,unsigned int processFlags,Nsf_ParseContext * pcPtr)24340 Nsf_ArgumentParse(
24341     Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
24342     Nsf_Object *object, Tcl_Obj *procNameObj,
24343     const Nsf_Param *paramPtr, int nrParams, int serial,
24344     unsigned int processFlags, Nsf_ParseContext *pcPtr
24345 ) {
24346 
24347   nonnull_assert(interp != NULL);
24348   nonnull_assert(objv != NULL);
24349   nonnull_assert(procNameObj != NULL);
24350   nonnull_assert(pcPtr != NULL);
24351 
24352   return ArgumentParse(interp, objc, objv, (NsfObject *)object, procNameObj,
24353                        paramPtr, nrParams, serial, processFlags,
24354                        (ParseContext *)pcPtr);
24355 }
24356 
24357 /*
24358  *----------------------------------------------------------------------
24359  * NextParam --
24360  *
24361  *    Advance in the parameter definitions and return the next parameter.
24362  *
24363  * Results:
24364  *    Next parameter.
24365  *
24366  * Side effects:
24367  *    None.
24368  *
24369  *----------------------------------------------------------------------
24370  */
24371 
24372 static const Nsf_Param * NextParam(Nsf_Param const *paramPtr, const Nsf_Param *lastParamPtr)
24373   nonnull(1) nonnull(2) returns_nonnull pure;
24374 
24375 static const Nsf_Param *
NextParam(Nsf_Param const * paramPtr,const Nsf_Param * lastParamPtr)24376 NextParam(Nsf_Param const *paramPtr, const Nsf_Param *lastParamPtr) {
24377 
24378   nonnull_assert(paramPtr != NULL);
24379   nonnull_assert(lastParamPtr != NULL);
24380 
24381   for (; (++paramPtr <= lastParamPtr) && (*paramPtr->name == '-'); );
24382   return paramPtr;
24383 }
24384 
24385 /*
24386  *----------------------------------------------------------------------
24387  * ArgumentParse --
24388  *
24389  *    Parse the provided list of argument against the given definition. The
24390  *    result is returned in the parse context structure.
24391  *
24392  * Results:
24393  *    Standard Tcl result.
24394  *
24395  * Side effects:
24396  *    None.
24397  *
24398  *----------------------------------------------------------------------
24399  */
24400 
24401 #define SkipNonposParamDefs(cPtr) \
24402   for (; (++(cPtr) <= lastParamPtr) && (*(cPtr)->name == '-'); )
24403 
24404 static int
ArgumentParse(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],NsfObject * object,Tcl_Obj * procNameObj,const Nsf_Param * paramPtr,int nrParams,int serial,unsigned int processFlags,ParseContext * pcPtr)24405 ArgumentParse(
24406     Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
24407     NsfObject *object, Tcl_Obj *procNameObj,
24408     const Nsf_Param *paramPtr, int nrParams, int serial,
24409     unsigned int processFlags, ParseContext *pcPtr
24410 ) {
24411   int              o, fromArg;
24412   bool             dashdash = NSF_FALSE;
24413   long             j;
24414   const Nsf_Param *currentParamPtr = paramPtr;
24415   const Nsf_Param *lastParamPtr = paramPtr + nrParams - 1;
24416 
24417   nonnull_assert(interp != NULL);
24418   nonnull_assert(objv != NULL);
24419   nonnull_assert(procNameObj != NULL);
24420   nonnull_assert(paramPtr != NULL);
24421   nonnull_assert(pcPtr != NULL);
24422 
24423   if ((processFlags & NSF_ARGPARSE_START_ZERO) != 0u) {
24424     fromArg = 0;
24425   } else {
24426     fromArg = 1;
24427   }
24428 
24429   ParseContextInit(pcPtr, nrParams, object, procNameObj);
24430 
24431 #if defined(PARSE_TRACE)
24432   { const Nsf_Param *pPtr;
24433     fprintf(stderr, "PARAMETER ");
24434     for (o = 0, pPtr = paramPtr; pPtr->name != NULL; o++, pPtr++) {
24435       fprintf(stderr, "[%d]%s (nrargs %d %s) ", o,
24436               pPtr->name, pPtr->nrArgs,
24437               (pPtr->flags & NSF_ARG_REQUIRED) != 0u ? "req" : "opt");
24438     }
24439     fprintf(stderr, "\n");
24440     fprintf(stderr, "BEGIN (%d) [0]%s ", objc, ObjStr(procNameObj));
24441     for (o = fromArg; o < objc; o++) {
24442       Tcl_Obj *obj = objv[o];
24443       if (obj->bytes == NULL) {
24444         fprintf(stderr, "[%d]unk(%s) ", o, obj->typePtr->name);
24445       } else {
24446         fprintf(stderr, "[%d]%s ", o, ObjStr(obj));
24447       }
24448     }
24449     fprintf(stderr, "\n");
24450   }
24451 #endif
24452 
24453   for (o = fromArg; o < objc; o++) {
24454     const Nsf_Param *pPtr = currentParamPtr;
24455     Tcl_Obj         *argumentObj = objv[o], *valueObj = NULL;
24456     const char      *valueInArgument = NULL;
24457 
24458 #if defined(PARSE_TRACE_FULL)
24459     fprintf(stderr, "arg [%d]: %s (param %ld, last %d)\n",
24460             o, ObjStr(argumentObj), currentParamPtr - paramPtr, currentParamPtr == lastParamPtr);
24461 #endif
24462 
24463     if (unlikely(currentParamPtr > lastParamPtr)) {
24464       int result;
24465       Tcl_Obj *methodPathObj;
24466 
24467       methodPathObj = NsfMethodNamePath(interp,
24468                                         CallStackGetTclFrame(interp, NULL, 0),
24469                                         NsfMethodName(procNameObj));
24470       INCR_REF_COUNT(methodPathObj);
24471       result = NsfUnexpectedArgumentError(interp, ObjStr(argumentObj), (Nsf_Object*)object,
24472                                         paramPtr, methodPathObj);
24473       DECR_REF_COUNT(methodPathObj);
24474       return result;
24475     }
24476 
24477     if (*currentParamPtr->name == '-') {
24478       /*
24479        * We expect a non-pos arg. Check whether we a Tcl_Obj already converted
24480        * to NsfFlagObjType.
24481        */
24482       NsfFlag *flagPtr = argumentObj->internalRep.twoPtrValue.ptr1;
24483 
24484 #if defined(PARSE_TRACE_FULL)
24485       fprintf(stderr, "... arg %p %s expect non-pos arg in block %s isFlag %d sig %d serial %d (%d => %d)\n",
24486               argumentObj, ObjStr(argumentObj), currentParamPtr->name,
24487               argumentObj->typePtr == &NsfFlagObjType,
24488               argumentObj->typePtr == &NsfFlagObjType ? flagPtr->signature == paramPtr : 0,
24489               argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial == serial : 0,
24490               argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial : 0,
24491               serial );
24492 #endif
24493 
24494       if (argumentObj->typePtr == &NsfFlagObjType
24495           && flagPtr->signature == paramPtr
24496           && flagPtr->serial == serial
24497           ) {
24498         /*
24499          * The argument was processed before and the Tcl_Obj is still valid.
24500          */
24501         if ((flagPtr->flags & NSF_FLAG_DASHDAH) != 0u) {
24502           /*
24503            * We got a dashDash, skip non-pos param definitions and continue with next
24504            * element from objv.
24505            */
24506           SkipNonposParamDefs(currentParamPtr);
24507           assert(!dashdash);
24508           continue;
24509         } else if ((flagPtr->flags & NSF_FLAG_CONTAINS_VALUE) != 0u) {
24510           /*
24511            * We got a flag with an embedded value (e.g. -flag=1).
24512            */
24513           valueInArgument = "flag";
24514         }
24515         pPtr = flagPtr->paramPtr;
24516         valueObj = flagPtr->payload;
24517 
24518       } else if ((argumentObj->typePtr == Nsf_OT_byteArrayType)
24519                  || (argumentObj->typePtr == Nsf_OT_properByteArrayType)
24520                  /*
24521                     || (argumentObj->typePtr == Nsf_OT_intType)
24522                     || (argumentObj->typePtr == Nsf_OT_doubleType)
24523                  */
24524                  ) {
24525         /*
24526          * The actual argument belongs to the types, for which we assume that
24527          * these can't belong to a non-pos flag.  The argument might be e.g. a
24528          * pure Tcl bytearray, for which we do not want to add a string rep
24529          * via ObjStr() such it loses its purity (Tcl 8.6). For these
24530          * argument types.  Proceed in the parameter vector to the next block
24531          * (positional parameter)
24532          */
24533         SkipNonposParamDefs(currentParamPtr);
24534         pPtr = currentParamPtr;
24535         /*
24536          * currentParamPtr is either NULL or points to a positional parameter
24537          */
24538         assert(currentParamPtr == NULL || currentParamPtr->name == NULL || *currentParamPtr->name != '-');
24539       } else {
24540         const char *argumentString = ObjStr(argumentObj);
24541         /*
24542          * We are in a state, where we expect a non-positional argument, and
24543          * the lookup from the Tcl_Obj has failed.  If this non-pos args are
24544          * optional, the current argument might contain also a value for a
24545          * positional argument maybe the argument is for a posarg
24546          * later). First check whether the argument looks like a flag.
24547          */
24548         if (argumentString[0] != '-') {
24549           /*
24550            * The actual argument is not a flag, so proceed in the parameter
24551            * vector to the next block (positional parameter)
24552            */
24553           SkipNonposParamDefs(currentParamPtr);
24554           pPtr = currentParamPtr;
24555           /*
24556            * currentParamPtr is either NULL or points to a positional parameter
24557            */
24558           assert(currentParamPtr == NULL || currentParamPtr->name == NULL || *currentParamPtr->name != '-');
24559 
24560         } else {
24561           /*
24562            * The actual argument starts with a dash, so search for the flag in
24563            * the current block of non-pos parameter definitions
24564            */
24565           char ch1 = *(argumentString+1);
24566 
24567           /*
24568            * Is there a "--" ?
24569            */
24570           if (ch1 == '-' && *(argumentString+2) == '\0' && !dashdash) {
24571             dashdash = NSF_TRUE;
24572             NsfFlagObjSet(interp, argumentObj, paramPtr, serial,
24573                           NULL, NULL, NSF_FLAG_DASHDAH);
24574             SkipNonposParamDefs(currentParamPtr);
24575             continue;
24576           }
24577 
24578           valueInArgument = strchr(argumentString, '=');
24579           if (valueInArgument != NULL) {
24580             bool   found = NSF_FALSE;
24581             long   equalOffset = valueInArgument - argumentString;
24582 
24583             /*
24584              * Handle parameter like -flag=1
24585              */
24586             for (; (pPtr <= lastParamPtr) && (*pPtr->name == '-'); pPtr++) {
24587               if (pPtr->nrArgs > 0) {
24588                 /*
24589                  * Parameter expects no arg, can't be this.
24590                  */
24591                 continue;
24592               }
24593               if ((pPtr->flags & NSF_ARG_NOCONFIG) == 0u
24594                   && ch1 == pPtr->name[1]
24595                   && strncmp(argumentString, pPtr->name, (size_t)equalOffset) == 0
24596                   && *(pPtr->name+equalOffset) == '\0') {
24597 
24598                 valueObj = Tcl_NewStringObj(valueInArgument+1, -1);
24599                 /*fprintf(stderr, "... value from argument = %s\n", ObjStr(valueObj));*/
24600                 NsfFlagObjSet(interp, argumentObj, paramPtr, serial,
24601                               pPtr, valueObj, NSF_FLAG_CONTAINS_VALUE);
24602                 found = NSF_TRUE;
24603                 break;
24604               }
24605             }
24606             if (!found) {
24607               const Nsf_Param *nextParamPtr = NextParam(currentParamPtr, lastParamPtr);
24608 
24609               if (nextParamPtr > lastParamPtr
24610                   || ((nextParamPtr->flags & NSF_ARG_NODASHALNUM) != 0u)) {
24611                 int result;
24612                 Tcl_Obj *methodPathObj= NsfMethodNamePath(interp,
24613                                                           CallStackGetTclFrame(interp, NULL, 0),
24614                                                           NsfMethodName(procNameObj));
24615                 INCR_REF_COUNT(methodPathObj);
24616                 result = NsfUnexpectedNonposArgumentError(interp, argumentString,
24617                                                           (Nsf_Object *)object,
24618                                                           currentParamPtr, paramPtr,
24619                                                           methodPathObj);
24620                 DECR_REF_COUNT(methodPathObj);
24621                 return result;
24622               }
24623               pPtr = currentParamPtr = nextParamPtr;
24624             }
24625           } else {
24626             /*
24627              * Must be a classical non-pos arg; check for a matching parameter
24628              * definition.
24629              */
24630             bool found = NSF_FALSE;
24631 
24632             assert(pPtr == currentParamPtr);
24633 
24634             if (likely(ch1 != '\0')) {
24635               if (unlikely(NsfParamDefsNonposLookup(interp, argumentString, currentParamPtr, &pPtr) != TCL_OK)) {
24636                 return TCL_ERROR;
24637               } else {
24638                 if (pPtr != NULL) {
24639                   found = NSF_TRUE;
24640                   NsfFlagObjSet(interp, argumentObj, paramPtr, serial, pPtr, NULL, 0u);
24641                 }
24642               }
24643             }
24644 
24645             /*
24646              * We might have found the argument starting with the dash in the
24647              * parameter definitions or not. If it was not found, then we can
24648              * advance to the next positional parameter and stuff the value in
24649              * there, if the parameter definition allows this.
24650              */
24651             if (!found) {
24652               int nonposArgError = 0;
24653               const Nsf_Param *nextParamPtr = NextParam(currentParamPtr, lastParamPtr);
24654 
24655               /*fprintf(stderr, "non-pos-arg '%s' not found, current %p %s last %p %s next %p %s\n",
24656                       argumentString,
24657                       currentParamPtr,  currentParamPtr->name,
24658                       lastParamPtr, lastParamPtr->name,
24659                       nextParamPtr, nextParamPtr->name);*/
24660 
24661               if (nextParamPtr > lastParamPtr) {
24662                 nonposArgError = 1;
24663               } else if ((nextParamPtr->flags & NSF_ARG_NODASHALNUM) != 0u) {
24664                 /*
24665                  * Check whether argument is numeric, since we want to allow it as
24666                  * value even when NSF_ARG_NODASHALNUM was specified.
24667                  */
24668                 nonposArgError = 1;
24669 
24670                 if (argumentString[1] >= '0' && argumentString[1] <= '9') {
24671                   char *p;
24672 
24673                   (void)strtod(&argumentString[1], &p);
24674                   if (*p == '\0') {
24675                     /*
24676                      * Argument is numeric.
24677                      */
24678                     nonposArgError = 0;
24679                   }
24680                 }
24681               }
24682 
24683               if (nonposArgError != 0) {
24684                 int result;
24685                 Tcl_Obj *methodPathObj = NsfMethodNamePath(interp,
24686                                                            CallStackGetTclFrame(interp, NULL, 0),
24687                                                            NsfMethodName(procNameObj));
24688                 INCR_REF_COUNT(methodPathObj);
24689                 result = NsfUnexpectedNonposArgumentError(interp, argumentString,
24690                                                           (Nsf_Object *)object,
24691                                                           currentParamPtr, paramPtr,
24692                                                           methodPathObj);
24693                 DECR_REF_COUNT(methodPathObj);
24694                 return result;
24695               }
24696               pPtr = currentParamPtr = nextParamPtr;
24697             }
24698           }
24699         }
24700         /* end of lookup loop */
24701       }
24702     } else {
24703       valueInArgument = NULL;
24704     }
24705 
24706     assert(pPtr != NULL);
24707     /*
24708      * "pPtr" points to the actual parameter (part of the currentParamPtr
24709      * block) or might point to a place past the last parameter, in which case
24710      * an unexpected argument was provided. "o" is the index of the actual
24711      * parameter, "valueObj" might be already provided for valueInArgument.
24712      */
24713     if (unlikely(pPtr > lastParamPtr)) {
24714       int      result;
24715       Tcl_Obj *methodPathObj;
24716 
24717       methodPathObj = NsfMethodNamePath(interp, CallStackGetTclFrame(interp, NULL, 0),
24718                                         NsfMethodName(procNameObj));
24719       INCR_REF_COUNT(methodPathObj);
24720       /*fprintf(stderr, "call NsfUnexpectedArgumentError 2\n");*/
24721       result = NsfUnexpectedArgumentError(interp, ObjStr(argumentObj),
24722                                         (Nsf_Object *)object, paramPtr,
24723                                         methodPathObj);
24724       DECR_REF_COUNT(methodPathObj);
24725       return result;
24726     }
24727 
24728     /*
24729      * Set the position in the downstream argv (normalized order)
24730      */
24731     j = pPtr - paramPtr;
24732 
24733 #if defined(PARSE_TRACE_FULL)
24734     fprintf(stderr, "... pPtr->name %s/%d o %d objc %d\n", pPtr->name, pPtr->nrArgs, o, objc);
24735 #endif
24736     if (*pPtr->name == '-') {
24737       /*
24738        * Process the non-pos arg.
24739        */
24740       if (pPtr->nrArgs == 1) {
24741         /*
24742          * The non-pos arg expects an argument.
24743          */
24744         o++;
24745         if (unlikely(o >= objc)) {
24746           /*
24747            * We expect an argument, but we are already at the end of the
24748            * argument list.
24749            */
24750           return NsfPrintError(interp, "value for parameter '%s' expected", pPtr->name);
24751         }
24752         assert(valueObj == NULL);
24753         valueObj = objv[o];
24754       } else {
24755         /*
24756          * The non-pos arg expects no argument.
24757          */
24758         if (valueObj == NULL) {
24759           valueObj = NsfGlobalObjs[NSF_ONE];
24760         }
24761       }
24762 
24763     } else if (unlikely((pPtr == lastParamPtr)
24764                         && (pPtr->converter == ConvertToNothing))) {
24765       /*
24766        * "args" was given, use the varargs interface.  Store the actual
24767        * argument into pcPtr->objv. No checking is performed on "args".
24768        */
24769       pcPtr->varArgs = NSF_TRUE;
24770       pcPtr->objv[j] = argumentObj;
24771 
24772 
24773 #if defined(PARSE_TRACE_FULL)
24774       fprintf(stderr, "... args found o %d objc %d is dashdash %d [%ld] <%s>\n",
24775               o, objc, (int)dashdash, j, ObjStr(argumentObj));
24776 #endif
24777       break;
24778 
24779     } else {
24780       /*
24781        * Process an ordinary positional argument.
24782        */
24783       currentParamPtr ++;
24784 
24785 #if defined(PARSE_TRACE_FULL)
24786       fprintf(stderr, "... positional arg o %d objc %d, nrArgs %d next paramPtr %s\n",
24787               o, objc, pPtr->nrArgs, currentParamPtr->name);
24788 #endif
24789 
24790       if (unlikely(pPtr->nrArgs == 0)) {
24791         /*
24792          * Allow positional arguments with 0 args for object parameter
24793          * aliases, which are always fired. Such parameter are non-consuming,
24794          * therefore the processing of the current argument is not finished, we
24795          * have to decrement o. We have to check here if we are already at the
24796          * end if the parameter vector.
24797          */
24798         o--;
24799         continue;
24800       }
24801       if (unlikely(dashdash)) {
24802         /*
24803          * Reset dashdash.
24804          */
24805         dashdash = NSF_FALSE;
24806       }
24807 
24808       valueObj = argumentObj;
24809     }
24810 
24811 #if defined(PARSE_TRACE_FULL)
24812     fprintf(stderr, "... setting parameter %s pos %ld valueObj '%s'\n",
24813             pPtr->name, j,
24814             valueObj == argumentObj ? "=" : ObjStr(valueObj));
24815 #endif
24816 
24817     /*
24818      * The value for the flag is now in the valueObj. We
24819      * check, whether it is value is permissible.
24820      */
24821     assert(valueObj != NULL);
24822 
24823     if (unlikely(ArgumentCheck(interp, valueObj, pPtr, processFlags,
24824                                &pcPtr->flags[j],
24825                                &pcPtr->clientData[j],
24826                                &pcPtr->objv[j]) != TCL_OK)) {
24827       if (pcPtr->flags[j] & NSF_PC_MUST_DECR) {
24828         pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
24829       }
24830       return TCL_ERROR;
24831     }
24832 
24833     /*
24834      * Switches are more tricky: if the flag is provided without
24835      * valueInArgument, we take the default and invert it. If valueInArgument
24836      * was used, the default inversion must not happen.
24837      */
24838     if (likely(valueInArgument == NULL)) {
24839       if (unlikely(pPtr->converter == Nsf_ConvertToSwitch)) {
24840         /*fprintf(stderr, "... set INVERT_DEFAULT for '%s' flags %.6x\n",
24841           pPtr->name, pPtr->flags);*/
24842         assert(pPtr->defaultValue != NULL);
24843         pcPtr->flags[j] |= NSF_PC_INVERT_DEFAULT;
24844       }
24845     }
24846 
24847     /*fprintf(stderr, "... non-positional pcPtr %p check [%d] obj %p flags %.6x & %p\n",
24848       pcPtr, j, pcPtr->objv[j], pcPtr->flags[j], &(pcPtr->flags[j]));        */
24849 
24850     /*
24851      * Provide warnings for double-settings.
24852      */
24853     if (unlikely((pcPtr->flags[j] & NSF_ARG_SET) != 0u)) {
24854       Tcl_Obj *cmdLineObj = Tcl_NewListObj(objc-1, objv+1);
24855 
24856       INCR_REF_COUNT(cmdLineObj);
24857       NsfLog(interp, NSF_LOG_WARN, "Non-positional parameter %s was passed more than once (%s%s%s %s)",
24858              pPtr->name, (object != NULL) ? ObjectName(object) : "", (object != NULL) ? " method " : "",
24859              ObjStr(procNameObj), ObjStr(cmdLineObj));
24860       DECR_REF_COUNT(cmdLineObj);
24861     }
24862     pcPtr->flags[j] |= NSF_ARG_SET;
24863 
24864     /*
24865      * Embed error message of converter in current context.
24866      */
24867     if (unlikely((pcPtr->flags[j] & NSF_ARG_WARN) != 0u)) {
24868       Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
24869       Tcl_DString ds, *dsPtr = &ds;
24870 
24871       Tcl_DStringInit(dsPtr);
24872       INCR_REF_COUNT(resultObj);
24873       NsfDStringArgv(dsPtr, objc, objv);
24874       NsfLog(interp, NSF_LOG_WARN, "%s during:\n%s %s",
24875              ObjStr(resultObj), (object != NULL) ? ObjectName(object) : "nsf::proc", Tcl_DStringValue(dsPtr));
24876       DECR_REF_COUNT(resultObj);
24877       Tcl_DStringFree(dsPtr);
24878     }
24879 
24880     if (unlikely((pcPtr->flags[j] & NSF_PC_MUST_DECR) != 0u)) {
24881       pcPtr->status |= NSF_PC_STATUS_MUST_DECR;
24882     }
24883 
24884     assert(!pcPtr->varArgs);
24885 
24886 #if defined(PARSE_TRACE_FULL)
24887     fprintf(stderr, "... iterate on o %d objc %d, currentParamPtr %s\n",
24888             o, objc, currentParamPtr->name);
24889 #endif
24890   }
24891 
24892   if ((currentParamPtr <= lastParamPtr) && (!pcPtr->varArgs)) {
24893     /*
24894      * Not all parameter processed, make sure varags is set.
24895      */
24896 
24897     /*fprintf(stderr, ".... not all parms processed, pPtr '%s' j %ld nrParams %d last '%s' varArgs %d dashdash %d\n",
24898             currentParamPtr->name, currentParamPtr - paramPtr, nrParams, lastParamPtr->name,
24899             pcPtr->varArgs, (int)dashdash);*/
24900 
24901     if (lastParamPtr->converter == ConvertToNothing) {
24902       pcPtr->varArgs = NSF_TRUE;
24903     }
24904   }
24905 
24906   /*
24907    * Set lastObjc as index of the first "unprocessed" parameter.
24908    */
24909   pcPtr->lastObjc = o;
24910   pcPtr->objc = nrParams;
24911 
24912   assert(ISOBJ(objv[pcPtr->lastObjc-1]));
24913 
24914 #if defined(PARSE_TRACE_FULL)
24915   fprintf(stderr, "..... argv processed o %d lastObjc %d nrParams %d o<objc %d varargs %d\n",
24916           o, pcPtr->lastObjc, nrParams, o<objc, pcPtr->varArgs);
24917 #endif
24918 
24919   return ArgumentDefaults(pcPtr, interp, paramPtr, nrParams, processFlags);
24920 }
24921 
24922 /***********************************
24923  * Begin result setting commands
24924  * (essentially List*() and support
24925  ***********************************/
24926 /*
24927  *----------------------------------------------------------------------
24928  * ListVarKeys --
24929  *
24930  *    Return variable names of the provided hash table in the interp
24931  *    result. Optionally "pattern" might be used to filter the result list.
24932  *
24933  * Results:
24934  *    Standard Tcl result
24935  *
24936  * Side effects:
24937  *    Modifies interp result
24938  *
24939  *----------------------------------------------------------------------
24940  */
24941 static int ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, const char *pattern)
24942   nonnull(1);
24943 
24944 static int
ListVarKeys(Tcl_Interp * interp,Tcl_HashTable * tablePtr,const char * pattern)24945 ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, const char *pattern) {
24946   const Tcl_HashEntry *hPtr;
24947 
24948   nonnull_assert(interp != NULL);
24949 
24950   if (pattern != NULL && NoMetaChars(pattern)) {
24951     Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1);
24952 
24953     INCR_REF_COUNT(patternObj);
24954     hPtr = (tablePtr != NULL) ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : NULL;
24955     if (hPtr != NULL) {
24956       const Var *val = TclVarHashGetValue(hPtr);
24957 
24958       Tcl_SetObjResult(interp, TclVarHashGetKey(val));
24959     } else {
24960       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
24961     }
24962     DECR_REF_COUNT(patternObj);
24963 
24964   } else {
24965     Tcl_Obj       *list = Tcl_NewListObj(0, NULL);
24966     Tcl_HashSearch hSrch;
24967 
24968     hPtr = (tablePtr != NULL) ? Tcl_FirstHashEntry(tablePtr, &hSrch) : NULL;
24969     for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSrch)) {
24970       const Var *val = TclVarHashGetValue(hPtr);
24971       Tcl_Obj   *key = TclVarHashGetKey(val);
24972 
24973       if (pattern == NULL || Tcl_StringMatch(ObjStr(key), pattern)) {
24974         Tcl_ListObjAppendElement(interp, list, key);
24975       }
24976     }
24977     Tcl_SetObjResult(interp, list);
24978   }
24979   return TCL_OK;
24980 }
24981 
24982 /*
24983  *----------------------------------------------------------------------
24984  * GetOriginalCommand --
24985  *
24986  *    Obtain for an imported/aliased cmd the original definition.
24987  *
24988  * Results:
24989  *    Tcl command
24990  *
24991  * Side effects:
24992  *    none
24993  *
24994  *----------------------------------------------------------------------
24995  */
24996 static Tcl_Command
GetOriginalCommand(Tcl_Command cmd)24997 GetOriginalCommand(
24998     Tcl_Command cmd  /* The imported command for which the original
24999                       * command should be returned.
25000                       */
25001 ) {
25002   Tcl_Command importedCmd;
25003 
25004   nonnull_assert(cmd != NULL);
25005 
25006   while (1) {
25007     AliasCmdClientData *tcd;
25008 
25009     /*
25010      * Dereference the namespace import reference chain
25011      */
25012     if ((importedCmd = TclGetOriginalCommand(cmd))) {
25013       cmd = importedCmd;
25014     }
25015     /*
25016      * Dereference the Next Scripting alias chain
25017      */
25018     if (Tcl_Command_deleteProc(cmd) == AliasCmdDeleteProc) {
25019       tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd);
25020       /*
25021         fprintf(stderr, "... GetOriginalCommand finds alias %s -> %s\n",
25022         Tcl_GetCommandName(NULL, cmd), Tcl_GetCommandName(NULL, tcd->aliasedCmd));
25023       */
25024       cmd = tcd->aliasedCmd;
25025       continue;
25026     }
25027     /*
25028      * Dereference the Next Scripting alias chain via potential proc contexts,
25029      * since we identify the alias reference on the AliasCmdDeleteProc.
25030      */
25031     if (Tcl_Command_deleteProc(cmd) == NsfProcDeleteProc
25032        && Tcl_Command_objProc(cmd) == NsfProcAliasMethod) {
25033       NsfProcContext *ctxPtr = Tcl_Command_deleteData(cmd);
25034 
25035       if (ctxPtr->oldDeleteProc == AliasCmdDeleteProc) {
25036         tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd);
25037 
25038         /*
25039            fprintf(stderr, "... GetOriginalCommand finds alias via oldDeleteProc %s -> %s (%p -> %p)\n",
25040            Tcl_GetCommandName(NULL, cmd), Tcl_GetCommandName(NULL, tcd->aliasedCmd),
25041            (void*)cmd, (void*)tcd->aliasedCmd  );
25042            char *name =Tcl_GetCommandName(NULL, cmd);
25043            if (!strcmp("incr", name)) {char *p = NULL; *p=1;}
25044         */
25045 
25046         cmd = tcd->aliasedCmd;
25047         continue;
25048       }
25049     }
25050     break;
25051   }
25052 
25053   return cmd;
25054 }
25055 
25056 /*
25057  *----------------------------------------------------------------------
25058  * ListProcBody --
25059  *
25060  *    Return the body of a scripted proc as Tcl interp result.
25061  *
25062  * Results:
25063  *    Standard Tcl result
25064  *
25065  * Side effects:
25066  *    Modifies interp result
25067  *
25068  *----------------------------------------------------------------------
25069  */
25070 static int ListProcBody(Tcl_Interp *interp, Proc *procPtr)
25071   nonnull(1) nonnull(2);
25072 
25073 static int
ListProcBody(Tcl_Interp * interp,Proc * procPtr)25074 ListProcBody(Tcl_Interp *interp, Proc *procPtr) {
25075   const char *body;
25076 
25077   nonnull_assert(interp != NULL);
25078   nonnull_assert(procPtr != NULL);
25079 
25080   body = ObjStr(procPtr->bodyPtr);
25081   Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1));
25082   return TCL_OK;
25083 }
25084 
25085 /*
25086  *----------------------------------------------------------------------
25087  * ListParamDefs --
25088  *
25089  *    Compute the parameter definition in one of four different forms.
25090  *
25091  * Results:
25092  *    Standard Tcl result
25093  *
25094  * Side effects:
25095  *    Modifies interp result
25096  *
25097  *----------------------------------------------------------------------
25098  */
25099 static Tcl_Obj *ListParamDefs(Tcl_Interp *interp, const Nsf_Param *paramsPtr,
25100                               NsfObject *contextObject, const char *pattern,
25101                               NsfParamsPrintStyle style)
25102   nonnull(1) nonnull(2) returns_nonnull;
25103 
25104 static Tcl_Obj *
ListParamDefs(Tcl_Interp * interp,const Nsf_Param * paramsPtr,NsfObject * contextObject,const char * pattern,NsfParamsPrintStyle style)25105 ListParamDefs(Tcl_Interp *interp, const Nsf_Param *paramsPtr,
25106               NsfObject *contextObject,  const char *pattern,
25107               NsfParamsPrintStyle style) {
25108   Tcl_Obj *listObj;
25109 
25110   nonnull_assert(interp != NULL);
25111   nonnull_assert(paramsPtr != NULL);
25112 
25113   switch (style) {
25114   case NSF_PARAMS_PARAMETER: listObj = ParamDefsFormat(interp, paramsPtr, contextObject, pattern); break;
25115   case NSF_PARAMS_LIST:      listObj = ParamDefsList(interp, paramsPtr, contextObject, pattern);   break;
25116   case NSF_PARAMS_NAMES:     listObj = ParamDefsNames(interp, paramsPtr, contextObject, pattern);  break;
25117   case NSF_PARAMS_SYNTAX:    listObj = NsfParamDefsSyntax(interp, paramsPtr, contextObject, pattern); break;
25118   default:                   listObj = NULL; assert(0); /*should never happen */; break;
25119   }
25120 
25121   return listObj;
25122 }
25123 
25124 /*
25125  *----------------------------------------------------------------------
25126  * ListCmdParams --
25127  *
25128  *    Obtains a cmd and a method name. As a side effect, sets the Tcl interp
25129  *    result to a list of parameter definitions, if available. The print-style
25130  *    NSF_PARAMS_NAMES, NSF_PARAMS_LIST, NSF_PARAMS_PARAMETER,
25131  *    NSF_PARAMS_SYNTAX controls the list content.
25132  *
25133  * Results:
25134  *    Tcl result code
25135  *
25136  * Side effects:
25137  *    Sets interp result
25138  *
25139  *----------------------------------------------------------------------
25140  */
25141 
25142 static int ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, NsfObject *contextObject,
25143                          const char *pattern, const char *methodName, NsfParamsPrintStyle printStyle)
25144   nonnull(1) nonnull(2) nonnull(5);
25145 
25146 static int
ListCmdParams(Tcl_Interp * interp,Tcl_Command cmd,NsfObject * contextObject,const char * pattern,const char * methodName,NsfParamsPrintStyle printStyle)25147 ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd,  NsfObject *contextObject,
25148                 const char *pattern, const char *methodName, NsfParamsPrintStyle printStyle) {
25149   NsfParamDefs *paramDefs;
25150   Tcl_Obj      *listObj;
25151   Proc         *procPtr;
25152   int           result = TCL_OK;
25153 
25154   nonnull_assert(interp != NULL);
25155   nonnull_assert(methodName != NULL);
25156   nonnull_assert(cmd != NULL);
25157 
25158   paramDefs = ParamDefsGet(cmd, NULL, NULL);
25159 
25160   if (paramDefs != NULL && paramDefs->paramsPtr != NULL) {
25161     /*
25162      * Obtain parameter info from paramDefs.
25163      */
25164     listObj = ListParamDefs(interp, paramDefs->paramsPtr, contextObject, pattern, printStyle);
25165     Tcl_SetObjResult(interp, listObj);
25166     DECR_REF_COUNT2("paramDefsObj", listObj);
25167     return TCL_OK;
25168   }
25169 
25170   procPtr = GetTclProcFromCommand(cmd);
25171   if (procPtr != NULL) {
25172     /*
25173      * Obtain parameter info from compiled locals.
25174      */
25175     CompiledLocal *args = procPtr->firstLocalPtr;
25176 
25177     listObj = Tcl_NewListObj(0, NULL);
25178     for ( ; args; args = args->nextPtr) {
25179 
25180       if (!TclIsCompiledLocalArgument(args)) {
25181         continue;
25182       }
25183       if (pattern != NULL && !Tcl_StringMatch(args->name, pattern)) {
25184         continue;
25185       }
25186 
25187       if (printStyle == NSF_PARAMS_SYNTAX && strcmp(args->name, "args") == 0) {
25188         if (args != procPtr->firstLocalPtr) {
25189           Tcl_AppendToObj(listObj, " ", 1);
25190         }
25191         Tcl_AppendToObj(listObj, "?/arg .../?", 11);
25192       } else {
25193         if (printStyle == NSF_PARAMS_SYNTAX) {
25194           /*
25195            * A default means that the argument is optional.
25196            */
25197           if (args->defValuePtr != NULL) {
25198             Tcl_AppendToObj(listObj, "?", 1);
25199             Tcl_AppendToObj(listObj, args->name, -1);
25200             Tcl_AppendToObj(listObj, "?", 1);
25201           } else {
25202             Tcl_AppendToObj(listObj, "/", 1);
25203             Tcl_AppendToObj(listObj, args->name, -1);
25204             Tcl_AppendToObj(listObj, "/", 1);
25205           }
25206           if (args->nextPtr != NULL) {
25207             Tcl_AppendToObj(listObj, " ", 1);
25208           }
25209         } else {
25210           Tcl_Obj *innerListObj = Tcl_NewListObj(0, NULL);
25211 
25212           Tcl_ListObjAppendElement(interp, innerListObj, Tcl_NewStringObj(args->name, -1));
25213           /*
25214            * Return default just for NSF_PARAMS_PARAMETER.
25215            */
25216           if ((args->defValuePtr != NULL) && (printStyle == NSF_PARAMS_PARAMETER)) {
25217             Tcl_ListObjAppendElement(interp, innerListObj, args->defValuePtr);
25218           }
25219           Tcl_ListObjAppendElement(interp, listObj, innerListObj);
25220         }
25221       }
25222     }
25223 
25224     Tcl_SetObjResult(interp, listObj);
25225     return TCL_OK;
25226   }
25227 
25228   {
25229     /*
25230      * If a command is not found for the object|class, check whether we
25231      * find the parameter definitions for the C-defined method.
25232      */
25233     Nsf_methodDefinition *mdPtr = Nsf_CmdDefinitionGet(((Command *)cmd)->objProc);
25234     if (mdPtr != NULL) {
25235       NsfParamDefs localParamDefs = {mdPtr->paramDefs, mdPtr->nrParameters, 1, 0};
25236       Tcl_Obj     *list = ListParamDefs(interp, localParamDefs.paramsPtr, contextObject, pattern, printStyle);
25237 
25238       Tcl_SetObjResult(interp, list);
25239       DECR_REF_COUNT2("paramDefsObj", list);
25240       return TCL_OK;
25241     }
25242   }
25243 
25244   if (((Command *)cmd)->objProc == NsfSetterMethod) {
25245     SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd);
25246 
25247     if (cd != NULL && cd->paramsPtr) {
25248       NsfParamDefs localParamDefs;
25249       Tcl_Obj     *list;
25250 
25251       localParamDefs.paramsPtr = cd->paramsPtr;
25252       /*localParamDefs.nrParams = 1;*/
25253       list = ListParamDefs(interp, localParamDefs.paramsPtr, contextObject, pattern, printStyle);
25254       Tcl_SetObjResult(interp, list);
25255       DECR_REF_COUNT2("paramDefsObj", list);
25256     } else {
25257       Tcl_SetObjResult(interp, Tcl_NewStringObj(methodName, -1));
25258     }
25259     return TCL_OK;
25260   }
25261 
25262   /*
25263    * In case, we failed so far to obtain a result, try to use the
25264    * object-system implementors definitions in the global array
25265    * ::nsf::parametersyntax. Note that we can only obtain the
25266    * parameter syntax this way.
25267    */
25268   if (printStyle == NSF_PARAMS_SYNTAX) {
25269     Tcl_DString ds, *dsPtr = &ds;
25270     Tcl_Obj *parameterSyntaxObj;
25271 
25272     Tcl_DStringInit(dsPtr);
25273     DStringAppendQualName(dsPtr, Tcl_Command_nsPtr(cmd), methodName);
25274     /*fprintf(stderr, "Looking up ::nsf::parametersyntax(%s) ...\n", Tcl_DStringValue(dsPtr));*/
25275     parameterSyntaxObj = Tcl_GetVar2Ex(interp, NsfGlobalStrings[NSF_ARRAY_PARAMETERSYNTAX],
25276                                        Tcl_DStringValue(dsPtr), TCL_GLOBAL_ONLY);
25277 
25278     /*fprintf(stderr, "No parametersyntax so far methodName %s cmd name %s ns %s\n",
25279       methodName, Tcl_GetCommandName(interp, cmd), Tcl_DStringValue(dsPtr));*/
25280 
25281     Tcl_DStringFree(dsPtr);
25282     if (parameterSyntaxObj != NULL) {
25283       Tcl_SetObjResult(interp, parameterSyntaxObj);
25284       return TCL_OK;
25285     }
25286   }
25287 
25288   if (Tcl_Command_objProc(cmd) == NsfForwardMethod) {
25289     result = NsfPrintError(interp, "could not obtain parameter definition for forwarder '%s'",
25290                            methodName);
25291 
25292   } else if (CmdIsNsfObject(cmd)) {
25293     /* procPtr == NsfObjDispatch:
25294 
25295        Reached for:
25296        ... ensemble objects
25297        ... plain objects
25298      */
25299   } else if (Tcl_Command_objProc(cmd) == NsfProcStub) {
25300     /*
25301      * Reached for C-implemented Tcl command procs.
25302      */
25303 
25304   } else {
25305     /*
25306      * Reached for other C-implemented command procs.
25307      */
25308     result = NsfPrintError(interp, "could not obtain parameter definition for method '%s'", methodName);
25309   }
25310   return result;
25311 }
25312 
25313 
25314 /*
25315  *----------------------------------------------------------------------
25316  * AppendForwardDefinition --
25317  *
25318  *    Append the parameters of a forward definition to the specified listObj.
25319  *
25320  * Results:
25321  *    None.
25322  *
25323  * Side effects:
25324  *    Appending to listObj
25325  *
25326  *----------------------------------------------------------------------
25327  */
25328 static void AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd)
25329   nonnull(1) nonnull(2) nonnull(3);
25330 
25331 static void
AppendForwardDefinition(Tcl_Interp * interp,Tcl_Obj * listObj,ForwardCmdClientData * tcd)25332 AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd) {
25333 
25334   nonnull_assert(interp != NULL);
25335   nonnull_assert(listObj != NULL);
25336   nonnull_assert(tcd != NULL);
25337 
25338   if (tcd->prefix != NULL) {
25339     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-prefix", -1));
25340     Tcl_ListObjAppendElement(interp, listObj, tcd->prefix);
25341   }
25342   if (tcd->subcommands != NULL) {
25343     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-default", -1));
25344     Tcl_ListObjAppendElement(interp, listObj, tcd->subcommands);
25345   }
25346   if (tcd->objProc != NULL) {
25347     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-earlybinding", -1));
25348   }
25349   if (tcd->frame == FrameObjectIdx) {
25350     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-frame", 6));
25351     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
25352   }
25353   Tcl_ListObjAppendElement(interp, listObj, tcd->cmdName);
25354 
25355   if (tcd->args != NULL) {
25356     Tcl_Obj **args;
25357     int nrArgs, i;
25358 
25359     Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args);
25360     for (i = 0; i < nrArgs; i++) {
25361       Tcl_ListObjAppendElement(interp, listObj, args[i]);
25362     }
25363   }
25364 }
25365 
25366 /*
25367  *----------------------------------------------------------------------
25368  * AppendMethodRegistration --
25369  *
25370  *    Append to the listObj the command words needed for definition /
25371  *    registration.
25372  *
25373  * Results:
25374  *    None.
25375  *
25376  * Side effects:
25377  *    Appending to listObj
25378  *
25379  *----------------------------------------------------------------------
25380  */
25381 
25382 static void AppendMethodRegistration(Tcl_Interp *interp, Tcl_Obj *listObj, const char *registerCmdName,
25383                                      NsfObject *object, const char *methodName, Tcl_Command cmd,
25384                                      bool withObjFrame, bool withPer_object, int withProtection)
25385   nonnull(1) nonnull(2) nonnull(3) nonnull(4) nonnull(5) nonnull(6);
25386 
25387 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)25388 AppendMethodRegistration(Tcl_Interp *interp, Tcl_Obj *listObj, const char *registerCmdName,
25389                          NsfObject *object, const char *methodName, Tcl_Command cmd,
25390                          bool withObjFrame, bool withPer_object, int withProtection) {
25391 
25392   nonnull_assert(interp != NULL);
25393   nonnull_assert(listObj != NULL);
25394   nonnull_assert(registerCmdName != NULL);
25395   nonnull_assert(object != NULL);
25396   nonnull_assert(methodName != NULL);
25397   nonnull_assert(cmd != NULL);
25398 
25399   Tcl_ListObjAppendElement(interp, listObj, object->cmdName);
25400   if (withProtection != CallprotectionNULL) {
25401     Tcl_ListObjAppendElement(interp, listObj,
25402                              (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD) != 0)
25403                              ? Tcl_NewStringObj("private", 7)
25404                              : (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CALL_PROTECTED_METHOD) != 0)
25405                              ? Tcl_NewStringObj("protected", 9)
25406                              : Tcl_NewStringObj("public", 6));
25407   }
25408 
25409   if (!NsfObjectIsClass(object) || withPer_object) {
25410     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
25411   }
25412   Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(registerCmdName, -1));
25413   Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(methodName, -1));
25414 
25415   if (withObjFrame) {
25416     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-frame", 6));
25417     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("object", 6));
25418   }
25419   if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_NONLEAF_METHOD) != 0) {
25420     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-frame", 6));
25421     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("method", 6));
25422   }
25423 }
25424 
25425 /*
25426  *----------------------------------------------------------------------
25427  * AppendReturnsClause --
25428  *
25429  *    Append to the listObj a returns clause, if it was specified for the
25430  *    current cmd.
25431  *
25432  * Results:
25433  *    None.
25434  *
25435  * Side effects:
25436  *    Appending to listObj
25437  *
25438  *----------------------------------------------------------------------
25439  */
25440 
25441 static void AppendReturnsClause(Tcl_Interp *interp, Tcl_Obj *listObj, Tcl_Command cmd)
25442   nonnull(1) nonnull(2) nonnull(3);
25443 
25444 static void
AppendReturnsClause(Tcl_Interp * interp,Tcl_Obj * listObj,Tcl_Command cmd)25445 AppendReturnsClause(Tcl_Interp *interp, Tcl_Obj *listObj, Tcl_Command cmd) {
25446   Tcl_Obj *returnsObj;
25447 
25448   nonnull_assert(interp != NULL);
25449   nonnull_assert(listObj != NULL);
25450   nonnull_assert(cmd != NULL);
25451 
25452   returnsObj = ParamDefsGetReturns(cmd);
25453   if (returnsObj != NULL) {
25454     /* TODO: avoid hard-coding the script-level/NX-specific keyword "-returns" */
25455     Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-returns", -1));
25456     Tcl_ListObjAppendElement(interp, listObj, returnsObj);
25457   }
25458 }
25459 
25460 static Tcl_Obj *DisassembleProc(Tcl_Interp *interp, Proc *procPtr,
25461                                 const char *procName, Namespace *nsPtr)
25462   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
25463 
DisassembleProc(Tcl_Interp * interp,Proc * procPtr,const char * procName,Namespace * nsPtr)25464 static Tcl_Obj *DisassembleProc(Tcl_Interp *interp, Proc *procPtr,
25465                                 const char *procName, Namespace *nsPtr) {
25466   unsigned int dummy = 0;
25467   Tcl_Obj *byteCodeObj = NULL;
25468 
25469   if ((procPtr->bodyPtr->typePtr == Nsf_OT_byteCodeType) ||
25470       (ByteCompiled(interp, &dummy, procPtr, nsPtr, procName) == TCL_OK)) {
25471     Tcl_Obj *ov[3];
25472 
25473     ov[0] = NULL;
25474     ov[1] = NsfGlobalObjs[NSF_SCRIPT];
25475     ov[2] = procPtr->bodyPtr;
25476 
25477     if ((NsfCallCommand(interp, NSF_DISASSEMBLE, 3, ov) == TCL_OK)) {
25478       byteCodeObj = Tcl_GetObjResult(interp);
25479     }
25480   }
25481 
25482   return byteCodeObj;
25483 }
25484 
25485 
25486 
25487 /*
25488  *----------------------------------------------------------------------
25489  * ListMethod --
25490  *
25491  *    Construct a command to regenerate the specified method. The method might
25492  *    be scripted or not (alias, forwarder, ...). The command is returned in
25493  *    the interp result.
25494  *
25495  * Results:
25496  *    Tcl result code.
25497  *
25498  * Side effects:
25499  *    Sets interp result
25500  *
25501  *----------------------------------------------------------------------
25502  */
25503 static int ListMethod(Tcl_Interp *interp,
25504                       NsfObject *regObject,
25505                       NsfObject *defObject,
25506                       const char *methodName,
25507                       Tcl_Command cmd,
25508                       InfomethodsubcmdIdx_t subcmd,
25509                       NsfObject *contextObject,
25510                       const char *pattern,
25511                       bool withPer_object)
25512   nonnull(1) nonnull(4) nonnull(5);
25513 
25514 static int ListDefinedMethods(Tcl_Interp *interp, NsfObject *object, const char *pattern,
25515                               bool withPer_object,
25516                               MethodtypeIdx_t methodType,
25517                               CallprotectionIdx_t withCallprotection,
25518                               bool withPath)
25519   nonnull(1) nonnull(2);
25520 
25521 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)25522 ListMethod(Tcl_Interp *interp,
25523            NsfObject *regObject,
25524            NsfObject *defObject,
25525            const char *methodName,
25526            Tcl_Command cmd,
25527            InfomethodsubcmdIdx_t subcmd,
25528            NsfObject *contextObject,
25529            const char *pattern,
25530            bool withPer_object) {
25531 
25532   Tcl_ObjCmdProc *objCmdProc;
25533   Proc           *procPtr;
25534   bool            outputPerObject;
25535   Tcl_Obj        *resultObj;
25536 
25537   nonnull_assert(interp != NULL);
25538   nonnull_assert(methodName != NULL);
25539   nonnull_assert(cmd != NULL);
25540 
25541   assert(*methodName != ':');
25542 
25543   Tcl_ResetResult(interp);
25544 
25545   if (regObject != NULL && !NsfObjectIsClass(regObject)) {
25546     withPer_object = 1;
25547     /*
25548      * Don't output "object" modifier, if regObject is not a class.
25549      */
25550     outputPerObject = NSF_FALSE;
25551   } else {
25552     outputPerObject = withPer_object;
25553   }
25554 
25555   switch (subcmd) {
25556   case InfomethodsubcmdRegistrationhandleIdx:
25557     {
25558       if (regObject != NULL) {
25559         Tcl_SetObjResult(interp, MethodHandleObj(regObject, withPer_object, methodName));
25560       }
25561       return TCL_OK;
25562     }
25563   case InfomethodsubcmdDefinitionhandleIdx:
25564     {
25565       if (defObject != NULL) {
25566         Tcl_SetObjResult(interp, MethodHandleObj(defObject,
25567                                                  NsfObjectIsClass(defObject) ? withPer_object : 1,
25568                                                  Tcl_GetCommandName(interp, cmd)));
25569       }
25570       return TCL_OK;
25571     }
25572   case InfomethodsubcmdExistsIdx:
25573     {
25574       Tcl_SetObjResult(interp, Tcl_NewIntObj((int)(!CmdIsNsfObject(cmd))));
25575       return TCL_OK;
25576     }
25577   case InfomethodsubcmdArgsIdx:
25578     {
25579       Tcl_Command importedCmd = GetOriginalCommand(cmd);
25580       return ListCmdParams(interp, importedCmd, contextObject, pattern, methodName, NSF_PARAMS_NAMES);
25581     }
25582   case InfomethodsubcmdParameterIdx:
25583     {
25584       Tcl_Command importedCmd = GetOriginalCommand(cmd);
25585       return ListCmdParams(interp, importedCmd, contextObject, pattern, methodName, NSF_PARAMS_PARAMETER);
25586     }
25587   case InfomethodsubcmdReturnsIdx:
25588     {
25589       Tcl_Obj *returnsObj = ParamDefsGetReturns(GetOriginalCommand(cmd));
25590 
25591       if (returnsObj != NULL) {
25592         Tcl_SetObjResult(interp, returnsObj);
25593       }
25594       return TCL_OK;
25595     }
25596   case InfomethodsubcmdSyntaxIdx:
25597     {
25598       Tcl_Command importedCmd = GetOriginalCommand(cmd);
25599       return ListCmdParams(interp, importedCmd, contextObject, pattern, methodName, NSF_PARAMS_SYNTAX);
25600     }
25601 
25602   case InfomethodsubcmdPreconditionIdx:
25603 #if defined(NSF_WITH_ASSERTIONS)
25604       if (regObject != NULL) {
25605         NsfProcAssertion *procs = NULL;
25606 
25607         if (withPer_object == 1) {
25608           if (regObject->opt != NULL && regObject->opt->assertions != NULL) {
25609             procs = AssertionFindProcs(regObject->opt->assertions, methodName);
25610           }
25611         } else {
25612           NsfClass *class = (NsfClass *)regObject;
25613           if (class->opt != NULL && class->opt->assertions != NULL) {
25614             procs = AssertionFindProcs(class->opt->assertions, methodName);
25615           }
25616         }
25617         if (procs != NULL) {
25618           Tcl_SetObjResult(interp, AssertionList(interp, procs->pre));
25619         }
25620       }
25621 #endif
25622       return TCL_OK;
25623 
25624 
25625   case InfomethodsubcmdPostconditionIdx:
25626 #if defined(NSF_WITH_ASSERTIONS)
25627       if (regObject != NULL) {
25628         NsfProcAssertion *procs = NULL;
25629 
25630         if (withPer_object == 1) {
25631           if (regObject->opt != NULL && regObject->opt->assertions != NULL) {
25632             procs = AssertionFindProcs(regObject->opt->assertions, methodName);
25633           }
25634         } else {
25635           NsfClass *class = (NsfClass *)regObject;
25636           if (class->opt != NULL && class->opt->assertions != NULL) {
25637             procs = AssertionFindProcs(class->opt->assertions, methodName);
25638           }
25639         }
25640         if (procs != NULL) {
25641           Tcl_SetObjResult(interp, AssertionList(interp, procs->post));
25642         }
25643       }
25644 #endif
25645       return TCL_OK;
25646 
25647   case InfomethodsubcmdSubmethodsIdx:
25648     {
25649       Tcl_Command origCmd = GetOriginalCommand(cmd);
25650 
25651       if (CmdIsNsfObject(origCmd)) {
25652         NsfObject *subObject = NsfGetObjectFromCmdPtr(origCmd);
25653         if (subObject != NULL) {
25654           return ListDefinedMethods(interp, subObject, NULL, NSF_TRUE /* per-object */,
25655                                     NSF_METHODTYPE_ALL, CallprotectionAllIdx, NSF_FALSE);
25656         }
25657       }
25658       /*
25659        * All other cases return empty.
25660        */
25661       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
25662       return TCL_OK;
25663     }
25664 
25665   case InfomethodsubcmdBodyIdx:        /* fall through */
25666   case InfomethodsubcmdOriginIdx:      /* fall through */
25667   case InfomethodsubcmdTypeIdx:        /* fall through */
25668   case InfomethodsubcmdDefinitionIdx:  /* fall through */
25669   case InfomethodsubcmdDisassembleIdx: /* fall through */
25670   case InfomethodsubcmdNULL:
25671     break;
25672   }
25673 
25674   objCmdProc = Tcl_Command_objProc(cmd);
25675   procPtr = GetTclProcFromCommand(cmd);
25676 
25677   /*
25678    * The subcommands differ per type of method. The converter in
25679    * InfoMethods defines the types:
25680    *
25681    *    all|scripted|builtin|alias|forwarder|object|setter|nsfproc
25682    */
25683   if (procPtr != NULL) {
25684     /*
25685      * A scripted method.
25686      */
25687     switch (subcmd) {
25688 
25689     case InfomethodsubcmdTypeIdx:
25690       if (regObject != NULL) {
25691         Tcl_SetObjResult(interp, Tcl_NewStringObj("scripted", -1));
25692       } else {
25693         Tcl_SetObjResult(interp, Tcl_NewStringObj("proc", -1));
25694       }
25695       break;
25696 
25697     case InfomethodsubcmdBodyIdx:
25698       ListProcBody(interp, procPtr);
25699       break;
25700 
25701     case InfomethodsubcmdDisassembleIdx:
25702     {
25703       Tcl_Namespace *nsPtr;
25704       NsfParamDefs  *paramDefs;
25705 
25706       paramDefs = ParamDefsGet(cmd, NULL, &nsPtr);
25707 
25708       if (paramDefs == NULL || nsPtr == NULL) {
25709         nsPtr = (Tcl_Namespace *)procPtr->cmdPtr->nsPtr;
25710       }
25711 
25712       resultObj = DisassembleProc(interp, procPtr, methodName,
25713                                   (Namespace *)nsPtr);
25714 
25715       if (resultObj != NULL) {
25716         Tcl_SetObjResult(interp, resultObj);
25717       }
25718     }
25719     break;
25720     case InfomethodsubcmdDefinitionIdx:
25721       {
25722         resultObj = Tcl_NewListObj(0, NULL);
25723 
25724         /* todo: don't hard-code registering command name "method" / NSF_METHOD */
25725         if (regObject != NULL) {
25726           AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_METHOD],
25727                                    regObject, methodName, cmd, NSF_FALSE, outputPerObject, 1);
25728         } else {
25729           Tcl_DString ds, *dsPtr = &ds;
25730 
25731           Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("::proc", -1));
25732 
25733           Tcl_DStringInit(dsPtr);
25734           DStringAppendQualName(dsPtr, Tcl_Command_nsPtr(cmd), methodName);
25735           Tcl_ListObjAppendElement(interp, resultObj,
25736                                    Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
25737                                                     Tcl_DStringLength(dsPtr)));
25738           Tcl_DStringFree(dsPtr);
25739         }
25740         ListCmdParams(interp, cmd, contextObject, NULL, methodName, NSF_PARAMS_PARAMETER);
25741         Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
25742 
25743         AppendReturnsClause(interp, resultObj, cmd);
25744 
25745         ListProcBody(interp, procPtr);
25746         Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
25747 
25748 #if defined(NSF_WITH_ASSERTIONS)
25749         if (regObject != NULL) {
25750           NsfAssertionStore *assertions;
25751 
25752           if (withPer_object == 1) {
25753             assertions = (regObject->opt != NULL) ? regObject->opt->assertions : NULL;
25754           } else {
25755             NsfClass *class = (NsfClass *)regObject;
25756             assertions = (class->opt != NULL) ? class->opt->assertions : NULL;
25757           }
25758 
25759           if (assertions != NULL) {
25760             NsfProcAssertion *procs = AssertionFindProcs(assertions, methodName);
25761             if (procs != NULL) {
25762               Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-precondition", -1));
25763               Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->pre));
25764               Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-postcondition", -1));
25765               Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->post));
25766             }
25767           }
25768         }
25769 #endif
25770         Tcl_SetObjResult(interp, resultObj);
25771         break;
25772       }
25773     case InfomethodsubcmdArgsIdx:               /* fall through */
25774     case InfomethodsubcmdDefinitionhandleIdx:   /* fall through */
25775     case InfomethodsubcmdExistsIdx:             /* fall through */
25776     case InfomethodsubcmdOriginIdx:             /* fall through */
25777     case InfomethodsubcmdParameterIdx:          /* fall through */
25778     case InfomethodsubcmdPostconditionIdx:      /* fall through */
25779     case InfomethodsubcmdPreconditionIdx:       /* fall through */
25780     case InfomethodsubcmdRegistrationhandleIdx: /* fall through */
25781     case InfomethodsubcmdReturnsIdx:            /* fall through */
25782     case InfomethodsubcmdSubmethodsIdx:         /* fall through */
25783     case InfomethodsubcmdSyntaxIdx:             /* fall through */
25784     case InfomethodsubcmdNULL:
25785     break;
25786     }
25787 
25788   } else if (objCmdProc == NsfForwardMethod) {
25789     /*
25790      * The command is a forwarder.
25791      */
25792     switch (subcmd) {
25793     case InfomethodsubcmdTypeIdx:
25794       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_FORWARD]);
25795       break;
25796     case InfomethodsubcmdDefinitionIdx:
25797       if (regObject != NULL) {
25798         ClientData clientData;
25799 
25800         clientData = Tcl_Command_objClientData(cmd);
25801         if (clientData != NULL) {
25802           resultObj = Tcl_NewListObj(0, NULL);
25803           /* todo: don't hard-code registering command name "forward" / NSF_FORWARD*/
25804           AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_FORWARD],
25805                                    regObject, methodName, cmd, NSF_FALSE, outputPerObject, 1);
25806           AppendReturnsClause(interp, resultObj, cmd);
25807 
25808           AppendForwardDefinition(interp, resultObj, clientData);
25809           Tcl_SetObjResult(interp, resultObj);
25810         }
25811       }
25812       break;
25813     case InfomethodsubcmdArgsIdx:                /* fall through */
25814     case InfomethodsubcmdBodyIdx:                /* fall through */
25815     case InfomethodsubcmdDefinitionhandleIdx:    /* fall through */
25816     case InfomethodsubcmdExistsIdx:              /* fall through */
25817     case InfomethodsubcmdOriginIdx:              /* fall through */
25818     case InfomethodsubcmdParameterIdx:           /* fall through */
25819     case InfomethodsubcmdPostconditionIdx:       /* fall through */
25820     case InfomethodsubcmdPreconditionIdx:        /* fall through */
25821     case InfomethodsubcmdRegistrationhandleIdx:  /* fall through */
25822     case InfomethodsubcmdReturnsIdx:             /* fall through */
25823     case InfomethodsubcmdSubmethodsIdx:          /* fall through */
25824     case InfomethodsubcmdSyntaxIdx:              /* fall through */
25825     case InfomethodsubcmdDisassembleIdx:         /* fall through */
25826     case InfomethodsubcmdNULL:
25827       break;
25828     }
25829 
25830   } else if (objCmdProc == NsfSetterMethod) {
25831     /*
25832      * The cmd is one of the setter methods.
25833      */
25834     switch (subcmd) {
25835     case InfomethodsubcmdTypeIdx:
25836       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_SETTER]);
25837       break;
25838     case InfomethodsubcmdDefinitionIdx:
25839       if (regObject != NULL) {
25840         SetterCmdClientData *cd = (SetterCmdClientData *)Tcl_Command_objClientData(cmd);
25841 
25842         resultObj = Tcl_NewListObj(0, NULL);
25843         /* todo: don't hard-code registering command name "setter" / NSF_SETTER */
25844         AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_SETTER], regObject,
25845                                  (cd != NULL && cd->paramsPtr) ? ObjStr(cd->paramsPtr->paramObj) : methodName,
25846                                  cmd, NSF_FALSE, outputPerObject, 1);
25847         Tcl_SetObjResult(interp, resultObj);
25848       }
25849       break;
25850     case InfomethodsubcmdArgsIdx:                /* fall through */
25851     case InfomethodsubcmdBodyIdx:                /* fall through */
25852     case InfomethodsubcmdDefinitionhandleIdx:    /* fall through */
25853     case InfomethodsubcmdExistsIdx:              /* fall through */
25854     case InfomethodsubcmdOriginIdx:              /* fall through */
25855     case InfomethodsubcmdParameterIdx:           /* fall through */
25856     case InfomethodsubcmdPostconditionIdx:       /* fall through */
25857     case InfomethodsubcmdPreconditionIdx:        /* fall through */
25858     case InfomethodsubcmdRegistrationhandleIdx:  /* fall through */
25859     case InfomethodsubcmdReturnsIdx:             /* fall through */
25860     case InfomethodsubcmdSubmethodsIdx:          /* fall through */
25861     case InfomethodsubcmdSyntaxIdx:              /* fall through */
25862     case InfomethodsubcmdDisassembleIdx:         /* fall through */
25863     case InfomethodsubcmdNULL:
25864       break;
25865     }
25866   } else if (objCmdProc == NsfProcStub) {
25867     /*
25868      * Special nsfproc handling:
25869      */
25870     NsfProcClientData *tcd = Tcl_Command_objClientData(cmd);
25871 
25872     if (tcd != NULL && tcd->procName) {
25873       Tcl_Command  procCmd = Tcl_GetCommandFromObj(interp, tcd->procName);
25874       Proc         *tProcPtr = GetTclProcFromCommand(procCmd);
25875       Tcl_DString  ds, *dsPtr = &ds;
25876 
25877       switch (subcmd) {
25878 
25879       case InfomethodsubcmdTypeIdx:
25880         Tcl_SetObjResult(interp, Tcl_NewStringObj("nsfproc", -1));
25881         break;
25882 
25883       case InfomethodsubcmdBodyIdx:
25884         ListProcBody(interp, tProcPtr);
25885         break;
25886 
25887       case InfomethodsubcmdDefinitionIdx:
25888         resultObj = Tcl_NewListObj(0, NULL);
25889         Tcl_DStringInit(dsPtr);
25890         DStringAppendQualName(dsPtr, Tcl_Command_nsPtr(cmd), methodName);
25891         /* don't hardcode names */
25892         Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("::nsf::proc", -1));
25893         if ((tcd->flags & NSF_PROC_FLAG_AD) != 0) {
25894           Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-ad", 3));
25895         }
25896         if (((unsigned int)Tcl_Command_flags(tcd->wrapperCmd) & NSF_CMD_DEBUG_METHOD) != 0) {
25897           Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-debug", 6));
25898         }
25899         if (((unsigned int)Tcl_Command_flags(tcd->wrapperCmd) & NSF_CMD_DEPRECATED_METHOD) != 0) {
25900           Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-deprecated", 11));
25901         }
25902 
25903         Tcl_ListObjAppendElement(interp, resultObj,
25904                                  Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
25905                                                   Tcl_DStringLength(dsPtr)));
25906         ListCmdParams(interp, cmd, NULL, NULL, Tcl_DStringValue(dsPtr), NSF_PARAMS_PARAMETER);
25907         Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
25908         ListProcBody(interp, tProcPtr);
25909         Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp));
25910         Tcl_SetObjResult(interp, resultObj);
25911         Tcl_DStringFree(dsPtr);
25912         break;
25913       case InfomethodsubcmdDisassembleIdx:
25914 
25915         resultObj = DisassembleProc(interp, tProcPtr, methodName,
25916                                     tProcPtr->cmdPtr->nsPtr);
25917 
25918         if (resultObj != NULL) {
25919           Tcl_SetObjResult(interp, resultObj);
25920         }
25921         break;
25922       case InfomethodsubcmdArgsIdx:                /* fall through */
25923       case InfomethodsubcmdDefinitionhandleIdx:    /* fall through */
25924       case InfomethodsubcmdExistsIdx:              /* fall through */
25925       case InfomethodsubcmdOriginIdx:              /* fall through */
25926       case InfomethodsubcmdParameterIdx:           /* fall through */
25927       case InfomethodsubcmdPostconditionIdx:       /* fall through */
25928       case InfomethodsubcmdPreconditionIdx:        /* fall through */
25929       case InfomethodsubcmdRegistrationhandleIdx:  /* fall through */
25930       case InfomethodsubcmdReturnsIdx:             /* fall through */
25931       case InfomethodsubcmdSubmethodsIdx:          /* fall through */
25932       case InfomethodsubcmdSyntaxIdx:              /* fall through */
25933       case InfomethodsubcmdNULL:
25934         break;
25935       }
25936     }
25937 
25938   } else if (defObject != NULL) {
25939     /*
25940      * The cmd must be an alias or object.
25941      *
25942      * Note that some aliases come with objCmdProc == NsfObjDispatch.  In order
25943      * to distinguish between "object" and alias, we have to do the lookup for
25944      * the entryObj to determine whether it is really an alias.
25945      */
25946     Tcl_Obj *entryObj;
25947 
25948     entryObj = AliasGet(interp, defObject->cmdName,
25949                         Tcl_GetCommandName(interp, cmd),
25950                         regObject != defObject ? NSF_TRUE : withPer_object, NSF_FALSE);
25951     /*
25952       fprintf(stderr, "aliasGet %s -> %s/%s (%d) returned %p\n",
25953       ObjectName(defObject), methodName, Tcl_GetCommandName(interp, cmd),
25954       withPer_object, entryObj);
25955       fprintf(stderr, "... regObject %p %s\n", regObject, ObjectName(regObject));
25956       fprintf(stderr, "... defObject %p %s\n", defObject, ObjectName(defObject));
25957     */
25958 
25959     if (entryObj != NULL) {
25960       /*
25961        * The entry is an alias.
25962        */
25963       switch (subcmd) {
25964       case InfomethodsubcmdTypeIdx:
25965         Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_ALIAS]);
25966         break;
25967       case InfomethodsubcmdDefinitionIdx:
25968         if (regObject != NULL) {
25969           int nrElements;
25970           Tcl_Obj **listElements;
25971 
25972           resultObj = Tcl_NewListObj(0, NULL);
25973           Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements);
25974           /* todo: don't hard-code registering command name "alias" / NSF_ALIAS */
25975           AppendMethodRegistration(interp, resultObj, NsfGlobalStrings[NSF_ALIAS],
25976                                    regObject, methodName, cmd,
25977                                    objCmdProc == NsfObjscopedMethod,
25978                                    outputPerObject, 1);
25979           AppendReturnsClause(interp, resultObj, cmd);
25980           Tcl_ListObjAppendElement(interp, resultObj, listElements[nrElements-1]);
25981           Tcl_SetObjResult(interp, resultObj);
25982         }
25983         break;
25984 
25985       case InfomethodsubcmdOriginIdx:
25986         {
25987           int nrElements;
25988           Tcl_Obj **listElements;
25989           Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements);
25990           Tcl_SetObjResult(interp, listElements[nrElements-1]);
25991           break;
25992         }
25993 
25994       case InfomethodsubcmdArgsIdx:                /* fall through */
25995       case InfomethodsubcmdBodyIdx:                /* fall through */
25996       case InfomethodsubcmdDefinitionhandleIdx:    /* fall through */
25997       case InfomethodsubcmdExistsIdx:              /* fall through */
25998       case InfomethodsubcmdParameterIdx:           /* fall through */
25999       case InfomethodsubcmdPostconditionIdx:       /* fall through */
26000       case InfomethodsubcmdPreconditionIdx:        /* fall through */
26001       case InfomethodsubcmdRegistrationhandleIdx:  /* fall through */
26002       case InfomethodsubcmdReturnsIdx:             /* fall through */
26003       case InfomethodsubcmdSubmethodsIdx:          /* fall through */
26004       case InfomethodsubcmdSyntaxIdx:              /* fall through */
26005       case InfomethodsubcmdDisassembleIdx:         /* fall through */
26006       case InfomethodsubcmdNULL:
26007         break;
26008       }
26009     } else {
26010       /*
26011        * Check if the command is and nsfObject to be on the safe side.
26012        */
26013       if (CmdIsNsfObject(cmd)) {
26014         /*
26015          * The command is an object.
26016          */
26017         switch (subcmd) {
26018         case InfomethodsubcmdTypeIdx:
26019           Tcl_SetObjResult(interp, Tcl_NewStringObj("object", -1));
26020           break;
26021         case InfomethodsubcmdDefinitionIdx:
26022           {
26023             NsfObject *subObject = NsfGetObjectFromCmdPtr(cmd);
26024 
26025             assert(subObject != NULL);
26026             resultObj = Tcl_NewListObj(0, NULL);
26027             AppendMethodRegistration(interp, resultObj, "create",
26028                                      &(subObject->cl)->object,
26029                                      ObjStr(subObject->cmdName), cmd,
26030                                      NSF_FALSE, NSF_FALSE, 0);
26031             Tcl_SetObjResult(interp, resultObj);
26032             break;
26033           }
26034 
26035         case InfomethodsubcmdArgsIdx:                /* fall through */
26036         case InfomethodsubcmdBodyIdx:                /* fall through */
26037         case InfomethodsubcmdDefinitionhandleIdx:    /* fall through */
26038         case InfomethodsubcmdExistsIdx:              /* fall through */
26039         case InfomethodsubcmdParameterIdx:           /* fall through */
26040         case InfomethodsubcmdPostconditionIdx:       /* fall through */
26041         case InfomethodsubcmdPreconditionIdx:        /* fall through */
26042         case InfomethodsubcmdRegistrationhandleIdx:  /* fall through */
26043         case InfomethodsubcmdReturnsIdx:             /* fall through */
26044         case InfomethodsubcmdSubmethodsIdx:          /* fall through */
26045         case InfomethodsubcmdSyntaxIdx:              /* fall through */
26046         case InfomethodsubcmdOriginIdx:              /* fall through */
26047         case InfomethodsubcmdDisassembleIdx:         /* fall through */
26048         case InfomethodsubcmdNULL:
26049           break;
26050         }
26051       } else {
26052         /*
26053          * Should never happen.
26054          *
26055          * The warning is just a guess, so we don't raise an error here.
26056          */
26057         NsfLog(interp, NSF_LOG_WARN, "Could not obtain alias definition for %s. "
26058                "Maybe someone deleted the alias %s for object %s?",
26059                methodName, methodName, ObjectName(regObject));
26060         Tcl_ResetResult(interp);
26061       }
26062     }
26063   } else {
26064     /*
26065      * The cmd must be a plain unregistered cmd
26066      */
26067     switch (subcmd) {
26068     case InfomethodsubcmdTypeIdx:
26069       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_CMD]);
26070       break;
26071     case InfomethodsubcmdDefinitionIdx:
26072       break;
26073     case InfomethodsubcmdOriginIdx:
26074       break;
26075 
26076     case InfomethodsubcmdArgsIdx:                /* fall through */
26077     case InfomethodsubcmdBodyIdx:                /* fall through */
26078     case InfomethodsubcmdDefinitionhandleIdx:    /* fall through */
26079     case InfomethodsubcmdExistsIdx:              /* fall through */
26080     case InfomethodsubcmdParameterIdx:           /* fall through */
26081     case InfomethodsubcmdPostconditionIdx:       /* fall through */
26082     case InfomethodsubcmdPreconditionIdx:        /* fall through */
26083     case InfomethodsubcmdRegistrationhandleIdx:  /* fall through */
26084     case InfomethodsubcmdReturnsIdx:             /* fall through */
26085     case InfomethodsubcmdSubmethodsIdx:          /* fall through */
26086     case InfomethodsubcmdSyntaxIdx:              /* fall through */
26087     case InfomethodsubcmdDisassembleIdx:         /* fall through */
26088     case InfomethodsubcmdNULL:
26089       break;
26090     }
26091   }
26092 
26093   return TCL_OK;
26094 }
26095 
26096 /*
26097  *----------------------------------------------------------------------
26098  * ListMethodResolve --
26099  *
26100  *    Call essentially ListMethod(), but try to resolve the method name/handle
26101  *    first.
26102  *
26103  * Results:
26104  *    Standard Tcl result
26105  *
26106  * Side effects:
26107  *    None.
26108  *
26109  *----------------------------------------------------------------------
26110  */
26111 static int
26112 ListMethodResolve(Tcl_Interp *interp, InfomethodsubcmdIdx_t subcmd,
26113                   NsfObject *contextObject, const char *pattern,
26114                   Tcl_Namespace *nsPtr, NsfObject *object,
26115                   Tcl_Obj *methodNameObj, bool fromClassNS)
26116   nonnull(1) nonnull(7);
26117 
26118 static int
ListMethodResolve(Tcl_Interp * interp,InfomethodsubcmdIdx_t subcmd,NsfObject * contextObject,const char * pattern,Tcl_Namespace * nsPtr,NsfObject * object,Tcl_Obj * methodNameObj,bool fromClassNS)26119 ListMethodResolve(Tcl_Interp *interp, InfomethodsubcmdIdx_t subcmd,
26120                   NsfObject *contextObject, const char *pattern,
26121                   Tcl_Namespace *nsPtr, NsfObject *object,
26122                   Tcl_Obj *methodNameObj, bool fromClassNS) {
26123   NsfObject   *regObject, *defObject;
26124   const char  *methodName1 = NULL;
26125   int          result = TCL_OK;
26126   Tcl_DString  ds, *dsPtr = &ds;
26127   Tcl_Command  cmd;
26128 
26129   nonnull_assert(interp != NULL);
26130   nonnull_assert(methodNameObj != NULL);
26131 
26132   Tcl_DStringInit(dsPtr);
26133 
26134   cmd = ResolveMethodName(interp, nsPtr, methodNameObj,
26135                           dsPtr, &regObject, &defObject, &methodName1, &fromClassNS);
26136   /*
26137    * If the cmd is NOT found, we return empty, unless for the sub-command
26138    * "exists", we return 0.
26139    */
26140   if (likely(cmd != NULL)) {
26141 
26142     result = ListMethod(interp, (regObject != NULL) ? regObject : object, (defObject != NULL) ? defObject : object,
26143                         methodName1, cmd, subcmd,
26144                         contextObject, pattern, (fromClassNS == 0));
26145 
26146   } else if (subcmd == InfomethodsubcmdExistsIdx) {
26147     Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
26148   }
26149 
26150   Tcl_DStringFree(dsPtr);
26151   return result;
26152 }
26153 
26154 
26155 /*
26156  *----------------------------------------------------------------------
26157  * MethodSourceMatches --
26158  *
26159  *    Check, whether the provided class or object (mutually exclusive) matches
26160  *    with the required method source (typically all|application|system).
26161  *
26162  * Results:
26163  *    Returns boolean
26164  *
26165  * Side effects:
26166  *    None.
26167  *
26168  *----------------------------------------------------------------------
26169  */
26170 static bool MethodSourceMatches(DefinitionsourceIdx_t withSource, NsfClass *class, NsfObject *object) pure;
26171 
MethodSourceMatches(DefinitionsourceIdx_t withSource,NsfClass * class,NsfObject * object)26172 static bool MethodSourceMatches(DefinitionsourceIdx_t withSource, NsfClass *class, NsfObject *object) {
26173   bool result;
26174 
26175   if (withSource == DefinitionsourceAllIdx) {
26176     result = NSF_TRUE;
26177 
26178   } else if (class == NULL) {
26179     /*
26180      * If the method is object specific, it can't be from a baseclass and must
26181      * be application specific.
26182      */
26183     assert(object != NULL);
26184     result = (withSource == DefinitionsourceApplicationIdx && !IsBaseClass(object));
26185 
26186   } else {
26187     bool isBaseClass;
26188 
26189     assert(class != NULL);
26190 
26191     isBaseClass = IsBaseClass(&class->object);
26192     if (withSource == DefinitionsourceSystemIdx && isBaseClass) {
26193       result = NSF_TRUE;
26194     } else if (withSource == DefinitionsourceApplicationIdx && !isBaseClass) {
26195       result = NSF_TRUE;
26196     } else {
26197       result = NSF_FALSE;
26198     }
26199   }
26200   return result;
26201 }
26202 
26203 
26204 /*
26205  *----------------------------------------------------------------------
26206  * MethodTypeMatches --
26207  *
26208  *    Check, whether the provided method (specified as a cmd) matches with the
26209  *    required method type (typically
26210  *    all|scripted|builtin|alias|forwarder|object|setter).
26211  *
26212  * Results:
26213  *    Returns Boolean value
26214  *
26215  * Side effects:
26216  *    None.
26217  *
26218  *----------------------------------------------------------------------
26219  */
26220 
26221 static bool MethodTypeMatches(Tcl_Interp *interp, MethodtypeIdx_t methodType, Tcl_Command cmd,
26222                               NsfObject *object, const char *methodName, int withPer_object,
26223                               bool *isObject)
26224   nonnull(1) nonnull(3) nonnull(5) nonnull(7);
26225 
26226 static bool
MethodTypeMatches(Tcl_Interp * interp,MethodtypeIdx_t methodType,Tcl_Command cmd,NsfObject * object,const char * methodName,int withPer_object,bool * isObject)26227 MethodTypeMatches(Tcl_Interp *interp, MethodtypeIdx_t methodType, Tcl_Command cmd,
26228                   NsfObject *object, const char *methodName, int withPer_object,
26229                   bool *isObject) {
26230   Tcl_ObjCmdProc *proc;
26231   Tcl_Command     importedCmd;
26232 
26233   nonnull_assert(interp != NULL);
26234   nonnull_assert(cmd != NULL);
26235   nonnull_assert(methodName != NULL);
26236   nonnull_assert(isObject != NULL);
26237 
26238   proc = Tcl_Command_objProc(cmd);
26239   importedCmd = GetOriginalCommand(cmd);
26240 
26241   /*
26242    * Return always state isObject, since the cmd might be an ensemble,
26243    * where we have to search further.
26244    */
26245   *isObject = CmdIsNsfObject(importedCmd);
26246 
26247   if (methodType == NSF_METHODTYPE_ALIAS) {
26248     if (!(proc == NsfProcAliasMethod
26249           || AliasGet(interp, object->cmdName, methodName, withPer_object, NSF_FALSE))
26250        ) {
26251       return NSF_FALSE;
26252       }
26253   } else {
26254     Tcl_ObjCmdProc *resolvedProc;
26255 
26256     if (proc == NsfProcAliasMethod) {
26257       if ((methodType & NSF_METHODTYPE_ALIAS) == 0) {
26258         return NSF_FALSE;
26259       }
26260     }
26261     resolvedProc = Tcl_Command_objProc(importedCmd);
26262 
26263     /*
26264      * The following cases are disjoint.
26265      */
26266     if (CmdIsProc(importedCmd)) {
26267       /*fprintf(stderr, "%s scripted %d\n", methodName, methodType & NSF_METHODTYPE_SCRIPTED);*/
26268       if ((methodType & NSF_METHODTYPE_SCRIPTED) == 0) {
26269         return NSF_FALSE;
26270       }
26271     } else if (resolvedProc == NsfForwardMethod) {
26272       if ((methodType & NSF_METHODTYPE_FORWARDER) == 0) {
26273         return NSF_FALSE;
26274       }
26275     } else if (resolvedProc == NsfSetterMethod) {
26276       if ((methodType & NSF_METHODTYPE_SETTER) == 0) {
26277         return NSF_FALSE;
26278       }
26279     } else if (*isObject) {
26280       if ((methodType & NSF_METHODTYPE_OBJECT) == 0) {
26281         return NSF_FALSE;
26282       }
26283     } else if (resolvedProc == NsfProcStub) {
26284       if ((methodType & NSF_METHODTYPE_NSFPROC) == 0) {
26285         return NSF_FALSE;
26286       }
26287     } else if ((methodType & NSF_METHODTYPE_OTHER) == 0) {
26288       /* fprintf(stderr, "OTHER %s not wanted %.4x\n", methodName, methodType);*/
26289       return NSF_FALSE;
26290     }
26291     /* NsfObjscopedMethod ??? */
26292   }
26293   return NSF_TRUE;
26294 }
26295 
26296 /*
26297  *----------------------------------------------------------------------
26298  * ProtectionMatches --
26299  *
26300  *    Check, whether the provided method (specified as a cmd) matches with the
26301  *    required call-protection (typically all|public|protected|private).
26302  *
26303  * Results:
26304  *    Returns boolean
26305  *
26306  * Side effects:
26307  *    None.
26308  *
26309  *----------------------------------------------------------------------
26310  */
26311 static bool ProtectionMatches(CallprotectionIdx_t withCallprotection, Tcl_Command cmd)
26312   nonnull(2) pure;
26313 
26314 static bool
ProtectionMatches(CallprotectionIdx_t withCallprotection,Tcl_Command cmd)26315 ProtectionMatches(CallprotectionIdx_t withCallprotection, Tcl_Command cmd) {
26316   int          result;
26317   bool         isProtected, isPrivate;
26318   unsigned int cmdFlags;
26319 
26320   nonnull_assert(cmd != NULL);
26321 
26322   cmdFlags    = (unsigned int)Tcl_Command_flags(cmd);
26323   isProtected = ((cmdFlags & NSF_CMD_CALL_PROTECTED_METHOD) != 0u);
26324   isPrivate   = ((cmdFlags & NSF_CMD_CALL_PRIVATE_METHOD) != 0u);
26325 
26326   if (withCallprotection == CallprotectionNULL) {
26327     withCallprotection = CallprotectionPublicIdx;
26328   }
26329   switch (withCallprotection) {
26330   case CallprotectionAllIdx: result = NSF_TRUE; break;
26331   case CallprotectionPublicIdx: result = (isProtected == 0); break;
26332   case CallprotectionProtectedIdx: result = (isProtected && !isPrivate); break;
26333   case CallprotectionPrivateIdx: result = isPrivate; break;
26334   case CallprotectionNULL: /* fall through */
26335   default: result = NSF_TRUE; break;
26336   }
26337   return result;
26338 }
26339 
26340 /*
26341  *----------------------------------------------------------------------
26342  *
26343  * ListMethodKeys --
26344  *
26345  *      List the method names contained in the specified hash-table
26346  *      according to the filtering options (types, pattern,
26347  *      protection, etc.). Optionally, a name prefix can be provided
26348  *      in form of a Tcl_DString. The result is placed into the interp
26349  *      result.
26350  *
26351  * Results:
26352  *      Tcl result code.
26353  *
26354  * Side effects:
26355  *      Setting interp result.
26356  *
26357  *----------------------------------------------------------------------
26358  */
26359 static int ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
26360                           Tcl_DString *prefix, const char *pattern,
26361                           MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection, bool withPath,
26362                           Tcl_HashTable *dups, NsfObject *object, bool withPer_object)
26363   nonnull(1) nonnull(2);
26364 
26365 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)26366 ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
26367                Tcl_DString *prefix, const char *pattern,
26368                MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection, bool withPath,
26369                Tcl_HashTable *dups, NsfObject *object, bool withPer_object) {
26370   Tcl_HashSearch       hSrch;
26371   const Tcl_HashEntry *hPtr;
26372   Tcl_Command          cmd;
26373   const char          *key;
26374   bool                 isObject, methodTypeMatch;
26375   Tcl_Obj             *resultObj;
26376 
26377   nonnull_assert(interp != NULL);
26378   nonnull_assert(tablePtr != NULL);
26379 
26380   resultObj = Tcl_GetObjResult(interp);
26381   if (pattern != NULL && NoMetaChars(pattern) && strchr(pattern, ' ') == NULL) {
26382     /*
26383      * We have a pattern that can be used for direct lookup; no need
26384      * to iterate.
26385      */
26386     hPtr = Tcl_CreateHashEntry(tablePtr, pattern, NULL);
26387     if (hPtr != NULL) {
26388       NsfObject   *childObject;
26389       Tcl_Command  origCmd;
26390 
26391       key = Tcl_GetHashKey(tablePtr, hPtr);
26392       cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
26393       methodTypeMatch = MethodTypeMatches(interp, methodType, cmd, object, key,
26394                                           withPer_object, &isObject);
26395       if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CLASS_ONLY_METHOD) != 0u
26396           && !NsfObjectIsClass(object)) {
26397         return TCL_OK;
26398       }
26399       /*
26400        * Aliased objects methods return 1 but lookup from cmd returns
26401        * NULL. Below, we are just interested on true sub-objects.
26402        */
26403       origCmd = GetOriginalCommand(cmd);
26404       childObject = (isObject) ? NsfGetObjectFromCmdPtr(origCmd) : NULL;
26405 
26406       if (childObject != NULL && withPath) {
26407         return TCL_OK;
26408       }
26409 
26410       if (ProtectionMatches(withCallprotection, cmd) && methodTypeMatch) {
26411         int prefixLength = (prefix != NULL) ? Tcl_DStringLength(prefix) : 0;
26412 
26413         if (prefixLength != 0) {
26414           Tcl_DStringAppend(prefix, key, -1);
26415           key = Tcl_DStringValue(prefix);
26416         }
26417         if (dups != NULL) {
26418           int new;
26419 
26420           (void)Tcl_CreateHashEntry(dups, key, &new);
26421           if (new != 0) {
26422             Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(key, -1));
26423           }
26424         } else {
26425           Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(key, -1));
26426         }
26427       }
26428     }
26429     return TCL_OK;
26430 
26431   } else {
26432     int prefixLength = (prefix != NULL) ? Tcl_DStringLength(prefix) : 0;
26433 
26434     /*
26435      * We have to iterate over the elements.
26436      */
26437 
26438     for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSrch);
26439          hPtr != NULL;
26440          hPtr = Tcl_NextHashEntry(&hSrch)) {
26441       NsfObject   *childObject;
26442       Tcl_Command  origCmd;
26443 
26444       key = Tcl_GetHashKey(tablePtr, hPtr);
26445       cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
26446       if (prefixLength != 0) {
26447         Tcl_DStringSetLength(prefix, prefixLength);
26448       }
26449       methodTypeMatch = MethodTypeMatches(interp, methodType, cmd, object, key,
26450                                           withPer_object, &isObject);
26451       /*
26452        * Aliased objects methods return 1 but lookup from cmd returns
26453        * NULL. Below, we are just interested on true sub-objects.
26454        */
26455       origCmd = GetOriginalCommand(cmd);
26456       childObject = (isObject) ? NsfGetObjectFromCmdPtr(origCmd) : NULL;
26457 
26458       if (childObject != NULL) {
26459         if (withPath) {
26460           Tcl_HashTable *cmdTablePtr;
26461 
26462           if (childObject->nsPtr == NULL) {
26463             /*
26464              * Nothing to do.
26465              */
26466             continue;
26467           }
26468           cmdTablePtr = Tcl_Namespace_cmdTablePtr(childObject->nsPtr);
26469           if (cmdTablePtr == NULL) {
26470             /*
26471              * Nothing to do.
26472              */
26473             continue;
26474           }
26475           if ((childObject->flags & NSF_IS_SLOT_CONTAINER) != 0u) {
26476             /*
26477              * Don't report slot container.
26478              */
26479             continue;
26480           }
26481           if ((childObject->flags & NSF_KEEP_CALLER_SELF) == 0u) {
26482             /*
26483              * Do only report sub-objects with keep caller self.
26484              */
26485             continue;
26486           }
26487 
26488           /*fprintf(stderr, "ListMethodKeys key %s append key space flags %.6x\n",
26489             key, childObject->flags);*/
26490           if (prefix == NULL) {
26491             Tcl_DString ds, *dsPtr = &ds;
26492 
26493             DSTRING_INIT(dsPtr);
26494             Tcl_DStringAppend(dsPtr, key, -1);
26495             Tcl_DStringAppend(dsPtr, " ", 1);
26496             ListMethodKeys(interp, cmdTablePtr, dsPtr, pattern, methodType,
26497                            withCallprotection, NSF_TRUE, dups, object, withPer_object);
26498             DSTRING_FREE(dsPtr);
26499           } else {
26500             Tcl_DStringAppend(prefix, key, -1);
26501             Tcl_DStringAppend(prefix, " ", 1);
26502             ListMethodKeys(interp, cmdTablePtr, prefix, pattern, methodType,
26503                            withCallprotection, NSF_TRUE, dups, object, withPer_object);
26504           }
26505           /*
26506            * Don't list ensembles by themselves.
26507            */
26508           continue;
26509         }
26510       }
26511 
26512       if (((unsigned int)Tcl_Command_flags(cmd) & NSF_CMD_CLASS_ONLY_METHOD) != 0u
26513           && !NsfObjectIsClass(object)
26514           ) {
26515         continue;
26516       }
26517       if (!ProtectionMatches(withCallprotection, cmd)
26518           || (!methodTypeMatch)) {
26519         continue;
26520       }
26521 
26522       if (prefixLength != 0) {
26523         Tcl_DStringAppend(prefix, key, -1);
26524         key = Tcl_DStringValue(prefix);
26525       }
26526 
26527       if (pattern != NULL && !Tcl_StringMatch(key, pattern)) {
26528         continue;
26529       }
26530       if (dups != NULL) {
26531         int new;
26532 
26533         Tcl_CreateHashEntry(dups, key, &new);
26534         if (new == 0) {
26535           continue;
26536         }
26537       }
26538       Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(key, -1));
26539     }
26540   }
26541   /*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/
26542   return TCL_OK;
26543 }
26544 
26545 /*
26546  *----------------------------------------------------------------------
26547  *
26548  * ListChildren --
26549  *
26550  *      List the children of the specified object. The result can be filtered
26551  *      via a pattern or a type.
26552  *
26553  * Results:
26554  *      Tcl result code.
26555  *
26556  * Side effects:
26557  *      Setting interp result.
26558  *
26559  *----------------------------------------------------------------------
26560  */
26561 static int ListChildren(
26562     Tcl_Interp *interp, NsfObject *object,
26563     const char *pattern,
26564     bool classesOnly, NsfClass *typeClass
26565 ) nonnull(1) nonnull(2);
26566 
26567 static int
ListChildren(Tcl_Interp * interp,NsfObject * object,const char * pattern,bool classesOnly,NsfClass * typeClass)26568 ListChildren(
26569     Tcl_Interp *interp, NsfObject *object,
26570     const char *pattern,
26571     bool classesOnly, NsfClass *typeClass
26572 ) {
26573   NsfObject *childObject;
26574 
26575   nonnull_assert(interp != NULL);
26576   nonnull_assert(object != NULL);
26577 
26578   if (object->nsPtr == NULL) {
26579     return TCL_OK;
26580   }
26581 
26582   if (pattern != NULL && NoMetaChars(pattern)) {
26583     Tcl_DString ds, *dsPtr = &ds;
26584 
26585     Tcl_DStringInit(dsPtr);
26586 
26587     if (*pattern != ':') {
26588       /*
26589        * Build a fully qualified name.
26590        */
26591       DStringAppendQualName(dsPtr, object->nsPtr, pattern);
26592       pattern = Tcl_DStringValue(dsPtr);
26593     }
26594 
26595     if ((childObject = GetObjectFromString(interp, pattern)) &&
26596         (!classesOnly || NsfObjectIsClass(childObject)) &&
26597         ((typeClass == NULL) || IsSubType(childObject->cl, typeClass)) &&
26598         (Tcl_Command_nsPtr(childObject->id) == object->nsPtr)  /* true children */
26599         ) {
26600       Tcl_SetObjResult(interp, childObject->cmdName);
26601     } else {
26602       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
26603     }
26604     Tcl_DStringFree(dsPtr);
26605 
26606   } else {
26607     Tcl_Obj *list = Tcl_NewListObj(0, NULL);
26608     Tcl_HashSearch hSrch;
26609     Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(object->nsPtr);
26610     const Tcl_HashEntry *hPtr;
26611 
26612     for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
26613          hPtr != NULL;
26614          hPtr = Tcl_NextHashEntry(&hSrch)) {
26615       const char *key = Tcl_GetHashKey(cmdTablePtr, hPtr);
26616 
26617       if (pattern == NULL || Tcl_StringMatch(key, pattern)) {
26618         Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
26619 
26620         /*fprintf(stderr, "... check %s child key %s child object %p %p\n",
26621                 ObjectName(object), key, GetObjectFromString(interp, key),
26622                 NsfGetObjectFromCmdPtr(cmd));*/
26623 
26624         if ((childObject = NsfGetObjectFromCmdPtr(cmd)) &&
26625             (!classesOnly || NsfObjectIsClass(childObject)) &&
26626             ((typeClass == NULL) || IsSubType(childObject->cl, typeClass)) &&
26627             (Tcl_Command_nsPtr(childObject->id) == object->nsPtr)  /* true children */
26628             ) {
26629           Tcl_ListObjAppendElement(interp, list, childObject->cmdName);
26630         }
26631       }
26632     }
26633     Tcl_SetObjResult(interp, list);
26634   }
26635 
26636   return TCL_OK;
26637 }
26638 
26639 /*
26640  *----------------------------------------------------------------------
26641  *
26642  * ListForward --
26643  *
26644  *      List registered forwarder defined in the hash table. The result can be filtered
26645  *      via a pattern, optionally the forward definition is returned.
26646  *
26647  * Results:
26648  *      Tcl result code.
26649  *
26650  * Side effects:
26651  *      Setting interp result.
26652  *
26653  *----------------------------------------------------------------------
26654  */
26655 static int ListForward(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
26656             const char *pattern, int withDefinition)
26657   nonnull(1) nonnull(2);
26658 
26659 static int
ListForward(Tcl_Interp * interp,Tcl_HashTable * tablePtr,const char * pattern,int withDefinition)26660 ListForward(Tcl_Interp *interp, Tcl_HashTable *tablePtr,
26661             const char *pattern, int withDefinition) {
26662 
26663   nonnull_assert(interp != NULL);
26664   nonnull_assert(tablePtr != NULL);
26665 
26666   if (withDefinition != 0) {
26667     const Tcl_HashEntry *hPtr = (pattern != NULL) ? Tcl_CreateHashEntry(tablePtr, pattern, NULL) : NULL;
26668     /*
26669      * Notice: we don't use pattern for wildcard matching here; pattern can
26670      * only contain wildcards when used without "-definition".
26671      */
26672     if (hPtr != NULL) {
26673       Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
26674       ClientData clientData = (cmd != NULL) ? Tcl_Command_objClientData(cmd) : NULL;
26675       ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData;
26676 
26677       if (tcd != NULL && Tcl_Command_objProc(cmd) == NsfForwardMethod) {
26678         Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
26679 
26680         AppendForwardDefinition(interp, listObj, tcd);
26681         Tcl_SetObjResult(interp, listObj);
26682         return TCL_OK;
26683       }
26684     }
26685     return NsfPrintError(interp, "'%s' is not a forwarder", pattern);
26686   }
26687   return ListMethodKeys(interp, tablePtr, NULL, pattern, NSF_METHODTYPE_FORWARDER,
26688                         CallprotectionAllIdx, NSF_FALSE, NULL, NULL, NSF_FALSE);
26689 }
26690 
26691 /*
26692  *----------------------------------------------------------------------
26693  *
26694  * ListDefinedMethods --
26695  *
26696  *      List the methods defined by the specified object/class
26697  *      according to the filtering options (types, pattern,
26698  *      protection, etc.). The result is placed into the interp
26699  *      result.
26700  *
26701  * Results:
26702  *      Tcl result code.
26703  *
26704  * Side effects:
26705  *      Setting interp result.
26706  *
26707  *----------------------------------------------------------------------
26708  */
26709 static int
ListDefinedMethods(Tcl_Interp * interp,NsfObject * object,const char * pattern,bool withPer_object,MethodtypeIdx_t methodType,CallprotectionIdx_t withCallprotection,bool withPath)26710 ListDefinedMethods(Tcl_Interp *interp, NsfObject *object, const char *pattern,
26711                    bool withPer_object, MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection,
26712                    bool withPath) {
26713   Tcl_HashTable *cmdTablePtr;
26714   Tcl_DString ds, *dsPtr = NULL;
26715 
26716   nonnull_assert(interp != NULL);
26717   nonnull_assert(object != NULL);
26718 
26719   if (pattern != NULL && *pattern == ':' && *(pattern + 1) == ':') {
26720     Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
26721     const char *remainder;
26722 
26723     /*fprintf(stderr, "we have a colon pattern '%s' methodtype %.6x\n", pattern, methodType);*/
26724 
26725     TclGetNamespaceForQualName(interp, pattern, NULL, 0,
26726                                &nsPtr, &dummy1Ptr, &dummy2Ptr, &remainder);
26727     /*fprintf(stderr,
26728             "TclGetNamespaceForQualName with %s => (%p %s) (%p %s) (%p %s) (%p %s)\n",
26729             pattern,
26730             nsPtr, (nsPtr != NULL) ? nsPtr->fullName : "",
26731             dummy1Ptr, (dummy1Ptr != NULL) ? dummy1Ptr->fullName : "",
26732             dummy2Ptr, (dummy2Ptr != NULL) ? dummy2Ptr->fullName : "",
26733             remainder, (remainder != 0) ? remainder : "");*/
26734     if (nsPtr != NULL) {
26735       cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
26736       dsPtr = &ds;
26737       Tcl_DStringInit(dsPtr);
26738       Tcl_DStringAppend(dsPtr, nsPtr->fullName, -1);
26739       if (Tcl_DStringLength(dsPtr) > 2) {
26740         Tcl_DStringAppend(dsPtr, "::", 2);
26741       }
26742       pattern = remainder;
26743     } else {
26744       cmdTablePtr = NULL;
26745     }
26746   } else if (NsfObjectIsClass(object) && !withPer_object) {
26747     cmdTablePtr = Tcl_Namespace_cmdTablePtr(((NsfClass *)object)->nsPtr);
26748   } else {
26749     cmdTablePtr = (object->nsPtr != NULL) ? Tcl_Namespace_cmdTablePtr(object->nsPtr) : NULL;
26750   }
26751 
26752   if (cmdTablePtr != NULL) {
26753     ListMethodKeys(interp, cmdTablePtr, dsPtr, pattern, methodType, withCallprotection, withPath,
26754                    NULL, object, withPer_object);
26755     if (dsPtr != NULL) {
26756       Tcl_DStringFree(dsPtr);
26757     }
26758   }
26759   return TCL_OK;
26760 }
26761 
26762 /*
26763  *----------------------------------------------------------------------
26764  *
26765  * ListSuperClasses --
26766  *
26767  *      List the superclasses of a class. Optionally the transitive closure is
26768  *      computed and the result can be filtered via a pattern.
26769  *
26770  * Results:
26771  *      Tcl result code.
26772  *
26773  * Side effects:
26774  *      Setting interp result.
26775  *
26776  *----------------------------------------------------------------------
26777  */
26778 
26779 static int ListSuperClasses(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *pattern, bool withClosure)
26780   nonnull(1) nonnull(2);
26781 
26782 static int
ListSuperClasses(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * pattern,bool withClosure)26783 ListSuperClasses(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *pattern, bool withClosure) {
26784 
26785   nonnull_assert(interp != NULL);
26786   nonnull_assert(class != NULL);
26787 
26788   if (class->super != NULL) {
26789     NsfObject   *matchObject = NULL;
26790     Tcl_Obj     *outObjPtr, *patternObj = NULL;
26791     const char  *patternString = NULL;
26792     ClientData   clientData;
26793     bool         found;
26794 
26795     if (pattern != NULL
26796         && ConvertToObjpattern(interp, pattern, NULL, &clientData, &outObjPtr) == TCL_OK
26797         ) {
26798       patternObj = (Tcl_Obj *)clientData;
26799 
26800       if (GetMatchObject(interp, patternObj, pattern, &matchObject, &patternString) == -1) {
26801         /*
26802          * The pattern has no meta chars and does not correspond to an existing
26803          * object. Therefore, it can't be a superclass.
26804          */
26805         if (patternObj != NULL) {
26806           DECR_REF_COUNT2("patternObj", patternObj);
26807         }
26808         return TCL_OK;
26809       }
26810     }
26811 
26812     if (withClosure) {
26813       NsfClasses *pl = PrecedenceOrder(class);
26814 
26815       if (pl != NULL) {
26816         pl = pl->nextPtr;
26817       }
26818       found = AppendMatchingElementsFromClasses(interp, pl, patternString, matchObject);
26819     } else {
26820       NsfClasses *clSuper = NsfReverseClasses(class->super);
26821 
26822       found = AppendMatchingElementsFromClasses(interp, clSuper, patternString, matchObject);
26823       NsfClassListFree(clSuper);
26824     }
26825 
26826     if (matchObject != NULL) {
26827       Tcl_SetObjResult(interp, found ? matchObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
26828     }
26829 
26830     if (patternObj != NULL) {
26831       DECR_REF_COUNT2("patternObj", patternObj);
26832     }
26833 
26834   }
26835   return TCL_OK;
26836 }
26837 
26838 
26839 /********************************
26840  * End result setting commands
26841  ********************************/
26842 
26843 /*
26844  *----------------------------------------------------------------------
26845  *
26846  * AliasIndex --
26847  *
26848  *      The alias index is an internal data structure keeping track of
26849  *      constructing aliases. This function computes the key of the index.
26850  *
26851  * Results:
26852  *      Returns a fresh Tcl_Obj. The caller is responsible for refcounting.
26853  *
26854  * Side effects:
26855  *      updating DString
26856  *
26857  *----------------------------------------------------------------------
26858  */
26859 static Tcl_Obj *AliasIndex(Tcl_Obj *cmdName, const char *methodName, bool withPer_object)
26860   nonnull(1) nonnull(2) returns_nonnull;
26861 
26862 static Tcl_Obj *
AliasIndex(Tcl_Obj * cmdName,const char * methodName,bool withPer_object)26863 AliasIndex(Tcl_Obj *cmdName, const char *methodName, bool withPer_object) {
26864   Tcl_DString  ds, *dsPtr = &ds;
26865   Tcl_Obj     *resultObj;
26866 
26867   nonnull_assert(cmdName != NULL);
26868   nonnull_assert(methodName != NULL);
26869 
26870   Tcl_DStringInit(dsPtr);
26871   Tcl_DStringAppend(dsPtr,  ObjStr(cmdName), -1);
26872   Tcl_DStringAppend(dsPtr,  ",", 1);
26873   Tcl_DStringAppend(dsPtr,  methodName, -11);
26874   if (withPer_object) {
26875     Tcl_DStringAppend(dsPtr, ",1", 2);
26876   } else {
26877     Tcl_DStringAppend(dsPtr, ",0", 2);
26878   }
26879   /*fprintf(stderr, "AI %s\n", Tcl_DStringValue(dsPtr));*/
26880   resultObj = Tcl_NewStringObj(dsPtr->string, dsPtr->length);
26881   Tcl_DStringFree(dsPtr);
26882 
26883   return resultObj;
26884 }
26885 
26886 /*
26887  *----------------------------------------------------------------------
26888  *
26889  * AliasAdd --
26890  *
26891  *      Add an alias to the alias index
26892  *
26893  * Results:
26894  *      Standard Tcl result
26895  *
26896  * Side effects:
26897  *      Adding value to the hidden associated array.
26898  *
26899  *----------------------------------------------------------------------
26900  */
26901 static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object,
26902          Tcl_Obj *cmdObj)
26903   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
26904 
26905 static int
AliasAdd(Tcl_Interp * interp,Tcl_Obj * cmdName,const char * methodName,bool withPer_object,Tcl_Obj * cmdObj)26906 AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object,
26907          Tcl_Obj *cmdObj) {
26908   Tcl_Obj    *indexObj;
26909 
26910   nonnull_assert(interp != NULL);
26911   nonnull_assert(cmdName != NULL);
26912   nonnull_assert(methodName != NULL);
26913   nonnull_assert(cmdObj != NULL);
26914 
26915 
26916 
26917   indexObj = AliasIndex(cmdName, methodName, withPer_object);
26918 
26919   INCR_REF_COUNT(indexObj);
26920   Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_ARRAY_ALIAS],
26921                  indexObj,
26922                  cmdObj,
26923                  TCL_GLOBAL_ONLY);
26924   DECR_REF_COUNT(indexObj);
26925 
26926   return TCL_OK;
26927 }
26928 
26929 /*
26930  *----------------------------------------------------------------------
26931  *
26932  * AliasDelete --
26933  *
26934  *      Delete an alias from the index
26935  *
26936  * Results:
26937  *      Standard Tcl result
26938  *
26939  * Side effects:
26940  *      delete an entry from the hidden associative array
26941  *
26942  *----------------------------------------------------------------------
26943  */
26944 static int
AliasDelete(Tcl_Interp * interp,Tcl_Obj * cmdName,const char * methodName,bool withPer_object)26945 AliasDelete(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object) {
26946   int         result;
26947   Tcl_Obj    *indexObj;
26948 
26949   nonnull_assert(interp != NULL);
26950   nonnull_assert(cmdName != NULL);
26951   nonnull_assert(methodName != NULL);
26952 
26953   indexObj = AliasIndex(cmdName, methodName, withPer_object);
26954   INCR_REF_COUNT(indexObj);
26955   result = Tcl_UnsetVar2(interp, NsfGlobalStrings[NSF_ARRAY_ALIAS],
26956                          ObjStr(indexObj),
26957                          TCL_GLOBAL_ONLY);
26958   DECR_REF_COUNT(indexObj);
26959 
26960   /*fprintf(stderr, "aliasDelete ::nsf::alias(%s) returned %d (%d)\n",
26961     AliasIndex(dsPtr, cmdName, methodName, withPer_object), result);*/
26962 
26963   return result;
26964 }
26965 
26966 /*
26967  *----------------------------------------------------------------------
26968  *
26969  * AliasGet --
26970  *
26971  *      Get an entry from the alias index.
26972  *
26973  * Results:
26974  *      Alias in form of a Tcl_Obj* (or NULL).
26975  *
26976  * Side effects:
26977  *      delete an entry from the hidden associative array
26978  *
26979  *----------------------------------------------------------------------
26980  */
26981 static Tcl_Obj *
AliasGet(Tcl_Interp * interp,Tcl_Obj * cmdName,const char * methodName,bool withPer_object,bool leaveError)26982 AliasGet(Tcl_Interp *interp, Tcl_Obj *cmdName, const char *methodName, bool withPer_object, bool leaveError) {
26983   Tcl_Obj *obj, *indexObj;
26984 
26985   nonnull_assert(interp != NULL);
26986   nonnull_assert(cmdName != NULL);
26987   nonnull_assert(methodName != NULL);
26988 
26989   indexObj = AliasIndex(cmdName, methodName, withPer_object);
26990 
26991   INCR_REF_COUNT(indexObj);
26992   obj = Tcl_ObjGetVar2(interp,
26993                        NsfGlobalObjs[NSF_ARRAY_ALIAS],
26994                        indexObj,
26995                        TCL_GLOBAL_ONLY);
26996   DECR_REF_COUNT(indexObj);
26997 
26998   /*fprintf(stderr, "aliasGet methodName '%s' returns %p\n", methodName, obj);*/
26999 
27000   if (obj == NULL && leaveError) {
27001     NsfPrintError(interp, "could not obtain alias definition for %s %s.",
27002                   ObjStr(cmdName), methodName);
27003   }
27004 
27005   return obj;
27006 }
27007 
27008 
27009 /*
27010  *----------------------------------------------------------------------
27011  * AliasDeleteObjectReference --
27012  *
27013  *    Delete an alias to a referenced object. Such aliases are
27014  *    created by registering an alias to an object. This function
27015  *    distinguishes between a sub-object and an alias to an object,
27016  *    deletes the alias but never the referenced object.
27017  *
27018  * Results:
27019  *    Boolean indicating when alias is deleted.
27020  *
27021  * Side effects:
27022  *    Deletes cmd sometimes
27023  *
27024  *----------------------------------------------------------------------
27025  */
27026 static bool
AliasDeleteObjectReference(Tcl_Interp * interp,Tcl_Command cmd)27027 AliasDeleteObjectReference(Tcl_Interp *interp, Tcl_Command cmd) {
27028   NsfObject *referencedObject = NsfGetObjectFromCmdPtr(cmd);
27029 
27030   nonnull_assert(interp != NULL);
27031   nonnull_assert(cmd != NULL);
27032   nonnull_assert(referencedObject != NULL);
27033 
27034   /*fprintf(stderr, "AliasDeleteObjectReference on %p obj %p\n", cmd, referencedObject);*/
27035   if (referencedObject->refCount > 0
27036       && cmd != referencedObject->id) {
27037     /*
27038      * The cmd is an aliased object, reduce the refCount of the
27039      * object, delete the cmd.
27040      */
27041     /*fprintf(stderr, "remove alias %s to %s\n",
27042       Tcl_GetCommandName(interp, cmd), ObjectName(referencedObject));*/
27043     NsfCleanupObject(referencedObject, "AliasDeleteObjectReference");
27044     Tcl_DeleteCommandFromToken(interp, cmd);
27045     return NSF_TRUE;
27046   }
27047   return NSF_FALSE;
27048 }
27049 
27050 /*
27051  *----------------------------------------------------------------------
27052  * AliasRefetch --
27053  *
27054  *    Perform a refetch of an epoched aliased cmd and update the
27055  *    AliasCmdClientData structure with fresh values.
27056  *
27057  * Results:
27058  *    Tcl result code.
27059  *
27060  * Side effects:
27061  *    None.
27062  *
27063  *----------------------------------------------------------------------
27064  */
27065 static int
AliasRefetch(Tcl_Interp * interp,NsfObject * object,const char * methodName,AliasCmdClientData * tcd)27066 AliasRefetch(Tcl_Interp *interp, NsfObject *object, const char *methodName, AliasCmdClientData *tcd) {
27067   Tcl_Obj **listElements, *entryObj, *targetObj;
27068   int nrElements, withPer_object;
27069   NsfObject *defObject;
27070   Tcl_Command cmd;
27071 
27072   nonnull_assert(interp != NULL);
27073   nonnull_assert(object != NULL);
27074   nonnull_assert(methodName != NULL);
27075   nonnull_assert(tcd != NULL);
27076 
27077   /*fprintf(stderr, "AliasRefetch %s\n", methodName);*/
27078 
27079   defObject = (tcd->class != NULL) ? &(tcd->class->object) : object;
27080 
27081   /*
27082    * Get the targetObject. Currently, we can get it just via the
27083    * alias array.
27084    */
27085   withPer_object = (tcd->class == NULL);
27086   entryObj = AliasGet(interp, defObject->cmdName, methodName, withPer_object, NSF_TRUE);
27087   if (unlikely(entryObj == NULL)) {
27088     return TCL_ERROR;
27089   }
27090 
27091   INCR_REF_COUNT(entryObj);
27092   Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements);
27093   targetObj = listElements[nrElements-1];
27094 
27095   NsfLog(interp, NSF_LOG_NOTICE,
27096          "trying to refetch an epoched cmd %p as %s -- cmdName %s",
27097          (void *)tcd->aliasedCmd, methodName, ObjStr(targetObj));
27098 
27099   /*
27100    * Replace cmd and its objProc and clientData with a newly fetched
27101    * version.
27102    */
27103   cmd = Tcl_GetCommandFromObj(interp, targetObj);
27104   if (cmd != NULL) {
27105     cmd = GetOriginalCommand(cmd);
27106     /*fprintf(stderr, "cmd %p epoch %d deleted %.6x\n",
27107       cmd,
27108       Tcl_Command_cmdEpoch(cmd),
27109       Tcl_Command_flags(cmd) & CMD_IS_DELETED);*/
27110     if (((unsigned int)Tcl_Command_flags(cmd) & CMD_IS_DELETED) != 0u) {
27111       cmd = NULL;
27112     }
27113   }
27114   if (cmd == NULL) {
27115     int result = NsfPrintError(interp, "target \"%s\" of alias %s apparently disappeared",
27116                                ObjStr(targetObj), methodName);
27117     DECR_REF_COUNT(entryObj);
27118     return result;
27119   }
27120 
27121   assert(Tcl_Command_objProc(cmd) != NULL);
27122 
27123   NsfCommandRelease(tcd->aliasedCmd);
27124   tcd->objProc    = Tcl_Command_objProc(cmd);
27125   tcd->aliasedCmd = cmd;
27126   tcd->clientData = Tcl_Command_objClientData(cmd);
27127   NsfCommandPreserve(tcd->aliasedCmd);
27128 
27129   DECR_REF_COUNT(entryObj);
27130   /*
27131    * Now, we should be able to proceed as planned, we have an
27132    * non-epoched aliasCmd.
27133    */
27134   return TCL_OK;
27135 }
27136 
27137 /*
27138  *----------------------------------------------------------------------
27139  * AliasDereference --
27140  *
27141  *    Dereference a cmd in respect of the alias structure. If necessary,
27142  *    this command refetches the aliased command.
27143  *
27144  * Results:
27145  *    NULL, in case refetching fails,
27146  *    the aliased cmd if it was an alias, or
27147  *    the original cmd
27148  *
27149  * Side effects:
27150  *    None.
27151  *
27152  *----------------------------------------------------------------------
27153  */
27154 NSF_INLINE static Tcl_Command AliasDereference(Tcl_Interp *interp, NsfObject *object, const char *methodName, Tcl_Command cmd)
27155   nonnull(1) nonnull(2) nonnull(3) nonnull(4);
27156 
27157 NSF_INLINE static Tcl_Command
AliasDereference(Tcl_Interp * interp,NsfObject * object,const char * methodName,Tcl_Command cmd)27158 AliasDereference(Tcl_Interp *interp, NsfObject *object, const char *methodName, Tcl_Command cmd) {
27159 
27160   nonnull_assert(interp != NULL);
27161   nonnull_assert(object != NULL);
27162   nonnull_assert(methodName != NULL);
27163   nonnull_assert(cmd != NULL);
27164 
27165   if (unlikely(Tcl_Command_objProc(cmd) == NsfProcAliasMethod)) {
27166     AliasCmdClientData *tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd);
27167 
27168     assert(tcd != NULL);
27169     /*fprintf(stderr, "AliasDereference %s epoch %d\n", methodName, Tcl_Command_cmdEpoch(tcd->aliasedCmd));*/
27170     if (unlikely(Tcl_Command_cmdEpoch(tcd->aliasedCmd) != 0)) {
27171 
27172       /*fprintf(stderr, "NsfProcAliasMethod aliasedCmd %p epoch %p\n",
27173         tcd->aliasedCmd, Tcl_Command_cmdEpoch(tcd->aliasedCmd));*/
27174 
27175       if (AliasRefetch(interp, object, methodName, tcd) != TCL_OK) {
27176         return NULL;
27177       }
27178     }
27179     return tcd->aliasedCmd;
27180   }
27181 
27182   return cmd;
27183 }
27184 
27185 #if defined(NSF_ASSEMBLE)
27186 # include "asm/nsfAssemble.c"
27187 #else
27188 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))27189   NsfAsmMethodCreateCmd(Tcl_Interp *UNUSED(interp),
27190                         NsfObject *UNUSED(defObject),
27191                         int UNUSED(with_checkAlways),
27192                         int UNUSED(withInner_namespace),
27193                         int UNUSED(withPer_object),
27194                         NsfObject *UNUSED(regObject),
27195                         Tcl_Obj *UNUSED(nameObj),
27196                         Tcl_Obj *UNUSED(argumentsObj),
27197                         Tcl_Obj *UNUSED(bodyObj))
27198 {
27199   /*
27200    * Dummy stub; used, when compiled without NSF_ASSEMBLE
27201    */
27202   return TCL_OK;
27203 }
27204 #endif
27205 
27206 /*
27207  *----------------------------------------------------------------------
27208  * SetBooleanFlag --
27209  *
27210  *    Set an unsigned int flag based on valueObj
27211  *
27212  * Results:
27213  *    Tcl result code
27214  *
27215  * Side effects:
27216  *    update passed flags
27217  *
27218  *----------------------------------------------------------------------
27219  */
27220 
27221 static int SetBooleanFlag(Tcl_Interp *interp, unsigned int *flagsPtr, unsigned int flag, Tcl_Obj *valueObj, int *flagValue)
27222   nonnull(1) nonnull(2) nonnull(4) nonnull(5);
27223 
27224 static int
SetBooleanFlag(Tcl_Interp * interp,unsigned int * flagsPtr,unsigned int flag,Tcl_Obj * valueObj,int * flagValue)27225 SetBooleanFlag(Tcl_Interp *interp, unsigned int *flagsPtr, unsigned int flag, Tcl_Obj *valueObj, int *flagValue) {
27226   int result;
27227 
27228   nonnull_assert(interp != NULL);
27229   nonnull_assert(flagsPtr != NULL);
27230   nonnull_assert(valueObj != NULL);
27231   nonnull_assert(flagValue != NULL);
27232 
27233   result = Tcl_GetBooleanFromObj(interp, valueObj, flagValue);
27234   if (unlikely(result != TCL_OK)) {
27235     return result;
27236   }
27237   if (*flagValue) {
27238     *flagsPtr |= flag;
27239   } else {
27240     *flagsPtr &= ~flag;
27241   }
27242   return result;
27243 }
27244 
27245 /***********************************************************************
27246  * Begin generated Next Scripting commands
27247  ***********************************************************************/
27248 
27249 /*
27250 cmd __db_compile_epoch NsfDebugCompileEpoch {}
27251  */
27252 static int NsfDebugCompileEpoch(Tcl_Interp *interp)
27253   nonnull(1);
27254 
27255 static int
NsfDebugCompileEpoch(Tcl_Interp * interp)27256 NsfDebugCompileEpoch(Tcl_Interp *interp) {
27257 
27258   nonnull_assert(interp != NULL);
27259 
27260   Tcl_SetObjResult(interp, Tcl_NewIntObj((int)(((Interp *)interp)->compileEpoch)));
27261   return TCL_OK;
27262 }
27263 
27264 /*
27265 cmd __db_show_obj NsfDebugShowObj {
27266   {-argName "obj"    -required 1 -type tclobj}
27267 }
27268 */
27269 static int NsfDebugShowObj(Tcl_Interp *interp, Tcl_Obj *obj)
27270   nonnull(1) nonnull(2);
27271 
27272 static int
NsfDebugShowObj(Tcl_Interp * interp,Tcl_Obj * obj)27273 NsfDebugShowObj(Tcl_Interp *interp, Tcl_Obj *obj) {
27274 
27275   nonnull_assert(interp != NULL);
27276   nonnull_assert(obj != NULL);
27277 
27278   fprintf(stderr, "*** obj %p refCount %d type <%s> ",
27279           (void *)obj, obj->refCount, ObjTypeStr(obj));
27280 
27281   if (obj->typePtr == &NsfObjectMethodObjType
27282       || obj->typePtr == &NsfInstanceMethodObjType
27283       ) {
27284     NsfMethodContext *mcPtr = obj->internalRep.twoPtrValue.ptr1;
27285     unsigned int currentMethodEpoch = obj->typePtr == &NsfObjectMethodObjType ?
27286       RUNTIME_STATE(interp)->objectMethodEpoch :
27287       RUNTIME_STATE(interp)->instanceMethodEpoch;
27288     Tcl_Command cmd = mcPtr->cmd;
27289 
27290     fprintf(stderr, "   method epoch %u max %u cmd %p objProc 0x%" PRIxPTR " flags %.6x",
27291             mcPtr->methodEpoch, currentMethodEpoch,
27292             (void *)cmd,
27293             (cmd != NULL) ? (unsigned long)PTR2UINT(((Command *)cmd)->objProc) : 0ul,
27294             mcPtr->flags);
27295     if (cmd != NULL) {
27296       fprintf(stderr, "... cmd %p flags %.6x\n", (void *)cmd, Tcl_Command_flags(cmd));
27297       assert(((Command *)cmd)->objProc != NULL);
27298     }
27299     assert(currentMethodEpoch >= mcPtr->methodEpoch);
27300 
27301   } else if (obj->typePtr == Nsf_OT_tclCmdNameType) {
27302     Tcl_Command cmd = Tcl_GetCommandFromObj(interp, obj);
27303 
27304     if (likely(cmd != NULL)) {
27305       Command    *procPtr = (Command *)cmd;
27306       const char *tail = Tcl_GetHashKey(procPtr->hPtr->tablePtr, procPtr->hPtr);
27307 
27308       fprintf(stderr, "... cmd %p flags %.6x name '%s' ns '%s' objProcName %s",
27309               (void *)cmd, Tcl_Command_flags(cmd), tail, procPtr->nsPtr->name,
27310               CmdObjProcName(cmd));
27311     }
27312   } else if ((obj->typePtr == Nsf_OT_byteArrayType)
27313              || (obj->typePtr == Nsf_OT_properByteArrayType)) {
27314     const char *bytes;
27315     int         i, length;
27316 
27317     bytes = (char *)Tcl_GetByteArrayFromObj(obj, &length);
27318 
27319     fprintf(stderr, "bytearray proper %d length %d string rep %p: ",
27320             (obj->typePtr == Nsf_OT_properByteArrayType),
27321             length, (void*)obj->bytes);
27322     for (i = 0; i < length; i++) {
27323       fprintf(stderr, "%.2x", (unsigned)(*(bytes+i)) & 0xff);
27324     }
27325   }
27326   fprintf(stderr, "\n");
27327 
27328   return TCL_OK;
27329 }
27330 
27331 /*
27332 cmd __db_get_obj NsfDebugGetDict {
27333   {-argName "obj"    -required 1 -type tclobj}
27334 }
27335 */
27336 #define NSF_DEBUG_SHOW_BYTES 10u
27337 static int NsfDebugGetDict(Tcl_Interp *interp, Tcl_Obj *obj)
27338   nonnull(1) nonnull(2);
27339 
27340 static int
NsfDebugGetDict(Tcl_Interp * interp,Tcl_Obj * obj)27341 NsfDebugGetDict(Tcl_Interp *interp, Tcl_Obj *obj) {
27342   Tcl_Obj    *resultObj;
27343   const char *typeString;
27344 
27345   nonnull_assert(interp != NULL);
27346   nonnull_assert(obj != NULL);
27347 
27348   typeString = (obj->typePtr != NULL) ? obj->typePtr->name : "";
27349 
27350   resultObj = Tcl_NewListObj(4, NULL);
27351   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("type", -1));
27352   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(typeString, -1));
27353   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("refcount", -1));
27354   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewIntObj(obj->refCount));
27355   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("length", -1));
27356   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewIntObj(obj->length));
27357   Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("hex", -1));
27358 
27359   if (obj->bytes != NULL) {
27360     size_t       i, objLength = (size_t)obj->length;
27361     char         trailer[3] = "...";
27362     char         buffer[NSF_DEBUG_SHOW_BYTES*2u + sizeof(trailer) + 1u];
27363 
27364     for (i = 0; i < NSF_DEBUG_SHOW_BYTES && i < objLength; i++) {
27365       snprintf(buffer + i*2, sizeof(buffer) - (i+1)*2, "%.2x", (unsigned)(*((obj->bytes)+i) & 0xff));
27366     }
27367     if (objLength > NSF_DEBUG_SHOW_BYTES) {
27368       strncat(buffer, trailer, sizeof(buffer) - strlen(buffer) - 1);
27369     }
27370     Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(buffer, -1));
27371 
27372   }
27373   Tcl_SetObjResult(interp, resultObj);
27374 
27375   return TCL_OK;
27376 }
27377 
27378 /*
27379 cmd __db_show_stack NsfShowStackCmd {}
27380 */
27381 static int
NsfShowStackCmd(Tcl_Interp * interp)27382 NsfShowStackCmd(Tcl_Interp *interp) {
27383 
27384   nonnull_assert(interp != NULL);
27385 
27386   NsfShowStack(interp);
27387   return TCL_OK;
27388 }
27389 
27390 /*
27391 cmd __db_run_assertions NsfDebugRunAssertionsCmd {}
27392 */
27393 static int
NsfDebugRunAssertionsCmd(Tcl_Interp * interp)27394 NsfDebugRunAssertionsCmd(Tcl_Interp *interp) {
27395   NsfObjectSystem *osPtr;
27396   NsfCmdList      *instances = NULL, *entry;
27397 
27398   nonnull_assert(interp != NULL);
27399 
27400   /*
27401    * Collect all instances from all object systems.
27402    */
27403   for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
27404     GetAllInstances(interp, &instances, osPtr->rootClass);
27405   }
27406 
27407   for (entry = instances; entry != NULL; entry = entry->nextPtr) {
27408 #if !defined(NDEBUG)
27409     NsfObject *object = (NsfObject *)entry->clorobj;
27410 #endif
27411 
27412     assert(object != NULL);
27413     assert(object->refCount > 0);
27414     assert(object->cmdName->refCount > 0);
27415     assert(object->activationCount >= 0);
27416 
27417 #if defined(CHECK_ACTIVATION_COUNTS)
27418     if (object->activationCount > 0) {
27419       Tcl_CallFrame *framePtr;
27420       int            count = 0;
27421       NsfClasses    *unstackedEntries = RUNTIME_STATE(interp)->cscList;
27422 
27423       /*fprintf(stderr, "DEBUG obj %p %s activationcount %d\n",
27424         object, ObjectName(object), object->activationCount);*/
27425 
27426       framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp);
27427       for (; framePtr != NULL; framePtr = Tcl_CallFrame_callerPtr(framePtr)) {
27428         int                  frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr);
27429         NsfCallStackContent *cscPtr =
27430           ((frameFlags & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) ?
27431           ((NsfCallStackContent *)Tcl_CallFrame_clientData(framePtr)) : NULL;
27432 
27433         if (cscPtr != NULL && cscPtr->self == object) {
27434           count ++;
27435         }
27436         if (cscPtr != NULL && (NsfObject *)cscPtr->cl == object) {
27437           count ++;
27438         }
27439       }
27440       for (; unstackedEntries; unstackedEntries = unstackedEntries->nextPtr) {
27441         NsfCallStackContent *cscPtr = (NsfCallStackContent *)unstackedEntries->cl;
27442 
27443         if (cscPtr != NULL && cscPtr->self == object) {
27444           count ++;
27445         }
27446         if (cscPtr != NULL && (NsfObject *)cscPtr->cl == object) {
27447           count ++;
27448         }
27449       }
27450 
27451       if (count != object->activationCount) {
27452         fprintf(stderr, "DEBUG obj %p %s activationcount %d on stack %d; "
27453                 "might be from non-stacked but active call-stack content\n",
27454                 object, ObjectName(object), object->activationCount, count);
27455         fprintf(stderr, "fixed count %d\n", count);
27456         /*NsfShowStack(interp);*/
27457         /*return NsfPrintError(interp, "wrong activation count for object %s", ObjectName(object));*/
27458       }
27459     }
27460 #endif
27461 
27462   }
27463   CmdListFree(&instances, NULL);
27464   /*fprintf(stderr, "all assertions passed\n");*/
27465 
27466   return TCL_OK;
27467 }
27468 
27469 /*
27470 cmd __profile_clear_data NsfProfileClearDataStub {}
27471 cmd __profile_get_data NsfProfileGetDataStub {}
27472 cmd __profile_trace NsfProfileTraceStub {
27473   {-argName "-enable" -required 1 -nrargs 1 -type boolean}
27474   {-argName "-verbose" -required 0 -nrargs 1 -type boolean}
27475   {-argName "-dontsave" -required 0 -nrargs 1 -type boolean}
27476   {-argName "-builtins" -required 0 -nrargs 1 -type tclobj}
27477 }
27478 */
27479 
27480 static int NsfProfileClearDataStub(Tcl_Interp *interp)
27481   nonnull(1);
27482 static int NsfProfileGetDataStub(Tcl_Interp *interp)
27483   nonnull(1);
27484 static int NsfProfileTraceStub(Tcl_Interp *interp,
27485                                int withEnable, int withVerbose, int withDontsave,
27486                                Tcl_Obj *builtinsObj)
27487   NSF_nonnull(1);
27488 
27489 #if defined(NSF_PROFILE)
27490 
27491 static int
NsfProfileClearDataStub(Tcl_Interp * interp)27492 NsfProfileClearDataStub(Tcl_Interp *interp) {
27493   nonnull_assert(interp != NULL);
27494   NsfProfileClearData(interp);
27495   return TCL_OK;
27496 }
27497 
27498 
27499 static int
NsfProfileGetDataStub(Tcl_Interp * interp)27500 NsfProfileGetDataStub(Tcl_Interp *interp) {
27501   nonnull_assert(interp != NULL);
27502   NsfProfileGetData(interp);
27503   return TCL_OK;
27504 }
27505 
27506 static int
NsfProfileTraceStub(Tcl_Interp * interp,int withEnable,int withVerbose,int withDontsave,Tcl_Obj * builtinsObj)27507 NsfProfileTraceStub(Tcl_Interp *interp, int withEnable, int withVerbose, int withDontsave, Tcl_Obj *builtinsObj) {
27508   nonnull_assert(interp != NULL);
27509   NsfProfileTrace(interp, withEnable, withVerbose, withDontsave, builtinsObj);
27510   return TCL_OK;
27511 }
27512 
27513 #else
NsfProfileClearDataStub(Tcl_Interp * UNUSED (interp))27514 static int NsfProfileClearDataStub(Tcl_Interp *UNUSED(interp)) {
27515   return TCL_OK;
27516 }
NsfProfileGetDataStub(Tcl_Interp * UNUSED (interp))27517 static int NsfProfileGetDataStub(  Tcl_Interp *UNUSED(interp)) {
27518   return TCL_OK;
27519 }
NsfProfileTraceStub(Tcl_Interp * UNUSED (interp),int UNUSED (withEnable),int UNUSED (withVerbose),int UNUSED (withDontsave),Tcl_Obj * UNUSED (builtins))27520 static int NsfProfileTraceStub(    Tcl_Interp *UNUSED(interp),
27521                     int UNUSED(withEnable),
27522                     int UNUSED(withVerbose),
27523                     int UNUSED(withDontsave),
27524                     Tcl_Obj *UNUSED(builtins)) {
27525   return TCL_OK;
27526 }
27527 #endif
27528 
27529 /*
27530  * Valgrind/callgrind support
27531  */
27532 #if defined(NSF_VALGRIND)
27533 
27534 #include <valgrind/callgrind.h>
27535 /*
27536 cmd __callgrind_dump_stats NsfCallgrindDumpStatsCmd {
27537   {-argName "-name" -required 0 -nrargs 1}
27538 }
27539 cmd __callgrind_start_instrumentation NsfCallgrindStartInstrumentationCmd {}
27540 cmd __callgrind_stop_instrumentation NsfCallgrindStopInstrumentationCmd {}
27541 cmd __callgrind_toggle_collect NsfCallgrindToggleCollectCmd {}
27542 cmd __callgrind_zero_stats NsfCallgrindZeroStatsCmd {}
27543 */
27544 
27545 static int
NsfCallgrindDumpStatsCmd(Tcl_Interp * UNUSED (interp),const char * nameString)27546 NsfCallgrindDumpStatsCmd(Tcl_Interp *UNUSED(interp), const char *nameString) {
27547   if (nameString == NULL) {
27548     CALLGRIND_DUMP_STATS;
27549   } else {
27550     CALLGRIND_DUMP_STATS_AT(nameString);
27551   }
27552   return TCL_OK;
27553 }
27554 
27555 static int
NsfCallgrindStartInstrumentationCmd(Tcl_Interp * UNUSED (interp))27556 NsfCallgrindStartInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
27557   CALLGRIND_START_INSTRUMENTATION;
27558   return TCL_OK;
27559 }
27560 
27561 static int
NsfCallgrindStopInstrumentationCmd(Tcl_Interp * UNUSED (interp))27562 NsfCallgrindStopInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
27563   CALLGRIND_STOP_INSTRUMENTATION;
27564   return TCL_OK;
27565 }
27566 
27567 static int
NsfCallgrindToggleCollectCmd(Tcl_Interp * UNUSED (interp))27568 NsfCallgrindToggleCollectCmd(Tcl_Interp *UNUSED(interp)) {
27569   CALLGRIND_TOGGLE_COLLECT;
27570   return TCL_OK;
27571 }
27572 
27573 static int
NsfCallgrindZeroStatsCmd(Tcl_Interp * UNUSED (interp))27574 NsfCallgrindZeroStatsCmd(Tcl_Interp *UNUSED(interp)) {
27575   CALLGRIND_ZERO_STATS;
27576   return TCL_OK;
27577 }
27578 #else
27579 
NsfCallgrindDumpStatsCmd(Tcl_Interp * UNUSED (interp),const char * UNUSED (nameString))27580 static int NsfCallgrindDumpStatsCmd(Tcl_Interp *UNUSED(interp), const char *UNUSED(nameString)) {
27581   return TCL_OK;
27582 }
NsfCallgrindStartInstrumentationCmd(Tcl_Interp * UNUSED (interp))27583 static int NsfCallgrindStartInstrumentationCmd(Tcl_Interp *UNUSED(interp)) {
27584   return TCL_OK;
27585 }
NsfCallgrindStopInstrumentationCmd(Tcl_Interp * UNUSED (interp))27586 static int NsfCallgrindStopInstrumentationCmd(Tcl_Interp *UNUSED(interp))  {
27587   return TCL_OK;
27588 }
NsfCallgrindToggleCollectCmd(Tcl_Interp * UNUSED (interp))27589 static int NsfCallgrindToggleCollectCmd(Tcl_Interp *UNUSED(interp))        {
27590   return TCL_OK;
27591 }
NsfCallgrindZeroStatsCmd(Tcl_Interp * UNUSED (interp))27592 static int NsfCallgrindZeroStatsCmd(Tcl_Interp *UNUSED(interp))            {
27593   return TCL_OK;
27594 }
27595 
27596 #endif
27597 
27598 /*
27599  *----------------------------------------------------------------------
27600  * NsfUnsetUnknownArgsCmd --
27601 *
27602  *    Unset variables set from arguments with the default dummy
27603  *    default value. The dummy default values are set by
27604  *    ArgumentDefaults()
27605  *
27606  * Results:
27607  *    Tcl result code.
27608  *
27609  * Side effects:
27610  *    unsets some variables
27611  *
27612  *----------------------------------------------------------------------
27613  */
27614 /*
27615 cmd __unset_unknown_args NsfUnsetUnknownArgsCmd {}
27616 */
27617 
27618 static int
NsfUnsetUnknownArgsCmd(Tcl_Interp * interp)27619 NsfUnsetUnknownArgsCmd(Tcl_Interp *interp) {
27620   CallFrame *varFramePtr;
27621   Proc      *proc;
27622 
27623   nonnull_assert(interp != NULL);
27624 
27625   varFramePtr = Tcl_Interp_varFramePtr(interp);
27626   proc = Tcl_CallFrame_procPtr(varFramePtr);
27627 
27628   if (likely(proc != NULL)) {
27629     const CompiledLocal *ap;
27630     const Var           *varPtr;
27631     int                  i;
27632 
27633     for (ap = proc->firstLocalPtr, i = 0; ap; ap = ap->nextPtr, i++) {
27634       if (!TclIsCompiledLocalArgument(ap)) {
27635         continue;
27636       }
27637       varPtr = &Tcl_CallFrame_compiledLocals(varFramePtr)[i];
27638       /*fprintf(stderr, "NsfUnsetUnknownArgsCmd var '%s' i %d fi %d var %p flags %.8x obj %p unk %p\n",
27639               ap->name, i, ap->frameIndex, varPtr, varPtr->flags, varPtr->value.objPtr,
27640               NsfGlobalObjs[NSF___UNKNOWN__]);*/
27641       if (varPtr->value.objPtr != NsfGlobalObjs[NSF___UNKNOWN__]) {
27642         continue;
27643       }
27644       /*fprintf(stderr, "NsfUnsetUnknownArgsCmd must unset %s\n", ap->name);*/
27645       Tcl_UnsetVar2(interp, ap->name, NULL, 0);
27646     }
27647   }
27648 
27649   return TCL_OK;
27650 }
27651 
27652 /*
27653 cmd asmproc NsfAsmProcCmd {
27654   {-argName "-ad" -required 0  -nrargs 0 -type switch}
27655   {-argName "-checkalways" -required 0  -nrargs 0 -type switch}
27656   {-argName "procName" -required 1 -type tclobj}
27657   {-argName "arguments" -required 1 -type tclobj}
27658   {-argName "body" -required 1 -type tclobj}
27659 }
27660 */
27661 #if !defined(NSF_ASSEMBLE)
27662 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))27663 NsfAsmProcCmd(Tcl_Interp *UNUSED(interp),
27664               int UNUSED(with_ad),
27665               int UNUSED(with_checkAlways),
27666               Tcl_Obj *UNUSED(nameObj),
27667               Tcl_Obj *UNUSED(arguments),
27668               Tcl_Obj *UNUSED(body))
27669 {
27670   return TCL_OK;
27671 }
27672 #else
27673 static int
NsfAsmProcCmd(Tcl_Interp * interp,int with_ad,int with_checkAlways,Tcl_Obj * nameObj,Tcl_Obj * arguments,Tcl_Obj * body)27674 NsfAsmProcCmd(Tcl_Interp *interp, int with_ad, int with_checkAlways, Tcl_Obj *nameObj, Tcl_Obj *arguments, Tcl_Obj *body) {
27675   NsfParsedParam parsedParam;
27676   int result;
27677 
27678   nonnull_assert(interp != NULL);
27679   nonnull_assert(nameObj != NULL);
27680   nonnull_assert(arguments != NULL);
27681   nonnull_assert(body != NULL);
27682 
27683   /*
27684    * Parse argument list "arguments" to determine if we should provide
27685    * nsf parameter handling.
27686    */
27687   result = ParamDefsParse(interp, nameObj, arguments,
27688                           NSF_DISALLOWED_ARG_METHOD_PARAMETER, NSF_FALSE,
27689                           &parsedParam, NULL);
27690   if (unlikely(result != TCL_OK)) {
27691     return result;
27692   }
27693 
27694   if (parsedParam.paramDefs != NULL) {
27695     /*
27696      * We need parameter handling.
27697      */
27698     result = NsfAsmProcAddParam(interp, &parsedParam, nameObj, body, with_ad, with_checkAlways);
27699 
27700   } else {
27701     /*
27702      * No parameter handling needed.
27703      */
27704     result = NsfAsmProcAddArgs(interp, arguments, nameObj, body, with_ad, with_checkAlways);
27705   }
27706 
27707   return result;
27708 }
27709 #endif
27710 
27711 /*
27712 cmd "cmd::info" NsfCmdInfoCmd {
27713   {-argName "subcmd" -required 1 -typeName "methodgetcmd" -type "args|body|definition|exists|registrationhandle|definitionhandle|origin|parameter|syntax|type|precondition|postcondition|submethods|returns"}
27714   {-argName "-context" -required 0 -type object}
27715   {-argName "methodName" -required 1 -type tclobj}
27716   {-argName "pattern" -required 0}
27717 } {-nxdoc 1}
27718 */
27719 static int
NsfCmdInfoCmd(Tcl_Interp * interp,InfomethodsubcmdIdx_t subcmd,NsfObject * contextObject,Tcl_Obj * methodNameObj,const char * pattern)27720 NsfCmdInfoCmd(Tcl_Interp *interp, InfomethodsubcmdIdx_t subcmd, NsfObject *contextObject,
27721               Tcl_Obj *methodNameObj, const char *pattern) {
27722 
27723   nonnull_assert(interp != NULL);
27724   nonnull_assert(methodNameObj != NULL);
27725 
27726   return ListMethodResolve(interp, subcmd, contextObject, pattern, NULL, NULL, methodNameObj, NSF_FALSE);
27727 }
27728 
27729 /*
27730 cmd configure NsfConfigureCmd {
27731   {-argName "option" -required 1 -type "debug|dtrace|filter|profile|softrecreate|objectsystems|keepcmds|checkresults|checkarguments"}
27732   {-argName "value" -required 0 -type tclobj}
27733 }
27734 */
27735 static int
NsfConfigureCmd(Tcl_Interp * interp,ConfigureoptionIdx_t option,Tcl_Obj * valueObj)27736 NsfConfigureCmd(Tcl_Interp *interp, ConfigureoptionIdx_t option, Tcl_Obj *valueObj) {
27737   int boolVal;
27738 
27739   nonnull_assert(interp != NULL);
27740 #if defined(NSF_DTRACE)
27741   if (NSF_DTRACE_CONFIGURE_PROBE_ENABLED()) {
27742     NSF_DTRACE_CONFIGURE_PROBE((char *)Nsf_Configureoption[option-1],
27743                                (valueObj != NULL) ? ObjStr(valueObj) : NULL);
27744   }
27745 #endif
27746 
27747   if (option == ConfigureoptionObjectsystemsIdx) {
27748     NsfObjectSystem *osPtr;
27749     Tcl_Obj         *list = Tcl_NewListObj(0, NULL);
27750 
27751     for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr != NULL; osPtr = osPtr->nextPtr) {
27752       Tcl_Obj *osObj = Tcl_NewListObj(0, NULL);
27753       Tcl_Obj *systemMethods = Tcl_NewListObj(0, NULL);
27754       int      idx;
27755 
27756       Tcl_ListObjAppendElement(interp, osObj, osPtr->rootClass->object.cmdName);
27757       Tcl_ListObjAppendElement(interp, osObj, osPtr->rootMetaClass->object.cmdName);
27758 
27759       for (idx = 0; Nsf_SystemMethodOpts[idx]; idx++) {
27760         /*fprintf(stderr, "opt %s %s\n", Nsf_SystemMethodOpts[idx],
27761           osPtr->methods[idx] ? ObjStr(osPtr->methods[idx]) : "NULL");*/
27762         if (osPtr->methods[idx] == NULL) {
27763           continue;
27764         }
27765         Tcl_ListObjAppendElement(interp, systemMethods, Tcl_NewStringObj(Nsf_SystemMethodOpts[idx], -1));
27766         if (osPtr->handles[idx] || osPtr->protected[idx]) {
27767           Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
27768 
27769           Tcl_ListObjAppendElement(interp, listObj, osPtr->methods[idx]);
27770           Tcl_ListObjAppendElement(interp, listObj, osPtr->handles[idx]);
27771           if (osPtr->protected[idx]) {
27772             Tcl_ListObjAppendElement(interp, listObj, Tcl_NewIntObj(1));
27773           }
27774           Tcl_ListObjAppendElement(interp, systemMethods, listObj);
27775         } else {
27776           Tcl_ListObjAppendElement(interp, systemMethods, osPtr->methods[idx]);
27777         }
27778       }
27779       Tcl_ListObjAppendElement(interp, osObj, systemMethods);
27780       Tcl_ListObjAppendElement(interp, list, osObj);
27781     }
27782     Tcl_SetObjResult(interp, list);
27783     return TCL_OK;
27784   }
27785 
27786   if (option == ConfigureoptionDebugIdx) {
27787 
27788     if (valueObj != NULL) {
27789       int level, result = Tcl_GetIntFromObj(interp, valueObj, &level);
27790 
27791       if (unlikely(result != TCL_OK)) {
27792         return result;
27793       }
27794       RUNTIME_STATE(interp)->logSeverity = level;
27795     }
27796     Tcl_SetIntObj(Tcl_GetObjResult(interp),
27797                   RUNTIME_STATE(interp)->logSeverity);
27798 
27799     return TCL_OK;
27800   }
27801 
27802   /*
27803    * All other configure options are boolean.
27804    */
27805   if (valueObj != NULL) {
27806     int result = Tcl_GetBooleanFromObj(interp, valueObj, &boolVal);
27807     if (unlikely(result != TCL_OK)) {
27808       return result;
27809     }
27810   }
27811 
27812   switch (option) {
27813 
27814   case ConfigureoptionDebugIdx: /* fall through */
27815   case ConfigureoptionObjectsystemsIdx:
27816     /*
27817      * Handled above.
27818      */
27819     break;
27820 
27821   case ConfigureoptionDtraceIdx:
27822     /*
27823      * Not implemented.
27824      */
27825     break;
27826 
27827   case ConfigureoptionNULL:
27828     /*
27829      * Do nothing; just for detection if option was specified.
27830      */
27831     break;
27832 
27833   case ConfigureoptionFilterIdx:
27834     Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
27835                       (RUNTIME_STATE(interp)->doFilters));
27836     if (valueObj != NULL) {
27837       RUNTIME_STATE(interp)->doFilters = boolVal;
27838     }
27839     break;
27840 
27841   case ConfigureoptionSoftrecreateIdx:
27842     Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
27843                       (RUNTIME_STATE(interp)->doSoftrecreate));
27844     if (valueObj != NULL) {
27845       RUNTIME_STATE(interp)->doSoftrecreate = boolVal;
27846     }
27847     break;
27848 
27849   case ConfigureoptionKeepcmdsIdx:
27850     Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
27851                       (RUNTIME_STATE(interp)->doKeepcmds));
27852     if (valueObj != NULL) {
27853       RUNTIME_STATE(interp)->doKeepcmds = boolVal;
27854     }
27855     break;
27856 
27857   case ConfigureoptionCheckresultsIdx:
27858     Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
27859                       (RUNTIME_STATE(interp)->doCheckResults));
27860     if (valueObj != NULL) {
27861       RUNTIME_STATE(interp)->doCheckResults = (unsigned int)boolVal;
27862     }
27863     break;
27864 
27865   case ConfigureoptionCheckargumentsIdx:
27866     Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
27867                       (RUNTIME_STATE(interp)->doCheckArguments) != 0);
27868     if (valueObj != NULL) {
27869       RUNTIME_STATE(interp)->doCheckArguments = (boolVal != 0) ? NSF_ARGPARSE_CHECK : 0;
27870     }
27871     break;
27872 
27873   }
27874   return TCL_OK;
27875 }
27876 
27877 
27878 /*
27879 cmd colon NsfColonCmd {
27880   {-argName "args" -type allargs}
27881 }
27882 */
27883 static int
NsfColonCmd(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])27884 NsfColonCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
27885   const char *methodName = ObjStr(objv[0]);
27886   NsfObject  *self;
27887   int         result;
27888 
27889   nonnull_assert(interp != NULL);
27890 
27891   self = GetSelfObj(interp);
27892   if (unlikely(self == NULL)) {
27893     return NsfNoCurrentObjectError(interp, methodName);
27894   }
27895   /*fprintf(stderr, "Colon dispatch %s.%s (%d)\n",
27896     ObjectName(self), ObjStr(nobjv[0]), nobjc);*/
27897 
27898   /*
27899    * Do we have a method, which is NOT a single colon?
27900    */
27901   if (likely(!(*methodName == ':' && *(methodName + 1) == '\0'))) {
27902     /*
27903      * A method like ":foo" is called via plain ObjectDispatch().
27904      */
27905     result = ObjectDispatch(self, interp, objc, objv, NSF_CM_NO_SHIFT);
27906 
27907   } else {
27908 
27909     /*
27910      * The method name is a single colon, and might have one or more
27911      * arguments.
27912      */
27913     if (objc <= 1) {
27914       /*
27915        * Single colon and no arguments.
27916        */
27917       Tcl_SetObjResult(interp, self->cmdName);
27918       result = TCL_OK;
27919 
27920     } else {
27921       /*
27922        * Single colon and multiple arguments.
27923        */
27924       methodName = ObjStr(objv[1]);
27925       if (*methodName != '-') {
27926         /*
27927          * No need to parse arguments (local, intrinsic, ...).
27928          */
27929         result = ObjectDispatch(self, interp, objc, objv, 0u);
27930       } else {
27931         ParseContext pc;
27932 
27933         /*
27934          * Parse arguments, use definitions from nsf::my
27935          */
27936         result = ArgumentParse(interp, objc, objv, NULL, objv[0],
27937                                method_definitions[NsfMyCmdIdx].paramDefs,
27938                                method_definitions[NsfMyCmdIdx].nrParameters,
27939                                0, NSF_ARGPARSE_BUILTIN, &pc);
27940         if (likely(result == TCL_OK)) {
27941           int      withIntrinsic, withLocal, withSystem;
27942           Tcl_Obj *methodObj;
27943 
27944           withIntrinsic = (int)PTR2INT(pc.clientData[0]);
27945           withLocal     = (int)PTR2INT(pc.clientData[1]);
27946           withSystem    = (int)PTR2INT(pc.clientData[2]);
27947           methodObj     = (Tcl_Obj *)pc.clientData[3];
27948 
27949           assert(pc.status == 0);
27950 
27951           if ((withIntrinsic && withLocal)
27952               || (withIntrinsic && withSystem)
27953               || (withLocal && withSystem)) {
27954             result = NsfPrintError(interp, "flags '-intrinsic', '-local' and '-system' are mutual exclusive");
27955           } else {
27956             unsigned int flags;
27957 
27958             flags = NSF_CSC_IMMEDIATE;
27959             if (withIntrinsic != 0) {
27960               flags |= NSF_CM_INTRINSIC_METHOD;
27961             }
27962             if (withLocal != 0)     {
27963               flags |= NSF_CM_LOCAL_METHOD;
27964             }
27965             if (withSystem != 0)    {
27966               flags |= NSF_CM_SYSTEM_METHOD;
27967             }
27968             result = CallMethod(self, interp, methodObj, (objc - pc.lastObjc) + 2, objv + pc.lastObjc, flags);
27969           }
27970         }
27971       }
27972     }
27973   }
27974   return result;
27975 }
27976 
27977 /*
27978 cmd "definitionnamespace" NsfDefinitionNamespaceCmd {
27979 }
27980 */
27981 static int
NsfDefinitionNamespaceCmd(Tcl_Interp * interp)27982 NsfDefinitionNamespaceCmd(Tcl_Interp *interp)
27983 {
27984   Tcl_Namespace *nsPtr;
27985 
27986   nonnull_assert(interp != NULL);
27987 
27988   nsPtr = CallingNameSpace(interp);
27989   Tcl_SetObjResult(interp, Tcl_NewStringObj(nsPtr->fullName, -1));
27990 
27991   return TCL_OK;
27992 }
27993 
27994 
27995 /*
27996 cmd "directdispatch" NsfDirectDispatchCmd {
27997   {-argName "object" -required 1 -type object}
27998   {-argName "-frame" -required 0 -nrargs 1 -type "method|object|default" -default "default"}
27999   {-argName "command" -required 1 -type tclobj}
28000   {-argName "args"  -type args}
28001 }
28002 */
28003 static int
NsfDirectDispatchCmd(Tcl_Interp * interp,NsfObject * object,FrameIdx_t withFrame,Tcl_Obj * commandObj,int trailingObjc,Tcl_Obj * const trailingObjv[])28004 NsfDirectDispatchCmd(Tcl_Interp *interp, NsfObject *object, FrameIdx_t withFrame,
28005                      Tcl_Obj *commandObj, int trailingObjc, Tcl_Obj *const trailingObjv[]) {
28006   int result;
28007   const char     *methodName;
28008   Tcl_Command     cmd, importedCmd;
28009   CallFrame       frame, *framePtr = &frame;
28010   Tcl_ObjCmdProc *proc;
28011   unsigned int    flags = 0u;
28012   bool            useCmdDispatch = NSF_TRUE;
28013 
28014   nonnull_assert(interp != NULL);
28015   nonnull_assert(object != NULL);
28016   nonnull_assert(commandObj != NULL);
28017 
28018   /*fprintf(stderr, "NsfDirectDispatchCmd obj=%s, cmd m='%s' oc %d\n", ObjectName(object), methodName, nobjc);*/
28019 
28020   methodName = ObjStr(commandObj);
28021   if (unlikely(*methodName != ':')) {
28022     return NsfPrintError(interp, "method name '%s' must be fully qualified", methodName);
28023   }
28024 
28025   /*
28026    * We have a fully qualified name of a Tcl command that will be dispatched.
28027    */
28028 
28029   cmd = Tcl_GetCommandFromObj(interp, commandObj);
28030   if (likely(cmd != NULL)) {
28031     importedCmd = TclGetOriginalCommand(cmd);
28032     if (unlikely(importedCmd != NULL)) {
28033       cmd = importedCmd;
28034     }
28035   }
28036 
28037   if (unlikely(cmd == NULL)) {
28038     return NsfPrintError(interp, "cannot lookup command '%s'", methodName);
28039   }
28040 
28041   proc = Tcl_Command_objProc(cmd);
28042   if (proc == TclObjInterpProc ||
28043       proc == NsfForwardMethod ||
28044       proc == NsfObjscopedMethod ||
28045       proc == NsfSetterMethod ||
28046       CmdIsNsfObject(cmd)) {
28047 
28048     if (withFrame && withFrame != FrameDefaultIdx) {
28049       return NsfPrintError(interp, "cannot use -frame object|method in dispatch for command '%s'",
28050                            methodName);
28051     }
28052     useCmdDispatch = NSF_FALSE;
28053   } else {
28054     if (unlikely(withFrame == FrameMethodIdx)) {
28055       useCmdDispatch = NSF_FALSE;
28056     }
28057   }
28058 
28059   /*
28060    * If "withFrame == FrameObjectIdx" is specified, a call-stack frame is
28061    * pushed to make instance variables accessible for the command.
28062    */
28063   if (unlikely(withFrame == FrameObjectIdx)) {
28064     Nsf_PushFrameObj(interp, object, framePtr);
28065     flags = NSF_CSC_IMMEDIATE;
28066   }
28067   /*
28068    * Since we know, that we are always called with a full argument
28069    * vector, we can include the cmd name in the objv by using
28070    * nobjv-1; this way, we avoid a memcpy().
28071    */
28072   if (useCmdDispatch) {
28073 
28074     if (NSF_DTRACE_METHOD_ENTRY_ENABLED()) {
28075       NSF_DTRACE_METHOD_ENTRY(ObjectName(object),
28076                               "",
28077                               (char *)methodName,
28078                               trailingObjc, (Tcl_Obj **)trailingObjv);
28079     }
28080 
28081     result = CmdMethodDispatch(object, interp, trailingObjc + 1, trailingObjv - 1,
28082                                object, cmd, NULL);
28083   } else {
28084     /*
28085      * If "withFrame == FrameMethodIdx" is specified, a call-stack frame is
28086      * pushed to make instance variables accessible for the command.
28087      */
28088     if (unlikely(withFrame == FrameMethodIdx)) {
28089       flags = NSF_CSC_FORCE_FRAME|NSF_CSC_IMMEDIATE;
28090     }
28091 
28092     result = MethodDispatch(interp, trailingObjc + 1, trailingObjv - 1, cmd, object,
28093                             NULL /*NsfClass *cl*/,
28094                             Tcl_GetCommandName(interp, cmd),
28095                             NSF_CSC_TYPE_PLAIN, flags);
28096   }
28097 
28098   if (unlikely(withFrame == FrameObjectIdx)) {
28099     Nsf_PopFrameObj(interp, framePtr);
28100   }
28101 
28102   return result;
28103 }
28104 
28105 
28106 /*
28107 cmd "dispatch" NsfDispatchCmd {
28108   {-argName "object" -required 1 -type object}
28109   {-argName "-intrinsic" -required 0 -nrargs 0}
28110   {-argName "-system" -required 0 -nrargs 0}
28111   {-argName "command" -required 1 -type tclobj}
28112   {-argName "args"  -type args}
28113 }
28114 */
28115 static int
NsfDispatchCmd(Tcl_Interp * interp,NsfObject * object,int withIntrinsic,int withSystem,Tcl_Obj * commandObj,int trailingObjc,Tcl_Obj * const trailingObjv[])28116 NsfDispatchCmd(Tcl_Interp *interp, NsfObject *object,
28117                int withIntrinsic, int withSystem,
28118                Tcl_Obj *commandObj,
28119                int trailingObjc, Tcl_Obj *const trailingObjv[]) {
28120   unsigned int    flags = NSF_CM_NO_UNKNOWN|NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS|NSF_CM_NO_SHIFT;
28121   Tcl_Obj *const *objv = trailingObjv-1;
28122 
28123   nonnull_assert(interp != NULL);
28124   nonnull_assert(object != NULL);
28125   nonnull_assert(commandObj != NULL);
28126 
28127   /*
28128    * We use the construct "tclobj" + "args" in the spec to enforce that at least a
28129    * commandName is specified (this way we allow empty "args", and can provide
28130    * a nice error message, if cmdName is not specified). Since the we know
28131    * that the commandObj has to be right before "args" in the objv, we can
28132    * decrement the nobjv to obtain objv (and increment nobjc), be we make sure
28133    * that this assumption is correct.
28134    */
28135   assert(objv[0] == commandObj);
28136   assert(ISOBJ_(commandObj));
28137 
28138   trailingObjc++;
28139 
28140 #if 0
28141   {int i;
28142   fprintf(stderr, "NsfDispatchCmd %s method %s oc %2d", ObjectName(object), ObjStr(commandObj), trailingObjc);
28143   for(i = 0; i < trailingObjc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(trailingObjv[i]));}
28144   fprintf(stderr, "\n");
28145   }
28146 #endif
28147 
28148   if (unlikely(withIntrinsic && withSystem)) {
28149     return NsfPrintError(interp, "flags '-intrinsic' and '-system' are mutual exclusive");
28150   }
28151 
28152   /*
28153    * Dispatch the command the method from the precedence order, with filters
28154    * etc. -- strictly speaking unnecessary, but this function can be used to
28155    * call protected methods and provide the flags '-intrinsics' and '-system'.
28156    */
28157 
28158   if (withIntrinsic != 0) {
28159     flags |= NSF_CM_INTRINSIC_METHOD;
28160   }
28161   if (withSystem != 0) {
28162     flags |= NSF_CM_SYSTEM_METHOD;
28163   }
28164 
28165   /*
28166    * Since we know, that we are always called with a full argument
28167    * vector, we can include the cmd name in the objv by using
28168    * nobjv-1; this way, we avoid a memcpy().
28169    */
28170   return ObjectDispatch(object, interp,  trailingObjc, objv, flags);
28171 }
28172 
28173 /*
28174 cmd finalize NsfFinalizeCmd {
28175   {-argName "-keepvars" -required 0 -nrargs 0}
28176 }
28177 */
28178 static int
NsfFinalizeCmd(Tcl_Interp * interp,int withKeepvars)28179 NsfFinalizeCmd(Tcl_Interp *interp, int withKeepvars) {
28180   int result;
28181 
28182   /* fprintf(stderr, "#### (%lx) NsfFinalizeCmd exitHandlerRound %d\n",
28183      (long)(void*)pthread_self(), RUNTIME_STATE(interp)->exitHandlerDestroyRound );*/
28184 
28185   nonnull_assert(interp != NULL);
28186 
28187 #if defined(NSF_PROFILE)
28188   /*
28189    * Check whether profile trace is still running. If so, delete it here.
28190    * Interestingly, NsfLog() seems to be unavailable at this place.
28191    */
28192   if (RUNTIME_STATE(interp)->doTrace == 1) {
28193     NsfLog(interp, NSF_LOG_WARN, "tracing is still active; deactivate it due to cleanup.");
28194     NsfProfileTrace(interp, 0, 0, 0, NULL);
28195   }
28196 #endif
28197 
28198 #if defined(NSF_STACKCHECK)
28199   {NsfRuntimeState *rst = RUNTIME_STATE(interp);
28200 
28201     NsfLog(interp, NSF_LOG_WARN, "Stack max usage %ld",
28202            labs(rst->maxStack - rst->bottomOfStack));
28203   }
28204 #endif
28205 
28206   /*fprintf(stderr, "+++ call tcl-defined exit handler (%x)\n", PTR2INT(pthread_self()));*/
28207 
28208   /*
28209    * Evaluate user-defined exit handler.
28210    */
28211   result = Tcl_Eval(interp, "::nsf::__exithandler");
28212 
28213   if (unlikely(result != TCL_OK)) {
28214     fprintf(stderr, "User defined exit handler contains errors!\n"
28215             "Error in line %d: %s\nExecution interrupted.\n",
28216             (int)Tcl_GetErrorLine(interp), ObjStr(Tcl_GetObjResult(interp)));
28217   }
28218 
28219   ObjectSystemsCleanup(interp, withKeepvars ? NSF_TRUE : NSF_FALSE);
28220 
28221 
28222 #ifdef DO_CLEANUP
28223   {
28224     NsfRuntimeState *rst = RUNTIME_STATE(interp);
28225 
28226 # if defined(CHECK_ACTIVATION_COUNTS)
28227     assert(rst->cscList == NULL);
28228 # endif
28229     /*fprintf(stderr, "CLEANUP TOP NS\n");*/
28230     Tcl_Export(interp, rst->NsfNS, "", 1);
28231     if (rst->NsfClassesNS != NULL) {
28232       MEM_COUNT_FREE("TclNamespace", rst->NsfClassesNS);
28233       Tcl_DeleteNamespace(rst->NsfClassesNS);
28234     }
28235     if (rst->NsfNS != NULL) {
28236       MEM_COUNT_FREE("TclNamespace", rst->NsfNS);
28237       Tcl_DeleteNamespace(rst->NsfNS);
28238     }
28239 
28240     {
28241       NsfDList *dlPtr = &rst->freeDList;
28242       size_t    i;
28243 
28244 #if defined(COLON_CMD_STATS)
28245       fprintf(stderr, "#### DList free size %lu avail %lu\n", dlPtr->size, dlPtr->avail);
28246 #endif
28247       for (i = 0u; i < dlPtr->size; i++) {
28248         /*
28249            fprintf(stderr, "#### DList free data[%lu] %p: %p\n", i,
28250            (void*)&(dlPtr->data[i]), (void*)dlPtr->data[i]);
28251         */
28252         NsfColonCmdContextFree(dlPtr->data[i]);
28253       }
28254       NsfDListFree(dlPtr);
28255     }
28256   }
28257 #endif
28258   return TCL_OK;
28259 }
28260 
28261 
28262 /*
28263 cmd interp NsfInterpObjCmd {
28264   {-argName "name"}
28265   {-argName "args" -type allargs}
28266 }
28267 */
28268 /*
28269  * Create a slave interp that calls Next Scripting Init
28270  */
28271 static int
NsfInterpObjCmd(Tcl_Interp * interp,const char * name,int objc,Tcl_Obj * const objv[])28272 NsfInterpObjCmd(Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[]) {
28273 
28274   nonnull_assert(interp != NULL);
28275   nonnull_assert(name != NULL);
28276 
28277   /*
28278    * Create a fresh Tcl interpreter, or pass command to an existing one
28279    */
28280   if (unlikely(NsfCallCommand(interp, NSF_INTERP, objc, objv) != TCL_OK)) {
28281     return TCL_ERROR;
28282   }
28283 
28284   /*
28285    * Upon [interp create], set up NSF for the new child interp by running
28286    * Nsf_Init()
28287    */
28288 
28289   if (isCreateString(name)) {
28290     Tcl_Obj    *slaveCmdObj;
28291     Tcl_Interp *slavePtr;
28292 
28293     /*
28294      * Tcl_InterpObjCmd() stores the newly created child interp's command name
28295      * in the interp result store.
28296      */
28297 
28298     slaveCmdObj = Tcl_GetObjResult(interp);
28299     slavePtr = Tcl_GetSlave(interp, ObjStr(slaveCmdObj));
28300 
28301     if (slavePtr == NULL) {
28302       return NsfPrintError(interp, "creation of slave interpreter failed");
28303     }
28304     if (unlikely(Nsf_Init(slavePtr) == TCL_ERROR)) {
28305       return TCL_ERROR;
28306     }
28307   }
28308   return TCL_OK;
28309 }
28310 
28311 /*
28312 cmd is NsfIsCmd {
28313   {-argName "-complain"  -nrargs 0}
28314   {-argName "-configure" -nrargs 0}
28315   {-argName "-name" -required 0}
28316   {-argName "constraint" -required 1 -type tclobj}
28317   {-argName "value" -required 1 -type tclobj}
28318 } {-nxdoc 1}
28319 */
28320 static int
NsfIsCmd(Tcl_Interp * interp,int withComplain,int withConfigure,const char * withName,Tcl_Obj * constraintObj,Tcl_Obj * valueObj)28321 NsfIsCmd(Tcl_Interp *interp,
28322          int withComplain,
28323          int withConfigure,
28324          const char *withName,
28325          Tcl_Obj *constraintObj,
28326          Tcl_Obj *valueObj) {
28327   Nsf_Param *paramPtr = NULL;
28328   int        result;
28329 
28330   nonnull_assert(interp != NULL);
28331   nonnull_assert(constraintObj != NULL);
28332   nonnull_assert(valueObj != NULL);
28333 
28334   result = ParameterCheck(interp, constraintObj, valueObj,
28335                           (withName != NULL) ? withName : "value:", 1,
28336                           (withName != NULL),
28337                           (withConfigure == 1),
28338                           &paramPtr,
28339                           Tcl_GetCurrentNamespace(interp)->fullName);
28340 
28341   if (unlikely(paramPtr == NULL)) {
28342     /*
28343      * We could not convert the arguments. Even with noComplain, we
28344      * report the invalid converter spec as exception.
28345      */
28346     result = TCL_ERROR;
28347 
28348   } else {
28349     if (paramPtr->converter == ConvertViaCmd
28350         && (withComplain == 0 || result == TCL_OK)) {
28351       Tcl_ResetResult(interp);
28352     }
28353 
28354     if (withComplain == 0) {
28355       Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK));
28356       result = TCL_OK;
28357     } else if (likely(result == TCL_OK)) {
28358       Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
28359     }
28360   }
28361 
28362   return result;
28363 }
28364 
28365 /*
28366 cmd parseargs NsfParseArgsCmd {
28367   {-argName "argspec" -required 1 -type tclobj}
28368   {-argName "arglist" -required 1 -type tclobj}
28369 } {-nxdoc 0}
28370 */
28371 static int
NsfParseArgsCmd(Tcl_Interp * interp,Tcl_Obj * argspecObj,Tcl_Obj * arglistObj)28372 NsfParseArgsCmd(Tcl_Interp *interp, Tcl_Obj *argspecObj, Tcl_Obj *arglistObj) {
28373   NsfParsedParam   parsedParam;
28374   Tcl_Obj        **objv;
28375   int              result, objc;
28376 
28377   result = ParamDefsParse(interp, NsfGlobalObjs[NSF_PARSE_ARGS], argspecObj,
28378                           NSF_DISALLOWED_ARG_METHOD_PARAMETER,
28379                           NSF_TRUE /* force use of param structure,
28380                                       even for Tcl-only params */,
28381                           &parsedParam, Tcl_GetCurrentNamespace(interp)->fullName);
28382 
28383   if (unlikely(result != TCL_OK)) {
28384     return result;
28385   }
28386 
28387   result = Tcl_ListObjGetElements(interp, arglistObj, &objc, &objv);
28388   if (likely(result == TCL_OK) && parsedParam.paramDefs != NULL) {
28389     ParseContext  pc;
28390     NsfParamDefs *paramDefs = parsedParam.paramDefs;
28391     unsigned int  processFlags = 0u;
28392 
28393     ParamDefsRefCountIncr(paramDefs);
28394     result = ArgumentParse(interp, objc, objv, NULL, NsfGlobalObjs[NSF_PARSE_ARGS],
28395                            paramDefs->paramsPtr, paramDefs->nrParams, paramDefs->serial,
28396                            processFlags|NSF_ARGPARSE_START_ZERO|RUNTIME_STATE(interp)->doCheckArguments,
28397                            &pc);
28398 
28399     if (result == TCL_OK) {
28400       Nsf_Param *paramPtr;
28401       Tcl_Obj   *resultObj;
28402       int        i;
28403 
28404       for (i = 0, paramPtr = paramDefs->paramsPtr; paramPtr->name != NULL; paramPtr++, i++) {
28405         Tcl_Obj *valueObj = pc.objv[i];
28406 
28407         if (valueObj != NsfGlobalObjs[NSF___UNKNOWN__]) {
28408           /*fprintf(stderr, "param %s -> <%s>\n", paramPtr->name,  ObjStr(valueObj));*/
28409           resultObj = Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, valueObj, TCL_LEAVE_ERR_MSG);
28410           if (resultObj == NULL) {
28411             result = TCL_ERROR;
28412             break;
28413           }
28414         }
28415       }
28416     }
28417     ParamDefsRefCountDecr(paramDefs);
28418     ParseContextRelease(&pc);
28419   }
28420   return result;
28421 }
28422 
28423 /*
28424 cmd method::alias NsfMethodAliasCmd {
28425   {-argName "object" -type object}
28426   {-argName "-per-object"}
28427   {-argName "methodName"}
28428   {-argName "-frame" -required 0 -nrargs 1 -type "method|object|default" -default "default"}
28429   {-argName "-protection" -required 0 -type "call-protected|redefine-protected|none" -default "none"}
28430   {-argName "cmdName" -required 1 -type tclobj}
28431 }
28432 */
28433 static int
NsfMethodAliasCmd(Tcl_Interp * interp,NsfObject * object,int withPer_object,const char * methodName,FrameIdx_t withFrame,ProtectionIdx_t withProtection,Tcl_Obj * cmdNameObj)28434 NsfMethodAliasCmd(
28435     Tcl_Interp *interp, NsfObject *object, int withPer_object,
28436     const char *methodName, FrameIdx_t withFrame, ProtectionIdx_t withProtection,
28437     Tcl_Obj *cmdNameObj
28438 ) {
28439   Tcl_ObjCmdProc     *objProc, *newObjProc;
28440   Tcl_CmdDeleteProc  *deleteProc;
28441   AliasCmdClientData *tcd;
28442   Tcl_Command         cmd, oldCmd, newCmd;
28443   Tcl_Namespace      *nsPtr;
28444   int                 result;
28445   unsigned int        flags;
28446   const NsfClass     *class;
28447   NsfObject          *newTargetObject;
28448 
28449   nonnull_assert(interp != NULL);
28450   nonnull_assert(object != NULL);
28451   nonnull_assert(methodName != NULL);
28452   assert(*methodName != ':');
28453   nonnull_assert(cmdNameObj != NULL);
28454 
28455   cmd = Tcl_GetCommandFromObj(interp, cmdNameObj);
28456   if (cmd == NULL) {
28457     return NsfPrintError(interp, "cannot lookup command '%s'", ObjStr(cmdNameObj));
28458   }
28459 
28460   cmd = GetOriginalCommand(cmd);
28461   objProc = Tcl_Command_objProc(cmd);
28462   assert(objProc != NULL);
28463 
28464   /*
28465    * objProc is either ...
28466    *
28467    * 1. NsfObjDispatch: a command representing a Next Scripting object
28468    *
28469    * 2. TclObjInterpProc: a cmd standing for a Tcl proc (including
28470    *    Next Scripting methods), verified through CmdIsProc() -> to be
28471    *    wrapped by NsfProcAliasMethod()
28472    *
28473    * 3. NsfForwardMethod: a Next Scripting forwarder
28474    *
28475    * 4. NsfSetterMethod: a Next Scripting setter
28476    *
28477    * 5. Arbitrary Tcl commands (e.g. set, ..., ::nsf::relation, ...)
28478    *
28479    */
28480 
28481   if (withFrame == FrameObjectIdx) {
28482     newObjProc = NsfObjscopedMethod;
28483   } else {
28484     newObjProc = NULL;
28485   }
28486 
28487   /*
28488    * We need to perform a defensive lookup of a previously defined
28489    * object-alias under the given methodName.
28490    */
28491   class = (withPer_object || ! NsfObjectIsClass(object)) ? NULL : (NsfClass *)object;
28492 
28493   nsPtr = (class != NULL) ? class->nsPtr : object->nsPtr;
28494   oldCmd = (nsPtr != NULL) ? FindMethod(nsPtr, methodName) : NULL;
28495   newTargetObject = NsfGetObjectFromCmdPtr(cmd);
28496 
28497   if (oldCmd != NULL) {
28498 #if 1
28499     /*
28500      * Old solution, leasds to a broken regression test with Tcl 8.7a1.
28501      * However, using Tcl_DeleteCommandFromToken() leads to a crash also with
28502      * earlier solutions when defining recursive aliases.
28503      */
28504     NsfObject *oldTargetObject;
28505 
28506     /*fprintf(stderr, "... DELETE preexisting cmd %s in ns %s\n", methodName, nsPtr->fullName);*/
28507 
28508     oldTargetObject = NsfGetObjectFromCmdPtr(oldCmd);
28509     /* fprintf(stderr, "oldTargetObject %p flags %.6x newTargetObject %p\n",
28510        oldTargetObject, (oldTargetObject != NULL) ? oldTargetObject->flags : 0, newTargetObject);*/
28511 
28512     /*
28513      * We might have to decrement the reference counter on a previously
28514      * aliased object. Decrement the reference count to the old aliased object
28515      * only, when it is different to the new target Object.
28516      */
28517 
28518     if (oldTargetObject != NULL && oldTargetObject != newTargetObject) {
28519       /*fprintf(stderr, "--- releasing old target object %p refCount %d\n",
28520         oldTargetObject, oldTargetObject->refCount);*/
28521       assert(oldTargetObject->refCount > 0);
28522       AliasDeleteObjectReference(interp, oldCmd);
28523     }
28524 
28525 #else
28526     Tcl_DeleteCommandFromToken(interp, oldCmd);
28527 #endif
28528 
28529   }
28530 
28531   if (newTargetObject != NULL) {
28532     /*
28533      * We set now for every alias to an object a stub proc, such we can
28534      * distinguish between cases, where the user wants to create a method, and
28535      * between cases, where object-invocation via method interface might
28536      * happen.
28537      */
28538     newObjProc = NsfProcAliasMethod;
28539 
28540   } else if (CmdIsProc(cmd)) {
28541     /*
28542      * When we have a Tcl proc|nsf-method as alias, then use the
28543      * wrapper, which will be deleted automatically when the original
28544      * proc/method is deleted.
28545      */
28546     newObjProc = NsfProcAliasMethod;
28547 
28548     if (objProc == TclObjInterpProc) {
28549       /*
28550        * We have an alias to a Tcl proc;
28551        */
28552       Proc    *procPtr = (Proc *)Tcl_Command_objClientData(cmd);
28553       Tcl_Obj *bodyObj = (procPtr != NULL) ? procPtr->bodyPtr : NULL;
28554 
28555       if (bodyObj && bodyObj->typePtr == Nsf_OT_byteCodeType) {
28556         /*
28557          * Flush old byte code
28558          */
28559         /*fprintf(stderr, "flush byte code\n");*/
28560         TclFreeIntRep(bodyObj);
28561       }
28562     }
28563 
28564     if (withFrame && withFrame != FrameDefaultIdx) {
28565       return NsfPrintError(interp,
28566                           "cannot use -frame object|method in alias for scripted command '%s'",
28567                            ObjStr(cmdNameObj));
28568     }
28569   }
28570 
28571   if (newObjProc != NULL) {
28572     /*
28573      * Add a wrapper.
28574      */
28575     /*fprintf(stderr, "NsfMethodAliasCmd add wrapper cmd %p\n", cmd);*/
28576     NsfCommandPreserve(cmd);
28577     tcd = NEW(AliasCmdClientData);
28578     tcd->cmdName    = object->cmdName;
28579     tcd->interp     = interp; /* just for deleting the alias */
28580     tcd->object     = NULL;
28581     tcd->class      = (class != NULL) ? (NsfClass *) object : NULL;
28582     tcd->objProc    = objProc;
28583     tcd->aliasedCmd = cmd;
28584     tcd->clientData = Tcl_Command_objClientData(cmd);
28585 
28586     objProc         = newObjProc;
28587     deleteProc      = AliasCmdDeleteProc;
28588     if (tcd->cmdName != NULL) {
28589       INCR_REF_COUNT(tcd->cmdName);
28590     }
28591   } else {
28592     /*
28593      * Call the command directly (must be a c-implemented command not
28594      * depending on a volatile client data)
28595      */
28596     deleteProc = NULL;
28597     tcd = Tcl_Command_objClientData(cmd);
28598     /*fprintf(stderr, "NsfMethodAliasCmd no wrapper cmd %p\n", cmd);*/
28599   }
28600 
28601   switch (withProtection) {
28602   case ProtectionCall_protectedIdx:     flags = NSF_CMD_CALL_PROTECTED_METHOD; break;
28603   case ProtectionRedefine_protectedIdx: flags = NSF_CMD_REDEFINE_PROTECTED_METHOD; break;
28604   case ProtectionNoneIdx: /* fall through */
28605   case ProtectionNULL:    /* fall through */
28606   default:                flags = 0u; break;
28607   }
28608 
28609   if (class != NULL) {
28610     result = NsfAddClassMethod(interp, (Nsf_Class *)class, methodName,
28611                                objProc, tcd, deleteProc, flags);
28612     nsPtr = class->nsPtr;
28613   } else {
28614     result = NsfAddObjectMethod(interp, (Nsf_Object *)object, methodName,
28615                                 objProc, tcd, deleteProc, flags);
28616     nsPtr = object->nsPtr;
28617   }
28618 
28619   if (likely(result == TCL_OK)) {
28620     newCmd = FindMethod(nsPtr, methodName);
28621   } else {
28622     newCmd = NULL;
28623   }
28624 
28625 #if defined(WITH_IMPORT_REFS)
28626   if (newObjProc != NULL) {
28627     /*
28628      * Define the reference chain like for 'namespace import' to
28629      * obtain automatic deletes when the original command is deleted.
28630      */
28631     ImportRef *refPtr = (ImportRef *) ckalloc((int)sizeof(ImportRef));
28632 
28633     refPtr->importedCmdPtr = (Command *) newCmd;
28634     refPtr->nextPtr = ((Command *) tcd->aliasedCmd)->importRefPtr;
28635     ((Command *) tcd->aliasedCmd)->importRefPtr = refPtr;
28636     tcd->aliasCmd = newCmd;
28637   }
28638 #else
28639   if (newObjProc != NULL) {
28640     tcd->aliasCmd = newCmd;
28641   }
28642 #endif
28643 
28644   if (newCmd != NULL) {
28645     AliasAdd(interp, object->cmdName, methodName, class == NULL, cmdNameObj);
28646 
28647     if (withFrame == FrameMethodIdx) {
28648       Tcl_Command_flags(newCmd) |= NSF_CMD_NONLEAF_METHOD;
28649       /*fprintf(stderr, "setting aliased for cmd %p %s flags %.6x, tcd = %p\n",
28650         newCmd, methodName, Tcl_Command_flags(newCmd), tcd);*/
28651     }
28652 
28653     Tcl_SetObjResult(interp, MethodHandleObj(object, class == NULL, methodName));
28654     result = TCL_OK;
28655   }
28656 
28657   return result;
28658 }
28659 
28660 /*
28661 cmd method::assertion NsfMethodAssertionCmd {
28662   {-argName "object" -type object}
28663   {-argName "assertionsubcmd" -required 1 -type "check|object-invar|class-invar"}
28664   {-argName "arg" -required 0 -type tclobj}
28665 }
28666 
28667   Make "::nsf::assertion" a cmd rather than a method, otherwise we
28668   cannot define e.g. a "method check options {...}" to reset the check
28669   options in case of a failed option, since assertion checking would
28670   be applied on the sketched method already.
28671 */
28672 
28673 static int
NsfMethodAssertionCmd(Tcl_Interp * interp,NsfObject * object,AssertionsubcmdIdx_t subcmd,Tcl_Obj * argObj)28674 NsfMethodAssertionCmd(Tcl_Interp *interp, NsfObject *object, AssertionsubcmdIdx_t subcmd, Tcl_Obj *argObj) {
28675 #if defined(NSF_WITH_ASSERTIONS)
28676   NsfClass *class;
28677 
28678   nonnull_assert(interp != NULL);
28679   nonnull_assert(object != NULL);
28680 
28681   switch (subcmd) {
28682   case AssertionsubcmdCheckIdx:
28683     if (argObj != NULL) {
28684       return AssertionSetCheckOptions(interp, object, argObj);
28685     } else {
28686       return AssertionListCheckOption(interp, object);
28687     }
28688     break;
28689 
28690   case AssertionsubcmdObject_invarIdx:
28691     if (argObj != NULL) {
28692       NsfObjectOpt *opt = NsfRequireObjectOpt(object);
28693 
28694       AssertionSetInvariants(interp, &opt->assertions, argObj);
28695     } else {
28696       if (object->opt != NULL && object->opt->assertions != NULL) {
28697         Tcl_SetObjResult(interp, AssertionList(interp, object->opt->assertions->invariants));
28698       }
28699     }
28700     break;
28701 
28702   case AssertionsubcmdClass_invarIdx:
28703 
28704     if (!NsfObjectIsClass(object)) {
28705       return NsfPrintError(interp, "object is not a class");
28706     }
28707 
28708     class = (NsfClass *)object;
28709     if (argObj != NULL) {
28710       NsfClassOpt *opt = NsfRequireClassOpt(class);
28711 
28712       AssertionSetInvariants(interp, &opt->assertions, argObj);
28713     } else {
28714       if (class->opt != NULL && class->opt->assertions != NULL) {
28715         Tcl_SetObjResult(interp, AssertionList(interp, class->opt->assertions->invariants));
28716       }
28717     }
28718 
28719   case AssertionsubcmdNULL:
28720     /*
28721      * Do nothing; just for detection if option was specified.
28722      */
28723     break;
28724   }
28725 #endif
28726   return TCL_OK;
28727 }
28728 
28729 /*
28730 cmd method::create NsfMethodCreateCmd {
28731   {-argName "object" -required 1 -type object}
28732   {-argName "-checkalways" -required 0 -nrargs 0 -type switch}
28733   {-argName "-inner-namespace"}
28734   {-argName "-per-object"}
28735   {-argName "-reg-object" -required 0 -nrargs 1 -type object}
28736   {-argName "name" -required 1 -type tclobj}
28737   {-argName "arguments" -required 1 -type tclobj}
28738   {-argName "body" -required 1 -type tclobj}
28739   {-argName "-precondition"  -nrargs 1 -type tclobj}
28740   {-argName "-postcondition" -nrargs 1 -type tclobj}
28741 }
28742 */
28743 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)28744 NsfMethodCreateCmd(Tcl_Interp *interp, NsfObject *object,
28745                    int withCheckalways, int withInner_namespace,
28746                    int withPer_object, NsfObject *regObject,
28747                    Tcl_Obj *methodNameObj, Tcl_Obj *argumentsObj, Tcl_Obj *bodyObj,
28748                    Tcl_Obj *preconditionObj, Tcl_Obj *postconditionObj) {
28749   NsfClass *class;
28750 
28751   nonnull_assert(interp != NULL);
28752   nonnull_assert(object != NULL);
28753   nonnull_assert(methodNameObj != NULL);
28754   nonnull_assert(argumentsObj != NULL);
28755   nonnull_assert(bodyObj != NULL);
28756 
28757   class = (withPer_object || ! NsfObjectIsClass(object)) ? NULL : (NsfClass *)object;
28758   if (class == NULL) {
28759     RequireObjNamespace(interp, object);
28760 
28761   }
28762   return MakeMethod(interp, object, regObject, class,
28763                     methodNameObj, argumentsObj, bodyObj,
28764                     preconditionObj, postconditionObj,
28765                     withInner_namespace, (withCheckalways != 0) ? NSF_ARGPARSE_CHECK : 0);
28766 }
28767 
28768 /*
28769 cmd "method::delete" NsfMethodDeleteCmd {
28770   {-argName "object" -required 1 -type object}
28771   {-argName "-per-object"}
28772   {-argName "methodName" -required 1 -type tclobj}
28773 }
28774 */
28775 static int
NsfMethodDeleteCmd(Tcl_Interp * interp,NsfObject * object,int withPer_object,Tcl_Obj * methodNameObj)28776 NsfMethodDeleteCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object,
28777                    Tcl_Obj *methodNameObj) {
28778   NsfObject      *regObject, *defObject;
28779   const char     *methodName1 = NULL;
28780   const NsfClass *class;
28781   bool            fromClassNS;
28782   int             result;
28783   Tcl_DString     ds, *dsPtr = &ds;
28784   Tcl_Command     cmd;
28785 
28786   nonnull_assert(interp != NULL);
28787   nonnull_assert(object != NULL);
28788   nonnull_assert(methodNameObj != NULL);
28789 
28790   class = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL;
28791   fromClassNS = (class != NULL);
28792 
28793   Tcl_DStringInit(dsPtr);
28794 
28795   cmd = ResolveMethodName(interp, (class != NULL) ? class->nsPtr : object->nsPtr, methodNameObj,
28796                           dsPtr, &regObject, &defObject, &methodName1, &fromClassNS);
28797 
28798   /*fprintf(stderr,
28799           "NsfMethodDeleteCmd method %s '%s' object %p regObject %p defObject %p cl %p fromClass %d cmd %p\n",
28800           ObjStr(methodNameObj), methodName1, object, regObject, defObject, cl, fromClassNS, cmd);*/
28801 
28802   if (cmd != NULL) {
28803     methodName1 = Tcl_GetCommandName(interp, cmd);
28804     if (defObject != NULL) {
28805       class = (withPer_object == 0 && NsfObjectIsClass(defObject)) ? (NsfClass *)defObject : NULL;
28806     } else {
28807       defObject = object;
28808     }
28809 
28810     if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
28811       result = (class != NULL) ?
28812         NsfRemoveClassMethod(interp,  (Nsf_Class *)defObject, methodName1) :
28813         NsfRemoveObjectMethod(interp, (Nsf_Object *)defObject, methodName1);
28814     } else {
28815       result = TCL_OK;
28816     }
28817 
28818   } else {
28819     result = NsfPrintError(interp, "%s: %s method '%s' does not exist",
28820                            ObjectName_(object), (withPer_object == 1) ? "object specific" : "instance",
28821                            ObjStr(methodNameObj));
28822   }
28823 
28824   Tcl_DStringFree(dsPtr);
28825 
28826   return result;
28827 }
28828 
28829 /*
28830 cmd method::forward NsfMethodForwardCmd {
28831   {-argName "object" -required 1 -type object}
28832   {-argName "-per-object" -required 0 -nrargs 0 -type switch}
28833   {-argName "method" -required 1 -type tclobj}
28834   {-argName "-default" -type tclobj}
28835   {-argName "-earlybinding" -nrargs 0}
28836   {-argName "-prefix" -type tclobj}
28837   {-argName "-frame" -nrargs 1 -type "object|method|default" -default default}
28838   {-argName "-verbose" -nrargs 0}
28839   {-argName "target" -type tclobj}
28840   {-argName "args" -type args}
28841 }
28842 */
28843 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,int trailingObjc,Tcl_Obj * const trailingObjv[])28844 NsfMethodForwardCmd(Tcl_Interp *interp,
28845                     NsfObject *object,
28846                     int withPer_object,
28847                     Tcl_Obj *methodObj,
28848                     Tcl_Obj *defaultObj,
28849                     int withEarlybinding,
28850                     Tcl_Obj *onerrorObj,
28851                     Tcl_Obj *prefixObj,
28852                     FrameIdx_t withFrame,
28853                     int withVerbose,
28854                     Tcl_Obj *targetObj,
28855                     int trailingObjc, Tcl_Obj *const trailingObjv[]) {
28856   ForwardCmdClientData *tcd = NULL;
28857   int result;
28858 
28859   nonnull_assert(interp != NULL);
28860   nonnull_assert(object != NULL);
28861   nonnull_assert(methodObj != NULL);
28862 
28863   result = ForwardProcessOptions(interp,
28864                                  methodObj,
28865                                  defaultObj,
28866                                  withEarlybinding,
28867                                  onerrorObj,
28868                                  prefixObj,
28869                                  (int)withFrame,
28870                                  (withVerbose == 1),
28871                                  targetObj,
28872                                  trailingObjc, trailingObjv,
28873                                  &tcd);
28874 
28875   if (likely(result == TCL_OK)) {
28876     const char *methodName = NSTail(ObjStr(methodObj));
28877     NsfClass *class =
28878       (withPer_object || ! NsfObjectIsClass(object)) ?
28879       NULL : (NsfClass *)object;
28880 
28881     tcd->object = object;
28882 
28883     if (class == NULL) {
28884       result = NsfAddObjectMethod(interp, (Nsf_Object *)object, methodName,
28885                                   (Tcl_ObjCmdProc *)NsfForwardMethod,
28886                                   tcd, ForwardCmdDeleteProc, 0u);
28887     } else {
28888       result = NsfAddClassMethod(interp, (Nsf_Class *)class, methodName,
28889                                  (Tcl_ObjCmdProc *)NsfForwardMethod,
28890                                  tcd, ForwardCmdDeleteProc, 0u);
28891     }
28892     if (likely(result == TCL_OK)) {
28893       Tcl_SetObjResult(interp, MethodHandleObj(object, (class == NULL), methodName));
28894     }
28895   }
28896 
28897   if (result != TCL_OK && tcd != NULL) {
28898     ForwardCmdDeleteProc(tcd);
28899   }
28900   return result;
28901 }
28902 
28903 
28904 /*
28905 cmd "method::forward::property" NsfForwardPropertyCmd {
28906   {-argName "object" -required 1 -type object}
28907   {-argName "-per-object" -required 0 -nrargs 0 -type switch}
28908   {-argName "methodName" -required 1 -type tclobj}
28909   {-argName "forwardProperty" -required 1 -type "target|verbose"}
28910   {-argName "value" -type tclobj}
28911 }
28912 */
28913 static int
NsfForwardPropertyCmd(Tcl_Interp * interp,NsfObject * object,int withPer_object,Tcl_Obj * methodNameObj,ForwardpropertyIdx_t forwardProperty,Tcl_Obj * valueObj)28914 NsfForwardPropertyCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object,
28915                      Tcl_Obj *methodNameObj, ForwardpropertyIdx_t forwardProperty, Tcl_Obj *valueObj) {
28916   ForwardCmdClientData *tcd;
28917   Tcl_ObjCmdProc       *procPtr;
28918   Tcl_Command           cmd;
28919   NsfObject            *defObject;
28920   const NsfClass       *class;
28921   bool                  fromClassNS;
28922 
28923   nonnull_assert(interp != NULL);
28924   nonnull_assert(object != NULL);
28925   nonnull_assert(methodNameObj != NULL);
28926 
28927   class = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL;
28928   fromClassNS = (class != NULL);
28929 
28930   cmd = ResolveMethodName(interp, (class != NULL) ? class->nsPtr : object->nsPtr, methodNameObj,
28931                           NULL, NULL, &defObject, NULL, &fromClassNS);
28932 
28933   if (unlikely(cmd == NULL)) {
28934     return NsfPrintError(interp, "cannot lookup %smethod '%s' for %s",
28935                          class == NULL ? "object " : "",
28936                          ObjStr(methodNameObj), ObjectName_(object));
28937   }
28938 
28939   procPtr = Tcl_Command_objProc(cmd);
28940   if (procPtr != NsfForwardMethod) {
28941     return NsfPrintError(interp, "%s is not a forwarder method",
28942                          ObjStr(methodNameObj));
28943   }
28944 
28945   tcd = (ForwardCmdClientData *)Tcl_Command_objClientData(cmd);
28946   if (tcd == NULL) {
28947     return NsfPrintError(interp, "forwarder method has no client data");
28948   }
28949 
28950   switch (forwardProperty) {
28951   case ForwardpropertyTargetIdx:
28952     if (valueObj != NULL) {
28953       DECR_REF_COUNT(tcd->cmdName);
28954       INCR_REF_COUNT(valueObj);
28955       tcd->cmdName = valueObj;
28956     }
28957     Tcl_SetObjResult(interp, tcd->cmdName);
28958     break;
28959 
28960   case ForwardpropertyPrefixIdx:
28961     if (valueObj != NULL) {
28962       DECR_REF_COUNT(tcd->prefix);
28963       INCR_REF_COUNT(valueObj);
28964       tcd->prefix = valueObj;
28965     }
28966     Tcl_SetObjResult(interp, tcd->prefix);
28967     break;
28968 
28969   case ForwardpropertyVerboseIdx:
28970     if (valueObj != NULL) {
28971       int boolValue;
28972 
28973       Tcl_GetBooleanFromObj(interp, valueObj, &boolValue);
28974       tcd->verbose = (boolValue != 0);
28975     }
28976     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(tcd->verbose));
28977     break;
28978 
28979   case ForwardpropertyNULL:
28980     /*
28981      * Do nothing; just for detection if option was specified.
28982      */
28983     break;
28984   }
28985 
28986   return TCL_OK;
28987 }
28988 
28989 /*
28990 cmd ::method::property NsfMethodPropertyCmd {
28991   {-argName "object" -required 1 -type object}
28992   {-argName "-per-object"}
28993   {-argName "methodName" -required 1 -type tclobj}
28994   {-argName "methodProperty" -required 1 -type "class-only|call-private|call-protected|debug|deprecated|exists|redefine-protected|returns"}
28995   {-argName "value" -type tclobj}
28996 }
28997 */
28998 static int
NsfMethodPropertyCmd(Tcl_Interp * interp,NsfObject * object,int withPer_object,Tcl_Obj * methodNameObj,MethodpropertyIdx_t methodProperty,Tcl_Obj * valueObj)28999 NsfMethodPropertyCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object,
29000                      Tcl_Obj *methodNameObj, MethodpropertyIdx_t methodProperty, Tcl_Obj *valueObj) {
29001   NsfObject      *defObject;
29002   Tcl_Command     cmd;
29003   const NsfClass *class;
29004   bool            fromClassNS;
29005   unsigned int    flag;
29006 
29007   nonnull_assert(interp != NULL);
29008   nonnull_assert(object != NULL);
29009   nonnull_assert(methodNameObj != NULL);
29010 
29011   class = withPer_object == 0 && NsfObjectIsClass(object) ? (NsfClass *)object : NULL;
29012   fromClassNS = (class != NULL);
29013 
29014   cmd = ResolveMethodName(interp,
29015                           (class != NULL) ? class->nsPtr : object->nsPtr,
29016                           methodNameObj, NULL, NULL, &defObject, NULL, &fromClassNS);
29017   /*fprintf(stderr, "methodProperty for method '%s' prop %d value %s => cl %p cmd %p\n",
29018     ObjStr(methodNameObj), methodproperty, (valueObj != NULL) ? ObjStr(valueObj) : "NULL", cl, cmd);*/
29019 
29020 
29021   if (unlikely(cmd == NULL)) {
29022     if (methodProperty == MethodpropertyExistsIdx) {
29023       Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
29024       return TCL_OK;
29025     } else {
29026       return NsfPrintError(interp, "cannot lookup %smethod '%s' for %s",
29027                            class == NULL ? "object " : "",
29028                            ObjStr(methodNameObj), ObjectName_(object));
29029     }
29030   }
29031 
29032   switch (methodProperty) {
29033   case MethodpropertyExistsIdx:
29034     Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
29035     break;
29036   case MethodpropertyClass_onlyIdx:          /* fall through */
29037   case MethodpropertyCall_privateIdx:        /* fall through */
29038   case MethodpropertyCall_protectedIdx:      /* fall through */
29039   case MethodpropertyDebugIdx:               /* fall through */
29040   case MethodpropertyDeprecatedIdx:          /* fall through */
29041   case MethodpropertyRedefine_protectedIdx:  /* fall through */
29042     {
29043       int impliedSetFlag = 0, impliedClearFlag = 0;
29044 
29045       switch (methodProperty) {
29046       case MethodpropertyClass_onlyIdx:
29047         flag = NSF_CMD_CLASS_ONLY_METHOD;
29048         break;
29049       case MethodpropertyCall_privateIdx:
29050         flag = NSF_CMD_CALL_PRIVATE_METHOD;
29051         impliedSetFlag = NSF_CMD_CALL_PROTECTED_METHOD;
29052         break;
29053       case MethodpropertyCall_protectedIdx:
29054         impliedClearFlag = NSF_CMD_CALL_PRIVATE_METHOD;
29055         flag = NSF_CMD_CALL_PROTECTED_METHOD;
29056         break;
29057       case MethodpropertyDebugIdx:
29058         flag = NSF_CMD_DEBUG_METHOD;
29059         break;
29060       case MethodpropertyDeprecatedIdx:
29061         flag = NSF_CMD_DEPRECATED_METHOD;
29062         break;
29063       case MethodpropertyRedefine_protectedIdx:
29064         flag = NSF_CMD_REDEFINE_PROTECTED_METHOD;
29065         break;
29066       case MethodpropertyNULL:       /* fall through */
29067       case MethodpropertyReturnsIdx: /* fall through */
29068       case MethodpropertyExistsIdx:
29069         flag = 0u;
29070         break;
29071       }
29072 
29073       if (valueObj != NULL) {
29074         int boolVal, result;
29075 
29076         result = Tcl_GetBooleanFromObj(interp, valueObj, &boolVal);
29077         if (unlikely(result != TCL_OK)) {
29078           return result;
29079         }
29080         if (boolVal != 0) {
29081 
29082           /*
29083            * set flag
29084            */
29085           Tcl_Command_flags(cmd) |= (int)flag;
29086           if (impliedSetFlag != 0) {
29087             Tcl_Command_flags(cmd) |= (int)impliedSetFlag;
29088           }
29089         } else {
29090           /*
29091            * clear flag
29092            */
29093           Tcl_Command_flags(cmd) &= (int)~flag;
29094           if (impliedClearFlag != 0) {
29095             Tcl_Command_flags(cmd) &= (int)~impliedClearFlag;
29096           }
29097         }
29098         if (class != NULL) {
29099           NsfInstanceMethodEpochIncr("Permissions");
29100         } else {
29101           NsfObjectMethodEpochIncr("Permissions");
29102         }
29103       }
29104       Tcl_SetIntObj(Tcl_GetObjResult(interp), ((unsigned int)Tcl_Command_flags(cmd) & flag) != 0u);
29105     }
29106     break;
29107 
29108   case MethodpropertyReturnsIdx:
29109     {
29110       NsfProcContext *pCtx = ProcContextGet(cmd);
29111 
29112       /*fprintf(stderr, "MethodProperty, ParamDefsGet cmd %p paramDefs %p returns %p\n",
29113         cmd, paramDefs, (paramDefs != NULL) ? paramDefs->returns:NULL);*/
29114 
29115       if (valueObj == NULL) {
29116         /*
29117          * Return the actual value for "returns".
29118          */
29119         Tcl_Obj *resultObj;
29120 
29121         if (pCtx == NULL || pCtx->returnsObj == NULL) {
29122           resultObj = NsfGlobalObjs[NSF_EMPTY];
29123         } else {
29124           resultObj = pCtx->returnsObj;
29125         }
29126         Tcl_SetObjResult(interp, resultObj);
29127 
29128       } else {
29129         /*
29130          * Set the value of "returns".
29131          */
29132         const char *valueString = ObjStr(valueObj);
29133 
29134         if (pCtx == NULL) {
29135           pCtx = ProcContextRequire(cmd);
29136         }
29137 
29138         /*
29139          * Set a new value; if there is already a value, free it.
29140          */
29141         if (pCtx->returnsObj != NULL) {
29142           DECR_REF_COUNT2("returnsObj", pCtx->returnsObj);
29143         }
29144         if (*valueString == '\0') {
29145           /*
29146            * Set returnsObj to NULL
29147            */
29148           pCtx->returnsObj = NULL;
29149         } else {
29150           pCtx->returnsObj = valueObj;
29151           INCR_REF_COUNT2("returnsObj", pCtx->returnsObj);
29152         }
29153       }
29154     }
29155     break;
29156 
29157   case MethodpropertyNULL:
29158     /*
29159      * Do nothing; just for detection if option was specified.
29160      */
29161     break;
29162   }
29163 
29164   return TCL_OK;
29165 }
29166 
29167 
29168 /*
29169 cmd "method::registered" NsfMethodRegisteredCmd {
29170   {-argName "handle" -required 1 -type tclobj}
29171 }
29172 */
29173 static int
NsfMethodRegisteredCmd(Tcl_Interp * interp,Tcl_Obj * handleObj)29174 NsfMethodRegisteredCmd(Tcl_Interp *interp, Tcl_Obj *handleObj) {
29175   NsfObject  *regObject;
29176   bool        fromClassNS = NSF_FALSE;
29177   Tcl_Command cmd;
29178 
29179   nonnull_assert(interp != NULL);
29180   nonnull_assert(handleObj != NULL);
29181 
29182   cmd = ResolveMethodName(interp, NULL, handleObj,
29183                           NULL, &regObject, NULL, NULL, &fromClassNS);
29184 
29185   /*
29186    * In case the provided cmd is fully qualified and refers to a registered
29187    * method, the function returns the object, on which the method was
29188    * resisted.
29189    */
29190   Tcl_SetObjResult(interp, ((cmd != NULL) && (regObject != NULL)) ? regObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
29191 
29192   return TCL_OK;
29193 }
29194 
29195 /*
29196 cmd method::setter NsfMethodSetterCmd {
29197   {-argName "object" -required 1 -type object}
29198   {-argName "-per-object"}
29199   {-argName "parameter" -type tclobj}
29200   }
29201 */
29202 static int
NsfMethodSetterCmd(Tcl_Interp * interp,NsfObject * object,int withPer_object,Tcl_Obj * parameterObj)29203 NsfMethodSetterCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object, Tcl_Obj *parameterObj) {
29204   SetterCmdClientData *setterClientData;
29205   const NsfClass      *class;
29206   const char          *methodName;
29207   size_t               j, length;
29208   int                  result;
29209 
29210   nonnull_assert(interp != NULL);
29211   nonnull_assert(object != NULL);
29212   nonnull_assert(parameterObj != NULL);
29213 
29214   methodName = ObjStr(parameterObj);
29215   if (unlikely(*methodName == '-' || *methodName == ':')) {
29216     return NsfPrintError(interp, "invalid setter name \"%s\" (must not start with a dash or colon)",
29217                          methodName);
29218   }
29219 
29220   setterClientData = NEW(SetterCmdClientData);
29221   setterClientData->object = NULL;
29222   setterClientData->paramsPtr = NULL;
29223 
29224   length = strlen(methodName);
29225 
29226   for (j = 0; j < length; j++) {
29227     if (methodName[j] == ':' || NsfHasTclSpace(&methodName[j])) {
29228       break;
29229     }
29230   }
29231 
29232   class = (withPer_object || ! NsfObjectIsClass(object)) ? NULL : (NsfClass *)object;
29233 
29234   if (j < length) {
29235     /*
29236      * Looks as if we have a parameter specification.
29237      */
29238     int rc, possibleUnknowns = 0, plainParams = 0, nrNonposArgs = 0;
29239     NsfObject *ctx = (class != NULL) ? (NsfObject *)class : object;
29240     Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(ctx->id);
29241 
29242     setterClientData->paramsPtr = ParamsNew(1u);
29243     rc = ParamDefinitionParse(interp, NsfGlobalObjs[NSF_SETTER], parameterObj,
29244                               NSF_DISALLOWED_ARG_SETTER|NSF_ARG_HAS_DEFAULT,
29245                               setterClientData->paramsPtr, &possibleUnknowns,
29246                               &plainParams, &nrNonposArgs,
29247                               nsPtr != NULL ? nsPtr->fullName : NULL);
29248 
29249     if (unlikely(rc != TCL_OK)) {
29250       SetterCmdDeleteProc(setterClientData);
29251       return rc;
29252     }
29253     methodName = setterClientData->paramsPtr->name;
29254   } else {
29255     setterClientData->paramsPtr = NULL;
29256   }
29257 
29258   if (class != NULL) {
29259     result = NsfAddClassMethod(interp, (Nsf_Class *)class, methodName,
29260                                (Tcl_ObjCmdProc *)NsfSetterMethod,
29261                                setterClientData, SetterCmdDeleteProc, 0u);
29262   } else {
29263     result = NsfAddObjectMethod(interp, (Nsf_Object *)object, methodName,
29264                                 (Tcl_ObjCmdProc *)NsfSetterMethod,
29265                                 setterClientData, SetterCmdDeleteProc, 0u);
29266   }
29267   if (likely(result == TCL_OK)) {
29268     Tcl_SetObjResult(interp, MethodHandleObj(object, class == NULL, methodName));
29269   } else {
29270     SetterCmdDeleteProc(setterClientData);
29271   }
29272   return result;
29273 }
29274 
29275 /*
29276 cmd "object::alloc" NsfObjectAllocCmd {
29277   {-argName "class" -required 1 -type class}
29278   {-argName "name" -required 1 -type tclobj}
29279   {-argName "initcmd" -required 0 -type tclobj}
29280 }
29281 */
29282 static int
NsfObjectAllocCmd(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * nameObj,Tcl_Obj * initcmdObj)29283 NsfObjectAllocCmd(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, Tcl_Obj *initcmdObj) {
29284   Tcl_Obj *newNameObj = NULL;
29285   int      result;
29286 
29287   nonnull_assert(interp != NULL);
29288   nonnull_assert(class != NULL);
29289   nonnull_assert(nameObj != NULL);
29290 
29291   /*
29292    * If the provided name is empty, make a new symbol
29293    */
29294   if (strlen(ObjStr(nameObj)) == 0) {
29295     Tcl_DString ds, *dsPtr = &ds;
29296 
29297     Tcl_DStringInit(dsPtr);
29298     Tcl_DStringAppend(dsPtr, autonamePrefix, (int)autonamePrefixLength);
29299 
29300     NewTclCommand(interp, dsPtr);
29301 
29302     newNameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
29303     INCR_REF_COUNT(newNameObj);
29304     Tcl_DStringFree(dsPtr);
29305 
29306     nameObj = newNameObj;
29307   }
29308 
29309   /*fprintf(stderr, "trying to alloc <%s>\n", ObjStr(nameObj));*/
29310 
29311   result = NsfCAllocMethod(interp, class, nameObj);
29312 
29313   if (result == TCL_OK && initcmdObj != NULL) {
29314     NsfObject *object;
29315     Tcl_Obj   *initNameObj = Tcl_GetObjResult(interp);
29316 
29317     INCR_REF_COUNT(initNameObj);
29318     if (unlikely(GetObjectFromObj(interp, initNameObj, &object) != TCL_OK)) {
29319       result = NsfPrintError(interp, "couldn't find result of alloc");
29320     } else {
29321       result = NsfDirectDispatchCmd(interp, object, 1,
29322                                     NsfGlobalObjs[NSF_EVAL],
29323                                     1, &initcmdObj);
29324       if (likely(result == TCL_OK)) {
29325         Tcl_SetObjResult(interp, initNameObj);
29326       }
29327     }
29328     DECR_REF_COUNT(initNameObj);
29329   }
29330 
29331   if (newNameObj != NULL) {
29332     DECR_REF_COUNT(newNameObj);
29333   }
29334 
29335   return result;
29336 }
29337 
29338 /*
29339 cmd "object::exists" NsfObjectExistsCmd {
29340   {-argName "value" -required 1 -type tclobj}
29341 }
29342 */
29343 static int
NsfObjectExistsCmd(Tcl_Interp * interp,Tcl_Obj * valueObj)29344 NsfObjectExistsCmd(Tcl_Interp *interp, Tcl_Obj *valueObj) {
29345   NsfObject *object;
29346 
29347   nonnull_assert(interp != NULL);
29348   nonnull_assert(valueObj != NULL);
29349 
29350   /*
29351    * Pass the object as Tcl_Obj, since we do not want to raise an error in
29352    * case the object does not exist.
29353    */
29354   Tcl_SetBooleanObj(Tcl_GetObjResult(interp), GetObjectFromObj(interp, valueObj, &object) == TCL_OK);
29355   return TCL_OK;
29356 }
29357 
29358 /*
29359 cmd "object::property" NsfObjectPropertyCmd {
29360   {-argName "object" -required 1 -type object}
29361   {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|volatile|autonamed|slotcontainer|hasperobjectslots|keepcallerself|perobjectdispatch" -required 1}
29362   {-argName "value" -required 0 -type tclobj}
29363 }
29364 */
29365 
29366 static int
NsfObjectPropertyCmd(Tcl_Interp * interp,NsfObject * object,ObjectpropertyIdx_t objectProperty,Tcl_Obj * valueObj)29367 NsfObjectPropertyCmd(Tcl_Interp *interp, NsfObject *object, ObjectpropertyIdx_t objectProperty, Tcl_Obj *valueObj) {
29368   unsigned int flags = 0u, allowSet = 0u;
29369 
29370   nonnull_assert(interp != NULL);
29371   nonnull_assert(object != NULL);
29372 
29373   switch (objectProperty) {
29374   case ObjectpropertyAutonamedIdx: flags = NSF_IS_AUTONAMED; allowSet = 1; break;
29375   case ObjectpropertyInitializedIdx: flags = NSF_INIT_CALLED; allowSet = 1; break;
29376   case ObjectpropertyClassIdx: flags = NSF_IS_CLASS; break;
29377   case ObjectpropertyRootmetaclassIdx: flags = NSF_IS_ROOT_META_CLASS; break;
29378   case ObjectpropertyVolatileIdx:
29379     if (valueObj == NULL) {
29380       Tcl_SetObjResult(interp,
29381                        NsfGlobalObjs[object->opt != NULL && object->opt->volatileVarName ? NSF_ONE : NSF_ZERO]);
29382       return TCL_OK;
29383     }
29384     allowSet = 1;
29385     break;
29386 
29387     /*
29388      * If a value is provided, return the error below.
29389      */
29390   case ObjectpropertyRootclassIdx: flags = NSF_IS_ROOT_CLASS; break;
29391   case ObjectpropertySlotcontainerIdx: flags = NSF_IS_SLOT_CONTAINER; allowSet = 1; break;
29392   case ObjectpropertyKeepcallerselfIdx: flags = NSF_KEEP_CALLER_SELF; allowSet = 1; break;
29393   case ObjectpropertyPerobjectdispatchIdx: flags = NSF_PER_OBJECT_DISPATCH; allowSet = 1; break;
29394   case ObjectpropertyHasperobjectslotsIdx: flags = NSF_HAS_PER_OBJECT_SLOTS; allowSet = 1; break;
29395   case ObjectpropertyNULL:
29396     /*
29397      * Do nothing; just for detection if option was specified.
29398      */
29399     break;
29400   }
29401 
29402   if (valueObj != NULL) {
29403     if (likely(allowSet)) {
29404       int flagValue, result;
29405 
29406       result = SetBooleanFlag(interp, &object->flags, flags, valueObj, &flagValue);
29407       if (unlikely(result != TCL_OK)) {
29408         return result;
29409       }
29410 
29411       if (objectProperty == ObjectpropertySlotcontainerIdx) {
29412         assert(object->nsPtr != NULL);
29413         if (flagValue != 0) {
29414           /*
29415            * Turn on SlotContainerCmdResolver.
29416            */
29417           Tcl_SetNamespaceResolvers(object->nsPtr,
29418                                     (Tcl_ResolveCmdProc *)SlotContainerCmdResolver,
29419                                     NsColonVarResolver,
29420                                     (Tcl_ResolveCompiledVarProc *)NULL);
29421         } else {
29422           /*
29423            * Turn off SlotContainerCmdResolver.
29424            */
29425           Tcl_SetNamespaceResolvers(object->nsPtr,
29426                                     (Tcl_ResolveCmdProc *)NULL,
29427                                     NsColonVarResolver,
29428                                     (Tcl_ResolveCompiledVarProc *)NULL);
29429         }
29430       } else if (objectProperty == ObjectpropertyVolatileIdx) {
29431         bool objectIsVolatile = (object->opt != NULL && object->opt->volatileVarName != NULL);
29432 
29433         if (flagValue != 0 && !objectIsVolatile) {
29434           /*
29435            * Set volatile property.
29436            */
29437 
29438           /*NsfObjectSystem *osPtr = GetObjectSystem(object);*/
29439           /*fprintf(stderr, "change volatile ... make volatile %s\n",
29440             ObjectName(&osPtr->rootClass->object));*/
29441           result = VolatileMethod(interp, object, NSF_TRUE);
29442 
29443         } else if (flagValue == 0 && objectIsVolatile) {
29444           /*
29445            * Remove volatile property.
29446            */
29447           UnsetTracedVars(interp, object);
29448           object->opt->volatileVarName = NULL;
29449         } else {
29450           /*
29451            * Nothing to do.
29452            */
29453         }
29454 
29455         if (unlikely(result != TCL_OK)) {
29456           return result;
29457         }
29458       }
29459     } else {
29460       return NsfPrintError(interp, "object property is read only");
29461     }
29462   }
29463 
29464   Tcl_SetObjResult(interp,
29465                    NsfGlobalObjs[(object->flags & flags) ?
29466                                  NSF_ONE : NSF_ZERO]);
29467   return TCL_OK;
29468 }
29469 
29470 /*
29471 cmd "object::qualify" NsfObjectQualifyCmd {
29472   {-argName "objectName" -required 1 -type tclobj}
29473 }
29474 */
29475 static int
NsfObjectQualifyCmd(Tcl_Interp * interp,Tcl_Obj * objectNameObj)29476 NsfObjectQualifyCmd(Tcl_Interp *interp, Tcl_Obj *objectNameObj) {
29477   const char *nameString;
29478 
29479   nonnull_assert(interp != NULL);
29480   nonnull_assert(objectNameObj != NULL);
29481 
29482   nameString = ObjStr(objectNameObj);
29483   if (isAbsolutePath(nameString)) {
29484     Tcl_SetObjResult(interp, objectNameObj);
29485   } else {
29486     Tcl_SetObjResult(interp, NameInNamespaceObj(nameString, CallingNameSpace(interp)));
29487   }
29488   return TCL_OK;
29489 }
29490 
29491 /*
29492 cmd "objectsystem::create" NsfObjectSystemCreateCmd {
29493   {-argName "rootClass" -required 1 -type tclobj}
29494   {-argName "rootMetaClass" -required 1 -type tclobj}
29495   {-argName "systemMethods" -required 0 -type tclobj}
29496 }
29497 */
29498 static int
NsfObjectSystemCreateCmd(Tcl_Interp * interp,Tcl_Obj * rootClassObj,Tcl_Obj * rootMetaClassObj,Tcl_Obj * systemMethodsObj)29499 NsfObjectSystemCreateCmd(Tcl_Interp *interp, Tcl_Obj *rootClassObj, Tcl_Obj *rootMetaClassObj, Tcl_Obj *systemMethodsObj) {
29500   NsfClass        *theobj = NULL, *thecls = NULL;
29501   Tcl_Obj         *object, *class;
29502   const char      *objectName, *className;
29503   NsfObjectSystem *osPtr;
29504 
29505   nonnull_assert(interp != NULL);
29506   nonnull_assert(rootClassObj != NULL);
29507   nonnull_assert(rootMetaClassObj != NULL);
29508 
29509   osPtr = NEW(NsfObjectSystem);
29510   memset(osPtr, 0, sizeof(NsfObjectSystem));
29511 
29512   objectName = ObjStr(rootClassObj);
29513   object = isAbsolutePath(objectName) ? rootClassObj :
29514     NameInNamespaceObj(objectName, CallingNameSpace(interp));
29515 
29516   className = ObjStr(rootMetaClassObj);
29517   class = isAbsolutePath(className) ? rootMetaClassObj :
29518     NameInNamespaceObj(className, CallingNameSpace(interp));
29519 
29520   GetClassFromObj(interp, object, &theobj, NSF_FALSE);
29521   GetClassFromObj(interp, class, &thecls, NSF_FALSE);
29522 
29523   if ((theobj != NULL) || (thecls != NULL)) {
29524     ObjectSystemFree(interp, osPtr);
29525     NsfLog(interp, NSF_LOG_WARN, "Base class '%s' exists already; ignoring definition",
29526            (theobj != NULL) ? objectName : className);
29527     return TCL_OK;
29528   }
29529 
29530   if (systemMethodsObj != NULL) {
29531     int       oc, idx;
29532     Tcl_Obj **ov;
29533 
29534     if ((Tcl_ListObjGetElements(interp, systemMethodsObj, &oc, &ov)) == TCL_OK) {
29535       int i;
29536 
29537       if (oc % 2) {
29538         ObjectSystemFree(interp, osPtr);
29539         return NsfPrintError(interp, "system methods must be provided as pairs");
29540       }
29541       for (i = 0; i < oc; i += 2) {
29542         Tcl_Obj *arg, **arg_ov;
29543         int      arg_oc = -1, result;
29544 
29545         arg = ov[i+1];
29546         result = Tcl_GetIndexFromObj(interp, ov[i], Nsf_SystemMethodOpts, "system method", 0, &idx);
29547         if (likely(result == TCL_OK)) {
29548           result = Tcl_ListObjGetElements(interp, arg, &arg_oc, &arg_ov);
29549         }
29550         if (unlikely(result != TCL_OK)) {
29551           ObjectSystemFree(interp, osPtr);
29552           return NsfPrintError(interp, "invalid system method '%s'", ObjStr(ov[i]));
29553         } else if (arg_oc < 1 || arg_oc > 3) {
29554           ObjectSystemFree(interp, osPtr);
29555           return NsfPrintError(interp, "invalid system method argument '%s'", ObjStr(ov[i]), ObjStr(arg));
29556         }
29557         /*fprintf(stderr, "NsfCreateObjectSystemCmd [%d] = %p %s (max %d, given %d)\n",
29558           idx, ov[i+1], ObjStr(ov[i+1]), NSF_s_set_idx, oc);*/
29559 
29560         if (arg_oc == 1) {
29561           osPtr->methods[idx] = arg;
29562           osPtr->methodNames[idx] = ObjStr(arg);
29563         } else { /* (arg_oc == 2) */
29564           osPtr->methods[idx] = arg_ov[0];
29565           osPtr->methodNames[idx] = ObjStr(arg_ov[0]);
29566           osPtr->handles[idx] = arg_ov[1];
29567           if  (arg_oc == 3) {
29568             int boolVal = 0;
29569             Tcl_GetBooleanFromObj(interp, arg_ov[2], &boolVal);
29570             osPtr->protected[idx] = (char)boolVal;
29571           }
29572           INCR_REF_COUNT(osPtr->handles[idx]);
29573         }
29574         INCR_REF_COUNT(osPtr->methods[idx]);
29575       }
29576     } else {
29577       ObjectSystemFree(interp, osPtr);
29578       return NsfPrintError(interp, "provided system methods are not a proper list");
29579     }
29580   }
29581   /*
29582    * Create a basic object system with the basic root-class Object and the
29583    * basic metaclass Class, and store them in the RUNTIME STATE if successful.
29584    */
29585   theobj = PrimitiveCCreate(interp, object, NULL, NULL);
29586   thecls = PrimitiveCCreate(interp, class, NULL, NULL);
29587   /* fprintf(stderr, "CreateObjectSystem created base classes \n"); */
29588 
29589   /*
29590    * Check whether Object and Class creation was successful.
29591    */
29592   if ((theobj == NULL) || (thecls == NULL)) {
29593 
29594     if (thecls != NULL) {
29595       PrimitiveCDestroy(thecls);
29596     }
29597     if (theobj != NULL) {
29598       PrimitiveCDestroy(theobj);
29599     }
29600 
29601     ObjectSystemFree(interp, osPtr);
29602     return NsfPrintError(interp, "creation of object system failed");
29603   }
29604 
29605   theobj->osPtr = osPtr;
29606   thecls->osPtr = osPtr;
29607   osPtr->rootClass = theobj;
29608   osPtr->rootMetaClass = thecls;
29609 
29610   theobj->object.flags |= (NSF_IS_ROOT_CLASS|NSF_INIT_CALLED);
29611   thecls->object.flags |= (NSF_IS_ROOT_META_CLASS|NSF_INIT_CALLED);
29612 
29613   ObjectSystemAdd(interp, osPtr);
29614 
29615   AddInstance((NsfObject *)theobj, thecls);
29616   AddInstance((NsfObject *)thecls, thecls);
29617   AddSuper(thecls, theobj);
29618 
29619   if (NSF_DTRACE_OBJECT_ALLOC_ENABLED()) {
29620     NSF_DTRACE_OBJECT_ALLOC(ObjectName((NsfObject *)theobj), ClassName(((NsfObject *)theobj)->cl));
29621     NSF_DTRACE_OBJECT_ALLOC(ObjectName((NsfObject *)thecls), ClassName(((NsfObject *)thecls)->cl));
29622   }
29623 
29624   return TCL_OK;
29625 }
29626 
29627 
29628 /*
29629 cmd my NsfMyCmd {
29630   {-argName "-intrinsic" -nrargs 0}
29631   {-argName "-local" -nrargs 0}
29632   {-argName "-system" -nrargs 0}
29633   {-argName "method" -required 1 -type tclobj}
29634   {-argName "args" -type args}
29635 }
29636 */
29637 static int
NsfMyCmd(Tcl_Interp * interp,int withIntrinsic,int withLocal,int withSystem,Tcl_Obj * methodNameObj,int trailingObjc,Tcl_Obj * const trailingObjv[])29638 NsfMyCmd(Tcl_Interp *interp,
29639          int withIntrinsic, int withLocal, int withSystem,
29640          Tcl_Obj *methodNameObj,
29641          int trailingObjc, Tcl_Obj *const trailingObjv[]) {
29642   NsfObject *self;
29643   int        result;
29644 
29645   nonnull_assert(interp != NULL);
29646   nonnull_assert(methodNameObj != NULL);
29647 
29648   self = GetSelfObj(interp);
29649   if (unlikely(self == NULL)) {
29650     result = NsfNoCurrentObjectError(interp, method_definitions[NsfMyCmdIdx].methodName);
29651 
29652   } else if ((withIntrinsic && withLocal)
29653              || (withIntrinsic && withSystem)
29654              || (withLocal && withSystem)) {
29655     result = NsfPrintError(interp, "flags '-intrinsic', '-local' and '-system' are mutual exclusive");
29656 
29657   } else {
29658     unsigned int  flags;
29659 #if 0
29660     /* TODO attempt to make "my" NRE-enabled, failed so far (crash in mixinInheritanceTest) */
29661     NsfCallStackContent *cscPtr = CallStackGetTopFrame0(interp);
29662 
29663     if (cscPtr == NULL || self != cscPtr->self) {
29664       flags = NSF_CSC_IMMEDIATE;
29665     } else {
29666       flags = NsfImmediateFromCallerFlags(cscPtr->flags);
29667       fprintf(stderr, "XXX MY %s.%s frame has flags %.6x -> next-flags %.6x\n",
29668               ObjectName(self), ObjStr(methodNameObj), cscPtr->flags, flags);
29669     }
29670     if (withIntrinsic != 0) {flags |= NSF_CM_INTRINSIC_METHOD;}
29671     if (withLocal != 0)     {flags |= NSF_CM_LOCAL_METHOD;}
29672     if (withSystem != 0)    {flags |= NSF_CM_SYSTEM_METHOD;}
29673     result = CallMethod(self, interp, methodNameObj, trailingObjc+2, trailingObjv, flags);
29674 #else
29675     flags = NSF_CSC_IMMEDIATE;
29676     if (withIntrinsic != 0) {flags |= NSF_CM_INTRINSIC_METHOD;}
29677     if (withLocal != 0)     {flags |= NSF_CM_LOCAL_METHOD;}
29678     if (withSystem != 0)    {flags |= NSF_CM_SYSTEM_METHOD;}
29679     result = CallMethod(self, interp, methodNameObj, trailingObjc+2, trailingObjv, flags);
29680 #endif
29681   }
29682 
29683   return result;
29684 }
29685 
29686 
29687 /*
29688  *----------------------------------------------------------------------
29689  * NsfNextCmd --
29690  *
29691  *    nsf::next calls the next shadowed method. It might get a single
29692  *    argument which is used as argument vector for that method. If no
29693  *    argument is provided, the argument vector of the last invocation
29694  *    is used.
29695  *
29696  * Results:
29697  *    Tcl return code
29698  *
29699  * Side effects:
29700  *    The invoked method might produce side effects
29701  *
29702  *----------------------------------------------------------------------
29703  */
29704 /*
29705 cmd next NsfNextCmd {
29706   {-argName "arguments" -required 0 -type tclobj}
29707 }
29708 */
29709 static int
NsfNextCmd(Tcl_Interp * interp,Tcl_Obj * argumentsObj)29710 NsfNextCmd(Tcl_Interp *interp, Tcl_Obj *argumentsObj) {
29711   int                  oc, nobjc = 0, result;
29712   bool                 freeArgumentVector;
29713   NsfCallStackContent *cscPtr = NULL;
29714   const char          *methodName = NULL;
29715   Tcl_Obj            **nobjv = NULL, **ov;
29716 
29717   nonnull_assert(interp != NULL);
29718 
29719   if (argumentsObj != NULL) {
29720     /*
29721      * Arguments were provided.
29722      */
29723     int rc = Tcl_ListObjGetElements(interp, argumentsObj, &oc, &ov);
29724 
29725     if (unlikely(rc != TCL_OK)) {
29726       return rc;
29727     }
29728   } else {
29729     /*
29730      * No arguments were provided.
29731      */
29732     oc = -1;
29733     ov = NULL;
29734   }
29735 
29736   result = NextGetArguments(interp, oc, ov, &cscPtr, &methodName,
29737                             &nobjc, &nobjv, &freeArgumentVector);
29738   if (likely(result == TCL_OK)) {
29739     assert(cscPtr != NULL);
29740     result = NextSearchAndInvoke(interp, methodName, nobjc, nobjv, cscPtr, freeArgumentVector);
29741   }
29742   return result;
29743 }
29744 
29745 /*
29746 cmd nscopyvars NsfNSCopyVars {
29747   {-argName "fromNs" -required 1 -type tclobj}
29748   {-argName "toNs" -required 1 -type tclobj}
29749 }
29750 */
29751 static int
NsfNSCopyVarsCmd(Tcl_Interp * interp,Tcl_Obj * fromNsObj,Tcl_Obj * toNsObj)29752 NsfNSCopyVarsCmd(Tcl_Interp *interp, Tcl_Obj *fromNsObj, Tcl_Obj *toNsObj) {
29753   Tcl_Namespace       *fromNsPtr = NULL, *toNsPtr;
29754   Var                 *varPtr = NULL;
29755   Tcl_HashSearch       hSrch;
29756   const Tcl_HashEntry *hPtr;
29757   TclVarHashTable     *varTablePtr;
29758   NsfObject           *destObject;
29759   const char          *destFullName;
29760   Tcl_Obj             *destFullNameObj;
29761   Tcl_CallFrame        frame, *framePtr = &frame;
29762   int                  result;
29763 
29764   nonnull_assert(interp != NULL);
29765   nonnull_assert(fromNsObj != NULL);
29766   nonnull_assert(toNsObj != NULL);
29767 
29768   TclGetNamespaceFromObj(interp, fromNsObj, &fromNsPtr);
29769 
29770   if (fromNsPtr != NULL) {
29771     if (TclGetNamespaceFromObj(interp, toNsObj, &toNsPtr) != TCL_OK) {
29772       return NsfPrintError(interp, "CopyVars: Destination namespace %s does not exist",
29773                            ObjStr(toNsObj));
29774     }
29775 
29776     destFullName = toNsPtr->fullName;
29777     destFullNameObj = Tcl_NewStringObj(destFullName, -1);
29778     INCR_REF_COUNT(destFullNameObj);
29779     varTablePtr = Tcl_Namespace_varTablePtr(fromNsPtr);
29780     Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, toNsPtr, 0);
29781   } else {
29782     NsfObject *newObject, *object;
29783 
29784     if (GetObjectFromObj(interp, fromNsObj, &object) != TCL_OK) {
29785       return NsfPrintError(interp, "CopyVars: Origin object/namespace %s does not exist",
29786                            ObjStr(fromNsObj));
29787 
29788     } else if (GetObjectFromObj(interp, toNsObj, &newObject) != TCL_OK) {
29789       return NsfPrintError(interp, "CopyVars: Destination object/namespace %s does not exist",
29790                            ObjStr(toNsObj));
29791     } else {
29792       varTablePtr = object->varTablePtr;
29793       destFullNameObj = newObject->cmdName;
29794       destFullName = ObjStr(destFullNameObj);
29795     }
29796   }
29797 
29798   destObject = GetObjectFromString(interp, destFullName);
29799   result = TCL_OK;
29800 
29801   /*
29802    * Copy all vars in the namespace.
29803    */
29804   hPtr = (varTablePtr != NULL) ? Tcl_FirstHashEntry(TclVarHashTablePtr(varTablePtr), &hSrch) : NULL;
29805   while (hPtr != NULL) {
29806     Tcl_Obj *varNameObj, *resultObj;
29807 
29808     GetVarAndNameFromHash(hPtr, &varPtr, &varNameObj);
29809     INCR_REF_COUNT(varNameObj);
29810 
29811     if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) {
29812       if (TclIsVarScalar(varPtr)) {
29813         /*
29814          * Copy scalar variables from the namespace, which might be
29815          * either instance or namespace variables.
29816          */
29817 
29818         if (destObject != NULL) {
29819           /* fprintf(stderr, "copy in obj %s var %s val '%s'\n", ObjectName(destObject), ObjStr(varNameObj),
29820              ObjStr(TclVarValue(Tcl_Obj, varPtr, objPtr)));*/
29821 
29822           resultObj = Nsf_ObjSetVar2((Nsf_Object *)destObject, interp, varNameObj, NULL,
29823                                      TclVarValue(Tcl_Obj, varPtr, objPtr), TCL_LEAVE_ERR_MSG);
29824         } else {
29825           resultObj = Tcl_ObjSetVar2(interp, varNameObj, NULL,
29826                                      TclVarValue(Tcl_Obj, varPtr, objPtr),
29827                                      TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
29828         }
29829         if (unlikely(resultObj == NULL)) {
29830           DECR_REF_COUNT(varNameObj);
29831           result = TCL_ERROR;
29832           goto copy_done;
29833         }
29834       } else {
29835         if (TclIsVarArray(varPtr)) {
29836           /* HERE!! PRE85 Why not [array get/set] based? Let the core iterate */
29837           TclVarHashTable *aTable = TclVarValue(TclVarHashTable, varPtr, tablePtr);
29838           Tcl_HashSearch ahSrch;
29839           Tcl_HashEntry *ahPtr = (aTable != NULL) ? Tcl_FirstHashEntry(TclVarHashTablePtr(aTable), &ahSrch) : 0;
29840 
29841           for (; ahPtr != NULL; ahPtr = Tcl_NextHashEntry(&ahSrch)) {
29842             Tcl_Obj *eltNameObj;
29843             Var *eltVar;
29844 
29845             GetVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj);
29846             INCR_REF_COUNT(eltNameObj);
29847 
29848             if (TclIsVarScalar(eltVar)) {
29849               if (destObject != NULL) {
29850                 resultObj = Nsf_ObjSetVar2((Nsf_Object *)destObject, interp, varNameObj, eltNameObj,
29851                                            TclVarValue(Tcl_Obj, eltVar, objPtr), TCL_LEAVE_ERR_MSG);
29852               } else {
29853                 resultObj = Tcl_ObjSetVar2(interp, varNameObj, eltNameObj,
29854                                            TclVarValue(Tcl_Obj, eltVar, objPtr),
29855                                            TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
29856               }
29857               if (unlikely(resultObj == NULL)) {
29858                 DECR_REF_COUNT(varNameObj);
29859                 result = TCL_ERROR;
29860                 goto copy_done;
29861               }
29862             }
29863             DECR_REF_COUNT(eltNameObj);
29864           }
29865         }
29866       }
29867     }
29868     DECR_REF_COUNT(varNameObj);
29869     hPtr = Tcl_NextHashEntry(&hSrch);
29870   }
29871  copy_done:
29872   if (fromNsPtr != NULL) {
29873     DECR_REF_COUNT(destFullNameObj);
29874     Tcl_PopCallFrame(interp);
29875   }
29876   return result;
29877 }
29878 
29879 /*
29880 cmd parameter::info NsfParameterInfoCmd {
29881   {-argName "subcmd"   -typeName "parametersubcmd" -type "default|list|name|syntax|type" -required 1}
29882   {-argName "parameterspec"   -required 1 -type tclobj}
29883   {-argName "varname"         -required 0 -type tclobj}
29884 }
29885 */
29886 static int
NsfParameterInfoCmd(Tcl_Interp * interp,ParametersubcmdIdx_t subcmd,Tcl_Obj * specObj,Tcl_Obj * varnameObj)29887 NsfParameterInfoCmd(Tcl_Interp *interp, ParametersubcmdIdx_t subcmd, Tcl_Obj *specObj,  Tcl_Obj *varnameObj) {
29888   NsfParsedParam parsedParam;
29889   Tcl_Obj *paramsObj, *listObj = NULL;
29890   Nsf_Param *paramsPtr;
29891   int result;
29892 
29893   nonnull_assert(interp != NULL);
29894   nonnull_assert(specObj != NULL);
29895 
29896   if (subcmd != ParametersubcmdDefaultIdx && varnameObj != NULL) {
29897     return NsfPrintError(interp, "parameter::info: provided third argument is only valid for querying defaults");
29898   }
29899 
29900   paramsObj = Tcl_NewListObj(1, &specObj);
29901   INCR_REF_COUNT(paramsObj);
29902   result = ParamDefsParse(interp, NULL, paramsObj,
29903                           NSF_DISALLOWED_ARG_OBJECT_PARAMETER, NSF_TRUE,
29904                           &parsedParam, NULL);
29905   DECR_REF_COUNT(paramsObj);
29906 
29907   if (unlikely(result != TCL_OK)) {
29908     return result;
29909   }
29910 
29911   assert(parsedParam.paramDefs != NULL);
29912   paramsPtr = parsedParam.paramDefs->paramsPtr;
29913   assert(paramsPtr != NULL);
29914 
29915   /*
29916    * Since we are passing in a parameter definition in Tcl syntax, and we want
29917    * to extract information from that syntax, it makes limited sense to
29918    * provide a context object for virtual parameter expansion. At least, we do
29919    * not allow this so far.
29920    */
29921 
29922   switch (subcmd) {
29923   case ParametersubcmdDefaultIdx:
29924     if (paramsPtr->defaultValue != NULL) {
29925       if (varnameObj != NULL) {
29926         Tcl_Obj *resultObj = Tcl_ObjSetVar2(interp, varnameObj, NULL,
29927                                             paramsPtr->defaultValue,
29928                                             TCL_LEAVE_ERR_MSG);
29929         if (unlikely(resultObj == NULL)) {
29930           ParamDefsRefCountDecr(parsedParam.paramDefs);
29931           return TCL_ERROR;
29932         }
29933       }
29934       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_ONE]);
29935     } else {
29936       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_ZERO]);
29937     }
29938     break;
29939 
29940   case ParametersubcmdListIdx:
29941     listObj = ParamDefsList(interp, paramsPtr, NULL, NULL);
29942     Tcl_SetObjResult(interp, listObj);
29943     DECR_REF_COUNT2("paramDefsObj", listObj);
29944     break;
29945 
29946   case ParametersubcmdNameIdx:
29947     listObj = ParamDefsNames(interp, paramsPtr, NULL, NULL);
29948     Tcl_SetObjResult(interp, listObj);
29949     DECR_REF_COUNT2("paramDefsObj", listObj);
29950     break;
29951 
29952   case ParametersubcmdSyntaxIdx:
29953     listObj = NsfParamDefsSyntax(interp, paramsPtr, NULL, NULL);
29954     Tcl_SetObjResult(interp, listObj);
29955     DECR_REF_COUNT2("paramDefsObj", listObj);
29956     break;
29957 
29958   case ParametersubcmdTypeIdx:
29959     if (paramsPtr->type != NULL) {
29960 
29961       if (paramsPtr->converter == Nsf_ConvertToTclobj && paramsPtr->converterArg) {
29962         Tcl_SetObjResult(interp, paramsPtr->converterArg);
29963 
29964       } else {
29965         if (paramsPtr->converter == Nsf_ConvertToObject || paramsPtr->converter == Nsf_ConvertToClass) {
29966           const char *what = paramsPtr->type;
29967           /*
29968            * baseclass and metaclass are communicated via flags
29969            */
29970           if (unlikely((paramsPtr->flags & NSF_ARG_BASECLASS) != 0u)) {
29971             what = "baseclass";
29972           } else if (unlikely((paramsPtr->flags & NSF_ARG_METACLASS) != 0u)) {
29973             what = "metaclass";
29974           }
29975           /*
29976            * The converterArg might contain a class for type checking
29977            */
29978           if (paramsPtr->converterArg == NULL) {
29979             Tcl_SetObjResult(interp, Tcl_NewStringObj(what, -1));
29980           } else {
29981             Tcl_SetObjResult(interp, paramsPtr->converterArg);
29982           }
29983         } else {
29984           Tcl_SetObjResult(interp, Tcl_NewStringObj(paramsPtr->type, -1));
29985         }
29986       }
29987     } else {
29988       Tcl_SetObjResult(interp, NsfGlobalObjs[NSF_EMPTY]);
29989     }
29990     break;
29991 
29992   case ParametersubcmdNULL:
29993     /*
29994      * Do nothing; just for detection if option was specified.
29995      */
29996     break;
29997   }
29998 
29999   ParamDefsRefCountDecr(parsedParam.paramDefs);
30000 
30001   return TCL_OK;
30002 }
30003 
30004 /*
30005 cmd parameter::cache::classinvalidate NsfParameterCacheClassInvalidateCmd {
30006   {-argName "class" -required 1 -type class}
30007 }
30008 */
30009 static int
NsfParameterCacheClassInvalidateCmd(Tcl_Interp * interp,NsfClass * class)30010 NsfParameterCacheClassInvalidateCmd(Tcl_Interp *interp, NsfClass *class) {
30011 
30012   nonnull_assert(interp != NULL);
30013   nonnull_assert(class != NULL);
30014 
30015   /*
30016    * First, increment the epoch in case we have a parsedParam. The
30017    * classParamPtrEpoch is just used for PER_OBJECT_PARAMETER_CACHING
30018    */
30019 #if defined(PER_OBJECT_PARAMETER_CACHING)
30020   if (unlikely(class->parsedParamPtr != NULL)) {
30021     NsfClassParamPtrEpochIncr("NsfParameterCacheClassInvalidateCmd");
30022   }
30023 #endif
30024 
30025   /*
30026    * During shutdown, no new objects are created, therefore we do not need to
30027    * to invalidate the cached parsedParamPtr of the classes.
30028    */
30029   if (unlikely(RUNTIME_STATE(interp)->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF)) {
30030     NsfClasses *dependentSubClasses;
30031     NsfClasses *clPtr;
30032 
30033     /*
30034      * Clear the cached parsedParam of the class and all its subclasses (the
30035      * result of DependentSubClasses() contains the starting
30036      * class). Furthermore, make a quick check whether any of the subclasses
30037      * is a class mixin of some other class.
30038      */
30039 
30040     dependentSubClasses = DependentSubClasses(class);
30041     if (dependentSubClasses != NULL) {
30042 
30043       for (clPtr = dependentSubClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
30044         NsfClass *subClass = clPtr->cl;
30045 
30046         if (subClass->parsedParamPtr != NULL) {
30047           ParsedParamFree(subClass->parsedParamPtr);
30048           subClass->parsedParamPtr = NULL;
30049         }
30050 
30051       }
30052       NsfClassListFree(dependentSubClasses);
30053     }
30054 
30055   }
30056   return TCL_OK;
30057 }
30058 
30059 
30060 /*
30061 cmd parameter::cache::objectinvalidate NsfParameterCacheObjectInvalidateCmd {
30062   {-argName "object" -required 1 -type object}
30063 }
30064 */
30065 static int
NsfParameterCacheObjectInvalidateCmd(Tcl_Interp * UNUSED (interp),NsfObject * object)30066 NsfParameterCacheObjectInvalidateCmd(Tcl_Interp *UNUSED(interp), NsfObject *object) {
30067 
30068   nonnull_assert(object != NULL);
30069 
30070 #if defined(PER_OBJECT_PARAMETER_CACHING)
30071   if (object->opt != NULL && object->opt->parsedParamPtr) {
30072     /*fprintf(stderr, "   %p %s invalidate %p\n", object,
30073       ObjectName(object),  object->opt->parsedParamPtr);*/
30074     ParsedParamFree(object->opt->parsedParamPtr);
30075     object->opt->parsedParamPtr = NULL;
30076   }
30077 #endif
30078   return TCL_OK;
30079 }
30080 
30081 /*
30082 cmd parameter::specs NsfParameterSpecsCmd {
30083   {-argName "-configure"  -nrargs 0 -required 0}
30084   {-argName "-nonposargs"  -nrargs 0 -required 0}
30085   {-argName "slotobjs"    -required 1 -type tclobj}
30086 }
30087 */
30088 
30089 static int
NsfParameterSpecsCmd(Tcl_Interp * interp,int withConfigure,int withNonposargs,Tcl_Obj * slotobjsObj)30090 NsfParameterSpecsCmd(Tcl_Interp *interp, int withConfigure, int withNonposargs, Tcl_Obj *slotobjsObj) {
30091   NsfTclObjList *objList = NULL, *elt;
30092   Tcl_Obj **objv, *resultObj;
30093   int result = TCL_OK, i, objc;
30094 
30095   nonnull_assert(interp != NULL);
30096   nonnull_assert(slotobjsObj != NULL);
30097 
30098   if (Tcl_ListObjGetElements(interp, slotobjsObj, &objc, &objv) != TCL_OK) {
30099     return NsfPrintError(interp, "NsfParameterSpecsCmd: invalid slot object list");
30100   }
30101 
30102   /*
30103    * Iterate over the slot objects and obtain the position and the
30104    * parameterSpec.
30105    */
30106   for (i = 0; i < objc; i++) {
30107     NsfObject *slotObject;
30108     Tcl_Obj *positionObj, *specObj = NULL;
30109 
30110     if (GetObjectFromObj(interp, objv[i], &slotObject) != TCL_OK) {
30111       return NsfPrintError(interp, "objectparameter: slot element is not a next scripting object");
30112     }
30113     assert(slotObject != NULL);
30114 
30115     /*
30116      * When withConfigure is provided, skip this parameter ...
30117      *  - when configure is not set
30118      *  - or  configure == 0
30119      */
30120     if (withConfigure != 0) {
30121       int configure = 0;
30122       Tcl_Obj *configureObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
30123                                              NsfGlobalObjs[NSF_CONFIGURABLE], NULL, 0);
30124       if (configureObj == NULL) {
30125         continue;
30126       }
30127       Tcl_GetBooleanFromObj(interp, configureObj, &configure);
30128       if (configure == 0) {
30129         continue;
30130       }
30131     }
30132 
30133     /*
30134      * When withNonposargs is provided, skip this parameter ...
30135      *  - when positional == 1
30136      */
30137     if (withNonposargs != 0) {
30138       Tcl_Obj *positionalObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
30139                                              NsfGlobalObjs[NSF_POSITIONAL], NULL, 0);
30140       if (positionalObj != NULL) {
30141         int positional = 0;
30142 
30143         Tcl_GetBooleanFromObj(interp, positionalObj, &positional);
30144         if (positional != 0) {
30145           continue;
30146         }
30147       }
30148     }
30149 
30150     positionObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
30151                                  NsfGlobalObjs[NSF_POSITION], NULL, 0);
30152     specObj = Nsf_ObjGetVar2((Nsf_Object *)slotObject, interp,
30153                              NsfGlobalObjs[NSF_PARAMETERSPEC], NULL, 0);
30154     if (specObj == NULL) {
30155       result = CallMethod(slotObject, interp, NsfGlobalObjs[NSF_GET_PARAMETER_SPEC], 2, NULL,
30156                           NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
30157       if (unlikely(result != TCL_OK)) {
30158         return NsfPrintError(interp, "objectparameter: %s %s returned error",
30159                              ObjectName_(slotObject),
30160                              NsfGlobalStrings[NSF_GET_PARAMETER_SPEC]);
30161       }
30162       specObj = Tcl_GetObjResult(interp);
30163     }
30164     /*fprintf(stderr, "NsfParameterSpecsCmd  slot obj = %s pos %s spec %s\n", ObjStr(objv[i]), (positionObj != NULL) ? ObjStr(positionObj) : "NONE", ObjStr(specObj)  );*/
30165     /*
30166      * Add the spec to the list indicated by the position
30167      */
30168     TclObjListAdd(interp, &objList, positionObj, specObj);
30169   }
30170 
30171   /*
30172    * Fold the per-position lists into a flat result list
30173    */
30174   resultObj = Tcl_NewListObj(0, NULL);
30175   for (elt = objList; elt != NULL; elt = elt->nextPtr) {
30176     Tcl_ListObjGetElements(interp, elt->payload, &objc, &objv);
30177     for (i = 0; i < objc; i++) {
30178       Tcl_ListObjAppendElement(interp, resultObj, objv[i]);
30179 
30180     }
30181   }
30182 
30183   Tcl_SetObjResult(interp, resultObj);
30184   if (objList != NULL) {
30185     TclObjListFreeList(objList);
30186   }
30187 
30188   return result;
30189 }
30190 
30191 /*
30192 cmd proc NsfProcCmd {
30193   {-argName "-ad"          -required 0 -nrargs 0 -type switch}
30194   {-argName "-checkalways" -required 0 -nrargs 0 -type switch}
30195   {-argName "-debug"       -required 0 -nrargs 0 -type switch}
30196   {-argName "-deprecated"  -required 0 -nrargs 0 -type switch}
30197   {-argName "procName"     -required 1 -type tclobj}
30198   {-argName "arguments"    -required 1 -type tclobj}
30199   {-argName "body"         -required 1 -type tclobj}
30200 }
30201 */
30202 static int
NsfProcCmd(Tcl_Interp * interp,int withAd,int withCheckalways,int withDebug,int withDeprecated,Tcl_Obj * procNameObj,Tcl_Obj * argumentsObj,Tcl_Obj * bodyObj)30203 NsfProcCmd(Tcl_Interp *interp, int withAd, int withCheckalways, int withDebug, int withDeprecated,
30204            Tcl_Obj *procNameObj, Tcl_Obj *argumentsObj, Tcl_Obj *bodyObj) {
30205   NsfParsedParam parsedParam;
30206   int result;
30207 
30208   nonnull_assert(interp != NULL);
30209   nonnull_assert(procNameObj != NULL);
30210   nonnull_assert(argumentsObj != NULL);
30211   nonnull_assert(bodyObj != NULL);
30212 
30213   /*
30214    * Parse argument list "arguments" to determine if we should provide
30215    * nsf parameter handling.
30216    */
30217   result = ParamDefsParse(interp, procNameObj, argumentsObj,
30218                           NSF_DISALLOWED_ARG_METHOD_PARAMETER, (withDebug != 0),
30219                           &parsedParam, Tcl_GetCurrentNamespace(interp)->fullName);
30220   if (unlikely(result != TCL_OK)) {
30221     return result;
30222   }
30223 
30224   if (parsedParam.paramDefs != NULL || withDebug != 0 || withDeprecated != 0) {
30225     /*
30226      * We need parameter handling. In such cases, a thin C-based layer
30227      * is added which handles the parameter passing and calls the proc
30228      * later.
30229      */
30230     result = NsfProcAdd(interp, &parsedParam, ObjStr(procNameObj), bodyObj,
30231                         withAd, withCheckalways, withDebug, withDeprecated);
30232 
30233   } else {
30234     /*
30235      * No parameter handling needed. A plain Tcl proc is added.
30236      */
30237     Tcl_Obj *ov[4];
30238 
30239     ov[0] = NULL;
30240     ov[1] = procNameObj;
30241     ov[2] = argumentsObj;
30242     ov[3] = bodyObj;
30243     result = Tcl_ProcObjCmd(0, interp, 4, ov);
30244   }
30245 
30246   return result;
30247 }
30248 
30249 /*
30250 cmd relation::get NsfRelationGetCmd {
30251   {-argName "object" -type object}
30252   {-argName "type" -required 1 -typeName "relationtype" -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"}
30253 }
30254 */
30255 static int
NsfRelationGetCmd(Tcl_Interp * interp,NsfObject * object,RelationtypeIdx_t type)30256 NsfRelationGetCmd(Tcl_Interp *interp, NsfObject *object, RelationtypeIdx_t type) {
30257 
30258   return NsfRelationSetCmd(interp, object, type, NULL);
30259 }
30260 
30261 
30262 /*
30263  *----------------------------------------------------------------------
30264  * NsfRelationClassMixinsSet --
30265  *
30266  *    Set class mixins; the main reason for the factored-out semantics is that
30267  *    it supports to undo/redo the operations in case of a failure.
30268  *
30269  * Results:
30270  *    Tcl result code.
30271  *
30272  * Side effects:
30273  *    class mixins are set, various kinds of invalidations.
30274  *
30275  *----------------------------------------------------------------------
30276  */
30277 static int NsfRelationClassMixinsSet(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *valueObj, int oc, Tcl_Obj **ov)
30278   nonnull(1) nonnull(2) nonnull(3);
30279 
30280 static int
NsfRelationClassMixinsSet(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * valueObj,int oc,Tcl_Obj ** ov)30281 NsfRelationClassMixinsSet(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *valueObj, int oc, Tcl_Obj **ov) {
30282   NsfCmdList  *newMixinCmdList = NULL, *cmds;
30283   NsfClasses  *subClasses;
30284   NsfClassOpt *clopt;
30285   int          i;
30286 
30287   nonnull_assert(interp != NULL);
30288   nonnull_assert(class != NULL);
30289   nonnull_assert(valueObj != NULL);
30290 
30291   for (i = 0; i < oc; i++) {
30292     if (unlikely(MixinAdd(interp, &newMixinCmdList, ov[i]) != TCL_OK)) {
30293       CmdListFree(&newMixinCmdList, GuardDel);
30294       return TCL_ERROR;
30295     }
30296   }
30297   clopt = class->opt;
30298   assert(clopt != NULL);
30299 
30300   if (clopt->classMixins != NULL) {
30301     RemoveFromClassMixinsOf(class->object.id, clopt->classMixins);
30302     CmdListFree(&clopt->classMixins, GuardDel);
30303   }
30304 
30305   subClasses = DependentSubClasses(class);
30306   MixinInvalidateObjOrders(subClasses);
30307 
30308   /*
30309    * Since methods of mixed in classes may be used as filters, we have to
30310    * invalidate the filters as well.
30311    */
30312   if (FiltersDefined(interp) > 0) {
30313     FilterInvalidateObjOrders(interp, subClasses);
30314   }
30315   NsfClassListFree(subClasses);
30316 
30317   /*
30318    * Now register the specified mixins.
30319    */
30320   clopt->classMixins = newMixinCmdList;
30321 
30322   /*
30323    * Finally, update classMixinOfs
30324    */
30325   for (cmds = newMixinCmdList; cmds; cmds = cmds->nextPtr) {
30326     NsfObject *nObject = NsfGetObjectFromCmdPtr(cmds->cmdPtr);
30327 
30328     if (nObject != NULL) {
30329       NsfClassOpt *nclopt = NsfRequireClassOpt((NsfClass *) nObject);
30330 
30331       CmdListAddSorted(&nclopt->isClassMixinOf, class->object.id, NULL);
30332     } else {
30333       NsfLog(interp, NSF_LOG_WARN,
30334              "Problem registering %s as a class mixin of %s\n",
30335              ObjStr(valueObj), ClassName_(class));
30336     }
30337   }
30338 
30339   return TCL_OK;
30340 }
30341 
30342 
30343 /*
30344 cmd relation::set NsfRelationSetCmd {
30345   {-argName "object"  -required 1 -type object}
30346   {-argName "type" -required 1 -typeName "relationtype" -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"}
30347   {-argName "value" -required 0 -type tclobj}
30348 }
30349 */
30350 static int
NsfRelationSetCmd(Tcl_Interp * interp,NsfObject * object,RelationtypeIdx_t type,Tcl_Obj * valueObj)30351 NsfRelationSetCmd(Tcl_Interp *interp, NsfObject *object, RelationtypeIdx_t type, Tcl_Obj *valueObj) {
30352   int            oc = 0, i;
30353   Tcl_Obj      **ov;
30354   NsfClass      *class = NULL;
30355   NsfObjectOpt  *objopt = NULL;
30356   NsfClassOpt   *clopt = NULL, *nclopt = NULL;
30357 
30358   nonnull_assert(interp != NULL);
30359   nonnull_assert(object != NULL);
30360 
30361   /*fprintf(stderr, "NsfRelationSetCmd %s rel=%d val='%s'\n",
30362     ObjectName(object), relationtype, (valueObj != NULL) ? ObjStr(valueObj) : "NULL");*/
30363 
30364   if (type == RelationtypeClass_mixinIdx ||
30365       type == RelationtypeClass_filterIdx) {
30366     if (NsfObjectIsClass(object)) {
30367       class = (NsfClass *)object;
30368     } else {
30369       /*
30370        * Fall back to per-object case.
30371        */
30372       type = (type == RelationtypeClass_mixinIdx) ?
30373         RelationtypeObject_mixinIdx :
30374         RelationtypeObject_filterIdx ;
30375     }
30376   }
30377 
30378   /*
30379    * The first switch block is just responsible for obtaining objopt or clopt
30380    * or handling other simple cases.
30381    */
30382   switch (type) {
30383   case RelationtypeObject_filterIdx: /* fall through */
30384   case RelationtypeObject_mixinIdx:
30385     if (valueObj == NULL) {
30386       objopt = object->opt;
30387       if (type == RelationtypeObject_mixinIdx) {
30388         return (objopt != NULL) ? MixinInfo(interp, objopt->objMixins, NULL, NSF_TRUE, NULL) : TCL_OK;
30389       } else /* (type == RelationtypeObject_filterIdx) */ {
30390         return (objopt != NULL) ? FilterInfo(interp, objopt->objFilters, NULL, NSF_TRUE, NSF_FALSE) : TCL_OK;
30391       }
30392     }
30393     if (unlikely(Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK)) {
30394       return TCL_ERROR;
30395     }
30396     objopt = NsfRequireObjectOpt(object);
30397     break;
30398 
30399   case RelationtypeClass_mixinIdx: /* fall through */
30400   case RelationtypeClass_filterIdx:
30401     assert(class != NULL);
30402     if (valueObj == NULL) {
30403       clopt = class->opt;
30404       if (type == RelationtypeClass_mixinIdx) {
30405         return (clopt != NULL) ? MixinInfo(interp, clopt->classMixins, NULL, NSF_TRUE, NULL) : TCL_OK;
30406       } else /* if (relationtype == RelationtypeClass_filterIdx) */ {
30407         return (clopt != NULL) ? FilterInfo(interp, clopt->classFilters, NULL, NSF_TRUE, NSF_FALSE) : TCL_OK;
30408       }
30409     }
30410     if (unlikely(Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK)) {
30411       return TCL_ERROR;
30412     }
30413     clopt = NsfRequireClassOpt(class);
30414     break;
30415 
30416   case RelationtypeSuperclassIdx:
30417     if (!NsfObjectIsClass(object)) {
30418       return NsfObjErrType(interp, "superclass", object->cmdName, "class", NULL);
30419     }
30420     class = (NsfClass *)object;
30421     if (valueObj == NULL) {
30422       return ListSuperClasses(interp, class, NULL, NSF_FALSE);
30423     }
30424     if (unlikely(Tcl_ListObjGetElements(interp, valueObj, &oc, &ov) != TCL_OK)) {
30425       return TCL_ERROR;
30426     }
30427     return SuperclassAdd(interp, class, oc, ov, valueObj);
30428 
30429   case RelationtypeClassIdx:
30430     if (valueObj == NULL) {
30431       Tcl_SetObjResult(interp, object->cl->object.cmdName);
30432       return TCL_OK;
30433     }
30434     GetClassFromObj(interp, valueObj, &class, NSF_TRUE);
30435     if (class == NULL) {
30436       return NsfObjErrType(interp, "class", valueObj, "a class", NULL);
30437     }
30438     i = ChangeClass(interp, object, class);
30439     if (i == TCL_OK) {
30440       Tcl_SetObjResult(interp, object->cl->object.cmdName);
30441     }
30442     return i;
30443 
30444   case RelationtypeRootclassIdx:
30445     {
30446     NsfClass *metaClass = NULL;
30447 
30448     if (!NsfObjectIsClass(object)) {
30449       return NsfObjErrType(interp, "rootclass", object->cmdName, "class", NULL);
30450     }
30451     class = (NsfClass *)object;
30452 
30453     if (valueObj == NULL) {
30454       return NsfPrintError(interp, "metaclass must be specified as third argument");
30455     }
30456     GetClassFromObj(interp, valueObj, &metaClass, NSF_FALSE);
30457     if (metaClass == NULL) {
30458       return NsfObjErrType(interp, "rootclass", valueObj, "class", NULL);
30459     }
30460 
30461     class->object.flags |= NSF_IS_ROOT_CLASS;
30462     metaClass->object.flags |= NSF_IS_ROOT_META_CLASS;
30463 
30464     return TCL_OK;
30465 
30466     /* TODO:
30467        Need to remove these properties?
30468        Allow one to delete a class system at runtime?
30469     */
30470     }
30471 
30472   case RelationtypeNULL:
30473     /* do nothing; just for detection if option was specified */
30474     return TCL_OK;
30475   }
30476 
30477   /*
30478    * The second switch block is responsible for the more complex handling of
30479    * the relations.
30480    */
30481 
30482   switch (type) {
30483   case RelationtypeObject_mixinIdx:
30484     {
30485       NsfCmdList *newMixinCmdList = NULL, *cmds;
30486 
30487       /*
30488        * Add every mixin class
30489        */
30490       for (i = 0; i < oc; i++) {
30491         if (unlikely(MixinAdd(interp, &newMixinCmdList, ov[i]) != TCL_OK)) {
30492           CmdListFree(&newMixinCmdList, GuardDel);
30493           return TCL_ERROR;
30494         }
30495       }
30496 
30497       if (objopt->objMixins != NULL) {
30498         NsfCmdList *cmdlist, *del;
30499 
30500         /*
30501          * Delete from old isObjectMixinOf lists
30502          */
30503         for (cmdlist = objopt->objMixins; cmdlist != NULL; cmdlist = cmdlist->nextPtr) {
30504           class = NsfGetClassFromCmdPtr(cmdlist->cmdPtr);
30505           clopt = (class != NULL) ? class->opt : NULL;
30506           if (clopt != NULL) {
30507             del = CmdListFindCmdInList(object->id, clopt->isObjectMixinOf);
30508             if (del != NULL) {
30509               /* fprintf(stderr, "Removing object %s from isObjectMixinOf of class %s\n",
30510                  ObjectName(object), ObjStr(NsfGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */
30511               del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del);
30512               CmdListDeleteCmdListEntry(del, GuardDel);
30513             }
30514           }
30515         }
30516         CmdListFree(&objopt->objMixins, GuardDel);
30517       }
30518 
30519       /*
30520        * Invalidate per-object infos
30521        */
30522       NsfParameterCacheObjectInvalidateCmd(interp, object);
30523       object->flags &= ~NSF_MIXIN_ORDER_VALID;
30524       /*
30525        * Since mixin procs may be used as filters -> we have to invalidate
30526        * filters as well.
30527        */
30528       object->flags &= ~NSF_FILTER_ORDER_VALID;
30529 
30530       /*
30531        * Now register the specified mixins.
30532        */
30533       objopt->objMixins = newMixinCmdList;
30534 
30535       for (cmds = newMixinCmdList; cmds; cmds = cmds->nextPtr) {
30536         NsfObject *nObject = NsfGetObjectFromCmdPtr(cmds->cmdPtr);
30537 
30538         if (nObject != NULL) {
30539           nclopt = NsfRequireClassOpt((NsfClass *) nObject);
30540           CmdListAddSorted(&nclopt->isObjectMixinOf, object->id, NULL);
30541         } else {
30542           NsfLog(interp, NSF_LOG_WARN,
30543                  "Problem registering %s as a object mixin of %s\n",
30544                  ObjStr(valueObj), ObjectName_(object));
30545         }
30546       }
30547 
30548       MixinComputeDefined(interp, object);
30549       FilterComputeDefined(interp, object);
30550     }
30551     break;
30552 
30553   case RelationtypeObject_filterIdx:
30554     {
30555       NsfCmdList *newFilterCmdList = NULL;
30556 
30557       for (i = 0; i < oc; i ++) {
30558         if (unlikely(FilterAdd(interp, &newFilterCmdList, ov[i], object, NULL) != TCL_OK)) {
30559           CmdListFree(&newFilterCmdList, GuardDel);
30560           return TCL_ERROR;
30561         }
30562       }
30563 
30564       if (objopt->objFilters != NULL) {
30565         CmdListFree(&objopt->objFilters, GuardDel);
30566       }
30567 
30568       object->flags &= ~NSF_FILTER_ORDER_VALID;
30569       objopt->objFilters = newFilterCmdList;
30570 
30571       /*FilterComputeDefined(interp, object);*/
30572     }
30573     break;
30574 
30575   case RelationtypeClass_mixinIdx:
30576     if (unlikely(NsfRelationClassMixinsSet(interp, class, valueObj, oc, ov) != TCL_OK)) {
30577       return TCL_ERROR;
30578     }
30579     break;
30580 
30581   case RelationtypeClass_filterIdx:
30582     {
30583       NsfCmdList *newFilterCmdList = NULL;
30584 
30585       for (i = 0; i < oc; i ++) {
30586         if (unlikely(FilterAdd(interp, &newFilterCmdList, ov[i], NULL, class) != TCL_OK)) {
30587           CmdListFree(&newFilterCmdList, GuardDel);
30588           return TCL_ERROR;
30589         }
30590       }
30591 
30592       if (clopt->classFilters != NULL) {
30593         CmdListFree(&clopt->classFilters, GuardDel);
30594       }
30595 
30596       if (FiltersDefined(interp) > 0) {
30597         NsfClasses *subClasses = DependentSubClasses(class);
30598         if (subClasses != NULL) {
30599           FilterInvalidateObjOrders(interp, subClasses);
30600           NsfClassListFree(subClasses);
30601         }
30602       }
30603 
30604       clopt->classFilters = newFilterCmdList;
30605 
30606     }
30607     break;
30608 
30609   case RelationtypeClassIdx:      /* fall through */
30610   case RelationtypeRootclassIdx:  /* fall through */
30611   case RelationtypeSuperclassIdx: /* fall through */
30612   case RelationtypeNULL:
30613     /* handled above */
30614     break;
30615 
30616   }
30617 
30618   /*
30619    * Return on success the final setting
30620    */
30621   NsfRelationSetCmd(interp, object, type, NULL);
30622   return TCL_OK;
30623 }
30624 
30625 /*
30626 cmd current NsfCurrentCmd {
30627   {-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}
30628 }
30629 */
30630 static int
NsfCurrentCmd(Tcl_Interp * interp,CurrentoptionIdx_t option)30631 NsfCurrentCmd(Tcl_Interp *interp, CurrentoptionIdx_t option) {
30632   NsfObject           *object;
30633   NsfCallStackContent *cscPtr;
30634   Tcl_CallFrame       *framePtr;
30635   int                  result = TCL_OK;
30636 
30637   nonnull_assert(interp != NULL);
30638 
30639   object = GetSelfObj(interp);
30640 
30641   /*
30642    * The first two clauses can succeed even it we are outside an NSF context
30643    * (no object known). The commands are "nsf::current", "nsf::current
30644    * object", "nsf::current level", and "nsf::current activelevel"
30645    */
30646   if (option == CurrentoptionNULL || option == CurrentoptionObjectIdx) {
30647     if (likely(object != NULL)) {
30648       Tcl_SetObjResult(interp, object->cmdName);
30649     } else {
30650       result = NsfNoCurrentObjectError(interp, NULL);
30651     }
30652     return result;
30653   }
30654 
30655   if (unlikely(object == NULL)) {
30656     if (option == CurrentoptionCallinglevelIdx) {
30657       Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
30658     } else if (option == CurrentoptionLevelIdx) {
30659       /*
30660        * Return empty, if we are not on an NSF level.
30661        */
30662       Tcl_ResetResult(interp);
30663     } else {
30664       result = NsfNoCurrentObjectError(interp, NULL);
30665     }
30666     return result;
30667   }
30668 
30669   /*
30670    * From here on, we have to be on a valid nsf frame/level, object has to be
30671    * know.
30672    */
30673   assert(object != NULL);
30674 
30675   switch (option) {
30676   case CurrentoptionMethodIdx: /* fall through */
30677   case CurrentoptionProcIdx:
30678     cscPtr = CallStackGetTopFrame0(interp);
30679     if (cscPtr != NULL) {
30680       const char *procName = Tcl_GetCommandName(interp, cscPtr->cmdPtr);
30681       Tcl_SetObjResult(interp, Tcl_NewStringObj(procName, -1));
30682     } else {
30683       /* TODO: Is this, practically, reachable? */
30684       return NsfPrintError(interp,  "can't find method");
30685     }
30686     break;
30687 
30688   case CurrentoptionMethodpathIdx:
30689     cscPtr = CallStackGetTopFrame0(interp);
30690     if (cscPtr != NULL) {
30691       Tcl_SetObjResult(interp, NsfMethodNamePath(interp,
30692                                                  CallStackGetTclFrame(interp, NULL, 1),
30693                                                  Tcl_GetCommandName(interp, cscPtr->cmdPtr)));
30694     } else {
30695       /* TODO: Is this, practically, reachable? */
30696       return NsfPrintError(interp,  "can't find method");
30697     }
30698     break;
30699 
30700   case CurrentoptionClassIdx: /* class subcommand */
30701     cscPtr = CallStackGetTopFrame0(interp);
30702     Tcl_SetObjResult(interp, (cscPtr != NULL && cscPtr->cl) ?
30703                      cscPtr->cl->object.cmdName : NsfGlobalObjs[NSF_EMPTY]);
30704     break;
30705 
30706   case CurrentoptionActivelevelIdx:
30707     Tcl_SetObjResult(interp, ComputeLevelObj(interp, ACTIVE_LEVEL));
30708     break;
30709 
30710   case CurrentoptionArgsIdx: {
30711     cscPtr = CallStackGetTopFrame(interp, &framePtr);
30712 
30713     if (cscPtr != NULL) {
30714       int nobjc;
30715       Tcl_Obj **nobjv;
30716 
30717       if (cscPtr->objv != NULL) {
30718         nobjc = cscPtr->objc;
30719         nobjv = (Tcl_Obj **)cscPtr->objv;
30720       } else {
30721         nobjc = Tcl_CallFrame_objc(framePtr);
30722         nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(framePtr);
30723       }
30724       Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1));
30725     } else {
30726       return NsfPrintError(interp,  "can't find proc");
30727     }
30728     break;
30729   }
30730 
30731   case CurrentoptionActivemixinIdx: {
30732     NsfObject *cmdObject = NULL;
30733 
30734     if (RUNTIME_STATE(interp)->currentMixinCmdPtr) {
30735       cmdObject = NsfGetObjectFromCmdPtr(RUNTIME_STATE(interp)->currentMixinCmdPtr);
30736     }
30737     Tcl_SetObjResult(interp, (cmdObject != NULL) ? cmdObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
30738     break;
30739   }
30740 
30741   case CurrentoptionCalledprocIdx:
30742   case CurrentoptionCalledmethodIdx:
30743     cscPtr = CallStackFindActiveFilter(interp);
30744     if (cscPtr != NULL) {
30745       Tcl_SetObjResult(interp,
30746                        Tcl_NewStringObj(MethodName(cscPtr->filterStackEntry->calledProc), -1));
30747     } else {
30748       result = NsfPrintError(interp, "called from outside of a filter");
30749     }
30750     break;
30751 
30752   case CurrentoptionCalledclassIdx: {
30753     const NsfClass *class = FindCalledClass(interp, object);
30754     Tcl_SetObjResult(interp, (class != NULL) ? class->object.cmdName : NsfGlobalObjs[NSF_EMPTY]);
30755     break;
30756   }
30757   case CurrentoptionCallingmethodIdx:
30758   case CurrentoptionCallingprocIdx: {
30759     Tcl_Obj *resultObj;
30760 
30761     cscPtr = NsfCallStackFindLastInvocation(interp, 1, &framePtr);
30762     if ((cscPtr != NULL) && (cscPtr->cmdPtr != NULL)) {
30763       resultObj = NsfMethodNamePath(interp,
30764                                     CallStackGetTclFrame(interp, framePtr, 1),
30765                                     Tcl_GetCommandName(interp, cscPtr->cmdPtr));
30766     } else {
30767       resultObj = NsfGlobalObjs[NSF_EMPTY];
30768     }
30769     Tcl_SetObjResult(interp, resultObj);
30770     break;
30771   }
30772   case CurrentoptionCallingclassIdx:
30773     cscPtr = NsfCallStackFindLastInvocation(interp, 1, NULL);
30774     Tcl_SetObjResult(interp, (cscPtr != NULL && cscPtr->cl != NULL)
30775                      ? cscPtr->cl->object.cmdName
30776                      : NsfGlobalObjs[NSF_EMPTY]);
30777     break;
30778 
30779   case CurrentoptionCallinglevelIdx:
30780     /*
30781      * Special case of object==NULL handled above.
30782      */
30783     Tcl_SetObjResult(interp, ComputeLevelObj(interp, CALLING_LEVEL));
30784     break;
30785 
30786   case CurrentoptionCallingobjectIdx:
30787     cscPtr = NsfCallStackFindLastInvocation(interp, 1, NULL);
30788     Tcl_SetObjResult(interp, (cscPtr != NULL) ? cscPtr->self->cmdName : NsfGlobalObjs[NSF_EMPTY]);
30789     break;
30790 
30791   case CurrentoptionFilterregIdx:
30792     cscPtr = CallStackFindActiveFilter(interp);
30793     if (cscPtr != NULL) {
30794       Tcl_SetObjResult(interp, FilterFindReg(interp, object, cscPtr->cmdPtr));
30795     } else {
30796       result = NsfPrintError(interp, "called from outside of a filter");
30797     }
30798     break;
30799 
30800   case CurrentoptionIsnextcallIdx: {
30801 
30802     cscPtr = CallStackGetTopFrame(interp, &framePtr);
30803 
30804     if ((cscPtr->frameType & NSF_CSC_TYPE_ENSEMBLE) != 0u) {
30805       (void)CallStackFindEnsembleCsc(framePtr, &framePtr);
30806     }
30807 
30808     framePtr = CallStackNextFrameOfType(Tcl_CallFrame_callerPtr(framePtr),
30809                                         FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD);
30810     cscPtr = (framePtr != NULL) ? Tcl_CallFrame_clientData(framePtr) : NULL;
30811 
30812     Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
30813                       (cscPtr != NULL && ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u)));
30814     break;
30815   }
30816 
30817   case CurrentoptionLevelIdx:
30818     /*
30819      * We have an "object", therefore we are on an NSF-frame/level. In this
30820      * case, "nsf level" behaves like "info level" (without arguments).
30821      */
30822     Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_CallFrame_level(Tcl_Interp_varFramePtr(interp))));
30823     break;
30824 
30825   case CurrentoptionNextmethodIdx: {
30826     Tcl_Obj *methodHandle;
30827 
30828     cscPtr = CallStackGetTopFrame(interp, &framePtr);
30829     assert(cscPtr != NULL);
30830 
30831     methodHandle = FindNextMethod(interp, framePtr);
30832     if (methodHandle == NULL) {
30833       Tcl_ResetResult(interp);
30834     } else {
30835       Tcl_SetObjResult(interp, methodHandle);
30836     }
30837 
30838     break;
30839   }
30840 
30841   case CurrentoptionObjectIdx: /* fall through */
30842   case CurrentoptionNULL:
30843     /* handled above */
30844     break;
30845   }
30846 
30847   return result;
30848 }
30849 
30850 /*
30851 cmd self NsfSelfCmd {
30852 }
30853 */
30854 static int
NsfSelfCmd(Tcl_Interp * interp)30855 NsfSelfCmd(Tcl_Interp *interp) {
30856   NsfObject *object;
30857 
30858   nonnull_assert(interp != NULL);
30859 
30860   object = GetSelfObj(interp);
30861   if (likely(object != NULL)) {
30862     Tcl_SetObjResult(interp, object->cmdName);
30863     return TCL_OK;
30864   } else {
30865     return NsfNoCurrentObjectError(interp, NULL);
30866   }
30867 }
30868 
30869 /*
30870 cmd var::exists NsfVarExistsCmd {
30871   {-argName "-array" -required 0 -nrargs 0}
30872   {-argName "object" -required 1 -type object}
30873   {-argName "varName" -required 1}
30874 }
30875 */
30876 static int
NsfVarExistsCmd(Tcl_Interp * interp,int withArray,NsfObject * object,const char * varName)30877 NsfVarExistsCmd(Tcl_Interp *interp, int withArray, NsfObject *object, const char *varName) {
30878   unsigned int flags =
30879     NSF_VAR_TRIGGER_TRACE|NSF_VAR_REQUIRE_DEFINED|
30880     ((withArray != 0) ? NSF_VAR_ISARRAY : 0u);
30881 
30882   nonnull_assert(interp != NULL);
30883   nonnull_assert(object != NULL);
30884   nonnull_assert(varName != NULL);
30885 
30886   if (unlikely(CheckVarName(interp, varName) != TCL_OK)) {
30887     return TCL_ERROR;
30888   }
30889   Tcl_SetIntObj(Tcl_GetObjResult(interp), VarExists(interp, object, varName, NULL, flags));
30890 
30891   return TCL_OK;
30892 }
30893 
30894 /*
30895 cmd var::get NsfVarGetCmd {
30896   {-argName "-array" -required 0 -nrargs 0 -type switch}
30897   {-argName "-notrace" -required 0 -nrargs 0 -type switch}
30898   {-argName "object" -required 1 -type object}
30899   {-argName "varName" -required 1 -type tclobj}
30900 }
30901 */
30902 static int
NsfVarGetCmd(Tcl_Interp * interp,int withArray,int withNotrace,NsfObject * object,Tcl_Obj * varNameObj)30903 NsfVarGetCmd(Tcl_Interp *interp, int withArray, int withNotrace,
30904              NsfObject *object, Tcl_Obj *varNameObj) {
30905 
30906   return NsfVarSetCmd(interp, withArray, withNotrace, object, varNameObj, NULL);
30907 }
30908 
30909 /*
30910 cmd var::import NsfVarImportCmd {
30911   {-argName "object" -type object}
30912   {-argName "args" -type args}
30913 }
30914 */
30915 static int NsfVarImport(Tcl_Interp *interp, NsfObject *object, const char *cmdName,
30916                         int objc, Tcl_Obj *const objv[])
30917   nonnull(1) nonnull(2) nonnull(3) nonnull(5);
30918 
30919 static int
NsfVarImport(Tcl_Interp * interp,NsfObject * object,const char * cmdName,int objc,Tcl_Obj * const objv[])30920 NsfVarImport(Tcl_Interp *interp, NsfObject *object, const char *cmdName,
30921              int objc, Tcl_Obj *const objv[]) {
30922   int i, result = TCL_OK;
30923 
30924   nonnull_assert(interp != NULL);
30925   nonnull_assert(object != NULL);
30926   nonnull_assert(cmdName != NULL);
30927   nonnull_assert(objv != NULL);
30928 
30929   for (i = 0; i < objc && result == TCL_OK; i++) {
30930     Tcl_Obj **ov;
30931     int oc;
30932 
30933     /*fprintf(stderr, "ListGetElements %p %s\n", objv[i], ObjStr(objv[i]));*/
30934     if ((result = Tcl_ListObjGetElements(interp, objv[i], &oc, &ov)) == TCL_OK) {
30935       Tcl_Obj *varName = NULL, *alias = NULL;
30936       switch (oc) {
30937       case 0:
30938         varName = objv[i];
30939         break;
30940       case 1:
30941         varName = ov[0];
30942         break;
30943       case 2:
30944         varName = ov[0];
30945         alias = ov[1];
30946         break;
30947       default:
30948         break;
30949       }
30950       if (likely(varName != NULL)) {
30951         result = ImportInstVarIntoCurrentScope(interp, cmdName, object, varName, alias);
30952       } else {
30953         assert(objv[i] != NULL);
30954         result = NsfPrintError(interp, "invalid variable specification '%s'", ObjStr(objv[i]));
30955       }
30956     }
30957   }
30958 
30959   return result;
30960 }
30961 
30962 static int
NsfVarImportCmd(Tcl_Interp * interp,NsfObject * object,int trailingObjc,Tcl_Obj * const trailingObjv[])30963 NsfVarImportCmd(Tcl_Interp *interp, NsfObject *object, int trailingObjc, Tcl_Obj *const trailingObjv[]) {
30964 
30965   nonnull_assert(interp != NULL);
30966   nonnull_assert(object != NULL);
30967 
30968   return NsfVarImport(interp, object, "importvar", trailingObjc, trailingObjv);
30969 }
30970 
30971 /*
30972 cmd var::set NsfVarSetCmd {
30973   {-argName "-array" -required 0 -nrargs 0 -type switch}
30974   {-argName "-notrace" -required 0 -nrargs 0 -type switch}
30975   {-argName "object" -required 1 -type object}
30976   {-argName "varName" -required 1 -type tclobj}
30977   {-argName "value" -required 0 -type tclobj}
30978 }
30979 */
30980 static int
NsfVarSetCmd(Tcl_Interp * interp,int withArray,int withNotrace,NsfObject * object,Tcl_Obj * varNameObj,Tcl_Obj * valueObj)30981 NsfVarSetCmd(Tcl_Interp *interp, int withArray, int withNotrace,
30982              NsfObject *object, Tcl_Obj *varNameObj, Tcl_Obj *valueObj) {
30983 
30984   nonnull_assert(interp != NULL);
30985   nonnull_assert(object != NULL);
30986   nonnull_assert(varNameObj != NULL);
30987 
30988   if (unlikely(CheckVarName(interp, ObjStr(varNameObj)) != TCL_OK)) {
30989     return TCL_ERROR;
30990   }
30991 
30992   if (withArray != 0) {
30993     return SetInstArray(interp, object, varNameObj, valueObj);
30994   } else {
30995     return SetInstVar(interp, object, varNameObj, valueObj, withNotrace ? 0 : NSF_VAR_TRIGGER_TRACE);
30996   }
30997 }
30998 
30999 /*
31000 cmd var::unset NsfVarUnsetCmd {
31001   {-argName "-nocomplain" -required 0 -nrargs 0}
31002   {-argName "object" -required 1 -type object}
31003   {-argName "varName" -required 1 -type tclobj}
31004 }
31005 */
31006 static int
NsfVarUnsetCmd(Tcl_Interp * interp,int withNocomplain,NsfObject * object,Tcl_Obj * varNameObj)31007 NsfVarUnsetCmd(Tcl_Interp *interp, int withNocomplain, NsfObject *object, Tcl_Obj *varNameObj) {
31008   const char *varName;
31009 
31010   nonnull_assert(interp != NULL);
31011   nonnull_assert(object != NULL);
31012   nonnull_assert(varNameObj != NULL);
31013 
31014   varName = ObjStr(varNameObj);
31015   if (unlikely(CheckVarName(interp, varName) != TCL_OK)) {
31016     return TCL_ERROR;
31017   }
31018 
31019   return UnsetInstVar(interp, withNocomplain, object, varName);
31020 }
31021 /***********************************************************************
31022  * End generated Next Scripting  commands
31023  ***********************************************************************/
31024 
31025 /*
31026  * Parameter support functions
31027  */
31028 
31029 typedef struct NsfParamWrapper {
31030   Nsf_Param *paramPtr;
31031   int refCount;
31032   bool canFree;
31033 } NsfParamWrapper;
31034 
31035 static Tcl_DupInternalRepProc      ParamDupInteralRep;
31036 static Tcl_FreeInternalRepProc     ParamFreeInternalRep;
31037 static Tcl_UpdateStringProc        ParamUpdateString;
31038 
31039 static void ParamUpdateString(Tcl_Obj *objPtr)
31040   nonnull(1);
31041 static void ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *UNUSED(dupPtr))
31042   nonnull(1);
31043 static void ParamFreeInternalRep(register Tcl_Obj *objPtr)
31044   nonnull(1);
31045 static int ParamSetFromAny(Tcl_Interp *interp,        register Tcl_Obj *objPtr)
31046   nonnull(1) nonnull(2);
31047 static int ParamSetFromAny2(Tcl_Interp *interp, const char *varNamePrefix,
31048                             bool allowObjectParameter, register Tcl_Obj *objPtr,
31049                             const char *qualifier)
31050   nonnull(1) nonnull(2) nonnull(4);
31051 
31052 static void
ParamUpdateString(Tcl_Obj * objPtr)31053 ParamUpdateString(Tcl_Obj *objPtr) {
31054   nonnull_assert(objPtr != NULL);
31055   Tcl_Panic("%s of type %s should not be called", "updateStringProc",
31056             objPtr->typePtr->name);
31057 }
31058 
31059 static void
ParamDupInteralRep(Tcl_Obj * srcPtr,Tcl_Obj * UNUSED (dupPtr))31060 ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *UNUSED(dupPtr)) {
31061   nonnull_assert(srcPtr != NULL);
31062   Tcl_Panic("%s of type %s should not be called", "dupStringProc",
31063             srcPtr->typePtr->name);
31064 }
31065 
31066 static Tcl_ObjType paramObjType = {
31067     "nsfParam",                          /* name */
31068     ParamFreeInternalRep,                /* freeIntRepProc */
31069     ParamDupInteralRep,                  /* dupIntRepProc */
31070     ParamUpdateString,                   /* updateStringProc */
31071     ParamSetFromAny                      /* setFromAnyProc */
31072 };
31073 
31074 static void
ParamFreeInternalRep(register Tcl_Obj * objPtr)31075 ParamFreeInternalRep(
31076     register Tcl_Obj *objPtr)   /* Param structure object with internal
31077                                  * representation to free. */
31078 {
31079   NsfParamWrapper *paramWrapperPtr;
31080 
31081   nonnull_assert(objPtr != NULL);
31082 
31083   paramWrapperPtr = (NsfParamWrapper *)objPtr->internalRep.twoPtrValue.ptr1;
31084   if (paramWrapperPtr != NULL) {
31085     /* fprintf(stderr, "ParamFreeInternalRep freeing wrapper %p paramPtr %p refCount %dcanFree %d\n",
31086             paramWrapperPtr, paramWrapperPtr->paramPtr, paramWrapperPtr->refCount,
31087             paramWrapperPtr->canFree);*/
31088 
31089     if (paramWrapperPtr->canFree) {
31090       ParamsFree(paramWrapperPtr->paramPtr);
31091       FREE(NsfParamWrapper, paramWrapperPtr);
31092     } else {
31093       paramWrapperPtr->refCount--;
31094     }
31095   }
31096 }
31097 
31098 /*
31099  *----------------------------------------------------------------------
31100  * ParamSetFromAny2 --
31101  *
31102  *    Convert the second argument (e.g. "x:integer") into the internal
31103  *    representation of a Tcl_Obj of the type parameter. The conversion is
31104  *    performed by the usual ParamDefinitionParse() function, used e.g. for
31105  *    the parameter passing for arguments.
31106  *
31107  * Results:
31108  *    Result code.
31109  *
31110  * Side effects:
31111  *    Converted internal rep of Tcl_Obj
31112  *
31113  *----------------------------------------------------------------------
31114  */
31115 
31116 static int
ParamSetFromAny2(Tcl_Interp * interp,const char * varNamePrefix,bool allowObjectParameter,register Tcl_Obj * objPtr,const char * qualifier)31117 ParamSetFromAny2(
31118     Tcl_Interp *interp,               /* Used for error reporting if not NULL. */
31119     const char *varNamePrefix,        /* shows up as varName in error message */
31120     bool allowObjectParameter,        /* allow object parameters */
31121     register Tcl_Obj *objPtr,         /* The object to convert. */
31122     const char *qualifier)
31123 {
31124   Tcl_Obj         *fullParamObj = Tcl_NewStringObj(varNamePrefix, -1);
31125   int              result, possibleUnknowns = 0, plainParams = 0, nrNonposArgs = 0;
31126   NsfParamWrapper *paramWrapperPtr = NEW(NsfParamWrapper);
31127 
31128   nonnull_assert(interp != NULL);
31129   nonnull_assert(varNamePrefix != NULL);
31130   nonnull_assert(objPtr != NULL);
31131 
31132   paramWrapperPtr->paramPtr = ParamsNew(1u);
31133   paramWrapperPtr->refCount = 1;
31134   paramWrapperPtr->canFree = NSF_FALSE;
31135 
31136   Tcl_AppendLimitedToObj(fullParamObj, ObjStr(objPtr), -1, INT_MAX, NULL);
31137   INCR_REF_COUNT(fullParamObj);
31138 
31139   result = ParamDefinitionParse(interp, NsfGlobalObjs[NSF_VALUECHECK], fullParamObj,
31140                                 (allowObjectParameter ? NSF_DISALLOWED_ARG_OBJECT_PARAMETER : NSF_DISALLOWED_ARG_VALUECHECK),
31141                                 paramWrapperPtr->paramPtr, &possibleUnknowns,
31142                                 &plainParams, &nrNonposArgs, qualifier);
31143   /*
31144    * We treat currently unknown user level converters as error.
31145    */
31146   if (unlikely((paramWrapperPtr->paramPtr->flags & NSF_ARG_CURRENTLY_UNKNOWN) != 0u)) {
31147     result = TCL_ERROR;
31148   }
31149 
31150   if (likely(result == TCL_OK)) {
31151     /*
31152      * In success cases, the memory allocated by this function is freed via
31153      * the Tcl_Obj type.
31154      */
31155     paramWrapperPtr->paramPtr->flags |= NSF_ARG_UNNAMED;
31156     if (*(paramWrapperPtr->paramPtr->name) == 'r') {
31157       paramWrapperPtr->paramPtr->flags |= NSF_ARG_IS_RETURNVALUE;
31158     }
31159     TclFreeIntRep(objPtr);
31160     objPtr->internalRep.twoPtrValue.ptr1 = (void *)paramWrapperPtr;
31161     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
31162     objPtr->typePtr = &paramObjType;
31163   } else {
31164     /*
31165      * In error cases, free manually memory allocated by this function.
31166      */
31167     ParamsFree(paramWrapperPtr->paramPtr);
31168     FREE(NsfParamWrapper, paramWrapperPtr);
31169   }
31170 
31171   DECR_REF_COUNT(fullParamObj);
31172   return result;
31173 }
31174 
31175 static int
ParamSetFromAny(Tcl_Interp * interp,register Tcl_Obj * objPtr)31176 ParamSetFromAny(
31177     Tcl_Interp *interp,               /* Used for error reporting if not NULL. */
31178     register Tcl_Obj *objPtr)         /* The object to convert. */
31179 {
31180   nonnull_assert(interp != NULL);
31181   nonnull_assert(objPtr != NULL);
31182 
31183   return ParamSetFromAny2(interp, "value:", NSF_FALSE, objPtr, NULL);
31184 }
31185 
31186 /*
31187  *----------------------------------------------------------------------
31188  * GetObjectParameterDefinition --
31189  *
31190  *    Obtain the parameter definitions for an object by calling the method
31191  *    "__objectparameter" if the value is not cached already. Either "object"
31192  *    or "class" must be non-null. Caching is performed on the class, the
31193  *    cached values are used in case there are no object-specific slots.
31194  *
31195  * Results:
31196  *    Tcl return code, parsed structure in last argument
31197  *
31198  * Side effects:
31199  *    Updates potentially cl->parsedParamPtr
31200  *
31201  *----------------------------------------------------------------------
31202  */
31203 static int
ComputeParameterDefinition(Tcl_Interp * interp,Tcl_Obj * procNameObj,NsfObject * object,NsfClass * class,NsfParsedParam * parsedParamPtr)31204 ComputeParameterDefinition(
31205     Tcl_Interp *interp, Tcl_Obj *procNameObj,
31206     NsfObject *object, NsfClass *class,
31207     NsfParsedParam *parsedParamPtr
31208 ) {
31209   int        result;
31210   Tcl_Obj   *methodObj;
31211   NsfObject *self;
31212 
31213   if (object != NULL) {
31214     methodObj = NsfMethodObj(object, NSF_o_configureparameter_idx);
31215     self = object;
31216   } else {
31217     assert(class != NULL);
31218     self = &class->object;
31219     methodObj = NsfMethodObj(self, NSF_c_configureparameter_idx);
31220   }
31221 
31222   if (methodObj == NULL) {
31223     result = TCL_OK;
31224   } else {
31225     /*fprintf(stderr, "calling %s %s\n", ObjectName(self), ObjStr(methodObj));*/
31226     result = CallMethod(self, interp, methodObj, 2, NULL,
31227                         NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
31228 
31229     if (likely(result == TCL_OK)) {
31230       Tcl_Obj *rawConfArgs = Tcl_GetObjResult(interp);
31231 
31232       /*      fprintf(stderr, ".... rawConfArgs for %s => '%s'\n",
31233               ObjectName(self), ObjStr(rawConfArgs));*/
31234       INCR_REF_COUNT(rawConfArgs);
31235 
31236       /*
31237        * Parse the string representation to obtain the internal
31238        * representation.
31239        */
31240       result = ParamDefsParse(interp, procNameObj, rawConfArgs,
31241                               NSF_DISALLOWED_ARG_OBJECT_PARAMETER, NSF_TRUE,
31242                               parsedParamPtr, NULL);
31243       if (likely(result == TCL_OK)) {
31244         NsfParsedParam *ppDefPtr = NEW(NsfParsedParam);
31245 
31246         ppDefPtr->paramDefs = parsedParamPtr->paramDefs;
31247         ppDefPtr->possibleUnknowns = parsedParamPtr->possibleUnknowns;
31248         if (class != NULL) {
31249           assert(class->parsedParamPtr == NULL);
31250           class->parsedParamPtr = ppDefPtr;
31251 #if defined(PER_OBJECT_PARAMETER_CACHING)
31252         } else if (object != NULL) {
31253           NsfObjectOpt *opt = NsfRequireObjectOpt(object);
31254 
31255           if (object->opt->parsedParamPtr != NULL) {
31256             NsfParameterCacheObjectInvalidateCmd(interp, object);
31257           }
31258           opt->parsedParamPtr = ppDefPtr;
31259           opt->classParamPtrEpoch = RUNTIME_STATE(interp)->classParamPtrEpoch;
31260           /*fprintf(stderr, "set obj param for obj %p %s epoch %d ppDefPtr %p\n",
31261             object, ObjectName(object), opt->classParamPtrEpoch, ppDefPtr);*/
31262 #endif
31263         }
31264         if (ppDefPtr->paramDefs != NULL) {
31265           ParamDefsRefCountIncr(ppDefPtr->paramDefs);
31266         }
31267       }
31268       DECR_REF_COUNT(rawConfArgs);
31269     }
31270   }
31271   return result;
31272 }
31273 
31274 /*
31275  *----------------------------------------------------------------------
31276  * GetObjectParameterDefinition --
31277  *
31278  *    Obtain the parameter definitions for an object by calling the method
31279  *    "__objectparameter" if the value is not cached already. Caching is
31280  *    performed on the class, the cached values are used in case there are no
31281  *    object-specific slots.
31282  *
31283  * Results:
31284  *    Tcl return code, parsed structure in last argument
31285  *
31286  * Side effects:
31287  *    Updates potentially cl->parsedParamPtr
31288  *
31289  *----------------------------------------------------------------------
31290  */
31291 static int
GetObjectParameterDefinition(Tcl_Interp * interp,Tcl_Obj * procNameObj,NsfObject * object,NsfClass * class,NsfParsedParam * parsedParamPtr)31292 GetObjectParameterDefinition(
31293     Tcl_Interp *interp, Tcl_Obj *procNameObj,
31294     NsfObject *object, NsfClass *class,
31295     NsfParsedParam *parsedParamPtr
31296 ) {
31297   int result = TCL_OK;
31298 
31299   nonnull_assert(interp != NULL);
31300   nonnull_assert(procNameObj != NULL);
31301   nonnull_assert(parsedParamPtr != NULL);
31302 
31303   parsedParamPtr->paramDefs = NULL;
31304   parsedParamPtr->possibleUnknowns = 0;
31305 
31306   if (class == NULL) {
31307     assert(object != NULL);
31308     if ((object->flags & NSF_HAS_PER_OBJECT_SLOTS) != 0u
31309         || (object->opt != NULL && object->opt->objMixins)
31310         ) {
31311       /*
31312        * We have object-specific parameters.  Do not use the per-class cache,
31313        * and do not save the results in the per-class cache.
31314        */
31315       /*fprintf(stderr, "per-object configure obj %s flags %.6x\n",
31316         ObjectName(object), object->flags);*/
31317     } else {
31318       class = object->cl;
31319     }
31320   }
31321 
31322   /*
31323    * Parameter definitions are cached in the class, for which
31324    * instances are created. The parameter definitions are flushed in
31325    * the following situations:
31326    *
31327    * a) on class cleanup: ParsedParamFree(cl->parsedParamPtr)
31328    * b) on class structure changes,
31329    * c) when class-mixins are added,
31330    * d) when new slots are defined,
31331    * e) when slots are removed
31332    *
31333    * When slot defaults or types are changed, the slots have to
31334    * perform a manual "::nsf::invalidateobjectparameter $domain".
31335    */
31336 
31337   /*
31338    * Check whether there is already a parameter definition available for
31339    * creating objects of this class.
31340    */
31341 
31342   if (likely(class != NULL && class->parsedParamPtr != NULL)) {
31343     NsfParsedParam *clParsedParamPtr = class->parsedParamPtr;
31344 
31345     parsedParamPtr->paramDefs = clParsedParamPtr->paramDefs;
31346     parsedParamPtr->possibleUnknowns = clParsedParamPtr->possibleUnknowns;
31347     result = TCL_OK;
31348 
31349 #if defined(PER_OBJECT_PARAMETER_CACHING)
31350   } else if (object != NULL && object->opt != NULL && object->opt->parsedParamPtr != NULL &&
31351              object->opt->classParamPtrEpoch == RUNTIME_STATE(interp)->classParamPtrEpoch) {
31352     NsfParsedParam *objParsedParamPtr = object->opt->parsedParamPtr;
31353 
31354     /*fprintf(stderr, "reuse obj param for obj %p  %s paramPtr %p\n",
31355       (void *)object, ObjectName(object), (void *)objParsedParamPtr);*/
31356     parsedParamPtr->paramDefs = objParsedParamPtr->paramDefs;
31357     parsedParamPtr->possibleUnknowns = objParsedParamPtr->possibleUnknowns;
31358     result = TCL_OK;
31359 #endif
31360 
31361   } else {
31362     /*
31363      * There is no parameter definition available, get a new one in
31364      * the string representation.
31365      */
31366     result = ComputeParameterDefinition(interp, procNameObj,
31367                                         object, class,
31368                                         parsedParamPtr);
31369   }
31370 
31371   return result;
31372 }
31373 
31374 /*
31375  *----------------------------------------------------------------------
31376  * ParameterCheck --
31377  *
31378  *    Check the provided valueObj against the parameter specification provided
31379  *    in the second argument (paramObjPtr), when doCheckArguments is true. This
31380  *    function is used e.g. by nsf::is, where only the right-hand side of a
31381  *    parameter specification (after the colon) is specified. The argument
31382  *    Name (before the colon in a parameter spec) is provided via
31383  *    argNamePrefix. The converted parameter structure is returned optionally
31384  *    via the last argument.
31385  *
31386  * Results:
31387  *    Tcl return code, parsed structure in last argument
31388  *
31389  * Side effects:
31390  *    Converts potentially tcl_obj type of paramObjPtr
31391  *
31392  *----------------------------------------------------------------------
31393  */
31394 
31395 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)31396 ParameterCheck(
31397     Tcl_Interp *interp, Tcl_Obj *paramObjPtr, Tcl_Obj *valueObj,
31398     const char *argNamePrefix, unsigned int doCheckArguments,
31399     bool isNamed, bool doConfigureParameter,
31400     Nsf_Param **paramPtrPtr, const char *qualifier
31401 ) {
31402   Nsf_Param       *paramPtr;
31403   NsfParamWrapper *paramWrapperPtr;
31404   Tcl_Obj         *outObjPtr;
31405   ClientData       checkedData;
31406   int              result;
31407   unsigned int     flags = 0u;
31408 
31409   nonnull_assert(interp != NULL);
31410   nonnull_assert(paramObjPtr != NULL);
31411   nonnull_assert(valueObj != NULL);
31412 
31413   /* fprintf(stderr, "ParameterCheck %s value %p %s\n",
31414      ObjStr(paramObjPtr), valueObj, ObjStr(valueObj)); */
31415 
31416   if (paramObjPtr->typePtr == &paramObjType) {
31417     paramWrapperPtr = (NsfParamWrapper *) paramObjPtr->internalRep.twoPtrValue.ptr1;
31418   } else {
31419     /*
31420      * We could use in principle Tcl_ConvertToType(..., &paramObjType) instead
31421      * of checking the type manually, but we want to pass the argNamePrefix
31422      * explicitly.
31423      */
31424     result = ParamSetFromAny2(interp, argNamePrefix, doConfigureParameter, paramObjPtr, qualifier);
31425     if (likely(result == TCL_OK)) {
31426       paramWrapperPtr = (NsfParamWrapper *) paramObjPtr->internalRep.twoPtrValue.ptr1;
31427     } else {
31428       const char *errMsg = ObjStr(Tcl_GetObjResult(interp));
31429 
31430       Tcl_SetErrorCode(interp, "NSF", "VALUE", "CONSTRAINT", NULL);
31431       if (*errMsg == '\0') {
31432         return NsfPrintError(interp, "invalid value constraints \"%s\"",
31433                              ObjStr(paramObjPtr) );
31434       } else {
31435         return NsfPrintError(interp, "invalid value constraints \"%s\": %s",
31436                              ObjStr(paramObjPtr), errMsg);
31437       }
31438     }
31439   }
31440   paramPtr = paramWrapperPtr->paramPtr;
31441   if (paramPtrPtr != NULL) *paramPtrPtr = paramPtr;
31442 
31443   if (isNamed) {
31444     paramPtr->flags &= ~NSF_ARG_UNNAMED;
31445   }
31446 
31447   RUNTIME_STATE(interp)->doClassConverterOmitUnknown = 1;
31448   outObjPtr = NULL;
31449   result = ArgumentCheck(interp, valueObj, paramPtr, doCheckArguments, &flags, &checkedData, &outObjPtr);
31450   RUNTIME_STATE(interp)->doClassConverterOmitUnknown = 0;
31451 
31452   /*fprintf(stderr, "ParameterCheck paramPtr %p final refCount of wrapper %d can free %d flags %.6x\n",
31453     paramPtr, paramWrapperPtr->refCount,  paramWrapperPtr->canFree, flags);*/
31454 
31455   assert(paramWrapperPtr->refCount > 0);
31456   paramWrapperPtr->canFree = NSF_TRUE;
31457 
31458   if ((flags & NSF_PC_MUST_DECR) != 0u) {
31459     DECR_REF_COUNT2("valueObj", outObjPtr);
31460   }
31461 
31462   return result;
31463 }
31464 
31465 
31466 
31467 /***********************************************************************
31468  * Begin Object Methods
31469  ***********************************************************************/
31470 /*
31471 objectMethod autoname NsfOAutonameMethod {
31472   {-argName "-instance"}
31473   {-argName "-reset"}
31474   {-argName "name" -required 1 -type tclobj}
31475 }
31476 */
31477 static int
NsfOAutonameMethod(Tcl_Interp * interp,NsfObject * object,int withInstance,int withReset,Tcl_Obj * nameObj)31478 NsfOAutonameMethod(
31479     Tcl_Interp *interp, NsfObject *object, int withInstance, int withReset,
31480     Tcl_Obj *nameObj
31481 ) {
31482   Tcl_Obj *autonamedObj;
31483 
31484   nonnull_assert(interp != NULL);
31485   nonnull_assert(object != NULL);
31486   nonnull_assert(nameObj != NULL);
31487 
31488   autonamedObj = AutonameIncr(interp, nameObj, object, withInstance, withReset);
31489   if (autonamedObj != NULL) {
31490     Tcl_SetObjResult(interp, autonamedObj);
31491     DECR_REF_COUNT2("autoname", autonamedObj);
31492     return TCL_OK;
31493   }
31494 
31495   return NsfPrintError(interp, "autoname failed. Probably format string (with %%) was not well-formed");
31496 }
31497 
31498 /*
31499 objectMethod class NsfOClassMethod {
31500   {-argName "class" -required 0 -type tclobj}
31501 }
31502 */
31503 static int
NsfOClassMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * classObj)31504 NsfOClassMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *classObj) {
31505 
31506   nonnull_assert(interp != NULL);
31507   nonnull_assert(object != NULL);
31508 
31509   return NsfRelationSetCmd(interp, object, RelationtypeClassIdx, classObj);
31510 }
31511 
31512 /*
31513 objectMethod cleanup NsfOCleanupMethod {
31514 }
31515 */
31516 static int
NsfOCleanupMethod(Tcl_Interp * interp,NsfObject * object)31517 NsfOCleanupMethod(Tcl_Interp *interp, NsfObject *object) {
31518   NsfClass *class;
31519   Tcl_Obj  *savedNameObj;
31520   bool      softrecreate;
31521 
31522   nonnull_assert(interp != NULL);
31523   nonnull_assert(object != NULL);
31524 
31525 #if defined(OBJDELETION_TRACE)
31526   fprintf(stderr, "+++ NsfOCleanupMethod\n");
31527 #endif
31528   PRINTOBJ("NsfOCleanupMethod", object);
31529 
31530   savedNameObj = object->cmdName;
31531   INCR_REF_COUNT(savedNameObj);
31532 
31533   /*
31534    * Get the class before the object is destroyed.
31535    */
31536   class = NsfObjectToClass(object);
31537   /*
31538    * Save and pass around softrecreate.
31539    */
31540   softrecreate =
31541     ((object->flags & NSF_RECREATE) != 0u
31542      && RUNTIME_STATE(interp)->doSoftrecreate);
31543 
31544   CleanupDestroyObject(interp, object, softrecreate);
31545   CleanupInitObject(interp, object, object->cl, object->nsPtr, softrecreate);
31546 
31547   if (class != NULL) {
31548     CleanupDestroyClass(interp, class, softrecreate, NSF_TRUE);
31549     CleanupInitClass(interp, class, class->nsPtr, softrecreate, NSF_TRUE);
31550   }
31551 
31552   DECR_REF_COUNT(savedNameObj);
31553   return TCL_OK;
31554 }
31555 
31556 /*
31557 objectMethod configure NsfOConfigureMethod {
31558   {-argName "args" -type allargs}
31559 }
31560 */
31561 
31562 static NsfObject* GetSlotObject(Tcl_Interp *interp, Tcl_Obj *slotObj)
31563   nonnull(1) nonnull(2);
31564 
31565 static NsfObject*
GetSlotObject(Tcl_Interp * interp,Tcl_Obj * slotObj)31566 GetSlotObject(Tcl_Interp *interp, Tcl_Obj *slotObj) {
31567   NsfObject *slotObject = NULL;
31568 
31569   nonnull_assert(interp != NULL);
31570   nonnull_assert(slotObj != NULL);
31571 
31572   if (unlikely(GetObjectFromObj(interp, slotObj, &slotObject) != TCL_OK || slotObject == NULL)) {
31573     NsfPrintError(interp, "couldn't resolve slot object %s", ObjStr(slotObj));
31574   }
31575 
31576   return slotObject;
31577 }
31578 
31579 
31580 static int
NsfOConfigureMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[],Tcl_Obj * objv0)31581 NsfOConfigureMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[], Tcl_Obj *objv0) {
31582   int result, i;
31583   NsfParsedParam  parsedParam;
31584   Nsf_Param      *paramPtr;
31585   NsfParamDefs   *paramDefs;
31586   Tcl_Obj        *newValue, *initMethodObj;
31587   const char     *initString;
31588   ParseContext    pc;
31589   CallFrame       frame, *framePtr = &frame, *uplevelVarFramePtr;
31590 
31591   nonnull_assert(interp != NULL);
31592   nonnull_assert(object != NULL);
31593   nonnull_assert(objv != NULL);
31594   nonnull_assert(objv0 != NULL);
31595 
31596 #if 0
31597   fprintf(stderr, "NsfOConfigureMethod %s.%s flags %.6x oc %2d", ObjectName(object), ObjStr(objv0), object->flags, objc);
31598   for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
31599   fprintf(stderr, "\n");
31600 #endif
31601 
31602   /*
31603    * Get the object parameter definition.
31604    */
31605   result = GetObjectParameterDefinition(interp, objv0, object, NULL, &parsedParam);
31606 
31607   if (result != TCL_OK || parsedParam.paramDefs == NULL) {
31608     /*fprintf(stderr, "... nothing to do for method %s\n", ObjStr(objv0));*/
31609     return result;
31610   }
31611 
31612   /*
31613    * Get the initMethodObj/initString outside the loop iterating over the
31614    * arguments.
31615    */
31616   if (CallDirectly(interp, object, NSF_o_init_idx, &initMethodObj)) {
31617     initString = NULL;
31618   } else {
31619     initString = ObjStr(initMethodObj);
31620   }
31621 
31622   /*
31623    * The effective call site of the configure() method (e.g., a proc or a
31624    * method) can result from up-leveling the object creation procedure;
31625    * therefore, the *effective* call site can deviate from the *declaring*
31626    * call site (e.g. as in XOTcl2's unknown method). In such a scenario, the
31627    * configure() dispatch finds itself in a particular call-stack
31628    * configuration: The top-most frame reflects the declaring call site
31629    * (interp->framePtr), while the effective call site (interp->varFramePtr)
31630    * is identified by a lower call-stack level.
31631    *
31632    * Since configure pushes an object frame (for accessing the instance
31633    * variables) and sometimes a CMETHOD frame (for method invocations) we
31634    * record a) whether there was a preceding uplevel (identifiable through
31635    * deviating interp->framePtr and interp->varFramePtr) and, in case, b) the
31636    * ruling variable frame context. The preserved call-frame reference can
31637    * later be used to restore the uplevel'ed call frame context.
31638    */
31639 
31640   uplevelVarFramePtr =
31641     (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp) != Tcl_Interp_framePtr(interp)
31642     ? Tcl_Interp_varFramePtr(interp)
31643     : NULL;
31644 
31645   /*
31646    * Push frame to allow for [self] and make instance variables of the object
31647    * accessible as locals.
31648    */
31649   Nsf_PushFrameObj(interp, object, framePtr);
31650 
31651   /*
31652    * Process the actual arguments based on the parameter definitions.
31653    */
31654   paramDefs = parsedParam.paramDefs;
31655   ParamDefsRefCountIncr(paramDefs);
31656 
31657 #if 0
31658   if (parsedParam.paramDefs != NULL) {
31659     Tcl_Obj *listObj = ParamDefsList(interp, paramDefs->paramsPtr, NULL, NULL);
31660     fprintf(stderr, "... got params <%s>\n", ObjStr(listObj));
31661   }
31662 #endif
31663 
31664   result = ProcessMethodArguments(&pc, interp, object,
31665                                   NSF_ARGPARSE_START_ZERO, paramDefs,
31666                                   NsfGlobalObjs[NSF_CONFIGURE], objc, objv);
31667 
31668   if (unlikely(result != TCL_OK)) {
31669     Nsf_PopFrameObj(interp, framePtr);
31670     goto configure_exit;
31671   }
31672 
31673   /*
31674    * At this point, the arguments are tested to be valid (according to the
31675    * parameter definitions) and the defaults are set. Now we have to apply the
31676    * arguments (mostly setting instance variables).
31677    */
31678 
31679 #if defined(CONFIGURE_ARGS_TRACE)
31680   fprintf(stderr, "*** POPULATE OBJ '%s': nr of parsed args %d\n", ObjectName(object), pc.objc);
31681 #endif
31682   for (i = 1, paramPtr = paramDefs->paramsPtr;
31683        paramPtr->name != NULL;
31684        paramPtr++, i++) {
31685 
31686     /*
31687      * Set the new value always when the new value was specified (was not
31688      * taken from the default). When we take the default, we do not overwrite
31689      * already existing values (which might have been set via parameter
31690      * alias).
31691      */
31692     /*fprintf(stderr, "[%d] param %s, object init called %d is default %d value = '%s' nrArgs %d\n",
31693             i, paramPtr->name, (object->flags & NSF_INIT_CALLED),
31694             (pc.flags[i-1] & NSF_PC_IS_DEFAULT),
31695             ObjStr(pc.full_objv[i]), paramPtr->nrArgs);*/
31696 
31697     if ((pc.flags[i-1] & NSF_PC_IS_DEFAULT)) {
31698       /*
31699        * Object parameter method calls (when the flag
31700        * NSF_ARG_METHOD_INVOCATION is set) do not set instance variables, so
31701        * we do not have to check for existing variables.
31702        */
31703       if ((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) == 0u) {
31704         Tcl_Obj *varObj = Tcl_ObjGetVar2(interp, paramPtr->nameObj, NULL, 0);
31705 
31706         if (varObj != NULL) {
31707           /*
31708            * The value exists already, ignore this parameter.
31709            */
31710           /*fprintf(stderr, "a variable for %s exists already, "
31711                   "ignore param flags %.6x valueObj %p\n",
31712                   paramPtr->name, paramPtr->flags, pc.full_objv[i]);*/
31713           continue;
31714         }
31715       } else if ((object->flags & NSF_INIT_CALLED) != 0u) {
31716         /*
31717          * The object is already initialized. Don't use the default, since it
31718          * might change part of the state back to the original default.  This
31719          * might happen, when e.g. configure is called on a class manually,
31720          * where "superclass" has a default.
31721          */
31722         /*fprintf(stderr, "%s skip default %s in configure\n",
31723           ObjectName(object), ObjStr(pc.full_objv[i]));*/
31724         continue;
31725       }
31726     } else if (unlikely((paramPtr->flags & NSF_ARG_REQUIRED) != 0u
31727                         && pc.full_objv[i] == NsfGlobalObjs[NSF___UNKNOWN__])) {
31728 
31729       /* Previous versions contained a test for
31730        *   (object->flags & NSF_INIT_CALLED)
31731        *
31732        * to perform required testing just for in the non-initialized state. We
31733        * switched in 2.0b5 to checking for the existence of the associated
31734        * instance variable, which works under the assumption that the instance
31735        * variable has the same name and that e.g. a required alias parameter
31736        * sets this variable either. Similar assumption is in the default
31737        * handling. Future versions might use a more general handling of the
31738        * parameter states.
31739        */
31740 
31741       Tcl_Obj *varObj = Tcl_ObjGetVar2(interp, paramPtr->nameObj, NULL, 0);
31742       if (unlikely(varObj == NULL)) {
31743         Tcl_Obj *paramDefsObj = NsfParamDefsSyntax(interp, paramDefs->paramsPtr, object, NULL);
31744 
31745         NsfPrintError(interp, "required argument '%s' is missing, should be:\n\t%s%s%s %s", (paramPtr->nameObj != NULL) ? ObjStr(paramPtr->nameObj) : paramPtr->name, (pc.object != NULL) ? ObjectName(pc.object) : "", (pc.object != NULL) ? " " : "",
31746                       ObjStr(pc.full_objv[0]),
31747                       ObjStr(paramDefsObj));
31748         DECR_REF_COUNT2("paramDefsObj", paramDefsObj);
31749 
31750         Nsf_PopFrameObj(interp, framePtr);
31751         result = TCL_ERROR;
31752         goto configure_exit;
31753       }
31754     }
31755 
31756     newValue = pc.full_objv[i];
31757     /*fprintf(stderr, "     new Value of %s = [%d] %p '%s', type %s addr %p\n",
31758             ObjStr(paramPtr->nameObj), i,
31759             newValue, (newValue != NULL) ? ObjStr(newValue) : "(null)", paramPtr->type,
31760             &(pc.full_objv[i]));*/
31761 
31762     /*
31763      * Handling slot initialize
31764      */
31765     if ((paramPtr->flags & NSF_ARG_SLOTINITIALIZE) != 0u) {
31766       NsfObject *slotObject = GetSlotObject(interp, paramPtr->slotObj);
31767 
31768       if (likely(slotObject != NULL)) {
31769         Tcl_Obj *ov[1];
31770 
31771         ov[0] = paramPtr->nameObj;
31772         result = NsfCallMethodWithArgs(interp, (Nsf_Object *)slotObject, NsfGlobalObjs[NSF_INITIALIZE],
31773                                        object->cmdName, 2, ov,
31774                                        NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
31775 
31776       }
31777       if (unlikely(result != TCL_OK)) {
31778         /*
31779          * The error message was set either by GetSlotObject or by ...CallMethod...
31780          */
31781         Nsf_PopFrameObj(interp, framePtr);
31782         goto configure_exit;
31783       }
31784     }
31785 
31786     /*
31787      * Special setter methods for invoking methods calls; handles types
31788      * "cmd", "initcmd", "alias" and "forward".
31789      */
31790     if ((paramPtr->flags & NSF_ARG_METHOD_INVOCATION) != 0u) {
31791       int consuming = (*paramPtr->name == '-' || paramPtr->nrArgs > 0);
31792 
31793       if (consuming && newValue == NsfGlobalObjs[NSF___UNKNOWN__]) {
31794         /*
31795          * In the case we have a consuming parameter, but we have no value
31796          * provided and not default, there is no reason to call the invocation
31797          * parameter.
31798          */
31799         /*fprintf(stderr, "%s consuming nrargs %d no value\n", paramPtr->name, paramPtr->nrArgs);*/
31800         continue;
31801       }
31802 
31803       if ((paramPtr->flags & NSF_ARG_INITCMD) != 0u) {
31804 
31805         if (paramPtr->defaultValue != NULL) {
31806           /*
31807            * The "defaultValue" holds the initcmd to be executed
31808            */
31809           Tcl_Obj *varObj = Tcl_ObjGetVar2(interp, NsfGlobalObjs[NSF_ARRAY_INITCMD],
31810                                            paramPtr->nameObj, 0);
31811           if (varObj == NULL) {
31812             /*
31813              * The variable is not set. Therefore, we assume, we have to
31814              * execute the initcmd. On success, we note the execution in the NSF_ARRAY_INITCMD
31815              * variable (usually __initcmd(name))
31816              */
31817             result = ParameterMethodDispatch(interp, object, paramPtr, paramPtr->defaultValue,
31818                                              uplevelVarFramePtr, initString,
31819                                              (Tcl_Obj **)&objv[pc.lastObjc],
31820                                              objc - pc.lastObjc);
31821 
31822             if (unlikely(result != TCL_OK)) {
31823               Nsf_PopFrameObj(interp, framePtr);
31824               goto configure_exit;
31825             }
31826             if (unlikely(Tcl_ObjSetVar2(interp, NsfGlobalObjs[NSF_ARRAY_INITCMD],
31827                                         paramPtr->nameObj, Tcl_NewIntObj(1), TCL_LEAVE_ERR_MSG) == NULL)) {
31828               Nsf_PopFrameObj(interp, framePtr);
31829               goto configure_exit;
31830             }
31831           }
31832 
31833         } else {
31834           /*
31835            * We could consider to require a default.
31836            */
31837         }
31838         /*
31839          * If we have a new actual value, proceed to setvars.
31840          */
31841         if ((pc.flags[i-1] & NSF_PC_IS_DEFAULT) == 0) {
31842           goto setvars;
31843         }
31844         continue;
31845       }
31846       /*
31847        * lastObjc points to the first "unprocessed" argument, the argument before should be valid, when lastObjc > 1
31848        */
31849       if (pc.lastObjc > 1) {
31850         assert(ISOBJ(objv[pc.lastObjc-1]));
31851       }
31852       result = ParameterMethodDispatch(interp, object, paramPtr, newValue,
31853                                        uplevelVarFramePtr, initString,
31854                                        (Tcl_Obj **)&objv[pc.lastObjc],
31855                                        objc - pc.lastObjc);
31856       if (unlikely(result != TCL_OK)) {
31857         Nsf_PopFrameObj(interp, framePtr);
31858         goto configure_exit;
31859       }
31860       continue;
31861     }
31862 
31863   setvars:
31864     if (newValue == NsfGlobalObjs[NSF___UNKNOWN__]) {
31865       /*
31866        * Nothing to do, we have a value setter, but no value is specified and
31867        * no default was provided.
31868        */
31869       continue;
31870     }
31871 
31872     /*
31873      * Set the instance variable unless the last argument of the
31874      * definition is varArgs.
31875      */
31876     if (i < paramDefs->nrParams || (!pc.varArgs)) {
31877 
31878 #if defined(CONFIGURE_ARGS_TRACE)
31879       fprintf(stderr, "*** %s SET %s '%s' // %p\n",
31880               ObjectName(object), ObjStr(paramPtr->nameObj), ObjStr(newValue), paramPtr->slotObj);
31881 #endif
31882       /*
31883        * Actually, set instance variable with the provided value or default
31884        * value. In case, explicit invocation of the setter is needed, we call the method, which
31885        * is typically a forwarder to the slot object.
31886        */
31887 
31888       if ((paramPtr->flags & NSF_ARG_SLOTSET) != 0u) {
31889         NsfObject *slotObject = GetSlotObject(interp, paramPtr->slotObj);
31890 
31891         if (likely(slotObject != NULL)) {
31892           Tcl_Obj *ov[2];
31893           Tcl_Obj *methodObj = NsfMethodObj(object, NSF_s_set_idx);
31894 
31895           ov[0] = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
31896           ov[1] = newValue;
31897 
31898           /*fprintf(stderr, "SLOTSET %s %s %s %s %s idx %d %p\n", ObjectName(slotObject),
31899                   ObjStr(NsfGlobalObjs[NSF_SET]), ObjStr(object->cmdName),
31900                   ObjStr(paramPtr->nameObj), ObjStr(newValue),
31901                   NSF_s_set_idx, methodObj);*/
31902 
31903           result = NsfCallMethodWithArgs(interp, (Nsf_Object *)slotObject,
31904                                          (methodObj != NULL) ? methodObj : NsfGlobalObjs[NSF_SLOT_SET],
31905                                          object->cmdName, 3, ov, NSF_CSC_IMMEDIATE);
31906         }
31907         if (unlikely(result != TCL_OK)) {
31908           /*
31909            * The error message was set either by GetSlotObject or by ...CallMethod...
31910            */
31911           Nsf_PopFrameObj(interp, framePtr);
31912           goto configure_exit;
31913         }
31914       } else {
31915         Tcl_Obj *resultObj;
31916         /*
31917          * Plain set of the variable.
31918          */
31919         resultObj = Tcl_ObjSetVar2(interp, paramPtr->nameObj, NULL, newValue, TCL_LEAVE_ERR_MSG);
31920         if (unlikely(resultObj == NULL)) {
31921           /*
31922            * When the setting of the variable failed (e.g. caused by variable
31923            * traces), report the error back.
31924            */
31925           result = TCL_ERROR;
31926           Nsf_PopFrameObj(interp, framePtr);
31927           goto configure_exit;
31928         }
31929       }
31930     }
31931   }
31932 
31933   Nsf_PopFrameObj(interp, framePtr);
31934 
31935  configure_exit:
31936 
31937   ParamDefsRefCountDecr(paramDefs);
31938   ParseContextRelease(&pc);
31939 
31940   if (likely(result == TCL_OK)) {
31941     Tcl_ResetResult(interp);
31942   }
31943   return result;
31944 }
31945 
31946 /*
31947 objectMethod cget NsfOCgetMethod {
31948   {-argName "name" -type tclobj -required 1}
31949 }
31950 */
31951 static int
NsfOCgetMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * nameObj)31952 NsfOCgetMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj) {
31953   int              result;
31954   NsfParsedParam   parsedParam;
31955   const Nsf_Param *paramPtr = NULL;
31956   CallFrame        frame, *framePtr = &frame, *uplevelVarFramePtr;
31957 
31958   nonnull_assert(interp != NULL);
31959   nonnull_assert(object != NULL);
31960   nonnull_assert(nameObj != NULL);
31961 
31962   /*
31963    * Get the object parameter definition
31964    */
31965 
31966   result = GetObjectParameterDefinition(interp, NsfGlobalObjs[NSF_EMPTY],
31967                                         object, NULL, &parsedParam);
31968   if (unlikely(result != TCL_OK)) {
31969     return result;
31970   }
31971 
31972   /*
31973    * GetObjectParameterDefinition() was returning TCL_OK, the paramdefs have
31974    * to be set.
31975    */
31976   assert(parsedParam.paramDefs != NULL);
31977 
31978   /*
31979    * We do not stack a plain stack from NSF_CSC_TYPE_PLAIN here, as we do in
31980    * NsfOConfigureMethod (but maybe we have to for full compatibility TODO:
31981    * check and compare with configure stack setup). Therefore, we pass NULL as
31982    * cscPtr to ParameterMethodForwardDispatch).
31983    */
31984 
31985   /*
31986    * The uplevel handling is exactly the same as in NsfOConfigureMethod() and
31987    * is needed, when methods are called, which perform an upvar.
31988    */
31989   uplevelVarFramePtr =
31990     (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp) != Tcl_Interp_framePtr(interp)
31991     ? Tcl_Interp_varFramePtr(interp)
31992     : NULL;
31993 
31994   /*
31995    * Push frame to allow invocations of [self] and make instance variables of
31996    * the object accessible as locals.
31997    */
31998   Nsf_PushFrameObj(interp, object, framePtr);
31999   ParamDefsRefCountIncr(parsedParam.paramDefs);
32000 
32001   result = CGetParamLookup(interp, nameObj, parsedParam.paramDefs, &paramPtr);
32002   if (result != TCL_OK) {
32003     /*
32004      * Error message is already set by CGetParamLookup()
32005      */
32006   } else if (paramPtr == NULL) {
32007     result = NsfPrintError(interp, "cget: unknown configure parameter %s", ObjStr(nameObj));
32008 
32009   } else {
32010 
32011     /*
32012      * Check for slot invocation.
32013      */
32014     if (paramPtr->slotObj != NULL) {
32015       NsfObject *slotObject = GetSlotObject(interp, paramPtr->slotObj);
32016       Tcl_Obj   *methodObj = NsfMethodObj(object, NSF_s_get_idx);
32017       Tcl_Obj   *ov[1];
32018 
32019       /*
32020        * Get instance variable via slot.
32021        */
32022       if (uplevelVarFramePtr != NULL) {
32023         Tcl_Interp_varFramePtr(interp) = uplevelVarFramePtr;
32024       }
32025       ov[0] = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
32026 
32027       /*fprintf(stderr, "SLOTGET %s idx %d %p method %s\n", ObjectName(slotObject),
32028         NSF_s_get_idx, (void *)methodObj, ObjStr(ov[0]));*/
32029 
32030       result = NsfCallMethodWithArgs(interp, (Nsf_Object *)slotObject,
32031                                      (methodObj != NULL) ? methodObj : NsfGlobalObjs[NSF_SLOT_GET],
32032                                      object->cmdName, 2, ov, NSF_CSC_IMMEDIATE);
32033     } else {
32034       /*
32035        * We do NOT have a slot
32036        */
32037       if ((paramPtr->flags & NSF_ARG_METHOD_CALL) != 0u) {
32038         if ((paramPtr->flags & NSF_ARG_ALIAS) != 0u) {
32039           /*
32040            * It is a parameter associated with an aliased method. Invoke the
32041            * method without an argument.
32042            */
32043           Tcl_Obj *methodObj = (paramPtr->method != NULL) ? paramPtr->method : paramPtr->nameObj;
32044 
32045           if (uplevelVarFramePtr != NULL) {
32046             Tcl_Interp_varFramePtr(interp) = uplevelVarFramePtr;
32047           }
32048 
32049           result = CallMethod(object, interp, methodObj, 2, NULL, NSF_CSC_IMMEDIATE);
32050         } else {
32051           /*
32052            * Must be NSF_ARG_FORWARD
32053            */
32054           assert((paramPtr->flags & NSF_ARG_FORWARD) != 0u);
32055 
32056           /*
32057            * Since we have no cscPtr, we provide NULL.
32058            */
32059           result = ParameterMethodForwardDispatch(interp, object,
32060                                                   paramPtr, NULL, NULL /* cscPtr */);
32061         }
32062       } else {
32063       /*
32064        * Must be a parameter associated with a variable.
32065        */
32066         unsigned int flags = (object->nsPtr != NULL) ? (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY) : TCL_LEAVE_ERR_MSG;
32067         Tcl_Obj     *resultObj = Tcl_ObjGetVar2(interp, paramPtr->nameObj, NULL, (int)flags);
32068 
32069         if (resultObj != NULL) {
32070           /*
32071            * The value exists.
32072            */
32073           Tcl_SetObjResult(interp, resultObj);
32074         }
32075       }
32076     }
32077   }
32078 
32079   Nsf_PopFrameObj(interp, framePtr);
32080   ParamDefsRefCountDecr(parsedParam.paramDefs);
32081 
32082   return result;
32083 }
32084 
32085 /*
32086 objectMethod destroy NsfODestroyMethod {
32087 }
32088 */
32089 static int
NsfODestroyMethod(Tcl_Interp * interp,NsfObject * object)32090 NsfODestroyMethod(Tcl_Interp *interp, NsfObject *object) {
32091   PRINTOBJ("NsfODestroyMethod", object);
32092 
32093   nonnull_assert(interp != NULL);
32094   nonnull_assert(object != NULL);
32095 
32096   /*
32097    * Provide protection against destroy on base classes.
32098    */
32099   if (unlikely(IsBaseClass(object))) {
32100     if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_ON_SOFT_DESTROY) {
32101       return NsfPrintError(interp, "cannot destroy base class %s", ObjectName_(object));
32102     }
32103   }
32104 
32105   /*fprintf(stderr, "NsfODestroyMethod %p %s flags %.6x activation %d cmd %p cmd->flags %.6x\n",
32106           object, ((Command *)object->id)->flags == 0 ? ObjectName(object) : "(deleted)",
32107           object->flags, object->activationCount, object->id, ((Command *)object->id)->flags);*/
32108 
32109   /*
32110    * NSF_DESTROY_CALLED might be set already be DispatchDestroyMethod(),
32111    * the implicit destroy calls. It is necessary to set it here for
32112    * the explicit destroy calls in the script, which reach the
32113    * Object->destroy.
32114    */
32115 
32116   if ((object->flags & NSF_DESTROY_CALLED) == 0u) {
32117     object->flags |= NSF_DESTROY_CALLED;
32118     /*fprintf(stderr, "NsfODestroyMethod %p sets DESTROY_CALLED %.6x\n", object, object->flags);*/
32119   }
32120   object->flags |= NSF_DESTROY_CALLED_SUCCESS;
32121 
32122   if (likely((object->flags & NSF_DURING_DELETE) == 0u)) {
32123     int result;
32124     Tcl_Obj *methodObj;
32125 
32126     /*fprintf(stderr, "   call dealloc on %p %s\n", object,
32127       ((Command *)object->id)->flags == 0u ? ObjectName(object) : "(deleted)");*/
32128 
32129     if (CallDirectly(interp, &object->cl->object, NSF_c_dealloc_idx, &methodObj)) {
32130       NSF_PROFILE_TIME_DATA;
32131       NSF_PROFILE_CALL(interp, &object->cl->object, Nsf_SystemMethodOpts[NSF_c_dealloc_idx]);
32132       result = DoDealloc(interp, object);
32133       NSF_PROFILE_EXIT(interp, &object->cl->object, Nsf_SystemMethodOpts[NSF_c_dealloc_idx]);
32134     } else {
32135       result = NsfCallMethodWithArgs(interp, (Nsf_Object *)object->cl, methodObj,
32136                                      object->cmdName, 1, NULL,
32137                                      NSF_CSC_IMMEDIATE|NSF_CM_IGNORE_PERMISSIONS);
32138       if (unlikely(result != TCL_OK)) {
32139         /*
32140          * In case, the call of the dealloc method has failed above (e.g. NS_DYING),
32141          * we have to call dealloc manually, otherwise we have a memory leak
32142          */
32143         /*fprintf(stderr, "*** dealloc failed for %p %s flags %.6x, retry\n",
32144           object, ObjectName(object), object->flags);*/
32145         result = DoDealloc(interp, object);
32146       }
32147     }
32148     return result;
32149   } else {
32150 #if defined(OBJDELETION_TRACE)
32151     fprintf(stderr, "  Object->destroy already during delete, don't call dealloc %p\n", object);
32152 #endif
32153   }
32154   return TCL_OK;
32155 }
32156 
32157 /*
32158 objectMethod exists NsfOExistsMethod {
32159   {-argName "varName" -required 1}
32160 }
32161 */
32162 static int
NsfOExistsMethod(Tcl_Interp * interp,NsfObject * object,const char * varName)32163 NsfOExistsMethod(Tcl_Interp *interp, NsfObject *object, const char *varName) {
32164 
32165   nonnull_assert(interp != NULL);
32166   nonnull_assert(object != NULL);
32167   nonnull_assert(varName != NULL);
32168 
32169   Tcl_SetIntObj(Tcl_GetObjResult(interp),
32170                 VarExists(interp, object, varName, NULL,
32171                           NSF_VAR_TRIGGER_TRACE|NSF_VAR_REQUIRE_DEFINED));
32172   return TCL_OK;
32173 }
32174 
32175 /*
32176 objectMethod filterguard NsfOFilterGuardMethod {
32177   {-argName "filter" -required 1}
32178   {-argName "guard" -required 1 -type tclobj}
32179 }
32180 */
32181 
32182 static int
NsfOFilterGuardMethod(Tcl_Interp * interp,NsfObject * object,const char * filter,Tcl_Obj * guardObj)32183 NsfOFilterGuardMethod(Tcl_Interp *interp, NsfObject *object, const char *filter, Tcl_Obj *guardObj) {
32184   NsfObjectOpt *opt;
32185 
32186   nonnull_assert(interp != NULL);
32187   nonnull_assert(object != NULL);
32188   nonnull_assert(filter != NULL);
32189   nonnull_assert(guardObj != NULL);
32190 
32191   opt = object->opt;
32192   if (opt != NULL && opt->objFilters) {
32193     NsfCmdList *h;
32194 
32195     h = CmdListFindNameInList(interp, filter, opt->objFilters);
32196     if (h != NULL) {
32197       if (h->clientData != NULL) {
32198         GuardDel((NsfCmdList *) h);
32199       }
32200       GuardAdd(h, guardObj);
32201       object->flags &= ~NSF_FILTER_ORDER_VALID;
32202       return TCL_OK;
32203     }
32204   }
32205 
32206   return NsfPrintError(interp, "filterguard: can't find filter %s on %s",
32207                        filter, ObjectName_(object));
32208 }
32209 
32210 /*
32211 objectMethod instvar NsfOInstvarMethod {
32212   {-argName "args" -type allargs}
32213 }
32214 */
32215 
32216 static int
NsfOInstvarMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[])32217 NsfOInstvarMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[]) {
32218   callFrameContext ctx = {NULL, NULL, 0};
32219   int              result;
32220 
32221   nonnull_assert(interp != NULL);
32222   nonnull_assert(object != NULL);
32223 
32224   if ((object->filterStack != NULL) || (object->mixinStack != NULL)) {
32225     CallStackUseActiveFrame(interp, &ctx);
32226   }
32227 
32228   if (unlikely(Tcl_Interp_varFramePtr(interp) == NULL)) {
32229     CallStackRestoreSavedFrames(interp, &ctx);
32230     return NsfPrintError(interp, "instvar used on %s, but call-stack is not in procedure scope",
32231                          ObjectName_(object));
32232   }
32233 
32234   result = NsfVarImport(interp, object, ObjStr(objv[0]), objc-1, objv+1);
32235   CallStackRestoreSavedFrames(interp, &ctx);
32236 
32237   return result;
32238 }
32239 
32240 /*
32241 objectMethod mixinguard NsfOMixinGuardMethod {
32242   {-argName "mixin" -required 1 -type tclobj}
32243   {-argName "guard" -required 1 -type tclobj}
32244 }
32245 */
32246 
32247 static int
NsfOMixinGuardMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * mixinObj,Tcl_Obj * guardObj)32248 NsfOMixinGuardMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *mixinObj, Tcl_Obj *guardObj) {
32249   NsfObjectOpt *opt;
32250 
32251   nonnull_assert(interp != NULL);
32252   nonnull_assert(object != NULL);
32253   nonnull_assert(mixinObj != NULL);
32254   nonnull_assert(guardObj != NULL);
32255 
32256   opt = object->opt;
32257   if (opt != NULL && opt->objMixins) {
32258     const Tcl_Command mixinCmd = Tcl_GetCommandFromObj(interp, mixinObj);
32259 
32260     if (mixinCmd != NULL) {
32261       const NsfClass *mixinClass = NsfGetClassFromCmdPtr(mixinCmd);
32262 
32263       if (mixinClass != NULL) {
32264         NsfCmdList *h = CmdListFindCmdInList(mixinCmd, opt->objMixins);
32265 
32266         if (h != NULL) {
32267           if (h->clientData != NULL) {
32268             GuardDel((NsfCmdList *) h);
32269           }
32270           GuardAdd(h, guardObj);
32271           object->flags &= ~NSF_MIXIN_ORDER_VALID;
32272           return TCL_OK;
32273         }
32274       }
32275     }
32276   }
32277 
32278   return NsfPrintError(interp, "mixinguard: can't find mixin %s on %s",
32279                        ObjStr(mixinObj), ObjectName_(object));
32280 }
32281 
32282 /*
32283 objectMethod noinit NsfONoinitMethod {
32284 }
32285 */
32286 static int
NsfONoinitMethod(Tcl_Interp * UNUSED (interp),NsfObject * object)32287 NsfONoinitMethod(Tcl_Interp *UNUSED(interp), NsfObject *object) {
32288 
32289   nonnull_assert(object != NULL);
32290 
32291   object->flags |= NSF_INIT_CALLED;
32292   return TCL_OK;
32293 }
32294 
32295 /*
32296 objectMethod requirenamespace NsfORequireNamespaceMethod {
32297 }
32298 */
32299 static int
NsfORequireNamespaceMethod(Tcl_Interp * interp,NsfObject * object)32300 NsfORequireNamespaceMethod(Tcl_Interp *interp, NsfObject *object) {
32301 
32302   nonnull_assert(interp != NULL);
32303   nonnull_assert(object != NULL);
32304 
32305   RequireObjNamespace(interp, object);
32306   return TCL_OK;
32307 }
32308 
32309 /*
32310 objectMethod residualargs NsfOResidualargsMethod {
32311   {-argName "args" -type allargs}
32312 }
32313 */
32314 static int
NsfOResidualargsMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[])32315 NsfOResidualargsMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[]) {
32316   int          i, start = 1, argc, nextArgc, normalArgs, result = TCL_OK;
32317   dashArgType  isdasharg = NO_DASH;
32318   const char  *methodName, *nextMethodName, *initString = NULL;
32319   Tcl_Obj    **argv, **nextArgv;
32320 
32321   nonnull_assert(interp != NULL);
32322   nonnull_assert(object != NULL);
32323 
32324 #if 0
32325   fprintf(stderr, "NsfOResidualargsMethod %s %2d ", ObjectName_(object), objc);
32326   for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%p %s,", i, &objv[i], ObjStr(objv[i]));}
32327   fprintf(stderr, "\n");
32328 #endif
32329 
32330   /*
32331    * Skip arguments without leading dash.
32332    */
32333   for (i = start; i < objc; i++) {
32334     if ((isdasharg = IsDashArg(interp, objv[i], 1, &methodName, &argc, &argv))) {
32335       break;
32336     }
32337   }
32338   normalArgs = i-1;
32339 
32340   /*
32341    * Get the init string; do it once, outside the loop.  If initString is not
32342    * obtainable (i.e. not configured in the object system), don't call the
32343    * "init" method in the loop.
32344    */
32345   if (i < objc) {
32346     NsfObjectSystem *osPtr   = GetObjectSystem(object);
32347     Tcl_Obj         *initObj = osPtr->methods[NSF_o_init_idx];
32348 
32349     if (initObj != NULL) {
32350       initString = osPtr->methodNames[NSF_o_init_idx];
32351       assert(initString != NULL);
32352     }
32353   }
32354 
32355 
32356   for( ; i < objc;  argc = nextArgc, argv = nextArgv, methodName = nextMethodName) {
32357 
32358     Tcl_ResetResult(interp);
32359 
32360     switch (isdasharg) {
32361     case SCALAR_DASH:    /* Argument is a scalar with a leading dash */
32362       { int j;
32363 
32364         nextMethodName = NULL;
32365         nextArgv = NULL;
32366         nextArgc = 0;
32367 
32368         for (j = i+1; j < objc; j++, argc++) {
32369           if ((isdasharg = IsDashArg(interp, objv[j], 1, &nextMethodName, &nextArgc, &nextArgv))) {
32370             break;
32371           }
32372         }
32373         if (initString != NULL) {
32374           result = CallConfigureMethod(interp, object, initString, methodName, argc+1, objv+i+1);
32375           if (unlikely(result != TCL_OK)) {
32376             return result;
32377           }
32378         }
32379         i += argc;
32380         break;
32381       }
32382     case LIST_DASH:  /* Argument is a list with a leading dash, grouping determined by list */
32383       { i++;
32384         nextMethodName = NULL;
32385 
32386         if (i < objc) {
32387           isdasharg = IsDashArg(interp, objv[i], 1, &nextMethodName, &nextArgc, &nextArgv);
32388         } else {
32389           nextMethodName = NULL;
32390           nextArgv = NULL;
32391           nextArgc = 0;
32392         }
32393         if (initString != NULL) {
32394           result = CallConfigureMethod(interp, object, initString, methodName, argc+1, argv+1);
32395           if (unlikely(result != TCL_OK)) {
32396             return result;
32397           }
32398         }
32399         break;
32400       }
32401     case NO_DASH: /* fall through */
32402     default:
32403       {
32404         return NsfPrintError(interp, "%s configure: unexpected argument '%s' between parameters",
32405                              ObjectName_(object), ObjStr(objv[i]));
32406       }
32407     }
32408   }
32409 
32410   /*
32411    * Call init with residual args in case it was not called yet.
32412    */
32413   result = DispatchInitMethod(interp, object, normalArgs, objv+1, 0u);
32414 
32415   if (likely(result == TCL_OK)) {
32416     /*
32417      * Return the non-processed leading arguments unless there was an error
32418      * (XOTcl convention)
32419      */
32420     Tcl_SetObjResult(interp, Tcl_NewListObj(normalArgs, objv+1));
32421   }
32422 
32423   return result;
32424 }
32425 
32426 /*
32427 objectMethod uplevel NsfOUplevelMethod {
32428   {-argName "args" -type allargs}
32429 }
32430 */
32431 static int
NsfOUplevelMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[])32432 NsfOUplevelMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[]) {
32433   int        result, getFrameResult = 0;
32434   CallFrame *requestedFramePtr;
32435 
32436   nonnull_assert(interp != NULL);
32437   nonnull_assert(objv != NULL);
32438 
32439   if (objc < 2) {
32440     result = NsfPrintError(interp,
32441                          "wrong # args: should be \"%s %s ?level? command ?arg ...?\"",
32442                          ObjectName_(object),
32443                          NsfMethodName(objv[0]));
32444 
32445   } else  if (objc == 2) {
32446     result = TCL_OK;
32447 
32448   } else {
32449     /*
32450      * TclObjGetFrame returns:
32451      *  0 ... when a syntactically invalid (incl. no) level specifier was provided
32452      *  1 ... when a syntactically valid level specifier with corresp. frame
32453               was found
32454      * -1 ... when a syntactically valid level specifier was provided,
32455               but an error occurred while finding the frame
32456               (error msg in interp, "bad level")
32457      */
32458     getFrameResult = TclObjGetFrame(interp, objv[1], &requestedFramePtr);
32459     result = unlikely(getFrameResult == -1) ? TCL_ERROR : TCL_OK;
32460   }
32461 
32462   if (likely(result == TCL_OK)) {
32463     Tcl_CallFrame *framePtr, *savedVarFramePtr;
32464 
32465     objc -= getFrameResult + 1;
32466     objv += getFrameResult + 1;
32467 
32468     if (getFrameResult == 0) {
32469       /*
32470        * 0 is returned from TclObjGetFrame when no (or, an invalid) level
32471        * specifier was provided; objv[0] is interpreted as a command word,
32472        * uplevel defaults to the computed level.
32473        */
32474       Tcl_CallFrame *callingFramePtr = NULL;
32475 
32476       framePtr = NULL;
32477       NsfCallStackFindCallingContext(interp, 1, &framePtr, &callingFramePtr);
32478 
32479       if (framePtr == NULL) {
32480         /*
32481          * No proc frame was found, default to parent frame.
32482          */
32483         framePtr = callingFramePtr;
32484       }
32485     } else {
32486       /*
32487        * Use the requested frame corresponding to the (valid) level specifier.
32488        */
32489       framePtr = (Tcl_CallFrame *)requestedFramePtr;
32490     }
32491 
32492     assert(framePtr != NULL);
32493 
32494     savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
32495     Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr;
32496 
32497     /*
32498      * Execute the residual arguments as a command.
32499      */
32500 
32501     if (objc == 1) {
32502       result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
32503     } else {
32504       /*
32505        * More than one argument: concatenate them together with spaces
32506        * between, then evaluate the result.  Tcl_EvalObjEx will delete
32507        * the object when it decrements its refCount after eval'ing it.
32508        */
32509       Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
32510 
32511       result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
32512     }
32513 
32514     if (unlikely(result == TCL_ERROR)) {
32515       Tcl_AppendObjToErrorInfo(interp,
32516                                Tcl_ObjPrintf("\n    (\"uplevel\" body line %d)",
32517                                              Tcl_GetErrorLine(interp)));
32518     }
32519 
32520     /*
32521      * Restore the variable frame, and return.
32522      */
32523     Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr;
32524   }
32525 
32526   return result;
32527 }
32528 
32529 /*
32530 objectMethod upvar NsfOUpvarMethod {
32531   {-argName "args" -type allargs}
32532 }
32533 */
32534 static int
NsfOUpvarMethod(Tcl_Interp * interp,NsfObject * object,int objc,Tcl_Obj * const objv[])32535 NsfOUpvarMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *const objv[]) {
32536   Tcl_Obj         *frameInfoObj;
32537   int              i, result = TCL_ERROR;
32538   const char      *frameInfo;
32539   callFrameContext ctx = {NULL, NULL, 0};
32540 
32541   nonnull_assert(interp != NULL);
32542   nonnull_assert(object != NULL);
32543 
32544   if (objc < 3) {
32545     return NsfPrintError(interp,
32546                          "wrong # args: should be \"%s %s "
32547                          "?level? otherVar localVar ?otherVar localVar ...?\"",
32548                          ObjectName_(object),
32549                          NsfMethodName(objv[0]));
32550   }
32551 
32552   if (objc % 2 == 0) {
32553     /*
32554      * Even number of arguments (including method), therefore the level
32555      * specifier is considered to be the first argument.
32556      */
32557     frameInfoObj = NULL;
32558     frameInfo = ObjStr(objv[1]);
32559     i = 2;
32560   } else {
32561     /*
32562      * Odd number of arguments (including method), therefore the level
32563      * specifier considered absent and the level has to be computed.
32564      */
32565     frameInfoObj = ComputeLevelObj(interp, CALLING_LEVEL);
32566     INCR_REF_COUNT(frameInfoObj);
32567     frameInfo = ObjStr(frameInfoObj);
32568     i = 1;
32569   }
32570 
32571   if ((object->filterStack != NULL) || (object->mixinStack != NULL)) {
32572     CallStackUseActiveFrame(interp, &ctx);
32573   }
32574 
32575   for ( ;  i < objc;  i += 2) {
32576     result = Tcl_UpVar2(interp, frameInfo, ObjStr(objv[i]), NULL,
32577                         ObjStr(objv[i+1]), 0 /*flags*/);
32578     if (unlikely(result != TCL_OK)) {
32579       break;
32580     }
32581   }
32582 
32583   if (frameInfoObj != NULL) {
32584     DECR_REF_COUNT(frameInfoObj);
32585   }
32586   CallStackRestoreSavedFrames(interp, &ctx);
32587   return result;
32588 
32589 }
32590 
32591 /*
32592 objectMethod volatile NsfOVolatileMethod {
32593 }
32594 objectMethod volatile1 NsfOVolatile1Method {
32595 }
32596 */
32597 static int
VolatileMethod(Tcl_Interp * interp,NsfObject * object,bool shallow)32598 VolatileMethod(Tcl_Interp *interp, NsfObject *object, bool shallow) {
32599   int               result = TCL_ERROR;
32600   Tcl_Obj          *objPtr;
32601   const char       *fullName, *vn;
32602   callFrameContext  ctx = {NULL, NULL, 0};
32603 
32604   nonnull_assert(interp != NULL);
32605   nonnull_assert(object != NULL);
32606 
32607   if (unlikely(RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_OFF)) {
32608     return NsfPrintError(interp, "can't make objects volatile during shutdown");
32609   }
32610 
32611   if (shallow) {
32612     CallStackUseActiveFrame(interp, &ctx);
32613 
32614   } else {
32615     NsfObjectSystem *osPtr = GetObjectSystem(object);
32616     Tcl_CallFrame   *invocationFrame;
32617 
32618     /*
32619      * XOTcl1 style
32620      */
32621     /*NsfShowStack(interp);*/
32622 
32623     CallStackUseActiveFrame(interp, &ctx);
32624 
32625     /*fprintf(stderr, "active varframe %p\n", (void*)Tcl_Interp_varFramePtr(interp));*/
32626     invocationFrame = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
32627 
32628     while (1) {
32629 
32630       if (((unsigned int)Tcl_CallFrame_isProcCallFrame(invocationFrame) & (FRAME_IS_NSF_METHOD|FRAME_IS_NSF_CMETHOD)) != 0u) {
32631         NsfCallStackContent *cscPtr;
32632 
32633         cscPtr = ((NsfCallStackContent *)Tcl_CallFrame_clientData(invocationFrame));
32634         /*
32635          * We were not called from an NSF frame.
32636          */
32637         if (cscPtr == NULL) {
32638           break;
32639         }
32640 
32641 
32642         /*
32643          * Walk up the stack of invocations of the current object to skip
32644          * e.g. overloaded internally called methods like "configure".
32645          */
32646         /*fprintf(stderr, "compare object %p == %p\n", (void*)object, (void*)cscPtr->self);*/
32647         if (cscPtr->self == object) {
32648           invocationFrame =  Tcl_CallFrame_callerPtr(invocationFrame);
32649           /*fprintf(stderr, "same object, continue with %p\n", (void*)invocationFrame);*/
32650           continue;
32651         }
32652 
32653         /*
32654          * If this was a "next" call, continue to walk up.
32655          */
32656         if ((cscPtr->flags & NSF_CSC_CALL_IS_NEXT) != 0u) {
32657           invocationFrame =  Tcl_CallFrame_callerPtr(invocationFrame);
32658           /*fprintf(stderr, "next call with %p\n", (void*)invocationFrame);*/
32659           continue;
32660         }
32661 
32662         /*
32663          * Final special case for XOTcl1 compliance: In case, we were called
32664          * from an "unknown" method, skip this frame as well.
32665          */
32666         /*fprintf(stderr, "cmd %s\n", Tcl_GetCommandName(interp, cscPtr->cmdPtr));*/
32667         if (strcmp(osPtr->methodNames[NSF_o_unknown_idx], Tcl_GetCommandName(interp, cscPtr->cmdPtr)) == 0) {
32668           invocationFrame =  Tcl_CallFrame_callerPtr(invocationFrame);
32669           /*fprintf(stderr, "have unknown, continue with %p\n", (void*)invocationFrame);*/
32670           continue;
32671         }
32672 
32673       }
32674       break;
32675     }
32676     /*
32677      * Finally, set the invocation frame. The original frame context was saved
32678      * already by CallStackUseActiveFrame() and will be properly restored.
32679      */
32680     Tcl_Interp_varFramePtr(interp) = (CallFrame *)invocationFrame;
32681 
32682   }
32683 
32684   objPtr = object->cmdName;
32685   fullName = ObjStr(objPtr);
32686   vn = NSTail(fullName);
32687 
32688   if (Tcl_SetVar2(interp, vn, NULL, fullName, 0)) {
32689     NsfObjectOpt *opt = NsfRequireObjectOpt(object);
32690 
32691     /*fprintf(stderr, "### setting trace for %s on frame %p\n", fullName,
32692       Tcl_Interp_varFramePtr(interp));
32693       NsfShowStack(interp);*/
32694     result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS,
32695                           (Tcl_VarTraceProc *)NsfUnsetTrace,
32696                           objPtr);
32697     opt->volatileVarName = vn;
32698   }
32699   CallStackRestoreSavedFrames(interp, &ctx);
32700 
32701   if (likely(result == TCL_OK)) {
32702     INCR_REF_COUNT(objPtr);
32703   }
32704   return result;
32705 }
32706 
32707 static int
NsfOVolatileMethod(Tcl_Interp * interp,NsfObject * object)32708 NsfOVolatileMethod(Tcl_Interp *interp, NsfObject *object) {
32709 
32710   return VolatileMethod(interp, object, NSF_TRUE);
32711 }
32712 
32713 static int
NsfOVolatile1Method(Tcl_Interp * interp,NsfObject * object)32714 NsfOVolatile1Method(Tcl_Interp *interp, NsfObject *object) {
32715 
32716   return VolatileMethod(interp, object, NSF_FALSE);
32717 }
32718 
32719 /***********************************************************************
32720  * End Object Methods
32721  ***********************************************************************/
32722 
32723 
32724 /***********************************************************************
32725  * Begin Class Methods
32726  ***********************************************************************/
32727 
32728 static int
NsfCAllocMethod_(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * nameObj,Tcl_Namespace * parentNsPtr)32729 NsfCAllocMethod_(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, Tcl_Namespace *parentNsPtr) {
32730   const char *nameString;
32731   NsfObject  *newObj;
32732 
32733   nonnull_assert(interp != NULL);
32734   nonnull_assert(class != NULL);
32735   nonnull_assert(nameObj != NULL);
32736 
32737   nameString = ObjStr(nameObj);
32738   assert(isAbsolutePath(nameString));
32739   assert(NSValidObjectName(nameString, 0) != 0);
32740 
32741   /*
32742    * Create a new object from scratch.
32743    */
32744   if (! IsMetaClass(interp, class, NSF_TRUE)) {
32745     /*
32746      * If the base class is an ordinary class, we create an object.
32747      */
32748     newObj = PrimitiveOCreate(interp, nameObj, parentNsPtr, class);
32749 
32750   } else {
32751     /*
32752      * If the base class is a metaclass, we create a class.
32753      */
32754     newObj = (NsfObject *)PrimitiveCCreate(interp, nameObj, parentNsPtr, class);
32755   }
32756 
32757   if (unlikely(newObj == NULL)) {
32758     return NsfPrintError(interp, "alloc failed to create '%s' "
32759                          "(possibly parent namespace does not exist)",
32760                          nameString);
32761   }
32762 
32763   if (NSF_DTRACE_OBJECT_ALLOC_ENABLED()) {
32764     NSF_DTRACE_OBJECT_ALLOC(ObjectName(newObj), ClassName(class));
32765   }
32766 
32767   /*fprintf(stderr, "PrimitiveCCreate returns nameObj %p typePtr %p %s\n",
32768           nameObj, nameObj->typePtr,
32769           ObjTypeStr(nameObj)); */
32770   Tcl_SetObjResult(interp, nameObj);
32771 
32772   return TCL_OK;
32773 }
32774 
32775 /*
32776 classMethod alloc NsfCAllocMethod {
32777   {-argName "name" -required 1 -type tclobj}
32778 }
32779 */
32780 static int
NsfCAllocMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * nameObj)32781 NsfCAllocMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj) {
32782   const char *nameString;
32783   int         result, nameLength = 0;
32784 
32785   /*
32786    * Create a new object from scratch.
32787    */
32788 
32789   nonnull_assert(interp != NULL);
32790   nonnull_assert(class != NULL);
32791   nonnull_assert(nameObj != NULL);
32792 
32793   /*
32794    * Check for illegal names.
32795    */
32796   nameString = TclGetStringFromObj(nameObj, &nameLength);
32797   if (unlikely(NSValidObjectName(nameString, (size_t)nameLength) == 0)) {
32798     result = NsfPrintError(interp, "cannot allocate object - illegal name '%s'", nameString);
32799 
32800   } else {
32801     Tcl_Namespace *parentNsPtr;
32802     Tcl_Obj       *tmpName;
32803 
32804     /*
32805      * Name is valid. If the path is not absolute, we add the appropriate
32806      * namespace.
32807      */
32808     if (isAbsolutePath(nameString)) {
32809       parentNsPtr = NULL;
32810       tmpName = NULL;
32811     } else {
32812       parentNsPtr = CallingNameSpace(interp);
32813       nameObj = tmpName = NameInNamespaceObj(nameString, parentNsPtr);
32814       if (strchr(nameString, ':')) {
32815         parentNsPtr = NULL;
32816       }
32817       INCR_REF_COUNT(tmpName);
32818       /*fprintf(stderr, " **** NoAbsoluteName for '%s' -> determined = '%s' parentNs %s\n",
32819         nameString, ObjStr(tmpName), parentNsPtr->fullName);*/
32820     }
32821 
32822     result = NsfCAllocMethod_(interp, class, nameObj, parentNsPtr);
32823 
32824     if (tmpName != NULL) {
32825       DECR_REF_COUNT(tmpName);
32826     }
32827   }
32828   return result;
32829 }
32830 
32831 /*
32832 classMethod create NsfCCreateMethod {
32833   {-argName "name" -required 1}
32834   {-argName "args" -type allargs}
32835 }
32836 */
32837 static int
NsfCCreateMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * nameObj,int objc,Tcl_Obj * const objv[])32838 NsfCCreateMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *nameObj, int objc, Tcl_Obj *const objv[]) {
32839   NsfObject     *newObject = NULL;
32840   Tcl_Obj       *actualNameObj, *methodObj, *tmpObj = NULL;
32841   int            result, nameLength = 0;
32842   bool           autoNameCreate;
32843   const char    *nameString;
32844   Tcl_Namespace *parentNsPtr;
32845 
32846   nonnull_assert(interp != NULL);
32847   nonnull_assert(class != NULL);
32848   nonnull_assert(nameObj != NULL);
32849   nonnull_assert(objv != NULL);
32850 
32851   nameString = TclGetStringFromObj(nameObj, &nameLength);
32852 #if 0
32853   { int i;
32854     fprintf(stderr, "NsfCCreateMethod %s create <%s> oc %d ", ClassName(class), ObjStr(nameObj), objc);
32855     for(i = 0; i < objc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(objv[i]));}
32856     fprintf(stderr, "\n");
32857   }
32858 #endif
32859 
32860   if (unlikely(RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_OFF)) {
32861     fprintf(stderr, "### Can't create instance %s of class %s during interp shutdown.\n",
32862             ObjStr(nameObj), ClassName_(class));
32863     /*
32864      * Don't fail, if this happens during destroy, it might be canceled.
32865      */
32866     return TCL_OK;
32867   }
32868 
32869   /*
32870    * Check for illegal names.
32871    */
32872   if (unlikely(NSValidObjectName(nameString, (size_t)nameLength) == 0)) {
32873     result = NsfPrintError(interp, "cannot allocate object - illegal name '%s'", nameString);
32874     goto create_method_exit;
32875   }
32876 
32877   /*fprintf(stderr, "NsfCCreateMethod specifiedName %s\n", nameString);*/
32878   /*
32879    * Complete the name if it is not absolute.
32880    */
32881   if (!isAbsolutePath(nameString)) {
32882     parentNsPtr = CallingNameSpace(interp);
32883     tmpObj = NameInNamespaceObj(nameString, parentNsPtr);
32884     /*
32885      * If the name contains colons, the parentNsPtr is not appropriate
32886      * for determining the parent.
32887      */
32888     if (strchr(nameString, ':')) {
32889       parentNsPtr = NULL;
32890     }
32891     nameString = ObjStr(tmpObj);
32892     /* fprintf(stderr, " **** fixed name is '%s'\n", nameString); */
32893     INCR_REF_COUNT(tmpObj);
32894     actualNameObj = tmpObj;
32895     autoNameCreate = NSF_FALSE;
32896 
32897   } else {
32898     parentNsPtr = NULL;
32899     actualNameObj = nameObj;
32900     /* fprintf(stderr, " **** used specified name is '%s'\n", nameString); */
32901 
32902     /*
32903      * Check for autname prefix string. This string is always an absolute path
32904      * name, so it is sufficient to test here.
32905      */
32906     autoNameCreate = (strncmp(autonamePrefix, nameString, autonamePrefixLength) == 0);
32907   }
32908 
32909   /*
32910    * Check whether we have to call recreate (i.e. when the object exists
32911    * already). First check whether we have such a command, then check whether
32912    * the command is an object.
32913    */
32914   {
32915     Tcl_Command cmd = NSFindCommand(interp, nameString);
32916     if (cmd != NULL) {
32917       newObject = NsfGetObjectFromCmdPtr(cmd);
32918       if (newObject == NULL) {
32919         /*
32920          * We have a cmd, but no object. Don't allow one to overwrite an
32921          * ordinary cmd by an NSF object.
32922          */
32923         result = NsfPrintError(interp, "refuse to overwrite cmd %s; delete/rename it before overwriting", nameString);
32924         goto create_method_exit;
32925       }
32926     }
32927   }
32928 
32929   /*fprintf(stderr, "+++ createspecifiedName '%s', nameString '%s', newObject=%p ismeta(%s) %d, ismeta(%s) %d\n",
32930           ObjStr(specifiedNameObj), nameString, newObject,
32931           ClassName(class), IsMetaClass(interp, class, NSF_TRUE),
32932           (newObject != NULL) ? ClassName(newObject->cl) : "NULL",
32933           (newObject != NULL) ? IsMetaClass(interp, newObject->cl, NSF_TRUE) : 0
32934           );*/
32935 
32936   /*
32937    * Provide protection against recreation if base classes.
32938    */
32939   if (unlikely(newObject != NULL && unlikely(IsBaseClass(newObject)))) {
32940     result = NsfPrintError(interp, "cannot recreate base class %s", ObjectName(newObject));
32941     goto create_method_exit;
32942   }
32943 
32944   /*
32945    * Don't allow one to
32946    *  - recreate an object as a class,
32947    *  - recreate a class as an object, and to
32948    *  - recreate an object in a different object system
32949    *
32950    * In these cases, we use destroy followed by create instead of recreate.
32951    */
32952 
32953   if ((newObject != NULL)
32954       && (IsMetaClass(interp, class, NSF_TRUE) == IsMetaClass(interp, newObject->cl, NSF_TRUE))
32955       && GetObjectSystem(newObject) == class->osPtr) {
32956 
32957     /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d oldOs %p != newOs %p EQ %d\n",
32958             ObjStr(actualNameObj), objc+1,
32959             GetObjectSystem(newObject), cl->osPtr,
32960             GetObjectSystem(newObject) != cl->osPtr
32961             );*/
32962 
32963 
32964     /*
32965      * Call recreate --> initialization.
32966      */
32967     if (CallDirectly(interp, &class->object, NSF_c_recreate_idx, &methodObj)) {
32968       NSF_PROFILE_TIME_DATA;
32969       NSF_PROFILE_CALL(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_recreate_idx]);
32970       result = RecreateObject(interp, class, newObject, objc, objv);
32971       NSF_PROFILE_EXIT(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_recreate_idx]);
32972 
32973     } else {
32974       ALLOC_ON_STACK(Tcl_Obj*, objc+3, xov);
32975 
32976       xov[0] = NULL; /* just a placeholder for passing conventions in ObjectDispatch() */
32977       xov[1] = methodObj;
32978       xov[2] = actualNameObj;
32979       if (objc >= 1) {
32980         memcpy(xov+3, objv, sizeof(Tcl_Obj *) * (size_t)objc);
32981       }
32982       result = ObjectDispatch(class, interp, objc+3, xov, NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
32983 
32984       FREE_ON_STACK(Tcl_Obj *, xov);
32985     }
32986 
32987     if (unlikely(result != TCL_OK)) {
32988       goto create_method_exit;
32989     }
32990 
32991     Tcl_SetObjResult(interp, newObject->cmdName);
32992     ObjTrace("RECREATE", newObject);
32993 
32994   } else {
32995     /*
32996      * "newObject" might exist here, but will be automatically destroyed by
32997      * alloc.
32998      */
32999 
33000     if (CallDirectly(interp, &class->object, NSF_c_alloc_idx, &methodObj)) {
33001       NSF_PROFILE_TIME_DATA;
33002       NSF_PROFILE_CALL(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_alloc_idx]);
33003       result = NsfCAllocMethod_(interp, class, actualNameObj, parentNsPtr);
33004       NSF_PROFILE_EXIT(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_alloc_idx]);
33005     } else {
33006       result = CallMethod(class, interp, methodObj,
33007                           3, &actualNameObj, NSF_CSC_IMMEDIATE);
33008     }
33009 
33010     if (unlikely(result != TCL_OK)) {
33011       goto create_method_exit;
33012     }
33013     actualNameObj = Tcl_GetObjResult(interp);
33014 
33015     if (unlikely(GetObjectFromObj(interp, actualNameObj, &newObject) != TCL_OK)) {
33016       result = NsfPrintError(interp, "couldn't find result of alloc");
33017       goto create_method_exit;
33018     }
33019 
33020     ObjTrace("CREATE", newObject);
33021 
33022     if (autoNameCreate) {
33023       newObject->flags |= NSF_IS_AUTONAMED;
33024     }
33025 
33026     /*
33027      * In case, the object is destroyed during initialization, we increment
33028      * the refCount.
33029      */
33030     INCR_REF_COUNT(actualNameObj);
33031     result = DoObjInitialization(interp, newObject, objc, objv);
33032     DECR_REF_COUNT(actualNameObj);
33033   }
33034  create_method_exit:
33035 
33036   if (tmpObj != NULL) {
33037     DECR_REF_COUNT(tmpObj);
33038   }
33039   return result;
33040 }
33041 
33042 /*
33043 classMethod dealloc NsfCDeallocMethod {
33044   {-argName "object" -required 1 -type tclobj}
33045 }
33046 */
33047 
33048 static int
NsfCDeallocMethod(Tcl_Interp * interp,NsfClass * UNUSED (class),Tcl_Obj * objectObj)33049 NsfCDeallocMethod(Tcl_Interp *interp, NsfClass *UNUSED(class), Tcl_Obj *objectObj) {
33050   NsfObject *object;
33051 
33052   nonnull_assert(interp != NULL);
33053 
33054   if (GetObjectFromObj(interp, objectObj, &object) != TCL_OK) {
33055     return NsfPrintError(interp, "can't destroy object %s that does not exist",
33056                          ObjStr(objectObj));
33057   }
33058 
33059   return DoDealloc(interp, object);
33060 }
33061 
33062 /*
33063 classMethod filterguard NsfCFilterGuardMethod {
33064   {-argName "filter" -required 1}
33065   {-argName "guard" -required 1 -type tclobj}
33066 }
33067 */
33068 
33069 static int
NsfCFilterGuardMethod(Tcl_Interp * interp,NsfClass * class,const char * filter,Tcl_Obj * guardObj)33070 NsfCFilterGuardMethod(Tcl_Interp *interp, NsfClass *class,
33071                       const char *filter, Tcl_Obj *guardObj) {
33072   NsfClassOpt *opt;
33073 
33074   nonnull_assert(interp != NULL);
33075   nonnull_assert(class != NULL);
33076   nonnull_assert(filter != NULL);
33077   nonnull_assert(guardObj != NULL);
33078 
33079   opt = class->opt;
33080   if (opt != NULL && opt->classFilters) {
33081     NsfCmdList *h = CmdListFindNameInList(interp, filter, opt->classFilters);
33082 
33083     if (h != NULL) {
33084       NsfClasses *subClasses = DependentSubClasses(class);
33085 
33086       if (h->clientData != NULL) {
33087         GuardDel(h);
33088       }
33089       GuardAdd(h, guardObj);
33090 
33091       if (subClasses != NULL) {
33092         FilterInvalidateObjOrders(interp, subClasses);
33093         NsfClassListFree(subClasses);
33094       }
33095 
33096       return TCL_OK;
33097     }
33098   }
33099 
33100   return NsfPrintError(interp, "filterguard: can't find filter %s on %s",
33101                        filter, ClassName_(class));
33102 }
33103 
33104 /*
33105 classMethod getCachedParameters NsfCGetCachendParametersMethod {
33106 }
33107 */
33108 static int
NsfCGetCachendParametersMethod(Tcl_Interp * interp,NsfClass * class)33109 NsfCGetCachendParametersMethod(Tcl_Interp *interp, NsfClass *class) {
33110 
33111   nonnull_assert(interp != NULL);
33112   nonnull_assert(class != NULL);
33113 
33114   if (likely(class->parsedParamPtr != NULL && class->parsedParamPtr->paramDefs != NULL)) {
33115     Tcl_Obj *listObj;
33116 
33117     listObj = ListParamDefs(interp, class->parsedParamPtr->paramDefs->paramsPtr,
33118                             NULL, NULL, NSF_PARAMS_PARAMETER);
33119     Tcl_SetObjResult(interp, listObj);
33120     DECR_REF_COUNT2("paramDefsObj", listObj);
33121   }
33122   return TCL_OK;
33123 }
33124 
33125 /*
33126 classMethod mixinguard NsfCMixinGuardMethod {
33127   {-argName "mixin" -required 1 -type tclobj}
33128   {-argName "guard" -required 1 -type tclobj}
33129 }
33130 */
33131 static int
NsfCMixinGuardMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * mixinObj,Tcl_Obj * guardObj)33132 NsfCMixinGuardMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *mixinObj, Tcl_Obj *guardObj) {
33133   NsfClassOpt *opt;
33134 
33135   nonnull_assert(interp != NULL);
33136   nonnull_assert(class != NULL);
33137   nonnull_assert(mixinObj != NULL);
33138   nonnull_assert(guardObj != NULL);
33139 
33140   opt = class->opt;
33141   if (opt != NULL && opt->classMixins != NULL) {
33142     const Tcl_Command mixinCmd = Tcl_GetCommandFromObj(interp, mixinObj);
33143 
33144     if (mixinCmd != NULL) {
33145      const NsfClass *mixinClass = NsfGetClassFromCmdPtr(mixinCmd);
33146 
33147       if (mixinClass != NULL) {
33148         NsfCmdList *h = CmdListFindCmdInList(mixinCmd, opt->classMixins);
33149 
33150         if (h != NULL) {
33151           NsfClasses *subClasses;
33152 
33153           if (h->clientData != NULL) {
33154             GuardDel((NsfCmdList *) h);
33155           }
33156           GuardAdd(h, guardObj);
33157           subClasses = DependentSubClasses(class);
33158           MixinInvalidateObjOrders(subClasses);
33159           NsfClassListFree(subClasses);
33160           return TCL_OK;
33161         }
33162       }
33163     }
33164   }
33165 
33166   return NsfPrintError(interp, "mixinguard: can't find mixin %s on %s",
33167                        ObjStr(mixinObj), ClassName_(class));
33168 }
33169 
33170 /*
33171 classMethod new NsfCNewMethod {
33172   {-argName "-childof" -required 0 -type tclobj}
33173   {-argName "args" -required 0 -type args}
33174 }
33175 */
33176 
33177 static int
NsfCNewMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * childofObj,int trailingObjc,Tcl_Obj * const trailingObjv[])33178 NsfCNewMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *childofObj,
33179               int trailingObjc, Tcl_Obj *const trailingObjv[]) {
33180   Tcl_Obj     *fullnameObj;
33181   Tcl_DString  dFullname, *dsPtr = &dFullname;
33182   int          result;
33183 
33184   nonnull_assert(interp != NULL);
33185   nonnull_assert(class != NULL);
33186 
33187 #if 0
33188   { int i;
33189     fprintf(stderr, "NsfCNewMethod %s withChildof %p oc %d ", ClassName(class), childofObj, trailingObjc);
33190     for(i = 0; i < trailingObjc; i++) {fprintf(stderr, " [%d]=%s,", i, ObjStr(trailingObjv[i]));}
33191     fprintf(stderr, "\n");
33192   }
33193 #endif
33194 
33195   Tcl_DStringInit(dsPtr);
33196   if (childofObj != 0) {
33197     const char *parentName = ObjStr(childofObj);
33198 
33199     /*
33200      * If "parentName" is fully qualified, use it as prefix, else prepend the
33201      * CallingNameSpace() to be compatible with the object name completion.
33202      */
33203     if (*parentName == ':' && *(parentName + 1) == ':') {
33204       /*
33205        * Prepend parentName only if it is not "::"
33206        */
33207       if (*(parentName + 2) != '\0') {
33208         Tcl_DStringAppend(dsPtr, parentName, -1);
33209       }
33210     } else {
33211       Tcl_Obj    *tmpName = NameInNamespaceObj(parentName, CallingNameSpace(interp));
33212       const char *completedParentName;
33213 
33214       INCR_REF_COUNT(tmpName);
33215       completedParentName = ObjStr(tmpName);
33216       if (strcmp(completedParentName, "::")) {
33217         Tcl_DStringAppend(dsPtr, ObjStr(tmpName), -1);
33218       }
33219       DECR_REF_COUNT(tmpName);
33220     }
33221     Tcl_DStringAppend(dsPtr, "::__#", 5);
33222   } else {
33223     Tcl_DStringAppend(dsPtr, autonamePrefix, (int)autonamePrefixLength);
33224   }
33225 
33226   NewTclCommand(interp, dsPtr);
33227 
33228   fullnameObj = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
33229   INCR_REF_COUNT(fullnameObj);
33230 
33231   {
33232     Tcl_Obj *methodObj;
33233     int      callDirectly;
33234 
33235     callDirectly = CallDirectly(interp, &class->object, NSF_c_create_idx, &methodObj);
33236 
33237     if (callDirectly != 0) {
33238       NSF_PROFILE_TIME_DATA;
33239       NSF_PROFILE_CALL(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_create_idx]);
33240       result = NsfCCreateMethod(interp, class, fullnameObj, trailingObjc, trailingObjv);
33241       NSF_PROFILE_EXIT(interp, &class->object, Nsf_SystemMethodOpts[NSF_c_create_idx]);
33242     } else {
33243       ALLOC_ON_STACK(Tcl_Obj*, trailingObjc+3, ov);
33244 
33245       ov[0] = NULL; /* just a placeholder for passing conventions in ObjectDispatch() */
33246       ov[1] = methodObj;
33247       ov[2] = fullnameObj;
33248       if (trailingObjc >= 1) {
33249         memcpy(ov+3, trailingObjv, sizeof(Tcl_Obj *) * (size_t)trailingObjc);
33250       }
33251       result = ObjectDispatch(class, interp, trailingObjc+3, ov, NSF_CSC_IMMEDIATE);
33252       FREE_ON_STACK(Tcl_Obj *, ov);
33253     }
33254   }
33255 
33256   DECR_REF_COUNT(fullnameObj);
33257   Tcl_DStringFree(dsPtr);
33258 
33259   return result;
33260 }
33261 
33262 /*
33263 classMethod recreate NsfCRecreateMethod {
33264   {-argName "objectName" -required 1 -type tclobj}
33265   {-argName "args" -type virtualclassargs}
33266 }
33267 */
33268 static int
RecreateObject(Tcl_Interp * interp,NsfClass * class,NsfObject * object,int objc,Tcl_Obj * const objv[])33269 RecreateObject(Tcl_Interp *interp, NsfClass *class, NsfObject *object,
33270                int objc, Tcl_Obj *const objv[]) {
33271   int result;
33272 
33273   nonnull_assert(interp != NULL);
33274   nonnull_assert(class != NULL);
33275   nonnull_assert(object != NULL);
33276   nonnull_assert(objv != NULL);
33277 
33278   object->flags |= NSF_RECREATE;
33279 
33280   /*
33281    * First, cleanup the data from the object.
33282    *
33283    * Check whether we have a pending destroy on the object; if yes,
33284    * clear it, such that the recreated object and won't be destroyed
33285    * on a POP.
33286    */
33287   MarkUndestroyed(object);
33288 
33289   /*
33290    * Ensure correct class for object.
33291    */
33292   result = ChangeClass(interp, object, class);
33293 
33294   if (likely(result == TCL_OK)) {
33295     Tcl_Obj *methodObj;
33296 
33297     /*
33298      * Dispatch "cleanup" method.
33299      */
33300     if (CallDirectly(interp, object, NSF_o_cleanup_idx, &methodObj)) {
33301       NSF_PROFILE_TIME_DATA;
33302       /*fprintf(stderr, "RECREATE calls cleanup directly for object %s\n", ObjectName(object));*/
33303       NSF_PROFILE_CALL(interp, object, Nsf_SystemMethodOpts[NSF_o_cleanup_idx]);
33304       result = NsfOCleanupMethod(interp, object);
33305       NSF_PROFILE_EXIT(interp, object, Nsf_SystemMethodOpts[NSF_o_cleanup_idx]);
33306     } else {
33307       /*NsfObjectSystem *osPtr = GetObjectSystem(object);
33308       fprintf(stderr, "RECREATE calls method cleanup for object %p %s OS %s\n",
33309               object, ObjectName(object), ObjectName(&osPtr->rootClass->object));*/
33310       result = CallMethod(object, interp, methodObj,
33311                           2, NULL, NSF_CM_IGNORE_PERMISSIONS|NSF_CSC_IMMEDIATE);
33312     }
33313   }
33314 
33315   /*
33316    * Second: if cleanup was successful, initialize the object as usual.
33317    */
33318   if (likely(result == TCL_OK)) {
33319     result = DoObjInitialization(interp, object, objc, objv);
33320     if (likely(result == TCL_OK)) {
33321       Tcl_SetObjResult(interp, object->cmdName);
33322     } else {
33323       /* fprintf(stderr, "recreate DoObjInitialization returned %d\n", result);*/
33324     }
33325   }
33326   return result;
33327 }
33328 
33329 static int
NsfCRecreateMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * objectNameObj,int trailingObjc,Tcl_Obj * const trailingObjv[])33330 NsfCRecreateMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *objectNameObj,
33331                    int trailingObjc, Tcl_Obj *const trailingObjv[]) {
33332   NsfObject *object;
33333 
33334   nonnull_assert(interp != NULL);
33335   nonnull_assert(class != NULL);
33336   nonnull_assert(objectNameObj != NULL);
33337 
33338   if (GetObjectFromObj(interp, objectNameObj, &object) != TCL_OK) {
33339     return NsfPrintError(interp, "can't recreate non existing object %s", ObjStr(objectNameObj));
33340   }
33341   return RecreateObject(interp, class, object, trailingObjc, trailingObjv);
33342 }
33343 
33344 /*
33345 classMethod superclass NsfCSuperclassMethod {
33346   {-argName "superclasses" -required 0 -type tclobj}
33347 }
33348 */
33349 static int
NsfCSuperclassMethod(Tcl_Interp * interp,NsfClass * class,Tcl_Obj * superclassesObj)33350 NsfCSuperclassMethod(Tcl_Interp *interp, NsfClass *class, Tcl_Obj *superclassesObj) {
33351 
33352   nonnull_assert(interp != NULL);
33353   nonnull_assert(class != NULL);
33354 
33355   return NsfRelationSetCmd(interp, &class->object, RelationtypeSuperclassIdx, superclassesObj);
33356 }
33357 
33358 /***********************************************************************
33359  * End Class Methods
33360  ***********************************************************************/
33361 
33362 static MethodtypeIdx_t
AggregatedMethodType(MethodtypeIdx_t methodType)33363 AggregatedMethodType(MethodtypeIdx_t methodType) {
33364   switch (methodType) {
33365   case MethodtypeNULL: /* default */
33366   case MethodtypeAllIdx:
33367     methodType = NSF_METHODTYPE_ALL;
33368     break;
33369   case MethodtypeScriptedIdx:
33370     /*methodType = NSF_METHODTYPE_SCRIPTED|NSF_METHODTYPE_ALIAS;*/
33371     methodType = NSF_METHODTYPE_SCRIPTED;
33372     break;
33373   case MethodtypeBuiltinIdx:
33374     methodType = NSF_METHODTYPE_BUILTIN|NSF_METHODTYPE_OBJECT;
33375     break;
33376   case MethodtypeForwarderIdx:
33377     methodType = NSF_METHODTYPE_FORWARDER;
33378     break;
33379   case MethodtypeAliasIdx:
33380     methodType = NSF_METHODTYPE_ALIAS;
33381     break;
33382   case MethodtypeSetterIdx:
33383     methodType = NSF_METHODTYPE_SETTER;
33384     break;
33385   case MethodtypeObjectIdx:
33386     methodType = NSF_METHODTYPE_OBJECT;
33387     break;
33388   case MethodtypeNsfprocIdx:
33389     methodType = NSF_METHODTYPE_NSFPROC;
33390     break;
33391   default:
33392     methodType = 0;
33393     break;
33394   }
33395 
33396   return methodType;
33397 }
33398 
33399 /***********************************************************************
33400  * Begin Object Info Methods
33401  ***********************************************************************/
33402 /*
33403 objectInfoMethod baseclass NsfObjInfoBaseclassMethod {
33404 }
33405 */
33406 
33407 static int
NsfObjInfoBaseclassMethod(Tcl_Interp * interp,NsfObject * object)33408 NsfObjInfoBaseclassMethod(Tcl_Interp *interp, NsfObject *object) {
33409   NsfObjectSystem *osPtr;
33410 
33411   nonnull_assert(interp != NULL);
33412   nonnull_assert(object != NULL);
33413 
33414   osPtr = GetObjectSystem(object);
33415   assert(osPtr != NULL);
33416 
33417   Tcl_SetObjResult(interp, osPtr->rootClass->object.cmdName);
33418 
33419   return TCL_OK;
33420 }
33421 /*
33422 objectInfoMethod children NsfObjInfoChildrenMethod {
33423   {-argName "-type" -required 0 -nrargs 1 -type class}
33424   {-argName "pattern" -required 0}
33425 }
33426 */
33427 static int
NsfObjInfoChildrenMethod(Tcl_Interp * interp,NsfObject * object,NsfClass * typeClass,const char * pattern)33428 NsfObjInfoChildrenMethod(Tcl_Interp *interp, NsfObject *object, NsfClass *typeClass, const char *pattern) {
33429 
33430   nonnull_assert(interp != NULL);
33431   nonnull_assert(object != NULL);
33432 
33433   return ListChildren(interp, object, pattern, NSF_FALSE, typeClass);
33434 }
33435 
33436 /*
33437 objectInfoMethod class NsfObjInfoClassMethod {
33438 }
33439 */
33440 static int
NsfObjInfoClassMethod(Tcl_Interp * interp,NsfObject * object)33441 NsfObjInfoClassMethod(Tcl_Interp *interp, NsfObject *object) {
33442 
33443   nonnull_assert(interp != NULL);
33444   nonnull_assert(object != NULL);
33445 
33446   Tcl_SetObjResult(interp, object->cl->object.cmdName);
33447   return TCL_OK;
33448 }
33449 
33450 /*
33451 objectInfoMethod filterguard NsfObjInfoFilterguardMethod {
33452   {-argName "filter" -required 1}
33453 }
33454 */
33455 static int
NsfObjInfoFilterguardMethod(Tcl_Interp * interp,NsfObject * object,const char * filter)33456 NsfObjInfoFilterguardMethod(Tcl_Interp *interp, NsfObject *object, const char *filter) {
33457 
33458   nonnull_assert(interp != NULL);
33459   nonnull_assert(object != NULL);
33460   nonnull_assert(filter != NULL);
33461 
33462   return (object->opt != NULL) ? GuardList(interp, object->opt->objFilters, filter) : TCL_OK;
33463 }
33464 
33465 /*
33466 objectInfoMethod filters NsfObjInfoFiltersMethod {
33467   {-argName "-guards" -nrargs 0 -type switch}
33468   {-argName "pattern"}
33469 }
33470 */
33471 static int
NsfObjInfoFiltersMethod(Tcl_Interp * interp,NsfObject * object,int withGuards,const char * pattern)33472 NsfObjInfoFiltersMethod(Tcl_Interp *interp, NsfObject *object, int withGuards,
33473                         const char *pattern) {
33474   NsfObjectOpt *opt;
33475 
33476   nonnull_assert(interp != NULL);
33477   nonnull_assert(object != NULL);
33478 
33479   opt = object->opt;
33480   return (opt != NULL) ? FilterInfo(interp, opt->objFilters, pattern, (withGuards == 1), NSF_FALSE) : TCL_OK;
33481 }
33482 
33483 /*
33484 objectInfoMethod forward NsfObjInfoForwardMethod {
33485   {-argName "-definition"}
33486   {-argName "pattern"}
33487 }
33488 */
33489 static int
NsfObjInfoForwardMethod(Tcl_Interp * interp,NsfObject * object,int withDefinition,const char * pattern)33490 NsfObjInfoForwardMethod(Tcl_Interp *interp, NsfObject *object, int withDefinition, const char *pattern) {
33491 
33492   nonnull_assert(interp != NULL);
33493   nonnull_assert(object != NULL);
33494 
33495   return (object->nsPtr != NULL) ?
33496     ListForward(interp, Tcl_Namespace_cmdTablePtr(object->nsPtr), pattern, withDefinition) :
33497     TCL_OK;
33498 }
33499 
33500 /*
33501 objectInfoMethod hasmixin NsfObjInfoHasMixinMethod {
33502   {-argName "class" -required 1 -type class}
33503 }
33504 */
33505 static int
NsfObjInfoHasMixinMethod(Tcl_Interp * interp,NsfObject * object,NsfClass * class)33506 NsfObjInfoHasMixinMethod(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
33507 
33508   nonnull_assert(interp != NULL);
33509   nonnull_assert(object != NULL);
33510   nonnull_assert(class != NULL);
33511 
33512   Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (int)HasMixin(interp, object, class));
33513   return TCL_OK;
33514 }
33515 
33516 /*
33517 objectInfoMethod hasnamespace NsfObjInfoHasnamespaceMethod {
33518 }
33519 */
33520 static int
NsfObjInfoHasnamespaceMethod(Tcl_Interp * interp,NsfObject * object)33521 NsfObjInfoHasnamespaceMethod(Tcl_Interp *interp, NsfObject *object) {
33522 
33523   nonnull_assert(interp != NULL);
33524   nonnull_assert(object != NULL);
33525 
33526   Tcl_SetBooleanObj(Tcl_GetObjResult(interp), object->nsPtr != NULL);
33527   return TCL_OK;
33528 }
33529 
33530 /*
33531 objectInfoMethod hastype NsfObjInfoHasTypeMethod {
33532   {-argName "class" -required 1 -type class}
33533 }
33534 */
33535 static int
NsfObjInfoHasTypeMethod(Tcl_Interp * interp,NsfObject * object,NsfClass * class)33536 NsfObjInfoHasTypeMethod(Tcl_Interp *interp, NsfObject *object, NsfClass *class) {
33537 
33538   nonnull_assert(interp != NULL);
33539   nonnull_assert(object != NULL);
33540   nonnull_assert(class != NULL);
33541 
33542   Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (int)IsSubType(object->cl, class));
33543   return TCL_OK;
33544 }
33545 
33546 /*
33547 objectInfoMethod lookupfilter NsfObjInfoLookupFilterMethod {
33548   {-argName "filter" -required 1}
33549 }
33550 */
33551 static int
NsfObjInfoLookupFilterMethod(Tcl_Interp * interp,NsfObject * object,const char * filter)33552 NsfObjInfoLookupFilterMethod(Tcl_Interp *interp, NsfObject *object, const char *filter) {
33553   const char *filterName;
33554   NsfCmdList *cmdList;
33555   NsfClass *fcl;
33556 
33557   nonnull_assert(interp != NULL);
33558   nonnull_assert(object != NULL);
33559   nonnull_assert(filter != NULL);
33560 
33561   /*
33562    * Searches for filter on [self] and returns fully qualified name if it is
33563    * not found it returns an empty string.
33564    */
33565   Tcl_ResetResult(interp);
33566 
33567   if ((object->flags & NSF_FILTER_ORDER_VALID) == 0u) {
33568     FilterComputeDefined(interp, object);
33569   }
33570   if ((object->flags & NSF_FILTER_ORDER_DEFINED) == 0u) {
33571     return TCL_OK;
33572   }
33573   for (cmdList = object->filterOrder; cmdList;  cmdList = cmdList->nextPtr) {
33574     filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr);
33575     if (filterName[0] == filter[0] && !strcmp(filterName, filter)) {
33576       break;
33577     }
33578   }
33579 
33580   if (cmdList == NULL) {
33581     return TCL_OK;
33582   }
33583   fcl = cmdList->clorobj;
33584   Tcl_SetObjResult(interp, MethodHandleObj((NsfObject *)fcl, !NsfObjectIsClass(&fcl->object), filterName));
33585   return TCL_OK;
33586 }
33587 
33588 
33589 /*
33590 objectInfoMethod lookupfilters NsfObjInfoLookupFiltersMethod {
33591   {-argName "-guards" -nrargs 0 -type switch}
33592   {-argName "pattern"}
33593 }
33594 */
33595 static int
NsfObjInfoLookupFiltersMethod(Tcl_Interp * interp,NsfObject * object,int withGuards,const char * pattern)33596 NsfObjInfoLookupFiltersMethod(Tcl_Interp *interp, NsfObject *object, int withGuards, const char *pattern) {
33597 
33598   nonnull_assert(interp != NULL);
33599   nonnull_assert(object != NULL);
33600 
33601   if ((object->flags & NSF_FILTER_ORDER_VALID) == 0u) {
33602     FilterComputeDefined(interp, object);
33603   }
33604   return FilterInfo(interp, object->filterOrder, pattern, (withGuards == 1), NSF_TRUE);
33605 }
33606 
33607 /*
33608 objectInfoMethod lookupmethod NsfObjInfoLookupMethodMethod {
33609   {-argName "name" -required 1 -type tclobj}
33610 }
33611 */
33612 static int
NsfObjInfoLookupMethodMethod(Tcl_Interp * interp,NsfObject * object,Tcl_Obj * nameObj)33613 NsfObjInfoLookupMethodMethod(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj) {
33614   NsfClass *classPtr = NULL;
33615   Tcl_Command cmd;
33616 
33617   nonnull_assert(interp != NULL);
33618   nonnull_assert(object != NULL);
33619   nonnull_assert(nameObj != NULL);
33620 
33621   cmd = ObjectFindMethod(interp, object, nameObj, &classPtr);
33622   if (likely(cmd != NULL)) {
33623     NsfObject *pobj = (classPtr != NULL) ? &classPtr->object : object;
33624     int perObject = (classPtr == NULL);
33625 
33626     ListMethod(interp, pobj, pobj, ObjStr(nameObj), cmd,
33627                InfomethodsubcmdRegistrationhandleIdx,
33628                NULL, NULL, (perObject == 1));
33629   }
33630   return TCL_OK;
33631 }
33632 
33633 
33634 static int ListMethodKeysClassList(Tcl_Interp *interp, NsfClasses *classListPtr,
33635                         DefinitionsourceIdx_t withSource, const char *pattern,
33636                         MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection,
33637                         bool withPath, Tcl_HashTable *dups,
33638                         NsfObject *object, bool withPer_object)
33639   nonnull(1) nonnull(8) nonnull(9);
33640 
33641 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)33642 ListMethodKeysClassList(Tcl_Interp *interp, NsfClasses *classListPtr,
33643                         DefinitionsourceIdx_t withSource, const char *pattern,
33644                         MethodtypeIdx_t methodType, CallprotectionIdx_t withCallprotection,
33645                         bool withPath, Tcl_HashTable *dups,
33646                         NsfObject *object, bool withPer_object) {
33647 
33648   nonnull_assert(interp != NULL);
33649   nonnull_assert(dups != NULL);
33650   nonnull_assert(object != NULL);
33651 
33652   /*
33653    * Append method keys from inheritance order
33654    */
33655   for (; classListPtr != NULL; classListPtr = classListPtr->nextPtr) {
33656     Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(classListPtr->cl->nsPtr);
33657 
33658     if (!MethodSourceMatches(withSource, classListPtr->cl, NULL)) {
33659       continue;
33660     }
33661 
33662     ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType,
33663                    withCallprotection, withPath,
33664                    dups, object, withPer_object);
33665   }
33666   return TCL_OK;
33667 }
33668 
33669 /*
33670 objectInfoMethod lookupmethods NsfObjInfoLookupMethodsMethod {
33671   {-argName "-callprotection" -type "all|public|protected|private" -default all}
33672   {-argName "-incontext" -nrargs 0}
33673   {-argName "-type" -typeName "methodtype" -type "all|scripted|builtin|alias|forwarder|object|setter|nsfproc"}
33674   {-argName "-nomixins" -nrargs 0}
33675   {-argName "-path" -nrargs 0}
33676   {-argName "-source" -type "all|application|system" -default all}
33677   {-argName "pattern" -required 0}
33678 }
33679 */
33680 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)33681 NsfObjInfoLookupMethodsMethod(Tcl_Interp *interp, NsfObject *object,
33682                               CallprotectionIdx_t withCallprotection,
33683                               int withIncontext,
33684                               MethodtypeIdx_t withType,
33685                               int withNomixins,
33686                               int withPath,
33687                               DefinitionsourceIdx_t withSource,
33688                               const char *pattern) {
33689   int             result;
33690   bool            withPer_object = NSF_TRUE;
33691   Tcl_HashTable   dupsTable, *dups = &dupsTable;
33692   MethodtypeIdx_t methodType = AggregatedMethodType(withType);
33693 
33694   nonnull_assert(interp != NULL);
33695   nonnull_assert(object != NULL);
33696 
33697   /*
33698    * TODO: we could make this faster for patterns without meta-chars
33699    * by letting ListMethodKeys() to signal us when an entry was found.
33700    * we wait, until the we decided about "info methods defined"
33701    * vs. "info method search" vs. "info defined" etc.
33702    */
33703   if (withCallprotection == CallprotectionNULL) {
33704     withCallprotection = CallprotectionPublicIdx;
33705   }
33706   if (withSource == DefinitionsourceNULL) {
33707     withSource = DefinitionsourceAllIdx;
33708   }
33709 
33710   Tcl_InitHashTable(dups, TCL_STRING_KEYS);
33711   if (object->nsPtr != NULL) {
33712     Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(object->nsPtr);
33713 
33714     if (MethodSourceMatches(withSource, NULL, object)) {
33715       ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType,
33716                      withCallprotection, (withPath == 1),
33717                      dups, object, withPer_object);
33718     }
33719   }
33720 
33721   if (withNomixins == 0) {
33722     if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
33723       MixinComputeDefined(interp, object);
33724     }
33725     if ((object->flags & NSF_MIXIN_ORDER_DEFINED_AND_VALID) != 0u) {
33726       NsfCmdList *ml;
33727 
33728       for (ml = object->mixinOrder; ml; ml = ml->nextPtr) {
33729         int guardOk = TCL_OK;
33730         NsfClass *mixin = NsfGetClassFromCmdPtr(ml->cmdPtr);
33731 
33732         assert(mixin != NULL);
33733         if (withIncontext != 0) {
33734           if (!RUNTIME_STATE(interp)->guardCount && ml->clientData) {
33735             guardOk = GuardCall(object, interp, ml->clientData, NULL);
33736           }
33737         }
33738         if (mixin && guardOk == TCL_OK) {
33739           Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(mixin->nsPtr);
33740           if (!MethodSourceMatches(withSource, mixin, NULL)) {
33741             continue;
33742           }
33743           ListMethodKeys(interp, cmdTablePtr, NULL, pattern, methodType,
33744                          withCallprotection, withPath,
33745                          dups, object, withPer_object);
33746         }
33747       }
33748     }
33749   }
33750 
33751   result = ListMethodKeysClassList(interp, PrecedenceOrder(object->cl),
33752                                    withSource, pattern,
33753                                    methodType, withCallprotection,
33754                                    (withPath == 1), dups, object, withPer_object);
33755 
33756   Tcl_DeleteHashTable(dups);
33757   return result;
33758 }
33759 
33760 /*
33761 objectInfoMethod lookupmixins NsfObjInfoLookupMixinsMethod {
33762   {-argName "-guards" -nrargs 0 -type switch}
33763   {-argName "pattern" -type objpattern}
33764 }
33765 */
33766 static int
NsfObjInfoLookupMixinsMethod(Tcl_Interp * interp,NsfObject * object,int withGuards,const char * patternString,NsfObject * patternObject)33767 NsfObjInfoLookupMixinsMethod(Tcl_Interp *interp, NsfObject *object, int withGuards,
33768                              const char *patternString, NsfObject *patternObject) {
33769   nonnull_assert(interp != NULL);
33770   nonnull_assert(object != NULL);
33771 
33772   if ((object->flags & NSF_MIXIN_ORDER_VALID) == 0u) {
33773     MixinComputeDefined(interp, object);
33774   }
33775   return MixinInfo(interp, object->mixinOrder, patternString, (withGuards == 1), patternObject);
33776 }
33777 
33778 
33779 /*
33780 objectInfoMethod lookupslots NsfObjInfoLookupSlotsMethod {
33781   {-argName "-source" -nrargs 1 -type "all|application|system" -default all}
33782   {-argName "-type" -required 0 -nrargs 1 -type class}
33783   {-argName "pattern" -required 0}
33784 }
33785 */
33786 static int
NsfObjInfoLookupSlotsMethod(Tcl_Interp * interp,NsfObject * object,DefinitionsourceIdx_t withSource,NsfClass * typeClass,const char * pattern)33787 NsfObjInfoLookupSlotsMethod(Tcl_Interp *interp, NsfObject *object,
33788                             DefinitionsourceIdx_t withSource,
33789                             NsfClass *typeClass,
33790                             const char *pattern) {
33791   Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
33792   NsfClasses *precedenceList, *clPtr;
33793   Tcl_HashTable slotTable;
33794 
33795   nonnull_assert(interp != NULL);
33796   nonnull_assert(object != NULL);
33797 
33798   precedenceList = ComputePrecedenceList(interp, object, NULL /* pattern*/,
33799                                          NSF_TRUE, NSF_TRUE);
33800   assert(precedenceList != NULL);
33801 
33802   if (withSource == 0) {
33803     withSource = 1;
33804   }
33805 
33806   Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS);
33807   MEM_COUNT_ALLOC("Tcl_InitHashTable", &slotTable);
33808 
33809   /*
33810    * First add the per-object slot objects.
33811    */
33812   if (MethodSourceMatches(withSource, NULL, object)) {
33813     AddSlotObjects(interp, object, "::per-object-slot", &slotTable,
33814                    typeClass, pattern, listObj);
33815   }
33816 
33817   /*
33818    * Then add the class provided slot objects.
33819    */
33820   for (clPtr = precedenceList; likely(clPtr != NULL); clPtr = clPtr->nextPtr) {
33821     if (MethodSourceMatches(withSource, clPtr->cl, NULL)) {
33822       AddSlotObjects(interp, &clPtr->cl->object, "::slot", &slotTable,
33823                      typeClass, pattern, listObj);
33824     }
33825   }
33826 
33827   Tcl_DeleteHashTable(&slotTable);
33828   MEM_COUNT_FREE("Tcl_InitHashTable", &slotTable);
33829 
33830   NsfClassListFree(precedenceList);
33831   Tcl_SetObjResult(interp, listObj);
33832 
33833   return TCL_OK;
33834 }
33835 
33836 /*
33837 objectInfoMethod method NsfObjInfoMethodMethod {
33838   {-argName "infomethodsubcmd" -type "args|body|definition|exists|registrationhandle|definitionhandle|origin|parameter|syntax|type|precondition|postcondition|submethods"}
33839   {-argName "name" -required 1 -type tclobj}
33840 }
33841 */
33842 static int
NsfObjInfoMethodMethod(Tcl_Interp * interp,NsfObject * object,InfomethodsubcmdIdx_t subcmd,Tcl_Obj * nameObj)33843 NsfObjInfoMethodMethod(Tcl_Interp *interp, NsfObject *object,
33844                        InfomethodsubcmdIdx_t subcmd, Tcl_Obj *nameObj) {
33845   return ListMethodResolve(interp, subcmd, NULL, NULL, object->nsPtr, object, nameObj, NSF_FALSE);
33846 }
33847 
33848 /*
33849 objectInfoMethod methods NsfObjInfoMethodsMethod {
33850   {-argName "-callprotection" -type "all|public|protected|private" -default all}
33851   {-argName "-type" -nrargs 1 -typeName "methodtype" -type "all|scripted|builtin|alias|forwarder|object|setter"}
33852   {-argName "-path" -nrargs 0}
33853   {-argName "pattern"}
33854 }
33855 */
33856 static int
NsfObjInfoMethodsMethod(Tcl_Interp * interp,NsfObject * object,CallprotectionIdx_t withCallprotection,MethodtypeIdx_t withType,int withPath,const char * pattern)33857 NsfObjInfoMethodsMethod(Tcl_Interp *interp, NsfObject *object,
33858                         CallprotectionIdx_t withCallprotection,
33859                         MethodtypeIdx_t withType,
33860                         int withPath,
33861                         const char *pattern) {
33862 
33863   nonnull_assert(interp != NULL);
33864   nonnull_assert(object != NULL);
33865 
33866   return ListDefinedMethods(interp, object, pattern, 1 /* per-object */,
33867                             AggregatedMethodType(withType), withCallprotection,
33868                             withPath);
33869 }
33870 
33871 /*
33872 objectInfoMethod mixins NsfObjInfoMixinsMethod {
33873   {-argName "-guards" -nrargs 0 -type switch}
33874   {-argName "pattern" -type objpattern}
33875 }
33876 */
33877 static int
NsfObjInfoMixinsMethod(Tcl_Interp * interp,NsfObject * object,int withGuards,const char * patternString,NsfObject * patternObject)33878 NsfObjInfoMixinsMethod(Tcl_Interp *interp, NsfObject *object, int withGuards,
33879                        const char *patternString, NsfObject *patternObject) {
33880   nonnull_assert(interp != NULL);
33881   nonnull_assert(object != NULL);
33882 
33883   return (object->opt != NULL) ?
33884     MixinInfo(interp, object->opt->objMixins, patternString, (withGuards == 1), patternObject) :
33885     TCL_OK;
33886 }
33887 
33888 /*
33889 objectInfoMethod mixinguard NsfObjInfoMixinguardMethod {
33890   {-argName "mixin"  -required 1}
33891 }
33892 */
33893 static int
NsfObjInfoMixinguardMethod(Tcl_Interp * interp,NsfObject * object,const char * mixin)33894 NsfObjInfoMixinguardMethod(Tcl_Interp *interp, NsfObject *object, const char *mixin) {
33895 
33896   nonnull_assert(interp != NULL);
33897   nonnull_assert(object != NULL);
33898   nonnull_assert(mixin != NULL);
33899 
33900   return (object->opt != NULL) ? GuardList(interp, object->opt->objMixins, mixin) : TCL_OK;
33901 }
33902 
33903 /*
33904 objectInfoMethod name NsfObjInfoNameMethod {
33905 }
33906 */
33907 static int
NsfObjInfoNameMethod(Tcl_Interp * interp,NsfObject * object)33908 NsfObjInfoNameMethod(Tcl_Interp *interp, NsfObject *object) {
33909 
33910   nonnull_assert(interp != NULL);
33911   nonnull_assert(object != NULL);
33912 
33913   Tcl_SetObjResult(interp,  Tcl_NewStringObj(Tcl_GetCommandName(interp, object->id), -1));
33914   return TCL_OK;
33915 }
33916 
33917 /*
33918 objectInfoMethod parent NsfObjInfoParentMethod {
33919 }
33920 */
33921 static int
NsfObjInfoParentMethod(Tcl_Interp * interp,NsfObject * object)33922 NsfObjInfoParentMethod(Tcl_Interp *interp, NsfObject *object) {
33923 
33924   nonnull_assert(interp != NULL);
33925   nonnull_assert(object != NULL);
33926 
33927   if (object->id != NULL) {
33928     Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(object->id);
33929     Tcl_SetObjResult(interp, Tcl_NewStringObj((nsPtr != NULL) ? nsPtr->fullName : "", -1));
33930   }
33931   return TCL_OK;
33932 }
33933 
33934 /*
33935 objectInfoMethod precedence NsfObjInfoPrecedenceMethod {
33936   {-argName "-intrinsic"}
33937   {-argName "pattern" -required 0}
33938 }
33939 */
33940 static int
NsfObjInfoPrecedenceMethod(Tcl_Interp * interp,NsfObject * object,int withIntrinsic,const char * pattern)33941 NsfObjInfoPrecedenceMethod(Tcl_Interp *interp, NsfObject *object,
33942                            int withIntrinsic, const char *pattern) {
33943   NsfClasses *precedenceList, *pl;
33944   Tcl_Obj    *resultObj = Tcl_NewObj();
33945 
33946   nonnull_assert(interp != NULL);
33947   nonnull_assert(object != NULL);
33948 
33949   precedenceList = ComputePrecedenceList(interp, object, pattern,
33950                                          (withIntrinsic == 0), NSF_TRUE);
33951   for (pl = precedenceList; pl != NULL; pl = pl->nextPtr) {
33952     assert(pl->cl != NULL);
33953     Tcl_ListObjAppendElement(interp, resultObj, pl->cl->object.cmdName);
33954   }
33955   if (precedenceList != NULL) {
33956     NsfClassListFree(precedenceList);
33957   }
33958 
33959   Tcl_SetObjResult(interp, resultObj);
33960   return TCL_OK;
33961 }
33962 
33963 /*
33964 objectInfoMethod slotobjects NsfObjInfoSlotobjectsMethod {
33965   {-argName "-type" -required 0 -nrargs 1 -type class}
33966   {-argName "pattern" -required 0}
33967 }
33968 */
33969 static int
NsfObjInfoSlotobjectsMethod(Tcl_Interp * interp,NsfObject * object,NsfClass * typeClass,const char * pattern)33970 NsfObjInfoSlotobjectsMethod(Tcl_Interp *interp, NsfObject *object,
33971                       NsfClass *typeClass, const char *pattern) {
33972   Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
33973 
33974   nonnull_assert(interp != NULL);
33975   nonnull_assert(object != NULL);
33976 
33977   AddSlotObjects(interp, object, "::per-object-slot", NULL,
33978                  typeClass, pattern, listObj);
33979 
33980   Tcl_SetObjResult(interp, listObj);
33981   return TCL_OK;
33982 }
33983 
33984 
33985 /*
33986 objectInfoMethod vars NsfObjInfoVarsMethod {
33987   {-argName "pattern" -required 0}
33988 }
33989 */
33990 static int
NsfObjInfoVarsMethod(Tcl_Interp * interp,NsfObject * object,const char * pattern)33991 NsfObjInfoVarsMethod(Tcl_Interp *interp, NsfObject *object, const char *pattern) {
33992   Tcl_Obj         *okList;
33993   TclVarHashTable *varTablePtr;
33994 
33995   nonnull_assert(interp != NULL);
33996   nonnull_assert(object != NULL);
33997 
33998   okList = Tcl_NewListObj(0, NULL);
33999 
34000   varTablePtr = (object->nsPtr != NULL) ?
34001     Tcl_Namespace_varTablePtr(object->nsPtr) :
34002     object->varTablePtr;
34003 
34004   /*
34005    * It is possible, that both, object->nsPtr and object->varTablePtr are
34006    * NULL.
34007    */
34008   if (likely(varTablePtr != NULL)) {
34009     Tcl_Obj  *varList, *element;
34010     int       i, length;
34011 
34012     ListVarKeys(interp, TclVarHashTablePtr(varTablePtr), pattern);
34013     varList = Tcl_GetObjResult(interp);
34014 
34015     Tcl_ListObjLength(interp, varList, &length);
34016     for (i = 0; i < length; i++) {
34017       Tcl_ListObjIndex(interp, varList, i, &element);
34018       if (VarExists(interp, object, ObjStr(element), NULL, NSF_VAR_REQUIRE_DEFINED)) {
34019         Tcl_ListObjAppendElement(interp, okList, element);
34020       } else {
34021         /*fprintf(stderr, "must ignore '%s' %d\n", ObjStr(element), i);*/
34022         /*Tcl_ListObjReplace(interp, varList, i, 1, 0, NULL);*/
34023       }
34024     }
34025   }
34026 
34027   Tcl_SetObjResult(interp, okList);
34028   return TCL_OK;
34029 }
34030 /***********************************************************************
34031  * End Object Info Methods
34032  ***********************************************************************/
34033 
34034 /***********************************************************************
34035  * Begin Class Info methods
34036  ***********************************************************************/
34037 
34038 /*
34039 classInfoMethod filterguard NsfClassInfoFilterguardMethod {
34040   {-argName "filter" -required 1}
34041   }
34042 */
34043 static int
NsfClassInfoFilterguardMethod(Tcl_Interp * interp,NsfClass * class,const char * filter)34044 NsfClassInfoFilterguardMethod(Tcl_Interp *interp, NsfClass *class, const char *filter) {
34045 
34046   nonnull_assert(interp != NULL);
34047   nonnull_assert(class != NULL);
34048   nonnull_assert(filter != NULL);
34049 
34050   return (class->opt != NULL) ? GuardList(interp, class->opt->classFilters, filter) : TCL_OK;
34051 }
34052 
34053 /*
34054 classInfoMethod filters NsfClassInfoFiltersMethod {
34055   {-argName "-guards" -nrargs 0 -type switch}
34056   {-argName "pattern"}
34057 }
34058 */
34059 static int
NsfClassInfoFiltersMethod(Tcl_Interp * interp,NsfClass * class,int withGuards,const char * pattern)34060 NsfClassInfoFiltersMethod(Tcl_Interp *interp, NsfClass *class,
34061                           int withGuards, const char *pattern) {
34062 
34063   nonnull_assert(interp != NULL);
34064   nonnull_assert(class != NULL);
34065 
34066   return (class->opt != NULL) ?
34067     FilterInfo(interp, class->opt->classFilters, pattern, (withGuards == 1), NSF_FALSE) : TCL_OK;
34068 }
34069 
34070 /*
34071 classInfoMethod forward NsfClassInfoForwardMethod {
34072   {-argName "-definition"}
34073   {-argName "pattern"}
34074 }
34075 */
34076 static int
NsfClassInfoForwardMethod(Tcl_Interp * interp,NsfClass * class,int withDefinition,const char * pattern)34077 NsfClassInfoForwardMethod(Tcl_Interp *interp, NsfClass *class,
34078                           int withDefinition, const char *pattern) {
34079 
34080   nonnull_assert(interp != NULL);
34081   nonnull_assert(class != NULL);
34082 
34083   return ListForward(interp, Tcl_Namespace_cmdTablePtr(class->nsPtr), pattern, withDefinition);
34084 }
34085 
34086 /*
34087 classInfoMethod heritage NsfClassInfoHeritageMethod {
34088   {-argName "pattern"}
34089 }
34090 */
34091 static int
NsfClassInfoHeritageMethod(Tcl_Interp * interp,NsfClass * class,const char * pattern)34092 NsfClassInfoHeritageMethod(Tcl_Interp *interp, NsfClass *class, const char *pattern) {
34093   NsfClasses *pl, *intrinsic, *checkList = NULL, *mixinClasses = NULL;
34094   Tcl_Obj *resultObj;
34095 
34096   nonnull_assert(interp != NULL);
34097   nonnull_assert(class != NULL);
34098 
34099   resultObj = Tcl_NewObj();
34100   intrinsic = PrecedenceOrder(class);
34101 
34102   NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
34103   for (pl = mixinClasses; pl != NULL; pl = pl->nextPtr) {
34104     if (NsfClassListFind(pl->nextPtr, pl->cl) == NULL &&
34105         NsfClassListFind(intrinsic, pl->cl) == NULL) {
34106       AppendMatchingElement(interp, resultObj, pl->cl->object.cmdName, pattern);
34107     }
34108   }
34109 
34110   if (intrinsic != NULL) {
34111     for (pl = intrinsic->nextPtr; pl != NULL; pl = pl->nextPtr) {
34112       AppendMatchingElement(interp, resultObj, pl->cl->object.cmdName, pattern);
34113     }
34114   }
34115 
34116   if (mixinClasses != NULL) {
34117     NsfClassListFree(mixinClasses);
34118   }
34119   if (checkList != NULL) {
34120     NsfClassListFree(checkList);
34121   }
34122 
34123   Tcl_SetObjResult(interp, resultObj);
34124   return TCL_OK;
34125 }
34126 
34127 
34128 /*
34129  *----------------------------------------------------------------------
34130  *
34131  * InstancesFromClassList --
34132  *
34133  *      Collect all instances of the classes of the provided class list in the
34134  *      returned result object.
34135  *
34136  * Results:
34137  *      Tcl_Obj containing a list of instances or a single instance
34138  *
34139  * Side effects:
34140  *      Updated resultObj.
34141  *
34142  *----------------------------------------------------------------------
34143  */
34144 
34145 static Tcl_Obj *InstancesFromClassList(
34146     Tcl_Interp *interp, NsfClasses *subClasses,
34147     const char *pattern, NsfObject *matchObject
34148 ) nonnull(1) nonnull(2) returns_nonnull;
34149 
34150 static Tcl_Obj *
InstancesFromClassList(Tcl_Interp * interp,NsfClasses * subClasses,const char * pattern,NsfObject * matchObject)34151 InstancesFromClassList(
34152     Tcl_Interp *interp, NsfClasses *subClasses,
34153     const char *pattern, NsfObject *matchObject
34154 ) {
34155   Tcl_Obj *resultObj = Tcl_NewObj();
34156 
34157   nonnull_assert(interp != NULL);
34158   nonnull_assert(subClasses != NULL);
34159 
34160   do {
34161     Tcl_HashTable *tablePtr = &subClasses->cl->instances;
34162     const Tcl_HashEntry *hPtr;
34163     Tcl_HashSearch search;
34164 
34165     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
34166          hPtr != NULL;
34167          hPtr = Tcl_NextHashEntry(&search)) {
34168       NsfObject *inst = (NsfObject *) Tcl_GetHashKey(tablePtr, hPtr);
34169 
34170       if (matchObject != NULL && inst == matchObject) {
34171         Tcl_SetStringObj(resultObj, ObjStr(matchObject->cmdName), -1);
34172         return resultObj;
34173       }
34174       AppendMatchingElement(interp, resultObj, inst->cmdName, pattern);
34175     }
34176     subClasses = subClasses->nextPtr;
34177   } while (subClasses != NULL);
34178 
34179   return resultObj;
34180 }
34181 
34182 /*
34183 classInfoMethod instances NsfClassInfoInstancesMethod {
34184   {-argName "-closure" -nrargs 0}
34185   {-argName "pattern" -type objpattern}
34186 }
34187 */
34188 static int
NsfClassInfoInstancesMethod(Tcl_Interp * interp,NsfClass * class,int withClosure,const char * patternString,NsfObject * patternObject)34189 NsfClassInfoInstancesMethod(
34190     Tcl_Interp *interp, NsfClass *class,
34191     int withClosure, const char *patternString,
34192     NsfObject *patternObject
34193 ) {
34194   NsfClasses clElement, *subClasses;
34195 
34196   nonnull_assert(interp != NULL);
34197   nonnull_assert(class != NULL);
34198 
34199   if (withClosure != 0) {
34200     subClasses = TransitiveSubClasses(class);
34201   } else {
34202     subClasses = &clElement;
34203     clElement.cl = class;
34204     clElement.nextPtr = NULL;
34205   }
34206 
34207   Tcl_SetObjResult(interp, InstancesFromClassList(interp, subClasses, patternString, patternObject));
34208 
34209   if (withClosure != 0) {
34210     NsfClassListFree(subClasses);
34211   }
34212 
34213   return TCL_OK;
34214 }
34215 
34216 /*
34217 classInfoMethod method NsfClassInfoMethodMethod {
34218   {-argName "infomethodsubcmd" -type "args|body|definition|exists|registrationhandle|definitionhandle|origin|parameter|syntax|type|precondition|postcondition|submethods|returns"}
34219   {-argName "name" -required 1 -type tclobj}
34220 }
34221 */
34222 static int
NsfClassInfoMethodMethod(Tcl_Interp * interp,NsfClass * class,InfomethodsubcmdIdx_t subcmd,Tcl_Obj * nameObj)34223 NsfClassInfoMethodMethod(
34224     Tcl_Interp *interp, NsfClass *class,
34225     InfomethodsubcmdIdx_t subcmd, Tcl_Obj *nameObj
34226 ) {
34227   return ListMethodResolve(interp, subcmd, NULL, NULL, class->nsPtr, &class->object, nameObj, NSF_TRUE);
34228 }
34229 
34230 /*
34231 classInfoMethod methods NsfClassInfoMethodsMethod {
34232   {-argName "-callprotection" -type "all|public|protected|private" -default all}
34233   {-argName "-closure" -nrargs 0}
34234   {-argName "-type" -typeName "methodtype" -nrargs 1 -type "all|scripted|builtin|alias|forwarder|object|setter"}
34235   {-argName "-path" -nrargs 0}
34236   {-argName "-source" -nrargs 1 -type "all|application|system"}
34237   {-argName "pattern"}
34238 }
34239 */
34240 static int
NsfClassInfoMethodsMethod(Tcl_Interp * interp,NsfClass * class,CallprotectionIdx_t withCallprotection,int withClosure,MethodtypeIdx_t withType,int withPath,DefinitionsourceIdx_t withSource,const char * pattern)34241 NsfClassInfoMethodsMethod(
34242     Tcl_Interp *interp, NsfClass *class,
34243     CallprotectionIdx_t withCallprotection,
34244     int withClosure,
34245     MethodtypeIdx_t withType,
34246     int withPath,
34247     DefinitionsourceIdx_t withSource,
34248     const char *pattern
34249 ) {
34250   nonnull_assert(interp != NULL);
34251   nonnull_assert(class != NULL);
34252 
34253   if (withClosure != 0) {
34254     NsfClasses *checkList = NULL, *mixinClasses = NULL;
34255     Tcl_HashTable dupsTable, *dups = &dupsTable;
34256     int result;
34257 
34258 #if 0
34259     if (withCallprotection == CallprotectionNULL) {
34260       withCallprotection = CallprotectionPublicIdx;
34261     }
34262 #endif
34263     if (withSource == DefinitionsourceNULL) {
34264       withSource = DefinitionsourceAllIdx;
34265     }
34266 
34267     Tcl_InitHashTable(dups, TCL_STRING_KEYS);
34268     /*
34269      * Guards are ignored.
34270      */
34271     NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
34272     (void) ListMethodKeysClassList(interp, mixinClasses,
34273                                    withSource, pattern,
34274                                    AggregatedMethodType(withType), withCallprotection,
34275                                    withPath, dups, &class->object, NSF_FALSE);
34276     if (checkList != NULL) {
34277       NsfClassListFree(checkList);
34278     }
34279     if (mixinClasses != NULL) {
34280       NsfClassListFree(mixinClasses);
34281     }
34282 
34283     result = ListMethodKeysClassList(interp, PrecedenceOrder(class),
34284                                      withSource, pattern,
34285                                      AggregatedMethodType(withType), withCallprotection,
34286                                      withPath, dups, &class->object, NSF_FALSE);
34287 
34288     Tcl_DeleteHashTable(dups);
34289     return result;
34290   } else {
34291     if (withSource != 0) {
34292       return NsfPrintError(interp, "-source cannot be used without -closure\n");
34293     }
34294     return ListDefinedMethods(interp, &class->object, pattern, 0 /* per-object */,
34295                               AggregatedMethodType(withType), withCallprotection,
34296                               withPath);
34297   }
34298 }
34299 
34300 /*
34301 classInfoMethod mixins NsfClassInfoMixinsMethod {
34302   {-argName "-closure" -nrargs 0 -type switch}
34303   {-argName "-guards" -nrargs 0 -type switch}
34304   {-argName "-heritage" -nrargs 0 -type switch}
34305   {-argName "pattern" -type objpattern}
34306 }
34307 */
34308 static int
NsfClassInfoMixinsMethod(Tcl_Interp * interp,NsfClass * class,int withClosure,int withGuards,int withHeritage,const char * patternString,NsfObject * patternObject)34309 NsfClassInfoMixinsMethod(
34310     Tcl_Interp *interp, NsfClass *class,
34311     int withClosure, int withGuards, int withHeritage,
34312     const char *patternString, NsfObject *patternObject
34313 ) {
34314   NsfClassOpt *opt;
34315   Tcl_Obj *resultObj;
34316   int result = TCL_OK;
34317 
34318   nonnull_assert(interp != NULL);
34319   nonnull_assert(class != NULL);
34320 
34321   opt = class->opt;
34322   Tcl_ResetResult(interp);
34323   resultObj = Tcl_GetObjResult(interp);
34324 
34325   if (withHeritage != 0) {
34326     NsfClasses *checkList = NULL, *mixinClasses = NULL, *clPtr;
34327 
34328     if (withGuards != 0) {
34329       return NsfPrintError(interp, "-guards cannot be used together with -heritage\n");
34330     }
34331 
34332     NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
34333     for (clPtr = mixinClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
34334       if (NsfClassListFind(clPtr->nextPtr, clPtr->cl)) {
34335         continue;
34336       }
34337       AppendMatchingElement(interp, resultObj, clPtr->cl->object.cmdName, patternString);
34338     }
34339 
34340     if (checkList != NULL) {
34341       NsfClassListFree(checkList);
34342     }
34343     if (mixinClasses != NULL) {
34344       NsfClassListFree(mixinClasses);
34345     }
34346 
34347   } else if (withClosure != 0) {
34348     Tcl_HashTable objTable, *commandTable = &objTable;
34349     bool          done;
34350 
34351     MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
34352     Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
34353     done = GetAllClassMixins(interp, commandTable, resultObj,
34354                              class, (withGuards == 1),
34355                              patternString, patternObject);
34356     if (patternObject != NULL && done && !withGuards) {
34357       Tcl_SetObjResult(interp, patternObject->cmdName);
34358     }
34359     Tcl_DeleteHashTable(commandTable);
34360     MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
34361 
34362   } else {
34363     result = (opt != NULL) ?
34364       MixinInfo(interp, opt->classMixins, patternString, (withGuards == 1), patternObject) : TCL_OK;
34365   }
34366 
34367   return result;
34368 }
34369 
34370 /*
34371 classInfoMethod mixinguard NsfClassInfoMixinguardMethod {
34372   {-argName "mixin"  -required 1}
34373 }
34374 */
34375 static int
NsfClassInfoMixinguardMethod(Tcl_Interp * interp,NsfClass * class,const char * mixin)34376 NsfClassInfoMixinguardMethod(Tcl_Interp *interp, NsfClass *class, const char *mixin) {
34377 
34378   nonnull_assert(interp != NULL);
34379   nonnull_assert(class != NULL);
34380   nonnull_assert(mixin != NULL);
34381 
34382   return (class->opt != NULL) ? GuardList(interp, class->opt->classMixins, mixin) : TCL_OK;
34383 }
34384 
34385 /*
34386 classInfoMethod mixinof  NsfClassInfoMixinOfMethod {
34387   {-argName "-closure" -nrargs 0}
34388   {-argName "-scope" -required 0 -nrargs 1 -type "all|class|object"}
34389   {-argName "pattern" -type objpattern}
34390 }
34391 */
34392 static int
NsfClassInfoMixinOfMethod(Tcl_Interp * interp,NsfClass * class,int withClosure,MixinscopeIdx_t withScope,const char * patternString,NsfObject * patternObject)34393 NsfClassInfoMixinOfMethod(
34394     Tcl_Interp *interp, NsfClass *class,
34395     int withClosure,
34396     MixinscopeIdx_t withScope,
34397     const char *patternString,
34398     NsfObject *patternObject
34399 ) {
34400   NsfClassOpt *opt;
34401   bool         perClass, perObject, done = NSF_FALSE;
34402   Tcl_Obj     *resultObj;
34403 
34404   nonnull_assert(interp != NULL);
34405   nonnull_assert(class != NULL);
34406 
34407   opt = class->opt;
34408   Tcl_ResetResult(interp);
34409   resultObj = Tcl_GetObjResult(interp);
34410 
34411   if (withScope == MixinscopeNULL || withScope == MixinscopeAllIdx) {
34412     perClass  = NSF_TRUE;
34413     perObject = NSF_TRUE;
34414   } else if (withScope == MixinscopeClassIdx) {
34415     perClass  = NSF_TRUE;
34416     perObject = NSF_FALSE;
34417   } else {
34418     perClass  = NSF_FALSE;
34419     perObject = NSF_TRUE;
34420   }
34421 
34422   if (opt != NULL && !withClosure) {
34423     if (perClass && opt->isClassMixinOf != NULL) {
34424       done = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf, resultObj,
34425                                              patternString, patternObject);
34426       if (done && (patternObject != NULL)) {
34427         goto finished;
34428       }
34429     }
34430     if (perObject && opt->isObjectMixinOf) {
34431       done = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, resultObj,
34432                                                patternString, patternObject);
34433     }
34434   } else if (withClosure != 0) {
34435     Tcl_HashTable objTable, *commandTable = &objTable;
34436 
34437     MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
34438     Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
34439     if (perClass) {
34440       done = GetAllClassMixinsOf(interp, commandTable, resultObj,
34441                                  class, NSF_FALSE, NSF_TRUE, patternString, patternObject);
34442       if (done && (patternObject != NULL)) {
34443         goto finished;
34444       }
34445     }
34446     if (perObject) {
34447       done = GetAllObjectMixinsOf(interp, commandTable, resultObj,
34448                                   class, NSF_FALSE, NSF_TRUE, patternString, patternObject);
34449     }
34450     Tcl_DeleteHashTable(commandTable);
34451     MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
34452   }
34453 
34454  finished:
34455   if (patternObject != NULL) {
34456     Tcl_SetObjResult(interp, done ? patternObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
34457   } else {
34458     Tcl_SetObjResult(interp, resultObj);
34459   }
34460   return TCL_OK;
34461 }
34462 
34463 /*
34464 classInfoMethod slots NsfClassInfoSlotobjectsMethod {
34465   {-argName "-closure" -nrargs 0}
34466   {-argName "-source" -nrargs 1 -type "all|application|system"}
34467   {-argName "-type" -required 0 -nrargs 1 -type class}
34468   {-argName "pattern" -required 0}
34469 }
34470 */
34471 static int
NsfClassInfoSlotobjectsMethod(Tcl_Interp * interp,NsfClass * class,int withClosure,DefinitionsourceIdx_t withSource,NsfClass * typeClass,const char * pattern)34472 NsfClassInfoSlotobjectsMethod(Tcl_Interp *interp,
34473                               NsfClass *class,
34474                               int withClosure,
34475                               DefinitionsourceIdx_t withSource,
34476                               NsfClass *typeClass,
34477                               const char *pattern) {
34478   NsfClasses    *clPtr, *intrinsicClasses, *precedenceList = NULL;
34479   Tcl_Obj       *listObj = Tcl_NewListObj(0, NULL);
34480   Tcl_HashTable  slotTable;
34481 
34482   nonnull_assert(interp != NULL);
34483   nonnull_assert(class != NULL);
34484 
34485   Tcl_ResetResult(interp);
34486   intrinsicClasses = PrecedenceOrder(class);
34487 
34488   if (withClosure != 0) {
34489     NsfClasses *checkList = NULL, *mixinClasses = NULL;
34490     /*
34491      * Compute the closure: first the transitive mixin-classes...
34492      */
34493     NsfClassListAddPerClassMixins(interp, class, &mixinClasses, &checkList);
34494     for (clPtr = mixinClasses; clPtr != NULL; clPtr = clPtr->nextPtr) {
34495       if (NsfClassListFind(clPtr->nextPtr, clPtr->cl) == NULL &&
34496           NsfClassListFind(intrinsicClasses, clPtr->cl) == NULL) {
34497         NsfClassListAdd(&precedenceList, clPtr->cl, NULL);
34498       }
34499     }
34500     /*
34501      * ... followed by the intrinsic classes.
34502      */
34503     NsfClassListAdd(&precedenceList, class, NULL);
34504     for (clPtr = intrinsicClasses->nextPtr; clPtr != NULL; clPtr = clPtr->nextPtr) {
34505       NsfClassListAdd(&precedenceList, clPtr->cl, NULL);
34506     }
34507     if (checkList != NULL) {
34508       NsfClassListFree(checkList);
34509     }
34510     if (mixinClasses != NULL) {
34511       NsfClassListFree(mixinClasses);
34512     }
34513 
34514   } else {
34515     NsfClassListAdd(&precedenceList, class, NULL);
34516   }
34517   /* NsfClassListPrint("precedence", precedenceList); */
34518   if (withSource == 0) {
34519     withSource = 1;
34520   }
34521 
34522   /*
34523    * Use a hash-table to eliminate potential duplicates.
34524    */
34525   Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS);
34526   MEM_COUNT_ALLOC("Tcl_InitHashTable", &slotTable);
34527 
34528   for (clPtr = precedenceList; clPtr != NULL; clPtr = clPtr->nextPtr) {
34529     if (MethodSourceMatches(withSource, clPtr->cl, NULL)) {
34530       AddSlotObjects(interp, &clPtr->cl->object, "::slot", &slotTable,
34531                      typeClass, pattern, listObj);
34532     }
34533   }
34534 
34535   Tcl_DeleteHashTable(&slotTable);
34536   MEM_COUNT_FREE("Tcl_InitHashTable", &slotTable);
34537 
34538   if (precedenceList != NULL) {
34539     NsfClassListFree(precedenceList);
34540   }
34541   Tcl_SetObjResult(interp, listObj);
34542 
34543   return TCL_OK;
34544 }
34545 
34546 
34547 /*
34548 classInfoMethod subclass NsfClassInfoSubclassMethod {
34549   {-argName "-closure" -nrargs 0 -type switch}
34550   {-argName "-dependent" -nrargs 0 -type switch}
34551   {-argName "pattern" -type objpattern}
34552 }
34553 */
34554 static int
NsfClassInfoSubclassMethod(Tcl_Interp * interp,NsfClass * class,int withClosure,int withDependent,const char * patternString,NsfObject * patternObject)34555 NsfClassInfoSubclassMethod(Tcl_Interp *interp, NsfClass *class,
34556                            int withClosure, int withDependent,
34557                            const char *patternString, NsfObject *patternObject) {
34558   bool found = NSF_FALSE;
34559 
34560   nonnull_assert(interp != NULL);
34561   nonnull_assert(class != NULL);
34562 
34563   if (withClosure && withDependent) {
34564     return NsfPrintError(interp, "only -closure or -dependent can be specified, not both");
34565   }
34566 
34567   if (withClosure || withDependent) {
34568     NsfClasses *subClasses = (withClosure != 0) ? TransitiveSubClasses(class) : DependentSubClasses(class);
34569 
34570     if (subClasses != NULL) {
34571       found = AppendMatchingElementsFromClasses(interp, subClasses, patternString, patternObject);
34572       NsfClassListFree(subClasses);
34573     }
34574   } else if (class->sub != NULL) {
34575     found = AppendMatchingElementsFromClasses(interp, class->sub, patternString, patternObject);
34576   }
34577 
34578   if (patternObject != NULL) {
34579     Tcl_SetObjResult(interp, found ? patternObject->cmdName : NsfGlobalObjs[NSF_EMPTY]);
34580   }
34581 
34582   return TCL_OK;
34583 }
34584 
34585 /*
34586 classInfoMethod superclass NsfClassInfoSuperclassMethod {
34587   {-argName "-closure" -nrargs 0}
34588   {-argName "pattern" -type tclobj}
34589 }
34590 */
34591 static int
NsfClassInfoSuperclassMethod(Tcl_Interp * interp,NsfClass * class,int withClosure,Tcl_Obj * patternObj)34592 NsfClassInfoSuperclassMethod(Tcl_Interp *interp, NsfClass *class, int withClosure, Tcl_Obj *patternObj) {
34593 
34594   nonnull_assert(interp != NULL);
34595   nonnull_assert(class != NULL);
34596 
34597   return ListSuperClasses(interp, class, patternObj, (withClosure == 1));
34598 }
34599 
34600 /***********************************************************************
34601  * End Class Info methods
34602  ***********************************************************************/
34603 
34604 /*
34605  * Initialization and Exit handlers
34606  */
34607 
34608 #ifdef DO_FULL_CLEANUP
34609 /*
34610  * Delete global variables and procs.
34611  */
34612 static void DeleteProcsAndVars(
34613     Tcl_Interp *interp, Tcl_Namespace *nsPtr, bool withKeepvars
34614 ) nonnull(1) nonnull(2);
34615 
34616 static void
DeleteProcsAndVars(Tcl_Interp * interp,Tcl_Namespace * nsPtr,bool withKeepvars)34617 DeleteProcsAndVars(
34618     Tcl_Interp *interp, Tcl_Namespace *nsPtr, bool withKeepvars
34619 ) {
34620   Tcl_HashTable *varTablePtr, *cmdTablePtr, *childTablePtr;
34621   Tcl_HashSearch search;
34622   Tcl_Command cmd;
34623   register Tcl_HashEntry *entryPtr;
34624 
34625   nonnull_assert(interp != NULL);
34626   nonnull_assert(nsPtr != NULL);
34627 
34628   /* fprintf(stderr, "DeleteProcsAndVars in %s\n", nsPtr->fullName); */
34629 
34630   varTablePtr = (Tcl_HashTable *)Tcl_Namespace_varTablePtr(nsPtr);
34631   cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
34632   childTablePtr = Tcl_Namespace_childTablePtr(nsPtr);
34633 
34634   /*
34635    * Deleting the procs and vars in the child namespaces does not seem to be
34636    * necessary, but we do it anyway.
34637    */
34638   for (entryPtr = Tcl_FirstHashEntry(childTablePtr, &search);
34639        entryPtr != NULL;
34640        entryPtr = Tcl_NextHashEntry(&search)) {
34641     Tcl_Namespace *childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
34642     DeleteProcsAndVars(interp, childNsPtr, withKeepvars);
34643   }
34644 
34645   if (!withKeepvars) {
34646     for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search);
34647          entryPtr != NULL;
34648          entryPtr = Tcl_NextHashEntry(&search)) {
34649       Tcl_Obj *nameObj;
34650       Var *varPtr;
34651 
34652       GetVarAndNameFromHash(entryPtr, &varPtr, &nameObj);
34653       if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) {
34654         /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/
34655         Tcl_UnsetVar2(interp, ObjStr(nameObj), (char *)NULL, TCL_GLOBAL_ONLY);
34656       }
34657     }
34658   }
34659 
34660   for (entryPtr = Tcl_FirstHashEntry(cmdTablePtr, &search);
34661        entryPtr != NULL;
34662        entryPtr = Tcl_NextHashEntry(&search)) {
34663     cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
34664 
34665     if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) {
34666       /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n",
34667         Tcl_GetHashKey(cmdTablePtr, entryPtr), cmd, Tcl_Command_proc(cmd), Tcl_Command_objProc(cmd),
34668         Tcl_Command_proc(cmd)==RUNTIME_STATE(interp)->objInterpProc);*/
34669 
34670       Tcl_DeleteCommandFromToken(interp, cmd);
34671     }
34672   }
34673 }
34674 #endif
34675 
34676 /*
34677  *----------------------------------------------------------------------
34678  *
34679  * FinalObjectDeletion --
34680  *
34681  *      The method is to be called, when an object is finally deleted, which
34682  *      happens typically during the final cleanup. It tests as well the
34683  *      activation count of the object.
34684  *
34685  * Results:
34686  *      None.
34687  *
34688  * Side effects:
34689  *      Deletion of the objects.
34690  *
34691  *----------------------------------------------------------------------
34692  */
34693 static void
FinalObjectDeletion(Tcl_Interp * interp,NsfObject * object)34694 FinalObjectDeletion(
34695     Tcl_Interp *interp, NsfObject *object
34696 ) {
34697 
34698   nonnull_assert(interp != NULL);
34699   nonnull_assert(object != NULL);
34700 
34701   /*
34702    * If a call to exit happens from a higher stack frame, the object
34703    * refCount might not be decremented correctly. If we are in the
34704    * physical destroy round, we can set the counter to an appropriate
34705    * value to ensure deletion.
34706    */
34707 #if defined(NSF_DEVELOPMENT_TEST)
34708   if (unlikely(object->refCount != 1)) {
34709     if (object->refCount > 1) {
34710       NsfLog(interp, NSF_LOG_WARN,  "RefCount for obj %p %d (name %s) > 1",
34711              (void *)object, object->refCount, ObjectName_(object));
34712     } else {
34713       NsfLog(interp, NSF_LOG_WARN,  "Refcount for obj %p %d > 1",
34714              (void *)object, object->refCount);
34715     }
34716     /*object->refCount = 1;*/
34717   }
34718 #endif
34719 
34720 #if !defined(NDEBUG)
34721   if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != NSF_EXITHANDLER_ON_PHYSICAL_DESTROY) {
34722     assert(object->activationCount == 0);
34723   } else if (object->activationCount != 0) {
34724     NsfLog(interp, NSF_LOG_WARN, "FinalObjectDeletion obj %p activationcount %d\n",
34725            (void *)object, object->activationCount);
34726   }
34727 #endif
34728 
34729   if (likely(object->id != NULL)) {
34730     /*fprintf(stderr, "  ... cmd dealloc %p final delete refCount %d\n",
34731       object->id, Tcl_Command_refCount(object->id));*/
34732 
34733     if (NSF_DTRACE_OBJECT_FREE_ENABLED()) {
34734       NSF_DTRACE_OBJECT_FREE(ObjectName(object), ClassName(object->cl));
34735     }
34736 
34737     Tcl_DeleteCommandFromToken(interp, object->id);
34738   }
34739 }
34740 
34741 #ifdef DO_CLEANUP
34742 /*
34743  *----------------------------------------------------------------------
34744  *
34745  * DeleteNsfProcs --
34746  *
34747  *      Delete all nsfprocs in the namespaces rooted by the second
34748  *      argument. If the provided nsPtr is NULL, the global namespace is used
34749  *      as root of the namespace tree. The function is necessary to trigger
34750  *      the freeing of the parameter definitions.
34751  *
34752  * Results:
34753  *      None.
34754  *
34755  * Side effects:
34756  *      Deletion of nsfprocs.
34757  *
34758  *----------------------------------------------------------------------
34759  */
34760 static void DeleteNsfProcs(
34761     Tcl_Interp *interp, Tcl_Namespace *nsPtr
34762 ) nonnull(1);
34763 
34764 static void
DeleteNsfProcs(Tcl_Interp * interp,Tcl_Namespace * nsPtr)34765 DeleteNsfProcs(
34766     Tcl_Interp *interp, Tcl_Namespace *nsPtr
34767 ) {
34768   Tcl_HashTable *cmdTablePtr, *childTablePtr;
34769   register Tcl_HashEntry *entryPtr;
34770   Tcl_HashSearch search;
34771 
34772   nonnull_assert(interp != NULL);
34773 
34774   if (nsPtr == NULL) {
34775     nsPtr = Tcl_GetGlobalNamespace(interp);
34776   }
34777 
34778   nonnull_assert(nsPtr != NULL);
34779   /*fprintf(stderr, "### DeleteNsfProcs current namespace '%s'\n", (nsPtr != NULL) ? nsPtr->fullName : "NULL");*/
34780 
34781   cmdTablePtr = Tcl_Namespace_cmdTablePtr(nsPtr);
34782   childTablePtr = Tcl_Namespace_childTablePtr(nsPtr);
34783 
34784   for (entryPtr = Tcl_FirstHashEntry(cmdTablePtr, &search);
34785        entryPtr != NULL;
34786        entryPtr = Tcl_NextHashEntry(&search)) {
34787     Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
34788 
34789     if (Tcl_Command_objProc(cmd) == NsfProcStub) {
34790       /*fprintf(stderr, "cmdname = %s cmd %p\n",
34791         Tcl_GetHashKey(cmdTablePtr, entryPtr), cmd);*/
34792       Tcl_DeleteCommandFromToken(interp, cmd);
34793     }
34794   }
34795   for (entryPtr = Tcl_FirstHashEntry(childTablePtr, &search);
34796        entryPtr != NULL;
34797        entryPtr = Tcl_NextHashEntry(&search)) {
34798     Tcl_Namespace *childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
34799 
34800     DeleteNsfProcs(interp, childNsPtr);
34801   }
34802 }
34803 
34804 /*
34805  *----------------------------------------------------------------------
34806  *
34807  * ClassHasSubclasses --
34808  *
34809  *      Check, whether the given class has subclasses.
34810  *
34811  * Results:
34812  *      Boolean
34813  *
34814  * Side effects:
34815  *      None.
34816  *
34817  *----------------------------------------------------------------------
34818  */
34819 static bool ClassHasSubclasses(
34820     const NsfClass *class
34821 ) nonnull(1) pure;
34822 
34823 static bool
ClassHasSubclasses(const NsfClass * class)34824 ClassHasSubclasses(
34825     const NsfClass *class
34826 ) {
34827   nonnull_assert(class != NULL);
34828 
34829   return (class->sub != NULL);
34830 }
34831 
34832 /*
34833  *----------------------------------------------------------------------
34834  *
34835  * ClassHasInstances --
34836  *
34837  *      Check, whether the given class has instances.
34838  *
34839  * Results:
34840  *      Boolean
34841  *
34842  * Side effects:
34843  *      None.
34844  *
34845  *----------------------------------------------------------------------
34846  */
34847 static bool ClassHasInstances(
34848     NsfClass *class
34849 ) nonnull(1) pure;
34850 
34851 static bool
ClassHasInstances(NsfClass * class)34852 ClassHasInstances(
34853     NsfClass *class
34854 ) {
34855   Tcl_HashSearch hSrch;
34856 
34857   nonnull_assert(class != NULL);
34858 
34859   return (Tcl_FirstHashEntry(&class->instances, &hSrch) != NULL);
34860 }
34861 
34862 /*
34863  *----------------------------------------------------------------------
34864  *
34865  * ObjectHasChildren --
34866  *
34867  *      Check, whether the given object has children
34868  *
34869  * Results:
34870  *      Boolean
34871  *
34872  * Side effects:
34873  *      None.
34874  *
34875  *----------------------------------------------------------------------
34876  */
34877 static bool ObjectHasChildren(
34878     const NsfObject *object
34879 ) nonnull(1) pure;
34880 
34881 static bool
ObjectHasChildren(const NsfObject * object)34882 ObjectHasChildren(
34883     const NsfObject *object
34884 ) {
34885   const Tcl_Namespace *ns;
34886   bool                 result = NSF_FALSE;
34887 
34888   nonnull_assert(object != NULL);
34889 
34890   ns = object->nsPtr;
34891   if (ns != NULL) {
34892     const Tcl_HashEntry *hPtr;
34893     Tcl_HashSearch hSrch;
34894     Tcl_HashTable *cmdTablePtr = Tcl_Namespace_cmdTablePtr(ns);
34895 
34896     for (hPtr = Tcl_FirstHashEntry(cmdTablePtr, &hSrch);
34897          hPtr != NULL;
34898          hPtr = Tcl_NextHashEntry(&hSrch)) {
34899       Tcl_Command cmd = Tcl_GetHashValue(hPtr);
34900       const NsfObject *childObject = NsfGetObjectFromCmdPtr(cmd);
34901 
34902       if (childObject != NULL) {
34903         result = NSF_TRUE;
34904         break;
34905       }
34906     }
34907   }
34908   return result;
34909 }
34910 
34911 /*
34912  *----------------------------------------------------------------------
34913  *
34914  * FreeAllNsfObjectsAndClasses --
34915  *
34916  *      Destroy and free all objects and classes defined int the interp.
34917  *
34918  * Results:
34919  *      None.
34920  *
34921  * Side effects:
34922  *      Freeing memory.
34923  *
34924  *----------------------------------------------------------------------
34925  */
34926 static void FreeAllNsfObjectsAndClasses(
34927     Tcl_Interp *interp, NsfCmdList **instances
34928 ) nonnull(1) nonnull(2);
34929 
34930 static void
FreeAllNsfObjectsAndClasses(Tcl_Interp * interp,NsfCmdList ** instances)34931 FreeAllNsfObjectsAndClasses(
34932     Tcl_Interp *interp, NsfCmdList **instances
34933 ) {
34934   NsfCmdList *entry, *lastEntry;
34935   int nrDeleted = 0;
34936 
34937   nonnull_assert(interp != NULL);
34938   nonnull_assert(instances != NULL);
34939 
34940   /*fprintf(stderr, "FreeAllNsfObjectsAndClasses in %p\n", interp);*/
34941 
34942   RUNTIME_STATE(interp)->exitHandlerDestroyRound = NSF_EXITHANDLER_ON_PHYSICAL_DESTROY;
34943 
34944   /*
34945    * First delete all child commands of all objects, which are not
34946    * objects themselves. This will for example delete namespace
34947    * imported commands and objects and will resolve potential loops in
34948    * the dependency graph. The result is a plain object/class tree.
34949    */
34950 
34951   for (entry = *instances; entry != NULL; entry = entry->nextPtr) {
34952     NsfObject *object = (NsfObject *)entry->clorobj;
34953 
34954     /*
34955      * Delete per-object methods.
34956      */
34957     if (object != NULL && object->nsPtr != NULL) {
34958       const Tcl_HashEntry *hPtr;
34959       Tcl_HashSearch hSrch;
34960 
34961       for (hPtr = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(object->nsPtr), &hSrch);
34962            hPtr != NULL;
34963            hPtr = Tcl_NextHashEntry(&hSrch)) {
34964         Tcl_Command cmd = Tcl_GetHashValue(hPtr);
34965 
34966         if (cmd != NULL) {
34967           if (CmdIsNsfObject(cmd)) {
34968             AliasDeleteObjectReference(interp, cmd);
34969             continue;
34970           }
34971           Tcl_DeleteCommandFromToken(interp, cmd);
34972           nrDeleted ++;
34973         }
34974       }
34975     }
34976 
34977     /*
34978      * Delete class methods; these methods might have aliases (dependencies) to
34979      * objects, which will be resolved this way.
34980      */
34981     if (object != NULL && NsfObjectIsClass(object)) {
34982       const Tcl_HashEntry *hPtr;
34983       Tcl_HashSearch hSrch;
34984 
34985       for (hPtr = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(((NsfClass *)object)->nsPtr),
34986                                       &hSrch);
34987            hPtr != NULL;
34988            hPtr = Tcl_NextHashEntry(&hSrch)) {
34989         Tcl_Command cmd = Tcl_GetHashValue(hPtr);
34990 
34991         if ((cmd != NULL) && CmdIsNsfObject(cmd)) {
34992           AliasDeleteObjectReference(interp, cmd);
34993           continue;
34994         }
34995       }
34996     }
34997   }
34998 
34999   /*fprintf(stderr, "deleted %d cmds\n", nrDeleted);*/
35000 
35001   /*
35002    * Finally delete the object/class tree in a bottom up manner,
35003    * deleting all objects without dependencies first. Finally, only
35004    * the root-classes of the object system will remain, which are
35005    * deleted separately.
35006    */
35007 
35008   while (1) {
35009     /*
35010      * Delete all plain objects without dependencies.
35011      */
35012     nrDeleted = 0;
35013     for (entry = *instances, lastEntry = NULL;
35014          entry != NULL;
35015          lastEntry = entry, entry = entry->nextPtr) {
35016       NsfObject *object = (NsfObject *)entry->clorobj;
35017 
35018       /*
35019        * The list of the instances should contain only alive objects, without
35020        * duplicates. We would recognize duplicates since a deletion of one
35021        * object would trigger the CMD_IS_DELETED flag of the cmdPtr of the
35022        * duplicate.
35023        */
35024       assert(((unsigned int)Tcl_Command_flags(entry->cmdPtr) & CMD_IS_DELETED) == 0u);
35025 
35026       if (object != NULL && !NsfObjectIsClass(object) && !ObjectHasChildren(object)) {
35027         /*fprintf(stderr, "check %p obj->flags %.6x cmd %p deleted %d\n",
35028                 object, object->flags, entry->cmdPtr,
35029                 Tcl_Command_flags(entry->cmdPtr) & CMD_IS_DELETED); */
35030         assert(object->id != NULL);
35031         /*fprintf(stderr, "  ... delete object %s %p, class=%s id %p ns %p\n",
35032           ObjectName(object), object,
35033           ClassName(object->cl), object->id, object->nsPtr);*/
35034 
35035         FreeUnsetTraceVariable(interp, object);
35036         FinalObjectDeletion(interp, object);
35037 
35038         if (entry == *instances) {
35039           *instances = entry->nextPtr;
35040           CmdListDeleteCmdListEntry(entry, NULL);
35041           entry = *instances;
35042         } else {
35043           lastEntry->nextPtr = entry->nextPtr;
35044           CmdListDeleteCmdListEntry(entry, NULL);
35045           entry = lastEntry;
35046         }
35047         assert(entry != NULL);
35048 
35049         nrDeleted++;
35050       }
35051     }
35052     /*fprintf(stderr, "deleted %d Objects without dependencies\n", nrDeleted);*/
35053 
35054     if (nrDeleted > 0) {
35055       continue;
35056     }
35057 
35058     /*
35059      * Delete all classes without dependencies.
35060      */
35061     for (entry = *instances, lastEntry = NULL;
35062          entry != NULL;
35063          (entry != NULL ? (lastEntry = entry, entry = entry->nextPtr) : NULL)) {
35064       NsfClass *class = entry->clorobj;
35065 
35066       assert(class != NULL);
35067 
35068       if (!NsfObjectIsClass(&class->object)) {
35069         continue;
35070       }
35071 
35072       /*fprintf(stderr, "### cl key = %s %p\n", ClassName(class), class); */
35073 
35074       /*
35075        * Remove manually mixinRegObjs to achieve correct deletion
35076        * order. Otherwise, refcount checking for NsfObjects complains during
35077        * shutdown (and dangling references would be a consequence).
35078        */
35079       if (class->opt != NULL && class->opt->mixinRegObjs != NULL) {
35080         NsfMixinregInvalidate(interp, class->opt->mixinRegObjs);
35081         DECR_REF_COUNT2("mixinRegObjs", class->opt->mixinRegObjs);
35082         class->opt->mixinRegObjs = NULL;
35083       }
35084 
35085       if (!ObjectHasChildren((NsfObject *)class)
35086           && !ClassHasInstances(class)
35087           && !ClassHasSubclasses(class)
35088           && !IsBaseClass(&class->object)
35089           ) {
35090         /*fprintf(stderr, "  ... delete class %s %p\n", ClassName(class), class); */
35091         assert(class->object.id);
35092 
35093         FreeUnsetTraceVariable(interp, &class->object);
35094         FinalObjectDeletion(interp, &class->object);
35095 
35096         if (entry == *instances) {
35097           *instances = entry->nextPtr;
35098           /*fprintf(stderr, "... delete first entry %p\n", entry);*/
35099           CmdListDeleteCmdListEntry(entry, NULL);
35100           entry = *instances;
35101         } else {
35102           /*fprintf(stderr, "... delete entry %p\n", entry);*/
35103           lastEntry->nextPtr = entry->nextPtr;
35104           CmdListDeleteCmdListEntry(entry, NULL);
35105           entry = lastEntry;
35106         }
35107 
35108         nrDeleted++;
35109       }
35110     }
35111 
35112     /*fprintf(stderr, "deleted %d Classes\n", nrDeleted);*/
35113 
35114     if (nrDeleted == 0) {
35115       int nrReclassed = 0;
35116 
35117       /*
35118        * Final check. If there are no cyclical dependencies, we should have
35119        * now just the base classes left. If this is not the case, reclass
35120        * the remaining objects to their base classes, and set the superClasses
35121        * to the most general superclass.
35122        */
35123       for (entry = *instances;
35124            entry != NULL;
35125            entry = entry->nextPtr) {
35126         NsfObject       *object = (NsfObject *)entry->clorobj;
35127         NsfClass        *baseClass;
35128         NsfObjectSystem *osPtr;
35129 
35130         if (NsfObjectIsClass(object) && IsBaseClass(object)) {
35131           continue;
35132         }
35133 
35134         osPtr = GetObjectSystem(object);
35135 
35136         /*
35137          * For classes, check the superclass hierarchy.
35138          */
35139         if (NsfObjectIsClass(object)) {
35140           NsfClass   *cl = (NsfClass *)object;
35141           NsfClasses *sc;
35142 
35143           for (sc = cl->super; sc != NULL; sc = sc->nextPtr) {
35144             if (sc->cl != osPtr->rootClass) {
35145               Tcl_Obj *objectName = osPtr->rootClass->object.cmdName;
35146 
35147               SuperclassAdd(interp, cl, 1, &objectName, objectName);
35148               nrReclassed ++;
35149               break;
35150             }
35151           }
35152         }
35153 
35154         /*
35155          * In all cases, straighten the class to the base case.
35156          */
35157         baseClass = NsfObjectIsClass(object) ? osPtr->rootMetaClass : osPtr->rootClass;
35158         if (object->cl != baseClass) {
35159           ChangeClass(interp, object, baseClass);
35160           nrReclassed ++;
35161         }
35162       }
35163       /*fprintf(stderr, "We have reclassed %d objects\n", nrReclassed);*/
35164 
35165       if (nrReclassed == 0) {
35166         break;
35167       }
35168     }
35169   }
35170 }
35171 
35172 #endif /* DO_CLEANUP */
35173 
35174 /*
35175  *  Exit Handler
35176  */
35177 
35178 static void
ExitHandler(ClientData clientData)35179 ExitHandler(ClientData clientData) {
35180   Tcl_Interp      *interp = (Tcl_Interp *)clientData;
35181   int              flags;
35182   NsfRuntimeState *rst;
35183 
35184   nonnull_assert(clientData != NULL);
35185 
35186   rst = RUNTIME_STATE(interp);
35187   /*fprintf(stderr, "+++ (%lx) ExitHandler interp %p deleted %d exitHandlerDestroyRound %d\n",
35188           (long)(void*)pthread_self(), interp, (Tcl_Interp_flags(interp) & DELETED),
35189           rst->exitHandlerDestroyRound);*/
35190 
35191   /*
35192    * Don't use exit handler, if the interpreter is already destroyed.
35193    * Call to exit handler comes after freeing namespaces, commands, etc.
35194    * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed.
35195    */
35196 
35197   /*
35198    * Ahem ...
35199    *
35200    * Since we *must* be sure that our destroy methods will run
35201    * we must *cheat* (I mean CHEAT) here: we flip the interp
35202    * flag, saying, "hey boy, you're not deleted any more".
35203    * After our handlers are done, we restore the old state...
35204    * All this is needed so we can do an eval in the interp which
35205    * is potentially marked for delete when we start working here.
35206    *
35207    * I know, I know, this is not really elegant. But...  I'd need a
35208    * standard way of invoking some code at interpreter delete time
35209    * but JUST BEFORE the actual deletion process starts. Sadly,
35210    * there is no such hook in Tcl as of Tcl8.4.*, that I know of.
35211    *
35212    * So, for the rest of procedure, assume the interp is alive !
35213    */
35214   flags = Tcl_Interp_flags(interp);
35215   Tcl_Interp_flags(interp) &= ~DELETED;
35216 
35217   CallStackPopAll(interp);
35218 
35219 #if defined(NSF_MEM_COUNT)
35220   /* The Tcl history list (which internally stores commands and scripts in the
35221    * array ::tcl::history) can retain Tcl_Obj references beyond the scope of
35222    * our shutdown procedures (::nsf::finalize, ExitHandler). Therefore, on
35223    * MEM_COUNT_RELEASE(), we might see unbalanced refcounts which are false
35224    * positives. Therefore, we aim at clearing the history list at this point.
35225    *
35226    * See also Tcl bug report 1ae12987cb.
35227   */
35228 
35229   if (unlikely(Tcl_Eval(interp, "::history clear") != TCL_OK)) {
35230     NsfLog(interp, NSF_LOG_WARN, "Clearing the Tcl history list failed! "
35231            "Memcounts could be reported as unbalanced on MEM_COUNT_RELEASE(). "
35232            "Error: %s\n",
35233            ObjStr(Tcl_GetObjResult(interp)));
35234   }
35235 #endif
35236 
35237   if (rst->exitHandlerDestroyRound == NSF_EXITHANDLER_OFF) {
35238     NsfFinalizeCmd(interp, NSF_FALSE);
35239   }
35240 
35241   /*
35242    * Must be before freeing of NsfGlobalObjs.
35243    */
35244   NsfShadowTclCommands(interp, SHADOW_UNLOAD);
35245 
35246   MEM_COUNT_FREE("Tcl_InitHashTable", &rst->activeFilterTablePtr);
35247   Tcl_DeleteHashTable(&rst->activeFilterTablePtr);
35248 
35249   /*
35250    * Free "global" (per main interp) objects.
35251    */
35252   {
35253     int i;
35254 
35255     for (i = 0; i < nr_elements(NsfGlobalStrings); i++) {
35256       DECR_REF_COUNT(NsfGlobalObjs[i]);
35257     }
35258   }
35259   NsfStringIncrFree(&rst->iss);
35260 
35261   /*
35262    * Free all data in the hash tables managing pointer converters,
35263    * enumerations, and method definitions.
35264    */
35265   Nsf_PointerExit(interp);
35266   Nsf_EnumerationTypeRelease();
35267   Nsf_CmdDefinitionRelease();
35268 
35269 #if defined(NSF_PROFILE)
35270   NsfProfileFree(interp);
35271 #endif
35272 
35273   FREE(Tcl_Obj**, NsfGlobalObjs);
35274 
35275 #if defined(TCL_MEM_DEBUG)
35276   TclDumpMemoryInfo((ClientData) stderr, 0);
35277   Tcl_DumpActiveMemory("./nsfActiveMem");
35278   /* Tcl_Eval(interp, "puts {checkmem to checkmemFile};
35279      checkmem checkmemFile"); */
35280 #endif
35281 
35282   /*
35283    * Free runtime state.
35284    */
35285   /*fprintf(stderr, "+++ ExiHandler frees runtime state of interp %p\n", interp);*/
35286   ckfree((char *) rst);
35287 #if defined(USE_ASSOC_DATA)
35288   Tcl_DeleteAssocData(interp, "NsfRuntimeState");
35289 #else
35290   Tcl_Interp_globalNsPtr(interp)->clientData = NULL;
35291 #endif
35292 
35293 #if defined(NSF_MEM_COUNT) && !defined(PRE86)
35294   /*
35295    * When raising an error, the Tcl_Objs on the error stack and in the
35296    * inner context are refCount-incremented. When Tcl exits, it does normally
35297    * not perform the according decrementing. We perform here a manual
35298    * decrementing and reset these lists.
35299    */
35300   {
35301     Interp *iPtr = (Interp *) interp;
35302 
35303     if (iPtr->innerContext != NULL) {
35304       Tcl_DecrRefCount(iPtr->errorStack);
35305       iPtr->errorStack = Tcl_NewListObj(0, NULL);
35306       Tcl_IncrRefCount(iPtr->errorStack);
35307       Tcl_DecrRefCount(iPtr->innerContext);
35308       iPtr->innerContext = Tcl_NewListObj(0, NULL);
35309       Tcl_IncrRefCount(iPtr->innerContext);
35310     }
35311   }
35312 #endif
35313 
35314   Tcl_Interp_flags(interp) = flags;
35315   Tcl_Release(interp);
35316 
35317   MEM_COUNT_RELEASE();
35318 }
35319 
35320 
35321 #if defined(TCL_THREADS)
35322 /*
35323  * Gets activated at thread-exit
35324  */
35325 
35326 static void
Nsf_ThreadExitProc(ClientData clientData)35327 Nsf_ThreadExitProc(ClientData clientData) {
35328 
35329   nonnull_assert(clientData != NULL);
35330 
35331   /*fprintf(stderr, "+++ (%lx) Nsf_ThreadExitProc %p\n", (long)(void*)pthread_self(), clientData);*/
35332 
35333   Tcl_DeleteThreadExitHandler(Nsf_ThreadExitProc, clientData);
35334   Tcl_DeleteExitHandler(Nsf_ExitProc, clientData);
35335   ExitHandler(clientData);
35336 }
35337 #endif
35338 
35339 /*
35340  * Gets activated at application-exit
35341  */
35342 
35343 static void
Nsf_ExitProc(ClientData clientData)35344 Nsf_ExitProc(ClientData clientData) {
35345 
35346   nonnull_assert(clientData != NULL);
35347 
35348   /*fprintf(stderr, "+++ (%lx) Nsf_ExitProc %p\n", (long)(void*)pthread_self(), clientData);*/
35349 #if defined(TCL_THREADS)
35350   Tcl_DeleteExitHandler(Nsf_ExitProc, clientData);
35351   Tcl_DeleteThreadExitHandler(Nsf_ThreadExitProc, clientData);
35352 #endif
35353   ExitHandler(clientData);
35354 }
35355 
35356 /*
35357  * Registers thread/application exit handlers.
35358  */
35359 static void RegisterExitHandlers(ClientData clientData)
35360   nonnull(1);
35361 
35362 static void
RegisterExitHandlers(ClientData clientData)35363 RegisterExitHandlers(ClientData clientData) {
35364 
35365   nonnull_assert(clientData != NULL);
35366 
35367   Tcl_Preserve(clientData);
35368 #if defined(TCL_THREADS)
35369   Tcl_CreateThreadExitHandler(Nsf_ThreadExitProc, clientData);
35370 #endif
35371   Tcl_CreateExitHandler(Nsf_ExitProc, clientData);
35372 }
35373 
35374 /*
35375  * Tcl extension initialization routine
35376  */
35377 
35378 #if 0
35379 #include <google/profiler.h>
35380 #endif
35381 
35382 
35383 int
Nsf_Init(Tcl_Interp * interp)35384 Nsf_Init(
35385     Tcl_Interp *interp
35386 ) {
35387   static NsfMutex  initMutex = 0;
35388   ClientData       runtimeState;
35389   NsfRuntimeState *rst;
35390   int              result, i;
35391   Tcl_Obj         *tmpObj;
35392 #ifdef NSF_BYTECODE
35393   /*NsfCompEnv *interpstructions = NsfGetCompEnv();*/
35394 #endif
35395 #ifdef USE_TCL_STUBS
35396   static int stubsInitialized = 0;
35397 #endif
35398 
35399   nonnull_assert(interp != NULL);
35400 
35401 #if 0
35402   ProfilerStart("profiler");
35403 #endif
35404 
35405 #ifdef USE_TCL_STUBS
35406   /*
35407    * Since the stub-tables are initialized globally (not per interp), we want
35408    * to initialize these only once.  The read operation on "stubsInitialized"
35409    * is a potentially dirty read. However, we can't use a mutex lock around
35410    * this, since Tcl_MutexLock() requires (at least on some platforms)
35411    * initialized stub-tables. The dirty read of stubsInitialized is not so
35412    * invasive as the dirty reads caused by overwriting the stub tables.
35413    *
35414    * NsfMutexLock(&stubFlagMutex);
35415    * ...
35416    * NsfMutexUnlock(&stubFlagMutex);
35417    */
35418 
35419   if (stubsInitialized == 0) {
35420     if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
35421       return TCL_ERROR;
35422     }
35423     if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
35424       return TCL_ERROR;
35425     }
35426     stubsInitialized = 1;
35427   }
35428 #endif
35429 
35430 #if defined(TCL_MEM_DEBUG)
35431   TclDumpMemoryInfo((ClientData) stderr, 0);
35432 #endif
35433 
35434   /*
35435    * Runtime State stored in the client data of the Interp's global namespace
35436    * in order to avoid global state information. All fields are per default
35437    * set to zero.
35438    */
35439   runtimeState = ckalloc((int)sizeof(NsfRuntimeState));
35440   memset(runtimeState, 0, sizeof(NsfRuntimeState));
35441 
35442 #if defined(USE_ASSOC_DATA)
35443   Tcl_SetAssocData(interp, "NsfRuntimeState", NULL, runtimeState);
35444 #else
35445   Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState;
35446 #endif
35447 
35448   /*
35449    * If MEM_COUNT is activated, the tables have to be initialized before the
35450    * first call to the MEM_COUNT macros (including e.g. INCR_REF_COUNT), but
35451    * it requires that the runtimeState is already associated with the interp.
35452    */
35453   MEM_COUNT_INIT();
35454 
35455   /*
35456    * Init global variables for Tcl_Obj types.
35457    */
35458   NsfMutexLock(&initMutex);
35459   Nsf_OT_byteCodeType = Tcl_GetObjType("bytecode");
35460   assert(Nsf_OT_byteCodeType != NULL);
35461 
35462   Nsf_OT_tclCmdNameType = Tcl_GetObjType("cmdName");
35463   assert(Nsf_OT_tclCmdNameType != NULL);
35464 
35465   Nsf_OT_listType = Tcl_GetObjType("list");
35466   assert(Nsf_OT_listType != NULL);
35467 
35468   Nsf_OT_doubleType = Tcl_GetObjType("double");
35469   assert(Nsf_OT_doubleType != NULL);
35470 
35471   /*
35472    * Type "int" and "wideInt" are a moving target in Tcl 8.7a+.  So, get the
35473    * type from the Tcl_Obj directly, which will continue to work.
35474    */
35475   tmpObj = Tcl_NewIntObj(0);
35476   Nsf_OT_intType = tmpObj->typePtr;
35477   Tcl_DecrRefCount(tmpObj);
35478   assert(Nsf_OT_intType != NULL);
35479 
35480   Nsf_OT_byteArrayType = Tcl_GetObjType("bytearray");
35481   assert(Nsf_OT_byteArrayType != NULL);
35482 
35483   /*
35484    * Get bytearray and proper bytearray from Tcl (latter if available,
35485    * introduced in Tcl 8.7a+)
35486    */
35487   tmpObj = Tcl_NewByteArrayObj(NULL, 0);
35488   Nsf_OT_properByteArrayType = tmpObj->typePtr;
35489   if (Nsf_OT_properByteArrayType == Nsf_OT_byteArrayType) {
35490     /*
35491      * When both values are the same, we are in a Tcl version before 8.7,
35492      * where we have no properByteArrayTypePtr. So set it to an invalid
35493      * value to avoid potential confusions. Without this stunt, we would
35494      * need several ifdefs.
35495      */
35496     Nsf_OT_properByteArrayType = (Tcl_ObjType *)0xffffff;
35497   }
35498   Tcl_DecrRefCount(tmpObj);
35499   assert(Nsf_OT_properByteArrayType != NULL);
35500 
35501   NsfMutexUnlock(&initMutex);
35502 
35503   /*
35504    * Initialize the pointer converter, the enumeration types and cmd
35505    * definitions tables and load it with the generated information for
35506    * introspection.
35507    */
35508   Nsf_PointerInit();
35509 
35510   Nsf_EnumerationTypeInit();
35511   result = Nsf_EnumerationTypeRegister(interp, enumeratorConverterEntries);
35512   if (unlikely(result != TCL_OK)) {
35513     return result;
35514   }
35515 
35516   Nsf_CmdDefinitionInit();
35517   Nsf_CmdDefinitionRegister(interp, method_definitions);
35518 
35519   /*
35520     fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n",
35521     sizeof(NsfObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(NsfClass),
35522     sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable));
35523   */
35524 
35525 #if defined(NSF_PROFILE)
35526   NsfProfileInit(interp);
35527 #endif
35528   rst = RUNTIME_STATE(interp);
35529   rst->logSeverity = NSF_LOG_NOTICE;
35530   rst->doFilters = 1;
35531   rst->doCheckResults = 1;
35532   rst->doCheckArguments = NSF_ARGPARSE_CHECK;
35533   NsfDListInit(&rst->freeDList);
35534 
35535 #if defined(NSF_STACKCHECK)
35536   { int someVar;
35537     /*
35538      * Note that Nsf_Init() is called typically via a package require, which
35539      * is therefore not really the bottom of the stack, but just a first
35540      * approximation.
35541      */
35542     rst->bottomOfStack = &someVar;
35543     rst->maxStack = rst->bottomOfStack;
35544   }
35545 #endif
35546 
35547   /*
35548    * Check whether the namespace exists, otherwise create it.
35549    */
35550   rst->NsfNS = Tcl_FindNamespace(interp, "::nsf", NULL, TCL_GLOBAL_ONLY);
35551   if (rst->NsfNS == NULL) {
35552     rst->NsfNS = Tcl_CreateNamespace(interp, "::nsf", NULL,
35553                                      (Tcl_NamespaceDeleteProc *)NULL);
35554   }
35555   MEM_COUNT_ALLOC("TclNamespace", rst->NsfNS);
35556 
35557   /*
35558    * Init an empty, faked proc structure in the RUNTIME state.
35559    */
35560   rst->fakeProc.iPtr = (Interp *)interp;
35561   rst->fakeProc.refCount = 1;
35562   rst->fakeProc.cmdPtr = NULL;
35563   rst->fakeProc.bodyPtr = NULL;
35564   rst->fakeProc.numArgs = 0;
35565   rst->fakeProc.numCompiledLocals = 0;
35566   rst->fakeProc.firstLocalPtr = NULL;
35567   rst->fakeProc.lastLocalPtr = NULL;
35568 
35569   /*
35570    * NsfClasses in separate Namespace / Objects
35571    */
35572   rst->NsfClassesNS =
35573     Tcl_CreateNamespace(interp, nsfClassesPrefix, NULL,
35574                         (Tcl_NamespaceDeleteProc *)NULL);
35575 
35576 #if !defined(PRE86)
35577   ((Namespace *)rst->NsfClassesNS)->flags |= NS_SUPPRESS_COMPILATION;
35578 #endif
35579 
35580   MEM_COUNT_ALLOC("TclNamespace", rst->NsfClassesNS);
35581 
35582   /*
35583    * Cache interpreters proc interpretation functions
35584    */
35585   rst->objInterpProc = TclGetObjInterpProc();
35586   rst->exitHandlerDestroyRound = NSF_EXITHANDLER_OFF;
35587 
35588   RegisterExitHandlers(interp);
35589   NsfStringIncrInit(&RUNTIME_STATE(interp)->iss);
35590   /*
35591    * initialize global Tcl_Obj
35592    */
35593   NsfGlobalObjs = NEW_ARRAY(Tcl_Obj*, nr_elements(NsfGlobalStrings));
35594 
35595   for (i = 0; i < nr_elements(NsfGlobalStrings); i++) {
35596     NsfGlobalObjs[i] = Tcl_NewStringObj(NsfGlobalStrings[i], -1);
35597     INCR_REF_COUNT(NsfGlobalObjs[i]);
35598   }
35599 
35600   Tcl_InitHashTable(&rst->activeFilterTablePtr, TCL_STRING_KEYS);
35601   MEM_COUNT_ALLOC("Tcl_InitHashTable", &rst->activeFilterTablePtr);
35602 
35603   /*
35604    * Create namespaces for the different command types.
35605    */
35606   Tcl_CreateNamespace(interp, "::nsf::cmd", 0, (Tcl_NamespaceDeleteProc *)NULL);
35607   for (i = 0; i < nr_elements(method_command_namespace_names); i++) {
35608     Tcl_CreateNamespace(interp, method_command_namespace_names[i], 0, (Tcl_NamespaceDeleteProc *)NULL);
35609   }
35610 
35611   /*
35612    * Create all method commands (will use the namespaces above).
35613    */
35614   for (i = 0; i < nr_elements(method_definitions)-1; i++) {
35615     Tcl_CreateObjCommand(interp, method_definitions[i].methodName, method_definitions[i].proc, 0, 0);
35616   }
35617 
35618   /*
35619    * Create Shadowed Tcl cmds:
35620    */
35621   result = NsfShadowTclCommands(interp, SHADOW_LOAD);
35622   if (unlikely(result != TCL_OK)) {
35623     return result;
35624   }
35625   /*
35626    * Create new Tcl cmds:
35627    */
35628 #ifdef NSF_BYTECODE
35629   instructions[INST_NEXT].cmdPtr = (Command *)
35630 #endif
35631     Tcl_CreateObjCommand(interp, "::nsf::xotclnext", NsfNextObjCmd, 0, 0);
35632 #ifdef NSF_BYTECODE
35633   instructions[INST_SELF].cmdPtr =
35634     (Command *)Tcl_FindCommand(interp, "::nsf::current", NULL, TCL_GLOBAL_ONLY);
35635 #endif
35636   /*Tcl_CreateObjCommand(interp, "::nsf::K", NsfKObjCmd, 0, 0);*/
35637 
35638 #ifdef NSF_BYTECODE
35639   NsfBytecodeInit();
35640 #endif
35641   NsfInitPkgConfig(interp);
35642 
35643   Tcl_AddInterpResolvers(interp, "nsf",
35644                          (Tcl_ResolveCmdProc *)InterpColonCmdResolver,
35645                          InterpColonVarResolver,
35646                          (Tcl_ResolveCompiledVarProc *)InterpCompiledColonVarResolver);
35647   rst->colonCmd = Tcl_FindCommand(interp, "::nsf::colon", NULL, TCL_GLOBAL_ONLY);
35648 
35649   /*
35650    *  Tcl occasionally resolves a proc's cmd structure (e.g., in
35651    *  [info frame /number/] or TclInfoFrame()) without
35652    *  verification. However, NSF non-proc frames, in particular
35653    *  initcmd blocks, point to the fakeProc structure which does not
35654    *  contain a initialized Command pointer. For now, we default to
35655    *  an internal command. However, we might have to revisit this decision
35656    *  as non-proc frames (e.g., initcmds) report a "proc" entry
35657    *  for c-based functions with a proc scope, such as "::nsf::colon"),
35658    *  which can lead to confusions. "proc" does not mean "tcp proc",
35659    *  but an entry with a proc frame for local vars.
35660   */
35661   rst->fakeProc.cmdPtr = (Command *)RUNTIME_STATE(interp)->colonCmd;
35662 
35663   {
35664     /*
35665      * The file "predefined.h" contains some methods and library procs
35666      * implemented in Tcl - they could go in .tcl file, but they are embedded
35667      * here with Tcl_Eval to avoid the need to carry around a separate file at
35668      * runtime.
35669      */
35670 
35671 #include "predefined.h"
35672 
35673     /* fprintf(stderr, "predefined=<<%s>>\n", cmd);*/
35674     if (
35675         (Tcl_Eval(interp, predefined_part1) != TCL_OK)
35676         || (Tcl_Eval(interp, predefined_part2) != TCL_OK)
35677         ) {
35678       static char reportingCmd[] =
35679         "puts stderr \"Error in predefined code\n\
35680          $::errorInfo\"";
35681       Tcl_EvalEx(interp, reportingCmd, -1, 0);
35682       return TCL_ERROR;
35683     }
35684   }
35685 
35686 #ifndef AOL_SERVER
35687   /*
35688    * The AOL server uses a different package loading mechanism.
35689    */
35690 # ifdef COMPILE_NSF_STUBS
35691   Tcl_PkgProvideEx(interp, "nsf", PACKAGE_VERSION, &nsfStubs);
35692 # else
35693   Tcl_PkgProvide(interp, "nsf", PACKAGE_VERSION);
35694 # endif
35695 #endif
35696 
35697   /*
35698    * Obtain type for parsed var name.
35699    */
35700   if (Nsf_OT_parsedVarNameType == NULL) {
35701     Tcl_Obj *varNameObj = Tcl_NewStringObj("::nsf::version", -1);
35702     Var *arrayPtr;
35703 
35704     INCR_REF_COUNT(varNameObj);
35705     TclObjLookupVar(interp, varNameObj, NULL, 0, "access",
35706                     /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
35707     Nsf_OT_parsedVarNameType = varNameObj->typePtr;
35708     assert(Nsf_OT_parsedVarNameType != NULL);
35709     DECR_REF_COUNT(varNameObj);
35710   }
35711 
35712 #if !defined(TCL_THREADS)
35713   if ((Tcl_GetVar2(interp, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) {
35714     /*
35715      * A non-threaded version of NSF is loaded into a threaded environment.
35716      */
35717     fprintf(stderr, "\n A non threaded version of the Next Scripting Framework "
35718             "is loaded into threaded environment.\n"
35719             "Please reconfigure nsf with --enable-threads!\n\n\n");
35720   }
35721 #endif
35722 
35723   Tcl_ResetResult(interp);
35724   Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
35725 
35726   return TCL_OK;
35727 }
35728 
35729 EXTERN int
Nsf_SafeInit(Tcl_Interp * interp)35730 Nsf_SafeInit(Tcl_Interp *interp) {
35731 
35732   nonnull_assert(interp != NULL);
35733 
35734   /*** dummy for now **/
35735   return Nsf_Init(interp);
35736 }
35737 
35738 
35739 
35740 /*
35741  * Local Variables:
35742  * mode: c
35743  * c-basic-offset: 2
35744  * fill-column: 78
35745  * indent-tabs-mode: nil
35746  * eval: (c-guess)
35747  * End:
35748  */
35749