1/* $Id: xotcl.c,v 1.51 2007/10/12 19:53:32 neumann Exp $
2 *
3 *  XOTcl - Extended Object Tcl
4 *
5 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (a)
6 *
7 * (a) Vienna University of Economics and Business Administration
8 *     Institute. of Information Systems and New Media
9 *     A-1090, Augasse 2-6
10 *     Vienna, Austria
11 *
12 * (b) University of Essen
13 *     Specification of Software Systems
14 *     Altendorferstrasse 97-101
15 *     D-45143 Essen, Germany
16 *
17 *  Permission to use, copy, modify, distribute, and sell this
18 *  software and its documentation for any purpose is hereby granted
19 *  without fee, provided that the above copyright notice appear in
20 *  all copies and that both that copyright notice and this permission
21 *  notice appear in supporting documentation. We make no
22 *  representations about the suitability of this software for any
23 *  purpose.  It is provided "as is" without express or implied
24 *  warranty.
25 *
26 *
27 *  This software is based upon MIT Object Tcl by David Wetherall and
28 *  Christopher J. Lindblad, that contains the following copyright
29 *  message:
30 *
31 *   "Copyright 1993 Massachusetts Institute of Technology
32 *
33 *    Permission to use, copy, modify, distribute, and sell this
34 *    software and its documentation for any purpose is hereby granted
35 *    without fee, provided that the above copyright notice appear in
36 *    all copies and that both that copyright notice and this
37 *    permission notice appear in supporting documentation, and that
38 *    the name of M.I.T. not be used in advertising or publicity
39 *    pertaining to distribution of the software without specific,
40 *    written prior permission.  M.I.T. makes no representations about
41 *    the suitability of this software for any purpose.  It is
42 *    provided "as is" without express or implied warranty."
43 * */
44
45#define XOTCL_C 1
46#include "xotclInt.h"
47#include "xotclAccessInt.h"
48
49#ifdef KEEP_TCL_CMD_TYPE
50/*# include "tclCompile.h"*/
51#endif
52
53#ifdef COMPILE_XOTCL_STUBS
54extern XotclStubs xotclStubs;
55#endif
56
57#ifdef XOTCL_MEM_COUNT
58int xotclMemCountInterpCounter = 0;
59#endif
60
61
62/*
63 * Tcl_Obj Types for XOTcl Objects
64 */
65
66#ifdef USE_TCL_STUBS
67# define XOTcl_ExprObjCmd(cd, interp, objc, objv)      \
68	XOTclCallCommand(interp, XOTE_EXPR, objc, objv)
69# define XOTcl_SubstObjCmd(cd, interp, objc, objv)     \
70	XOTclCallCommand(interp, XOTE_SUBST, objc, objv)
71#else
72# define XOTcl_ExprObjCmd(cd, interp, objc, objv)      \
73	Tcl_ExprObjCmd(cd, interp, objc, objv)
74# define XOTcl_SubstObjCmd(cd, interp, objc, objv)     \
75	Tcl_SubstObjCmd(cd, interp, objc, objv)
76#endif
77
78
79static int SetXOTclObjectFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
80static void UpdateStringOfXOTclObject(Tcl_Obj *objPtr);
81static void FreeXOTclObjectInternalRep(Tcl_Obj *objPtr);
82static void DupXOTclObjectInternalRep(Tcl_Obj *src, Tcl_Obj *cpy);
83
84static Tcl_Obj*NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *ns);
85static Tcl_Namespace *callingNameSpace(Tcl_Interp *interp);
86XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, char *name, Tcl_Namespace *ns);
87#ifdef EXPERIMENTAL_CMD_RESOLVER
88static int NSisXOTclNamespace(Tcl_Namespace *nsPtr);
89#endif
90
91XOTCLINLINE static void GuardAdd(Tcl_Interp *interp, XOTclCmdList *filterCL, Tcl_Obj *guard);
92static int GuardCheck(Tcl_Interp *interp, ClientData guards);
93static int GuardCall(XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, Tcl_Interp *interp, ClientData clientData, int push);
94static void GuardDel(XOTclCmdList *filterCL);
95static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl);
96static int hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl);
97static int isSubType(XOTclClass *subcl, XOTclClass *cl);
98
99static Tcl_ObjType XOTclObjectType = {
100  "XOTclObject",
101  FreeXOTclObjectInternalRep,
102  DupXOTclObjectInternalRep,
103  UpdateStringOfXOTclObject,
104  SetXOTclObjectFromAny
105};
106
107typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel;
108
109typedef struct callFrameContext {
110  int framesSaved;
111  Tcl_CallFrame *framePtr;
112  Tcl_CallFrame *varFramePtr;
113} callFrameContext;
114typedef struct tclCmdClientData {
115  XOTclObject *obj;
116  Tcl_Obj *cmdName;
117} tclCmdClientData;
118typedef struct forwardCmdClientData {
119  XOTclObject *obj;
120  Tcl_Obj *cmdName;
121  Tcl_ObjCmdProc *objProc;
122  int passthrough;
123  int needobjmap;
124  int verbose;
125  ClientData cd;
126  int nr_args;
127  Tcl_Obj *args;
128  int objscope;
129  Tcl_Obj *prefix;
130  int nr_subcommands;
131  Tcl_Obj *subcommands;
132} forwardCmdClientData;
133typedef struct aliasCmdClientData {
134  XOTclObject *obj;
135  Tcl_Obj *cmdName;
136  Tcl_ObjCmdProc *objProc;
137  ClientData cd;
138} aliasCmdClientData;
139
140XOTCLINLINE static int DoDispatch(ClientData cd, Tcl_Interp *interp, int objc,
141                                  Tcl_Obj *CONST objv[], int flags);
142static int XOTclNextMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclClass *givenCl,
143                           char *givenMethod, int objc, Tcl_Obj *CONST objv[],
144                           int useCSObjs);
145
146static int XOTclForwardMethod(ClientData cd, Tcl_Interp *interp, int objc,
147                              Tcl_Obj *CONST objv[]);
148static int XOTclObjscopedMethod(ClientData cd, Tcl_Interp *interp, int objc,
149                                Tcl_Obj *CONST objv[]);
150static int XOTclSetterMethod(ClientData cd, Tcl_Interp *interp, int objc,
151                             Tcl_Obj *CONST objv[]);
152
153static int callDestroyMethod(ClientData cd, Tcl_Interp *interp, XOTclObject *obj, int flags);
154
155static int XOTclObjConvertObject(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj);
156static XOTclObject *XOTclpGetObject(Tcl_Interp *interp, char *name);
157static XOTclClass *XOTclpGetClass(Tcl_Interp *interp, char *name);
158static XOTclCallStackContent *CallStackGetFrame(Tcl_Interp *interp);
159#if !defined(NDEBUG)
160static void checkAllInstances(Tcl_Interp *interp, XOTclClass *startCl, int lvl);
161#endif
162
163#if defined(PRE85)
164# define XOTcl_FindHashEntry(tablePtr, key) Tcl_FindHashEntry(tablePtr, key)
165#else
166# define XOTcl_FindHashEntry(tablePtr, key) Tcl_CreateHashEntry(tablePtr, key, NULL)
167#endif
168
169
170
171
172#ifdef PRE81
173/* for backward compatibility only
174 */
175static int
176Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) {
177  int i, result;
178  Tcl_DString ds, *dsp = &ds;
179
180  assert(flags == 0);
181  DSTRING_INIT(dsp);
182  for (i = 0; i < objc; i++) {
183    Tcl_DStringAppendElement(dsp, ObjStr(objv[i]));
184  }
185  result = Tcl_Eval(interp, Tcl_DStringValue(dsp));
186  DSTRING_FREE(dsp);
187  return result;
188}
189static int
190Tcl_EvalEx(Tcl_Interp *interp, char *cmd, int len, int flags) {
191  return Tcl_Eval(interp, cmd);
192}
193static int
194Tcl_SubstObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
195  char *ov[20];
196  int i;
197  assert(objc<19);
198  for (i=0; i<objc; i++)
199    ov[i] = ObjStr(objv[i]);
200
201  return Tcl_SubstCmd(cd, interp, objc, ov);
202}
203#endif
204
205/*
206 * Var Reform Compatibility support
207 */
208
209#if !defined(TclOffset)
210#ifdef offsetof
211#define TclOffset(type, field) ((int) offsetof(type, field))
212#else
213#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field))
214#endif
215#endif
216
217#if defined(PRE85) && FORWARD_COMPATIBLE
218/*
219 * Define the types missing for the forward compatible mode
220 */
221typedef Var * (Tcl_VarHashCreateVarFunction) _ANSI_ARGS_(
222                                                         (TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr)
223                                                         );
224typedef void (Tcl_InitVarHashTableFunction) _ANSI_ARGS_(
225                                                        (TclVarHashTable *tablePtr, Namespace *nsPtr)
226                                                        );
227typedef void (Tcl_CleanupVarFunction) _ANSI_ARGS_ (
228                                                   (Var * varPtr, Var *arrayPtr)
229                                                   );
230typedef Var * (Tcl_DeleteVarFunction) _ANSI_ARGS_ (
231                                                   (Interp *iPtr, TclVarHashTable *tablePtr)
232                                                   );
233typedef Var * (lookupVarFromTableFunction) _ANSI_ARGS_ (
234                                                        (TclVarHashTable *varTable, CONST char *simpleName, XOTclObject *obj)
235                                                        );
236
237
238typedef struct TclVarHashTable85 {
239  Tcl_HashTable table;
240  struct Namespace *nsPtr;
241} TclVarHashTable85;
242
243typedef struct Var85 {
244  int flags;
245  union {
246    Tcl_Obj *objPtr;
247    TclVarHashTable85 *tablePtr;
248    struct Var85 *linkPtr;
249  } value;
250} Var85;
251
252typedef struct VarInHash {
253  Var85 var;
254  int refCount;
255  Tcl_HashEntry entry;
256} VarInHash;
257
258
259typedef struct Tcl_CallFrame85 {
260  Tcl_Namespace *nsPtr;
261  int dummy1;
262  int dummy2;
263  char *dummy3;
264  char *dummy4;
265  char *dummy5;
266  int dummy6;
267  char *dummy7;
268  char *dummy8;
269  int dummy9;
270  char *dummy10;
271  char *dummy11;
272  char *dummy12;
273} Tcl_CallFrame85;
274
275typedef struct CallFrame85 {
276  Namespace *nsPtr;
277  int isProcCallFrame;
278  int objc;
279  Tcl_Obj *CONST *objv;
280  struct CallFrame *callerPtr;
281  struct CallFrame *callerVarPtr;
282  int level;
283  Proc *procPtr;
284  TclVarHashTable *varTablePtr;
285  int numCompiledLocals;
286  Var85 *compiledLocals;
287  ClientData clientData;
288  void *localCachePtr;
289} CallFrame85;
290
291/*
292 * These are global variables, but thread-safe, since they
293 * are only set during initialzation and they are never changed,
294 * and the variables are single words.
295 */
296static int forwardCompatibleMode;
297
298static Tcl_VarHashCreateVarFunction  *tclVarHashCreateVar;
299static Tcl_InitVarHashTableFunction  *tclInitVarHashTable;
300static Tcl_CleanupVarFunction        *tclCleanupVar;
301static lookupVarFromTableFunction    *lookupVarFromTable;
302
303static int varRefCountOffset;
304static int varHashTableSize;
305
306# define VarHashRefCount(varPtr)                      \
307  (*((int *) (((char *)(varPtr))+varRefCountOffset)))
308
309# define VarHashGetValue(hPtr)                            \
310  (forwardCompatibleMode ?                                \
311   (Var *) ((char *)hPtr - TclOffset(VarInHash, entry)) : \
312   (Var *) Tcl_GetHashValue(hPtr)                         \
313   )
314
315#define VarHashGetKey(varPtr)                   \
316  (((VarInHash *)(varPtr))->entry.key.objPtr)
317
318#define VAR_TRACED_READ85        0x10       /* TCL_TRACE_READS  */
319#define VAR_TRACED_WRITE85       0x20       /* TCL_TRACE_WRITES */
320#define VAR_TRACED_UNSET85       0x40       /* TCL_TRACE_UNSETS */
321#define VAR_TRACED_ARRAY85       0x800      /* TCL_TRACE_ARRAY  */
322#define VAR_TRACE_ACTIVE85       0x2000
323#define VAR_SEARCH_ACTIVE85      0x4000
324#define VAR_ALL_TRACES85                                                \
325  (VAR_TRACED_READ85|VAR_TRACED_WRITE85|VAR_TRACED_ARRAY85|VAR_TRACED_UNSET85)
326
327#define VAR_ARRAY85            0x1
328#define VAR_LINK85             0x2
329
330#define varFlags(varPtr)                        \
331  (forwardCompatibleMode ?                      \
332   ((Var85 *)varPtr)->flags :                   \
333   (varPtr)->flags                              \
334   )
335#undef TclIsVarScalar
336#define TclIsVarScalar(varPtr)                              \
337  (forwardCompatibleMode ?                                  \
338   !(((Var85 *)varPtr)->flags & (VAR_ARRAY85|VAR_LINK85)) : \
339   ((varPtr)->flags & VAR_SCALAR)                           \
340   )
341#undef TclIsVarArray
342#define TclIsVarArray(varPtr)                   \
343  (forwardCompatibleMode ?                      \
344   (((Var85 *)varPtr)->flags & VAR_ARRAY85) :   \
345   ((varPtr)->flags & VAR_ARRAY)                \
346   )
347#define TclIsVarNamespaceVar(varPtr)                \
348  (forwardCompatibleMode ?                          \
349   (((Var85 *)varPtr)->flags & VAR_NAMESPACE_VAR) : \
350   ((varPtr)->flags & VAR_NAMESPACE_VAR)            \
351   )
352
353#define TclIsVarTraced(varPtr)                      \
354  (forwardCompatibleMode ?                          \
355   (((Var85 *)varPtr)->flags & VAR_ALL_TRACES85) :  \
356   (varPtr->tracePtr != NULL)                       \
357   )
358#undef TclIsVarLink
359#define TclIsVarLink(varPtr)                    \
360  (forwardCompatibleMode ?                      \
361   (((Var85 *)varPtr)->flags & VAR_LINK85) :    \
362   (varPtr->flags & VAR_LINK)                   \
363   )
364#undef TclIsVarUndefined
365#define TclIsVarUndefined(varPtr)               \
366  (forwardCompatibleMode ?                      \
367   (((Var85 *)varPtr)->value.objPtr == NULL) :  \
368   (varPtr->flags & VAR_UNDEFINED)              \
369   )
370#undef TclSetVarLink
371#define TclSetVarLink(varPtr)                                           \
372  if (forwardCompatibleMode)                                            \
373    ((Var85 *)varPtr)->flags = (((Var85 *)varPtr)->flags & ~VAR_ARRAY85) | VAR_LINK85; \
374  else                                                                  \
375    (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK
376
377#undef TclClearVarUndefined
378#define TclClearVarUndefined(varPtr)            \
379  if (!forwardCompatibleMode)                   \
380    (varPtr)->flags &= ~VAR_UNDEFINED
381
382#undef Tcl_CallFrame_compiledLocals
383#define Tcl_CallFrame_compiledLocals(cf)          \
384  (forwardCompatibleMode ?                        \
385   (Var *)(((CallFrame85 *)cf)->compiledLocals) : \
386   (((CallFrame*)cf)->compiledLocals)             \
387   )
388
389#define getNthVar(varPtr, i)                    \
390  (forwardCompatibleMode ?                      \
391   (Var *)(((Var85 *)varPtr)+(i)) :             \
392   (((Var *)varPtr)+(i))                        \
393   )
394
395#define valueOfVar(type, varPtr, field)          \
396  (forwardCompatibleMode ?                      \
397   (type *)(((Var85 *)varPtr)->value.field) :   \
398   (type *)(((Var *)varPtr)->value.field)       \
399   )
400#endif
401
402
403#if !FORWARD_COMPATIBLE
404# define getNthVar(varPtr, i) (((Var *)varPtr)+(i))
405#endif
406
407
408#define TclIsCompiledLocalArgument(compiledLocalPtr)  \
409  ((compiledLocalPtr)->flags & VAR_ARGUMENT)
410#define TclIsCompiledLocalTemporary(compiledLocalPtr) \
411  ((compiledLocalPtr)->flags & VAR_TEMPORARY)
412
413#if defined(PRE85) && !FORWARD_COMPATIBLE
414# define VarHashGetValue(hPtr) (Var *)Tcl_GetHashValue(hPtr)
415# define VarHashRefCount(varPtr) (varPtr)->refCount
416# define TclIsVarTraced(varPtr)  (varPtr->tracePtr != NULL)
417# define TclIsVarNamespaceVar(varPtr) ((varPtr)->flags & VAR_NAMESPACE_VAR)
418# define varHashTableSize sizeof(TclVarHashTable)
419# define valueOfVar(type, varPtr, field) (type *)(varPtr)->value.field
420#endif
421
422
423#if defined(PRE85)
424/*
425 * We need NewVar from tclVar.c ... but its not exported
426 */
427static Var *NewVar84() {
428  register Var *varPtr;
429
430  varPtr = (Var *) ckalloc(sizeof(Var));
431  varPtr->value.objPtr = NULL;
432  varPtr->name = NULL;
433  varPtr->nsPtr = NULL;
434  varPtr->hPtr = NULL;
435  varPtr->refCount = 0;
436  varPtr->tracePtr = NULL;
437  varPtr->searchPtr = NULL;
438  varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);
439  return varPtr;
440}
441
442static Var *
443VarHashCreateVar84(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) {
444  char *newName = ObjStr(key);
445  Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, newName, newPtr);
446  Var *varPtr;
447
448  if (newPtr && *newPtr) {
449    varPtr = NewVar84();
450    Tcl_SetHashValue(hPtr, varPtr);
451    varPtr->hPtr = hPtr;
452    varPtr->nsPtr = NULL; /* a local variable */
453  } else {
454    varPtr = (Var *) Tcl_GetHashValue(hPtr);
455  }
456
457  return varPtr;
458}
459
460static void
461InitVarHashTable84(TclVarHashTable *tablePtr, Namespace *nsPtr) {
462  /* fprintf(stderr,"InitVarHashTable84\n"); */
463  Tcl_InitHashTable((tablePtr), TCL_STRING_KEYS);
464}
465
466static void
467TclCleanupVar84(Var * varPtr, Var *arrayPtr) {
468  if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)
469      && (varPtr->tracePtr == NULL)
470      && (varPtr->flags & VAR_IN_HASHTABLE)) {
471    if (varPtr->hPtr) {
472      Tcl_DeleteHashEntry(varPtr->hPtr);
473    }
474    ckfree((char *) varPtr);
475  }
476  if (arrayPtr) {
477    if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0)
478        && (arrayPtr->tracePtr == NULL)
479        && (arrayPtr->flags & VAR_IN_HASHTABLE)) {
480      if (arrayPtr->hPtr) {
481        Tcl_DeleteHashEntry(arrayPtr->hPtr);
482      }
483      ckfree((char *) arrayPtr);
484    }
485  }
486}
487static Var *
488LookupVarFromTable84(TclVarHashTable *varTable, CONST char *simpleName,
489                     XOTclObject *obj) {
490  Var *varPtr = NULL;
491  Tcl_HashEntry *entryPtr;
492
493  if (varTable) {
494    entryPtr = XOTcl_FindHashEntry(varTable, simpleName);
495    if (entryPtr) {
496      varPtr = VarHashGetValue(entryPtr);
497    }
498  }
499  return varPtr;
500}
501#endif
502
503
504#if defined(PRE85)
505# if FORWARD_COMPATIBLE
506#  define VarHashCreateVar   (*tclVarHashCreateVar)
507#  define InitVarHashTable   (*tclInitVarHashTable)
508#  define CleanupVar         (*tclCleanupVar)
509#  define LookupVarFromTable (*lookupVarFromTable)
510#  define TclCallFrame       Tcl_CallFrame85
511# else
512#  define VarHashCreateVar   VarHashCreateVar84
513#  define InitVarHashTable   InitVarHashTable84
514#  define CleanupVar         TclCleanupVar84
515#  define LookupVarFromTable LookupVarFromTable84
516#  define TclCallFrame       Tcl_CallFrame
517# endif
518#else
519# define VarHashCreateVar   VarHashCreateVar85
520# define InitVarHashTable   TclInitVarHashTable
521# define CleanupVar         TclCleanupVar
522# define LookupVarFromTable LookupVarFromTable85
523# define TclCallFrame       Tcl_CallFrame
524#endif
525
526
527#if defined(PRE85)
528/*
529 * for backward compatibility
530 */
531
532#define VarHashTable(t) t
533#define TclVarHashTable Tcl_HashTable
534
535static Var *
536XOTclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, CONST char *part2,
537                  int flags, const char *msg, int createPart1, int createPart2,
538                  Var **arrayPtrPtr) {
539
540  return TclLookupVar(interp, ObjStr(part1Ptr), part2, flags, msg,
541                      createPart1, createPart2, arrayPtrPtr);
542}
543
544#define ObjFindNamespace(interp, objPtr)                \
545  Tcl_FindNamespace((interp), ObjStr(objPtr), NULL, 0);
546
547#else
548
549/*
550 *  definitions for tcl 8.5
551 */
552
553#define VarHashGetValue(hPtr)                             \
554  ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
555#define VarHashGetKey(varPtr)                   \
556  (((VarInHash *)(varPtr))->entry.key.objPtr)
557#define VarHashTable(varTable)                  \
558  &(varTable)->table
559#define XOTclObjLookupVar TclObjLookupVar
560#define varHashTableSize sizeof(TclVarHashTable)
561#define valueOfVar(type, varPtr, field) (type *)(varPtr)->value.field
562
563XOTCLINLINE static Tcl_Namespace *
564ObjFindNamespace(Tcl_Interp *interp, Tcl_Obj *objPtr) {
565  Tcl_Namespace *nsPtr;
566
567  if (TclGetNamespaceFromObj(interp, objPtr, &nsPtr) == TCL_OK) {
568    return nsPtr;
569  } else {
570    return NULL;
571  }
572}
573#endif
574
575#if !defined(PRE85) || FORWARD_COMPATIBLE
576static XOTCLINLINE Var *
577VarHashCreateVar85(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr)
578{
579  Var *varPtr = NULL;
580  Tcl_HashEntry *hPtr;
581  hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
582                             (char *) key, newPtr);
583  if (hPtr) {
584    varPtr = VarHashGetValue(hPtr);
585  }
586  return varPtr;
587}
588
589static XOTCLINLINE Var *
590LookupVarFromTable85(TclVarHashTable *tablePtr, CONST char *simpleName,
591                     XOTclObject *obj) {
592  Var *varPtr = NULL;
593  if (tablePtr) {
594    Tcl_Obj *keyPtr = Tcl_NewStringObj(simpleName, -1);
595    Tcl_IncrRefCount(keyPtr);
596    varPtr = VarHashCreateVar85(tablePtr, keyPtr, NULL);
597    Tcl_DecrRefCount(keyPtr);
598  }
599  return varPtr;
600}
601#endif
602
603
604
605
606
607/*
608 * call an XOTcl method
609 */
610static int
611callMethod(ClientData cd, Tcl_Interp *interp, Tcl_Obj *method,
612           int objc, Tcl_Obj *CONST objv[], int flags) {
613  XOTclObject *obj = (XOTclObject*) cd;
614  int result;
615  ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
616
617  tov[0] = obj->cmdName;
618  tov[1] = method;
619
620  if (objc>2)
621    memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc-2));
622
623  /*fprintf(stderr, "%%%% callMethod cmdname=%s, method=%s, objc=%d\n",
624    ObjStr(tov[0]), ObjStr(tov[1]), objc);*/
625  result = DoDispatch(cd, interp, objc, tov, flags);
626  /*fprintf(stderr, "     callMethod returns %d\n", result);*/
627  FREE_ON_STACK(Tcl_Obj *,tov);
628  return result;
629}
630
631int
632XOTclCallMethodWithArgs(ClientData cd, Tcl_Interp *interp, Tcl_Obj *method, Tcl_Obj *arg,
633                        int givenobjc, Tcl_Obj *CONST objv[], int flags) {
634  XOTclObject *obj = (XOTclObject*) cd;
635  int objc = givenobjc + 2;
636  int result;
637  ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
638
639  assert(objc>1);
640  tov[0] = obj->cmdName;
641  tov[1] = method;
642  if (objc>2) {
643    tov[2] = arg;
644  }
645  if (objc>3)
646    memcpy(tov+3, objv, sizeof(Tcl_Obj *)*(objc-3));
647
648  result = DoDispatch(cd, interp, objc, tov, flags);
649
650  FREE_ON_STACK(Tcl_Obj *, tov);
651  return result;
652}
653
654/*
655 *  realize self, class, proc through the [self] command
656 */
657
658XOTCLINLINE static CONST84 char *
659GetSelfProc(Tcl_Interp *interp) {
660  /*return Tcl_GetCommandName(interp, RUNTIME_STATE(interp)->cs.top->cmdPtr);*/
661  return Tcl_GetCommandName(interp, CallStackGetFrame(interp)->cmdPtr);
662
663}
664
665XOTCLINLINE static XOTclClass*
666GetSelfClass(Tcl_Interp *interp) {
667  /*return RUNTIME_STATE(interp)->cs.top->cl;*/
668  return CallStackGetFrame(interp)->cl;
669}
670
671XOTCLINLINE static XOTclObject*
672GetSelfObj(Tcl_Interp *interp) {
673  return CallStackGetFrame(interp)->self;
674}
675
676/* extern callable GetSelfObj */
677XOTcl_Object*
678XOTclGetSelfObj(Tcl_Interp *interp) {
679  return (XOTcl_Object*)GetSelfObj(interp);
680}
681
682XOTCLINLINE static Tcl_Command
683GetSelfProcCmdPtr(Tcl_Interp *interp) {
684  /*return RUNTIME_STATE(interp)->cs.top->cmdPtr;*/
685  return CallStackGetFrame(interp)->cmdPtr;
686}
687
688/*
689 * prints a msg to the screen that oldCmd is deprecated
690 * optinal: give a new cmd
691 */
692extern void
693XOTclDeprecatedMsg(char *oldCmd, char *newCmd) {
694  fprintf(stderr, "**\n**\n** The command/method <%s> is deprecated.\n", oldCmd);
695  if (newCmd)
696    fprintf(stderr, "** Use <%s> instead.\n", newCmd);
697  fprintf(stderr, "**\n");
698}
699
700static int
701XOTcl_DeprecatedCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
702  char *new;
703  if (objc == 2)
704    new = 0;
705  else if (objc == 3)
706    new = ObjStr(objv[2]);
707  else
708    return XOTclObjErrArgCnt(interp, NULL, "deprecated oldcmd ?newcmd?");
709  XOTclDeprecatedMsg(ObjStr(objv[1]), new);
710  return TCL_OK;
711}
712#ifdef DISPATCH_TRACE
713static void printObjv(int objc, Tcl_Obj *CONST objv[]) {
714  int i, j;
715  if (objc <= 3) j = objc; else j = 3;
716  for (i=0;i<j;i++) fprintf(stderr, " %s", ObjStr(objv[i]));
717  if (objc > 3) fprintf(stderr," ...");
718  fprintf(stderr," (objc=%d)", objc);
719}
720
721static void printCall(Tcl_Interp *interp, char *string, int objc, Tcl_Obj *CONST objv[]) {
722  fprintf(stderr, "     (%d) >%s: ", Tcl_Interp_numLevels(interp), string);
723  printObjv(objc, objv);
724  fprintf(stderr, "\n");
725}
726static void printExit(Tcl_Interp *interp, char *string,
727                      int objc, Tcl_Obj *CONST objv[], int result) {
728  fprintf(stderr, "     (%d) <%s: ", Tcl_Interp_numLevels(interp), string);
729  /*printObjv(objc, objv);*/
730  fprintf(stderr, " result=%d\n", result);
731}
732#endif
733
734
735/*
736 *  XOTclObject Reference Accounting
737 */
738#if defined(XOTCLOBJ_TRACE)
739# define XOTclObjectRefCountIncr(obj)                                   \
740  obj->refCount++;                                                      \
741  fprintf(stderr, "RefCountIncr %p count=%d %s\n", obj, obj->refCount, obj->cmdName?ObjStr(obj->cmdName):"no name"); \
742  MEM_COUNT_ALLOC("XOTclObject RefCount", obj)
743# define XOTclObjectRefCountDecr(obj)                                 \
744  obj->refCount--;                                                    \
745  fprintf(stderr, "RefCountDecr %p count=%d\n", obj, obj->refCount);  \
746  MEM_COUNT_FREE("XOTclObject RefCount", obj)
747#else
748# define XOTclObjectRefCountIncr(obj)           \
749  obj->refCount++;                              \
750  MEM_COUNT_ALLOC("XOTclObject RefCount", obj)
751# define XOTclObjectRefCountDecr(obj)           \
752  obj->refCount--;                              \
753  MEM_COUNT_FREE("XOTclObject RefCount", obj)
754#endif
755
756#if defined(XOTCLOBJ_TRACE)
757void objTrace(char *string, XOTclObject *obj) {
758  if (obj)
759    fprintf(stderr,"--- %s tcl %p %s (%d %p) xotcl %p (%d) %s \n", string,
760            obj->cmdName, obj->cmdName->typePtr ? obj->cmdName->typePtr->name : "NULL",
761            obj->cmdName->refCount, obj->cmdName->internalRep.twoPtrValue.ptr1,
762            obj, obj->refCount, ObjStr(obj->cmdName));
763  else
764    fprintf(stderr,"--- No object: %s\n", string);
765}
766#else
767# define objTrace(a, b)
768#endif
769
770
771/* search for tail of name */
772static CONST char *
773NSTail(CONST char *string) {
774  register char *p = (char *)string+strlen(string);
775  while (p > string) {
776    if (*p == ':' && *(p-1) == ':') return p+1;
777    p--;
778  }
779  return string;
780}
781
782XOTCLINLINE static int
783isClassName(char *string) {
784  return (strncmp((string), "::xotcl::classes", 16) == 0);
785}
786
787/* removes preceding ::xotcl::classes from a string */
788XOTCLINLINE static char *
789NSCutXOTclClasses(char *string) {
790  assert(strncmp((string), "::xotcl::classes", 16) == 0);
791  return string+16;
792}
793
794XOTCLINLINE static char *
795NSCmdFullName(Tcl_Command cmd) {
796  Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd);
797  return nsPtr ? nsPtr->fullName : "";
798}
799
800static void
801XOTclCleanupObject(XOTclObject *obj) {
802  XOTclObjectRefCountDecr(obj);
803#if REFCOUNT_TRACE
804  fprintf(stderr,"###CLNO %p refcount = %d\n", obj, obj->refCount);
805#endif
806  if (obj->refCount <= 0) {
807    assert(obj->refCount == 0);
808    assert(obj->flags & XOTCL_DESTROYED);
809#if REFCOUNT_TRACE
810    fprintf(stderr,"###CLNO %p flags %x rc %d destr %d dc %d\n",
811            obj, obj->flags,
812            (obj->flags & XOTCL_REFCOUNTED) != 0,
813            (obj->flags & XOTCL_DESTROYED) != 0,
814            (obj->flags & XOTCL_DESTROY_CALLED) != 0
815            );
816#endif
817
818    MEM_COUNT_FREE("XOTclObject/XOTclClass", obj);
819#if defined(XOTCLOBJ_TRACE) || defined(REFCOUNT_TRACE)
820    fprintf(stderr, "CKFREE Object %p refcount=%d\n", obj, obj->refCount);
821#endif
822#if !defined(NDEBUG)
823    memset(obj, 0, sizeof(XOTclObject));
824#endif
825    /* fprintf(stderr,"CKFREE obj %p\n", obj);*/
826    ckfree((char *) obj);
827  }
828}
829
830
831
832/*
833 *  Tcl_Obj functions for objects
834 */
835static void
836RegisterObjTypes() {
837  Tcl_RegisterObjType(&XOTclObjectType);
838}
839
840static void
841FreeXOTclObjectInternalRep(register Tcl_Obj *objPtr) {
842  XOTclObject *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr;
843
844  /*  fprintf(stderr,"FIP objPtr %p obj %p obj->cmd %p '%s', bytes='%s'\n",
845      objPtr, obj, obj->cmdName, ObjStr(obj->cmdName), objPtr->bytes);
846  */
847#if defined(XOTCLOBJ_TRACE)
848  if (obj)
849    fprintf(stderr,"FIP --- tcl %p (%d)\n", objPtr, objPtr->refCount);
850#endif
851
852#if !defined(REFCOUNTED)
853  if (obj) {
854    XOTclCleanupObject(obj);
855  }
856#else
857  if (obj) {
858#if REFCOUNT_TRACE
859    fprintf(stderr, "FIP in %p\n", obj->teardown);
860    fprintf(stderr, "FIP call is destroy %d\n", RUNTIME_STATE(obj->teardown)->callIsDestroy);
861    fprintf(stderr,"FIP %p flags %x rc %d destr %d dc %d refcount = %d\n",
862            obj, obj->flags,
863            (obj->flags & XOTCL_REFCOUNTED) != 0,
864            (obj->flags & XOTCL_DESTROYED) != 0,
865            (obj->flags & XOTCL_DESTROY_CALLED) != 0,
866            obj->refCount
867            );
868#endif
869    if (obj->flags & XOTCL_REFCOUNTED &&
870        !(obj->flags & XOTCL_DESTROY_CALLED)) {
871      Tcl_Interp *interp = obj->teardown;
872      INCR_REF_COUNT(obj->cmdName);
873      callDestroyMethod((ClientData)obj, interp, obj, 0);
874      /* the call to cleanup is the counterpart of the
875         INCR_REF_COUNT(obj->cmdName) above */
876      XOTclCleanupObject(obj);
877    } else {
878      fprintf(stderr, "BEFORE CLEANUPOBJ %x\n", (obj->flags & XOTCL_REFCOUNTED));
879      XOTclCleanupObject(obj);
880      fprintf(stderr, "AFTER CLEANUPOBJ\n");
881    }
882  }
883#endif
884  objPtr->internalRep.otherValuePtr = NULL;
885  objPtr->typePtr = NULL;
886}
887
888static void
889DupXOTclObjectInternalRep(Tcl_Obj *src, Tcl_Obj *cpy) {
890  XOTclObject *obj = (XOTclObject*)src->internalRep.otherValuePtr;
891#if defined(XOTCLOBJ_TRACE)
892  if (obj) fprintf(stderr,"DIP --- tcl %p (%d)\n", src, src->refCount);
893#endif
894  XOTclObjectRefCountIncr(obj);
895  cpy->internalRep.otherValuePtr = src->internalRep.otherValuePtr;
896  cpy->typePtr = src->typePtr;
897}
898
899static int
900SetXOTclObjectFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr) {
901  Tcl_ObjType *oldTypePtr = (Tcl_ObjType *)objPtr->typePtr;
902  char *string = ObjStr(objPtr);
903  XOTclObject *obj;
904  Tcl_Obj *tmpName = NULL;
905  int result = TCL_OK;
906
907#ifdef XOTCLOBJ_TRACE
908  fprintf(stderr,"SetXOTclObjectFromAny %p '%s' %p\n",
909          objPtr, string, objPtr->typePtr);
910  if (oldTypePtr)
911    fprintf(stderr,"   convert %s to XOTclObject\n", oldTypePtr->name);
912#endif
913
914  if (!isAbsolutePath(string)) {
915    char *nsString;
916    tmpName = NameInNamespaceObj(interp, string, callingNameSpace(interp));
917
918    nsString = ObjStr(tmpName);
919    INCR_REF_COUNT(tmpName);
920    obj = XOTclpGetObject(interp, nsString);
921    DECR_REF_COUNT(tmpName);
922    if (!obj) {
923      /* retry with global namespace */
924      tmpName = Tcl_NewStringObj("::", 2);
925      Tcl_AppendToObj(tmpName, string,-1);
926      INCR_REF_COUNT(tmpName);
927      obj = XOTclpGetObject(interp, ObjStr(tmpName));
928      DECR_REF_COUNT(tmpName);
929    }
930  } else {
931    obj = XOTclpGetObject(interp, string);
932  }
933
934#if 0
935  obj = XOTclpGetObject(interp, string);
936#endif
937
938  if (obj) {
939    if (oldTypePtr && oldTypePtr->freeIntRepProc) {
940#ifdef XOTCLOBJ_TRACE
941      fprintf(stderr,"   freeing type=%p, type=%s\n",
942              objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : "");
943#endif
944      oldTypePtr->freeIntRepProc(objPtr);
945    }
946    XOTclObjectRefCountIncr(obj);
947#if defined(XOTCLOBJ_TRACE)
948    fprintf(stderr, "SetXOTclObjectFromAny tcl %p (%d) xotcl %p (%d)\n",
949            objPtr, objPtr->refCount, obj, obj->refCount);
950#endif
951    objPtr->internalRep.otherValuePtr = (XOTclObject*) obj;
952    objPtr->typePtr = &XOTclObjectType;
953  } else
954    result = TCL_ERROR;
955
956  return result;
957}
958
959static void
960UpdateStringOfXOTclObject(register Tcl_Obj *objPtr) {
961  XOTclObject *obj = (XOTclObject *)objPtr->internalRep.otherValuePtr;
962  char *nsFullName = NULL;
963
964#ifdef XOTCLOBJ_TRACE
965  fprintf(stderr,"UpdateStringOfXOTclObject %p refCount %d\n",
966          objPtr, objPtr->refCount);
967  fprintf(stderr,"    teardown %p id %p destroyCalled %d\n",
968          obj->teardown, obj->id, (obj->flags & XOTCL_DESTROY_CALLED));
969#endif
970
971  /* Here we use GetCommandName, because it doesnt need
972     Interp*, but Tcl_GetCommandFullName(interp, obj->id, ObjName); does*/
973  if (obj && !(obj->flags & XOTCL_DESTROY_CALLED)) {
974    Tcl_DString ds, *dsp = &ds;
975    unsigned l;
976    DSTRING_INIT(dsp);
977    nsFullName = NSCmdFullName(obj->id);
978    if (!(*nsFullName==':' && *(nsFullName+1)==':' &&
979          *(nsFullName+2)=='\0')) {
980      Tcl_DStringAppend(dsp, nsFullName, -1);
981    }
982    Tcl_DStringAppend(dsp, "::", 2);
983    Tcl_DStringAppend(dsp, Tcl_GetCommandName(NULL, obj->id), -1);
984
985    l = (unsigned) Tcl_DStringLength(dsp)+1;
986    objPtr->bytes = (char *) ckalloc(l);
987    memcpy(objPtr->bytes, Tcl_DStringValue(dsp), l);
988    objPtr->length = Tcl_DStringLength(dsp);
989    DSTRING_FREE(dsp);
990  } else if (obj) {
991    fprintf(stderr,"try to read string of deleted command\n");
992    FreeXOTclObjectInternalRep(objPtr);
993    objPtr->bytes = NULL;
994    objPtr->length = 0;
995  } else {
996    objPtr->bytes = NULL;
997    objPtr->length = 0;
998  }
999  /*
1000    fprintf(stderr, "+++UpdateStringOfXOTclObject bytes='%s', length=%d\n",
1001    objPtr->bytes, objPtr->length);
1002  */
1003}
1004
1005#ifdef NOTUSED
1006static Tcl_Obj *
1007NewXOTclObjectObj(register XOTclObject *obj) {
1008  register Tcl_Obj *objPtr;
1009
1010  XOTclNewObj(objPtr);
1011  objPtr->bytes = NULL;
1012  objPtr->internalRep.otherValuePtr = obj;
1013  objPtr->typePtr = &XOTclObjectType;
1014#ifdef XOTCLOBJ_TRACE
1015  fprintf(stderr,"NewXOTclObjectObj %p\n", objPtr);
1016#endif
1017  return objPtr;
1018}
1019#endif
1020
1021static Tcl_Obj *
1022NewXOTclObjectObjName(register XOTclObject *obj, char *name, unsigned l)
1023{
1024  register Tcl_Obj *objPtr;
1025
1026  XOTclNewObj(objPtr);
1027  objPtr->length = l;
1028  objPtr->bytes = ckalloc(l+1);
1029  memcpy(objPtr->bytes, name, l);
1030  *(objPtr->bytes+l) = 0;
1031  objPtr->internalRep.otherValuePtr = obj;
1032  objPtr->typePtr = &XOTclObjectType;
1033
1034#ifdef XOTCLOBJ_TRACE
1035  fprintf(stderr,"NewXOTclObjectObjName tcl %p (%d) xotcl %p (%d) %s\n",
1036          objPtr, objPtr->refCount, obj, obj->refCount, objPtr->bytes);
1037#endif
1038  XOTclObjectRefCountIncr(obj);
1039
1040  return objPtr;
1041}
1042
1043#ifdef KEEP_TCL_CMD_TYPE
1044XOTCLINLINE static CONST86 Tcl_ObjType *
1045GetCmdNameType(Tcl_ObjType CONST86 *cmdType) {
1046  static Tcl_ObjType CONST86 *tclCmdNameType = NULL;
1047
1048  if (tclCmdNameType == NULL) {
1049# if defined(PRE82)
1050    if (cmdType
1051        && cmdType != &XOTclObjectType
1052        && !strcmp(cmdType->name,"cmdName")) {
1053      tclCmdNameType = cmdType;
1054    }
1055# else
1056    static XOTclMutex initMutex = 0;
1057    XOTclMutexLock(&initMutex);
1058    if (tclCmdNameType == NULL)
1059      tclCmdNameType = Tcl_GetObjType("cmdName");
1060    XOTclMutexUnlock(&initMutex);
1061# endif
1062  }
1063  return tclCmdNameType;
1064}
1065#endif
1066
1067#if NOTUSED
1068static int
1069XOTclObjGetObject(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj) {
1070  int result;
1071  register Tcl_ObjType CONST86 *cmdType = objPtr->typePtr;
1072  XOTclObject *o;
1073
1074  if (cmdType == &XOTclObjectType) {
1075    o = (XOTclObject*) objPtr->internalRep.otherValuePtr;
1076    if (!(o->flags & XOTCL_DESTROYED)) {
1077      *obj = o;
1078      return TCL_OK;
1079    }
1080  }
1081
1082  if (cmdType == GetCmdNameType(cmdType)) {
1083    Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr);
1084    /*fprintf(stderr,"obj is of type tclCmd\n");*/
1085    if (cmd) {
1086      o = XOTclGetObjectFromCmdPtr(cmd);
1087      if (o) {
1088        *obj = o;
1089        return TCL_OK;
1090      }
1091    }
1092  }
1093
1094  o = XOTclpGetObject(interp, ObjStr(objPtr));
1095  if (o) {
1096    *obj = o;
1097    return TCL_OK;
1098  }
1099  return TCL_ERROR;
1100}
1101#endif
1102
1103static int
1104XOTclObjConvertObject(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **obj) {
1105  int result;
1106  register Tcl_ObjType CONST86 *cmdType = objPtr->typePtr;
1107
1108  /*
1109   * Only really share the "::x" Tcl_Objs but not "x" because we so not have
1110   * references upon object kills and then will get dangling
1111   * internalRep references to killed XOTclObjects
1112   */
1113  if (cmdType == &XOTclObjectType) {
1114    /*fprintf(stderr,"obj is of type XOTclObjectType\n");*/
1115    if (obj) {
1116      XOTclObject *o = (XOTclObject*) objPtr->internalRep.otherValuePtr;
1117      int refetch = 0;
1118      if (o->flags & XOTCL_DESTROYED) {
1119        /* fprintf(stderr,"????? calling free by hand\n"); */
1120        FreeXOTclObjectInternalRep(objPtr);
1121        refetch = 1;
1122        result = SetXOTclObjectFromAny(interp, objPtr);
1123        if (result == TCL_OK) {
1124          o = (XOTclObject*) objPtr->internalRep.otherValuePtr;
1125          assert(o && !(o->flags & XOTCL_DESTROYED));
1126        }
1127      } else {
1128        result = TCL_OK;
1129      }
1130
1131      *obj = o;
1132
1133#ifdef XOTCLOBJ_TRACE
1134      if (result == TCL_OK)
1135        fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) xotcl %p (%d) r=%d %s\n",
1136                objPtr, objPtr->refCount, o, o->refCount, refetch, objPtr->bytes);
1137      else
1138        fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) **** rc=%d r=%d %s\n",
1139                objPtr, objPtr->refCount, result, refetch, objPtr->bytes);
1140#endif
1141    } else {
1142      result = TCL_OK;
1143    }
1144#ifdef KEEP_TCL_CMD_TYPE
1145  } else if (cmdType == GetCmdNameType(cmdType)) {
1146    Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr);
1147    /*fprintf(stderr,"obj %s is of type tclCmd, cmd=%p\n", ObjStr(objPtr), cmd);*/
1148    if (cmd) {
1149      XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd);
1150      /*
1151        fprintf(stderr,"Got Object from '%s' %p\n", objPtr->bytes, o);
1152        fprintf(stderr,"cmd->objProc %p == %p, proc=%p\n",
1153	      Tcl_Command_objProc(cmd), XOTclObjDispatch,
1154	      Tcl_Command_proc(cmd) );
1155      */
1156      if (o) {
1157        if (obj) *obj = o;
1158        result = TCL_OK;
1159      } else {
1160        goto convert_to_xotcl_object;
1161      }
1162    } else goto convert_to_xotcl_object;
1163#endif
1164  } else {
1165#ifdef KEEP_TCL_CMD_TYPE
1166  convert_to_xotcl_object:
1167#endif
1168    result = SetXOTclObjectFromAny(interp, objPtr);
1169    if (result == TCL_OK && obj) {
1170      *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr;
1171    }
1172  }
1173  return result;
1174}
1175
1176#ifndef NAMESPACEINSTPROCS
1177static Tcl_Namespace *
1178GetCallerVarFrame(Tcl_Interp *interp, Tcl_CallFrame *varFramePtr) {
1179  Tcl_Namespace *nsPtr = NULL;
1180  if (varFramePtr) {
1181    Tcl_CallFrame *callerVarPtr = Tcl_CallFrame_callerVarPtr(varFramePtr);
1182    if (callerVarPtr) {
1183      nsPtr = (Tcl_Namespace *)callerVarPtr->nsPtr;
1184    }
1185  }
1186  if (nsPtr == NULL)
1187    nsPtr = Tcl_Interp_globalNsPtr(interp);
1188
1189  return nsPtr;
1190}
1191#endif
1192
1193static Tcl_Obj*
1194NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *ns) {
1195  Tcl_Obj *objName;
1196  int len;
1197  char *p;
1198
1199  /*fprintf(stderr,"NameInNamespaceObj %s (%p) ", name, ns);*/
1200  if (!ns)
1201    ns = Tcl_GetCurrentNamespace(interp);
1202  objName = Tcl_NewStringObj(ns->fullName,-1);
1203  len = Tcl_GetCharLength(objName);
1204  p = ObjStr(objName);
1205  if (len == 2 && p[0] == ':' && p[1] == ':') {
1206  } else {
1207    Tcl_AppendToObj(objName,"::", 2);
1208  }
1209  Tcl_AppendToObj(objName, name, -1);
1210
1211  /*fprintf(stderr,"returns %s\n", ObjStr(objName));*/
1212  return objName;
1213}
1214
1215
1216
1217static int
1218GetXOTclClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr,
1219                     XOTclClass **cl, int retry) {
1220  XOTclObject *obj;
1221  XOTclClass *cls = NULL;
1222  int result = TCL_OK;
1223  char *objName = ObjStr(objPtr);
1224
1225  /* fprintf(stderr, "GetXOTclClassFromObj %s retry %d\n", objName, retry);*/
1226
1227  if (retry) {
1228    /* we refer to an existing object; use command resolver */
1229    if (!isAbsolutePath(objName)) {
1230      Tcl_Command cmd = NSFindCommand(interp, objName, callingNameSpace(interp));
1231
1232      /*fprintf(stderr, "GetXOTclClassFromObj %s cmd = %p cl=%p retry=%d\n",
1233        objName, cmd, cmd ? XOTclGetClassFromCmdPtr(cmd) : NULL, retry);*/
1234      if (cmd) {
1235        cls = XOTclGetClassFromCmdPtr(cmd);
1236        if (cl) *cl = cls;
1237      }
1238    }
1239  }
1240
1241  if (!cls) {
1242    result = XOTclObjConvertObject(interp, objPtr, &obj);
1243
1244    if (result == TCL_OK) {
1245      cls = XOTclObjectToClass(obj);
1246      if (cls) {
1247        if (cl) *cl = cls;
1248      } else {
1249        /* we have an object, but no class */
1250        result = TCL_ERROR;
1251      }
1252    }
1253  }
1254
1255  if (!cls && retry) {
1256    Tcl_Obj *ov[3];
1257    ov[0] = RUNTIME_STATE(interp)->theClass->object.cmdName;
1258    ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN];
1259    if (isAbsolutePath(objName)) {
1260      ov[2] = objPtr;
1261    } else {
1262      ov[2] = NameInNamespaceObj(interp, objName, callingNameSpace(interp));
1263    }
1264    INCR_REF_COUNT(ov[2]);
1265    /*fprintf(stderr,"+++ calling %s __unknown for %s, objPtr=%s\n",
1266      ObjStr(ov[0]), ObjStr(ov[2]), ObjStr(objPtr)); */
1267
1268    result = Tcl_EvalObjv(interp, 3, ov, 0);
1269    if (result == TCL_OK) {
1270      result = GetXOTclClassFromObj(interp, objPtr, cl, 0);
1271    }
1272    DECR_REF_COUNT(ov[2]);
1273  }
1274
1275  /*fprintf(stderr, "GetXOTclClassFromObj %s returns %d cls = %p *cl = %p\n",
1276    objName, result, cls, cl?*cl:NULL);*/
1277  return result;
1278}
1279
1280extern void
1281XOTclFreeClasses(XOTclClasses *sl) {
1282  XOTclClasses *n;
1283  for (; sl; sl = n) {
1284    n = sl->next;
1285    FREE(XOTclClasses, sl);
1286  }
1287}
1288
1289/* reverse class list, caller is responsible for freeing data */
1290static XOTclClasses*
1291XOTclReverseClasses(XOTclClasses *sl) {
1292  XOTclClasses *first = NULL;
1293  for (; sl; sl = sl->next) {
1294    XOTclClasses *element = NEW(XOTclClasses);
1295    element->cl = sl->cl;
1296    element->clientData = sl->clientData;
1297    element->next = first;
1298    first = element;
1299  }
1300  return first;
1301}
1302
1303extern XOTclClasses**
1304XOTclAddClass(XOTclClasses **cList, XOTclClass *cl, ClientData cd) {
1305  XOTclClasses *l = *cList, *element = NEW(XOTclClasses);
1306  element->cl = cl;
1307  element->clientData = cd;
1308  element->next = NULL;
1309  if (l) {
1310    while (l->next) l = l->next;
1311    l->next = element;
1312  } else
1313    *cList = element;
1314  return &(element->next);
1315}
1316
1317/*
1318 * precedence ordering functions
1319 */
1320
1321enum colors { WHITE, GRAY, BLACK };
1322
1323static XOTclClasses *Super(XOTclClass *cl) { return cl->super; }
1324static XOTclClasses *Sub(XOTclClass *cl) { return cl->sub; }
1325
1326
1327static int
1328TopoSort(XOTclClass *cl, XOTclClass *base, XOTclClasses* (*next)(XOTclClass*)) {
1329  /*XOTclClasses *sl = (*next)(cl);*/
1330  XOTclClasses *sl = next == Super ? cl->super : cl->sub;
1331  XOTclClasses *pl;
1332
1333  /*
1334   * careful to reset the color of unreported classes to
1335   * white in case we unwind with error, and on final exit
1336   * reset color of reported classes to white
1337   */
1338
1339  cl->color = GRAY;
1340  for (; sl; sl = sl->next) {
1341    XOTclClass *sc = sl->cl;
1342    if (sc->color == GRAY) { cl->color = WHITE; return 0; }
1343    if (sc->color == WHITE && !TopoSort(sc, base, next)) {
1344      cl->color = WHITE;
1345      if (cl == base) {
1346        register XOTclClasses *pc;
1347        for (pc = cl->order; pc; pc = pc->next) { pc->cl->color = WHITE; }
1348      }
1349      return 0;
1350    }
1351  }
1352  cl->color = BLACK;
1353  pl = NEW(XOTclClasses);
1354  pl->cl = cl;
1355  pl->next = base->order;
1356  base->order = pl;
1357  if (cl == base) {
1358    register XOTclClasses *pc;
1359    for (pc = cl->order; pc; pc = pc->next) { pc->cl->color = WHITE; }
1360  }
1361  return 1;
1362}
1363
1364static XOTclClasses*
1365TopoOrder(XOTclClass *cl, XOTclClasses* (*next)(XOTclClass*)) {
1366  if (TopoSort(cl, cl, next))
1367    return cl->order;
1368  XOTclFreeClasses(cl->order);
1369  return cl->order = NULL;
1370}
1371
1372static XOTclClasses*
1373ComputeOrder(XOTclClass *cl, XOTclClasses *order, XOTclClasses* (*direction)(XOTclClass*)) {
1374  if (order)
1375    return order;
1376  return cl->order = TopoOrder(cl, direction);
1377}
1378
1379extern XOTclClasses*
1380XOTclComputePrecedence(XOTclClass *cl) {
1381  return ComputeOrder(cl, cl->order, Super);
1382}
1383
1384extern XOTclClasses*
1385XOTclComputeDependents(XOTclClass *cl) {
1386  return ComputeOrder(cl, cl->order, Sub);
1387}
1388
1389
1390static void
1391FlushPrecedencesOnSubclasses(XOTclClass *cl) {
1392  XOTclClasses *pc;
1393  XOTclFreeClasses(cl->order);
1394  cl->order = NULL;
1395  pc = ComputeOrder(cl, cl->order, Sub);
1396
1397  /*
1398   * ordering doesn't matter here - we're just using toposort
1399   * to find all lower classes so we can flush their caches
1400   */
1401
1402  if (pc) pc = pc->next;
1403  for (; pc; pc = pc->next) {
1404    XOTclFreeClasses(pc->cl->order);
1405    pc->cl->order = NULL;
1406  }
1407  XOTclFreeClasses(cl->order);
1408  cl->order = NULL;
1409}
1410
1411static void
1412AddInstance(XOTclObject *obj, XOTclClass *cl) {
1413  obj->cl = cl;
1414  if (cl) {
1415    int nw;
1416    (void) Tcl_CreateHashEntry(&cl->instances, (char *)obj, &nw);
1417  }
1418}
1419
1420static int
1421RemoveInstance(XOTclObject *obj, XOTclClass *cl) {
1422  if (cl) {
1423    Tcl_HashEntry *hPtr = XOTcl_FindHashEntry(&cl->instances, (char *)obj);
1424      if (hPtr) {
1425        Tcl_DeleteHashEntry(hPtr);
1426    	return 1;
1427    }
1428  }
1429  return 0;
1430}
1431
1432/*
1433 * superclass/subclass list maintenance
1434 */
1435
1436static void
1437AS(XOTclClass *cl, XOTclClass *s, XOTclClasses **sl) {
1438  register XOTclClasses *l = *sl;
1439  while (l && l->cl != s) l = l->next;
1440  if (!l) {
1441    XOTclClasses *sc = NEW(XOTclClasses);
1442    sc->cl = s;
1443    sc->next = *sl;
1444    *sl = sc;
1445  }
1446}
1447
1448static void
1449AddSuper(XOTclClass *cl, XOTclClass *super) {
1450  if (cl && super) {
1451    /*
1452     * keep corresponding sub in step with super
1453     */
1454    AS(cl, super, &cl->super);
1455    AS(super, cl, &super->sub);
1456  }
1457}
1458
1459static int
1460RemoveSuper1(XOTclClass *cl, XOTclClass *s, XOTclClasses **sl) {
1461  XOTclClasses *l = *sl;
1462  if (!l) return 0;
1463  if (l->cl == s) {
1464    *sl = l->next;
1465    FREE(XOTclClasses, l);
1466    return 1;
1467  }
1468  while (l->next && l->next->cl != s) l = l->next;
1469  if (l->next) {
1470    XOTclClasses *n = l->next->next;
1471    FREE(XOTclClasses, l->next);
1472    l->next = n;
1473    return 1;
1474  }
1475  return 0;
1476}
1477
1478static int
1479RemoveSuper(XOTclClass *cl, XOTclClass *super) {
1480  /*
1481   * keep corresponding sub in step with super
1482   */
1483  int sp = RemoveSuper1(cl, super, &cl->super);
1484  int sb = RemoveSuper1(super, cl, &super->sub);
1485
1486  return sp && sb;
1487}
1488
1489/*
1490 * internal type checking
1491 */
1492
1493extern XOTcl_Class*
1494XOTclIsClass(Tcl_Interp *interp, ClientData cd) {
1495  if (cd && XOTclObjectIsClass((XOTclObject *)cd))
1496    return (XOTcl_Class*) cd;
1497  return 0;
1498}
1499
1500/*
1501 * methods lookup
1502 */
1503XOTCLINLINE
1504static Tcl_Command
1505FindMethod(char *methodName, Tcl_Namespace *nsPtr) {
1506  register Tcl_HashEntry *entryPtr;
1507  if ((entryPtr = XOTcl_FindHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName))) {
1508    return (Tcl_Command) Tcl_GetHashValue(entryPtr);
1509  }
1510  /*fprintf(stderr, "find %s in %p returns %p\n", methodName, cmdTable, cmd);*/
1511  return NULL;
1512}
1513
1514static XOTclClass*
1515SearchPLMethod(XOTclClasses *pl, char *methodName, Tcl_Command *cmd) {
1516  /* Search the precedence list (class hierarchy) */
1517#if 0
1518  Tcl_HashEntry *entryPtr;
1519  for (; pl;  pl = pl->next) {
1520    if ((entryPtr = XOTcl_FindHashEntry(Tcl_Namespace_cmdTable(pl->cl->nsPtr), methodName))) {
1521      *cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
1522      return pl->cl;
1523    }
1524  }
1525#else
1526  for (; pl;  pl = pl->next) {
1527    if ((*cmd = FindMethod(methodName, pl->cl->nsPtr))) {
1528      return pl->cl;
1529    }
1530  }
1531#endif
1532  return NULL;
1533}
1534
1535
1536static XOTclClass*
1537SearchCMethod(XOTclClass *cl, char *nm, Tcl_Command *cmd) {
1538  assert(cl);
1539  return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd);
1540}
1541
1542static int
1543callDestroyMethod(ClientData cd, Tcl_Interp *interp, XOTclObject *obj, int flags) {
1544  int result;
1545
1546  /* don't call destroy after exit handler started physical
1547     destruction */
1548  if (RUNTIME_STATE(interp)->exitHandlerDestroyRound ==
1549      XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY)
1550    return TCL_OK;
1551
1552  /* fprintf(stderr," obj %p flags %.4x %d\n", obj, obj->flags,
1553     RUNTIME_STATE(interp)->callDestroy);*/
1554
1555  /* we don't call destroy, if we're in the exit handler
1556     during destruction of Object and Class */
1557  if (!RUNTIME_STATE(interp)->callDestroy) {
1558    obj->flags |= XOTCL_DESTROY_CALLED;
1559    /* return TCL_ERROR so that clients know we haven't deleted the
1560       associated command yet */
1561    return TCL_ERROR;
1562  }
1563  /*fprintf(stderr, "+++ calldestroy flags=%d\n", flags);*/
1564  if (obj->flags & XOTCL_DESTROY_CALLED)
1565    return TCL_OK;
1566
1567#if !defined(NDEBUG)
1568  {char *cmdName = ObjStr(obj->cmdName);
1569    assert(cmdName);
1570    /*fprintf(stderr,"findCommand %s -> %p obj->id %p\n", cmdName,
1571      Tcl_FindCommand(interp, cmdName, NULL, 0), obj->id);*/
1572    /*assert(Tcl_FindCommand(interp, cmdName, NULL, 0) != NULL);*/
1573    /*fprintf(stderr,"callDestroyMethod: %p command to be destroyed '%s' does not exist\n",
1574      obj, cmdName);*/
1575  }
1576#endif
1577
1578
1579#ifdef OBJDELETION_TRACE
1580  fprintf(stderr, "   command found\n");
1581  PRINTOBJ("callDestroy", obj);
1582#endif
1583  result = callMethod(cd, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, flags);
1584  if (result != TCL_OK) {
1585    static char cmd[] =
1586      "puts stderr \"[self]: Error in instproc destroy\n\
1587	 $::errorCode $::errorInfo\"";
1588    Tcl_EvalEx(interp, cmd, -1, 0);
1589    if (++RUNTIME_STATE(interp)->errorCount > 20)
1590      Tcl_Panic("too many destroy errors occured. Endless loop?", NULL);
1591  } else {
1592    if (RUNTIME_STATE(interp)->errorCount > 0)
1593      RUNTIME_STATE(interp)->errorCount--;
1594  }
1595
1596#ifdef OBJDELETION_TRACE
1597  fprintf(stderr, "callDestroyMethod for %p exit\n", obj);
1598#endif
1599  return result;
1600}
1601
1602/*
1603 * conditional memory allocations of optional storage
1604 */
1605
1606extern XOTclObjectOpt *
1607XOTclRequireObjectOpt(XOTclObject *obj) {
1608  if (!obj->opt) {
1609    obj->opt = NEW(XOTclObjectOpt);
1610    memset(obj->opt, 0, sizeof(XOTclObjectOpt));
1611  }
1612  return obj->opt;
1613}
1614
1615extern XOTclClassOpt*
1616XOTclRequireClassOpt(XOTclClass *cl) {
1617  assert(cl);
1618  if (!cl->opt) {
1619    cl->opt = NEW(XOTclClassOpt);
1620    memset(cl->opt, 0, sizeof(XOTclClassOpt));
1621    if (cl->object.flags & XOTCL_IS_CLASS) {
1622      cl->opt->id = cl->object.id;  /* probably a temporary solution */
1623    }
1624  }
1625  return cl->opt;
1626}
1627
1628
1629
1630
1631static Tcl_Namespace*
1632NSGetFreshNamespace(Tcl_Interp *interp, ClientData cd, char *name);
1633
1634static void
1635makeObjNamespace(Tcl_Interp *interp, XOTclObject *obj) {
1636#ifdef NAMESPACE_TRACE
1637  fprintf(stderr, "+++ Make Namespace for %s\n", ObjStr(obj->cmdName));
1638#endif
1639  if (!obj->nsPtr) {
1640    Tcl_Namespace *nsPtr;
1641    char *cmdName =  ObjStr(obj->cmdName);
1642    obj->nsPtr = NSGetFreshNamespace(interp, (ClientData)obj, cmdName);
1643    if (!obj->nsPtr)
1644      Tcl_Panic("makeObjNamespace: Unable to make namespace", NULL);
1645    nsPtr = obj->nsPtr;
1646
1647    /*
1648     * Copy all obj variables to the newly created namespace
1649     */
1650
1651    if (obj->varTable) {
1652      Tcl_HashSearch  search;
1653      Tcl_HashEntry   *hPtr;
1654      TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr);
1655      Tcl_HashTable   *varHashTable = VarHashTable(varTable);
1656      Tcl_HashTable   *objHashTable = VarHashTable(obj->varTable);
1657
1658      *varHashTable = *objHashTable; /* copy the table */
1659
1660      if (objHashTable->buckets == objHashTable->staticBuckets) {
1661        varHashTable->buckets = varHashTable->staticBuckets;
1662      }
1663      for (hPtr = Tcl_FirstHashEntry(varHashTable, &search);  hPtr;
1664           hPtr = Tcl_NextHashEntry(&search)) {
1665#if defined(PRE85)
1666        Var *varPtr;
1667# if FORWARD_COMPATIBLE
1668        if (!forwardCompatibleMode) {
1669          varPtr = (Var *) Tcl_GetHashValue(hPtr);
1670          varPtr->nsPtr = (Namespace *)nsPtr;
1671        }
1672# else
1673        varPtr = (Var *) Tcl_GetHashValue(hPtr);
1674        varPtr->nsPtr = (Namespace *)nsPtr;
1675# endif
1676#endif
1677        hPtr->tablePtr = varHashTable;
1678      }
1679
1680      ckfree((char *) obj->varTable);
1681      obj->varTable = NULL;
1682    }
1683  }
1684}
1685
1686/*
1687  typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
1688  *	        Tcl_Interp *interp, CONST char * name, Tcl_Namespace *context,
1689  *	        int flags, Tcl_Var *rPtr));
1690  */
1691int
1692varResolver(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns, int flags, Tcl_Var *varPtr) {
1693  int new;
1694  Tcl_Obj *key;
1695  Tcl_CallFrame *varFramePtr;
1696  Var *newVar;
1697
1698  /* Case 1: The variable is to be resolved in global scope, proceed in
1699   * resolver chain (i.e. return TCL_CONTINUE)
1700   *
1701   * Note: For now, I am not aware of this case to become effective,
1702   * it is a mere safeguard measure.
1703   *
1704   * TODO: Can it be omitted safely?
1705   */
1706
1707  if (flags & TCL_GLOBAL_ONLY) {
1708    /*fprintf(stderr, "global-scoped var detected '%s' in NS '%s'\n", name, \
1709      varFramePtr->nsPtr->fullName);*/
1710    return TCL_CONTINUE;
1711  }
1712
1713  /* Case 2: The variable appears as to be proc-local, so proceed in
1714   * resolver chain (i.e. return TCL_CONTINUE)
1715   *
1716   * Note 1: This happens to be a rare occurrence, e.g. for nested
1717   * object structures which are shadowed by nested Tcl namespaces.
1718   *
1719   * TODO: Cannot reproduce the issue found with xotcl::package->require()
1720   *
1721   * Note 2: It would be possible to resolve the proc-local variable
1722   * directly (by digging into compiled and non-compiled locals etc.),
1723   * however, it would cause further code redundance.
1724   */
1725  varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
1726  /*
1727  fprintf(stderr,"varFramePtr=%p, isProcCallFrame=%d %p\n",varFramePtr,
1728          varFramePtr != NULL ? Tcl_CallFrame_isProcCallFrame(varFramePtr): 0,
1729          varFramePtr != NULL ? Tcl_CallFrame_procPtr(varFramePtr): 0
1730          );
1731  */
1732  if (varFramePtr && Tcl_CallFrame_isProcCallFrame(varFramePtr)) {
1733    /*fprintf(stderr, "proc-scoped var detected '%s' in NS '%s'\n", name,
1734      varFramePtr->nsPtr->fullName);*/
1735    return TCL_CONTINUE;
1736  }
1737
1738  /*
1739   * Check for absolutely/relatively qualified variable names, i.e.
1740   * make sure that the variable name does not contain any namespace qualifiers.
1741   * Proceed with a TCL_CONTINUE, otherwise.
1742   */
1743
1744  if ((*name == ':' && *(name+1) == ':') || NSTail(name) != name) {
1745    return TCL_CONTINUE;
1746  }
1747
1748  /* Case 3: Does the variable exist in the per-object namespace? */
1749  *varPtr = (Tcl_Var)LookupVarFromTable(Tcl_Namespace_varTable(ns),name,NULL);
1750
1751  if(*varPtr == NULL) {
1752    /* We failed to find the variable so far, therefore we create it
1753     * here in the namespace.  Note that the cases (1), (2) and (3)
1754     * TCL_CONTINUE care for variable creation if necessary.
1755     */
1756
1757    key = Tcl_NewStringObj(name, -1);
1758
1759    INCR_REF_COUNT(key);
1760    newVar = VarHashCreateVar(Tcl_Namespace_varTable(ns), key, &new);
1761    DECR_REF_COUNT(key);
1762
1763#if defined(PRE85)
1764# if FORWARD_COMPATIBLE
1765    if (!forwardCompatibleMode) {
1766      newVar->nsPtr = (Namespace *)ns;
1767    }
1768# else
1769    newVar->nsPtr = (Namespace *)ns;
1770# endif
1771#endif
1772    *varPtr = (Tcl_Var)newVar;
1773  }
1774  return *varPtr ? TCL_OK : TCL_ERROR;
1775}
1776
1777
1778static void
1779requireObjNamespace(Tcl_Interp *interp, XOTclObject *obj) {
1780  if (!obj->nsPtr) makeObjNamespace(interp, obj);
1781
1782  /* This puts a per-object namespace resolver into position upon
1783   * acquiring the namespace. Works for object-scoped commands/procs
1784   * and object-only ones (set, unset, ...)
1785   */
1786  Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL,
1787			    varResolver, (Tcl_ResolveCompiledVarProc*)NULL);
1788
1789}
1790extern void
1791XOTclRequireObjNamespace(Tcl_Interp *interp, XOTcl_Object *obj) {
1792  requireObjNamespace(interp,(XOTclObject*) obj);
1793}
1794
1795
1796/*
1797 * Namespace related commands
1798 */
1799
1800static int
1801NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *ns, char *name) {
1802  /* a simple deletion would delete a global command with
1803     the same name, if the command is not existing, so
1804     we use the CmdToken */
1805  Tcl_Command token;
1806  assert(ns);
1807  if ((token = FindMethod(name, ns))) {
1808    return Tcl_DeleteCommandFromToken(interp, token);
1809  }
1810  return -1;
1811}
1812
1813static void CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *obj);
1814static void PrimitiveCDestroy(ClientData cd);
1815static void PrimitiveODestroy(ClientData cd);
1816
1817static void
1818tclDeletesObject(ClientData clientData) {
1819  XOTclObject *object = (XOTclObject*)clientData;
1820  /*fprintf(stderr, "tclDeletesObject %p\n",object);*/
1821  object->flags |= XOTCL_TCL_DELETE;
1822  PrimitiveODestroy(clientData);
1823}
1824
1825static void
1826tclDeletesClass(ClientData clientData) {
1827  XOTclObject *object = (XOTclObject*)clientData;
1828  /*fprintf(stderr, "tclDeletesClass %p\n",object);*/
1829  object->flags |= XOTCL_TCL_DELETE;
1830  PrimitiveCDestroy(clientData);
1831}
1832
1833
1834static void
1835NSDeleteChildren(Tcl_Interp *interp, Tcl_Namespace *ns) {
1836  Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns);
1837  Tcl_HashSearch hSrch;
1838  Tcl_HashEntry *hPtr;
1839
1840#ifdef OBJDELETION_TRACE
1841  fprintf(stderr, "NSDeleteChildren %s\n", ns->fullName);
1842#endif
1843
1844  Tcl_ForgetImport(interp, ns, "*"); /* don't destroy namespace imported objects */
1845
1846  for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr;
1847       hPtr = Tcl_NextHashEntry(&hSrch)) {
1848    Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
1849    if (!Tcl_Command_cmdEpoch(cmd)) {
1850      char *oname = Tcl_GetHashKey(cmdTable, hPtr);
1851      Tcl_DString name;
1852      XOTclObject *obj;
1853      /* fprintf(stderr, " ... child %s\n", oname); */
1854
1855      ALLOC_NAME_NS(&name, ns->fullName, oname);
1856      obj = XOTclpGetObject(interp, Tcl_DStringValue(&name));
1857
1858      if (obj) {
1859        /* fprintf(stderr, " ... obj= %s\n", ObjStr(obj->cmdName));*/
1860
1861        /* in the exit handler physical destroy --> directly call destroy */
1862        if (RUNTIME_STATE(interp)->exitHandlerDestroyRound
1863            == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) {
1864          if (XOTclObjectIsClass(obj))
1865            PrimitiveCDestroy((ClientData) obj);
1866          else
1867            PrimitiveODestroy((ClientData) obj);
1868        } else {
1869          if (obj->teardown && obj->id &&
1870              !(obj->flags & XOTCL_DESTROY_CALLED)) {
1871
1872            if (callDestroyMethod((ClientData)obj, interp, obj, 0) != TCL_OK) {
1873              /* destroy method failed, but we have to remove the command
1874                 anyway. */
1875              obj->flags |= XOTCL_DESTROY_CALLED;
1876
1877              if (obj->teardown) {
1878                CallStackDestroyObject(interp, obj);
1879              }
1880              /*(void*) Tcl_DeleteCommandFromToken(interp, oid);*/
1881            }
1882          }
1883        }
1884      }
1885      DSTRING_FREE(&name);
1886    }
1887  }
1888}
1889
1890/*
1891 * ensure that a variable exists on object varTable or nsPtr->varTable,
1892 * if necessary create it. Return Var * if successful, otherwise 0
1893 */
1894static Var *
1895NSRequireVariableOnObj(Tcl_Interp *interp, XOTclObject *obj, char *name, int flgs) {
1896  XOTcl_FrameDecls;
1897  Var *varPtr, *arrayPtr;
1898
1899  XOTcl_PushFrame(interp, obj);
1900  varPtr = TclLookupVar(interp, name, 0, flgs, "obj vwait",
1901                        /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
1902  XOTcl_PopFrame(interp, obj);
1903  return varPtr;
1904}
1905
1906static int
1907XOTcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command cmd) {
1908  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
1909  XOTclCallStackContent *csc = cs->top;
1910
1911  for (; csc > cs->content; csc--) {
1912    if (csc->cmdPtr == cmd) {
1913      csc->cmdPtr = NULL;
1914    }
1915  }
1916  return Tcl_DeleteCommandFromToken(interp, cmd);
1917}
1918
1919/*
1920 * delete all vars & procs in a namespace
1921 */
1922static void
1923NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *ns) {
1924  TclVarHashTable *varTable = Tcl_Namespace_varTable(ns);
1925  Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns);
1926  Tcl_HashSearch hSrch;
1927  Tcl_HashEntry *hPtr;
1928  Tcl_Command cmd;
1929  /*
1930   * Delete all variables and initialize var table again
1931   * (deleteVars frees the vartable)
1932   */
1933  TclDeleteVars((Interp *)interp, varTable);
1934  InitVarHashTable(varTable, (Namespace *)ns);
1935
1936  /*
1937   * Delete all user-defined procs in the namespace
1938   */
1939  for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr;
1940       hPtr = Tcl_NextHashEntry(&hSrch)) {
1941    cmd = (Tcl_Command) Tcl_GetHashValue(hPtr);
1942    /* objects should not be deleted here to preseve children deletion order*/
1943    if (!XOTclGetObjectFromCmdPtr(cmd)) {
1944      /*fprintf(stderr,"NSCleanupNamespace deleting %s %p\n",
1945        Tcl_Command_nsPtr(cmd)->fullName, cmd);*/
1946      XOTcl_DeleteCommandFromToken(interp, cmd);
1947    }
1948  }
1949}
1950
1951
1952static void
1953NSNamespaceDeleteProc(ClientData clientData) {
1954  /* dummy for ns identification by pointer comparison */
1955  XOTclObject *obj = (XOTclObject*) clientData;
1956  /*fprintf(stderr,"namespacedeleteproc obj=%p\n", clientData);*/
1957  if (obj) {
1958    obj->flags |= XOTCL_NS_DESTROYED;
1959    obj->nsPtr = NULL;
1960  }
1961}
1962
1963#ifdef EXPERIMENTAL_CMD_RESOLVER
1964static int
1965NSisXOTclNamespace(Tcl_Namespace *nsPtr) {
1966  return nsPtr->deleteProc == NSNamespaceDeleteProc;
1967}
1968#endif
1969
1970void
1971XOTcl_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) {
1972  int activationCount = 0;
1973  Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp);
1974
1975  /*
1976    fprintf(stderr, "  ... correcting ActivationCount for %s was %d ",
1977	  nsPtr->fullName, nsp->activationCount);
1978  */
1979  while (f) {
1980    if (f->nsPtr == nsPtr)
1981      activationCount++;
1982    f = Tcl_CallFrame_callerPtr(f);
1983  }
1984
1985  Tcl_Namespace_activationCount(nsPtr) = activationCount;
1986
1987  /*
1988    fprintf(stderr, "to %d. \n", nsp->activationCount);
1989  */
1990  MEM_COUNT_FREE("TclNamespace", nsPtr);
1991  if (Tcl_Namespace_deleteProc(nsPtr)) {
1992    /*fprintf(stderr,"calling deteteNamespace\n");*/
1993    Tcl_DeleteNamespace(nsPtr);
1994  }
1995}
1996
1997static Tcl_Namespace*
1998NSGetFreshNamespace(Tcl_Interp *interp, ClientData cd, char *name) {
1999  Tcl_Namespace *ns = Tcl_FindNamespace(interp, name, NULL, 0);
2000
2001  if (ns) {
2002    if (ns->deleteProc || ns->clientData) {
2003      Tcl_Panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace",
2004            name, ns->deleteProc, ns->clientData);
2005    }
2006    ns->clientData = cd;
2007    ns->deleteProc = (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc;
2008  } else {
2009    ns = Tcl_CreateNamespace(interp, name, cd,
2010                             (Tcl_NamespaceDeleteProc *)NSNamespaceDeleteProc);
2011  }
2012  MEM_COUNT_ALLOC("TclNamespace", ns);
2013  return ns;
2014}
2015
2016
2017/*
2018 * check colons for illegal object/class names
2019 */
2020XOTCLINLINE static int
2021NSCheckColons(char *name, unsigned l) {
2022  register char *n = name;
2023  if (*n == '\0') return 0; /* empty name */
2024  if (l == 0) l=strlen(name);
2025  if (*(n+l-1) == ':')  return 0; /* name ends with : */
2026  if (*n == ':' && *(n+1) != ':') return 0; /* name begins with single : */
2027  for (; *n != '\0'; n++) {
2028    if (*n == ':' && *(n+1) == ':' && *(n+2) == ':')
2029      return 0;   /* more than 2 colons in series in a name */
2030  }
2031  return 1;
2032}
2033
2034/*
2035 * check for parent namespace existance (used before commands are created)
2036 */
2037
2038XOTCLINLINE static int
2039NSCheckForParent(Tcl_Interp *interp, char *name, unsigned l) {
2040  register char *n = name+l;
2041  int result = 1;
2042
2043  /*search for last '::'*/
2044  while ((*n != ':' || *(n-1) != ':') && n-1 > name) {n--; }
2045  if (*n == ':' && n > name && *(n-1) == ':') {n--;}
2046
2047  if ((n-name)>0) {
2048    Tcl_DString parentNSName, *dsp = &parentNSName;
2049    char *parentName;
2050    DSTRING_INIT(dsp);
2051
2052    Tcl_DStringAppend(dsp, name, (n-name));
2053    parentName = Tcl_DStringValue(dsp);
2054
2055    if (Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) == NULL) {
2056      XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName);
2057      if (parentObj) {
2058        /* this is for classes */
2059        requireObjNamespace(interp, parentObj);
2060      } else {
2061        /* call unknown and try again */
2062        Tcl_Obj *ov[3];
2063        int rc;
2064        ov[0] = RUNTIME_STATE(interp)->theClass->object.cmdName;
2065        ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN];
2066        ov[2] = Tcl_NewStringObj(parentName,-1);
2067        INCR_REF_COUNT(ov[2]);
2068        /*fprintf(stderr,"+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/
2069        rc = Tcl_EvalObjv(interp, 3, ov, 0);
2070        if (rc == TCL_OK) {
2071          XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName);
2072          if (parentObj) {
2073            requireObjNamespace(interp, parentObj);
2074          }
2075          result = (Tcl_FindNamespace(interp, parentName,
2076                                      (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != NULL);
2077        } else {
2078          result = 0;
2079        }
2080        DECR_REF_COUNT(ov[2]);
2081      }
2082    } else {
2083      XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName);
2084      if (parentObj) {
2085        requireObjNamespace(interp, parentObj);
2086      }
2087    }
2088    DSTRING_FREE(dsp);
2089  }
2090  return result;
2091}
2092
2093/*
2094 * Find the "real" command belonging eg. to an XOTcl class or object.
2095 * Do not return cmds produced by Tcl_Import, but the "real" cmd
2096 * to which they point.
2097 */
2098XOTCLINLINE static Tcl_Command
2099NSFindCommand(Tcl_Interp *interp, char *name, Tcl_Namespace *ns) {
2100  Tcl_Command cmd;
2101  if ((cmd = Tcl_FindCommand(interp, name, ns, 0))) {
2102    Tcl_Command importedCmd;
2103    if ((importedCmd = TclGetOriginalCommand(cmd)))
2104      cmd = importedCmd;
2105  }
2106  return cmd;
2107}
2108
2109
2110
2111/*
2112 * C interface routines for manipulating objects and classes
2113 */
2114
2115
2116extern XOTcl_Object*
2117XOTclGetObject(Tcl_Interp *interp, char *name) {
2118  return (XOTcl_Object*) XOTclpGetObject(interp, name);
2119}
2120
2121/*
2122 * Find an object using a char *name
2123 */
2124static XOTclObject*
2125XOTclpGetObject(Tcl_Interp *interp, char *name) {
2126  register Tcl_Command cmd;
2127  assert(name);
2128  cmd = NSFindCommand(interp, name, NULL);
2129
2130  /*if (cmd) {
2131    fprintf(stderr,"+++ XOTclGetObject from %s -> objProc=%p, dispatch=%p\n",
2132    name, Tcl_Command_objProc(cmd), XOTclObjDispatch);
2133    }*/
2134
2135  if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) {
2136    return (XOTclObject*)Tcl_Command_objClientData(cmd);
2137  }
2138  return 0;
2139}
2140
2141/*
2142 * Find a class using a char *name
2143 */
2144
2145extern XOTcl_Class*
2146XOTclGetClass(Tcl_Interp *interp, char *name) {
2147  return (XOTcl_Class*)XOTclpGetClass(interp, name);
2148}
2149
2150static XOTclClass*
2151XOTclpGetClass(Tcl_Interp *interp, char *name) {
2152  XOTclObject *obj = XOTclpGetObject(interp, name);
2153  return (obj && XOTclObjectIsClass(obj)) ? (XOTclClass*)obj : NULL;
2154}
2155
2156void
2157XOTclAddPMethod(Tcl_Interp *interp, XOTcl_Object *obji, CONST char *nm, Tcl_ObjCmdProc *proc,
2158                ClientData cd, Tcl_CmdDeleteProc *dp) {
2159  XOTclObject *obj = (XOTclObject*) obji;
2160  Tcl_DString newCmd, *cptr = &newCmd;
2161  requireObjNamespace(interp, obj);
2162  ALLOC_NAME_NS(cptr, obj->nsPtr->fullName, nm);
2163  Tcl_CreateObjCommand(interp, Tcl_DStringValue(cptr), proc, cd, dp);
2164  DSTRING_FREE(cptr);
2165}
2166
2167void
2168XOTclAddIMethod(Tcl_Interp *interp, XOTcl_Class *cli, CONST char *nm,
2169                Tcl_ObjCmdProc *proc, ClientData cd, Tcl_CmdDeleteProc *dp) {
2170  XOTclClass *cl = (XOTclClass*) cli;
2171  Tcl_DString newCmd, *cptr = &newCmd;
2172  ALLOC_NAME_NS(cptr, cl->nsPtr->fullName, nm);
2173  Tcl_CreateObjCommand(interp, Tcl_DStringValue(cptr), proc, cd, dp);
2174  DSTRING_FREE(cptr);
2175}
2176
2177
2178/*
2179 * Generic Tcl_Obj List
2180 */
2181
2182static void
2183TclObjListFreeList(XOTclTclObjList *list) {
2184  XOTclTclObjList *del;
2185  while (list) {
2186    del = list;
2187    list = list->next;
2188    DECR_REF_COUNT(del->content);
2189    FREE(XOTclTclObjList, del);
2190  }
2191}
2192
2193static Tcl_Obj*
2194TclObjListNewElement(XOTclTclObjList **list, Tcl_Obj *ov) {
2195  XOTclTclObjList *elt = NEW(XOTclTclObjList);
2196  INCR_REF_COUNT(ov);
2197  elt->content = ov;
2198  elt->next = *list;
2199  *list = elt;
2200  return ov;
2201}
2202
2203/*
2204 * Autonaming
2205 */
2206
2207static Tcl_Obj*
2208AutonameIncr(Tcl_Interp *interp, Tcl_Obj *name, XOTclObject *obj,
2209             int instanceOpt, int resetOpt) {
2210  int valueLength, mustCopy = 1, format = 0;
2211  char *valueString, *c;
2212  Tcl_Obj *valueObject, *result = NULL, *savedResult = NULL;
2213#ifdef PRE83
2214  int flgs = 0;
2215#else
2216  int flgs = TCL_LEAVE_ERR_MSG;
2217#endif
2218  XOTcl_FrameDecls;
2219
2220  XOTcl_PushFrame(interp, obj);
2221  if (obj->nsPtr)
2222    flgs |= TCL_NAMESPACE_ONLY;
2223
2224  valueObject = Tcl_ObjGetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name, flgs);
2225  if (valueObject) {
2226    long autoname_counter;
2227    /* should probably do an overflow check here */
2228    Tcl_GetLongFromObj(interp, valueObject,&autoname_counter);
2229    autoname_counter++;
2230    if (Tcl_IsShared(valueObject)) {
2231      valueObject = Tcl_DuplicateObj(valueObject);
2232    }
2233    Tcl_SetLongObj(valueObject, autoname_counter);
2234  }
2235  Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name,
2236                 valueObject, flgs);
2237
2238  if (resetOpt) {
2239    if (valueObject) { /* we have an entry */
2240      Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(name), flgs);
2241    }
2242    result = XOTclGlobalObjects[XOTE_EMPTY];
2243    INCR_REF_COUNT(result);
2244  } else {
2245    if (valueObject == NULL) {
2246      valueObject = Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES],
2247                                   name, XOTclGlobalObjects[XOTE_ONE], flgs);
2248    }
2249    if (instanceOpt) {
2250      char buffer[1], firstChar, *nextChars;
2251      nextChars = ObjStr(name);
2252      firstChar = *(nextChars ++);
2253      if (isupper((int)firstChar)) {
2254        buffer[0] = tolower((int)firstChar);
2255        result = Tcl_NewStringObj(buffer, 1);
2256        INCR_REF_COUNT(result);
2257        Tcl_AppendToObj(result, nextChars, -1);
2258        mustCopy = 0;
2259      }
2260    }
2261    if (mustCopy) {
2262      result = Tcl_DuplicateObj(name);
2263      INCR_REF_COUNT(result);
2264      /*
2265        fprintf(stderr,"*** copy %p %s = %p\n", name, ObjStr(name), result);
2266      */
2267    }
2268    /* if we find a % in the autoname -> We use Tcl_FormatObjCmd
2269       to let the autoname string be formated, like Tcl "format"
2270       command, with the value. E.g.:
2271       autoname a%06d --> a000000, a000001, a000002, ...
2272    */
2273    for (c = ObjStr(result); *c != '\0'; c++) {
2274      if (*c == '%') {
2275        if (*(c+1) != '%') {
2276          format = 1;
2277          break;
2278        } else {
2279          /* when we find a %% we format and then append autoname, e.g.
2280             autoname a%% --> a%1, a%2, ... */
2281          c++;
2282        }
2283      }
2284    }
2285    if (format) {
2286      ALLOC_ON_STACK(Tcl_Obj*, 3, ov);
2287      savedResult = Tcl_GetObjResult(interp);
2288      INCR_REF_COUNT(savedResult);
2289      ov[0] = XOTclGlobalObjects[XOTE_FORMAT];
2290      ov[1] = result;
2291      ov[2] = valueObject;
2292      if (Tcl_EvalObjv(interp, 3, ov, 0) != TCL_OK) {
2293        XOTcl_PopFrame(interp, obj);
2294        DECR_REF_COUNT(savedResult);
2295        FREE_ON_STACK(Tcl_Obj *, ov);
2296        return 0;
2297      }
2298      DECR_REF_COUNT(result);
2299      result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
2300      INCR_REF_COUNT(result);
2301      Tcl_SetObjResult(interp, savedResult);
2302      DECR_REF_COUNT(savedResult);
2303      FREE_ON_STACK(Tcl_Obj *, ov);
2304    } else {
2305      valueString = Tcl_GetStringFromObj(valueObject,&valueLength);
2306      Tcl_AppendToObj(result, valueString, valueLength);
2307      /*fprintf(stderr,"+++ append to obj done\n");*/
2308    }
2309  }
2310
2311  XOTcl_PopFrame(interp, obj);
2312  assert((resetOpt && result->refCount>=1) || (result->refCount == 1));
2313  return result;
2314}
2315
2316/*
2317 * XOTcl CallStack
2318 */
2319
2320XOTclCallStackContent *
2321XOTclCallStackFindLastInvocation(Tcl_Interp *interp, int offset) {
2322  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2323  register XOTclCallStackContent *csc = cs->top;
2324  int topLevel = csc->currentFramePtr ? Tcl_CallFrame_level(csc->currentFramePtr) : 0;
2325  int deeper = offset;
2326
2327  /* skip through toplevel inactive filters, do this offset times */
2328  for (csc=cs->top; csc > cs->content; csc--) {
2329      /* fprintf(stderr, "csc %p callType = %x, frameType = %x, offset=%d\n",
2330         csc,csc->callType,csc->frameType,offset); */
2331    if ((csc->callType & XOTCL_CSC_CALL_IS_NEXT) ||
2332        (csc->frameType & XOTCL_CSC_TYPE_INACTIVE))
2333      continue;
2334    if (offset)
2335      offset--;
2336    else {
2337        /* fprintf(stderr, "csc %p offset ok, deeper=%d\n",csc,deeper); */
2338      if (!deeper || cs->top->callType & XOTCL_CSC_CALL_IS_GUARD) {
2339        return csc;
2340      }
2341      if (csc->currentFramePtr && Tcl_CallFrame_level(csc->currentFramePtr) < topLevel) {
2342        return csc;
2343      }
2344    }
2345  }
2346  /* for some reasons, we could not find invocation (topLevel, destroy) */
2347  /* fprintf(stderr, "csc %p could not find invocation\n",csc);*/
2348  return NULL;
2349}
2350
2351static XOTclCallStackContent *
2352CallStackFindActiveFilter(Tcl_Interp *interp) {
2353  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2354  register XOTclCallStackContent *csc;
2355
2356  /* search for first active frame and set tcl frame pointers */
2357  for (csc=cs->top; csc > cs->content; csc --) {
2358    if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) return csc;
2359  }
2360  /* for some reasons, we could not find invocation (topLevel, destroy) */
2361  return NULL;
2362}
2363
2364XOTclCallStackContent *
2365XOTclCallStackFindActiveFrame(Tcl_Interp *interp, int offset) {
2366  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2367  register XOTclCallStackContent *csc;
2368
2369  /* search for first active frame and set tcl frame pointers */
2370  for (csc=cs->top-offset; csc > cs->content; csc --) {
2371    if (!(csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) {
2372      /* we found the highest active frame */
2373      return csc;
2374    }
2375  }
2376  /* we could not find an active frame; called from toplevel? */
2377  return NULL;
2378}
2379
2380static void
2381CallStackUseActiveFrames(Tcl_Interp *interp, callFrameContext *ctx) {
2382  XOTclCallStackContent *active, *top = RUNTIME_STATE(interp)->cs.top;
2383  Tcl_CallFrame *inFramePtr =  (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp);
2384
2385  active = XOTclCallStackFindActiveFrame(interp, 0);
2386  /*fprintf(stderr,"active %p, varFrame(interp) %p, topVarFrame %p, active->curr %p\n",
2387	  active, inFramePtr, top->currentFramePtr,
2388	  active? active->currentFramePtr : NULL);*/
2389
2390  if (active == top || inFramePtr == NULL || Tcl_CallFrame_level(inFramePtr) == 0) {
2391    /* top frame is a active frame, or we could not find a calling
2392       frame, call frame pointers are fine */
2393    ctx->framesSaved = 0;
2394  } else if (active == NULL) {
2395    Tcl_CallFrame *cf = inFramePtr;
2396    /*fprintf(stderr,"active == NULL\n"); */
2397    /* find a proc frame, which is not equal the top level cmd */
2398    /* XOTclStackDump(interp);*/
2399    for (; cf && Tcl_CallFrame_level(cf); cf = Tcl_CallFrame_callerPtr(cf)) {
2400      if (Tcl_CallFrame_isProcCallFrame(cf) && cf != top->currentFramePtr)
2401        break;
2402    }
2403    ctx->varFramePtr = inFramePtr;
2404    Tcl_Interp_varFramePtr(interp) = (CallFrame *) cf;
2405    ctx->framesSaved = 1;
2406  } else {
2407    Tcl_CallFrame *framePtr;
2408    /*fprintf(stderr,"active == deeper active=%p frame %p, active+1 %p frame %p\n",
2409	    active, active->currentFramePtr,
2410	    active+1, (active+1)->currentFramePtr);*/
2411    /* search returned a deeper pointer, use stored tcl frame pointers;
2412       If Tcl is mixed with XOTcl it is needed to use instead of
2413       active->currentFrame the callerPtr of the last inactive frame
2414       unless the last inactive is NULL */
2415    if ((framePtr = (active+1)->currentFramePtr))
2416      framePtr = Tcl_CallFrame_callerPtr(framePtr);
2417    else
2418      framePtr = active->currentFramePtr;
2419    ctx->varFramePtr = inFramePtr;
2420    Tcl_Interp_varFramePtr(interp) = (CallFrame *) framePtr;
2421    ctx->framesSaved = 1;
2422  }
2423}
2424
2425static void
2426CallStackRestoreSavedFrames(Tcl_Interp *interp, callFrameContext *ctx) {
2427  if (ctx->framesSaved) {
2428    Tcl_Interp_varFramePtr(interp) = (CallFrame *)ctx->varFramePtr;
2429    /*RUNTIME_STATE(interp)->varFramePtr = ctx->varFramePtr;*/
2430
2431  }
2432}
2433
2434
2435XOTCLINLINE static int
2436CallStackPush(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl,
2437              Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int frameType) {
2438  XOTclCallStack *cs;
2439  register XOTclCallStackContent *csc;
2440
2441  cs = &RUNTIME_STATE(interp)->cs;
2442  if (cs->top >= &cs->content[MAX_NESTING_DEPTH-1]) {
2443    Tcl_SetResult(interp, "too many nested calls to Tcl_EvalObj (infinite loop?)",
2444                  TCL_STATIC);
2445    return TCL_ERROR;
2446  }
2447  /*fprintf(stderr, "CallStackPush sets self\n");*/
2448  csc = ++cs->top;
2449  csc->self          = obj;
2450  csc->cl            = cl;
2451  csc->cmdPtr        = cmd;
2452  csc->destroyedCmd  = NULL;
2453  csc->frameType     = frameType;
2454  csc->callType      = 0;
2455  csc->currentFramePtr = NULL; /* this will be set by InitProcNSCmd */
2456
2457  if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER)
2458    csc->filterStackEntry = obj->filterStack;
2459  else
2460    csc->filterStackEntry = NULL;
2461
2462  /*fprintf(stderr, "PUSH obj %s, self=%p cmd=%p (%s) id=%p (%s) frame=%p\n",
2463	  ObjStr(obj->cmdName), obj,
2464	  cmd, (char *) Tcl_GetCommandName(interp, cmd),
2465	  obj->id, Tcl_GetCommandName(interp, obj->id), csc);*/
2466
2467  MEM_COUNT_ALLOC("CallStack", NULL);
2468  return TCL_OK;
2469}
2470
2471XOTCLINLINE static void
2472CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *obj) {
2473  Tcl_Command oid;
2474
2475  PRINTOBJ("CallStackDoDestroy", obj);
2476  oid = obj->id;
2477  obj->id = NULL;
2478
2479  if (obj->teardown && oid) {
2480    Tcl_DeleteCommandFromToken(interp, oid);
2481  }
2482}
2483
2484
2485static void
2486CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *obj) {
2487  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2488  XOTclCallStackContent *csc;
2489  int countSelfs = 0;
2490  Tcl_Command oid = obj->id;
2491
2492  for (csc = &cs->content[1]; csc <= cs->top; csc++) {
2493    if (csc->self == obj) {
2494      csc->destroyedCmd = oid;
2495      csc->callType |= XOTCL_CSC_CALL_IS_DESTROY;
2496      /*fprintf(stderr,"setting destroy on frame %p for obj %p\n", csc, obj);*/
2497      if (csc->destroyedCmd) {
2498        Tcl_Command_refCount(csc->destroyedCmd)++;
2499        MEM_COUNT_ALLOC("command refCount", csc->destroyedCmd);
2500      }
2501      countSelfs++;
2502    }
2503  }
2504  /* if the object is not referenced at the callstack anymore
2505     we have to directly destroy it, because CallStackPop won't
2506     find the object destroy */
2507  if (countSelfs == 0) {
2508    /*fprintf(stderr,"directdestroy %p\n", obj);*/
2509    CallStackDoDestroy(interp, obj);
2510  } else {
2511    /*fprintf(stderr,"selfcount for %p = %d\n", obj, countSelfs);*/
2512    /* to prevail the deletion order call delete children now
2513       -> children destructors are called before parent's
2514       destructor */
2515    if (obj->teardown && obj->nsPtr) {
2516      NSDeleteChildren(interp, obj->nsPtr);
2517    }
2518  }
2519}
2520
2521XOTCLINLINE static int
2522CallStackIsDestroyed(Tcl_Interp *interp) {
2523  return (RUNTIME_STATE(interp)->cs.top->destroyedCmd == NULL) ? 0 : 1;
2524}
2525
2526XOTCLINLINE static void
2527CallStackPop(Tcl_Interp *interp) {
2528  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2529  XOTclCallStackContent *csc;
2530  XOTclCallStackContent *h = cs->top;
2531
2532  assert(cs->top > cs->content);
2533  csc = cs->top;
2534
2535  /*fprintf(stderr, "POP frame=%p\n", csc);*/
2536
2537  if (csc->destroyedCmd) {
2538    int destroy = 1;
2539    TclCleanupCommand((Command *)csc->destroyedCmd);
2540    MEM_COUNT_FREE("command refCount", csc->destroyedCmd);
2541    /* do not physically destroy, when callstack still contains "self"
2542       entries of the object */
2543    while (--h > cs->content) {
2544      if (h->self == csc->self) {
2545        destroy = 0;
2546        break;
2547      }
2548    }
2549    if (destroy) {
2550      CallStackDoDestroy(interp, csc->self);
2551    }
2552  }
2553
2554  cs->top--;
2555  MEM_COUNT_FREE("CallStack", NULL);
2556}
2557
2558
2559
2560XOTCLINLINE static XOTclCallStackContent*
2561CallStackGetTopFrame(Tcl_Interp *interp) {
2562  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2563  return cs->top;
2564}
2565
2566static XOTclCallStackContent*
2567CallStackGetFrame(Tcl_Interp *interp) {
2568  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
2569  register XOTclCallStackContent *top = cs->top;
2570  Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
2571
2572  /* fprintf(stderr, "Tcl_Interp_framePtr(interp) %p != varFramePtr %p && top->currentFramePtr %p\n", Tcl_Interp_framePtr(interp), varFramePtr, top->currentFramePtr);*/
2573
2574  if (Tcl_Interp_framePtr(interp) != varFramePtr && top->currentFramePtr) {
2575    XOTclCallStackContent *bot = cs->content + 1;
2576    /*fprintf(stderr, "uplevel\n");*/
2577    /* we are in a uplevel */
2578    while (varFramePtr != top->currentFramePtr && top>bot) {
2579      top--;
2580    }
2581  }
2582  return top;
2583}
2584
2585/*
2586 * cmd list handling
2587 */
2588
2589/*
2590 * Cmd List Add/Remove ... returns the new element
2591 */
2592static XOTclCmdList*
2593CmdListAdd(XOTclCmdList **cList, Tcl_Command c, XOTclClass *clorobj, int noDuplicates) {
2594  XOTclCmdList *l = *cList, *new;
2595
2596  /*
2597   * check for duplicates, if necessary
2598   */
2599  if (noDuplicates) {
2600    XOTclCmdList *h = l, **end = NULL;
2601    while (h) {
2602      if (h->cmdPtr == c)
2603        return h;
2604      end = &(h->next);
2605      h = h->next;
2606    }
2607    if (end) {
2608      /* no duplicates, no need to search below, we are at the end of the list */
2609      cList = end;
2610      l = NULL;
2611    }
2612  }
2613
2614  /*
2615   * ok, we have no duplicates -> append "new"
2616   * to the end of the list
2617   */
2618  new = NEW(XOTclCmdList);
2619  new->cmdPtr = c;
2620  Tcl_Command_refCount(new->cmdPtr)++;
2621  MEM_COUNT_ALLOC("command refCount", new->cmdPtr);
2622  new->clientData = NULL;
2623  new->clorobj = clorobj;
2624  new->next = NULL;
2625
2626  if (l) {
2627    while (l->next)
2628      l = l->next;
2629    l->next = new;
2630  } else
2631    *cList = new;
2632  return new;
2633}
2634
2635static void
2636CmdListReplaceCmd(XOTclCmdList *replace, Tcl_Command cmd, XOTclClass *clorobj) {
2637  Tcl_Command del = replace->cmdPtr;
2638  replace->cmdPtr = cmd;
2639  replace->clorobj = clorobj;
2640  Tcl_Command_refCount(cmd)++;
2641  MEM_COUNT_ALLOC("command refCount", cmd);
2642  TclCleanupCommand((Command *)del);
2643  MEM_COUNT_FREE("command refCount", cmd);
2644}
2645
2646#if 0
2647/** for debug purposes only */
2648static void
2649CmdListPrint(Tcl_Interp *interp, char *title, XOTclCmdList *cmdList) {
2650  if (cmdList)
2651    fprintf(stderr, title);
2652  while (cmdList) {
2653    fprintf(stderr, "   CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n",
2654            cmdList,
2655            cmdList->cmdPtr,
2656            in ? Tcl_GetCommandName(interp, cmdList->cmdPtr) : "",
2657            cmdList->clorobj,
2658            cmdList->clientData);
2659    cmdList = cmdList->next;
2660  }
2661}
2662#endif
2663
2664/*
2665 * physically delete an entry 'del'
2666 */
2667static void
2668CmdListDeleteCmdListEntry(XOTclCmdList *del, XOTclFreeCmdListClientData *freeFct) {
2669  if (freeFct)
2670    (*freeFct)(del);
2671  MEM_COUNT_FREE("command refCount", del->cmdPtr);
2672  TclCleanupCommand((Command *)del->cmdPtr);
2673  FREE(XOTclCmdList, del);
2674}
2675
2676/*
2677 * remove a command 'delCL' from a command list, but do not
2678 * free it ... returns the removed XOTclCmdList*
2679 */
2680static XOTclCmdList*
2681CmdListRemoveFromList(XOTclCmdList **cmdList, XOTclCmdList *delCL) {
2682  register XOTclCmdList *c = *cmdList, *del = NULL;
2683  if (c == NULL)
2684    return NULL;
2685  if (c == delCL) {
2686    *cmdList = c->next;
2687    del = c;
2688  } else {
2689    while (c->next && c->next != delCL) {
2690      c = c->next;
2691    }
2692    if (c->next == delCL) {
2693      del = delCL;
2694      c->next = delCL->next;
2695    }
2696  }
2697  return del;
2698}
2699
2700/*
2701 * remove all command pointers from a list that have a bumped epoch
2702 */
2703static void
2704CmdListRemoveEpoched(XOTclCmdList **cmdList, XOTclFreeCmdListClientData *freeFct) {
2705  XOTclCmdList *f = *cmdList, *del;
2706  while (f) {
2707    if (Tcl_Command_cmdEpoch(f->cmdPtr)) {
2708      del = f;
2709      f = f->next;
2710      del = CmdListRemoveFromList(cmdList, del);
2711      CmdListDeleteCmdListEntry(del, freeFct);
2712    } else
2713      f = f->next;
2714  }
2715}
2716
2717
2718/*
2719 * delete all cmds with given context class object
2720 */
2721static void
2722CmdListRemoveContextClassFromList(XOTclCmdList **cmdList, XOTclClass *clorobj,
2723                                  XOTclFreeCmdListClientData *freeFct) {
2724  XOTclCmdList *c, *del = NULL;
2725  /*
2726    CmdListRemoveEpoched(cmdList, freeFct);
2727  */
2728  c = *cmdList;
2729  while (c && c->clorobj == clorobj) {
2730    del = c;
2731    *cmdList = c->next;
2732    CmdListDeleteCmdListEntry(del, freeFct);
2733    c = *cmdList;
2734  }
2735  while (c) {
2736    if (c->clorobj == clorobj) {
2737      del = c;
2738      c = *cmdList;
2739      while (c->next && c->next != del)
2740        c = c->next;
2741      if (c->next == del)
2742        c->next = del->next;
2743      CmdListDeleteCmdListEntry(del, freeFct);
2744    }
2745    c = c->next;
2746  }
2747}
2748
2749/*
2750 * free the memory of a whole 'cmdList'
2751 */
2752static void
2753CmdListRemoveList(XOTclCmdList **cmdList, XOTclFreeCmdListClientData *freeFct) {
2754  XOTclCmdList *del;
2755  while (*cmdList) {
2756    del = *cmdList;
2757    *cmdList = (*cmdList)->next;
2758    CmdListDeleteCmdListEntry(del, freeFct);
2759  }
2760}
2761
2762/*
2763 * simple list search proc to search a list of cmds
2764 * for a command ptr
2765 */
2766static XOTclCmdList*
2767CmdListFindCmdInList(Tcl_Command cmd, XOTclCmdList *l) {
2768  register XOTclCmdList *h;
2769  for (h = l; h; h = h->next) {
2770    if (h->cmdPtr == cmd)
2771      return h;
2772  }
2773  return 0;
2774}
2775
2776/*
2777 * simple list search proc to search a list of cmds
2778 * for a simple Name
2779 */
2780static XOTclCmdList*
2781CmdListFindNameInList(Tcl_Interp *interp, char *name, XOTclCmdList *l) {
2782  register XOTclCmdList *h;
2783  for (h = l; h; h = h->next) {
2784    CONST84 char *cmdName = Tcl_GetCommandName(interp, h->cmdPtr);
2785    if (cmdName[0] == name[0] && !strcmp(cmdName, name))
2786      return h;
2787  }
2788  return 0;
2789}
2790
2791/*
2792 * Assertions
2793 */
2794static XOTclTclObjList*
2795AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj) {
2796  Tcl_Obj **ov; int oc;
2797  XOTclTclObjList *last = NULL;
2798
2799  if (Tcl_ListObjGetElements(interp, aObj, &oc, &ov) == TCL_OK) {
2800    if (oc > 0) {
2801      int i;
2802      for (i=oc-1; i>=0; i--) {
2803        TclObjListNewElement(&last, ov[i]);
2804      }
2805    }
2806  }
2807  return last;
2808}
2809
2810static Tcl_Obj*
2811AssertionList(Tcl_Interp *interp, XOTclTclObjList *alist) {
2812  Tcl_Obj *newAssStr = Tcl_NewStringObj("", 0);
2813  for (; alist; alist = alist->next) {
2814    Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content),
2815                           "}", (char *) NULL);
2816    if (alist->next)
2817      Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL);
2818  }
2819  return newAssStr;
2820}
2821
2822/* append a string of pre and post assertions to a proc
2823   or instproc body */
2824static void
2825AssertionAppendPrePost(Tcl_Interp *interp, Tcl_DString *dsPtr, XOTclProcAssertion *procs) {
2826  if (procs) {
2827    Tcl_Obj *preAss = AssertionList(interp, procs->pre);
2828    Tcl_Obj *postAss = AssertionList(interp, procs->post);
2829    INCR_REF_COUNT(preAss); INCR_REF_COUNT(postAss);
2830    Tcl_DStringAppendElement(dsPtr, ObjStr(preAss));
2831    Tcl_DStringAppendElement(dsPtr, ObjStr(postAss));
2832    DECR_REF_COUNT(preAss); DECR_REF_COUNT(postAss);
2833  }
2834}
2835
2836static int
2837AssertionListCheckOption(Tcl_Interp *interp, XOTclObject *obj) {
2838  XOTclObjectOpt *opt = obj->opt;
2839  if (!opt)
2840    return TCL_OK;
2841  if (opt->checkoptions & CHECK_OBJINVAR)
2842    Tcl_AppendElement(interp, "invar");
2843  if (opt->checkoptions & CHECK_CLINVAR)
2844    Tcl_AppendElement(interp, "instinvar");
2845  if (opt->checkoptions & CHECK_PRE)
2846    Tcl_AppendElement(interp, "pre");
2847  if (opt->checkoptions & CHECK_POST)
2848    Tcl_AppendElement(interp, "post");
2849  return TCL_OK;
2850}
2851
2852static XOTclProcAssertion*
2853AssertionFindProcs(XOTclAssertionStore *aStore, char *name) {
2854  Tcl_HashEntry *hPtr;
2855  if (aStore == NULL) return NULL;
2856  hPtr = XOTcl_FindHashEntry(&aStore->procs, name);
2857  if (hPtr == NULL) return NULL;
2858  return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr);
2859}
2860
2861static void
2862AssertionRemoveProc(XOTclAssertionStore *aStore, char *name) {
2863  Tcl_HashEntry *hPtr;
2864  if (aStore) {
2865    hPtr = XOTcl_FindHashEntry(&aStore->procs, name);
2866    if (hPtr) {
2867      XOTclProcAssertion *procAss =
2868        (XOTclProcAssertion*) Tcl_GetHashValue(hPtr);
2869      TclObjListFreeList(procAss->pre);
2870      TclObjListFreeList(procAss->post);
2871      FREE(XOTclProcAssertion, procAss);
2872      Tcl_DeleteHashEntry(hPtr);
2873    }
2874  }
2875}
2876
2877static void
2878AssertionAddProc(Tcl_Interp *interp, char *name, XOTclAssertionStore *aStore,
2879                 Tcl_Obj *pre, Tcl_Obj *post) {
2880  int nw = 0;
2881  Tcl_HashEntry *hPtr = NULL;
2882  XOTclProcAssertion *procs = NEW(XOTclProcAssertion);
2883
2884  AssertionRemoveProc(aStore, name);
2885  procs->pre = AssertionNewList(interp, pre);
2886  procs->post = AssertionNewList(interp, post);
2887  hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &nw);
2888  if (nw) Tcl_SetHashValue(hPtr, (ClientData)procs);
2889}
2890
2891static XOTclAssertionStore*
2892AssertionCreateStore() {
2893  XOTclAssertionStore *aStore = NEW(XOTclAssertionStore);
2894  aStore->invariants = NULL;
2895  Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS);
2896  MEM_COUNT_ALLOC("Tcl_InitHashTable",&aStore->procs);
2897  return aStore;
2898}
2899
2900static void
2901AssertionRemoveStore(XOTclAssertionStore *aStore) {
2902  Tcl_HashSearch hSrch;
2903  Tcl_HashEntry *hPtr;
2904
2905  if (aStore) {
2906    for (hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); hPtr;
2907         hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch)) {
2908      /*
2909       * AssertionRemoveProc calls Tcl_DeleteHashEntry(hPtr), thus
2910       * we get the FirstHashEntry afterwards again to proceed
2911       */
2912      AssertionRemoveProc(aStore, Tcl_GetHashKey(&aStore->procs, hPtr));
2913    }
2914    Tcl_DeleteHashTable(&aStore->procs);
2915    MEM_COUNT_FREE("Tcl_InitHashTable",&aStore->procs);
2916    TclObjListFreeList(aStore->invariants);
2917    FREE(XOTclAssertionStore, aStore);
2918  }
2919}
2920
2921/*
2922 * check a given condition in the current callframe's scope
2923 * it's the responsiblity of the caller to push the intended callframe
2924 */
2925static int
2926checkConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition) {
2927  int result, success;
2928  Tcl_Obj *ov[2];
2929  ov [1] = condition;
2930  INCR_REF_COUNT(condition);
2931  result = XOTcl_ExprObjCmd(NULL, interp, 2, ov);
2932  DECR_REF_COUNT(condition);
2933
2934  if (result == TCL_OK) {
2935    result = Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp),&success);
2936
2937    if (result == TCL_OK && success == 0)
2938      result = XOTCL_CHECK_FAILED;
2939  }
2940  return result;
2941}
2942
2943static int
2944AssertionCheckList(Tcl_Interp *interp, XOTclObject *obj,
2945                   XOTclTclObjList *alist, char *methodName) {
2946  XOTclTclObjList *checkFailed = NULL;
2947  Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp);
2948  int savedCheckoptions, acResult = TCL_OK;
2949
2950  /*
2951   * no obj->opt -> checkoption == CHECK_NONE
2952   */
2953  if (!obj->opt)
2954    return TCL_OK;
2955
2956  /* we do not check assertion modifying methods, otherwise
2957     we can not react in catch on a runtime assertion check failure */
2958  if (isCheckString(methodName) || isInfoString(methodName) ||
2959      isInvarString(methodName) || isInstinvarString(methodName) ||
2960      isProcString(methodName) || isInstprocString(methodName))
2961    return TCL_OK;
2962
2963  INCR_REF_COUNT(savedObjResult);
2964
2965  Tcl_ResetResult(interp);
2966
2967  while (alist) {
2968    /* Eval instead of IfObjCmd => the substitutions in the
2969       conditions will be done by Tcl */
2970    char *assStr = ObjStr(alist->content), *c = assStr;
2971    int comment = 0;
2972
2973    for (; c && *c != '\0'; c++) {
2974      if (*c == '#') {
2975        comment = 1; break;
2976      }
2977    }
2978
2979    if (!comment) {
2980      XOTcl_FrameDecls;
2981      XOTcl_PushFrame(interp, obj);
2982      CallStackPush(interp, obj, 0, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN);
2983
2984      /* don't check assertion during assertion check */
2985      savedCheckoptions = obj->opt->checkoptions;
2986      obj->opt->checkoptions = CHECK_NONE;
2987
2988      /* fprintf(stderr, "Checking Assertion %s ", assStr); */
2989
2990      /*
2991       * now check the assertion in the pushed callframe's scope
2992       */
2993      acResult = checkConditionInScope(interp, alist->content);
2994      if (acResult != TCL_OK)
2995        checkFailed = alist;
2996
2997      obj->opt->checkoptions = savedCheckoptions;
2998
2999      /* fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok"); */
3000
3001      CallStackPop(interp);
3002      XOTcl_PopFrame(interp, obj);
3003    }
3004    if (checkFailed)
3005      break;
3006    alist = alist->next;
3007  }
3008
3009  if (checkFailed) {
3010    DECR_REF_COUNT(savedObjResult);
3011    if (acResult == TCL_ERROR) {
3012      Tcl_Obj *sr = Tcl_GetObjResult(interp);
3013      INCR_REF_COUNT(sr);
3014      XOTclVarErrMsg(interp, "Error in Assertion: {",
3015                     ObjStr(checkFailed->content), "} in proc '",
3016                     GetSelfProc(interp), "'\n\n", ObjStr(sr), (char *) NULL);
3017      DECR_REF_COUNT(sr);
3018      return TCL_ERROR;
3019    }
3020    return XOTclVarErrMsg(interp, "Assertion failed check: {",
3021                          ObjStr(checkFailed->content), "} in proc '",
3022                          GetSelfProc(interp), "'", (char *) NULL);
3023  }
3024
3025  Tcl_SetObjResult(interp, savedObjResult);
3026  DECR_REF_COUNT(savedObjResult);
3027  return TCL_OK;
3028}
3029
3030static int
3031AssertionCheckInvars(Tcl_Interp *interp, XOTclObject *obj, char *method,
3032                     CheckOptions checkoptions) {
3033  int result = TCL_OK;
3034
3035  if (checkoptions & CHECK_OBJINVAR && obj->opt->assertions) {
3036    result = AssertionCheckList(interp, obj, obj->opt->assertions->invariants,
3037                                method);
3038  }
3039
3040  if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) {
3041    XOTclClasses *clPtr;
3042    clPtr = ComputeOrder(obj->cl, obj->cl->order, Super);
3043    while (clPtr && result != TCL_ERROR) {
3044      XOTclAssertionStore *aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0;
3045      if (aStore) {
3046        result = AssertionCheckList(interp, obj, aStore->invariants, method);
3047      }
3048      clPtr = clPtr->next;
3049    }
3050  }
3051  return result;
3052}
3053
3054static int
3055AssertionCheck(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl,
3056               char *method, int checkOption) {
3057  XOTclProcAssertion *procs;
3058  int result = TCL_OK;
3059  XOTclAssertionStore *aStore;
3060
3061  if (cl)
3062    aStore = cl->opt ? cl->opt->assertions : 0;
3063  else
3064    aStore = obj->opt ? obj->opt->assertions : 0;
3065
3066  assert(obj->opt);
3067
3068 if (checkOption & obj->opt->checkoptions) {
3069    procs = AssertionFindProcs(aStore, method);
3070    if (procs) {
3071      switch (checkOption) {
3072      case CHECK_PRE:
3073       result = AssertionCheckList(interp, obj, procs->pre, method);
3074        break;
3075      case CHECK_POST:
3076        result = AssertionCheckList(interp, obj, procs->post, method);
3077        break;
3078      }
3079    }
3080    if (result != TCL_ERROR)
3081      result = AssertionCheckInvars(interp, obj, method, obj->opt->checkoptions);
3082  }
3083  return result;
3084}
3085
3086
3087
3088
3089/*
3090 * Per-Object-Mixins
3091 */
3092
3093/*
3094 * push a mixin stack information on this object
3095 */
3096static int
3097MixinStackPush(XOTclObject *obj) {
3098  register XOTclMixinStack *h = NEW(XOTclMixinStack);
3099  h->currentCmdPtr = NULL;
3100  h->next = obj->mixinStack;
3101  obj->mixinStack = h;
3102  return 1;
3103}
3104
3105/*
3106 * pop a mixin stack information on this object
3107 */
3108static void
3109MixinStackPop(XOTclObject *obj) {
3110  register XOTclMixinStack *h = obj->mixinStack;
3111  obj->mixinStack = h->next;
3112  FREE(XOTclMixinStack, h);
3113}
3114
3115/*
3116 * Appends XOTclClasses *containing the mixin classes and their
3117 * superclasses to 'mixinClasses' list from a given mixinList
3118 */
3119static void
3120MixinComputeOrderFullList(Tcl_Interp *interp, XOTclCmdList **mixinList,
3121                          XOTclClasses **mixinClasses,
3122                          XOTclClasses **checkList, int level) {
3123  XOTclCmdList *m;
3124  XOTclClasses *pl, **clPtr = mixinClasses;
3125
3126  CmdListRemoveEpoched(mixinList, GuardDel);
3127
3128  for (m = *mixinList; m; m = m->next) {
3129    XOTclClass *mCl = XOTclGetClassFromCmdPtr(m->cmdPtr);
3130    if (mCl) {
3131      for (pl = ComputeOrder(mCl, mCl->order, Super); pl; pl = pl->next) {
3132        /*fprintf(stderr, " %s, ", ObjStr(pl->cl->object.cmdName));*/
3133        if (pl->cl != RUNTIME_STATE(interp)->theObject) {
3134          XOTclClassOpt *opt = pl->cl->opt;
3135          if (opt && opt->instmixins) {
3136            /* compute transitively the instmixin classes of this added
3137               class */
3138            XOTclClasses *cls;
3139            int i, found = 0;
3140            for (i=0, cls = *checkList; cls; i++, cls = cls->next) {
3141              /* fprintf(stderr,"+++ c%d: %s\n", i,
3142                 ObjStr(cls->cl->object.cmdName));*/
3143              if (pl->cl == cls->cl) {
3144                found = 1;
3145                break;
3146              }
3147            }
3148            if (!found) {
3149              XOTclAddClass(checkList, pl->cl, NULL);
3150              /*fprintf(stderr, "+++ transitive %s\n",
3151                ObjStr(pl->cl->object.cmdName));*/
3152
3153              MixinComputeOrderFullList(interp, &opt->instmixins, mixinClasses,
3154                                        checkList, level+1);
3155            }
3156          }
3157          /* fprintf(stderr,"+++ add to mixinClasses %p path: %s clPtr %p\n",
3158             mixinClasses, ObjStr(pl->cl->object.cmdName), clPtr);*/
3159          clPtr = XOTclAddClass(clPtr, pl->cl, m->clientData);
3160        }
3161      }
3162    }
3163  }
3164  if (level == 0 && *checkList) {
3165    XOTclFreeClasses(*checkList);
3166    *checkList = NULL;
3167  }
3168}
3169
3170static void
3171MixinResetOrder(XOTclObject *obj) {
3172  /*fprintf(stderr,"removeList %s \n", ObjStr(obj->cmdName));*/
3173  CmdListRemoveList(&obj->mixinOrder, NULL /*GuardDel*/);
3174  obj->mixinOrder = NULL;
3175}
3176
3177/*
3178 * Computes a linearized order of per-object and per-class mixins. Then
3179 * duplicates in the full list and with the class inheritance list of
3180 * 'obj' are eliminated.
3181 * The precendence rule is that the last occurence makes it into the
3182 * final list.
3183 */
3184static void
3185MixinComputeOrder(Tcl_Interp *interp, XOTclObject *obj) {
3186  XOTclClasses *fullList, *checkList = NULL, *mixinClasses = NULL, *nextCl, *pl,
3187    *checker, *guardChecker;
3188
3189  if (obj->mixinOrder)  MixinResetOrder(obj);
3190  /*fprintf(stderr, "Mixin Order:\n First List: ");*/
3191
3192  /* append per-obj mixins */
3193  if (obj->opt) {
3194    MixinComputeOrderFullList(interp, &obj->opt->mixins, &mixinClasses,
3195                              &checkList, 0);
3196  }
3197
3198  /* append per-class mixins */
3199  for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) {
3200    XOTclClassOpt *opt = pl->cl->opt;
3201    if (opt && opt->instmixins) {
3202      MixinComputeOrderFullList(interp, &opt->instmixins, &mixinClasses,
3203                                &checkList, 0);
3204    }
3205  }
3206  fullList = mixinClasses;
3207
3208  /* use no duplicates & no classes of the precedence order
3209     on the resulting list */
3210  while (mixinClasses) {
3211    checker = nextCl = mixinClasses->next;
3212    /* fprintf(stderr,"--- checking %s\n",
3213       ObjStr(mixinClasses->cl->object.cmdName));*/
3214
3215    while (checker) {
3216      if (checker->cl == mixinClasses->cl) break;
3217      checker = checker->next;
3218    }
3219    /* if checker is set, it is a duplicate and ignored */
3220
3221    if (checker == NULL) {
3222      /* check obj->cl hierachy */
3223      for (checker = ComputeOrder(obj->cl, obj->cl->order, Super); checker; checker = checker->next) {
3224        if (checker->cl == mixinClasses->cl)
3225          break;
3226      }
3227      /* if checker is set, it was found in the class hierarchy
3228         and it is ignored */
3229    }
3230    if (checker == NULL) {
3231      /* add the class to the mixinOrder list */
3232      XOTclCmdList *new;
3233      /* fprintf(stderr,"--- adding to mixinlist %s\n",
3234         ObjStr(mixinClasses->cl->object.cmdName));*/
3235      new = CmdListAdd(&obj->mixinOrder, mixinClasses->cl->object.id, NULL,
3236                       /*noDuplicates*/ 0);
3237
3238      /* in the client data of the order list, we require the first
3239         matching guard ... scan the full list for it. */
3240      for (guardChecker = fullList; guardChecker; guardChecker = guardChecker->next) {
3241        if (guardChecker->cl == mixinClasses->cl) {
3242          new->clientData = guardChecker->clientData;
3243          break;
3244        }
3245      }
3246    }
3247    mixinClasses = nextCl;
3248  }
3249
3250  /* ... and free the memory of the full list */
3251  XOTclFreeClasses(fullList);
3252
3253  /*CmdListPrint(interp,"mixin order\n", obj->mixinOrder);*/
3254
3255}
3256
3257/*
3258 * add a mixin class to 'mixinList' by appending it
3259 */
3260static int
3261MixinAdd(Tcl_Interp *interp, XOTclCmdList **mixinList, Tcl_Obj *name) {
3262  XOTclClass *mixin;
3263  Tcl_Obj *guard = NULL;
3264  int ocName; Tcl_Obj **ovName;
3265  XOTclCmdList *new;
3266
3267  if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) {
3268    if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) {
3269      name = ovName[0];
3270      guard = ovName[2];
3271      /*fprintf(stderr,"mixinadd name = '%s', guard = '%s'\n", ObjStr(name), ObjStr(guard));*/
3272    } /*else return XOTclVarErrMsg(interp, "mixin registration '", ObjStr(name),
3273        "' has too many elements.", (char *) NULL);*/
3274  }
3275
3276  if (GetXOTclClassFromObj(interp, name, &mixin, 1) != TCL_OK)
3277    return XOTclErrBadVal(interp, "mixin", "a class as mixin", ObjStr(name));
3278
3279
3280  new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1);
3281
3282  if (guard) {
3283    GuardAdd(interp, new, guard);
3284  } else {
3285    if (new->clientData)
3286      GuardDel(new);
3287  }
3288
3289  return TCL_OK;
3290}
3291
3292/*
3293 * call AppendElement for matching values
3294 */
3295static void
3296AppendMatchingElement(Tcl_Interp *interp, Tcl_Obj *name, char *pattern) {
3297  char *string = ObjStr(name);
3298  if (!pattern || Tcl_StringMatch(string, pattern)) {
3299    Tcl_AppendElement(interp, string);
3300  }
3301}
3302
3303/*
3304 * apply AppendMatchingElement to CmdList
3305 */
3306static int
3307AppendMatchingElementsFromCmdList(Tcl_Interp *interp, XOTclCmdList *cmdl,
3308                                  char *pattern, XOTclObject *matchObject) {
3309  int rc = 0;
3310  for ( ; cmdl; cmdl = cmdl->next) {
3311    XOTclObject *obj = XOTclGetObjectFromCmdPtr(cmdl->cmdPtr);
3312    if (obj) {
3313      if (matchObject == obj) {
3314        return 1;
3315      } else {
3316        AppendMatchingElement(interp, obj->cmdName, pattern);
3317      }
3318    }
3319  }
3320  return rc;
3321}
3322
3323/*
3324 * apply AppendMatchingElement to
3325 */
3326static int
3327AppendMatchingElementsFromClasses(Tcl_Interp *interp, XOTclClasses *cls,
3328                                 char *pattern, XOTclObject *matchObject) {
3329  int rc = 0;
3330
3331  for ( ; cls; cls = cls->next) {
3332    XOTclObject *obj = (XOTclObject *)cls->cl;
3333    if (obj) {
3334      if (matchObject && obj == matchObject) {
3335        /* we have a matchObject and it is identical to obj,
3336           just return true and don't continue search
3337        */
3338        return 1;
3339        break;
3340      } else {
3341        AppendMatchingElement(interp, obj->cmdName, pattern);
3342      }
3343    }
3344  }
3345  return rc;
3346}
3347
3348/*
3349 * get all instances of a class recursively into an initialized
3350 * String key hashtable
3351 */
3352static int
3353listInstances(Tcl_Interp *interp, XOTclClass *startCl,
3354              char *pattern, int closure, XOTclObject *matchObject) {
3355  Tcl_HashTable *table = &startCl->instances;
3356  XOTclClasses *sc;
3357  Tcl_HashSearch search;
3358  Tcl_HashEntry *hPtr;
3359  int rc = 0;
3360
3361  for (hPtr = Tcl_FirstHashEntry(table, &search);  hPtr;
3362       hPtr = Tcl_NextHashEntry(&search)) {
3363    XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr);
3364    if (matchObject && inst == matchObject) {
3365      return 1;
3366    }
3367    AppendMatchingElement(interp, inst->cmdName, pattern);
3368  }
3369  if (closure) {
3370    for (sc = startCl->sub; sc; sc = sc->next) {
3371        rc = listInstances(interp, sc->cl, pattern, closure, matchObject);
3372      if (rc) break;
3373    }
3374  }
3375  return rc;
3376}
3377
3378
3379/*
3380 * get all instances of a class recursively into an initialized
3381 * String key hashtable
3382 */
3383static void
3384getAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl) {
3385  Tcl_HashTable *table = &startCl->instances;
3386  XOTclClasses *sc;
3387  Tcl_HashSearch search;
3388  Tcl_HashEntry *hPtr;
3389
3390  for (hPtr = Tcl_FirstHashEntry(table, &search);  hPtr;
3391       hPtr = Tcl_NextHashEntry(&search)) {
3392    XOTclObject *inst = (XOTclObject *)Tcl_GetHashKey(table, hPtr);
3393    int new;
3394
3395    Tcl_CreateHashEntry(destTable, ObjStr(inst->cmdName), &new);
3396    /*
3397      fprintf (stderr, " -- %s (%s)\n", ObjStr(inst->cmdName), ObjStr(startCl->object.cmdName));
3398    */
3399  }
3400  for (sc = startCl->sub; sc; sc = sc->next) {
3401    getAllInstances(interp, destTable, sc->cl);
3402  }
3403}
3404
3405/*
3406 * helper function for getAllClassMixinsOf to add classes to the
3407 * result set, flagging test for matchObject as result
3408 */
3409
3410static int
3411addToResultSet(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclObject *obj, int *new,
3412                    int appendResult, char *pattern, XOTclObject *matchObject) {
3413  Tcl_CreateHashEntry(destTable, (char *)obj, new);
3414  if (*new) {
3415    if (matchObject && matchObject == obj) {
3416      return 1;
3417    }
3418    if (appendResult) {
3419      AppendMatchingElement(interp, obj->cmdName, pattern);
3420    }
3421  }
3422  return 0;
3423}
3424
3425/*
3426 * helper function for getAllClassMixins to add classes with guards
3427 * to the result set, flagging test for matchObject as result
3428 */
3429
3430static int
3431addToResultSetWithGuards(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *cl, ClientData clientData, int *new,
3432                    int appendResult, char *pattern, XOTclObject *matchObject) {
3433  Tcl_CreateHashEntry(destTable, (char *)cl, new);
3434  if (*new) {
3435    if (appendResult) {
3436      if (!pattern || Tcl_StringMatch(ObjStr(cl->object.cmdName), pattern)) {
3437        Tcl_Obj *l = Tcl_NewListObj(0, NULL);
3438        Tcl_Obj *g = (Tcl_Obj*) clientData;
3439        Tcl_ListObjAppendElement(interp, l, cl->object.cmdName);
3440        Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]);
3441        Tcl_ListObjAppendElement(interp, l, g);
3442	Tcl_AppendElement(interp, ObjStr(l));
3443	DECR_REF_COUNT(l);
3444      }
3445    }
3446    if (matchObject && matchObject == (XOTclObject *)cl) {
3447      return 1;
3448    }
3449  }
3450  return 0;
3451}
3452
3453/*
3454 * recursively get all per object mixins from an class and its subclasses/instmixinofs
3455 * into an initialized object ptr hashtable (TCL_ONE_WORD_KEYS)
3456 */
3457
3458static int
3459getAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl,
3460		    int isMixin,
3461                    int appendResult, char *pattern, XOTclObject *matchObject) {
3462  int rc = 0, new = 0;
3463  XOTclClasses *sc;
3464
3465  /*fprintf(stderr, "startCl = %s, opt %p, isMixin %d\n",
3466    ObjStr(startCl->object.cmdName),startCl->opt, isMixin);*/
3467
3468  /*
3469   * check all subclasses of startCl for mixins
3470   */
3471  for (sc = startCl->sub; sc; sc = sc->next) {
3472    rc = getAllObjectMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject);
3473    if (rc) {return rc;}
3474  }
3475  /*fprintf(stderr, "check subclasses of %s done\n",ObjStr(startCl->object.cmdName));*/
3476
3477  if (startCl->opt) {
3478    XOTclCmdList *m;
3479    XOTclClass *cl;
3480    for (m = startCl->opt->isClassMixinOf; m; m = m->next) {
3481
3482      /* we should have no deleted commands in the list */
3483      assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0);
3484
3485      cl = XOTclGetClassFromCmdPtr(m->cmdPtr);
3486      assert(cl);
3487      /* fprintf(stderr, "check %s mixinof %s\n",
3488	 ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName));*/
3489      rc = getAllObjectMixinsOf(interp, destTable, cl, isMixin, appendResult, pattern, matchObject);
3490      /*fprintf(stderr, "check %s mixinof %s done\n",
3491	ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName));*/
3492    if (rc) {return rc;}
3493    }
3494  }
3495
3496  /*
3497   * check, if startCl has associated per-object mixins
3498   */
3499  if (startCl->opt) {
3500    XOTclCmdList *m;
3501    XOTclObject *obj;
3502
3503    for (m = startCl->opt->isObjectMixinOf; m; m = m->next) {
3504
3505      /* we should have no deleted commands in the list */
3506      assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0);
3507
3508      obj = XOTclGetObjectFromCmdPtr(m->cmdPtr);
3509      assert(obj);
3510
3511      rc = addToResultSet(interp, destTable, obj, &new, appendResult, pattern, matchObject);
3512      if (rc == 1) {return rc;}
3513    }
3514  }
3515  return rc;
3516}
3517
3518/*
3519 * recursively get all isClassMixinOf of a class into an initialized
3520 * object ptr hashtable (TCL_ONE_WORD_KEYS)
3521 */
3522
3523static int
3524getAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl,
3525		    int isMixin,
3526                    int appendResult, char *pattern, XOTclObject *matchObject) {
3527  int rc = 0, new = 0;
3528  XOTclClass *cl;
3529  XOTclClasses *sc;
3530
3531  /*
3532  fprintf(stderr, "startCl = %s, opt %p, isMixin %d\n",
3533          ObjStr(startCl->object.cmdName),startCl->opt, isMixin);
3534  */
3535
3536  /*
3537   * the startCl is a per class mixin, add it to the result set
3538   */
3539  if (isMixin) {
3540    rc = addToResultSet(interp, destTable, &startCl->object, &new, appendResult, pattern, matchObject);
3541    if (rc == 1) {return rc;}
3542
3543    /*
3544     * check all subclasses of startCl for mixins
3545     */
3546    for (sc = startCl->sub; sc; sc = sc->next) {
3547      rc = getAllClassMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject);
3548      if (rc) {return rc;}
3549    }
3550  }
3551
3552  /*
3553   * check, if startCl is a per-class mixin of some other classes
3554   */
3555  if (startCl->opt) {
3556    XOTclCmdList *m;
3557
3558    for (m = startCl->opt->isClassMixinOf; m; m = m->next) {
3559
3560      /* we should have no deleted commands in the list */
3561      assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0);
3562
3563      cl = XOTclGetClassFromCmdPtr(m->cmdPtr);
3564      assert(cl);
3565
3566      rc = addToResultSet(interp, destTable, &cl->object, &new, appendResult, pattern, matchObject);
3567      if (rc == 1) {return rc;}
3568      if (new) {
3569        rc = getAllClassMixinsOf(interp, destTable, cl, 1, appendResult, pattern, matchObject);
3570        if (rc) {return rc;}
3571      }
3572    }
3573  }
3574
3575  return rc;
3576}
3577
3578/*
3579 * recursively get all instmixins of a class into an initialized
3580 * object ptr hashtable (TCL_ONE_WORD_KEYS)
3581 */
3582
3583static int
3584getAllClassMixins(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl,
3585                    int withGuards, char *pattern, XOTclObject *matchObject) {
3586  int rc = 0, new = 0;
3587  XOTclClass *cl;
3588  XOTclClasses *sc;
3589
3590  /*
3591   * check this class for instmixins
3592   */
3593  if (startCl->opt) {
3594    XOTclCmdList *m;
3595
3596    for (m = startCl->opt->instmixins; m; m = m->next) {
3597
3598      /* we should have no deleted commands in the list */
3599      assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0);
3600
3601      cl = XOTclGetClassFromCmdPtr(m->cmdPtr);
3602      assert(cl);
3603
3604      /* fprintf(stderr,"Instmixin found: %s\n", ObjStr(cl->object.cmdName)); */
3605
3606      if ((withGuards) && (m->clientData)) {
3607        /* fprintf(stderr,"addToResultSetWithGuards: %s\n", ObjStr(cl->object.cmdName)); */
3608        rc = addToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject);
3609      } else {
3610        /* fprintf(stderr,"addToResultSet: %s\n", ObjStr(cl->object.cmdName)); */
3611	rc = addToResultSet(interp, destTable, &cl->object, &new, 1, pattern, matchObject);
3612      }
3613      if (rc == 1) {return rc;}
3614
3615      if (new) {
3616        /* fprintf(stderr,"Instmixin getAllClassMixins for: %s (%s)\n",ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName)); */
3617        rc = getAllClassMixins(interp, destTable, cl, withGuards, pattern, matchObject);
3618        if (rc) {return rc;}
3619      }
3620    }
3621  }
3622
3623
3624  /*
3625   * check all superclasses of startCl for instmixins
3626   */
3627    for (sc = startCl->super; sc; sc = sc->next) {
3628      /* fprintf(stderr,"Superclass getAllClassMixins for %s (%s)\n",ObjStr(sc->cl->object.cmdName),ObjStr(startCl->object.cmdName)); */
3629      rc = getAllClassMixins(interp, destTable, sc->cl, withGuards, pattern, matchObject);
3630      if (rc) {return rc;}
3631    }
3632  return rc;
3633}
3634
3635
3636static void
3637RemoveFromClassMixinsOf(Tcl_Command cmd, XOTclCmdList *cmdlist) {
3638
3639  for ( ; cmdlist; cmdlist = cmdlist->next) {
3640    XOTclClass *ncl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr);
3641    XOTclClassOpt *nclopt = ncl ? ncl->opt : NULL;
3642    if (nclopt) {
3643      XOTclCmdList *del = CmdListFindCmdInList(cmd, nclopt->isClassMixinOf);
3644      if (del) {
3645        /* fprintf(stderr,"Removing class %s from isClassMixinOf of class %s\n",
3646           ObjStr(cl->object.cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */
3647        del = CmdListRemoveFromList(&nclopt->isClassMixinOf, del);
3648        CmdListDeleteCmdListEntry(del, GuardDel);
3649      }
3650    }
3651  }
3652}
3653
3654static void
3655removeFromObjectMixinsOf(Tcl_Command cmd, XOTclCmdList *cmdlist) {
3656  for ( ; cmdlist; cmdlist = cmdlist->next) {
3657    XOTclClass *cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr);
3658    XOTclClassOpt *clopt = cl ? cl->opt : NULL;
3659    if (clopt) {
3660      XOTclCmdList *del = CmdListFindCmdInList(cmd, clopt->isObjectMixinOf);
3661      if (del) {
3662        /* fprintf(stderr,"Removing object %s from isObjectMixinOf of Class %s\n",
3663           ObjStr(obj->cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */
3664        del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del);
3665        CmdListDeleteCmdListEntry(del, GuardDel);
3666      }
3667    } /* else fprintf(stderr,"CleanupDestroyObject %s: NULL pointer in mixins!\n", ObjStr(obj->cmdName)); */
3668  }
3669}
3670
3671static void
3672RemoveFromInstmixins(Tcl_Command cmd, XOTclCmdList *cmdlist) {
3673  for ( ; cmdlist; cmdlist = cmdlist->next) {
3674    XOTclClass *cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr);
3675    XOTclClassOpt *clopt = cl ? cl->opt : NULL;
3676    if (clopt) {
3677      XOTclCmdList *del = CmdListFindCmdInList(cmd, clopt->instmixins);
3678      if (del) {
3679        /* fprintf(stderr,"Removing class %s from mixins of object %s\n",
3680           ObjStr(cl->object.cmdName), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */
3681        del = CmdListRemoveFromList(&clopt->instmixins, del);
3682        CmdListDeleteCmdListEntry(del, GuardDel);
3683	if (cl->object.mixinOrder) MixinResetOrder(&cl->object);
3684      }
3685    }
3686  }
3687}
3688
3689static void
3690RemoveFromMixins(Tcl_Command cmd, XOTclCmdList *cmdlist) {
3691  for ( ; cmdlist; cmdlist = cmdlist->next) {
3692    XOTclObject *nobj = XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr);
3693    XOTclObjectOpt *objopt = nobj ? nobj->opt : NULL;
3694    if (objopt) {
3695      XOTclCmdList *del = CmdListFindCmdInList(cmd, objopt->mixins);
3696      if (del) {
3697        /* fprintf(stderr,"Removing class %s from mixins of object %s\n",
3698           ObjStr(cl->object.cmdName), ObjStr(XOTclGetObjectFromCmdPtr(cmdlist->cmdPtr)->cmdName)); */
3699        del = CmdListRemoveFromList(&objopt->mixins, del);
3700        CmdListDeleteCmdListEntry(del, GuardDel);
3701	if (nobj->mixinOrder) MixinResetOrder(nobj);
3702      }
3703    }
3704  }
3705}
3706
3707/*
3708 * Reset mixin order for instances of a class
3709 */
3710
3711static void
3712MixinResetOrderForInstances(Tcl_Interp *interp, XOTclClass *cl) {
3713  Tcl_HashSearch hSrch;
3714  Tcl_HashEntry *hPtr;
3715
3716  hPtr = Tcl_FirstHashEntry(&cl->instances, &hSrch);
3717
3718    /*fprintf(stderr,"invalidating instances of class %s\n",
3719      ObjStr(clPtr->cl->object.cmdName));*/
3720
3721    /* here we should check, whether this class is used as
3722       a mixin / instmixin somewhere else and invalidate
3723       the objects of these as well -- */
3724
3725  for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
3726    XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&cl->instances, hPtr);
3727    if (obj
3728        && !(obj->flags & XOTCL_DESTROY_CALLED)
3729        && (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) {
3730        MixinResetOrder(obj);
3731        obj->flags &= ~XOTCL_MIXIN_ORDER_VALID;
3732    }
3733  }
3734}
3735
3736/* reset mixin order for all objects having this class as per object mixin */
3737static void
3738ResetOrderOfClassesUsedAsMixins(XOTclClass *cl) {
3739  /*fprintf(stderr,"ResetOrderOfClassesUsedAsMixins %s - %p\n",
3740    ObjStr(cl->object.cmdName), cl->opt);*/
3741
3742  if (cl->opt) {
3743    XOTclCmdList *ml;
3744    for (ml = cl->opt->isObjectMixinOf; ml; ml = ml->next) {
3745      XOTclObject *obj = XOTclGetObjectFromCmdPtr(ml->cmdPtr);
3746      if (obj) {
3747        if (obj->mixinOrder) { MixinResetOrder(obj); }
3748        obj->flags &= ~XOTCL_MIXIN_ORDER_VALID;
3749      }
3750    }
3751  }
3752}
3753
3754/*
3755 * if the class hierarchy or class mixins have changed ->
3756 * invalidate mixin entries in all dependent instances
3757 */
3758static void
3759MixinInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) {
3760  XOTclClasses *saved = cl->order, *clPtr;
3761  Tcl_HashSearch hSrch;
3762  Tcl_HashEntry *hPtr;
3763  Tcl_HashTable objTable, *commandTable = &objTable;
3764
3765  cl->order = NULL;
3766
3767  /* reset mixin order for all instances of the class and the
3768     instances of its subclasses
3769  */
3770  for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->next) {
3771    Tcl_HashSearch hSrch;
3772    Tcl_HashEntry *hPtr = &clPtr->cl->instances ?
3773      Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : NULL;
3774
3775    /* reset mixin order for all objects having this class as per object mixin */
3776    ResetOrderOfClassesUsedAsMixins(clPtr->cl);
3777
3778    /* fprintf(stderr,"invalidating instances of class %s\n", ObjStr(clPtr->cl->object.cmdName));
3779     */
3780
3781    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
3782      XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr);
3783      if (obj->mixinOrder) { MixinResetOrder(obj); }
3784      obj->flags &= ~XOTCL_MIXIN_ORDER_VALID;
3785    }
3786  }
3787
3788  XOTclFreeClasses(cl->order);
3789  cl->order = saved;
3790
3791  /* Reset mixin order for all objects having this class as a per
3792     class mixin (instmixin).  This means that we have to work through
3793     the instmixin hierarchy with its corresponding instances.
3794  */
3795  Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
3796  MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
3797  getAllClassMixinsOf(interp, commandTable, cl, 1, 0, NULL, NULL);
3798
3799  for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr;
3800       hPtr = Tcl_NextHashEntry(&hSrch)) {
3801      XOTclClass *ncl = (XOTclClass *)Tcl_GetHashKey(commandTable, hPtr);
3802      /*fprintf(stderr,"Got %s, reset for ncl %p\n",ncl?ObjStr(ncl->object.cmdName):"NULL",ncl);*/
3803      if (ncl) {
3804          MixinResetOrderForInstances(interp, ncl);
3805      }
3806  }
3807  Tcl_DeleteHashTable(commandTable);
3808  MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
3809
3810}
3811
3812static int MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern,
3813                     int withGuards, XOTclObject *matchObject);
3814/*
3815 * the mixin order is either
3816 *   DEFINED (there are mixins on the instance),
3817 *   NONE    (there are no mixins for the instance),
3818 *   or INVALID (a class re-strucuturing has occured, thus it is not clear
3819 *               whether mixins are defined or not).
3820 * If it is INVALID MixinComputeDefined can be used to compute the order
3821 * and set the instance to DEFINE or NONE
3822 */
3823static void
3824MixinComputeDefined(Tcl_Interp *interp, XOTclObject *obj) {
3825  MixinComputeOrder(interp, obj);
3826  obj->flags |= XOTCL_MIXIN_ORDER_VALID;
3827  if (obj->mixinOrder)
3828    obj->flags |= XOTCL_MIXIN_ORDER_DEFINED;
3829  else
3830    obj->flags &= ~XOTCL_MIXIN_ORDER_DEFINED;
3831}
3832
3833/*
3834 * Walk through the command list until the current command is reached.
3835 * return the next entry.
3836 *
3837 */
3838static XOTclCmdList *
3839seekCurrent(Tcl_Command currentCmd, register XOTclCmdList *cmdl) {
3840  if (currentCmd) {
3841    /* go forward to current class */
3842    for (; cmdl; cmdl = cmdl->next) {
3843      if (cmdl->cmdPtr == currentCmd) {
3844        return cmdl->next;
3845      }
3846    }
3847  }
3848  return cmdl;
3849}
3850
3851/*
3852 * before we can perform a mixin dispatch, MixinSearchProc seeks the
3853 * current mixin and the relevant calling information
3854 */
3855static Tcl_Command
3856MixinSearchProc(Tcl_Interp *interp, XOTclObject *obj, char *methodName,
3857                XOTclClass **cl, Tcl_Command *currentCmdPtr) {
3858  Tcl_Command cmd = NULL;
3859  XOTclCmdList *cmdList;
3860  XOTclClass *cls;
3861
3862  assert(obj);
3863  assert(obj->mixinStack);
3864
3865  /* ensure that the mixin order is not invalid, otherwise compute order */
3866  assert(obj->flags & XOTCL_MIXIN_ORDER_VALID);
3867  /*MixinComputeDefined(interp, obj);*/
3868  cmdList = seekCurrent(obj->mixinStack->currentCmdPtr, obj->mixinOrder);
3869
3870#if defined(ACTIVEMIXIN)
3871  RUNTIME_STATE(interp)->cmdPtr = cmdList->cmdPtr;
3872#endif
3873
3874  /*
3875    fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName, cmdList);
3876  */
3877  /*CmdListPrint(interp,"MixinSearch CL = \n", cmdList);*/
3878
3879  while (cmdList) {
3880    if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) {
3881      cmdList = cmdList->next;
3882    } else {
3883      cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr);
3884      /*
3885        fprintf(stderr,"+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n",
3886	      ObjStr(obj->cmdName), methodName, cmdList,
3887	      cmdList->cmdPtr, cmdList->clientData);
3888      */
3889      if (cls) {
3890        int guardOk = TCL_OK;
3891        cmd = FindMethod(methodName, cls->nsPtr);
3892        if (cmd && cmdList->clientData) {
3893          if (!RUNTIME_STATE(interp)->cs.guardCount) {
3894            guardOk = GuardCall(obj, cls, (Tcl_Command) cmd, interp, cmdList->clientData, 1);
3895          }
3896        }
3897        if (cmd && guardOk == TCL_OK) {
3898          /*
3899           * on success: compute mixin call data
3900           */
3901          *cl = cls;
3902          *currentCmdPtr = cmdList->cmdPtr;
3903          break;
3904        } else {
3905          cmd = NULL;
3906          cmdList = cmdList->next;
3907        }
3908      }
3909    }
3910  }
3911
3912  return cmd;
3913}
3914
3915/*
3916 * info option for mixins and instmixins
3917 */
3918static int
3919MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern,
3920          int withGuards, XOTclObject *matchObject) {
3921  Tcl_Obj *list = Tcl_NewListObj(0, NULL);
3922  XOTclClass *mixinClass;
3923
3924  while (m) {
3925      /* fprintf(stderr,"   mixin info m=%p, next=%p, pattern %s, matchObject %p\n",
3926         m, m->next, pattern, matchObject);*/
3927    mixinClass = XOTclGetClassFromCmdPtr(m->cmdPtr);
3928    if (mixinClass &&
3929        (!pattern
3930         || (matchObject && &(mixinClass->object) == matchObject)
3931         || (!matchObject && Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern)))) {
3932      if (withGuards && m->clientData) {
3933        Tcl_Obj *l = Tcl_NewListObj(0, NULL);
3934        Tcl_Obj *g = (Tcl_Obj*) m->clientData;
3935        Tcl_ListObjAppendElement(interp, l, mixinClass->object.cmdName);
3936        Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]);
3937        Tcl_ListObjAppendElement(interp, l, g);
3938        Tcl_ListObjAppendElement(interp, list, l);
3939      } else {
3940        Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName);
3941      }
3942      if (matchObject) break;
3943    }
3944    m = m->next;
3945  }
3946  Tcl_SetObjResult(interp, list);
3947  return TCL_OK;
3948}
3949
3950static Tcl_Command
3951MixinSearchMethodByName(Tcl_Interp *interp, XOTclCmdList *mixinList, char *name, XOTclClass **cl) {
3952  Tcl_Command cmd;
3953
3954  for (; mixinList;  mixinList = mixinList->next) {
3955    XOTclClass *mcl =
3956      XOTclpGetClass(interp, (char *) Tcl_GetCommandName(interp, mixinList->cmdPtr));
3957    if (mcl && SearchCMethod(mcl, name, &cmd)) {
3958      if (cl) *cl = mcl;
3959      return cmd;
3960    }
3961  }
3962  return 0;
3963}
3964
3965
3966/*
3967 *  Filter-Commands
3968 */
3969
3970/*
3971 * The search method implements filter search order for filter
3972 * and instfilter: first a given name is interpreted as fully
3973 * qualified instproc name. If no instproc is found, a proc is
3974 * search with fully name. Otherwise the simple name is searched
3975 * on the heritage order: object (only for
3976 * per-object filters), class, meta-class
3977 */
3978
3979static Tcl_Command
3980FilterSearch(Tcl_Interp *interp, char *name, XOTclObject *startingObj,
3981             XOTclClass *startingCl, XOTclClass **cl) {
3982  Tcl_Command cmd = NULL;
3983
3984  if (startingObj) {
3985    XOTclObjectOpt *opt = startingObj->opt;
3986    /*
3987     * the object-specific filter can also be defined on the object's
3988     * class, its hierarchy, or the respective instmixins; thus use the
3989     * object's class as start point for the class-specific search then ...
3990     */
3991    startingCl = startingObj->cl;
3992
3993    /*
3994     * search for filters on object mixins
3995     */
3996    if (opt && opt->mixins) {
3997      if ((cmd = MixinSearchMethodByName(interp, opt->mixins, name, cl))) {
3998        return cmd;
3999      }
4000    }
4001  }
4002
4003  /*
4004   * search for instfilters on instmixins
4005   */
4006  if (startingCl) {
4007    XOTclClassOpt *opt = startingCl->opt;
4008    if (opt && opt->instmixins) {
4009      if ((cmd = MixinSearchMethodByName(interp, opt->instmixins, name, cl))) {
4010        return cmd;
4011      }
4012    }
4013  }
4014
4015  /*
4016   * seach for object procs that are used as filters
4017   */
4018  if (startingObj && startingObj->nsPtr) {
4019    /*fprintf(stderr,"search filter %s as proc \n",name);*/
4020    if ((cmd = FindMethod(name, startingObj->nsPtr))) {
4021      *cl = (XOTclClass*)startingObj;
4022      return cmd;
4023    }
4024  }
4025
4026  /*
4027   * ok, no filter on obj or mixins -> search class
4028   */
4029  if (startingCl) {
4030    *cl = SearchCMethod(startingCl, name, &cmd);
4031    if (!*cl) {
4032      /*
4033       * If no filter is found yet -> search the meta-class
4034       */
4035      *cl = SearchCMethod(startingCl->object.cl, name, &cmd);
4036    }
4037  }
4038  return cmd;
4039}
4040
4041/*
4042 * Filter Guards
4043 */
4044
4045/* check a filter guard, return 1 if ok */
4046static int
4047GuardCheck(Tcl_Interp *interp, ClientData clientData) {
4048  Tcl_Obj *guard = (Tcl_Obj*) clientData;
4049  int rc;
4050  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
4051
4052  if (guard) {
4053    /*
4054     * if there are more than one filter guard for this filter
4055     * (i.e. they are inherited), then they are OR combined
4056     * -> if one check succeeds => return 1
4057     */
4058
4059    /*fprintf(stderr, "checking guard **%s**\n", ObjStr(guard));*/
4060
4061    cs->guardCount++;
4062    rc = checkConditionInScope(interp, guard);
4063    cs->guardCount--;
4064
4065    /*fprintf(stderr, "checking guard **%s** returned rc=%d\n",
4066      ObjStr(fr->content), rc);*/
4067
4068    if (rc == TCL_OK) {
4069      /* fprintf(stderr, " +++ OK\n"); */
4070      return TCL_OK;
4071    } else if (rc == TCL_ERROR) {
4072      Tcl_Obj *sr = Tcl_GetObjResult(interp);
4073      INCR_REF_COUNT(sr);
4074
4075      /* fprintf(stderr, " +++ ERROR\n");*/
4076
4077      XOTclVarErrMsg(interp, "Guard Error: '", ObjStr(guard), "'\n\n",
4078                     ObjStr(sr), (char *) NULL);
4079      DECR_REF_COUNT(sr);
4080      return TCL_ERROR;
4081    }
4082  }
4083  /*
4084    fprintf(stderr, " +++ FAILED\n");
4085  */
4086  return XOTCL_CHECK_FAILED;
4087}
4088
4089/*
4090  static void
4091  GuardPrint(Tcl_Interp *interp, ClientData clientData) {
4092  Tcl_Obj *guard = (TclObj*) clientData;
4093  fprintf(stderr, " +++ <GUARDS> \n");
4094  if (guard) {
4095  fprintf(stderr, "   *     %s \n", ObjStr(guard));
4096  }
4097  fprintf(stderr, " +++ </GUARDS>\n");
4098  }
4099*/
4100
4101static void
4102GuardDel(XOTclCmdList *CL) {
4103  /*fprintf(stderr, "GuardDel %p cd = %p\n",
4104    CL, CL? CL->clientData : NULL);*/
4105  if (CL && CL->clientData) {
4106    DECR_REF_COUNT((Tcl_Obj*)CL->clientData);
4107    CL->clientData = NULL;
4108  }
4109}
4110
4111XOTCLINLINE static void
4112GuardAdd(Tcl_Interp *interp, XOTclCmdList *CL, Tcl_Obj *guard) {
4113  if (guard) {
4114    GuardDel(CL);
4115    if (strlen(ObjStr(guard)) != 0) {
4116      INCR_REF_COUNT(guard);
4117      CL->clientData = (ClientData) guard;
4118      /*fprintf(stderr,"guard added to %p cmdPtr=%p, clientData= %p\n",
4119        CL, CL->cmdPtr, CL->clientData);
4120      */
4121    }
4122  }
4123}
4124/*
4125  static void
4126  GuardAddList(Tcl_Interp *interp, XOTclCmdList *dest, ClientData source) {
4127  XOTclTclObjList *s = (XOTclTclObjList*) source;
4128  while (s) {
4129  GuardAdd(interp, dest, (Tcl_Obj*) s->content);
4130  s = s->next;
4131  }
4132  } */
4133
4134static int
4135GuardCall(XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd,
4136          Tcl_Interp *interp, ClientData clientData, int push) {
4137  int rc = TCL_OK;
4138
4139  if (clientData) {
4140    XOTclCallStackContent *csc = CallStackGetTopFrame(interp);
4141    Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */
4142    INCR_REF_COUNT(res);
4143
4144    csc->callType |= XOTCL_CSC_CALL_IS_GUARD;
4145
4146    /* GuardPrint(interp, cmdList->clientData); */
4147    /*
4148     * ok, there is a guard ... we have to push a
4149     * fake callframe on the tcl stack so that uplevel
4150     * is in sync with the XOTcl callstack, and we can uplevel
4151     * into the above pushed CallStack entry
4152     */
4153    if (push) {
4154      CallStackPush(interp, obj, cl, cmd, 0, 0, XOTCL_CSC_TYPE_GUARD);
4155      rc = GuardCheck(interp, clientData);
4156      CallStackPop(interp);
4157    } else {
4158      rc = GuardCheck(interp, clientData);
4159    }
4160    Tcl_SetObjResult(interp, res);  /* restore the result */
4161    DECR_REF_COUNT(res);
4162  }
4163
4164  return rc;
4165}
4166
4167static int
4168GuardAddFromDefinitionList(Tcl_Interp *interp, XOTclCmdList *dest,
4169                           XOTclObject *obj, Tcl_Command interceptorCmd,
4170                           XOTclCmdList *interceptorDefList) {
4171  XOTclCmdList *h;
4172  if (interceptorDefList) {
4173    h = CmdListFindCmdInList(interceptorCmd, interceptorDefList);
4174    if (h) {
4175      GuardAdd(interp, dest, (Tcl_Obj*) h->clientData);
4176      /*
4177       * 1 means we have added a guard successfully "interceptorCmd"
4178       */
4179      return 1;
4180    }
4181  }
4182  /*
4183   * 0 means we have not added a guard successfully "interceptorCmd"
4184   */
4185  return 0;
4186}
4187
4188static void
4189GuardAddInheritedGuards(Tcl_Interp *interp, XOTclCmdList *dest,
4190                        XOTclObject *obj, Tcl_Command filterCmd) {
4191  XOTclClasses *pl;
4192  int guardAdded = 0;
4193  XOTclObjectOpt *opt;
4194
4195  /* search guards for instfilters registered on mixins */
4196  if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
4197    MixinComputeDefined(interp, obj);
4198  if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) {
4199    XOTclCmdList *ml;
4200    XOTclClass *mixin;
4201    for (ml = obj->mixinOrder; ml && !guardAdded; ml = ml->next) {
4202      mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr);
4203      if (mixin && mixin->opt) {
4204        guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd,
4205                                                mixin->opt->instfilters);
4206      }
4207    }
4208  }
4209
4210  /* search per-object filters */
4211  opt = obj->opt;
4212  if (!guardAdded && opt && opt->filters) {
4213    guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, opt->filters);
4214  }
4215
4216  if (!guardAdded) {
4217    /* search per-class filters */
4218    for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); !guardAdded && pl; pl = pl->next) {
4219      XOTclClassOpt *opt = pl->cl->opt;
4220      if (opt) {
4221        guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd,
4222                                                opt->instfilters);
4223      }
4224    }
4225
4226
4227    /*
4228     * if this is not a registered filter, it is an inherited filter, like:
4229     *   Class A
4230     *   A instproc f ...
4231     *   Class B -superclass A
4232     *   B instproc {{f {<guard>}}}
4233     *   B instfilter f
4234     * -> get the guard from the filter that inherits it (here B->f)
4235     */
4236    if (!guardAdded) {
4237      XOTclCmdList *registeredFilter =
4238        CmdListFindNameInList(interp,(char *) Tcl_GetCommandName(interp, filterCmd),
4239                              obj->filterOrder);
4240      if (registeredFilter) {
4241        GuardAdd(interp, dest, (Tcl_Obj*) registeredFilter->clientData);
4242      }
4243    }
4244  }
4245}
4246
4247static int
4248GuardList(Tcl_Interp *interp, XOTclCmdList *frl, char *interceptorName) {
4249  XOTclCmdList *h;
4250  if (frl) {
4251    /* try to find simple name first */
4252    h = CmdListFindNameInList(interp, interceptorName, frl);
4253    if (!h) {
4254      /* maybe it is a qualified name */
4255      Tcl_Command cmd = NSFindCommand(interp, interceptorName, NULL);
4256      if (cmd) {
4257        h = CmdListFindCmdInList(cmd, frl);
4258      }
4259    }
4260    if (h) {
4261      Tcl_ResetResult(interp);
4262      if (h->clientData) {
4263        Tcl_Obj *g = (Tcl_Obj*) h->clientData;
4264        Tcl_SetObjResult(interp, g);
4265      }
4266      return TCL_OK;
4267    }
4268  }
4269  return XOTclVarErrMsg(interp, "info (*)guard: can't find filter/mixin ",
4270                        interceptorName, (char *) NULL);
4271}
4272
4273/*
4274 * append a filter command to the 'filterList' of an obj/class
4275 */
4276static int
4277FilterAdd(Tcl_Interp *interp, XOTclCmdList **filterList, Tcl_Obj *name,
4278          XOTclObject *startingObj, XOTclClass *startingCl) {
4279  Tcl_Command cmd;
4280  int ocName; Tcl_Obj **ovName;
4281  Tcl_Obj *guard = NULL;
4282  XOTclCmdList *new;
4283  XOTclClass *cl;
4284
4285  if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) {
4286    if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) {
4287      name = ovName[0];
4288      guard = ovName[2];
4289    }
4290  }
4291
4292  if (!(cmd = FilterSearch(interp, ObjStr(name), startingObj, startingCl, &cl))) {
4293    if (startingObj)
4294      return XOTclVarErrMsg(interp, "filter: can't find filterproc on: ",
4295                            ObjStr(startingObj->cmdName), " - proc: ",
4296                            ObjStr(name), (char *) NULL);
4297    else
4298      return XOTclVarErrMsg(interp, "instfilter: can't find filterproc on: ",
4299                            ObjStr(startingCl->object.cmdName), " - proc: ",
4300                            ObjStr(name), (char *) NULL);
4301  }
4302
4303  /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(name), cl);*/
4304
4305  new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1);
4306
4307  if (guard) {
4308    GuardAdd(interp, new, guard);
4309  } else {
4310    if (new->clientData)
4311      GuardDel(new);
4312  }
4313
4314  return TCL_OK;
4315}
4316
4317/*
4318 * reset the filter order cached in obj->filterOrder
4319 */
4320static void
4321FilterResetOrder(XOTclObject *obj) {
4322  CmdListRemoveList(&obj->filterOrder, GuardDel);
4323  obj->filterOrder = NULL;
4324}
4325
4326/*
4327 * search the filter in the hierarchy again with FilterSearch, e.g.
4328 * upon changes in the class hierarchy or mixins that carry the filter
4329 * command, so that we can be sure it is still reachable.
4330 */
4331static void
4332FilterSearchAgain(Tcl_Interp *interp, XOTclCmdList **filters,
4333                  XOTclObject *startingObj, XOTclClass *startingCl) {
4334  char *simpleName;
4335  Tcl_Command cmd;
4336  XOTclCmdList *cmdList, *del;
4337  XOTclClass *cl = NULL;
4338
4339  CmdListRemoveEpoched(filters, GuardDel);
4340  for (cmdList = *filters; cmdList; ) {
4341    simpleName = (char *) Tcl_GetCommandName(interp, cmdList->cmdPtr);
4342    cmd = FilterSearch(interp, simpleName, startingObj, startingCl, &cl);
4343    if (cmd == NULL) {
4344      del = CmdListRemoveFromList(filters, cmdList);
4345      cmdList = cmdList->next;
4346      CmdListDeleteCmdListEntry(del, GuardDel);
4347    } else if (cmd != cmdList->cmdPtr) {
4348      CmdListReplaceCmd(cmdList, cmd, cl);
4349      cmdList = cmdList->next;
4350    } else {
4351      cmdList = cmdList->next;
4352    }
4353  }
4354
4355  /* some entries might be NULL now, if they are not found anymore
4356     -> delete those
4357     CmdListRemoveNulledEntries(filters, GuardDel);
4358  */
4359}
4360
4361/*
4362 * if the class hierarchy or class filters have changed ->
4363 * invalidate filter entries in all dependent instances
4364 *
4365 */
4366static void
4367FilterInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) {
4368  XOTclClasses *saved = cl->order, *clPtr, *savePtr;
4369
4370  cl->order = NULL;
4371  savePtr = clPtr = ComputeOrder(cl, cl->order, Sub);
4372  cl->order = saved;
4373
4374  for ( ; clPtr; clPtr = clPtr->next) {
4375    Tcl_HashSearch hSrch;
4376    Tcl_HashEntry *hPtr = &clPtr->cl->instances ?
4377      Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0;
4378
4379    /* recalculate the commands of all instfilter registrations */
4380    if (clPtr->cl->opt) {
4381      FilterSearchAgain(interp, &clPtr->cl->opt->instfilters, 0, clPtr->cl);
4382    }
4383    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
4384      XOTclObject *obj = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr);
4385      FilterResetOrder(obj);
4386      obj->flags &= ~XOTCL_FILTER_ORDER_VALID;
4387
4388      /* recalculate the commands of all object filter registrations */
4389      if (obj->opt) {
4390        FilterSearchAgain(interp, &obj->opt->filters, obj, 0);
4391      }
4392    }
4393  }
4394  XOTclFreeClasses(savePtr);
4395}
4396
4397/*
4398 * from cl on down the hierarchy we remove all filters
4399 * the refer to "removeClass" namespace. E.g. used to
4400 * remove filters defined in superclass list from dependent
4401 * class cl
4402 */
4403static void
4404FilterRemoveDependentFilterCmds(XOTclClass *cl, XOTclClass *removeClass) {
4405  XOTclClasses *saved = cl->order, *clPtr;
4406  cl->order = NULL;
4407
4408  /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n",
4409	  cl, ObjStr(cl->object.cmdName),
4410	  removeClass, ObjStr(removeClass->object.cmdName));*/
4411
4412  for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->next) {
4413    Tcl_HashSearch hSrch;
4414    Tcl_HashEntry *hPtr = &clPtr->cl->instances ?
4415      Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : NULL;
4416    XOTclClassOpt *opt = clPtr->cl->opt;
4417    if (opt) {
4418      CmdListRemoveContextClassFromList(&opt->instfilters, removeClass, GuardDel);
4419    }
4420    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
4421      XOTclObject *obj = (XOTclObject*)	Tcl_GetHashKey(&clPtr->cl->instances, hPtr);
4422      if (obj->opt) {
4423        CmdListRemoveContextClassFromList(&obj->opt->filters, removeClass, GuardDel);
4424      }
4425    }
4426  }
4427
4428  XOTclFreeClasses(cl->order);
4429  cl->order = saved;
4430}
4431
4432/*
4433 * build up a qualifier of the form <obj/cl> proc/instproc <procName>
4434 * if cl is not NULL, we build an instproc identifier for cl, else a proc
4435 * with obj
4436 */
4437static Tcl_Obj*
4438getFullProcQualifier(Tcl_Interp *interp, CONST84 char *cmdName,
4439                     XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd) {
4440  Tcl_Obj *list = Tcl_NewListObj(0, NULL);
4441  Tcl_Obj *procObj = Tcl_NewStringObj(cmdName, -1);
4442  Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd);
4443  int isTcl = (TclIsProc((Command *)cmd) != NULL);
4444
4445  if (cl) {
4446    Tcl_ListObjAppendElement(interp, list, cl->object.cmdName);
4447    /*fprintf(stderr,"current %p, dispatch %p, forward %p, parametermcd %p, is tcl %p\n",
4448	    objProc, XOTclObjDispatch, XOTclForwardMethod,
4449	    XOTclSetterMethod, TclIsProc((Command *)cmd)); */
4450    if (isTcl) {
4451      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPROC]);
4452    } else if (objProc == XOTclForwardMethod) {
4453      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFORWARD]);
4454    } else if (objProc == XOTclSetterMethod) {
4455      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPARAMETERCMD]);
4456    } else {
4457      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTCMD]);
4458    }
4459  } else {
4460    Tcl_ListObjAppendElement(interp, list, obj->cmdName);
4461    if (isTcl) {
4462      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PROC]);
4463    } else if (objProc == XOTclForwardMethod) {
4464      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FORWARD]);
4465    } else if (objProc == XOTclSetterMethod) {
4466      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PARAMETERCMD]);
4467    } else {
4468      Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_CMD]);
4469    }
4470  }
4471  Tcl_ListObjAppendElement(interp, list, procObj);
4472  return list;
4473}
4474
4475/*
4476 * info option for filters and instfilters
4477 * withGuards -> if not 0 => append guards
4478 * fullProcQualifiers -> if not 0 => full names with obj/class proc/instproc
4479 */
4480static int
4481FilterInfo(Tcl_Interp *interp, XOTclCmdList *f, char *pattern,
4482           int withGuards, int fullProcQualifiers) {
4483  CONST84 char *simpleName;
4484  Tcl_Obj *list = Tcl_NewListObj(0, NULL);
4485
4486  /* guard lists should only have unqualified filter lists
4487     when withGuards is activated, fullProcQualifiers has not
4488     effect */
4489  if (withGuards) {
4490    fullProcQualifiers = 0;
4491  }
4492
4493  while (f) {
4494    simpleName = Tcl_GetCommandName(interp, f->cmdPtr);
4495    if (!pattern || Tcl_StringMatch(simpleName, pattern)) {
4496      if (withGuards && f->clientData) {
4497        Tcl_Obj *innerList = Tcl_NewListObj(0, NULL);
4498        Tcl_Obj *g = (Tcl_Obj*) f->clientData;
4499        Tcl_ListObjAppendElement(interp, innerList,
4500                                 Tcl_NewStringObj(simpleName, -1));
4501        Tcl_ListObjAppendElement(interp, innerList, XOTclGlobalObjects[XOTE_GUARD_OPTION]);
4502        Tcl_ListObjAppendElement(interp, innerList, g);
4503        Tcl_ListObjAppendElement(interp, list, innerList);
4504      } else {
4505        if (fullProcQualifiers) {
4506          XOTclClass *fcl;
4507          XOTclObject *fobj;
4508          if (f->clorobj && !XOTclObjectIsClass(&f->clorobj->object)) {
4509            fobj = (XOTclObject *)f->clorobj;
4510            fcl = NULL;
4511          } else {
4512            fobj = NULL;
4513            fcl = f->clorobj;
4514          }
4515          Tcl_ListObjAppendElement(interp, list,
4516                                   getFullProcQualifier(interp, simpleName,
4517                                                        fobj, fcl, f->cmdPtr));
4518        } else {
4519          Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1));
4520        }
4521      }
4522    }
4523    f = f->next;
4524  }
4525  Tcl_SetObjResult(interp, list);
4526  return TCL_OK;
4527}
4528
4529/*
4530 * Appends XOTclCmdPtr *containing the filter cmds and their
4531 * superclass specializations to 'filterList'
4532 */
4533static void
4534FilterComputeOrderFullList(Tcl_Interp *interp, XOTclCmdList **filters,
4535                           XOTclCmdList **filterList) {
4536  XOTclCmdList *f ;
4537  char *simpleName;
4538  XOTclClass *fcl;
4539  XOTclClasses *pl;
4540
4541  /*
4542   * ensure that no epoched command is in the filters list
4543   */
4544  CmdListRemoveEpoched(filters, GuardDel);
4545
4546  for (f = *filters; f; f = f->next) {
4547    simpleName = (char *) Tcl_GetCommandName(interp, f->cmdPtr);
4548    fcl = f->clorobj;
4549    CmdListAdd(filterList, f->cmdPtr, fcl, /*noDuplicates*/ 0);
4550
4551    if (fcl && !XOTclObjectIsClass(&fcl->object)) {
4552      /* get the object for per-object filter */
4553      XOTclObject *fObj = (XOTclObject *)fcl;
4554      /* and then get class */
4555      fcl = fObj->cl;
4556    }
4557
4558    /* if we have a filter class -> search up the inheritance hierarchy*/
4559    if (fcl) {
4560      pl = ComputeOrder(fcl, fcl->order, Super);
4561      if (pl && pl->next) {
4562        /* don't search on the start class again */
4563        pl = pl->next;
4564        /* now go up the hierarchy */
4565        for(; pl; pl = pl->next) {
4566          Tcl_Command pi = FindMethod(simpleName, pl->cl->nsPtr);
4567          if (pi) {
4568            CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0);
4569            /*
4570              fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName);
4571            */
4572          }
4573        }
4574      }
4575    }
4576  }
4577  /*CmdListPrint(interp,"FilterComputeOrderFullList....\n", *filterList);*/
4578}
4579
4580/*
4581 * Computes a linearized order of filter and instfilter. Then
4582 * duplicates in the full list and with the class inheritance list of
4583 * 'obj' are eliminated.
4584 * The precendence rule is that the last occurence makes it into the
4585 * final list.
4586 */
4587static void
4588FilterComputeOrder(Tcl_Interp *interp, XOTclObject *obj) {
4589  XOTclCmdList *filterList = NULL, *next, *checker, *newlist;
4590  XOTclClasses *pl;
4591
4592  if (obj->filterOrder) FilterResetOrder(obj);
4593  /*
4594    fprintf(stderr, "<Filter Order obj=%s> List: ", ObjStr(obj->cmdName));
4595  */
4596
4597  /* append instfilters registered for mixins */
4598  if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
4599    MixinComputeDefined(interp, obj);
4600
4601  if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) {
4602    XOTclCmdList *ml;
4603    XOTclClass *mixin;
4604
4605    for (ml = obj->mixinOrder; ml; ml = ml->next) {
4606      mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr);
4607      if (mixin && mixin->opt && mixin->opt->instfilters)
4608        FilterComputeOrderFullList(interp, &mixin->opt->instfilters, &filterList);
4609    }
4610  }
4611
4612  /* append per-obj filters */
4613  if (obj->opt)
4614    FilterComputeOrderFullList(interp, &obj->opt->filters, &filterList);
4615
4616  /* append per-class filters */
4617  for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl=pl->next) {
4618    XOTclClassOpt *opt = pl->cl->opt;
4619    if (opt && opt->instfilters) {
4620      FilterComputeOrderFullList(interp, &opt->instfilters, &filterList);
4621    }
4622  }
4623
4624  /*
4625    fprintf(stderr, "\n");
4626  */
4627  /* use no duplicates & no classes of the precedence order
4628     on the resulting list */
4629  while (filterList) {
4630    checker = next = filterList->next;
4631    while (checker) {
4632      if (checker->cmdPtr == filterList->cmdPtr) break;
4633      checker = checker->next;
4634    }
4635    if (checker == NULL) {
4636      newlist = CmdListAdd(&obj->filterOrder, filterList->cmdPtr, filterList->clorobj,
4637                           /*noDuplicates*/ 0);
4638      GuardAddInheritedGuards(interp, newlist, obj, filterList->cmdPtr);
4639      /*
4640        fprintf(stderr, "  Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(interp, filterList->cmdPtr));
4641      */
4642      /*
4643        GuardPrint(interp, newlist->clientData);
4644      */
4645
4646    }
4647
4648    CmdListDeleteCmdListEntry(filterList, GuardDel);
4649
4650    filterList = next;
4651  }
4652  /*
4653    fprintf(stderr, "</Filter Order>\n");
4654  */
4655}
4656
4657/*
4658 * the filter order is either
4659 *   DEFINED (there are filter on the instance),
4660 *   NONE    (there are no filter for the instance),
4661 *   or INVALID (a class re-strucuturing has occured, thus it is not clear
4662 *               whether filters are defined or not).
4663 * If it is INVALID FilterComputeDefined can be used to compute the order
4664 * and set the instance to DEFINE or NONE
4665 */
4666static void
4667FilterComputeDefined(Tcl_Interp *interp, XOTclObject *obj) {
4668  FilterComputeOrder(interp, obj);
4669  obj->flags |= XOTCL_FILTER_ORDER_VALID;
4670  if (obj->filterOrder)
4671    obj->flags |= XOTCL_FILTER_ORDER_DEFINED;
4672  else
4673    obj->flags &= ~XOTCL_FILTER_ORDER_DEFINED;
4674}
4675
4676/*
4677 * push a filter stack information on this object
4678 */
4679static int
4680FilterStackPush(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *calledProc) {
4681  register XOTclFilterStack *h = NEW(XOTclFilterStack);
4682
4683  h->currentCmdPtr = NULL;
4684  h->calledProc = calledProc;
4685  INCR_REF_COUNT(h->calledProc);
4686  h->next = obj->filterStack;
4687  obj->filterStack = h;
4688  return 1;
4689}
4690
4691/*
4692 * pop a filter stack information on this object
4693 */
4694static void
4695FilterStackPop(XOTclObject *obj) {
4696  register XOTclFilterStack *h = obj->filterStack;
4697  obj->filterStack = h->next;
4698
4699  /* free stack entry */
4700  DECR_REF_COUNT(h->calledProc);
4701  FREE(XOTclFilterStack, h);
4702}
4703
4704/*
4705 * seek through the filters active for "obj" and check whether cmdPtr
4706 * is among them
4707 */
4708XOTCLINLINE static int
4709FilterActiveOnObj(Tcl_Interp *interp, XOTclObject *obj, Tcl_Command cmd) {
4710  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
4711  XOTclCallStackContent *bot = cs->content;
4712  register XOTclCallStackContent *csc = cs->top;
4713  while (csc > bot) {
4714    /* only check the callstack entries for this object &&
4715       only check the callstack entries for the given cmd */
4716    if (obj == csc->self && cmd == csc->cmdPtr &&
4717        csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) {
4718      return 1;
4719    }
4720    csc--;
4721  }
4722  return 0;
4723}
4724
4725/*
4726 * search through the filter list on obj and class hierarchy
4727 * for registration of a command ptr as filter
4728 *
4729 * returns a tcl obj list with the filter registration, like:
4730 * "<obj> filter <filterName>,
4731 * "<class> instfilter <filterName>,
4732 * or an empty list, if not registered
4733 */
4734static Tcl_Obj*
4735FilterFindReg(Tcl_Interp *interp, XOTclObject *obj, Tcl_Command cmd) {
4736  Tcl_Obj *list = Tcl_NewListObj(0, NULL);
4737  XOTclClasses *pl;
4738
4739  /* search per-object filters */
4740  if (obj->opt && CmdListFindCmdInList(cmd, obj->opt->filters)) {
4741    Tcl_ListObjAppendElement(interp, list, obj->cmdName);
4742    Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FILTER]);
4743    Tcl_ListObjAppendElement(interp, list,
4744                             Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1));
4745    return list;
4746  }
4747
4748  /* search per-class filters */
4749  for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) {
4750    XOTclClassOpt *opt = pl->cl->opt;
4751    if (opt && opt->instfilters) {
4752      if (CmdListFindCmdInList(cmd, opt->instfilters)) {
4753        Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName);
4754        Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFILTER]);
4755        Tcl_ListObjAppendElement(interp, list,
4756                                 Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1));
4757        return list;
4758      }
4759    }
4760  }
4761  return list;
4762}
4763
4764/*
4765 * before we can perform a filter dispatch, FilterSearchProc seeks the
4766 * current filter and the relevant calling information
4767 */
4768static Tcl_Command
4769FilterSearchProc(Tcl_Interp *interp, XOTclObject *obj,
4770                 Tcl_Command *currentCmd, XOTclClass **cl) {
4771  XOTclCmdList *cmdList;
4772
4773  assert(obj);
4774  assert(obj->filterStack);
4775
4776  *currentCmd = NULL;
4777
4778  /* Ensure that the filter order is not invalid, otherwise compute order
4779     FilterComputeDefined(interp, obj);
4780  */
4781  assert(obj->flags & XOTCL_FILTER_ORDER_VALID);
4782  cmdList = seekCurrent(obj->filterStack->currentCmdPtr, obj->filterOrder);
4783
4784  while (cmdList) {
4785    if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) {
4786      cmdList = cmdList->next;
4787    } else if (FilterActiveOnObj(interp, obj, cmdList->cmdPtr)) {
4788      /* fprintf(stderr, "Filter <%s> -- Active on: %s\n",
4789         Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), ObjStr(obj->cmdName));
4790      */
4791      obj->filterStack->currentCmdPtr = cmdList->cmdPtr;
4792      cmdList = seekCurrent(obj->filterStack->currentCmdPtr, obj->filterOrder);
4793    } else {
4794      /* ok. we' ve found it */
4795     if (cmdList->clorobj && !XOTclObjectIsClass(&cmdList->clorobj->object)) {
4796        *cl = NULL;
4797      } else {
4798        *cl = cmdList->clorobj;
4799      }
4800      *currentCmd = cmdList->cmdPtr;
4801      /* fprintf(stderr, "FilterSearchProc - found: %s, %p\n",
4802         Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), cmdList->cmdPtr);
4803      */
4804      return cmdList->cmdPtr;
4805    }
4806  }
4807  return NULL;
4808}
4809
4810
4811static int
4812SuperclassAdd(Tcl_Interp *interp, XOTclClass *cl, int oc, Tcl_Obj **ov, Tcl_Obj *arg) {
4813  XOTclClasses *filterCheck, *osl = NULL;
4814  XOTclClass **scl;
4815  int reversed = 0;
4816  int i, j;
4817
4818  filterCheck = ComputeOrder(cl, cl->order, Super);
4819  /*
4820   * we have to remove all dependent superclass filter referenced
4821   * by class or one of its subclasses
4822   *
4823   * do not check the class "cl" itself (first entry in
4824   * filterCheck class list)
4825   */
4826  if (filterCheck)
4827    filterCheck = filterCheck->next;
4828  for (; filterCheck; filterCheck = filterCheck->next) {
4829    FilterRemoveDependentFilterCmds(cl, filterCheck->cl);
4830  }
4831
4832  /* invalidate all interceptors orders of instances of this
4833     and of all depended classes */
4834  MixinInvalidateObjOrders(interp, cl);
4835  FilterInvalidateObjOrders(interp, cl);
4836
4837  scl = NEW_ARRAY(XOTclClass*, oc);
4838  for (i = 0; i < oc; i++) {
4839    if (GetXOTclClassFromObj(interp, ov[i], &scl[i], 1) != TCL_OK) {
4840      FREE(XOTclClass**, scl);
4841      return XOTclErrBadVal(interp, "superclass", "a list of classes",
4842                            ObjStr(arg));
4843    }
4844  }
4845
4846  /*
4847   * check that superclasses don't precede their classes
4848   */
4849
4850  for (i = 0; i < oc; i++) {
4851    if (reversed) break;
4852    for (j = i+1; j < oc; j++) {
4853      XOTclClasses *dl = ComputeOrder(scl[j], scl[j]->order, Super);
4854      if (reversed) break;
4855      while (dl) {
4856        if (dl->cl == scl[i]) break;
4857        dl = dl->next;
4858      }
4859      if (dl) reversed = 1;
4860    }
4861  }
4862
4863  if (reversed) {
4864    return XOTclErrBadVal(interp, "superclass", "classes in dependence order",
4865                          ObjStr(arg));
4866  }
4867
4868  while (cl->super) {
4869    /*
4870     * build up an old superclass list in case we need to revert
4871     */
4872
4873    XOTclClass *sc = cl->super->cl;
4874    XOTclClasses *l = osl;
4875    osl = NEW(XOTclClasses);
4876    osl->cl = sc;
4877    osl->next = l;
4878    (void)RemoveSuper(cl, cl->super->cl);
4879  }
4880  for (i = 0; i < oc; i++) {
4881    AddSuper(cl, scl[i]);
4882  }
4883  FREE(XOTclClass**, scl);
4884  FlushPrecedencesOnSubclasses(cl);
4885
4886  if (!ComputeOrder(cl, cl->order, Super)) {
4887
4888    /*
4889     * cycle in the superclass graph, backtrack
4890     */
4891
4892    XOTclClasses *l;
4893    while (cl->super) (void)RemoveSuper(cl, cl->super->cl);
4894    for (l = osl; l; l = l->next) AddSuper(cl, l->cl);
4895    XOTclFreeClasses(osl);
4896    return XOTclErrBadVal(interp, "superclass", "a cycle-free graph", ObjStr(arg));
4897  }
4898  XOTclFreeClasses(osl);
4899
4900  /* if there are no more super classes add the Object
4901     class as superclasses */
4902  if (cl->super == NULL)
4903    AddSuper(cl, RUNTIME_STATE(interp)->theObject);
4904
4905  Tcl_ResetResult(interp);
4906  return TCL_OK;
4907}
4908
4909static int
4910varExists(Tcl_Interp *interp, XOTclObject *obj, char *varName, char *index,
4911          int triggerTrace, int requireDefined) {
4912  XOTcl_FrameDecls;
4913  Var *varPtr, *arrayPtr;
4914  int result;
4915  int flags = 0;
4916
4917#ifdef PRE81
4918  flags |= (index == NULL) ? TCL_PARSE_PART1 : 0;
4919#endif
4920
4921  XOTcl_PushFrame(interp, obj);
4922
4923#if defined(PRE83)
4924  varPtr = TclLookupVar(interp, varName, index, flags, "access",
4925                        /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
4926#else
4927  if (triggerTrace)
4928    varPtr = TclVarTraceExists(interp, varName);
4929  else
4930    varPtr = TclLookupVar(interp, varName, index, flags, "access",
4931                          /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
4932#endif
4933  /*
4934  fprintf(stderr, "varExists %s varPtr %p requireDefined %d, triggerTrace %d, isundef %d\n",
4935          varName,
4936          varPtr,
4937          requireDefined, triggerTrace,
4938          varPtr ? TclIsVarUndefined(varPtr) : 0);
4939  */
4940  result = (varPtr && (!requireDefined || !TclIsVarUndefined(varPtr)));
4941
4942  XOTcl_PopFrame(interp, obj);
4943
4944  return result;
4945}
4946
4947static void
4948getVarAndNameFromHash(Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) {
4949  *val  = VarHashGetValue(hPtr);
4950#if defined(PRE85)
4951# if FORWARD_COMPATIBLE
4952  if (forwardCompatibleMode) {
4953    *varNameObj  = VarHashGetKey(*val);
4954  } else {
4955    *varNameObj  = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1);
4956  }
4957# else
4958  *varNameObj  = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1);
4959# endif
4960#else
4961  *varNameObj  = VarHashGetKey(*val);
4962#endif
4963}
4964
4965/*
4966 * Search default values specified through 'parameter' on one class
4967 */
4968static int
4969SearchDefaultValuesOnClass(Tcl_Interp *interp, XOTclObject *obj,
4970                           XOTclClass *cmdCl, XOTclClass *targetClass) {
4971  int result = TCL_OK;
4972  Var *defaults, *initcmds;
4973  Tcl_Namespace *ns = targetClass->object.nsPtr;
4974  TclVarHashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : targetClass->object.varTable;
4975
4976  defaults = LookupVarFromTable(varTable, "__defaults",(XOTclObject*)targetClass);
4977  initcmds = LookupVarFromTable(varTable, "__initcmds",(XOTclObject*)targetClass);
4978
4979  if (defaults && TclIsVarArray(defaults)) {
4980    TclVarHashTable *tablePtr = valueOfVar(TclVarHashTable, defaults, tablePtr);
4981    Tcl_HashSearch hSrch;
4982    Tcl_HashEntry *hPtr = tablePtr ? Tcl_FirstHashEntry(VarHashTable(tablePtr), &hSrch) : 0;
4983
4984    /*fprintf(stderr, "+++ we have defaults for %s in <%s>\n",
4985      ObjStr(obj->cmdName), className(targetClass));*/
4986
4987    /* iterate over all elements of the defaults array */
4988    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
4989      Var *val;
4990      Tcl_Obj *varNameObj;
4991
4992      getVarAndNameFromHash(hPtr, &val, &varNameObj);
4993      INCR_REF_COUNT(varNameObj);
4994
4995      if (TclIsVarScalar(val)) {
4996        Tcl_Obj *oldValue = XOTclOGetInstVar2((XOTcl_Object*) obj,
4997                                              interp, varNameObj, NULL,
4998                                              TCL_PARSE_PART1);
4999        /** we check whether the variable is already set.
5000            if so, we do not set it again */
5001        if (oldValue == NULL) {
5002          Tcl_Obj *valueObj = valueOfVar(Tcl_Obj, val, objPtr);
5003          char *value = ObjStr(valueObj), *v;
5004          int doSubst = 0;
5005          for (v=value; *v; v++) {
5006            if (*v == '[' && doSubst == 0)
5007              doSubst = 1;
5008            else if ((doSubst == 1 && *v == ']') || *v == '$') {
5009              doSubst = 2;
5010              break;
5011            }
5012          }
5013          if (doSubst == 2) { /* we have to subst */
5014            Tcl_Obj *ov[2];
5015            int rc = CallStackPush(interp, obj, cmdCl, 0, 1,
5016                                   &varNameObj, XOTCL_CSC_TYPE_PLAIN);
5017            if (rc != TCL_OK) {
5018              DECR_REF_COUNT(varNameObj);
5019              return rc;
5020            }
5021            ov[1] = valueObj;
5022            Tcl_ResetResult(interp);
5023            rc = XOTcl_SubstObjCmd(NULL, interp, 2, ov);
5024            CallStackPop(interp);
5025            if (rc == TCL_OK) {
5026              valueObj = Tcl_GetObjResult(interp);
5027            } else {
5028              DECR_REF_COUNT(varNameObj);
5029              return rc;
5030            }
5031          }
5032          /*fprintf(stderr,"calling %s value='%s'\n",
5033            ObjStr(varNameObj), ObjStr(valueObj));*/
5034          INCR_REF_COUNT(valueObj);
5035          result = XOTclCallMethodWithArgs((ClientData)obj, interp,
5036                                           varNameObj, valueObj, 1, 0, 0);
5037          DECR_REF_COUNT(valueObj);
5038
5039          if (result != TCL_OK) {
5040            DECR_REF_COUNT(varNameObj);
5041            return result;
5042          }
5043        }
5044      }
5045      DECR_REF_COUNT(varNameObj);
5046    }
5047  }
5048
5049  if (initcmds && TclIsVarArray(initcmds)) {
5050    TclVarHashTable *tablePtr = valueOfVar(TclVarHashTable, initcmds, tablePtr);
5051    Tcl_HashSearch hSrch;
5052    Tcl_HashEntry *hPtr = tablePtr ? Tcl_FirstHashEntry(VarHashTable(tablePtr), &hSrch) : NULL;
5053
5054    /*fprintf(stderr, "+++ we have initcmds for <%s>\n", className(targetClass));*/
5055    /* iterate over the elements of initcmds */
5056    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
5057      Var  *val;
5058      Tcl_Obj *varNameObj;
5059
5060      getVarAndNameFromHash(hPtr, &val, &varNameObj);
5061
5062      INCR_REF_COUNT(varNameObj);
5063      /*fprintf(stderr,"varexists(%s->%s) = %d\n",
5064	      ObjStr(obj->cmdName),
5065	      ObjStr(varNameObj), varExists(interp, obj, ObjStr(varNameObj), NULL, 0, 0));*/
5066
5067      if (TclIsVarScalar(val) &&
5068          (!varExists(interp, obj, ObjStr(varNameObj), NULL, 0, 0) ||
5069           varExists(interp, &targetClass->object, "__defaults", ObjStr(varNameObj), 0, 0)
5070           )) {
5071        Tcl_Obj *valueObj = valueOfVar(Tcl_Obj, val, objPtr);
5072        char *string = ObjStr(valueObj);
5073        int rc;
5074        XOTcl_FrameDecls;
5075        if (*string) {
5076          XOTcl_PushFrame(interp, obj); /* make instvars accessible */
5077          CallStackPush(interp, obj, cmdCl, 0, 1,
5078                        &varNameObj, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/
5079
5080          /*fprintf(stderr,"evaluating '%s' obj=%s\n\n", ObjStr(valueObj), ObjStr(obj->cmdName));
5081            XOTclCallStackDump(interp);*/
5082
5083          rc = Tcl_EvalObjEx(interp, valueObj, TCL_EVAL_DIRECT);
5084          CallStackPop(interp);
5085          XOTcl_PopFrame(interp, obj);
5086          if (rc != TCL_OK) {
5087            DECR_REF_COUNT(varNameObj);
5088            return rc;
5089          }
5090          /* fprintf(stderr,"... varexists(%s->%s) = %d\n",
5091             ObjStr(obj->cmdName),
5092             varName, varExists(interp, obj, varName, NULL, 0, 0)); */
5093        }
5094      }
5095      DECR_REF_COUNT(varNameObj);
5096    }
5097  }
5098  return result;
5099}
5100
5101/*
5102 * Search default values specified through 'parameter' on
5103 * mixin and class hierarchy
5104 */
5105static int
5106SearchDefaultValues(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cmdCl) {
5107  XOTcl_FrameDecls;
5108  XOTclClass *cl = obj->cl, *mixin;
5109  XOTclClasses *pl;
5110  XOTclCmdList *ml;
5111  int result = TCL_OK;
5112
5113  if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
5114    MixinComputeDefined(interp, obj);
5115  if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)
5116    ml = obj->mixinOrder;
5117  else
5118    ml = NULL;
5119
5120  assert(cl);
5121
5122  XOTcl_PushFrame(interp, obj);
5123
5124  while (ml) {
5125    mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr);
5126    result = SearchDefaultValuesOnClass(interp, obj, cmdCl, mixin);
5127    if (result != TCL_OK)
5128      break;
5129    ml = ml->next;
5130  }
5131
5132  for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) {
5133    result = SearchDefaultValuesOnClass(interp, obj, cmdCl, pl->cl);
5134    if (result != TCL_OK)
5135      break;
5136  }
5137
5138  XOTcl_PopFrame(interp, obj);
5139  return result;
5140}
5141
5142static int
5143ParameterSearchDefaultsMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) {
5144  XOTclClass *cl = XOTclObjectToClass(cd);
5145  XOTclObject *defaultObj;
5146
5147  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
5148  if (objc != 2)
5149    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "searchDefaults obj");
5150  if (XOTclObjConvertObject(interp, objv[1], &defaultObj) != TCL_OK)
5151    return XOTclVarErrMsg(interp, "Can't find default object ",
5152                          ObjStr(objv[1]), (char *) NULL);
5153
5154  /*
5155   *  Search for default values for vars on superclasses
5156   */
5157  return SearchDefaultValues(interp, defaultObj, defaultObj->cl);
5158}
5159
5160static int
5161callParameterMethodWithArg(XOTclObject *obj, Tcl_Interp *interp, Tcl_Obj *method,
5162                           Tcl_Obj *arg, int objc, Tcl_Obj *CONST objv[], int flags) {
5163  XOTclClassOpt *opt = obj->cl->opt;
5164  Tcl_Obj *pcl = XOTclGlobalObjects[XOTE_PARAM_CL];
5165  XOTclClass *paramCl;
5166  int result;
5167
5168  if (opt && opt->parameterClass) pcl = opt->parameterClass;
5169
5170  if (GetXOTclClassFromObj(interp, pcl,&paramCl, 1) == TCL_OK) {
5171    result = XOTclCallMethodWithArgs((ClientData)paramCl, interp,
5172                                     method, arg, objc-2, objv, flags);
5173  }
5174  else
5175    result = XOTclVarErrMsg(interp, "create: can't find parameter class",
5176                            (char *) NULL);
5177  return result;
5178}
5179
5180#if !defined(PRE85)
5181# if defined(WITH_TCL_COMPILE)
5182#  include <tclCompile.h>
5183# endif
5184
5185static void
5186MakeProcError(
5187    Tcl_Interp *interp,		/* The interpreter in which the procedure was
5188				 * called. */
5189    Tcl_Obj *procNameObj)	/* Name of the procedure. Used for error
5190				 * messages and trace information. */
5191{
5192    int overflow, limit = 60, nameLen;
5193    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
5194
5195    overflow = (nameLen > limit);
5196    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
5197	    "\n    (procedure \"%.*s%s\" line %d)",
5198	    (overflow ? limit : nameLen), procName,
5199	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
5200}
5201
5202static int PushProcCallFrame(
5203    ClientData clientData, 	/* Record describing procedure to be
5204				 * interpreted. */
5205    register Tcl_Interp *interp,/* Interpreter in which procedure was
5206				 * invoked. */
5207    int objc,			/* Count of number of arguments to this
5208				 * procedure. */
5209    Tcl_Obj *CONST objv[],	/* Argument value objects. */
5210    int isLambda)		/* 1 if this is a call by ApplyObjCmd: it
5211				 * needs special rules for error msg */
5212{
5213    Proc *procPtr = (Proc *) clientData;
5214    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
5215    CallFrame *framePtr, **framePtrPtr = &framePtr;
5216    int result;
5217    static Tcl_ObjType CONST86 *byteCodeType = NULL;
5218
5219    if (byteCodeType == NULL) {
5220      static XOTclMutex initMutex = 0;
5221      XOTclMutexLock(&initMutex);
5222      if (byteCodeType == NULL) {
5223        byteCodeType = Tcl_GetObjType("bytecode");
5224      }
5225      XOTclMutexUnlock(&initMutex);
5226    }
5227
5228    if (procPtr->bodyPtr->typePtr == byteCodeType) {
5229# if defined(WITH_TCL_COMPILE)
5230      ByteCode *codePtr;
5231      Interp *iPtr = (Interp *) interp;
5232
5233      /*
5234       * When we've got bytecode, this is the check for validity. That is,
5235       * the bytecode must be for the right interpreter (no cross-leaks!),
5236       * the code must be from the current epoch (so subcommand compilation
5237       * is up-to-date), the namespace must match (so variable handling
5238       * is right) and the resolverEpoch must match (so that new shadowed
5239       * commands and/or resolver changes are considered).
5240       */
5241
5242      codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
5243      if (((Interp *) *codePtr->interpHandle != iPtr)
5244          || (codePtr->compileEpoch != iPtr->compileEpoch)
5245          || (codePtr->nsPtr != nsPtr)
5246          || (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
5247        goto doCompilation;
5248      }
5249# endif
5250    } else {
5251# if defined(WITH_TCL_COMPILE)
5252    doCompilation:
5253# endif
5254      result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
5255                                   (Namespace *) nsPtr, "body of proc", TclGetString(objv[isLambda]));
5256      /*fprintf(stderr,"compile returned %d",result);*/
5257      if (result != TCL_OK) {
5258        return result;
5259      }
5260    }
5261    /*
5262     * Set up and push a new call frame for the new procedure invocation.
5263     * This call frame will execute in the proc's namespace, which might be
5264     * different than the current namespace. The proc's namespace is that of
5265     * its command, which can change if the command is renamed from one
5266     * namespace to another.
5267     */
5268
5269    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
5270	    (Tcl_Namespace *) nsPtr,
5271	    (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC));
5272
5273    if (result != TCL_OK) {
5274	return result;
5275    }
5276
5277    framePtr->objc = objc;
5278    framePtr->objv = objv;
5279    framePtr->procPtr = procPtr;
5280
5281    return TCL_OK;
5282}
5283#endif
5284
5285/*
5286 * method dispatch
5287 */
5288
5289/* actually call a method (with assertion checking) */
5290static int
5291callProcCheck(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
5292              Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName,
5293              int frameType, int isTclProc) {
5294  int result = TCL_OK;
5295  XOTclRuntimeState *rst = RUNTIME_STATE(interp);
5296  CheckOptions co;
5297
5298#if defined(PROFILE)
5299  long int startUsec, startSec;
5300  struct timeval trt;
5301
5302  gettimeofday(&trt, NULL);
5303  startSec  = trt.tv_sec;
5304  startUsec = trt.tv_usec;
5305#endif
5306  assert(obj);
5307
5308  rst->callIsDestroy = 0;
5309  /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 0, m=%s obj=%p (%s) is TclProc %d\n",
5310    methodName, obj, ObjStr(obj->cmdName), isTclProc);*/
5311
5312  /*
5313    fprintf(stderr,"*** callProcCheck: cmd = %p\n", cmd);
5314    fprintf(stderr,
5315	  "cp=%p, isTclProc=%d %p %s, dispatch=%d %p, forward=%d %p, scoped %p, ov[0]=%p oc=%d\n",
5316	  cp,
5317	  isTclProc, cmd,
5318	  Tcl_GetCommandName(interp, cmd),
5319	  Tcl_Command_objProc(cmd) == XOTclObjDispatch, XOTclObjDispatch,
5320	  Tcl_Command_objProc(cmd) == XOTclForwardMethod, XOTclForwardMethod,
5321    XOTclObjscopedMethod,
5322	  objv[0], objc
5323	  );
5324  */
5325
5326#ifdef CALLSTACK_TRACE
5327  XOTclCallStackDump(interp);
5328#endif
5329
5330  /*fprintf(stderr, "+++ callProcCheck teardown %p, method=%s, isTclProc %d\n",obj->teardown,methodName,isTclProc);*/
5331  if (!obj->teardown) {
5332    goto finish;
5333  }
5334
5335  if (isTclProc == 0) {
5336    if (obj->opt) {
5337      co = obj->opt->checkoptions;
5338      if ((co & CHECK_INVAR) &&
5339          ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) {
5340        goto finish;
5341      }
5342    }
5343
5344#ifdef DISPATCH_TRACE
5345    printCall(interp,"callProcCheck cmd", objc, objv);
5346    fprintf(stderr,"\tcmd=%s\n", Tcl_GetCommandName(interp, cmd));
5347#endif
5348
5349    result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmd), cp, objc, objv);
5350
5351#ifdef DISPATCH_TRACE
5352    printExit(interp,"callProcCheck cmd", objc, objv, result);
5353    /*fprintf(stderr, " returnCode %d xotcl rc %d\n",
5354      Tcl_Interp_returnCode(interp), rst->returnCode);*/
5355#endif
5356
5357    /*
5358      if (obj && obj->teardown && cl && !(obj->flags & XOTCL_DESTROY_CALLED)) {
5359      fprintf(stderr, "Obj= %s ", ObjStr(obj->cmdName));
5360      fprintf(stderr, "CL= %s ", ObjStr(cl->object.cmdName));
5361      fprintf(stderr, "method=%s\n", methodName);
5362      }
5363    */
5364    /* The order of the check is important, since obj might be already
5365       freed in case the call was a instdestroy */
5366    if (!rst->callIsDestroy && obj->opt) {
5367      co = obj->opt->checkoptions;
5368      if ((co & CHECK_INVAR) &&
5369          ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) {
5370        goto finish;
5371      }
5372    }
5373  } else {
5374    /* isTclProc == 1
5375     * if this is a filter, check whether its guard applies,
5376     * if not: just step forward to the next filter
5377     */
5378    /*fprintf(stderr,"calling proc %s isTclProc %d tearDown %d\n",methodName,isTclProc,obj->teardown);*/
5379
5380    if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) {
5381      XOTclCmdList *cmdList;
5382      /*
5383       * seek cmd in obj's filterOrder
5384       */
5385      assert(obj->flags & XOTCL_FILTER_ORDER_VALID);
5386      /* otherwise: FilterComputeDefined(interp, obj);*/
5387
5388      for (cmdList = obj->filterOrder; cmdList && cmdList->cmdPtr != cmd; cmdList = cmdList->next);
5389
5390      /*
5391       * when it is found, check whether it has a filter guard
5392       */
5393      if (cmdList) {
5394        int rc = GuardCall(obj, cl, (Tcl_Command) cmdList->cmdPtr, interp,
5395                           cmdList->clientData, 0);
5396        if (rc != TCL_OK) {
5397          if (rc != TCL_ERROR) {
5398            /*
5399             * call next, use the given objv's, not the callstack objv
5400             * we may not be in a method, thus there may be wrong or
5401             * no callstackobjs
5402             */
5403            /*fprintf(stderr, "... calling nextmethod\n");  XOTclCallStackDump(interp);*/
5404
5405            rc = XOTclNextMethod(obj, interp, cl, methodName,
5406                                 objc, objv, /*useCallStackObjs*/ 0);
5407            /*fprintf(stderr, "... after nextmethod\n");
5408              XOTclCallStackDump(interp);*/
5409
5410          }
5411
5412          return rc;
5413        }
5414      }
5415    }
5416
5417    /*fprintf(stderr, "AFTER FILTER, teardown=%p call is destroy %d\n",obj->teardown,rst->callIsDestroy);*/
5418
5419    /*
5420    if (!obj->teardown || rst->callIsDestroy) {
5421      goto finish;
5422    }
5423    */
5424
5425    if (obj->opt &&
5426        (obj->opt->checkoptions & CHECK_PRE) &&
5427        (result = AssertionCheck(interp, obj, cl, methodName, CHECK_PRE)) == TCL_ERROR) {
5428      goto finish;
5429    }
5430
5431#if defined(RST_RETURNCODE)
5432    if (Tcl_Interp_numLevels(interp) <= 2)
5433      rst->returnCode = TCL_OK;
5434#endif
5435
5436#ifdef DISPATCH_TRACE
5437    printCall(interp,"callProcCheck tclCmd", objc, objv);
5438    fprintf(stderr,"\tproc=%s\n", Tcl_GetCommandName(interp, cmd));
5439#endif
5440
5441    /*
5442     * In case, we have Tcl 8.5.* or better, we can avoid calling the
5443     * standard TclObjInterpProc() and ::xotcl::initProcNS defined in
5444     * the method, since Tcl 8.5 has a separate functions
5445     * PushProcCallFrame() and TclObjInterpProcCore(), where the
5446     * latter is callable from the outside (e.g. from XOTcl). This new
5447     * interface allows us to setup the XOTcl callframe before the
5448     * bytecode of the method body (provisioned by PushProcCallFrame)
5449     * is executed. On the medium range, we do not need the xotcl
5450     * callframe when we stop supporting Tcl 8.4 (we should simply use
5451     * the calldata field in the callstack), which should be managed
5452     * here or in PushProcCallFrame. At the same time, we could do the
5453     * non-pos-arg handling here as well.
5454     */
5455#if !defined(PRE85) && !defined(NRE)
5456    /*fprintf(stderr,"\tproc=%s cp=%p %d\n", Tcl_GetCommandName(interp, cmd),cp, isTclProc);*/
5457
5458    result = PushProcCallFrame(cp, interp, objc, objv, /*isLambda*/ 0);
5459
5460    if (result == TCL_OK) {
5461      rst->cs.top->currentFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp);
5462      result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
5463    } else {
5464      result = TCL_ERROR;
5465    }
5466#else
5467    result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmd), cp, objc, objv);
5468#endif
5469
5470#ifdef DISPATCH_TRACE
5471    printExit(interp,"callProcCheck tclCmd", objc, objv, result);
5472    /* fprintf(stderr, " returnCode %d xotcl rc %d\n",
5473       Tcl_Interp_returnCode(interp), result);*/
5474#endif
5475
5476#if defined(RST_RETURNCODE)
5477    if (result == TCL_BREAK && rst->returnCode == TCL_OK)
5478      rst->returnCode = result;
5479#endif
5480
5481    /* we give the information whether the call has destroyed the
5482       object back to the caller, because after CallStackPop it
5483       cannot be retrieved via the call stack */
5484    /* if the object is destroyed -> the assertion structs's are already
5485       destroyed */
5486    if (rst->cs.top->callType & XOTCL_CSC_CALL_IS_DESTROY) {
5487      rst->callIsDestroy = 1;
5488      /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 1\n");*/
5489    }
5490
5491    if (obj->opt && !rst->callIsDestroy && obj->teardown &&
5492        (obj->opt->checkoptions & CHECK_POST) &&
5493        (result = AssertionCheck(interp, obj, cl, methodName, CHECK_POST) == TCL_ERROR)) {
5494      goto finish;
5495    }
5496  }
5497
5498 finish:
5499#if defined(PROFILE)
5500  if (rst->callIsDestroy == 0) {
5501    XOTclProfileEvaluateData(interp, startSec, startUsec, obj, cl, methodName);
5502  }
5503#endif
5504
5505  return result;
5506}
5507
5508static int
5509DoCallProcCheck(ClientData cd, Tcl_Interp *interp,
5510                int objc, Tcl_Obj *CONST objv[],
5511                Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl,
5512                char *methodName, int frameType) {
5513  int rc, push, isTclProc = 0;
5514  ClientData cp = Tcl_Command_objClientData(cmd);
5515
5516  if (cp) {
5517    register Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd);
5518
5519    if (proc == TclObjInterpProc) {
5520      assert((TclIsProc((Command *)cmd)));
5521      isTclProc = 1;
5522    } else if (proc == XOTclObjDispatch) {
5523      assert((TclIsProc((Command *)cmd) == NULL));
5524    } else if (proc == XOTclForwardMethod ||
5525               proc == XOTclObjscopedMethod) {
5526      tclCmdClientData *tcd = (tclCmdClientData *)cp;
5527      tcd->obj = obj;
5528      assert((TclIsProc((Command *)cmd) == NULL));
5529    } else if (cp == XOTCL_NONLEAF_METHOD) {
5530      cp = cd;
5531      assert((TclIsProc((Command *)cmd) == NULL));
5532    }
5533
5534    /* push the xotcl info */
5535    push = 1;
5536    if ((CallStackPush(interp, obj, cl, cmd, objc, objv, frameType)) != TCL_OK) {
5537      return TCL_ERROR;
5538    }
5539
5540  } else {
5541    push = 0;
5542    assert((TclIsProc((Command *)cmd) == NULL));
5543    cp = cd;
5544  }
5545
5546  rc = callProcCheck(cp, interp, objc, objv, cmd, obj, cl,
5547                     methodName, frameType, isTclProc);
5548  if (push) {
5549    CallStackPop(interp);
5550  }
5551
5552  return rc;
5553}
5554
5555
5556XOTCLINLINE static int
5557DoDispatch(ClientData cd, Tcl_Interp *interp, int objc,
5558           Tcl_Obj *CONST objv[], int flags) {
5559  register XOTclObject *obj = (XOTclObject*)cd;
5560  int result = TCL_OK, mixinStackPushed = 0,
5561    filterStackPushed = 0, unknown, objflags,
5562    frameType = XOTCL_CSC_TYPE_PLAIN;
5563#ifdef OBJDELETION_TRACE
5564  Tcl_Obj *method;
5565#endif
5566  char *methodName;
5567  XOTclClass *cl = NULL;
5568  Tcl_Command cmd = NULL;
5569  XOTclRuntimeState *rst = RUNTIME_STATE(interp);
5570  Tcl_Obj *cmdName = obj->cmdName;
5571  XOTclCallStack *cs = &rst->cs;
5572  /* int isdestroy = (objv[1] == XOTclGlobalObjects[XOTE_DESTROY]); */
5573#ifdef AUTOVARS
5574  int isNext;
5575#endif
5576
5577  assert(objc>0);
5578  methodName = ObjStr(objv[1]);
5579
5580#ifdef AUTOVARS
5581  isNext = isNextString(methodName);
5582#endif
5583#ifdef DISPATCH_TRACE
5584  printCall(interp,"DISPATCH", objc, objv);
5585#endif
5586
5587#ifdef OBJDELETION_TRACE
5588  method = objv[1];
5589  if (method == XOTclGlobalObjects[XOTE_CLEANUP] ||
5590      method == XOTclGlobalObjects[XOTE_DESTROY]) {
5591    fprintf(stderr, "%s->%s id=%p destroyCalled=%d\n",
5592            ObjStr(cmdName), methodName, obj,
5593            (obj->flags & XOTCL_DESTROY_CALLED));
5594  }
5595#endif
5596
5597  objflags = obj->flags; /* avoid stalling */
5598  INCR_REF_COUNT(cmdName);
5599
5600  if (!(objflags & XOTCL_FILTER_ORDER_VALID))
5601    FilterComputeDefined(interp, obj);
5602
5603  if (!(objflags & XOTCL_MIXIN_ORDER_VALID))
5604    MixinComputeDefined(interp, obj);
5605
5606#ifdef AUTOVARS
5607  if (!isNext) {
5608#endif
5609    /* Only start new filter chain, if
5610       (a) filters are defined and
5611       (b) the toplevel csc entry is not an filter on self
5612    */
5613
5614    if (((obj->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == XOTCL_FILTER_ORDER_DEFINED_AND_VALID)
5615        && RUNTIME_STATE(interp)->doFilters
5616        && !(flags & XOTCL_CM_NO_FILTERS)
5617        && !cs->guardCount) {
5618      XOTclObject *self = GetSelfObj(interp);
5619      if (obj != self ||
5620          cs->top->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) {
5621
5622        filterStackPushed = FilterStackPush(interp, obj, objv[1]);
5623        cmd = FilterSearchProc(interp, obj, &obj->filterStack->currentCmdPtr,&cl);
5624        if (cmd) {
5625          frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER;
5626          methodName = (char *)Tcl_GetCommandName(interp, cmd);
5627        } else {
5628          FilterStackPop(obj);
5629          filterStackPushed = 0;
5630        }
5631      }
5632    }
5633
5634    /* check if a mixin is to be called.
5635       don't use mixins on next method calls, since normally it is not
5636       intercepted (it is used as a primitive command).
5637       don't use mixins on init calls, since init is invoked on mixins
5638       during mixin registration (in XOTclOMixinMethod)
5639    */
5640    if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) {
5641
5642      mixinStackPushed = MixinStackPush(obj);
5643
5644      if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) {
5645        cmd = MixinSearchProc(interp, obj, methodName, &cl,
5646                              &obj->mixinStack->currentCmdPtr);
5647        if (cmd) {
5648          frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN;
5649        } else { /* the else branch could be deleted */
5650          MixinStackPop(obj);
5651          mixinStackPushed = 0;
5652        }
5653      }
5654    }
5655
5656#ifdef AUTOVARS
5657  }
5658#endif
5659
5660  /* if no filter/mixin is found => do ordinary method lookup */
5661  if (cmd == NULL) {
5662
5663    if (obj->nsPtr) {
5664      cmd = FindMethod(methodName, obj->nsPtr);
5665      /* fprintf(stderr,"lookup for proc in obj %p method %s nsPtr %p => %p\n",
5666         obj, methodName, obj->nsPtr, cmd);*/
5667    }
5668
5669    /*fprintf(stderr,"findMethod for proc '%s' in %p returned %p\n", methodName, obj->nsPtr, cmd);*/
5670
5671    if (cmd == NULL) {
5672      if (obj->cl->order == NULL) obj->cl->order = TopoOrder(obj->cl, Super);
5673      cl = SearchPLMethod(obj->cl->order, methodName, &cmd);
5674
5675      /* cl = SearchCMethod(obj->cl, methodName, &cmd); */
5676    }
5677  }
5678
5679  if (cmd) {
5680    if ((result = DoCallProcCheck(cd, interp, objc-1, objv+1, cmd, obj, cl,
5681                                  methodName, frameType)) == TCL_ERROR) {
5682      result = XOTclErrInProc(interp, cmdName, cl ? cl->object.cmdName : NULL, methodName);
5683    }
5684    unknown = RUNTIME_STATE(interp)->unknown;
5685  } else {
5686    unknown = 1;
5687  }
5688
5689  if (result == TCL_OK) {
5690    /*fprintf(stderr,"after doCallProcCheck unknown == %d\n", unknown);*/
5691    if (unknown) {
5692      if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) {
5693        return XOTclVarErrMsg(interp, ObjStr(objv[0]),
5694                              ": unable to dispatch method '",
5695                              methodName, "'", (char *) NULL);
5696      } else if (objv[1] != XOTclGlobalObjects[XOTE_UNKNOWN]) {
5697        /*
5698         * back off and try unknown;
5699         */
5700        XOTclObject *obj = (XOTclObject*)cd;
5701        ALLOC_ON_STACK(Tcl_Obj*, objc+1, tov);
5702        /*
5703          fprintf(stderr,"calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s\n",
5704          ObjStr(obj->cmdName), ObjStr(objv[1]), flags,  XOTCL_CM_NO_UNKNOWN,
5705          XOTclObjectIsClass(obj), obj, ObjStr(obj->cmdName));
5706        */
5707        tov[0] = obj->cmdName;
5708        tov[1] = XOTclGlobalObjects[XOTE_UNKNOWN];
5709        if (objc>1)
5710          memcpy(tov+2, objv+1, sizeof(Tcl_Obj *)*(objc-1));
5711        /*
5712          fprintf(stderr,"?? %s unknown %s\n", ObjStr(obj->cmdName), ObjStr(tov[2]));
5713        */
5714        result = DoDispatch(cd, interp, objc+1, tov, flags | XOTCL_CM_NO_UNKNOWN);
5715        FREE_ON_STACK(Tcl_Obj *, tov);
5716
5717      } else { /* unknown failed */
5718        return XOTclVarErrMsg(interp, ObjStr(objv[0]),
5719                              ": unable to dispatch method '",
5720                              ObjStr(objv[2]), "'", (char *) NULL);
5721      }
5722
5723    }
5724  }
5725  /* be sure to reset unknown flag */
5726  if (unknown)
5727    RUNTIME_STATE(interp)->unknown = 0;
5728
5729#ifdef DISPATCH_TRACE
5730  printExit(interp,"DISPATCH", objc, objv, result);
5731  fprintf(stderr,"obj=%p isDestroy %d\n",obj, rst->callIsDestroy);
5732  if (!rst->callIsDestroy) {
5733    fprintf(stderr,"obj %p mixinStackPushed %d mixinStack %p\n",
5734            obj, mixinStackPushed, obj->mixinStack);
5735  }
5736#endif
5737
5738
5739  /*if (!rst->callIsDestroy)
5740    fprintf(stderr, "obj freed? %p destroy %p self %p %s %d [%d] reference=%d,%d\n", obj,
5741    cs->top->destroyedCmd, cs->top->self, ObjStr(objv[1]),
5742    rst->callIsDestroy,
5743    cs->top->callType & XOTCL_CSC_CALL_IS_DESTROY,
5744    !rst->callIsDestroy,
5745    isdestroy);*/
5746
5747  if (!rst->callIsDestroy) {
5748    /*!(obj->flags & XOTCL_DESTROY_CALLED)) {*/
5749    if (mixinStackPushed && obj->mixinStack)
5750      MixinStackPop(obj);
5751
5752    if (filterStackPushed && obj->filterStack)
5753      FilterStackPop(obj);
5754  }
5755
5756  DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */
5757  return result;
5758}
5759
5760int
5761XOTclObjDispatch(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
5762  int result;
5763
5764#ifdef STACK_TRACE
5765  XOTclStackDump(interp);
5766#endif
5767
5768#ifdef CALLSTACK_TRACE
5769  XOTclCallStackDump(interp);
5770#endif
5771
5772  if (objc == 1) {
5773    Tcl_Obj *tov[2];
5774    tov[0] = objv[0];
5775    tov[1] = XOTclGlobalObjects[XOTE_DEFAULTMETHOD];
5776    result = DoDispatch(cd, interp, 2, tov, 0);
5777  } else {
5778    /* normal dispatch */
5779    result = DoDispatch(cd, interp, objc, objv, 0);
5780  }
5781
5782  return result;
5783}
5784
5785#ifdef XOTCL_BYTECODE
5786int
5787XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *interp,
5788                        int objc, Tcl_Obj *CONST objv[]) {
5789  int result;
5790#ifdef XOTCLOBJ_TRACE
5791  XOTclObject *obj;
5792#endif
5793  objTrace("BEFORE SELF DISPATCH", obj);
5794  result = XOTclObjDispatch((ClientData)GetSelfObj(interp), interp, objc, objv);
5795  objTrace("AFTER SELF DISPATCH", obj);
5796  return result;
5797}
5798#endif
5799
5800/*
5801 * Non Positional Args
5802 */
5803
5804static void
5805NonposArgsDeleteHashEntry(Tcl_HashEntry *hPtr) {
5806  XOTclNonposArgs *nonposArg = (XOTclNonposArgs*) Tcl_GetHashValue(hPtr);
5807  if (nonposArg) {
5808    DECR_REF_COUNT(nonposArg->nonposArgs);
5809    DECR_REF_COUNT(nonposArg->ordinaryArgs);
5810    MEM_COUNT_FREE("nonposArg", nonposArg);
5811    ckfree((char *) nonposArg);
5812    Tcl_DeleteHashEntry(hPtr);
5813  }
5814}
5815
5816static Tcl_HashTable*
5817NonposArgsCreateTable() {
5818  Tcl_HashTable *nonposArgsTable =
5819    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
5820  MEM_COUNT_ALLOC("Tcl_HashTable", nonposArgsTable);
5821  Tcl_InitHashTable(nonposArgsTable, TCL_STRING_KEYS);
5822  MEM_COUNT_ALLOC("Tcl_InitHashTable", nonposArgsTable);
5823  return nonposArgsTable;
5824}
5825
5826static void
5827NonposArgsFreeTable(Tcl_HashTable *nonposArgsTable) {
5828  Tcl_HashSearch hSrch;
5829  Tcl_HashEntry *hPtr = nonposArgsTable ?
5830    Tcl_FirstHashEntry(nonposArgsTable, &hSrch) : 0;
5831  for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
5832    NonposArgsDeleteHashEntry(hPtr);
5833  }
5834}
5835
5836static XOTclNonposArgs*
5837NonposArgsGet(Tcl_HashTable *nonposArgsTable, char * methodName) {
5838  Tcl_HashEntry *hPtr;
5839  if (nonposArgsTable &&
5840      ((hPtr = XOTcl_FindHashEntry(nonposArgsTable, methodName)))) {
5841    return (XOTclNonposArgs*) Tcl_GetHashValue(hPtr);
5842  }
5843  return NULL;
5844}
5845
5846static Tcl_Obj*
5847NonposArgsFormat(Tcl_Interp *interp, Tcl_Obj *nonposArgsData) {
5848  int r1, npalistc, npac, checkc, i, j, first;
5849  Tcl_Obj **npalistv, **npav, **checkv,
5850    *list = Tcl_NewListObj(0, NULL), *innerlist,
5851    *nameStringObj;
5852
5853  /*fprintf(stderr, "nonposargsformat '%s'\n", ObjStr(nonposArgsData));*/
5854
5855  r1 = Tcl_ListObjGetElements(interp, nonposArgsData, &npalistc, &npalistv);
5856  if (r1 == TCL_OK) {
5857    for (i=0; i < npalistc; i++) {
5858      r1 = Tcl_ListObjGetElements(interp, npalistv[i], &npac, &npav);
5859      if (r1 == TCL_OK) {
5860        nameStringObj = Tcl_NewStringObj("-", 1);
5861        Tcl_AppendStringsToObj(nameStringObj, ObjStr(npav[0]),
5862                               (char *) NULL);
5863        if (npac > 1 && *(ObjStr(npav[1])) != '\0') {
5864          first = 1;
5865          r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv);
5866          if (r1 == TCL_OK) {
5867            for (j=0; j < checkc; j++) {
5868              if (first) {
5869                Tcl_AppendToObj(nameStringObj,":", 1);
5870                first = 0;
5871              } else {
5872                Tcl_AppendToObj(nameStringObj,",", 1);
5873              }
5874              Tcl_AppendToObj(nameStringObj, ObjStr(checkv[j]), -1);
5875            }
5876          }
5877        }
5878        /* fprintf(stderr, "nonposargsformat namestring '%s'\n",
5879           ObjStr(nameStringObj));*/
5880
5881#if 1
5882        innerlist = Tcl_NewListObj(0, NULL);
5883        Tcl_ListObjAppendElement(interp, innerlist, nameStringObj);
5884        if (npac > 2) {
5885          Tcl_ListObjAppendElement(interp, innerlist, npav[2]);
5886        }
5887#else
5888        {
5889          Tcl_DString ds, *dsPtr = &ds;
5890          DSTRING_INIT(dsPtr);
5891          Tcl_DStringAppend(dsPtr, ObjStr(nameStringObj), -1);
5892          if (npac > 2) {
5893            Tcl_DStringAppendElement(dsPtr, ObjStr(npav[2]));
5894          }
5895          innerlist = Tcl_NewStringObj(Tcl_DStringValue(dsPtr),
5896                                       Tcl_DStringLength(dsPtr));
5897          DSTRING_FREE(dsPtr);
5898        }
5899#endif
5900        Tcl_ListObjAppendElement(interp, list, innerlist);
5901      }
5902    }
5903  }
5904  return list;
5905}
5906
5907/*
5908 *  Proc-Creation
5909 */
5910
5911static Tcl_Obj *addPrefixToBody(Tcl_Obj *body, int nonposArgs) {
5912  Tcl_Obj *resultBody;
5913  resultBody = Tcl_NewStringObj("", 0);
5914  INCR_REF_COUNT(resultBody);
5915#if defined(PRE85) || defined(NRE)
5916  Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", (char *) NULL);
5917#endif
5918  if (nonposArgs) {
5919    Tcl_AppendStringsToObj(resultBody,
5920                           "::xotcl::interpretNonpositionalArgs $args\n",
5921                           (char *) NULL);
5922  }
5923  Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL);
5924  return resultBody;
5925}
5926
5927static int
5928parseNonposArgs(Tcl_Interp *interp,
5929                char *procName, Tcl_Obj *npArgs, Tcl_Obj *ordinaryArgs,
5930                Tcl_HashTable **nonposArgsTable,
5931                int *haveNonposArgs) {
5932  int rc, nonposArgsDefc, npac;
5933  Tcl_Obj **nonposArgsDefv;
5934
5935  rc = Tcl_ListObjGetElements(interp, npArgs, &nonposArgsDefc, &nonposArgsDefv);
5936  if (rc != TCL_OK) {
5937    return XOTclVarErrMsg(interp, "cannot break down non-positional args: ",
5938                          ObjStr(npArgs), (char *) NULL);
5939  }
5940  if (nonposArgsDefc > 0) {
5941    int start, end, length, i, j, nw = 0;
5942    char *arg;
5943    Tcl_Obj *npaObj, **npav, *nonposArgsObj = Tcl_NewListObj(0, NULL);
5944    Tcl_HashEntry *hPtr;
5945
5946    INCR_REF_COUNT(nonposArgsObj);
5947    for (i=0; i < nonposArgsDefc; i++) {
5948      rc = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav);
5949      if (rc == TCL_ERROR || npac < 1 || npac > 2) {
5950        DECR_REF_COUNT(nonposArgsObj);
5951        return XOTclVarErrMsg(interp, "wrong # of elements in non-positional args ",
5952                              "(should be 1 or 2 list elements): ",
5953                              ObjStr(npArgs), (char *) NULL);
5954      }
5955      npaObj = Tcl_NewListObj(0, NULL);
5956      arg = ObjStr(npav[0]);
5957      if (arg[0] != '-') {
5958        DECR_REF_COUNT(npaObj);
5959        DECR_REF_COUNT(nonposArgsObj);
5960        return XOTclVarErrMsg(interp, "non-positional args does not start with '-': ",
5961                              arg, " in: ", ObjStr(npArgs), (char *) NULL);
5962      }
5963
5964      length = strlen(arg);
5965      for (j=0; j<length; j++) {
5966        if (arg[j] == ':') break;
5967      }
5968      if (arg[j] == ':') {
5969        int l;
5970        Tcl_Obj *list = Tcl_NewListObj(0, NULL);
5971
5972        Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj(arg+1, j-1));
5973        start = j+1;
5974        while(start<length && isspace((int)arg[start])) start++;
5975        for (l=start; l<length;l++) {
5976          if (arg[l] == ',') {
5977            for (end = l;end>0 && isspace((int)arg[end-1]); end--);
5978            Tcl_ListObjAppendElement(interp, list,
5979                                     Tcl_NewStringObj(arg+start, end-start));
5980            l++;
5981            start = l;
5982            while (start<length && isspace((int)arg[start])) start++;
5983          }
5984        }
5985        /* append last arg */
5986        for (end = l;end>0 && isspace((int)arg[end-1]); end--);
5987        Tcl_ListObjAppendElement(interp, list,
5988                                 Tcl_NewStringObj(arg+start, end-start));
5989
5990        /* append the whole thing to the list */
5991        Tcl_ListObjAppendElement(interp, npaObj, list);
5992      } else {
5993        Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj(arg+1, length));
5994        Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj("", 0));
5995      }
5996      if (npac == 2) {
5997        Tcl_ListObjAppendElement(interp, npaObj, npav[1]);
5998      }
5999      Tcl_ListObjAppendElement(interp, nonposArgsObj, npaObj);
6000      *haveNonposArgs = 1;
6001    }
6002
6003    if (*haveNonposArgs) {
6004      XOTclNonposArgs *nonposArg;
6005
6006      if (*nonposArgsTable == NULL) {
6007        *nonposArgsTable = NonposArgsCreateTable();
6008      }
6009
6010      hPtr = Tcl_CreateHashEntry(*nonposArgsTable, procName, &nw);
6011      assert(nw);
6012
6013      MEM_COUNT_ALLOC("nonposArg", nonposArg);
6014      nonposArg = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs));
6015      nonposArg->nonposArgs = nonposArgsObj;
6016      nonposArg->ordinaryArgs = ordinaryArgs;
6017      INCR_REF_COUNT(ordinaryArgs);
6018      Tcl_SetHashValue(hPtr, (ClientData)nonposArg);
6019    } else {
6020      /* for strange reasons, we did not find nonpos-args, although we
6021         have definitions */
6022      DECR_REF_COUNT(nonposArgsObj);
6023    }
6024  }
6025  return TCL_OK;
6026}
6027
6028
6029
6030static int
6031MakeProc(Tcl_Namespace *ns, XOTclAssertionStore *aStore,
6032         Tcl_HashTable **nonposArgsTable,
6033         Tcl_Interp *interp, int objc, Tcl_Obj *objv[], XOTclObject *obj) {
6034  int result, incr, haveNonposArgs = 0;
6035  TclCallFrame frame, *framePtr = &frame;
6036  Tcl_Obj *ov[4];
6037  Tcl_HashEntry *hPtr = NULL;
6038  char *procName = ObjStr(objv[1]);
6039
6040  if (*nonposArgsTable && (hPtr = XOTcl_FindHashEntry(*nonposArgsTable, procName))) {
6041    NonposArgsDeleteHashEntry(hPtr);
6042  }
6043
6044  ov[0] = objv[0];
6045  ov[1] = objv[1];
6046
6047  if (objc == 5 || objc == 7) {
6048    if ((result = parseNonposArgs(interp, procName, objv[2], objv[3],
6049                                  nonposArgsTable, &haveNonposArgs)) != TCL_OK)
6050      return result;
6051
6052    if (haveNonposArgs) {
6053      ov[2] = XOTclGlobalObjects[XOTE_ARGS];
6054      ov[3] = addPrefixToBody(objv[4], 1);
6055    } else { /* no nonpos arguments */
6056      ov[2] = objv[3];
6057      ov[3] = addPrefixToBody(objv[4], 0);
6058    }
6059  } else {
6060#if !defined(XOTCL_DISJOINT_ARGLISTS)
6061    int argsc, i;
6062    Tcl_Obj **argsv;
6063
6064    /* see, if we have nonposArgs in the ordinary argument list */
6065    result = Tcl_ListObjGetElements(interp, objv[2], &argsc, &argsv);
6066    if (result != TCL_OK) {
6067      return XOTclVarErrMsg(interp, "cannot break args into list: ",
6068                            ObjStr(objv[2]), (char *) NULL);
6069    }
6070    for (i=0; i<argsc; i++) {
6071      char *arg;
6072      int npac, rc;
6073      Tcl_Obj **npav;
6074      /* arg = ObjStr(argsv[i]);
6075         fprintf(stderr, "*** argparse0 arg='%s'\n", arg);*/
6076
6077      rc = Tcl_ListObjGetElements(interp, argsv[i], &npac, &npav);
6078      if (rc == TCL_OK && npac > 0) {
6079        arg = ObjStr(npav[0]);
6080        /* fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n", arg, rc);*/
6081        if (*arg == '-') {
6082          haveNonposArgs = 1;
6083          continue;
6084        }
6085      }
6086      break;
6087    }
6088    if (haveNonposArgs) {
6089      int nrOrdinaryArgs = argsc - i;
6090      Tcl_Obj *ordinaryArgs = Tcl_NewListObj(nrOrdinaryArgs, &argsv[i]);
6091      Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]);
6092      INCR_REF_COUNT(ordinaryArgs);
6093      INCR_REF_COUNT(nonposArgs);
6094      result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs,
6095			       nonposArgsTable, &haveNonposArgs);
6096      DECR_REF_COUNT(ordinaryArgs);
6097      DECR_REF_COUNT(nonposArgs);
6098      if (result != TCL_OK)
6099        return result;
6100    }
6101#endif
6102    if (haveNonposArgs) {
6103      ov[2] = XOTclGlobalObjects[XOTE_ARGS];
6104      ov[3] = addPrefixToBody(objv[3], 1);
6105    } else { /* no nonpos arguments */
6106      ov[2] = objv[2];
6107      ov[3] = addPrefixToBody(objv[3], 0);
6108    }
6109
6110  }
6111
6112#ifdef AUTOVARS
6113  { char *p, *body;
6114    body = ObjStr(ov[3]);
6115    if ((p = strstr(body, "self")) && p != body && *(p-1) != '[')
6116      Tcl_AppendStringsToObj(ov[3], "::set self [self]\n", (char *) NULL);
6117    if (strstr(body, "proc"))
6118      Tcl_AppendStringsToObj(ov[3], "::set proc [self proc]\n", (char *) NULL);
6119    if (strstr(body, "class"))
6120      Tcl_AppendStringsToObj(ov[3], "::set class [self class]\n", (char *) NULL);
6121  }
6122#endif
6123
6124  Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, ns, 0);
6125
6126  result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK;
6127#if defined(NAMESPACEINSTPROCS)
6128  {
6129    Proc *procPtr = TclFindProc((Interp *)interp, procName);
6130    /*fprintf(stderr,"proc=%p cmd=%p ns='%s' objns=%s\n", procPtr, procPtr->cmdPtr,
6131      procPtr->cmdPtr->nsPtr->fullName, cmd->nsPtr->fullName);*/
6132    /*** patch the command ****/
6133    if (procPtr) {
6134      /* procPtr->cmdPtr = (Command *)obj->id; OLD*/
6135      procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr;
6136    }
6137  }
6138#endif
6139
6140  Tcl_PopCallFrame(interp);
6141
6142  if (objc == 6 || objc == 7) {
6143    incr = (objc == 6) ? 0:1;
6144    AssertionAddProc(interp, ObjStr(objv[1]), aStore, objv[4+incr], objv[5+incr]);
6145  }
6146
6147  DECR_REF_COUNT(ov[3]);
6148
6149  return result;
6150}
6151
6152/*
6153 * List-Functions for Info
6154 */
6155static int
6156ListInfo(Tcl_Interp *interp, int isclass) {
6157  Tcl_ResetResult(interp);
6158  Tcl_AppendElement(interp, "vars"); Tcl_AppendElement(interp, "body");
6159  Tcl_AppendElement(interp, "default"); Tcl_AppendElement(interp, "args");
6160  Tcl_AppendElement(interp, "procs"); Tcl_AppendElement(interp, "commands");
6161  Tcl_AppendElement(interp, "class"); Tcl_AppendElement(interp, "children");
6162  Tcl_AppendElement(interp, "filter"); Tcl_AppendElement(interp, "filterguard");
6163  Tcl_AppendElement(interp, "forward");
6164  Tcl_AppendElement(interp, "info");
6165  Tcl_AppendElement(interp, "invar"); Tcl_AppendElement(interp, "mixin");
6166  Tcl_AppendElement(interp, "methods");
6167  Tcl_AppendElement(interp, "parent");
6168  Tcl_AppendElement(interp, "pre"); Tcl_AppendElement(interp, "post");
6169  Tcl_AppendElement(interp, "precedence");
6170  if (isclass) {
6171    Tcl_AppendElement(interp, "superclass"); Tcl_AppendElement(interp, "subclass");
6172    Tcl_AppendElement(interp, "heritage"); Tcl_AppendElement(interp, "instances");
6173    Tcl_AppendElement(interp, "instcommands"); Tcl_AppendElement(interp, "instprocs");
6174    Tcl_AppendElement(interp, "instdefault"); Tcl_AppendElement(interp, "instbody");
6175    Tcl_AppendElement(interp, "instmixin");
6176    Tcl_AppendElement(interp, "instforward");
6177    Tcl_AppendElement(interp, "instmixinof"); Tcl_AppendElement(interp, "mixinof");
6178    Tcl_AppendElement(interp, "classchildren"); Tcl_AppendElement(interp, "classparent");
6179    Tcl_AppendElement(interp, "instfilter"); Tcl_AppendElement(interp, "instfilterguard");
6180    Tcl_AppendElement(interp, "instinvar");
6181    Tcl_AppendElement(interp, "instpre"); Tcl_AppendElement(interp, "instpost");
6182    Tcl_AppendElement(interp, "parameter");
6183  }
6184  return TCL_OK;
6185}
6186
6187XOTCLINLINE static int
6188noMetaChars(char *pattern) {
6189  register char c, *p = pattern;
6190  assert(pattern);
6191  for (c=*p; c; c = *++p) {
6192    if (c == '*' || c == '[') {
6193      return 0;
6194    }
6195  }
6196  return 1;
6197}
6198
6199static int
6200getMatchObject(Tcl_Interp *interp, char **pattern, XOTclObject **matchObject, Tcl_DString *dsPtr) {
6201  if (*pattern && noMetaChars(*pattern)) {
6202    *matchObject = XOTclpGetObject(interp, *pattern);
6203    if (*matchObject) {
6204      *pattern = ObjStr((*matchObject)->cmdName);
6205      return 1;
6206    } else {
6207      /* object does not exist */
6208      Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
6209      return -1;
6210    }
6211  } else {
6212    *matchObject = NULL;
6213    if (*pattern) {
6214      /*
6215       * we have a pattern and meta characters, we might have
6216       * to prefix it to ovoid abvious errors: since all object
6217       * names are prefixed with ::, we add this prefix automatically
6218       * to the match pattern, if it does not exist
6219       */
6220      if (**pattern && **pattern != ':' && **pattern+1 && **pattern+1 != ':') {
6221        /*fprintf(stderr, "pattern is not prefixed '%s'\n",*pattern);*/
6222        Tcl_DStringAppend(dsPtr, "::", -1);
6223        Tcl_DStringAppend(dsPtr, *pattern, -1);
6224        *pattern = Tcl_DStringValue(dsPtr);
6225        /*fprintf(stderr, "prefixed pattern = '%s'\n",*pattern);*/
6226      }
6227    }
6228  }
6229  return 0;
6230}
6231
6232static int
6233ListKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) {
6234  Tcl_HashEntry *hPtr;
6235  char *key;
6236
6237  if (pattern && noMetaChars(pattern)) {
6238    hPtr = table ? XOTcl_FindHashEntry(table, pattern) : 0;
6239    if (hPtr) {
6240      key = Tcl_GetHashKey(table, hPtr);
6241      Tcl_SetResult(interp, key, TCL_VOLATILE);
6242    } else {
6243      Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
6244    }
6245  } else {
6246    Tcl_Obj *list = Tcl_NewListObj(0, NULL);
6247    Tcl_HashSearch hSrch;
6248    hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
6249    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
6250      key = Tcl_GetHashKey(table, hPtr);
6251      if (!pattern || Tcl_StringMatch(key, pattern)) {
6252        Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(key,-1));
6253      }
6254    }
6255    Tcl_SetObjResult(interp, list);
6256  }
6257  return TCL_OK;
6258}
6259
6260#if !defined(PRE85) || FORWARD_COMPATIBLE
6261static int
6262ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, char *pattern) {
6263  Tcl_HashEntry *hPtr;
6264
6265  if (pattern && noMetaChars(pattern)) {
6266    Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1);
6267    INCR_REF_COUNT(patternObj);
6268
6269    hPtr = tablePtr ? XOTcl_FindHashEntry(tablePtr, (char *)patternObj) : 0;
6270    if (hPtr) {
6271      Var  *val = VarHashGetValue(hPtr);
6272      Tcl_SetObjResult(interp, VarHashGetKey(val));
6273    } else {
6274      Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
6275    }
6276    DECR_REF_COUNT(patternObj);
6277  } else {
6278    Tcl_Obj *list = Tcl_NewListObj(0, NULL);
6279    Tcl_HashSearch hSrch;
6280    hPtr = tablePtr ? Tcl_FirstHashEntry(tablePtr, &hSrch) : 0;
6281    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
6282      Var  *val = VarHashGetValue(hPtr);
6283      Tcl_Obj *key  = VarHashGetKey(val);
6284      if (!pattern || Tcl_StringMatch(ObjStr(key), pattern)) {
6285        Tcl_ListObjAppendElement(interp, list, key);
6286      }
6287    }
6288    Tcl_SetObjResult(interp, list);
6289  }
6290  return TCL_OK;
6291}
6292#endif
6293
6294
6295static int
6296ListVars(Tcl_Interp *interp, XOTclObject *obj, char *pattern) {
6297  Tcl_Obj *varlist, *okList, *element;
6298  int i, length;
6299  TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable;
6300
6301#if defined(PRE85)
6302# if FORWARD_COMPATIBLE
6303  if (forwardCompatibleMode) {
6304    ListVarKeys(interp, VarHashTable(varTable), pattern);
6305  } else {
6306    ListKeys(interp, varTable, pattern);
6307  }
6308# else
6309  ListKeys(interp, varTable, pattern);
6310# endif
6311#else
6312  ListVarKeys(interp, VarHashTable(varTable), pattern);
6313#endif
6314  varlist = Tcl_GetObjResult(interp);
6315
6316  Tcl_ListObjLength(interp, varlist, &length);
6317  okList = Tcl_NewListObj(0, NULL);
6318  for (i=0; i<length; i++) {
6319    Tcl_ListObjIndex(interp, varlist, i, &element);
6320    if (varExists(interp, obj, ObjStr(element), NULL, 0, 1)) {
6321      Tcl_ListObjAppendElement(interp, okList, element);
6322    } else {
6323      /*fprintf(stderr,"must ignore '%s' %d\n", ObjStr(element), i);*/
6324      /*Tcl_ListObjReplace(interp, varlist, i, 1, 0, NULL);*/
6325    }
6326  }
6327  Tcl_SetObjResult(interp, okList);
6328  return TCL_OK;
6329}
6330
6331/* static int */
6332/* ListObjPtrHashTable(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { */
6333/*   Tcl_HashEntry *hPtr; */
6334/*   if (pattern && noMetaChars(pattern)) { */
6335/*     XOTclObject *childobj = XOTclpGetObject(interp, pattern); */
6336/*     hPtr = XOTcl_FindHashEntry(table, (char *)childobj); */
6337/*     if (hPtr) { */
6338/*       Tcl_SetObjResult(interp, childobj->cmdName); */
6339/*     } else { */
6340/*       Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); */
6341/*     } */
6342/*   } else { */
6343/*     Tcl_Obj *list = Tcl_NewListObj(0, NULL); */
6344/*     Tcl_HashSearch hSrch; */
6345/*     hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; */
6346/*     for (;  hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { */
6347/*       XOTclObject *obj = (XOTclObject*)Tcl_GetHashKey(table, hPtr); */
6348/*       if (!pattern || Tcl_StringMatch(ObjStr(obj->cmdName), pattern)) { */
6349/*         Tcl_ListObjAppendElement(interp, list, obj->cmdName); */
6350/*       } */
6351/*     } */
6352/*     Tcl_SetObjResult(interp, list); */
6353/*   } */
6354/*   return TCL_OK; */
6355/* } */
6356
6357static int
6358ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern,
6359               int noProcs, int noCmds, int noDups, int onlyForwarder, int onlySetter) {
6360  Tcl_HashSearch hSrch;
6361  Tcl_HashEntry *hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
6362  for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
6363    char *key = Tcl_GetHashKey(table, hPtr);
6364    Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
6365    Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd);
6366
6367    if (pattern && !Tcl_StringMatch(key, pattern)) continue;
6368    if (noCmds  && proc != RUNTIME_STATE(interp)->objInterpProc) continue;
6369    if (noProcs && proc == RUNTIME_STATE(interp)->objInterpProc) continue;
6370    if (onlyForwarder && proc != XOTclForwardMethod) continue;
6371    if (onlySetter && proc != XOTclSetterMethod) continue;
6372    /* XOTclObjscopedMethod ??? */
6373    if (noDups) {
6374      int listc, i;
6375      Tcl_Obj **listv;
6376      int result = Tcl_ListObjGetElements(interp, Tcl_GetObjResult(interp), &listc, &listv);
6377      size_t keylen = strlen(key);
6378      if (result == TCL_OK) {
6379        int found = 0;
6380        for (i=0; i<listc; i++) {
6381          int length;
6382          char *bytes;
6383          bytes = Tcl_GetStringFromObj(listv[i], &length);
6384          if (keylen == length && (memcmp(bytes, key, (size_t)length) == 0)) {
6385            found = 1;
6386            break;
6387          }
6388        }
6389        if (found) continue;
6390      }
6391    }
6392    Tcl_AppendElement(interp, key);
6393  }
6394  return TCL_OK;
6395}
6396
6397static int
6398forwardList(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern,
6399            int definition) {
6400  int rc;
6401  if (definition) {
6402    Tcl_HashEntry *hPtr = table && pattern ? XOTcl_FindHashEntry(table, pattern) : 0;
6403    if (hPtr) {
6404      Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
6405      ClientData cd = cmd? Tcl_Command_objClientData(cmd) : NULL;
6406      forwardCmdClientData *tcd = (forwardCmdClientData *)cd;
6407      if (tcd) {
6408        Tcl_Obj *list = Tcl_NewListObj(0, NULL);
6409        if (tcd->prefix) {
6410          Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-methodprefix",-1));
6411          Tcl_ListObjAppendElement(interp, list, tcd->prefix);
6412        }
6413        if (tcd->subcommands) {
6414          Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-default",-1));
6415          Tcl_ListObjAppendElement(interp, list, tcd->subcommands);
6416        }
6417        if (tcd->objscope) {
6418          Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-objscope",-1));
6419        }
6420        Tcl_ListObjAppendElement(interp, list, tcd->cmdName);
6421        if (tcd->args) {
6422          Tcl_Obj **args;
6423          int nrArgs, i;
6424          Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args);
6425          for (i=0; i<nrArgs; i++) {
6426            Tcl_ListObjAppendElement(interp, list, args[i]);
6427          }
6428        }
6429        Tcl_SetObjResult(interp, list);
6430      } else {
6431        /* ERROR HANDLING ****GN**** */
6432      }
6433    } else {
6434      /* ERROR HANDLING ****GN**** */
6435    }
6436    rc = TCL_OK;
6437  } else {
6438    rc = ListMethodKeys(interp, table, pattern, 1, 0, 0, 1, 0);
6439  }
6440  return rc;
6441}
6442
6443static int
6444ListMethods(Tcl_Interp *interp, XOTclObject *obj, char *pattern,
6445            int noProcs, int noCmds, int noMixins, int inContext) {
6446  XOTclClasses *pl;
6447  if (obj->nsPtr) {
6448    Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr);
6449    ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, 0, 0, 0);
6450  }
6451
6452  if (!noMixins) {
6453    if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
6454      MixinComputeDefined(interp, obj);
6455    if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) {
6456      XOTclCmdList *ml;
6457      XOTclClass *mixin;
6458      for (ml = obj->mixinOrder; ml; ml = ml->next) {
6459        int guardOk = TCL_OK;
6460        mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr);
6461        if (inContext) {
6462          XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
6463          if (!cs->guardCount) {
6464            guardOk = GuardCall(obj, 0, 0, interp, ml->clientData, 1);
6465          }
6466        }
6467        if (mixin && guardOk == TCL_OK) {
6468          Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr);
6469          ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, 1, 0, 0);
6470        }
6471      }
6472    }
6473  }
6474
6475  /* append per-class filters */
6476  for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) {
6477    Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr);
6478    ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, 1, 0, 0);
6479  }
6480  return TCL_OK;
6481}
6482
6483static int
6484ListClass(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) {
6485  Tcl_SetObjResult(interp, obj->cl->object.cmdName);
6486  return TCL_OK;
6487}
6488
6489static int
6490ListHeritage(Tcl_Interp *interp, XOTclClass *cl, char *pattern) {
6491  XOTclClasses *pl = ComputeOrder(cl, cl->order, Super);
6492  Tcl_ResetResult(interp);
6493  if (pl) pl=pl->next;
6494  for (; pl; pl = pl->next) {
6495    AppendMatchingElement(interp, pl->cl->object.cmdName, pattern);
6496  }
6497  return TCL_OK;
6498}
6499
6500static int
6501ListPrecedence(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int intrinsicOnly) {
6502  XOTclClasses *pl;
6503  Tcl_ResetResult(interp);
6504
6505  if (!intrinsicOnly) {
6506    if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
6507      MixinComputeDefined(interp, obj);
6508
6509    if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) {
6510      XOTclCmdList *ml = obj->mixinOrder;
6511      for (; ml; ml = ml->next) {
6512        XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr);
6513        AppendMatchingElement(interp, mixin->object.cmdName, pattern);
6514      }
6515    }
6516  }
6517
6518  for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) {
6519    AppendMatchingElement(interp, pl->cl->object.cmdName, pattern);
6520  }
6521  return TCL_OK;
6522}
6523
6524
6525static Proc*
6526FindProc(Tcl_Interp *interp, Tcl_HashTable *table, char *name) {
6527  Tcl_HashEntry *hPtr = table ? XOTcl_FindHashEntry(table, name) : 0;
6528  if (hPtr) {
6529    Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
6530    Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd);
6531    if (proc == RUNTIME_STATE(interp)->objInterpProc)
6532      return (Proc*) Tcl_Command_objClientData(cmd);
6533#if USE_INTERP_PROC
6534    else if ((Tcl_CmdProc*)proc == RUNTIME_STATE(interp)->interpProc)
6535      return (Proc*) Tcl_Command_clientData(cmd);
6536#endif
6537  }
6538  return 0;
6539}
6540
6541static int
6542ListProcArgs(Tcl_Interp *interp, Tcl_HashTable *table, char *name) {
6543  Proc *proc = FindProc(interp, table, name);
6544  if (proc) {
6545    CompiledLocal *args = proc->firstLocalPtr;
6546    Tcl_ResetResult(interp);
6547    for ( ; args; args = args->nextPtr) {
6548      if (TclIsCompiledLocalArgument(args))
6549	      Tcl_AppendElement(interp, args->name);
6550
6551    }
6552    return TCL_OK;
6553  }
6554  return XOTclErrBadVal(interp, "info args", "a tcl method name", name);
6555}
6556
6557static void
6558AppendOrdinaryArgsFromNonposArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs,
6559				 int varsOnly,
6560				 Tcl_Obj *argList) {
6561  int i, rc, ordinaryArgsDefc, defaultValueObjc;
6562  Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg;
6563  rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs,
6564                              &ordinaryArgsDefc, &ordinaryArgsDefv);
6565  for (i=0; i < ordinaryArgsDefc; i++) {
6566    ordinaryArg = ordinaryArgsDefv[i];
6567    rc = Tcl_ListObjGetElements(interp, ordinaryArg,
6568                                &defaultValueObjc, &defaultValueObjv);
6569    if (rc == TCL_OK) {
6570      if (varsOnly && defaultValueObjc == 2) {
6571	Tcl_ListObjAppendElement(interp, argList, defaultValueObjv[0]);
6572      } else {
6573	Tcl_ListObjAppendElement(interp, argList, ordinaryArg);
6574      }
6575    }
6576  }
6577}
6578
6579
6580static int
6581ListArgsFromOrdinaryArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) {
6582  Tcl_Obj *argList = argList = Tcl_NewListObj(0, NULL);
6583  AppendOrdinaryArgsFromNonposArgs(interp, nonposArgs, 1, argList);
6584  Tcl_SetObjResult(interp, argList);
6585  return TCL_OK;
6586}
6587
6588static int
6589GetProcDefault(Tcl_Interp *interp, Tcl_HashTable *table,
6590               char *name, char *arg, Tcl_Obj **resultObj) {
6591  Proc *proc = FindProc(interp, table, name);
6592  *resultObj = NULL;
6593  if (proc) {
6594    CompiledLocal *ap;
6595    for (ap = proc->firstLocalPtr; ap; ap = ap->nextPtr) {
6596      if (!TclIsCompiledLocalArgument(ap)) continue;
6597      if (strcmp(arg, ap->name) != 0) continue;
6598
6599      if (ap->defValuePtr) {
6600        *resultObj = ap->defValuePtr;
6601        return TCL_OK;
6602      }
6603      return TCL_OK;
6604    }
6605  }
6606  return TCL_ERROR;
6607}
6608
6609static int
6610SetProcDefault(Tcl_Interp *interp, Tcl_Obj *var, Tcl_Obj *defVal) {
6611  int result = TCL_OK;
6612  callFrameContext ctx = {0};
6613  CallStackUseActiveFrames(interp,&ctx);
6614
6615  if (defVal) {
6616    if (Tcl_ObjSetVar2(interp, var, NULL, defVal, 0)) {
6617      Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
6618    } else {
6619      result = TCL_ERROR;
6620    }
6621  } else {
6622    if (Tcl_ObjSetVar2(interp, var, NULL,
6623                       XOTclGlobalObjects[XOTE_EMPTY], 0)) {
6624      Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
6625    } else {
6626      result = TCL_ERROR;
6627    }
6628  }
6629  CallStackRestoreSavedFrames(interp, &ctx);
6630
6631  if (result == TCL_ERROR) {
6632    XOTclVarErrMsg(interp, "couldn't store default value in variable '",
6633                   var, "'", (char *) NULL);
6634  }
6635  return result;
6636}
6637
6638static int
6639ListProcDefault(Tcl_Interp *interp, Tcl_HashTable *table,
6640                char *name, char *arg, Tcl_Obj *var) {
6641  Tcl_Obj *defVal;
6642  int result;
6643  if (GetProcDefault(interp, table, name, arg, &defVal) == TCL_OK) {
6644    result = SetProcDefault(interp, var, defVal);
6645  } else {
6646    XOTclVarErrMsg(interp, "method '", name,
6647                   "' doesn't exist or doesn't have an argument '",
6648                   arg, "'", (char *) NULL);
6649    result = TCL_ERROR;
6650  }
6651  return result;
6652}
6653
6654static int
6655ListDefaultFromOrdinaryArgs(Tcl_Interp *interp, char *procName,
6656                            XOTclNonposArgs *nonposArgs, char *arg, Tcl_Obj *var) {
6657  int i, rc, ordinaryArgsDefc, defaultValueObjc;
6658  Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg;
6659
6660  rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs,
6661                              &ordinaryArgsDefc, &ordinaryArgsDefv);
6662  if (rc != TCL_OK)
6663    return TCL_ERROR;
6664
6665  for (i=0; i < ordinaryArgsDefc; i++) {
6666    ordinaryArg = ordinaryArgsDefv[i];
6667    rc = Tcl_ListObjGetElements(interp, ordinaryArg,
6668                                &defaultValueObjc, &defaultValueObjv);
6669    /*fprintf(stderr, "arg='%s', *arg==0 %d, defaultValueObjc=%d\n", arg, *arg==0, defaultValueObjc);*/
6670    if (rc == TCL_OK) {
6671      if (defaultValueObjc > 0 && !strcmp(arg, ObjStr(defaultValueObjv[0]))) {
6672	return SetProcDefault(interp, var, defaultValueObjc == 2 ? defaultValueObjv[1] : NULL);
6673      } else if (defaultValueObjc == 0 && *arg == 0) {
6674	return SetProcDefault(interp, var, NULL);
6675      }
6676    }
6677  }
6678  XOTclVarErrMsg(interp, "method '", procName, "' doesn't have an argument '",
6679                 arg, "'", (char *) NULL);
6680  return TCL_ERROR;
6681}
6682
6683static char *
6684StripBodyPrefix(char *body) {
6685#if defined(PRE85) || defined(NRE)
6686  if (strncmp(body, "::xotcl::initProcNS\n", 20) == 0)
6687    body+=20;
6688#endif
6689  if (strncmp(body, "::xotcl::interpretNonpositionalArgs $args\n", 42) == 0)
6690    body+=42;
6691  /*fprintf(stderr, "--- returing body ***%s***\n", body);*/
6692  return body;
6693}
6694
6695static int
6696ListProcBody(Tcl_Interp *interp, Tcl_HashTable *table, char *name) {
6697  Proc *proc = FindProc(interp, table, name);
6698  if (proc) {
6699    char *body = ObjStr(proc->bodyPtr);
6700    Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1));
6701    return TCL_OK;
6702  }
6703  return XOTclErrBadVal(interp, "info body", "a tcl method name", name);
6704}
6705
6706static int
6707ListChildren(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int classesOnly) {
6708  XOTclObject *childobj;
6709  Tcl_HashTable *cmdTable;
6710  XOTcl_FrameDecls;
6711
6712  if (!obj->nsPtr) return TCL_OK;
6713
6714  cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr);
6715  if (pattern && noMetaChars(pattern)) {
6716    XOTcl_PushFrame(interp, obj);
6717    if ((childobj = XOTclpGetObject(interp, pattern)) &&
6718        (!classesOnly || XOTclObjectIsClass(childobj)) &&
6719        (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr)  /* true children */
6720        ) {
6721      Tcl_SetObjResult(interp, childobj->cmdName);
6722    } else {
6723      Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
6724    }
6725    XOTcl_PopFrame(interp, obj);
6726  } else {
6727    Tcl_Obj *list = Tcl_NewListObj(0, NULL);
6728    Tcl_HashSearch hSrch;
6729    Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch);
6730    char *key;
6731    XOTcl_PushFrame(interp, obj);
6732    for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
6733      key = Tcl_GetHashKey(cmdTable, hPtr);
6734      if (!pattern || Tcl_StringMatch(key, pattern)) {
6735        if ((childobj = XOTclpGetObject(interp, key)) &&
6736            (!classesOnly || XOTclObjectIsClass(childobj)) &&
6737            (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr)  /* true children */
6738            ) {
6739          Tcl_ListObjAppendElement(interp, list, childobj->cmdName);
6740        }
6741      }
6742    }
6743    XOTcl_PopFrame(interp, obj);
6744    Tcl_SetObjResult(interp, list);
6745  }
6746  return TCL_OK;
6747}
6748
6749static int
6750ListParent(Tcl_Interp *interp, XOTclObject *obj) {
6751  if (obj->id) {
6752    Tcl_SetResult(interp, NSCmdFullName(obj->id), TCL_VOLATILE);
6753  }
6754  return TCL_OK;
6755}
6756
6757static XOTclClass*
6758FindCalledClass(Tcl_Interp *interp, XOTclObject *obj) {
6759  XOTclCallStackContent *csc = CallStackGetTopFrame(interp);
6760  char *methodName;
6761  Tcl_Command cmd;
6762
6763  if (csc->frameType == XOTCL_CSC_TYPE_PLAIN)
6764    return GetSelfClass(interp);
6765
6766  if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER)
6767    methodName = ObjStr(csc->filterStackEntry->calledProc);
6768  else if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && obj->mixinStack)
6769    methodName = (char *) GetSelfProc(interp);
6770  else
6771    methodName = "";
6772
6773  if (obj->nsPtr) {
6774    cmd = FindMethod(methodName, obj->nsPtr);
6775    if (cmd) {
6776      return NULL;
6777    }
6778  }
6779
6780  return SearchCMethod(obj->cl, methodName, &cmd);
6781}
6782
6783/*
6784 * Next Primitive Handling
6785 */
6786XOTCLINLINE static void
6787NextSearchMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclCallStackContent *csc,
6788                 XOTclClass **cl, char **method, Tcl_Command *cmd,
6789                 int *isMixinEntry, int *isFilterEntry,
6790                 int *endOfFilterChain, Tcl_Command *currentCmd) {
6791  XOTclClasses *pl = 0;
6792  int endOfChain = 0;
6793
6794  *endOfFilterChain = 0;
6795
6796  /*
6797   *  Next in filters
6798   */
6799  /*assert(obj->flags & XOTCL_FILTER_ORDER_VALID);   *** strange, worked before ****/
6800
6801  FilterComputeDefined(interp, obj);
6802
6803  if ((obj->flags & XOTCL_FILTER_ORDER_VALID) &&
6804      obj->filterStack &&
6805      obj->filterStack->currentCmdPtr) {
6806    *cmd = FilterSearchProc(interp, obj, currentCmd, cl);
6807    /*fprintf(stderr,"EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/
6808    /*  XOTclCallStackDump(interp); XOTclStackDump(interp);*/
6809
6810    if (*cmd == 0) {
6811      if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) {
6812        /* reset the information to the values of method, cl
6813           to the values they had before calling the filters */
6814        *method = ObjStr(obj->filterStack->calledProc);
6815        endOfChain = 1;
6816        *endOfFilterChain = 1;
6817        *cl = 0;
6818        /*fprintf(stderr,"EndOfChain resetting cl\n");*/
6819      }
6820    } else {
6821      *method = (char *) Tcl_GetCommandName(interp, *cmd);
6822      *isFilterEntry = 1;
6823      return;
6824    }
6825  }
6826
6827  /*
6828   *  Next in Mixins
6829   */
6830  assert(obj->flags & XOTCL_MIXIN_ORDER_VALID);
6831  /* otherwise: MixinComputeDefined(interp, obj); */
6832
6833  /*fprintf(stderr,"nextsearch: mixinorder valid %d stack=%p\n",
6834    obj->flags & XOTCL_MIXIN_ORDER_VALID,  obj->mixinStack);*/
6835
6836  if ((obj->flags & XOTCL_MIXIN_ORDER_VALID) &&  obj->mixinStack) {
6837    *cmd = MixinSearchProc(interp, obj, *method, cl, currentCmd);
6838    /*fprintf(stderr,"nextsearch: mixinsearch cmd %p, currentCmd %p\n",*cmd, *currentCmd);*/
6839    if (*cmd == 0) {
6840      if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) {
6841        endOfChain = 1;
6842        *cl = 0;
6843      }
6844    } else {
6845      *isMixinEntry = 1;
6846      return;
6847    }
6848  }
6849
6850  /*
6851   * otherwise: normal method dispatch
6852   *
6853   * if we are already in the precedence ordering, then advance
6854   * past our last point; otherwise (if cl==0) begin from the start
6855   */
6856
6857  /* if a mixin or filter chain has ended -> we have to search
6858     the obj-specific methods as well */
6859
6860  if (obj->nsPtr && endOfChain) {
6861    *cmd = FindMethod(*method, obj->nsPtr);
6862  } else {
6863    *cmd = 0;
6864  }
6865
6866
6867  if (!*cmd) {
6868    for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl && *cl; pl = pl->next) {
6869      if (pl->cl == *cl)
6870        *cl = 0;
6871    }
6872
6873    /*
6874     * search for a further class method
6875     */
6876    *cl = SearchPLMethod(pl, *method, cmd);
6877    /*fprintf(stderr, "no cmd, cl = %p %s\n",*cl, ObjStr((*cl)->object.cmdName));*/
6878  } else {
6879    *cl = 0;
6880  }
6881
6882  return;
6883}
6884
6885static int
6886XOTclNextMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclClass *givenCl,
6887                char *givenMethod, int objc, Tcl_Obj *CONST objv[],
6888                int useCallstackObjs) {
6889  XOTclCallStackContent *csc = CallStackGetTopFrame(interp);
6890  Tcl_Command cmd, currentCmd = NULL;
6891  int result = TCL_OK,
6892    frameType = XOTCL_CSC_TYPE_PLAIN,
6893    isMixinEntry = 0, isFilterEntry = 0,
6894    endOfFilterChain = 0, decrObjv0 = 0;
6895  int nobjc; Tcl_Obj **nobjv;
6896  XOTclClass **cl = &givenCl;
6897  char **methodName = &givenMethod;
6898
6899#if !defined(NDEBUG)
6900  if (useCallstackObjs) {
6901    Tcl_CallFrame *cf = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
6902    int found = 0;
6903    while (cf) {
6904      /*      fprintf(stderr, " ... compare fp = %p and cfp %p procFrame %p oc=%d\n",
6905              cf, csc->currentFramePtr,
6906              Tcl_Interp_framePtr(interp), Tcl_CallFrame_objc(Tcl_Interp_framePtr(interp))
6907              );*/
6908      if (cf == csc->currentFramePtr) {
6909        found = 1;
6910        break;
6911      }
6912      cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr;
6913    }
6914    /*
6915      if (!found) {
6916      if (Tcl_Interp_varFramePtr(interp)) {
6917      fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n",
6918      csc->currentFramePtr, found,
6919      Tcl_CallFrame_level(Tcl_Interp_varFramePtr(interp)));
6920      } else {
6921      fprintf(stderr,"no varFramePtr\n");
6922      }
6923      return TCL_OK;
6924      }
6925    */
6926  }
6927#endif
6928
6929  /*fprintf(stderr,"givenMethod = %s, csc = %p, useCallstackObj %d, objc %d currentFramePtr %p\n",
6930    givenMethod, csc, useCallstackObjs, objc, csc->currentFramePtr);*/
6931
6932
6933  /* if no args are given => use args from stack */
6934  if (objc < 2 && useCallstackObjs && csc->currentFramePtr) {
6935    nobjc = Tcl_CallFrame_objc(csc->currentFramePtr);
6936    nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr);
6937  } else {
6938    nobjc = objc;
6939    nobjv = (Tcl_Obj **)objv;
6940    /* We do not want to have "next" as the procname, since this can
6941       lead to unwanted results e.g. in a forwarder using %proc. So, we
6942       replace the first word with the value from the callstack to be
6943       compatible with the case where next is called without args.
6944    */
6945    if (useCallstackObjs && csc->currentFramePtr) {
6946        nobjv[0] = Tcl_CallFrame_objv(csc->currentFramePtr)[0];
6947        INCR_REF_COUNT(nobjv[0]); /* we seem to need this here */
6948        decrObjv0 = 1;
6949    }
6950  }
6951
6952  /*
6953   * Search the next method & compute its method data
6954   */
6955  NextSearchMethod(obj, interp, csc, cl, methodName, &cmd,
6956                   &isMixinEntry, &isFilterEntry, &endOfFilterChain, &currentCmd);
6957
6958  /*
6959    fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,",
6960    *methodName, endOfFilterChain);
6961    if (obj)
6962    fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName));
6963    if ((*cl))
6964    fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName);
6965    fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n",
6966	  isMixinEntry, isFilterEntry, proc);
6967  */
6968
6969  Tcl_ResetResult(interp); /* needed for bytecode support */
6970
6971  if (cmd) {
6972    /*
6973     * change mixin state
6974     */
6975    if (obj->mixinStack) {
6976      if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN)
6977        csc->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN;
6978
6979      /* otherwise move the command pointer forward */
6980      if (isMixinEntry) {
6981        frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN;
6982        obj->mixinStack->currentCmdPtr = currentCmd;
6983      }
6984    }
6985    /*
6986     * change filter state
6987     */
6988    if (obj->filterStack) {
6989      if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER)
6990        csc->frameType = XOTCL_CSC_TYPE_INACTIVE_FILTER;
6991
6992      /* otherwise move the command pointer forward */
6993      if (isFilterEntry) {
6994        frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER;
6995        obj->filterStack->currentCmdPtr = currentCmd;
6996      }
6997    }
6998
6999    /*
7000     * now actually call the "next" method
7001     */
7002
7003    /* cut the flag, that no stdargs should be used, if it is there */
7004    if (nobjc > 1) {
7005      char *nobjv1 = ObjStr(nobjv[1]);
7006      if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs"))
7007        nobjc = 1;
7008    }
7009    csc->callType |= XOTCL_CSC_CALL_IS_NEXT;
7010    RUNTIME_STATE(interp)->unknown = 0;
7011    result = DoCallProcCheck((ClientData)obj, interp, nobjc, nobjv, cmd,
7012                             obj, *cl, *methodName, frameType);
7013
7014    csc->callType &= ~XOTCL_CSC_CALL_IS_NEXT;
7015
7016    if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER)
7017      csc->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER;
7018    else if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN)
7019      csc->frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN;
7020  } else if (result == TCL_OK && endOfFilterChain) {
7021    /*fprintf(stderr,"setting unknown to 1\n");*/
7022    RUNTIME_STATE(interp)->unknown = 1;
7023  }
7024
7025  if (decrObjv0) {
7026      INCR_REF_COUNT(nobjv[0]);
7027  }
7028
7029  return result;
7030}
7031
7032int
7033XOTclNextObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
7034  XOTclCallStackContent *csc = CallStackGetTopFrame(interp);
7035
7036  if (!csc->self)
7037    return XOTclVarErrMsg(interp, "next: can't find self", (char *) NULL);
7038
7039  if (!csc->cmdPtr)
7040    return XOTclErrMsg(interp, "next: no executing proc", TCL_STATIC);
7041
7042  return XOTclNextMethod(csc->self, interp, csc->cl,
7043                         (char *)Tcl_GetCommandName(interp, csc->cmdPtr),
7044                         objc, objv, 1);
7045}
7046
7047
7048int
7049XOTclQualifyObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
7050  char *string;
7051  if (objc != 2)
7052    return XOTclVarErrMsg(interp, "wrong # of args for __qualify", (char *) NULL);
7053
7054  string = ObjStr(objv[1]);
7055  if (!isAbsolutePath(string)) {
7056    Tcl_SetObjResult(interp, NameInNamespaceObj(interp, string, callingNameSpace(interp)));
7057  } else {
7058    Tcl_SetObjResult(interp, objv[1]);
7059  }
7060  return TCL_OK;
7061}
7062
7063/* method for calling e.g.  $obj __next  */
7064static int
7065XOTclONextMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
7066  XOTclObject *obj = (XOTclObject*)cd;
7067  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
7068  XOTclCallStackContent *csc = CallStackGetTopFrame(interp);
7069  char *methodName;
7070
7071  for (; csc >= cs->content; csc--) {
7072    if (csc->self == obj) break;
7073  }
7074  if (csc<cs->content)
7075    return XOTclVarErrMsg(interp, "__next: can't find object",
7076                          ObjStr(obj->cmdName), (char *) NULL);
7077  methodName = (char *)Tcl_GetCommandName(interp, csc->cmdPtr);
7078  /*fprintf(stderr,"******* next for proc %s\n", methodName);*/
7079  return XOTclNextMethod(obj, interp, csc->cl, methodName, objc-1, &objv[1], 0);
7080}
7081
7082/*
7083 * "self" object command
7084 */
7085
7086static int
7087FindSelfNext(Tcl_Interp *interp, XOTclObject *obj) {
7088  XOTclCallStackContent *csc = CallStackGetTopFrame(interp);
7089  Tcl_Command cmd, currentCmd = 0;
7090  int isMixinEntry = 0,
7091    isFilterEntry = 0,
7092    endOfFilterChain = 0;
7093  XOTclClass *cl = csc->cl;
7094  XOTclObject *o = csc->self;
7095  char *methodName;
7096
7097  Tcl_ResetResult(interp);
7098
7099  methodName = (char *)GetSelfProc(interp);
7100  if (!methodName)
7101    return TCL_OK;
7102
7103  NextSearchMethod(o, interp, csc, &cl, &methodName, &cmd,
7104                   &isMixinEntry, &isFilterEntry, &endOfFilterChain, &currentCmd);
7105
7106  if (cmd) {
7107    Tcl_SetObjResult(interp, getFullProcQualifier(interp, Tcl_GetCommandName(interp, cmd),
7108                                                  o, cl, cmd));
7109  }
7110  return TCL_OK;
7111}
7112
7113static Tcl_Obj *
7114computeLevelObj(Tcl_Interp *interp, CallStackLevel level) {
7115  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
7116  XOTclCallStackContent *csc;
7117  Tcl_Obj *resultObj;
7118
7119  switch (level) {
7120  case CALLING_LEVEL: csc = XOTclCallStackFindLastInvocation(interp, 1); break;
7121  case ACTIVE_LEVEL:  csc = XOTclCallStackFindActiveFrame(interp, 1); break;
7122  default: csc = NULL;
7123  }
7124
7125  if (cs->top->currentFramePtr == ((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp))
7126      && csc && csc < cs->top && csc->currentFramePtr) {
7127    /* this was from an xotcl frame, return absolute frame number */
7128    char buffer[LONG_AS_STRING];
7129    int l;
7130    buffer[0] = '#';
7131    /* fprintf(stderr,"*** csc=%p\n", csc);*/
7132    XOTcl_ltoa(buffer+1,(long)Tcl_CallFrame_level(csc->currentFramePtr),&l);
7133    resultObj = Tcl_NewStringObj(buffer, l+1);
7134  } else {
7135    /* If not called from an xotcl frame, return 1 as default */
7136    resultObj = Tcl_NewIntObj(1);
7137  }
7138  /*XOTclStackDump(interp);XOTclCallStackDump(interp);*/
7139
7140  return resultObj;
7141}
7142
7143static int
7144XOTclSelfSubCommand(Tcl_Interp *interp, XOTclObject *obj, char *option) {
7145  assert(option);
7146
7147  if (isProcString(option)) { /* proc subcommand */
7148    char *procName = (char *) GetSelfProc(interp);
7149    if (procName) {
7150      Tcl_SetResult(interp, procName, TCL_VOLATILE);
7151      return TCL_OK;
7152    } else {
7153      return XOTclVarErrMsg(interp, "Can't find proc", (char *) NULL);
7154    }
7155  } else if (isClassString(option)) { /* class subcommand */
7156    XOTclClass *cl = GetSelfClass(interp);
7157    Tcl_SetObjResult(interp, cl ? cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
7158    return TCL_OK;
7159  } else {
7160    XOTclCallStackContent *csc = NULL;
7161
7162    switch (*option) { /* other callstack information */
7163    case 'a':
7164      if (!strcmp(option, "activelevel")) {
7165        Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL));
7166        return TCL_OK;
7167      } else if (!strcmp(option,"args")) {
7168        int nobjc;
7169        Tcl_Obj **nobjv;
7170        csc = CallStackGetTopFrame(interp);
7171        nobjc = Tcl_CallFrame_objc(csc->currentFramePtr);
7172        nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr);
7173        Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1, nobjv+1));
7174        return TCL_OK;
7175      }
7176#if defined(ACTIVEMIXIN)
7177      else if (!strcmp(option, "activemixin")) {
7178        XOTclObject *o = NULL;
7179        csc = CallStackGetTopFrame(interp);
7180        /*CmdListPrint(interp,"self a....\n", obj->mixinOrder);
7181          fprintf(stderr,"current cmdPtr = %p cl = %p, mo=%p %p\n", csc->cmdPtr, csc->cl,
7182          obj->mixinOrder,   RUNTIME_STATE(interp)->cmdPtr);*/
7183        if (RUNTIME_STATE(interp)->cmdPtr) {
7184          o = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr);
7185        }
7186        Tcl_SetObjResult(interp, o ? o->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
7187        return TCL_OK;
7188      }
7189#endif
7190      break;
7191    case 'c':
7192      if (!strcmp(option, "calledproc")) {
7193        if (!(csc = CallStackFindActiveFilter(interp)))
7194          return XOTclVarErrMsg(interp,
7195                                "self calledproc called from outside of a filter",
7196                                (char *) NULL);
7197        Tcl_SetObjResult(interp, csc->filterStackEntry->calledProc);
7198        return TCL_OK;
7199      } else if (!strcmp(option, "calledclass")) {
7200        Tcl_SetResult(interp, className(FindCalledClass(interp, obj)), TCL_VOLATILE);
7201        return TCL_OK;
7202      } else if (!strcmp(option, "callingproc")) {
7203        csc = XOTclCallStackFindLastInvocation(interp, 1);
7204        Tcl_SetResult(interp, csc ? (char *)Tcl_GetCommandName(interp, csc->cmdPtr) : "",
7205                      TCL_VOLATILE);
7206        return TCL_OK;
7207      } else if (!strcmp(option, "callingclass")) {
7208        csc = XOTclCallStackFindLastInvocation(interp, 1);
7209        Tcl_SetObjResult(interp, csc && csc->cl ? csc->cl->object.cmdName :
7210                         XOTclGlobalObjects[XOTE_EMPTY]);
7211        return TCL_OK;
7212      } else if (!strcmp(option, "callinglevel")) {
7213        Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL));
7214        return TCL_OK;
7215      } else if (!strcmp(option, "callingobject")) {
7216
7217        /*XOTclStackDump(interp); XOTclCallStackDump(interp);*/
7218
7219        csc = XOTclCallStackFindLastInvocation(interp, 1);
7220        Tcl_SetObjResult(interp, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
7221        return TCL_OK;
7222      }
7223      break;
7224
7225    case 'f':
7226      if (!strcmp(option, "filterreg")) {
7227        if (!(csc = CallStackFindActiveFilter(interp))) {
7228          return XOTclVarErrMsg(interp,
7229                                "self filterreg called from outside of a filter",
7230                                (char *) NULL);
7231        }
7232        Tcl_SetObjResult(interp, FilterFindReg(interp, obj, GetSelfProcCmdPtr(interp)));
7233        return TCL_OK;
7234      }
7235      break;
7236
7237    case 'i':
7238      if (!strcmp(option, "isnextcall")) {
7239        XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
7240        csc = cs->top;
7241        csc--;
7242        Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
7243                          (csc > cs->content &&
7244                           (csc->callType & XOTCL_CSC_CALL_IS_NEXT)));
7245        return TCL_OK;
7246      }
7247      break;
7248
7249    case 'n':
7250      if (!strcmp(option, "next"))
7251        return FindSelfNext(interp, obj);
7252      break;
7253    }
7254  }
7255  return XOTclVarErrMsg(interp, "unknown option '", option,
7256                        "' for self", (char *) NULL);
7257}
7258
7259/*
7260  int
7261  XOTclKObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
7262  if (objc < 2)
7263  return XOTclVarErrMsg(interp, "wrong # of args for K", (char *) NULL);
7264
7265  Tcl_SetObjResult(interp, objv[1]);
7266  return TCL_OK;
7267  }
7268*/
7269
7270int
7271XOTclGetSelfObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
7272  XOTclObject *obj;
7273
7274  if (objc > 2)
7275    return XOTclVarErrMsg(interp, "wrong # of args for self", (char *) NULL);
7276
7277  obj = GetSelfObj(interp);
7278
7279  /*fprintf(stderr,"getSelfObj returns %p\n", obj);XOTclCallStackDump(interp);*/
7280
7281  if (!obj) {
7282    if (objc == 2 && !strcmp(ObjStr(objv[1]),"callinglevel")) {
7283      Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
7284      return TCL_OK;
7285    } else {
7286      return XOTclVarErrMsg(interp, "self: no current object", (char *) NULL);
7287    }
7288  }
7289
7290  if (objc == 1) {
7291    Tcl_SetObjResult(interp, obj->cmdName);
7292    return TCL_OK;
7293  } else {
7294    return XOTclSelfSubCommand(interp, obj, ObjStr(objv[1]));
7295  }
7296}
7297
7298
7299/*
7300 * object creation & destruction
7301 */
7302
7303static int
7304unsetInAllNamespaces(Tcl_Interp *interp, Namespace *nsPtr, CONST char *name) {
7305  int rc = 0;
7306  fprintf(stderr, "### unsetInAllNamespaces variable '%s', current namespace '%s'\n",
7307          name, nsPtr ? nsPtr->fullName : "NULL");
7308
7309  if (nsPtr) {
7310    Tcl_HashSearch search;
7311    Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
7312    Tcl_Var *varPtr;
7313    int result;
7314
7315    varPtr = (Tcl_Var *) Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) nsPtr, 0);
7316    /*fprintf(stderr, "found %s in %s -> %p\n", name, nsPtr->fullName, varPtr);*/
7317    if (varPtr) {
7318      Tcl_DString dFullname, *dsPtr = &dFullname;
7319      Tcl_DStringInit(dsPtr);
7320      Tcl_DStringAppend(dsPtr, "unset ", -1);
7321      Tcl_DStringAppend(dsPtr, nsPtr->fullName, -1);
7322      Tcl_DStringAppend(dsPtr, "::", 2);
7323      Tcl_DStringAppend(dsPtr, name, -1);
7324      /*rc = Tcl_UnsetVar2(interp, Tcl_DStringValue(dsPtr), NULL, TCL_LEAVE_ERR_MSG);*/
7325      result = Tcl_Eval(interp, Tcl_DStringValue(dsPtr));
7326      /* fprintf(stderr, "fqName = '%s' unset => %d %d\n", Tcl_DStringValue(dsPtr), rc, TCL_OK);*/
7327      if (result == TCL_OK) {
7328        rc = 1;
7329      } else {
7330        Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
7331        fprintf(stderr, "   err = '%s'\n", ObjStr(resultObj));
7332      }
7333      Tcl_DStringFree(dsPtr);
7334    }
7335
7336    while (rc == 0 && entryPtr) {
7337      Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
7338      /*fprintf(stderr, "child = %s\n", childNsPtr->fullName);*/
7339      entryPtr = Tcl_NextHashEntry(&search);
7340      rc |= unsetInAllNamespaces(interp, childNsPtr, name);
7341    }
7342  }
7343  return rc;
7344}
7345
7346static int
7347freeUnsetTraceVariable(Tcl_Interp *interp, XOTclObject *obj) {
7348  int rc = TCL_OK;
7349
7350  obj->flags |= XOTCL_FREE_TRACE_VAR_CALLED;
7351
7352  if (obj->opt && obj->opt->volatileVarName) {
7353    /*
7354      Somebody destroys a volatile object manually while
7355      the vartrace is still active. Destroying the object will
7356      be a problem in case the variable is deleted later
7357      and fires the trace. So, we unset the variable here
7358      which will cause a destroy via var trace, which in
7359      turn clears the volatileVarName flag.
7360    */
7361    /*fprintf(stderr,"### freeUnsetTraceVariable %s\n", obj->opt->volatileVarName);*/
7362
7363    rc = Tcl_UnsetVar2(interp, obj->opt->volatileVarName, NULL, 0);
7364    if (rc != TCL_OK) {
7365      /* try hard to find variable */
7366      int rc = Tcl_UnsetVar2(interp, obj->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY);
7367
7368      if (rc != TCL_OK) {
7369        Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
7370
7371        if (unsetInAllNamespaces(interp, nsPtr, obj->opt->volatileVarName) == 0) {
7372          fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n",
7373                  obj->opt->volatileVarName);
7374        }
7375      }
7376    }
7377    /*if (rc == TCL_OK) {
7378      fprintf(stderr, "### success unset\n");
7379      }*/
7380  }
7381
7382  return  rc;
7383}
7384
7385static char *
7386XOTclUnsetTrace(ClientData cd, Tcl_Interp *interp, CONST84 char *name, CONST84 char *name2, int flags)
7387{
7388  Tcl_Obj *obj = (Tcl_Obj *)cd;
7389  XOTclObject *o;
7390  char *result = NULL;
7391
7392  /*fprintf(stderr,"XOTclUnsetTrace %s flags %x %x\n", name, flags,
7393    flags & TCL_INTERP_DESTROYED); */
7394
7395  if ((flags & TCL_INTERP_DESTROYED) == 0) {
7396    if (XOTclObjConvertObject(interp, obj, &o) == TCL_OK) {
7397
7398      /*fprintf(stderr,"XOTclUnsetTrace o %p flags %.6x\n", o, o->flags);*/
7399
7400      /* clear variable, destroy is called from trace */
7401      if (o->opt && o->opt->volatileVarName) {
7402        o->opt->volatileVarName = NULL;
7403      }
7404
7405      if ( o->flags & XOTCL_FREE_TRACE_VAR_CALLED ) {
7406        /*fprintf(stderr,"XOTclUnsetTrace o %p remove trace\n", o);*/
7407        Tcl_UntraceVar(interp, name, flags, (Tcl_VarTraceProc*)XOTclUnsetTrace, (ClientData)o);
7408      } else {
7409        Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */
7410        INCR_REF_COUNT(res);
7411
7412        if (callMethod((ClientData)o, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0) != TCL_OK) {
7413          result = "Destroy for volatile object failed";
7414        } else {
7415          result = "No XOTcl Object passed";
7416        }
7417
7418        Tcl_SetObjResult(interp, res);  /* restore the result */
7419        DECR_REF_COUNT(res);
7420      }
7421    }
7422    DECR_REF_COUNT(obj);
7423  } else {
7424    /*fprintf(stderr, "omitting destroy on %s %p\n", name);*/
7425  }
7426  return result;
7427}
7428
7429/*
7430 * mark an obj on the existing callstack, as not destroyed
7431 */
7432static void
7433UndestroyObj(Tcl_Interp *interp, XOTclObject *obj) {
7434  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
7435  XOTclCallStackContent *csc;
7436
7437  /*
7438   * mark the object on the whole callstack as not destroyed
7439   */
7440  for (csc = &cs->content[1]; csc <= cs->top; csc++) {
7441    if (obj == csc->self && csc->destroyedCmd) {
7442      /*
7443       * The ref count was incremented, when csc->destroyedCmd
7444       * was set. We revert this first before forgetting the
7445       * destroyedCmd.
7446       */
7447      if (Tcl_Command_refCount(csc->destroyedCmd) > 1) {
7448        Tcl_Command_refCount(csc->destroyedCmd)--;
7449        MEM_COUNT_FREE("command refCount", csc->destroyedCmd);
7450      }
7451      csc->destroyedCmd  = 0;
7452    }
7453  }
7454  /*
7455   * mark obj->flags XOTCL_DESTROY_CALLED as NOT CALLED (0)
7456   */
7457  obj->flags &= ~XOTCL_DESTROY_CALLED;
7458}
7459
7460/*
7461 * bring an object into a state, as after initialization
7462 */
7463static void
7464CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *obj, int softrecreate) {
7465  XOTclClass *thecls, *theobj;
7466
7467  thecls = RUNTIME_STATE(interp)->theClass;
7468  theobj = RUNTIME_STATE(interp)->theObject;
7469  /* remove the instance, but not for ::Class/::Object */
7470  if (obj != &(thecls->object) && obj != &(theobj->object)) {
7471
7472    if (!softrecreate) {
7473      (void)RemoveInstance(obj, obj->cl);
7474    }
7475  }
7476
7477  if (obj->nsPtr) {
7478    NSCleanupNamespace(interp, obj->nsPtr);
7479    NSDeleteChildren(interp, obj->nsPtr);
7480  }
7481
7482  if (obj->varTable) {
7483    TclDeleteVars(((Interp *)interp), obj->varTable);
7484    ckfree((char *)obj->varTable);
7485    /*FREE(obj->varTable, obj->varTable);*/
7486    obj->varTable = 0;
7487  }
7488
7489  if (obj->opt) {
7490    XOTclObjectOpt *opt = obj->opt;
7491    AssertionRemoveStore(opt->assertions);
7492    opt->assertions = NULL;
7493
7494#ifdef XOTCL_METADATA
7495    XOTclMetaDataDestroy(obj);
7496#endif
7497
7498    if (!softrecreate) {
7499      /*
7500       *  Remove this object from all per object mixin lists and clear the mixin list
7501       */
7502      removeFromObjectMixinsOf(obj->id, opt->mixins);
7503
7504      CmdListRemoveList(&opt->mixins, GuardDel);
7505      CmdListRemoveList(&opt->filters, GuardDel);
7506
7507      FREE(XOTclObjectOpt, opt);
7508      opt = obj->opt = 0;
7509    }
7510  }
7511
7512  if (obj->nonposArgsTable) {
7513    NonposArgsFreeTable(obj->nonposArgsTable);
7514    Tcl_DeleteHashTable(obj->nonposArgsTable);
7515    MEM_COUNT_FREE("Tcl_InitHashTable", obj->nonposArgsTable);
7516    ckfree((char *) obj->nonposArgsTable);
7517    MEM_COUNT_FREE("Tcl_HashTable", obj->nonposArgsTable);
7518  }
7519
7520  obj->flags &= ~XOTCL_MIXIN_ORDER_VALID;
7521  if (obj->mixinOrder)  MixinResetOrder(obj);
7522  obj->flags &= ~XOTCL_FILTER_ORDER_VALID;
7523  if (obj->filterOrder) FilterResetOrder(obj);
7524}
7525
7526/*
7527 * do obj initialization & namespace creation
7528 */
7529static void
7530CleanupInitObject(Tcl_Interp *interp, XOTclObject *obj,
7531                  XOTclClass *cl, Tcl_Namespace *namespacePtr, int softrecreate) {
7532#ifdef OBJDELETION_TRACE
7533  fprintf(stderr,"+++ CleanupInitObject\n");
7534#endif
7535  obj->teardown = interp;
7536  obj->nsPtr = namespacePtr;
7537  if (!softrecreate) {
7538    AddInstance(obj, cl);
7539  }
7540  if (obj->flags & XOTCL_RECREATE) {
7541    obj->opt = 0;
7542    obj->varTable = 0;
7543    obj->nonposArgsTable = 0;
7544    obj->mixinOrder = 0;
7545    obj->filterOrder = 0;
7546    obj->flags = 0;
7547  }
7548}
7549
7550/*
7551 * physical object destroy
7552 */
7553static void
7554PrimitiveODestroy(ClientData cd) {
7555  XOTclObject *obj = (XOTclObject*)cd;
7556  Tcl_Interp *interp;
7557
7558  /*fprintf(stderr, "****** PrimitiveODestroy %p %s\n", obj, ObjStr(obj->cmdName));*/
7559  assert(obj && !(obj->flags & XOTCL_DESTROYED));
7560
7561  /*
7562   * check and latch against recurrent calls with obj->teardown
7563   */
7564  PRINTOBJ("PrimitiveODestroy", obj);
7565
7566  if (!obj || !obj->teardown) return;
7567  interp = obj->teardown;
7568
7569  /*
7570   * Don't destroy, if the interpreter is destroyed already
7571   * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed
7572   */
7573  if (Tcl_InterpDeleted(interp)) return;
7574  /*
7575   * call and latch user destroy with obj->id if we haven't
7576   */
7577  if (!(obj->flags & XOTCL_DESTROY_CALLED)) {
7578    callDestroyMethod(cd, interp, obj, 0);
7579    obj->id = NULL;
7580  }
7581
7582#ifdef OBJDELETION_TRACE
7583  fprintf(stderr,"  physical delete of %p id=%p destroyCalled=%d '%s'\n",
7584          obj, obj->id, (obj->flags & XOTCL_DESTROY_CALLED), ObjStr(obj->cmdName));
7585#endif
7586
7587  CleanupDestroyObject(interp, obj, 0);
7588
7589  while (obj->mixinStack)
7590    MixinStackPop(obj);
7591
7592  while (obj->filterStack)
7593    FilterStackPop(obj);
7594
7595  obj->teardown = NULL;
7596
7597#if 0
7598  {
7599    /* Prevent that PrimitiveODestroy is called more than once.
7600       This code was used in earlier versions of XOTcl
7601       but does not seem necessary any more. If it has to be used
7602       again in the future, don't use Tcl_GetCommandFromObj()
7603       in Tcl 8.4.* versions.
7604    */
7605    Tcl_Command cmd = Tcl_FindCommand(interp, ObjStr(obj->cmdName), 0, 0);
7606    if (cmd)
7607      Tcl_Command_deleteProc(cmd) = NULL;
7608  }
7609#endif
7610
7611  if (obj->nsPtr) {
7612    /*fprintf(stderr,"primitive odestroy calls deletenamespace for obj %p\n", obj);*/
7613    XOTcl_DeleteNamespace(interp, obj->nsPtr);
7614    obj->nsPtr = NULL;
7615  }
7616
7617  /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", ObjStr(obj->cmdName));*/
7618
7619  obj->flags |= XOTCL_DESTROYED;
7620  objTrace("ODestroy", obj);
7621#if REFCOUNT_TRACE
7622  fprintf(stderr,"ODestroy %p flags %d rc %d destr %d dc %d\n",
7623          obj, obj->flags,
7624          (obj->flags & XOTCL_REFCOUNTED) != 0,
7625          (obj->flags & XOTCL_DESTROYED) != 0,
7626          (obj->flags & XOTCL_DESTROY_CALLED) != 0
7627          );
7628#endif
7629#if REFCOUNTED
7630  if (!(obj->flags & XOTCL_REFCOUNTED)) {
7631    DECR_REF_COUNT(obj->cmdName);
7632  }
7633#else
7634  DECR_REF_COUNT(obj->cmdName);
7635#endif
7636
7637  XOTclCleanupObject(obj);
7638
7639#if !defined(NDEBUG)
7640  if (obj != (XOTclObject*)RUNTIME_STATE(interp)->theClass)
7641    checkAllInstances(interp, RUNTIME_STATE(interp)->theClass, 0);
7642#endif
7643}
7644
7645static void
7646PrimitiveOInit(void *mem, Tcl_Interp *interp, char *name, XOTclClass *cl) {
7647  XOTclObject *obj = (XOTclObject*)mem;
7648  Tcl_Namespace *nsPtr = NULL;
7649
7650#ifdef OBJDELETION_TRACE
7651  fprintf(stderr,"+++ PrimitiveOInit\n");
7652#endif
7653
7654#ifdef XOTCLOBJ_TRACE
7655  fprintf(stderr, "OINIT %s = %p\n", name, obj);
7656#endif
7657  XOTclObjectRefCountIncr(obj);
7658
7659  /* if the command of the obj was used before, we have to clean
7660   * up the callstack from set "destroyedCmd" flags
7661   */
7662  UndestroyObj(interp, obj);
7663
7664  if (Tcl_FindNamespace(interp, name, NULL, 0)) {
7665      nsPtr = NSGetFreshNamespace(interp, (ClientData)obj, name);
7666  }
7667  CleanupInitObject(interp, obj, cl, nsPtr, 0);
7668
7669  /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/
7670  obj->mixinStack = NULL;
7671  obj->filterStack = NULL;
7672}
7673
7674/*
7675 * Object creation: create object name (full name) and Tcl command
7676 */
7677static XOTclObject*
7678PrimitiveOCreate(Tcl_Interp *interp, char *name, XOTclClass *cl) {
7679  XOTclObject *obj = (XOTclObject*)ckalloc(sizeof(XOTclObject));
7680  unsigned length;
7681
7682  /*fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);*/
7683#if defined(XOTCLOBJ_TRACE)
7684  fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);
7685#endif
7686#ifdef OBJDELETION_TRACE
7687  fprintf(stderr,"+++ PrimitiveOCreate\n");
7688#endif
7689
7690  memset(obj, 0, sizeof(XOTclObject));
7691  MEM_COUNT_ALLOC("XOTclObject/XOTclClass", obj);
7692  assert(obj); /* ckalloc panics, if malloc fails */
7693  assert(isAbsolutePath(name));
7694
7695  length = strlen(name);
7696  if (!NSCheckForParent(interp, name, length)) {
7697    ckfree((char *) obj);
7698    return 0;
7699  }
7700  obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch,
7701                                 (ClientData)obj, tclDeletesObject);
7702
7703  PrimitiveOInit(obj, interp, name, cl);
7704#if 0
7705  /*defined(KEEP_TCL_CMD_TYPE)*/
7706  /*TclNewObj(obj->cmdName);*/
7707  obj->cmdName = Tcl_NewStringObj(name, length);
7708  TclSetCmdNameObj(interp, obj->cmdName, (Command*)obj->id);
7709  /*fprintf(stderr, "new command has name '%s'\n", ObjStr(obj->cmdName));*/
7710#else
7711  obj->cmdName = NewXOTclObjectObjName(obj, name, length);
7712#endif
7713  INCR_REF_COUNT(obj->cmdName);
7714
7715  objTrace("PrimitiveOCreate", obj);
7716
7717  return obj;
7718}
7719
7720/*
7721 * Cleanup class: remove filters, mixins, assertions, instances ...
7722 * and remove class from class hierarchy
7723 */
7724static void
7725CleanupDestroyClass(Tcl_Interp *interp, XOTclClass *cl, int softrecreate, int recreate) {
7726  Tcl_HashSearch hSrch;
7727  Tcl_HashEntry *hPtr;
7728  XOTclClass *theobj = RUNTIME_STATE(interp)->theObject;
7729  XOTclClassOpt *clopt = cl->opt;
7730
7731  assert(softrecreate? recreate == 1 : 1);
7732
7733  /* fprintf(stderr, "CleanupDestroyClass softrecreate=%d,recreate=%d, %p\n",
7734     softrecreate,recreate,clopt); */
7735
7736  /* do this even with no clopt, since the class might be used as a
7737     superclass of a per object mixin, so it has no clopt...
7738   */
7739  MixinInvalidateObjOrders(interp, cl);
7740  FilterInvalidateObjOrders(interp, cl);
7741
7742  if (clopt) {
7743    /*
7744     *  Remove this class from all isClassMixinOf lists and clear the instmixin list
7745     */
7746    RemoveFromClassMixinsOf(clopt->id, clopt->instmixins);
7747
7748    CmdListRemoveList(&clopt->instmixins, GuardDel);
7749    /*MixinInvalidateObjOrders(interp, cl);*/
7750
7751    CmdListRemoveList(&clopt->instfilters, GuardDel);
7752    /*FilterInvalidateObjOrders(interp, cl);*/
7753
7754    if (!recreate) {
7755      /*
7756      *  Remove this class from all mixin lists and clear the isObjectMixinOf list
7757      */
7758
7759      RemoveFromMixins(clopt->id, clopt->isObjectMixinOf);
7760      CmdListRemoveList(&clopt->isObjectMixinOf, GuardDel);
7761
7762      /*
7763       *  Remove this class from all instmixin lists and clear the isClassMixinOf list
7764       */
7765
7766      RemoveFromInstmixins(clopt->id, clopt->isClassMixinOf);
7767      CmdListRemoveList(&clopt->isClassMixinOf, GuardDel);
7768    }
7769    /* remove dependent filters of this class from all subclasses*/
7770    FilterRemoveDependentFilterCmds(cl, cl);
7771    AssertionRemoveStore(clopt->assertions);
7772    clopt->assertions = NULL;
7773#ifdef XOTCL_OBJECTDATA
7774    XOTclFreeObjectData(cl);
7775#endif
7776  }
7777
7778  Tcl_ForgetImport(interp, cl->nsPtr, "*"); /* don't destroy namespace imported objects */
7779  NSCleanupNamespace(interp, cl->nsPtr);
7780  NSDeleteChildren(interp, cl->nsPtr);
7781
7782  if (!softrecreate) {
7783    /* Reclass all instances of the current class the the appropriate
7784       most general class ("baseClass"). The most general class of a
7785       metaclass is ::xotcl::Class, the most general class of an
7786       object is ::xotcl::Object. Instances of metaclasses can be only
7787       reset to ::xotcl::Class (and not to ::xotcl::Object as in
7788       earlier versions), since otherwise their instances can't be
7789       deleted, because ::xotcl::Object has no method "instdestroy".
7790
7791       We do not have to reclassing in case, cl == ::xotcl::Object
7792    */
7793    if (cl != theobj) {
7794      XOTclClass *baseClass = IsMetaClass(interp, cl) ? RUNTIME_STATE(interp)->theClass : theobj;
7795      if (baseClass == cl) {
7796        /* During final cleanup, we delete ::xotcl::Class; there are
7797           no more Classes or user objects available at that time, so
7798           we reclass to ::xotcl::Object.
7799        */
7800        baseClass = theobj;
7801      }
7802      hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0;
7803      for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
7804        XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr);
7805        if (inst && inst != (XOTclObject*)cl && inst->id) {
7806          if (inst != &(baseClass->object)) {
7807            (void)RemoveInstance(inst, cl->object.cl);
7808            AddInstance(inst, baseClass);
7809          }
7810        }
7811      }
7812    }
7813    Tcl_DeleteHashTable(&cl->instances);
7814    MEM_COUNT_FREE("Tcl_InitHashTable",&cl->instances);
7815  }
7816
7817  if (cl->nonposArgsTable) {
7818    NonposArgsFreeTable(cl->nonposArgsTable);
7819    Tcl_DeleteHashTable(cl->nonposArgsTable);
7820    MEM_COUNT_FREE("Tcl_InitHashTable", cl->nonposArgsTable);
7821    ckfree((char *) cl->nonposArgsTable);
7822    MEM_COUNT_FREE("Tcl_HashTable", cl->nonposArgsTable);
7823  }
7824
7825  if (cl->parameters) {
7826    DECR_REF_COUNT(cl->parameters);
7827  }
7828
7829  if ((clopt) && (!recreate)) {
7830    if (clopt->parameterClass) {
7831      DECR_REF_COUNT(clopt->parameterClass);
7832    }
7833    FREE(XOTclClassOpt, clopt);
7834    clopt = cl->opt = 0;
7835  }
7836
7837  /* On a recreate, it might be possible that the newly created class
7838     has a different superclass. So we have to flush the precedence list
7839     on a recreate as well.
7840  */
7841  FlushPrecedencesOnSubclasses(cl);
7842  while (cl->super) (void)RemoveSuper(cl, cl->super->cl);
7843
7844  if (!softrecreate) {
7845    /*
7846     * flush all caches, unlink superclasses
7847     */
7848
7849    while (cl->sub) {
7850      XOTclClass *subClass = cl->sub->cl;
7851      (void)RemoveSuper(subClass, cl);
7852      /* if there are no more super classes add the Object
7853       * class as superclasses
7854       * -> don't do that for Object itself!
7855       */
7856      if (subClass->super == 0 && cl != theobj)
7857        AddSuper(subClass, theobj);
7858    }
7859  }
7860
7861}
7862
7863/*
7864 * do class initialization & namespace creation
7865 */
7866static void
7867CleanupInitClass(Tcl_Interp *interp, XOTclClass *cl, Tcl_Namespace *namespacePtr,
7868                 int softrecreate, int recreate) {
7869  XOTclObject *obj = (XOTclObject*)cl;
7870
7871  assert(softrecreate? recreate == 1 : 1);
7872
7873#ifdef OBJDELETION_TRACE
7874  fprintf(stderr,"+++ CleanupInitClass\n");
7875#endif
7876
7877  /*
7878   * during init of Object and Class the theClass value is not set
7879   */
7880  /*
7881    if (RUNTIME_STATE(interp)->theClass != 0)
7882    obj->type = RUNTIME_STATE(interp)->theClass;
7883  */
7884  XOTclObjectSetClass(obj);
7885
7886  cl->nsPtr = namespacePtr;
7887  if (!softrecreate) {
7888      /* subclasses are preserved during recreate, superclasses not (since
7889         the creation statement defined the superclass, might be different
7890         the second time)
7891      */
7892      cl->sub = NULL;
7893  }
7894  cl->super = NULL;
7895  AddSuper(cl, RUNTIME_STATE(interp)->theObject);
7896
7897  cl->color = WHITE;
7898  cl->order = NULL;
7899  cl->parameters = NULL;
7900
7901  if (!softrecreate) {
7902    Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS);
7903    MEM_COUNT_ALLOC("Tcl_InitHashTable",&cl->instances);
7904  }
7905
7906  if (!recreate) {
7907    cl->opt = NULL;
7908  }
7909
7910  cl->nonposArgsTable = NULL;
7911}
7912
7913/*
7914 * class physical destruction
7915 */
7916static void
7917PrimitiveCDestroy(ClientData cd) {
7918  XOTclClass *cl = (XOTclClass*)cd;
7919  XOTclObject *obj = (XOTclObject*)cd;
7920  Tcl_Interp *interp;
7921  Tcl_Namespace *saved;
7922
7923  /*
7924   * check and latch against recurrent calls with obj->teardown
7925   */
7926  if (!obj || !obj->teardown) return;
7927  interp = obj->teardown;
7928
7929  /*
7930   * Don't destroy, if the interpreted is destroyed already
7931   * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed
7932   */
7933  if (Tcl_InterpDeleted(interp)) return;
7934
7935  /*
7936   * call and latch user destroy with obj->id if we haven't
7937   */
7938  /*fprintf(stderr,"PrimitiveCDestroy %s flags %x\n", ObjStr(obj->cmdName), obj->flags);*/
7939
7940  if (!(obj->flags & XOTCL_DESTROY_CALLED))
7941    /*fprintf(stderr,"PrimitiveCDestroy call destroy\n");*/
7942    callDestroyMethod(cd, interp, obj, 0);
7943
7944  obj->teardown = 0;
7945
7946  CleanupDestroyClass(interp, cl, 0, 0);
7947
7948  /*
7949   * handoff the primitive teardown
7950   */
7951
7952  saved = cl->nsPtr;
7953  obj->teardown = interp;
7954
7955  /*
7956   * class object destroy + physical destroy
7957   */
7958  /* fprintf(stderr,"primitive cdestroy calls primitive odestroy\n");*/
7959  PrimitiveODestroy(cd);
7960
7961  /*fprintf(stderr,"primitive cdestroy calls deletenamespace for obj %p\n", cl);*/
7962  saved->clientData = NULL;
7963  XOTcl_DeleteNamespace(interp, saved);
7964
7965  return;
7966}
7967
7968/*
7969 * class init
7970 */
7971static void
7972PrimitiveCInit(XOTclClass *cl, Tcl_Interp *interp, char *name) {
7973  TclCallFrame frame, *framePtr = &frame;
7974  Tcl_Namespace *ns;
7975
7976  /*
7977   * ensure that namespace is newly created during CleanupInitClass
7978   * ie. kill it, if it exists already
7979   */
7980  if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr,
7981                        RUNTIME_STATE(interp)->XOTclClassesNS, 0) != TCL_OK)
7982    return;
7983  ns = NSGetFreshNamespace(interp, (ClientData)cl, name);
7984  Tcl_PopCallFrame(interp);
7985
7986  CleanupInitClass(interp, cl, ns, 0, 0);
7987  return;
7988}
7989
7990/*
7991 * class create: creation of namespace + class full name
7992 * calls class object creation
7993 */
7994static XOTclClass*
7995PrimitiveCCreate(Tcl_Interp *interp, char *name, XOTclClass *class) {
7996  XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass));
7997  unsigned length;
7998  XOTclObject *obj = (XOTclObject*)cl;
7999
8000  /*fprintf(stderr, "PrimitiveCCreate Class %p %s\n", cl, name);*/
8001
8002  memset(cl, 0, sizeof(XOTclClass));
8003  MEM_COUNT_ALLOC("XOTclObject/XOTclClass", cl);
8004  /*
8005    fprintf(stderr, " +++ CLS alloc: %s\n", name);
8006  */
8007  assert(isAbsolutePath(name));
8008  length = strlen(name);
8009  /*
8010    fprintf(stderr,"Class alloc %p '%s'\n", cl, name);
8011  */
8012  /* check whether Object parent NS already exists,
8013     otherwise: error */
8014  if (!NSCheckForParent(interp, name, length)) {
8015    ckfree((char *) cl);
8016    return 0;
8017  }
8018  obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch,
8019                                 (ClientData)cl, tclDeletesClass);
8020
8021  PrimitiveOInit(obj, interp, name, class);
8022
8023  obj->cmdName = NewXOTclObjectObjName(obj, name, length);
8024  INCR_REF_COUNT(obj->cmdName);
8025  PrimitiveCInit(cl, interp, name+2);
8026
8027  objTrace("PrimitiveCCreate", obj);
8028  return cl;
8029}
8030
8031/* change XOTcl class conditionally; obj must not be NULL */
8032
8033XOTCLINLINE static int
8034changeClass(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) {
8035    assert(obj);
8036
8037    if (cl != obj->cl) {
8038        if (IsMetaClass(interp, cl)) {
8039            /* Do not allow upgrading from a class to a meta-class (in
8040               other words, don't make an object to a class). To allow
8041               this, it would be necessary to reallocate the base
8042               structures.
8043            */
8044            if (!IsMetaClass(interp, obj->cl)) {
8045              return XOTclVarErrMsg(interp, "cannot turn object into a class",
8046                                      (char *) NULL);
8047            }
8048        } else {
8049            /* The target class is not a meta class. Changing meta-class to
8050               meta-class, or class to class, or object to object is fine,
8051               but upgrading/downgrading is not allowed */
8052
8053            /*fprintf(stderr,"target class %s not a meta class, am i a class %d\n",
8054                    ObjStr(cl->object.cmdName),
8055                    XOTclObjectIsClass(obj) );*/
8056
8057            if (XOTclObjectIsClass(obj)) {
8058                return XOTclVarErrMsg(interp, "cannot turn class into an object ",
8059                                      (char *) NULL);
8060            }
8061        }
8062        (void)RemoveInstance(obj, obj->cl);
8063        AddInstance(obj, cl);
8064
8065        MixinComputeDefined(interp, obj);
8066        FilterComputeDefined(interp, obj);
8067    }
8068    return TCL_OK;
8069}
8070
8071
8072/*
8073 * Undestroy the object, reclass it, and call "cleanup" afterwards
8074 */
8075static int
8076doCleanup(Tcl_Interp *interp, XOTclObject *newobj, XOTclObject *classobj,
8077          int objc, Tcl_Obj *CONST objv[]) {
8078  int destroyed = 0, result;
8079  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
8080  XOTclCallStackContent *csc;
8081  /*
8082   * we check whether the object to be re-created is destroyed or not
8083   */
8084  for (csc = &cs->content[1]; csc <= cs->top; csc++) {
8085    if (newobj == csc->self && csc->destroyedCmd) {
8086      destroyed = 1; break;
8087    }
8088  }
8089
8090  if (destroyed)
8091    UndestroyObj(interp, newobj);
8092
8093  /*
8094   *  re-create, first ensure correct class for newobj
8095   */
8096
8097  result = changeClass(interp, newobj, (XOTclClass*) classobj);
8098
8099  if (result == TCL_OK) {
8100    /*
8101     * dispatch "cleanup"
8102     */
8103    result = callMethod((ClientData) newobj, interp, XOTclGlobalObjects[XOTE_CLEANUP], 2, 0, 0);
8104  }
8105  return result;
8106}
8107
8108/*
8109 * Std object initialization:
8110 *   call parameter default values
8111 *   apply "-" methods (call "configure" with given arguments)
8112 *   call constructor "init", if it was not called before
8113 */
8114static int
8115doObjInitialization(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) {
8116  int result, initArgsC = objc;
8117  Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); /* save the result */
8118  INCR_REF_COUNT(savedObjResult);
8119
8120  /*
8121   * Search for default values of parameter on superclasses
8122   */
8123  if (!(obj->flags & XOTCL_INIT_CALLED)) {
8124    result = callParameterMethodWithArg(obj, interp, XOTclGlobalObjects[XOTE_SEARCH_DEFAULTS],
8125                                        obj->cmdName, 3, 0, 0);
8126    if (result != TCL_OK)
8127      return result;
8128  }
8129
8130  /* clear INIT_CALLED_FLAG */
8131  obj->flags &= ~XOTCL_INIT_CALLED;
8132
8133  /*
8134   * call configure methods (starting with '-')
8135   */
8136
8137  result = callMethod((ClientData) obj, interp,
8138                      XOTclGlobalObjects[XOTE_CONFIGURE], objc, objv+2, 0);
8139  if (result != TCL_OK)
8140    return result;
8141
8142  /* check, whether init was called already, and determine where the
8143   * configure (with '-') start (we don't send them as args to
8144   * "init").  */
8145
8146  if (!(obj->flags & XOTCL_INIT_CALLED)) {
8147    int newargs;
8148    Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
8149    /*
8150     * Call the user-defined constructor 'init'
8151     */
8152    INCR_REF_COUNT(resultObj);
8153    result = Tcl_GetIntFromObj(interp, resultObj,&newargs);
8154    DECR_REF_COUNT(resultObj);
8155
8156    if (result == TCL_OK && newargs+2 < objc)
8157      initArgsC = newargs+2;
8158    result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_INIT],
8159                        initArgsC, objv+2, 0);
8160    obj->flags |= XOTCL_INIT_CALLED;
8161  }
8162
8163  if (result == TCL_OK) {
8164    Tcl_SetObjResult(interp, savedObjResult);
8165  }
8166  DECR_REF_COUNT(savedObjResult);
8167
8168  return result;
8169}
8170
8171
8172/*
8173 * experimental resolver implementation -> not used at the moment
8174 */
8175#ifdef EXPERIMENTAL_CMD_RESOLVER
8176static int
8177XOTclResolveCmd(Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr,
8178                int flags, Tcl_Command *rPtr) {
8179
8180  Tcl_Namespace *nsPtr[2], *cxtNsPtr;
8181  char *simpleName;
8182  register Tcl_HashEntry *entryPtr;
8183  register Tcl_Command cmd;
8184  register int search;
8185
8186  /*fprintf(stderr, "  ***%s->%s\n", contextNsPtr->fullName, name);*/
8187
8188  /*
8189   * Find the namespace(s) that contain the command.
8190   */
8191  if (flags & TCL_GLOBAL_ONLY) {
8192    cxtNsPtr = Tcl_GetGlobalNamespace(interp);
8193  }
8194  else if (contextNsPtr) {
8195    cxtNsPtr = contextNsPtr;
8196  }
8197  else {
8198    cxtNsPtr = Tcl_GetCurrentNamespace(interp);
8199  }
8200
8201  TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,flags,
8202                             &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
8203
8204  /*fprintf(stderr, "  ***Found %s, %s\n", nsPtr[0]->fullName, nsPtr[0]->fullName);*/
8205
8206  /*
8207   * Look for the command in the command table of its namespace.
8208   * Be sure to check both possible search paths: from the specified
8209   * namespace context and from the global namespace.
8210   */
8211
8212  cmd = NULL;
8213  for (search = 0;  (search < 2) && (cmd == NULL);  search++) {
8214    if (nsPtr[search] && simpleName) {
8215      cmdTable = Tcl_Namespace_cmdTable(nsPtr[search]);
8216      entryPtr = XOTcl_FindHashEntry(cmdTable, simpleName);
8217      if (entryPtr) {
8218        cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
8219      }
8220    }
8221  }
8222  if (cmd) {
8223    Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd);
8224    if (NSisXOTclNamespace(cxtNsPtr) &&
8225        objProc != XOTclObjDispatch &&
8226        objProc != XOTclNextObjCmd &&
8227        objProc != XOTclGetSelfObjCmd) {
8228
8229      /*
8230       * the cmd is defined in an XOTcl object or class namespace, but
8231       * not an object & not self/next -> redispatch in
8232       * global namespace
8233       */
8234      cmd = 0;
8235      nsPtr[0] = Tcl_GetGlobalNamespace(interp);
8236      if (nsPtr[0] && simpleName) {
8237        cmdTable = Tcl_Namespace_cmdTable(nsPtr[0]);
8238        if ((entryPtr = XOTcl_FindHashEntry(cmdTable, simpleName))) {
8239          cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
8240        }
8241      }
8242
8243      /*
8244        XOTclStackDump(interp);
8245        XOTclCallStackDump(interp);
8246      */
8247    }
8248    *rPtr = cmd;
8249    return TCL_OK;
8250  }
8251
8252  return TCL_CONTINUE;
8253}
8254static int
8255XOTclResolveVar(Tcl_Interp *interp, char *name, Tcl_Namespace *context,
8256                Tcl_ResolvedVarInfo *rPtr) {
8257  /*fprintf(stderr, "Resolving %s in %s\n", name, context->fullName);*/
8258
8259  return TCL_CONTINUE;
8260}
8261#endif
8262
8263/*
8264 * object method implementations
8265 */
8266
8267static int
8268XOTclODestroyMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8269  XOTclObject *obj = (XOTclObject*)cd;
8270
8271  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8272  if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, "destroy");
8273  PRINTOBJ("XOTclODestroyMethod", obj);
8274
8275  /*
8276   * call instdestroy for [self]
8277   */
8278  return XOTclCallMethodWithArgs((ClientData)obj->cl, interp,
8279                                 XOTclGlobalObjects[XOTE_INSTDESTROY], obj->cmdName,
8280                                 objc, objv+1, 0);
8281}
8282
8283static int
8284XOTclOCleanupMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8285  XOTclObject *obj = (XOTclObject*)cd;
8286  XOTclClass  *cl  = XOTclObjectToClass(obj);
8287  char *fn;
8288  int softrecreate;
8289  Tcl_Obj *savedNameObj;
8290
8291#if defined(OBJDELETION_TRACE)
8292  fprintf(stderr,"+++ XOTclOCleanupMethod\n");
8293#endif
8294
8295  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8296  if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, "cleanup");
8297  PRINTOBJ("XOTclOCleanupMethod", obj);
8298
8299  fn = ObjStr(obj->cmdName);
8300  savedNameObj = obj->cmdName;
8301  INCR_REF_COUNT(savedNameObj);
8302
8303  /* save and pass around softrecreate*/
8304  softrecreate = obj->flags & XOTCL_RECREATE && RUNTIME_STATE(interp)->doSoftrecreate;
8305
8306  CleanupDestroyObject(interp, obj, softrecreate);
8307  CleanupInitObject(interp, obj, obj->cl, obj->nsPtr, softrecreate);
8308
8309  if (cl) {
8310    CleanupDestroyClass(interp, cl, softrecreate, 1);
8311    CleanupInitClass(interp, cl, cl->nsPtr, softrecreate, 1);
8312  }
8313
8314  DECR_REF_COUNT(savedNameObj);
8315
8316  return TCL_OK;
8317}
8318
8319static int
8320XOTclOIsClassMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8321  Tcl_Obj *className;
8322  XOTclObject *obj = (XOTclObject*)cd, *o;
8323  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8324  if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName,
8325                                                     "isclass ?className?");
8326  className = (objc == 2) ? objv[1] : obj->cmdName;
8327
8328  Tcl_SetIntObj(Tcl_GetObjResult(interp),
8329                (XOTclObjConvertObject(interp, className, &o) == TCL_OK
8330                 && XOTclObjectIsClass(o) ));
8331  return TCL_OK;
8332}
8333
8334static int
8335XOTclOIsObjectMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8336  XOTclObject *obj = (XOTclObject*)cd, *o;
8337
8338  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8339  if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "isobject <objName>");
8340
8341  if (XOTclObjConvertObject(interp, objv[1], &o) == TCL_OK) {
8342    Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
8343  } else {
8344    Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
8345  }
8346  return TCL_OK;
8347}
8348
8349static int
8350IsMetaClass(Tcl_Interp *interp, XOTclClass *cl) {
8351  /* check if cl is a meta-class by checking is Class is a superclass of cl*/
8352  XOTclClasses *pl, *checkList = NULL, *mixinClasses = NULL, *mc;
8353  int hasMCM = 0;
8354
8355  if (cl == RUNTIME_STATE(interp)->theClass)
8356    return 1;
8357
8358  for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) {
8359    if (pl->cl == RUNTIME_STATE(interp)->theClass)
8360      return 1;
8361  }
8362
8363  for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) {
8364    XOTclClassOpt *clopt = pl->cl->opt;
8365    if (clopt && clopt->instmixins) {
8366      MixinComputeOrderFullList(interp,
8367                                &clopt->instmixins,
8368                                &mixinClasses,
8369                                &checkList, 0);
8370    }
8371  }
8372
8373  for (mc=mixinClasses; mc; mc = mc->next) {
8374    /*fprintf(stderr,"- got %s\n", ObjStr(mc->cl->object.cmdName));*/
8375    if (isSubType(mc->cl, RUNTIME_STATE(interp)->theClass)) {
8376      hasMCM = 1;
8377      break;
8378    }
8379  }
8380  XOTclFreeClasses(mixinClasses);
8381  XOTclFreeClasses(checkList);
8382  /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n",
8383    hasMCM, mixinClasses);*/
8384
8385  return hasMCM;
8386}
8387
8388static int
8389XOTclOIsMetaClassMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8390  XOTclObject *obj = (XOTclObject*)cd, *o;
8391  Tcl_Obj *className;
8392  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8393  if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName,
8394                                                     "ismetaclass ?metaClassName?");
8395
8396  className = (objc == 2) ? objv[1] : obj->cmdName;
8397
8398  if (XOTclObjConvertObject(interp, className, &o) == TCL_OK
8399      && XOTclObjectIsClass(o)
8400      && IsMetaClass(interp, (XOTclClass*)o)) {
8401    Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
8402  } else {
8403    Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
8404  }
8405  return TCL_OK;
8406}
8407
8408
8409static int
8410isSubType(XOTclClass *subcl, XOTclClass *cl) {
8411  XOTclClasses *t;
8412  int success = 1;
8413  assert(cl && subcl);
8414
8415  if (cl != subcl) {
8416    success = 0;
8417    for (t = ComputeOrder(subcl, subcl->order, Super); t && t->cl; t = t->next) {
8418      if (t->cl == cl) {
8419        success = 1;
8420        break;
8421      }
8422    }
8423  }
8424  return success;
8425}
8426
8427
8428
8429static int
8430XOTclOIsTypeMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8431  XOTclObject *obj = (XOTclObject*)cd;
8432  XOTclClass *cl;
8433  int success = 0;
8434
8435  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8436  if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "istype <className>");
8437  if (obj->cl && GetXOTclClassFromObj(interp, objv[1],&cl, 1) == TCL_OK) {
8438    success = isSubType(obj->cl, cl);
8439  }
8440  Tcl_ResetResult(interp);
8441  Tcl_SetIntObj(Tcl_GetObjResult(interp), success);
8442  return TCL_OK;
8443}
8444
8445static int
8446hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) {
8447
8448  if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
8449    MixinComputeDefined(interp, obj);
8450
8451  if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) {
8452    XOTclCmdList *ml;
8453    for (ml = obj->mixinOrder; ml; ml = ml->next) {
8454      XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr);
8455      if (mixin == cl) {
8456        return 1;
8457      }
8458    }
8459  }
8460  return 0;
8461}
8462
8463static int
8464XOTclOIsMixinMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8465  XOTclObject *obj = (XOTclObject*)cd;
8466  XOTclClass *cl;
8467  int success = 0;
8468
8469  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8470  if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "ismixin <className>");
8471
8472  if (GetXOTclClassFromObj(interp, objv[1],&cl, 1) == TCL_OK) {
8473    success = hasMixin(interp, obj, cl);
8474  }
8475  Tcl_ResetResult(interp);
8476  Tcl_SetIntObj(Tcl_GetObjResult(interp), success);
8477  return TCL_OK;
8478}
8479
8480static int
8481XOTclOExistsMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8482  XOTclObject *obj = (XOTclObject*)cd;
8483
8484  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8485  if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "exists var");
8486
8487  Tcl_SetIntObj(Tcl_GetObjResult(interp),
8488                varExists(interp, obj, ObjStr(objv[1]), NULL, 1, 1));
8489  return TCL_OK;
8490}
8491
8492static int
8493countModifiers(int objc, Tcl_Obj * CONST objv[]) {
8494  int i, count = 0;
8495  char *to;
8496  for (i = 2; i < objc; i++) {
8497    to = ObjStr(objv[i]);
8498    if (to[0] == '-') {
8499      count++;
8500      /* '--' stops modifiers */
8501      if (to[1] == '-') break;
8502    }
8503  }
8504  return count;
8505}
8506
8507static int
8508checkForModifier(Tcl_Obj * CONST objv[], int numberModifiers, char *modifier) {
8509  int i;
8510  if (numberModifiers == 0) return 0;
8511  for (i = 2; i-2 < numberModifiers; i++) {
8512    char *ov = ObjStr(objv[i]);
8513    /* all start with a "-", so there must be a ov[1] */
8514    if (ov[1] == modifier[1] && !strcmp(ov, modifier))
8515      return 1;
8516  }
8517  return 0;
8518}
8519
8520static int
8521XOTclOInfoMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
8522  XOTclObject *obj = (XOTclObject*)cd;
8523  Tcl_Namespace *nsp = obj->nsPtr;
8524  char *cmd, *pattern;
8525  int modifiers = 0;
8526  XOTclObjectOpt *opt;
8527
8528  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8529  if (objc < 2)
8530    return XOTclObjErrArgCnt(interp, obj->cmdName, "info <opt> ?args?");
8531
8532  opt = obj->opt;
8533  cmd = ObjStr(objv[1]);
8534  pattern = (objc > 2) ? ObjStr(objv[2]) : 0;
8535
8536  /*fprintf(stderr, "OInfo cmd=%s, obj=%s, nsp=%p\n", cmd, ObjStr(obj->cmdName), nsp);*/
8537
8538  /*
8539   * check for "-" modifiers
8540   */
8541  if (pattern && *pattern == '-') {
8542    modifiers = countModifiers(objc, objv);
8543    pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0;
8544  }
8545
8546  switch (*cmd) {
8547  case 'a':
8548    if (isArgsString(cmd)) {
8549      if (objc != 3 || modifiers > 0)
8550        return XOTclObjErrArgCnt(interp, obj->cmdName, "info args <proc>");
8551      if (obj->nonposArgsTable) {
8552        XOTclNonposArgs *nonposArgs =
8553          NonposArgsGet(obj->nonposArgsTable, pattern);
8554        if (nonposArgs) {
8555          return ListArgsFromOrdinaryArgs(interp, nonposArgs);
8556        }
8557      }
8558      if (nsp)
8559        return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern);
8560      else
8561        return TCL_OK;
8562    }
8563    break;
8564
8565  case 'b':
8566    if (!strcmp(cmd, "body")) {
8567      if (objc != 3 || modifiers > 0)
8568        return XOTclObjErrArgCnt(interp, obj->cmdName, "info body <proc>");
8569      if (nsp)
8570        return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern);
8571      else
8572        return TCL_OK;
8573    }
8574    break;
8575
8576  case 'c':
8577    if (isClassString(cmd)) {
8578      if (objc > 3 || modifiers > 0 || pattern)
8579        return XOTclObjErrArgCnt(interp, obj->cmdName, "info class");
8580      return ListClass(interp, obj, objc, objv);
8581    } else if (!strcmp(cmd, "commands")) {
8582      if (objc > 3 || modifiers > 0)
8583        return XOTclObjErrArgCnt(interp, obj->cmdName, "info commands ?pattern?");
8584      if (nsp)
8585        return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern);
8586      else
8587        return TCL_OK;
8588    } else if (!strcmp(cmd, "children")) {
8589      if (objc > 3 || modifiers > 0)
8590        return XOTclObjErrArgCnt(interp, obj->cmdName, "info children ?pattern?");
8591      return ListChildren(interp, obj, pattern, 0);
8592    } else if (!strcmp(cmd, "check")) {
8593      if (objc != 2 || modifiers > 0)
8594        return XOTclObjErrArgCnt(interp, obj->cmdName, "info check");
8595      return AssertionListCheckOption(interp, obj);
8596    }
8597    break;
8598
8599  case 'd':
8600    if (!strcmp(cmd, "default")) {
8601      if (objc != 5 || modifiers > 0)
8602        return XOTclObjErrArgCnt(interp, obj->cmdName, "info default <proc> <arg> <var>");
8603
8604      if (obj->nonposArgsTable) {
8605        XOTclNonposArgs *nonposArgs =
8606          NonposArgsGet(obj->nonposArgsTable, pattern);
8607        if (nonposArgs) {
8608          return ListDefaultFromOrdinaryArgs(interp, pattern,  nonposArgs,
8609                                             ObjStr(objv[3]), objv[4]);
8610        }
8611      }
8612      if (nsp)
8613        return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern,
8614                               ObjStr(objv[3]), objv[4]);
8615      else
8616        return TCL_OK;
8617    }
8618    break;
8619
8620  case 'f':
8621    if (!strcmp(cmd, "filter")) {
8622      int withGuards = 0, withOrder = 0;
8623      if (objc-modifiers > 3)
8624        return XOTclObjErrArgCnt(interp, obj->cmdName,
8625                                 "info filter ?-guards? ?-order? ?pattern?");
8626      if (modifiers > 0) {
8627        withGuards = checkForModifier(objv, modifiers, "-guards");
8628        withOrder = checkForModifier(objv, modifiers, "-order");
8629
8630        if (withGuards == 0 && withOrder == 0)
8631          return XOTclVarErrMsg(interp, "info filter: unknown modifier ",
8632                                ObjStr(objv[2]), (char *) NULL);
8633        /*
8634          if (withGuards && withOrder)
8635          return XOTclVarErrMsg(interp, "info filter: cannot use -guards and -order together",
8636          ObjStr(objv[2]), (char *) NULL);
8637        */
8638      }
8639
8640      if (withOrder) {
8641        if (!(obj->flags & XOTCL_FILTER_ORDER_VALID))
8642          FilterComputeDefined(interp, obj);
8643        return FilterInfo(interp, obj->filterOrder, pattern, withGuards, 1);
8644      }
8645
8646      return opt ? FilterInfo(interp, opt->filters, pattern, withGuards, 0) : TCL_OK;
8647
8648    } else if (!strcmp(cmd, "filterguard")) {
8649      if (objc != 3 || modifiers > 0)
8650        return XOTclObjErrArgCnt(interp, obj->cmdName, "info filterguard filter");
8651      return opt ? GuardList(interp, opt->filters, pattern) : TCL_OK;
8652    } else if (!strcmp(cmd, "forward")) {
8653      int argc = objc-modifiers;
8654      int definition;
8655      if (argc < 2 || argc > 3)
8656        return XOTclObjErrArgCnt(interp, obj->cmdName,
8657                                 "info forward ?-definition name? ?pattern?");
8658      definition = checkForModifier(objv, modifiers, "-definition");
8659      if (definition && argc < 3)
8660        return XOTclObjErrArgCnt(interp, obj->cmdName,
8661                                 "info forward ?-definition name? ?pattern?");
8662      if (nsp) {
8663	return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition);
8664      } else {
8665        return TCL_OK;
8666      }
8667    }
8668
8669    break;
8670
8671  case 'h':
8672    if (!strcmp(cmd, "hasNamespace")) {
8673      Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL);
8674      return TCL_OK;
8675    }
8676    break;
8677
8678  case 'i':
8679    if (!strcmp(cmd, "invar")) {
8680      if (objc != 2 || modifiers > 0)
8681        return XOTclObjErrArgCnt(interp, obj->cmdName, "info invar");
8682      if (opt && opt->assertions)
8683        Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants));
8684      return TCL_OK;
8685    } else if (!strcmp(cmd, "info")) {
8686      if (objc > 2 || modifiers > 0)
8687        return XOTclObjErrArgCnt(interp, obj->cmdName, "info info");
8688      return ListInfo(interp, GetXOTclClassFromObj(interp, obj->cmdName, NULL, 0) == TCL_OK);
8689    }
8690    break;
8691
8692  case 'm':
8693    if (!strcmp(cmd, "mixin")) {
8694      int withOrder = 0, withGuards = 0, rc;
8695      XOTclObject *matchObject;
8696      Tcl_DString ds, *dsPtr = &ds;
8697
8698      if (objc-modifiers > 3)
8699        return XOTclObjErrArgCnt(interp, obj->cmdName,
8700                                 "info mixin ?-guards? ?-order? ?class?");
8701      if (modifiers > 0) {
8702        withOrder = checkForModifier(objv, modifiers, "-order");
8703        withGuards = checkForModifier(objv, modifiers, "-guards");
8704
8705        if (withOrder == 0 && withGuards == 0)
8706          return XOTclVarErrMsg(interp, "info mixin: unknown modifier . ",
8707                                ObjStr(objv[2]), (char *) NULL);
8708      }
8709
8710      DSTRING_INIT(dsPtr);
8711      if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
8712        return TCL_OK;
8713      }
8714      if (withOrder) {
8715        if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
8716          MixinComputeDefined(interp, obj);
8717        rc = MixinInfo(interp, obj->mixinOrder, pattern, withGuards, matchObject);
8718      } else {
8719        rc = opt ? MixinInfo(interp, opt->mixins, pattern, withGuards, matchObject) : TCL_OK;
8720      }
8721      DSTRING_FREE(dsPtr);
8722      return rc;
8723
8724    } else if (!strcmp(cmd, "mixinguard")) {
8725      if (objc != 3 || modifiers > 0)
8726        return XOTclObjErrArgCnt(interp, obj->cmdName, "info mixinguard mixin");
8727
8728      return opt ? GuardList(interp, opt->mixins, pattern) : TCL_OK;
8729    } else if (!strcmp(cmd, "methods")) {
8730      int noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0;
8731      if (objc-modifiers > 3)
8732        return XOTclObjErrArgCnt(interp, obj->cmdName,
8733                                 "info methods ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pattern?");
8734      if (modifiers > 0) {
8735        noprocs = checkForModifier(objv, modifiers, "-noprocs");
8736        nocmds = checkForModifier(objv, modifiers, "-nocmds");
8737        nomixins = checkForModifier(objv, modifiers, "-nomixins");
8738        inContext = checkForModifier(objv, modifiers, "-incontext");
8739      }
8740      return ListMethods(interp, obj, pattern, noprocs, nocmds, nomixins, inContext);
8741    }
8742#ifdef XOTCL_METADATA
8743    else  if (!strcmp(cmd, "metadata")) {
8744      if (objc > 3 || modifiers > 0)
8745        return XOTclObjErrArgCnt(interp, obj->cmdName, "info metadata ?pattern?");
8746      return ListKeys(interp, &obj->metaData, pattern);
8747    }
8748#endif
8749    break;
8750
8751  case 'n':
8752    if (!strcmp(cmd, "nonposargs")) {
8753      if (objc != 3 || modifiers > 0)
8754        return XOTclObjErrArgCnt(interp, obj->cmdName, "info nonposargs <proc>");
8755      if (obj->nonposArgsTable) {
8756        XOTclNonposArgs *nonposArgs =
8757          NonposArgsGet(obj->nonposArgsTable, pattern);
8758        if (nonposArgs) {
8759          Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs));
8760        }
8761      }
8762      return TCL_OK;
8763    }
8764    break;
8765
8766  case 'p':
8767    if (!strcmp(cmd, "procs")) {
8768      if (objc > 3 || modifiers > 0)
8769        return XOTclObjErrArgCnt(interp, obj->cmdName, "info procs ?pattern?");
8770      if (nsp)
8771        return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern,
8772                              /*noProcs*/ 0, /*noCmds*/ 1, /* noDups */ 0,
8773			      /* onlyForward */0, /* onlySetter */ 0 );
8774      else
8775        return TCL_OK;
8776    } else if (!strcmp(cmd, "parent")) {
8777      if (objc > 2 || modifiers > 0)
8778        return XOTclObjErrArgCnt(interp, obj->cmdName, "info parent");
8779      return ListParent(interp, obj);
8780    } else if (!strcmp(cmd, "pre")) {
8781      XOTclProcAssertion *procs;
8782      if (objc != 3 || modifiers > 0)
8783        return XOTclObjErrArgCnt(interp, obj->cmdName, "info pre <proc>");
8784      if (opt) {
8785        procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2]));
8786        if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre));
8787      }
8788      return TCL_OK;
8789    } else if (!strcmp(cmd, "post")) {
8790      XOTclProcAssertion *procs;
8791      if (objc != 3 || modifiers > 0)
8792        return XOTclObjErrArgCnt(interp, obj->cmdName, "info post <proc>");
8793      if (opt) {
8794        procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2]));
8795        if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post));
8796      }
8797      return TCL_OK;
8798    } else if (!strcmp(cmd, "precedence")) {
8799      int intrinsic = 0;
8800      if (objc-modifiers > 3 || modifiers > 1)
8801          return XOTclObjErrArgCnt(interp, obj->cmdName, "info precedence ?-intrinsic? ?pattern?");
8802
8803      intrinsic = checkForModifier(objv, modifiers, "-intrinsic");
8804      return ListPrecedence(interp, obj, pattern, intrinsic);
8805    } else if (!strcmp(cmd, "parametercmd")) {
8806      int argc = objc-modifiers;
8807      if (argc < 2)
8808        return XOTclObjErrArgCnt(interp, obj->cmdName,
8809                                 "info parametercmd ?pattern?");
8810      if (nsp) {
8811	return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, 1, 0, 0, 0, 1);
8812      } else {
8813        return TCL_OK;
8814      }
8815    }
8816
8817    break;
8818
8819  case 'v':
8820    if (!strcmp(cmd, "vars")) {
8821      if (objc > 3 || modifiers > 0)
8822        return XOTclObjErrArgCnt(interp, obj->cmdName, "info vars ?pattern?");
8823      return ListVars(interp, obj, pattern);
8824    }
8825    break;
8826  }
8827  return XOTclErrBadVal(interp, "info",
8828                        "an info option (use 'info info' to list all info options)", cmd);
8829}
8830
8831
8832static int
8833XOTclOProcMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
8834  XOTclObject *obj = (XOTclObject*)cd;
8835  char *argStr, *bdyStr, *name;
8836  XOTclObjectOpt *opt;
8837  int incr = 0, result = TCL_OK;
8838
8839  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8840  if (objc < 4 || objc > 7)
8841    return XOTclObjErrArgCnt(interp, obj->cmdName,
8842                             "proc name ?non-positional-args? args body ?preAssertion postAssertion?");
8843
8844  if (objc == 5 || objc == 7) {
8845    incr = 1;
8846  }
8847
8848  argStr = ObjStr(objv[2 + incr]);
8849  bdyStr = ObjStr(objv[3 + incr]);
8850  name = ObjStr(objv[1 + incr]);
8851
8852  if (*argStr == 0 && *bdyStr == 0) {
8853    opt = obj->opt;
8854    if (opt)
8855      AssertionRemoveProc(opt->assertions, name);
8856    if (obj->nsPtr)
8857      NSDeleteCmd(interp, obj->nsPtr, name);
8858  } else {
8859    XOTclAssertionStore *aStore = NULL;
8860    if (objc > 5) {
8861      opt = XOTclRequireObjectOpt(obj);
8862      if (!opt->assertions)
8863        opt->assertions = AssertionCreateStore();
8864      aStore = opt->assertions;
8865    }
8866    requireObjNamespace(interp, obj);
8867    result = MakeProc(obj->nsPtr, aStore, &(obj->nonposArgsTable),
8868                      interp, objc, (Tcl_Obj **) objv, obj);
8869  }
8870
8871  /* could be a filter => recompute filter order */
8872  FilterComputeDefined(interp, obj);
8873
8874  return result;
8875}
8876
8877static int
8878XOTclONoinitMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
8879  XOTclObject *obj = (XOTclObject*)cd;
8880
8881  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
8882  if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, "noninit");
8883
8884  obj->flags |= XOTCL_INIT_CALLED;
8885
8886  return TCL_OK;
8887}
8888
8889Tcl_Obj*
8890XOTclOSetInstVar(XOTcl_Object *obj, Tcl_Interp *interp,
8891                 Tcl_Obj *name, Tcl_Obj *value, int flgs) {
8892  return XOTclOSetInstVar2(obj, interp, name, (Tcl_Obj *)NULL, value, (flgs|TCL_PARSE_PART1));
8893}
8894
8895Tcl_Obj*
8896XOTclOGetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name, int flgs) {
8897  return XOTclOGetInstVar2(obj, interp, name, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1));
8898}
8899
8900int
8901XOTclUnsetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, char *name, int flgs) {
8902  return XOTclUnsetInstVar2 (obj, interp, name,(char *)NULL, flgs);
8903}
8904
8905extern int
8906XOTclCreateObject(Tcl_Interp *interp, Tcl_Obj *name, XOTcl_Class *cli) {
8907  XOTclClass *cl = (XOTclClass*) cli;
8908  int result;
8909  INCR_REF_COUNT(name);
8910  result = XOTclCallMethodWithArgs((ClientData)cl, interp,
8911                                   XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0);
8912  DECR_REF_COUNT(name);
8913  return result;
8914}
8915
8916extern int
8917XOTclCreateClass(Tcl_Interp *interp, Tcl_Obj *name, XOTcl_Class *cli) {
8918  XOTclClass *cl = (XOTclClass*) cli;
8919  int result;
8920  INCR_REF_COUNT(name);
8921  result = XOTclCallMethodWithArgs((ClientData)cl, interp,
8922                                   XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0);
8923  DECR_REF_COUNT(name);
8924  return result;
8925}
8926
8927int
8928XOTclDeleteObject(Tcl_Interp *interp, XOTcl_Object *obji) {
8929  XOTclObject *obj = (XOTclObject*) obji;
8930  return callMethod((ClientData)obj, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0);
8931}
8932
8933int
8934XOTclDeleteClass(Tcl_Interp *interp, XOTcl_Class *cli) {
8935  XOTclClass *cl = (XOTclClass*) cli;
8936  return callMethod((ClientData)cl, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, 0);
8937}
8938
8939extern Tcl_Obj*
8940XOTclOSetInstVar2(XOTcl_Object *obji, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
8941                  Tcl_Obj *value, int flgs) {
8942  XOTclObject *obj = (XOTclObject*) obji;
8943  Tcl_Obj *result;
8944  XOTcl_FrameDecls;
8945
8946  XOTcl_PushFrame(interp, obj);
8947  if (obj->nsPtr)
8948    flgs |= TCL_NAMESPACE_ONLY;
8949
8950  result = Tcl_ObjSetVar2(interp, name1, name2, value, flgs);
8951  XOTcl_PopFrame(interp, obj);
8952  return result;
8953}
8954
8955extern int
8956XOTclUnsetInstVar2(XOTcl_Object *obji, Tcl_Interp *interp, char *name1, char *name2,
8957                   int flgs) {
8958  XOTclObject *obj = (XOTclObject*) obji;
8959  int result;
8960  XOTcl_FrameDecls;
8961
8962  XOTcl_PushFrame(interp, obj);
8963  if (obj->nsPtr)
8964    flgs |= TCL_NAMESPACE_ONLY;
8965
8966  result = Tcl_UnsetVar2(interp, name1, name2, flgs);
8967  XOTcl_PopFrame(interp, obj);
8968  return result;
8969}
8970
8971static int
8972GetInstVarIntoCurrentScope(Tcl_Interp *interp, XOTclObject *obj,
8973                           Tcl_Obj *varName, Tcl_Obj *newName) {
8974  Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr;
8975  int new;
8976  Tcl_CallFrame *varFramePtr;
8977  TclVarHashTable *tablePtr;
8978  XOTcl_FrameDecls;
8979
8980  int flgs = TCL_LEAVE_ERR_MSG |
8981    /* PARSE_PART1 needed for 8.0.5 */ TCL_PARSE_PART1;
8982
8983  XOTcl_PushFrame(interp, obj);
8984  if (obj->nsPtr) {
8985    flgs = flgs|TCL_NAMESPACE_ONLY;
8986  }
8987
8988  otherPtr = XOTclObjLookupVar(interp, varName, (char *) NULL, flgs, "define",
8989                               /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
8990  XOTcl_PopFrame(interp, obj);
8991
8992  if (otherPtr == NULL) {
8993    return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName),
8994                          ": can't find variable on ", ObjStr(obj->cmdName),
8995                          (char *) NULL);
8996  }
8997
8998  /*
8999   * if newName == NULL -> there is no alias, use varName
9000   * as target link name
9001   */
9002  if (newName == NULL) {
9003    /*
9004     * Variable link into namespace cannot be an element in an array.
9005     * see Tcl_VariableObjCmd ...
9006     */
9007    if (arrayPtr) {
9008      return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName),
9009                            " on ", ObjStr(obj->cmdName),
9010                            ": variable cannot be an element in an array;",
9011                            " use an alias or objeval.", (char *) NULL);
9012    }
9013
9014    newName = varName;
9015  }
9016
9017  varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
9018
9019  /*
9020   * If we are executing inside a Tcl procedure, create a local
9021   * variable linked to the new namespace variable "varName".
9022   */
9023  if (varFramePtr && Tcl_CallFrame_isProcCallFrame(varFramePtr)) {
9024    Proc *procPtr           = Tcl_CallFrame_procPtr(varFramePtr);
9025    int localCt             = procPtr->numCompiledLocals;
9026    CompiledLocal *localPtr = procPtr->firstLocalPtr;
9027    Var *localVarPtr        = Tcl_CallFrame_compiledLocals(varFramePtr);
9028    char *newNameString     = ObjStr(newName);
9029    int i, nameLen          = strlen(newNameString);
9030
9031    for (i = 0;  i < localCt;  i++) {    /* look in compiled locals */
9032
9033      /* fprintf(stderr,"%d of %d %s flags %x not isTemp %d\n", i, localCt,
9034         localPtr->name, localPtr->flags,
9035         !TclIsCompiledLocalTemporary(localPtr));*/
9036
9037      if (!TclIsCompiledLocalTemporary(localPtr)) {
9038        char *localName = localPtr->name;
9039        if ((newNameString[0] == localName[0])
9040            && (nameLen == localPtr->nameLength)
9041            && (strcmp(newNameString, localName) == 0)) {
9042          varPtr = getNthVar(localVarPtr, i);
9043          new = 0;
9044          break;
9045        }
9046      }
9047      localPtr = localPtr->nextPtr;
9048    }
9049
9050    if (varPtr == NULL) {	/* look in frame's local var hashtable */
9051      tablePtr = Tcl_CallFrame_varTablePtr(varFramePtr);
9052      if (tablePtr == NULL) {
9053        tablePtr = (TclVarHashTable *) ckalloc(varHashTableSize);
9054        InitVarHashTable(tablePtr, NULL);
9055        Tcl_CallFrame_varTablePtr(varFramePtr) = tablePtr;
9056      }
9057      varPtr = VarHashCreateVar(tablePtr, newName, &new);
9058    }
9059    /*
9060     * if we define an alias (newName != varName), be sure that
9061     * the target does not exist already
9062     */
9063    if (!new) {
9064      if (varPtr == otherPtr)
9065        return XOTclVarErrMsg(interp, "can't instvar to variable itself",
9066                              (char *) NULL);
9067
9068      if (TclIsVarLink(varPtr)) {
9069        /* we try to make the same instvar again ... this is ok */
9070        Var *linkPtr = valueOfVar(Var, varPtr, linkPtr);
9071        if (linkPtr == otherPtr) {
9072          return TCL_OK;
9073        }
9074
9075        /*fprintf(stderr, "linkvar flags=%x\n", linkPtr->flags);
9076          Tcl_Panic("new linkvar %s... When does this happen?", newNameString, NULL);*/
9077
9078        /* We have already a variable with the same name imported
9079           from a different object. Get rid of this old variable
9080        */
9081        VarHashRefCount(linkPtr)--;
9082        if (TclIsVarUndefined(linkPtr)) {
9083          CleanupVar(linkPtr, (Var *) NULL);
9084        }
9085
9086      } else if (!TclIsVarUndefined(varPtr)) {
9087        return XOTclVarErrMsg(interp, "variable '", ObjStr(newName),
9088                              "' exists already", (char *) NULL);
9089      } else if (TclIsVarTraced(varPtr)) {
9090        return XOTclVarErrMsg(interp, "variable '", ObjStr(newName),
9091                              "' has traces: can't use for instvar", (char *) NULL);
9092      }
9093    }
9094
9095    TclSetVarLink(varPtr);
9096    TclClearVarUndefined(varPtr);
9097#if FORWARD_COMPATIBLE
9098    if (forwardCompatibleMode) {
9099      Var85 *vPtr = (Var85 *)varPtr;
9100      vPtr->value.linkPtr = (Var85 *)otherPtr;
9101    } else {
9102      varPtr->value.linkPtr = otherPtr;
9103    }
9104#else
9105    varPtr->value.linkPtr = otherPtr;
9106#endif
9107    VarHashRefCount(otherPtr)++;
9108
9109    /*
9110      {
9111      Var85 *p = (Var85 *)varPtr;
9112      fprintf(stderr,"defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n",
9113      ObjStr(newName), ObjStr(obj->cmdName), forwardCompatibleMode,
9114      varFlags(varPtr),
9115      TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr));
9116      }
9117    */
9118  }
9119  return TCL_OK;
9120}
9121
9122static int
9123XOTclOInstVarMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
9124
9125extern int
9126XOTclInstVar(XOTcl_Object *obji, Tcl_Interp *interp, char *name, char *destName) {
9127  XOTclObject *obj = (XOTclObject*) obji;
9128  int result;
9129  Tcl_Obj *alias = NULL;
9130  ALLOC_ON_STACK(Tcl_Obj*, 2, objv);
9131
9132  objv[0] = XOTclGlobalObjects[XOTE_INSTVAR];
9133  objv[1] = Tcl_NewStringObj(name, -1);
9134  INCR_REF_COUNT(objv[1]);
9135
9136  if (destName) {
9137    alias = Tcl_NewStringObj(destName, -1);
9138    INCR_REF_COUNT(alias);
9139    Tcl_ListObjAppendElement(interp, objv[1], alias);
9140  }
9141
9142  result = XOTclOInstVarMethod((ClientData) obj, interp, 2, objv);
9143
9144  if (destName) {
9145    DECR_REF_COUNT(alias);
9146  }
9147  DECR_REF_COUNT(objv[1]);
9148  FREE_ON_STACK(Tcl_Obj *, objv);
9149  return result;
9150}
9151
9152extern void
9153XOTclRemovePMethod(Tcl_Interp *interp, XOTcl_Object *obji, char *nm) {
9154  XOTclObject *obj = (XOTclObject*) obji;
9155  if (obj->nsPtr)
9156    NSDeleteCmd(interp, obj->nsPtr, nm);
9157}
9158
9159extern void
9160XOTclRemoveIMethod(Tcl_Interp *interp, XOTcl_Class *cli, char *nm) {
9161  XOTclClass *cl = (XOTclClass*) cli;
9162  NSDeleteCmd(interp, cl->nsPtr, nm);
9163}
9164
9165/*
9166 * obj/cl ClientData setter/getter
9167 */
9168extern void
9169XOTclSetObjClientData(XOTcl_Object *obji, ClientData data) {
9170  XOTclObject *obj = (XOTclObject*) obji;
9171  XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj);
9172  opt->clientData = data;
9173}
9174extern ClientData
9175XOTclGetObjClientData(XOTcl_Object *obji) {
9176  XOTclObject *obj = (XOTclObject*) obji;
9177  return (obj && obj->opt) ? obj->opt->clientData : 0;
9178}
9179extern void
9180XOTclSetClassClientData(XOTcl_Class *cli, ClientData data) {
9181  XOTclClass *cl = (XOTclClass*) cli;
9182  XOTclRequireClassOpt(cl);
9183  cl->opt->clientData = data;
9184}
9185extern ClientData
9186XOTclGetClassClientData(XOTcl_Class *cli) {
9187  XOTclClass *cl = (XOTclClass*) cli;
9188  return (cl && cl->opt) ? cl->opt->clientData : 0;
9189}
9190
9191static int
9192setInstVar(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *value) {
9193  Tcl_Obj *result;
9194  int flags = (obj->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG;
9195  XOTcl_FrameDecls;
9196  XOTcl_PushFrame(interp, obj);
9197
9198  if (value == NULL) {
9199    result = Tcl_ObjGetVar2(interp, name, NULL, flags);
9200  } else {
9201    result = Tcl_ObjSetVar2(interp, name, NULL, value, flags);
9202  }
9203  XOTcl_PopFrame(interp, obj);
9204
9205  if (result) {
9206    Tcl_SetObjResult(interp, result);
9207    return TCL_OK;
9208  }
9209  return TCL_ERROR;
9210}
9211
9212static int
9213XOTclOSetMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9214  XOTclObject *obj = (XOTclObject*)cd;
9215
9216  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9217  if (objc > 3 || objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "set var ?value?");
9218  return setInstVar(interp, obj, objv[1], objc == 3 ? objv[2] : NULL);
9219}
9220
9221static int
9222XOTclSetterMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9223  XOTclObject *obj = (XOTclObject*)cd;
9224
9225  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9226  if (objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "parameter ?value?");
9227  return setInstVar(interp, obj, objv[0], objc == 2 ? objv[1] : NULL);
9228}
9229
9230
9231static int
9232XOTclOUpvarMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
9233  XOTclObject *obj = (XOTclObject*)cd;
9234  Tcl_Obj *frameInfoObj = NULL;
9235  int i, result = TCL_ERROR;
9236  char *frameInfo;
9237  callFrameContext ctx = {0};
9238
9239  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9240  if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName,
9241                                         "?level? otherVar localVar ?otherVar localVar ...?");
9242
9243  if (objc % 2 == 0) {
9244    frameInfo = ObjStr(objv[1]);
9245    i = 2;
9246  } else {
9247    frameInfoObj = computeLevelObj(interp, CALLING_LEVEL);
9248    INCR_REF_COUNT(frameInfoObj);
9249    frameInfo = ObjStr(frameInfoObj);
9250    i = 1;
9251  }
9252
9253  if (obj && (obj->filterStack || obj->mixinStack)) {
9254    CallStackUseActiveFrames(interp, &ctx);
9255  }
9256
9257  for ( ;  i < objc;  i += 2) {
9258    result = Tcl_UpVar2(interp, frameInfo, ObjStr(objv[i]), NULL,
9259                        ObjStr(objv[i+1]), 0 /*flags*/);
9260    if (result != TCL_OK)
9261      break;
9262  }
9263
9264  if (frameInfoObj) {
9265    DECR_REF_COUNT(frameInfoObj);
9266  }
9267  CallStackRestoreSavedFrames(interp, &ctx);
9268  return result;
9269}
9270
9271static int
9272XOTclOUplevelMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
9273  XOTclObject *obj = (XOTclObject *)cd;
9274  int i, result = TCL_ERROR;
9275  char *frameInfo = NULL;
9276  Tcl_CallFrame *framePtr = NULL, *savedVarFramePtr;
9277
9278  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9279  if (objc < 2) {
9280  uplevelSyntax:
9281    return XOTclObjErrArgCnt(interp, obj->cmdName, "?level? command ?arg ...?");
9282  }
9283  /*
9284   * Find the level to use for executing the command.
9285   */
9286  if (objc>2) {
9287    CallFrame *cf;
9288    frameInfo = ObjStr(objv[1]);
9289    result = TclGetFrame(interp, frameInfo, &cf);
9290    if (result == -1) {
9291      return TCL_ERROR;
9292    }
9293    framePtr = (Tcl_CallFrame *)cf;
9294    i = result+1;
9295  } else {
9296    i = 1;
9297  }
9298
9299  objc -= i;
9300  objv += i;
9301  if (objc == 0) {
9302    goto uplevelSyntax;
9303  }
9304
9305  if (!framePtr) {
9306    XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 1);
9307    if (csc)
9308      framePtr = csc->currentFramePtr;
9309  }
9310
9311  savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp);
9312  Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr;
9313
9314  /*
9315   * Execute the residual arguments as a command.
9316   */
9317
9318  if (objc == 1) {
9319    result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
9320  } else {
9321    /*
9322     * More than one argument: concatenate them together with spaces
9323     * between, then evaluate the result.  Tcl_EvalObjEx will delete
9324     * the object when it decrements its refcount after eval'ing it.
9325     */
9326    Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
9327    result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
9328  }
9329  if (result == TCL_ERROR) {
9330    char msg[32 + TCL_INTEGER_SPACE];
9331    sprintf(msg, "\n    (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp));
9332    Tcl_AddObjErrorInfo(interp, msg, -1);
9333  }
9334
9335  /*
9336   * Restore the variable frame, and return.
9337   */
9338
9339  Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr;
9340  return result;
9341}
9342
9343static int
9344forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
9345           Tcl_Obj *o, forwardCmdClientData *tcd, Tcl_Obj **out,
9346           Tcl_Obj **freeList, int *inputarg, int *mapvalue) {
9347  char *element = ObjStr(o), *p;
9348  int totalargs = objc + tcd->nr_args - 1;
9349  char c = *element, c1;
9350
9351  p = element;
9352
9353  if (c == '%' && *(element+1) == '@') {
9354    char *remainder = NULL;
9355    long pos;
9356    element += 2;
9357    pos = strtol(element,&remainder, 0);
9358    /*fprintf(stderr,"strtol('%s) returned %ld '%s'\n", element, pos, remainder);*/
9359    if (element == remainder && *element == 'e' && !strncmp(element,"end", 3)) {
9360      pos = totalargs;
9361      remainder += 3;
9362    }
9363    if (element == remainder || abs(pos) > totalargs) {
9364      return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ",
9365                            ObjStr(o), (char *) NULL);
9366    }    if (!remainder || *remainder != ' ') {
9367      return XOTclVarErrMsg(interp, "forward: invaild syntax in '",  ObjStr(o),
9368                            "' use: %@<pos> <cmd>",(char *) NULL);
9369    }
9370
9371    element = ++remainder;
9372    if (pos<0) pos = totalargs + pos;
9373    /*fprintf(stderr,"remainder = '%s' pos = %ld\n", remainder, pos);*/
9374    *mapvalue = pos;
9375    element = remainder;
9376    c = *element;
9377  }
9378  /*fprintf(stderr,"c==%c element = '%s'\n", c, element);*/
9379  if (c == '%') {
9380    Tcl_Obj *list = NULL, **listElements;
9381    int nrargs = objc-1, nrElements = 0;
9382    c = *++element;
9383    c1 = *(element+1);
9384
9385    if (c == 's' && !strcmp(element,"self")) {
9386      *out = tcd->obj->cmdName;
9387    } else if (c == 'p' && !strcmp(element,"proc")) {
9388      *out = objv[0];
9389    } else if (c == '1' && (c1 == '\0' || c1 == ' ')) {
9390      /*fprintf(stderr, "   nrargs=%d, subcommands=%d inputarg=%d, objc=%d\n",
9391        nrargs, tcd->nr_subcommands, inputarg, objc);*/
9392      if (c1 != '\0') {
9393        if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) {
9394          return XOTclVarErrMsg(interp, "forward: %1 must by a valid list, given: '",
9395                                ObjStr(o), "'", (char *) NULL);
9396        }
9397        if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) {
9398          return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '",
9399                                ObjStr(list),"'", (char *) NULL);
9400        }
9401      } else if (tcd->subcommands) { /* deprecated part */
9402        if (Tcl_ListObjGetElements(interp, tcd->subcommands,&nrElements,&listElements) != TCL_OK) {
9403          return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '",
9404                                ObjStr(list),"'", (char *) NULL);
9405        }
9406      }
9407      if (nrElements > nrargs) {
9408        /* insert default subcommand depending on number of arguments */
9409        *out = listElements[nrargs];
9410      } else if (objc<=1) {
9411        return XOTclObjErrArgCnt(interp, objv[0], "no argument given");
9412      } else {
9413        *out = objv[1];
9414        *inputarg = 2;
9415      }
9416    } else if (c == 'a' && !strncmp(element,"argcl", 4)) {
9417      if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) {
9418        return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '",
9419                              ObjStr(o), "'", (char *) NULL);
9420      }
9421      if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) {
9422        return XOTclVarErrMsg(interp, "forward: %argclindex contains invalid list '",
9423                              ObjStr(list),"'", (char *) NULL);
9424      }
9425      if (nrargs >= nrElements) {
9426        return XOTclVarErrMsg(interp, "forward: not enough elements in specified list of ARGC argument ",
9427                              ObjStr(o), (char *) NULL);
9428      }
9429      *out = listElements[nrargs];
9430    } else if (c == '%') {
9431      Tcl_Obj *newarg = Tcl_NewStringObj(element,-1);
9432      *out = newarg;
9433      goto add_to_freelist;
9434    } else {
9435      /* evaluating given command */
9436      int result;
9437      /*fprintf(stderr,"evaluating '%s'\n", element);*/
9438      if ((result = Tcl_EvalEx(interp, element, -1, 0)) != TCL_OK)
9439        return result;
9440      *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
9441      /*fprintf(stderr,"result = '%s'\n", ObjStr(*out));*/
9442      goto add_to_freelist;
9443    }
9444  } else {
9445    if (p == element)
9446      *out = o;
9447    else {
9448      Tcl_Obj *newarg = Tcl_NewStringObj(element,-1);
9449      *out = newarg;
9450      goto add_to_freelist;
9451    }
9452  }
9453  return TCL_OK;
9454
9455 add_to_freelist:
9456  if (!*freeList) {
9457    *freeList = Tcl_NewListObj(1, out);
9458    INCR_REF_COUNT(*freeList);
9459  } else
9460    Tcl_ListObjAppendElement(interp, *freeList, *out);
9461  return TCL_OK;
9462}
9463
9464
9465static int
9466callForwarder(forwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9467  ClientData cd;
9468  int result;
9469  XOTcl_FrameDecls;
9470
9471  if (tcd->verbose) {
9472    Tcl_Obj *cmd = Tcl_NewListObj(objc, objv);
9473    fprintf(stderr,"calling %s\n", ObjStr(cmd));
9474    DECR_REF_COUNT(cmd);
9475  }
9476  if (tcd->objscope) {
9477    XOTcl_PushFrame(interp, tcd->obj);
9478  }
9479  if (tcd->objProc) {
9480    result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->cd, objc, objv);
9481  } else if (tcd->cmdName->typePtr == &XOTclObjectType
9482             && XOTclObjConvertObject(interp, tcd->cmdName, (void*)&cd) == TCL_OK) {
9483    /*fprintf(stderr, "XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName), objc);*/
9484    result = XOTclObjDispatch(cd, interp, objc, objv);
9485  } else {
9486    /*fprintf(stderr, "no XOTcl object %s\n", ObjStr(tcd->cmdName));*/
9487    result = Tcl_EvalObjv(interp, objc, objv, 0);
9488  }
9489
9490  if (tcd->objscope) {
9491    XOTcl_PopFrame(interp, tcd->obj);
9492  }
9493  return result;
9494}
9495
9496static int
9497XOTclForwardMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9498  forwardCmdClientData *tcd = (forwardCmdClientData *)cd;
9499  int result, j, inputarg = 1, outputarg = 0;
9500  if (!tcd || !tcd->obj) return XOTclObjErrType(interp, objv[0], "Object");
9501
9502  /* it is a c-method; establish a value for the currentFramePtr */
9503  RUNTIME_STATE(interp)->cs.top->currentFramePtr =
9504    (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp);
9505  /*
9506    fprintf(stderr,"...setting currentFramePtr %p to %p (ForwardMethod)\n",
9507    RUNTIME_STATE(interp)->cs.top->currentFramePtr,
9508    (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp)); */
9509
9510
9511  if (tcd->passthrough) { /* two short cuts for simple cases */
9512    /* early binding, cmd *resolved, we have to care only for objscope */
9513    return callForwarder(tcd, interp, objc, objv);
9514  } else if (!tcd->args && *(ObjStr(tcd->cmdName)) != '%') {
9515    /* we have ony to replace the method name with the given cmd name */
9516    ALLOC_ON_STACK(Tcl_Obj*, objc, ov);
9517    memcpy(ov, objv, sizeof(Tcl_Obj *)*objc);
9518    ov[0] = tcd->cmdName;
9519    result = callForwarder(tcd, interp, objc, ov);
9520    FREE_ON_STACK(Tcl_Obj *, ov);
9521    return result;
9522  } else {
9523    Tcl_Obj **ov, *freeList=NULL;
9524    int totalargs = objc + tcd->nr_args + 3;
9525    ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV);
9526    ALLOC_ON_STACK(int, totalargs, objvmap);
9527
9528    ov = &OV[1];
9529    if (tcd->needobjmap) {
9530      memset(objvmap, -1, sizeof(int)*totalargs);
9531    }
9532
9533#if 0
9534    fprintf(stderr,"command %s (%p) objc=%d, subcommand=%d, args=%p, nrargs\n",
9535            ObjStr(objv[0]), tcd, objc,
9536            tcd->nr_subcommands,
9537            tcd->args
9538            );
9539#endif
9540
9541    /* the first argument is always the command, to which we forward */
9542
9543    if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd,
9544                             &ov[outputarg], &freeList, &inputarg,
9545                             &objvmap[outputarg])) != TCL_OK) {
9546      goto exitforwardmethod;
9547    }
9548    outputarg++;
9549
9550    if (tcd->args) {
9551      /* copy argument list from definition */
9552      Tcl_Obj **listElements;
9553      int nrElements;
9554      Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements);
9555
9556      for (j=0; j<nrElements; j++, outputarg++) {
9557        if ((result = forwardArg(interp, objc, objv, listElements[j], tcd,
9558                                 &ov[outputarg], &freeList, &inputarg,
9559                                 &objvmap[outputarg])) != TCL_OK) {
9560          goto exitforwardmethod;
9561        }
9562      }
9563    }
9564    /*
9565      fprintf(stderr, "objc=%d, tcd->nr_subcommands=%d size=%d\n",
9566	    objc, tcd->nr_subcommands, objc+ 2	    );*/
9567
9568    if (objc-inputarg>0) {
9569      /*fprintf(stderr, "  copying remaining %d args starting at [%d]\n",
9570        objc-inputarg, outputarg);*/
9571      memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg));
9572    } else {
9573      /*fprintf(stderr, "  nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/
9574    }
9575    objc += outputarg - inputarg;
9576
9577#if 0
9578    for(j=0; j<objc; j++) {
9579      /*fprintf(stderr, "  ov[%d]=%p, objc=%d\n", j, ov[j], objc);*/
9580      fprintf(stderr, " o[%d]=%s (%d),", j, ObjStr(ov[j]), objvmap[j]);
9581    }
9582    fprintf(stderr,"\n");
9583#endif
9584
9585    if (tcd->needobjmap)
9586      for (j=0; j<totalargs; j++) {
9587        Tcl_Obj *tmp;
9588        int pos = objvmap[j], i;
9589        if (pos == -1 || pos == j)
9590          continue;
9591        tmp = ov[j];
9592        if (j>pos) {
9593          for(i=j; i>pos; i--) {
9594            /*fprintf(stderr,"...moving right %d to %d\n", i-1, i);*/
9595            ov[i] = ov[i-1];
9596            objvmap[i] = objvmap[i-1];
9597          }
9598        } else {
9599          for(i=j; i<pos; i++) {
9600            /*fprintf(stderr,"...moving left %d to %d\n", i+1, i);*/
9601            ov[i] = ov[i+1];
9602            objvmap[i] = objvmap[i+1];
9603          }
9604        }
9605        /* fprintf(stderr,"...setting at %d -> %s\n", pos, ObjStr(tmp)); */
9606        ov[pos] = tmp;
9607        objvmap[pos] = -1;
9608      }
9609
9610    if (tcd->prefix) {
9611      /* prepend a prefix for the subcommands to avoid name clashes */
9612      Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix);
9613      Tcl_AppendObjToObj(methodName, ov[1]);
9614      ov[1] = methodName;
9615      INCR_REF_COUNT(ov[1]);
9616    }
9617
9618#if 0
9619    for(j=0; j<objc; j++) {
9620      /*fprintf(stderr, "  ov[%d]=%p, objc=%d\n", j, ov[j], objc);*/
9621      fprintf(stderr, "  ov[%d]='%s' map=%d\n", j, ObjStr(ov[j]), objvmap[j]);
9622    }
9623#endif
9624
9625    OV[0] = tcd->cmdName;
9626    result = callForwarder(tcd, interp, objc, ov);
9627
9628    if (tcd->prefix) {DECR_REF_COUNT(ov[1]);}
9629  exitforwardmethod:
9630    if (freeList)    {DECR_REF_COUNT(freeList);}
9631    FREE_ON_STACK(int, objvmap);
9632    FREE_ON_STACK(Tcl_Obj *,OV);
9633  }
9634  return result;
9635}
9636
9637
9638
9639static int
9640XOTclOInstVarMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9641  XOTclObject  *obj   = (XOTclObject*)cd;
9642  Tcl_Obj      **ov;
9643  int          i, oc, result = TCL_OK;
9644  callFrameContext ctx = {0};
9645
9646  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9647  if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "instvar ?vars?");
9648
9649  if (obj && (obj->filterStack || obj->mixinStack) ) {
9650    CallStackUseActiveFrames(interp, &ctx);
9651  }
9652  if (!Tcl_Interp_varFramePtr(interp)) {
9653    CallStackRestoreSavedFrames(interp, &ctx);
9654    return XOTclVarErrMsg(interp, "instvar used on ", ObjStr(obj->cmdName),
9655                          ", but callstack is not in procedure scope",
9656                          (char *) NULL);
9657  }
9658
9659  for (i=1; i<objc; i++) {
9660    /*fprintf(stderr,"ListGetElements %p %s\n", objv[i], ObjStr(objv[i]));*/
9661    if ((result = Tcl_ListObjGetElements(interp, objv[i], &oc, &ov)) == TCL_OK) {
9662      Tcl_Obj *varname = NULL, *alias = NULL;
9663      switch (oc) {
9664      case 0: {varname = objv[i]; break;}
9665      case 1: {varname = ov[0];   break;}
9666      case 2: {varname = ov[0];   alias = ov[1]; break;}
9667      }
9668      if (varname) {
9669        result = GetInstVarIntoCurrentScope(interp, obj, varname, alias);
9670      } else {
9671        result = XOTclVarErrMsg(interp, "invalid variable specification '",
9672                                ObjStr(objv[i]), "'", (char *) NULL);
9673      }
9674      if (result != TCL_OK) {
9675        break;
9676      }
9677    } else {
9678      break;
9679    }
9680  }
9681  CallStackRestoreSavedFrames(interp, &ctx);
9682  return result;
9683}
9684
9685/*
9686 * copied from Tcl, since not exported
9687 */
9688static char *
9689VwaitVarProc(clientData, interp, name1, name2, flags)
9690     ClientData clientData;	/* Pointer to integer to set to 1. */
9691     Tcl_Interp *interp;		/* Interpreter containing variable. */
9692     char *name1;		/* Name of variable. */
9693     char *name2;		/* Second part of variable name. */
9694     int flags;			/* Information about what happened. */
9695{
9696  int *donePtr = (int *) clientData;
9697
9698  *donePtr = 1;
9699  return (char *) NULL;
9700}
9701static int
9702XOTclOVwaitMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9703  XOTclObject *obj = (XOTclObject*)cd;
9704  int done, foundEvent;
9705  char *nameString;
9706  int flgs = TCL_TRACE_WRITES|TCL_TRACE_UNSETS;
9707  XOTcl_FrameDecls;
9708
9709  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9710  if (objc != 2)
9711    return XOTclObjErrArgCnt(interp, obj->cmdName, "vwait varname");
9712
9713  nameString = ObjStr(objv[1]);
9714
9715  /*
9716   * Make sure the var table exists and the varname is in there
9717   */
9718  if (NSRequireVariableOnObj(interp, obj, nameString, flgs) == 0)
9719    return XOTclVarErrMsg(interp, "Can't lookup (and create) variable ",
9720                          nameString, " on ", ObjStr(obj->cmdName),
9721                          (char *) NULL);
9722
9723  XOTcl_PushFrame(interp, obj);
9724  /*
9725   * much of this is copied from Tcl, since we must avoid
9726   * access with flag TCL_GLOBAL_ONLY ... doesn't work on
9727   * obj->varTable vars
9728   */
9729  if (Tcl_TraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc,
9730                   (ClientData) &done) != TCL_OK) {
9731    return TCL_ERROR;
9732  }
9733  done = 0;
9734  foundEvent = 1;
9735  while (!done && foundEvent) {
9736    foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
9737  }
9738  Tcl_UntraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc,
9739                 (ClientData) &done);
9740  XOTcl_PopFrame(interp, obj);
9741  /*
9742   * Clear out the interpreter's result, since it may have been set
9743   * by event handlers.
9744   */
9745  Tcl_ResetResult(interp);
9746
9747  if (!foundEvent) {
9748    return XOTclVarErrMsg(interp, "can't wait for variable '", nameString,
9749                          "':  would wait forever", (char *) NULL);
9750  }
9751  return TCL_OK;
9752}
9753
9754static int
9755XOTclOInvariantsMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9756  XOTclObject *obj = (XOTclObject*)cd;
9757  XOTclObjectOpt *opt;
9758
9759  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9760  if (objc != 2)
9761    return XOTclObjErrArgCnt(interp, obj->cmdName, "invar <invariantList>");
9762
9763  opt = XOTclRequireObjectOpt(obj);
9764
9765  if (opt->assertions)
9766    TclObjListFreeList(opt->assertions->invariants);
9767  else
9768    opt->assertions = AssertionCreateStore();
9769
9770  opt->assertions->invariants = AssertionNewList(interp, objv[1]);
9771  return TCL_OK;
9772}
9773
9774static int
9775XOTclOAutonameMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9776  XOTclObject *obj = (XOTclObject*)cd;
9777  int instanceOpt = 0, resetOpt = 0;
9778  Tcl_Obj *autoname;
9779
9780  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9781  if (objc == 3) {
9782    instanceOpt = (strcmp(ObjStr(objv[1]), "-instance") == 0);
9783    resetOpt = (strcmp(ObjStr(objv[1]), "-reset") == 0);
9784  }
9785  if ((objc < 2 || objc > 3) || (objc == 3 && !instanceOpt && !resetOpt))
9786    return XOTclObjErrArgCnt(interp, obj->cmdName, "autoname [-instance | -reset] name");
9787
9788  autoname = AutonameIncr(interp, objv[objc-1], obj, instanceOpt, resetOpt);
9789  if (autoname) {
9790    Tcl_SetObjResult(interp, autoname);
9791    DECR_REF_COUNT(autoname);
9792  }
9793  else
9794    return XOTclVarErrMsg(interp,
9795                          "Autoname failed. Probably format string (with %) was not well-formed",
9796                          (char *) NULL);
9797
9798  return TCL_OK;
9799}
9800
9801static int
9802XOTclOCheckMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9803  XOTclObject *obj = (XOTclObject*)cd;
9804  int ocArgs; Tcl_Obj **ovArgs;
9805  int i;
9806  XOTclObjectOpt *opt;
9807
9808  /*fprintf(stderr,"checkmethod\n");*/
9809  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
9810  if (objc != 2)
9811    return XOTclObjErrArgCnt(interp, obj->cmdName,
9812                             "check (?all? ?pre? ?post? ?invar? ?instinvar?)");
9813
9814  opt = XOTclRequireObjectOpt(obj);
9815  opt->checkoptions = CHECK_NONE;
9816
9817  if (Tcl_ListObjGetElements(interp, objv[1], &ocArgs, &ovArgs) == TCL_OK
9818      && ocArgs > 0) {
9819    for (i = 0; i < ocArgs; i++) {
9820      char *option = ObjStr(ovArgs[i]);
9821      if (option) {
9822        switch (*option) {
9823        case 'i':
9824          if (strcmp(option, "instinvar") == 0) {
9825            opt->checkoptions |= CHECK_CLINVAR;
9826          } else if (strcmp(option, "invar") == 0) {
9827            opt->checkoptions |= CHECK_OBJINVAR;
9828          }
9829          break;
9830        case 'p':
9831          if (strcmp(option, "pre") == 0) {
9832            opt->checkoptions |= CHECK_PRE;
9833          } else if (strcmp(option, "post") == 0) {
9834            opt->checkoptions  |= CHECK_POST;
9835          }
9836          break;
9837        case 'a':
9838          if (strcmp(option, "all") == 0) {
9839            opt->checkoptions |= CHECK_ALL;
9840          }
9841          break;
9842        }
9843      }
9844    }
9845  }
9846  if (opt->checkoptions == CHECK_NONE && ocArgs>0) {
9847    return XOTclVarErrMsg(interp, "Unknown check option in command '",
9848                          ObjStr(obj->cmdName), " ", ObjStr(objv[0]),
9849                          " ", ObjStr(objv[1]),
9850                          "', valid: all pre post invar instinvar",
9851                          (char *) NULL);
9852  }
9853
9854  Tcl_ResetResult(interp);
9855  return TCL_OK;
9856}
9857
9858static int
9859XOTclConfigureCommand(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9860  int bool, opt, result = TCL_OK;
9861  static CONST char *opts[] = {
9862    "filter", "softrecreate",
9863    NULL
9864  };
9865  enum subCmdIdx {
9866    filterIdx, softrecreateIdx
9867  };
9868
9869  if (objc < 2 || objc>3)
9870    return XOTclObjErrArgCnt(interp, objv[0],
9871                             "::xotcl::configure filter|softrecreate ?on|off?");
9872
9873  if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, &opt) != TCL_OK) {
9874    return TCL_ERROR;
9875  }
9876
9877  if (objc == 3) {
9878    result = Tcl_GetBooleanFromObj(interp, objv[2], &bool);
9879  }
9880  if (result == TCL_OK) {
9881    switch (opt) {
9882    case filterIdx:
9883      Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
9884                        (RUNTIME_STATE(interp)->doFilters));
9885      if (objc == 3)
9886        RUNTIME_STATE(interp)->doFilters = bool;
9887      break;
9888
9889    case softrecreateIdx:
9890      Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
9891                        (RUNTIME_STATE(interp)->doSoftrecreate));
9892      if (objc == 3)
9893        RUNTIME_STATE(interp)->doSoftrecreate = bool;
9894      break;
9895    }
9896  }
9897  return result;
9898}
9899
9900static int
9901XOTclObjscopedMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9902  aliasCmdClientData *tcd = (aliasCmdClientData *)cd;
9903  XOTclObject *obj = tcd->obj;
9904  int rc;
9905  XOTcl_FrameDecls;
9906  /* fprintf(stderr,"objscopedMethod obj=%p, ptr=%p\n", obj, tcd->objProc); */
9907
9908  XOTcl_PushFrame(interp, obj);
9909  rc = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->cd, objc, objv);
9910  XOTcl_PopFrame(interp, obj);
9911
9912  return rc;
9913}
9914
9915static void aliasCmdDeleteProc(ClientData cd) {
9916  aliasCmdClientData *tcd = (aliasCmdClientData *)cd;
9917  if (tcd->cmdName)     {DECR_REF_COUNT(tcd->cmdName);}
9918  /*fprintf(stderr,"aliasCmdDeleteProc\n");*/
9919  FREE(aliasCmdClientData, tcd);
9920}
9921
9922static int
9923XOTclAliasCommand(ClientData cd, Tcl_Interp *interp,
9924                  int objc, Tcl_Obj *CONST objv[]) {
9925  XOTclObject *obj = NULL;
9926  XOTclClass *cl = NULL;
9927  Tcl_Command cmd = NULL;
9928  Tcl_ObjCmdProc *objProc;
9929  char allocation, *methodName, *optionName;
9930  Tcl_CmdDeleteProc *dp = NULL;
9931  aliasCmdClientData *tcd = NULL;
9932  int objscope = 0, i;
9933
9934  if (objc < 4 || objc > 6) {
9935    return XOTclObjErrArgCnt(interp, objv[0],
9936                             "<class>|<obj> <methodName> ?-objscope? ?-per-object? <cmdName>");
9937  }
9938
9939  GetXOTclClassFromObj(interp, objv[1], &cl, 1);
9940  if (!cl) {
9941    XOTclObjConvertObject(interp, objv[1], &obj);
9942    if (!obj)
9943      return XOTclObjErrType(interp, objv[1], "Class|Object");
9944    allocation = 'o';
9945  } else {
9946    allocation = 'c';
9947  }
9948
9949  methodName = ObjStr(objv[2]);
9950
9951  for (i=3; i<5; i++) {
9952    optionName = ObjStr(objv[i]);
9953    if (*optionName != '-') break;
9954    if (!strcmp("-objscope", optionName)) {
9955      objscope = 1;
9956    } else if (!strcmp("-per-object", optionName)) {
9957      allocation = 'o';
9958    } else {
9959      return XOTclErrBadVal(interp, "::xotcl::alias",
9960                            "option -objscope or -per-object", optionName);
9961    }
9962  }
9963
9964  cmd = Tcl_GetCommandFromObj(interp, objv[i]);
9965  if (cmd == NULL)
9966    return XOTclVarErrMsg(interp, "cannot lookup command '",
9967                          ObjStr(objv[i]), "'", (char *) NULL);
9968  objProc = Tcl_Command_objProc(cmd);
9969
9970  if (objc>i+1) {
9971    return XOTclVarErrMsg(interp, "invalid argument '",
9972                          ObjStr(objv[i+1]), "'", (char *) NULL);
9973  }
9974
9975  if (objscope) {
9976    tcd = NEW(aliasCmdClientData);
9977    tcd->cmdName = NULL;
9978    tcd->obj     = allocation == 'c' ? &cl->object : obj;
9979    tcd->objProc = objProc;
9980    tcd->cd      = Tcl_Command_objClientData(cmd);
9981    objProc      = XOTclObjscopedMethod;
9982    dp = aliasCmdDeleteProc;
9983  } else {
9984    tcd = Tcl_Command_objClientData(cmd);
9985  }
9986
9987  if (allocation == 'c') {
9988    XOTclAddIMethod(interp, (XOTcl_Class*)cl, methodName, objProc, tcd, dp);
9989  } else {
9990    XOTclAddPMethod(interp, (XOTcl_Object*)obj, methodName, objProc, tcd, dp);
9991  }
9992  return TCL_OK;
9993}
9994
9995
9996static int
9997XOTclSetInstvarCommand(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
9998  XOTclObject *obj;
9999
10000  if (objc < 3 || objc > 4)
10001    return XOTclObjErrArgCnt(interp, objv[0], "::xotcl::instvarset obj var ?value?");
10002
10003  XOTclObjConvertObject(interp, objv[1], &obj);
10004  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10005
10006  return setInstVar(interp, obj , objv[2], objc == 4 ? objv[3] : NULL);
10007}
10008
10009
10010static int
10011XOTclSetRelationCommand(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10012  int oc; Tcl_Obj **ov;
10013  XOTclObject *obj = NULL;
10014  XOTclClass *cl = NULL;
10015  XOTclObject *nobj = NULL;
10016  XOTclObjectOpt *objopt = NULL;
10017  XOTclClassOpt *clopt = NULL;
10018  XOTclClassOpt *nclopt = NULL;
10019  int i, opt;
10020  static CONST char *opts[] = {
10021    "mixin", "instmixin",
10022    "filter", "instfilter",
10023    "class", "superclass",
10024    NULL
10025  };
10026  enum subCmdIdx {
10027    mixinIdx, instmixinIdx,
10028    filterIdx, instfilterIdx,
10029    classIdx, superclassIdx
10030  };
10031
10032  if (objc < 3)
10033    return XOTclObjErrArgCnt(interp, objv[0], "::xotcl::setrelation obj reltype classes");
10034
10035  if (Tcl_GetIndexFromObj(interp, objv[2], opts, "relation type", 0, &opt) != TCL_OK) {
10036    return TCL_ERROR;
10037  }
10038
10039  switch (opt) {
10040  case mixinIdx:
10041  case filterIdx: {
10042    XOTclObjConvertObject(interp, objv[1], &obj);
10043    if (!obj) return XOTclObjErrType(interp, objv[1], "Object");
10044    if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK)
10045      return TCL_ERROR;
10046    objopt = XOTclRequireObjectOpt(obj);
10047    break;
10048  }
10049  case instmixinIdx:
10050  case instfilterIdx: {
10051    GetXOTclClassFromObj(interp, objv[1], &cl, 1);
10052    if (!cl) return XOTclObjErrType(interp, objv[1], "Class");
10053    if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK)
10054      return TCL_ERROR;
10055    clopt = XOTclRequireClassOpt(cl);
10056    break;
10057  }
10058  case superclassIdx:
10059    {
10060      GetXOTclClassFromObj(interp, objv[1], &cl, 1);
10061      if (!cl) return XOTclObjErrType(interp, objv[1], "Class");
10062      if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK)
10063        return TCL_ERROR;
10064      return SuperclassAdd(interp, cl, oc, ov, objv[3]);
10065    }
10066  case classIdx:
10067    {
10068      XOTclObjConvertObject(interp, objv[1], &obj);
10069      if (!obj) return XOTclObjErrType(interp, objv[1], "Object");
10070      GetXOTclClassFromObj(interp, objv[3], &cl, 1);
10071      if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1]));
10072      return changeClass(interp, obj, cl);
10073    }
10074  }
10075
10076  switch (opt) {
10077  case mixinIdx:
10078    {
10079      if (objopt->mixins) {
10080        XOTclCmdList *cmdlist, *del;
10081        for (cmdlist = objopt->mixins; cmdlist; cmdlist = cmdlist->next) {
10082          cl = XOTclGetClassFromCmdPtr(cmdlist->cmdPtr);
10083          clopt = cl ? cl->opt : NULL;
10084          if (clopt) {
10085            del = CmdListFindCmdInList(obj->id, clopt->isObjectMixinOf);
10086            if (del) {
10087              /* fprintf(stderr,"Removing object %s from isObjectMixinOf of class %s\n",
10088                 ObjStr(obj->cmdName), ObjStr(XOTclGetClassFromCmdPtr(cmdlist->cmdPtr)->object.cmdName)); */
10089              del = CmdListRemoveFromList(&clopt->isObjectMixinOf, del);
10090              CmdListDeleteCmdListEntry(del, GuardDel);
10091            }
10092          }
10093        }
10094        CmdListRemoveList(&objopt->mixins, GuardDel);
10095      }
10096
10097      obj->flags &= ~XOTCL_MIXIN_ORDER_VALID;
10098      /*
10099       * since mixin procs may be used as filters -> we have to invalidate
10100       */
10101      obj->flags &= ~XOTCL_FILTER_ORDER_VALID;
10102
10103      /*
10104       * now add the specified mixins
10105       */
10106      for (i = 0; i < oc; i++) {
10107        Tcl_Obj *ocl = NULL;
10108        if (MixinAdd(interp, &objopt->mixins, ov[i]) != TCL_OK) {
10109          return TCL_ERROR;
10110        }
10111        /* fprintf(stderr,"Added to mixins of %s: %s\n", ObjStr(obj->cmdName), ObjStr(ov[i])); */
10112        Tcl_ListObjIndex(interp, ov[i], 0, &ocl);
10113        XOTclObjConvertObject(interp, ocl, &nobj);
10114        if (nobj) {
10115          /* fprintf(stderr,"Registering object %s to isObjectMixinOf of class %s\n",
10116             ObjStr(obj->cmdName), ObjStr(nobj->cmdName)); */
10117          nclopt = XOTclRequireClassOpt((XOTclClass*) nobj);
10118          CmdListAdd(&nclopt->isObjectMixinOf, obj->id, NULL, /*noDuplicates*/ 1);
10119          /*fprintf(stderr,"adding cmd %p %s (epoch %d) to isObjectMixinOf %p\n",
10120                  obj->id, Tcl_GetCommandName(interp, obj->id),
10121                  Tcl_Command_cmdEpoch(obj->id),
10122                  nclopt->isObjectMixinOf);*/
10123        } /* else fprintf(stderr,"Problem registering %s as a per object mixin of %s\n",
10124             ObjStr(ov[i]), ObjStr(cl->object.cmdName)); */
10125      }
10126
10127      MixinComputeDefined(interp, obj);
10128      FilterComputeDefined(interp, obj);
10129      break;
10130    }
10131  case filterIdx:
10132    {
10133      if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel);
10134
10135      obj->flags &= ~XOTCL_FILTER_ORDER_VALID;
10136      for (i = 0; i < oc; i ++) {
10137        if (FilterAdd(interp, &objopt->filters, ov[i], obj, 0) != TCL_OK)
10138          return TCL_ERROR;
10139      }
10140      /*FilterComputeDefined(interp, obj);*/
10141      break;
10142    }
10143
10144  case instmixinIdx:
10145    {
10146      if (clopt->instmixins) {
10147        RemoveFromClassMixinsOf(cl->object.id, clopt->instmixins);
10148        CmdListRemoveList(&clopt->instmixins, GuardDel);
10149      }
10150
10151      MixinInvalidateObjOrders(interp, cl);
10152      /*
10153       * since mixin procs may be used as filters -> we have to invalidate
10154       */
10155      FilterInvalidateObjOrders(interp, cl);
10156
10157      for (i = 0; i < oc; i++) {
10158        Tcl_Obj *ocl = NULL;
10159        if (MixinAdd(interp, &clopt->instmixins, ov[i]) != TCL_OK) {
10160          return TCL_ERROR;
10161        }
10162        /* fprintf(stderr,"Added to instmixins of %s: %s\n",
10163           ObjStr(cl->object.cmdName), ObjStr(ov[i])); */
10164
10165        Tcl_ListObjIndex(interp, ov[i], 0, &ocl);
10166        XOTclObjConvertObject(interp, ocl, &nobj);
10167        if (nobj) {
10168          /* fprintf(stderr,"Registering class %s to isClassMixinOf of class %s\n",
10169             ObjStr(cl->object.cmdName), ObjStr(nobj->cmdName)); */
10170          nclopt = XOTclRequireClassOpt((XOTclClass*) nobj);
10171          CmdListAdd(&nclopt->isClassMixinOf, cl->object.id, NULL, /*noDuplicates*/ 1);
10172        } /* else fprintf(stderr,"Problem registering %s as a instmixinof of %s\n",
10173             ObjStr(ov[i]), ObjStr(cl->object.cmdName)); */
10174      }
10175      break;
10176    }
10177  case instfilterIdx:
10178    {
10179      if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel);
10180
10181      FilterInvalidateObjOrders(interp, cl);
10182
10183      for (i = 0; i < oc; i ++) {
10184        if (FilterAdd(interp, &clopt->instfilters, ov[i], 0, cl) != TCL_OK)
10185          return TCL_ERROR;
10186      }
10187      break;
10188    }
10189  }
10190  return TCL_OK;
10191}
10192
10193
10194static int
10195XOTclOMixinGuardMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10196  XOTclObject *obj = (XOTclObject*)cd;
10197  XOTclCmdList *h;
10198  XOTclObjectOpt *opt;
10199
10200  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10201  if (objc != 3)
10202    return XOTclObjErrArgCnt(interp, obj->cmdName, "mixinguard mixin guards");
10203
10204  opt = obj->opt;
10205  if (opt && opt->mixins) {
10206    XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1]));
10207    Tcl_Command mixinCmd = NULL;
10208    if (mixinCl) {
10209      mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName);
10210    }
10211    if (mixinCmd) {
10212      h = CmdListFindCmdInList(mixinCmd, opt->mixins);
10213      if (h) {
10214        if (h->clientData)
10215          GuardDel((XOTclCmdList*) h);
10216        GuardAdd(interp, h, objv[2]);
10217        obj->flags &= ~XOTCL_MIXIN_ORDER_VALID;
10218        return TCL_OK;
10219      }
10220    }
10221  }
10222
10223  return XOTclVarErrMsg(interp, "Mixinguard: can't find mixin ",
10224                        ObjStr(objv[1]), " on ", ObjStr(obj->cmdName),
10225                        (char *) NULL);
10226}
10227
10228
10229static int
10230XOTclOFilterGuardMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10231  XOTclObject *obj = (XOTclObject*)cd;
10232  XOTclCmdList *h;
10233  XOTclObjectOpt *opt;
10234
10235  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10236  if (objc != 3)
10237    return XOTclObjErrArgCnt(interp, obj->cmdName, "filterguard filtername filterGuards");
10238
10239  opt = obj->opt;
10240  if (opt && opt->filters) {
10241    h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->filters);
10242    if (h) {
10243      if (h->clientData)
10244        GuardDel((XOTclCmdList*) h);
10245      GuardAdd(interp, h, objv[2]);
10246      obj->flags &= ~XOTCL_FILTER_ORDER_VALID;
10247      return TCL_OK;
10248    }
10249  }
10250
10251  return XOTclVarErrMsg(interp, "Filterguard: can't find filter ",
10252                        ObjStr(objv[1]), " on ", ObjStr(obj->cmdName),
10253                        (char *) NULL);
10254}
10255
10256/*
10257 *  Searches for filter on [self] and returns fully qualified name
10258 *  if it is not found it returns an empty string
10259 */
10260static int
10261XOTclOFilterSearchMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10262  XOTclObject *obj = (XOTclObject*)cd;
10263  char *methodName;
10264  XOTclCmdList *cmdList;
10265  XOTclClass *fcl;
10266  XOTclObject *fobj;
10267
10268  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10269  if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "filtersearch name");
10270  Tcl_ResetResult(interp);
10271
10272  if (!(obj->flags & XOTCL_FILTER_ORDER_VALID))
10273    FilterComputeDefined(interp, obj);
10274  if (!(obj->flags & XOTCL_FILTER_ORDER_DEFINED))
10275    return TCL_OK;
10276
10277  methodName = ObjStr(objv[1]);
10278
10279  for (cmdList = obj->filterOrder; cmdList;  cmdList = cmdList->next) {
10280    CONST84 char *filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr);
10281    if (filterName[0] == methodName[0] && !strcmp(filterName, methodName))
10282      break;
10283  }
10284
10285  if (!cmdList)
10286    return TCL_OK;
10287
10288  fcl = cmdList->clorobj;
10289  if (fcl && XOTclObjectIsClass(&fcl->object)) {
10290    fobj = NULL;
10291  } else {
10292    fobj = (XOTclObject*)fcl;
10293    fcl = NULL;
10294  }
10295
10296  Tcl_SetObjResult(interp,
10297                   getFullProcQualifier(interp, methodName, fobj, fcl,
10298                                        cmdList->cmdPtr));
10299  return TCL_OK;
10300}
10301
10302static int
10303XOTclOProcSearchMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10304  XOTclObject *obj = (XOTclObject*)cd;
10305  XOTclClass *pcl = NULL;
10306  Tcl_Command cmd = NULL;
10307  char *simpleName, *methodName;
10308
10309  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10310  if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "procsearch name");
10311
10312  Tcl_ResetResult(interp);
10313
10314  methodName = ObjStr(objv[1]);
10315
10316  if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID))
10317    MixinComputeDefined(interp, obj);
10318
10319  if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) {
10320    XOTclCmdList *mixinList;
10321    for (mixinList = obj->mixinOrder; mixinList; mixinList = mixinList->next) {
10322      XOTclClass *mcl = XOTclpGetClass(interp, (char *)Tcl_GetCommandName(interp, mixinList->cmdPtr));
10323      if (mcl && (pcl = SearchCMethod(mcl, methodName, &cmd))) {
10324        break;
10325      }
10326    }
10327  }
10328
10329  if (!cmd && obj->nsPtr) {
10330    cmd = FindMethod(methodName, obj->nsPtr);
10331  }
10332
10333  if (!cmd && obj->cl)
10334    pcl = SearchCMethod(obj->cl, methodName, &cmd);
10335
10336  if (cmd) {
10337    XOTclObject *pobj = pcl ? NULL : obj;
10338    simpleName = (char *)Tcl_GetCommandName(interp, cmd);
10339    Tcl_SetObjResult(interp, getFullProcQualifier(interp, simpleName, pobj, pcl, cmd));
10340  }
10341  return TCL_OK;
10342}
10343
10344static int
10345XOTclORequireNamespaceMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10346  XOTclObject *obj = (XOTclObject*)cd;
10347
10348  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10349  if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, "requireNamespace");
10350
10351  requireObjNamespace(interp, obj);
10352  return TCL_OK;
10353}
10354
10355typedef enum {NO_DASH, SKALAR_DASH, LIST_DASH} dashArgType;
10356
10357static dashArgType
10358isDashArg(Tcl_Interp *interp, Tcl_Obj *obj, char **methodName, int *objc, Tcl_Obj **objv[]) {
10359  char *flag;
10360  static Tcl_ObjType CONST86 *listType = NULL;
10361
10362  assert(obj);
10363
10364  /* fetch list type, if not set already; if used on more places, this should
10365     be moved into the interpreter state
10366  */
10367  if (listType == NULL) {
10368#if defined(PRE82)
10369    Tcl_Obj *tmp = Tcl_NewListObj(1, &obj);
10370    listType = tmp->typePtr;
10371    DECR_REF_COUNT(tmp);
10372#else
10373    static XOTclMutex initMutex = 0;
10374    XOTclMutexLock(&initMutex);
10375    if (listType == NULL) {
10376      listType = Tcl_GetObjType("list");
10377      /*fprintf(stderr, "fetching listType=%p\n", listType);*/
10378    }
10379    XOTclMutexUnlock(&initMutex);
10380#endif
10381  }
10382
10383  if (obj->typePtr == listType) {
10384    if (Tcl_ListObjGetElements(interp, obj, objc, objv) == TCL_OK && *objc>1) {
10385      flag = ObjStr(*objv[0]);
10386      /*fprintf(stderr, "we have a list starting with '%s'\n", flag);*/
10387      if (*flag == '-') {
10388        *methodName = flag+1;
10389        return LIST_DASH;
10390      }
10391    }
10392  }
10393  flag = ObjStr(obj);
10394  /*fprintf(stderr, "we have a scalar '%s'\n", flag);*/
10395  if (*flag == '-' && isalpha((int)*((flag)+1))) {
10396    *methodName = flag+1;
10397    *objc = 1;
10398    return SKALAR_DASH;
10399  }
10400  return NO_DASH;
10401}
10402
10403static int
10404callConfigureMethod(Tcl_Interp *interp, XOTclObject *obj,
10405                    char *methodName, int argc, Tcl_Obj *CONST argv[]) {
10406  int result;
10407  Tcl_Obj *method = Tcl_NewStringObj(methodName,-1);
10408
10409  /*fprintf(stderr,"callConfigureMethod method %s->'%s' argc %d\n",
10410    ObjStr(obj->cmdName), methodName, argc);*/
10411
10412  if (isInitString(methodName))
10413    obj->flags |= XOTCL_INIT_CALLED;
10414
10415  INCR_REF_COUNT(method);
10416  result = callMethod((ClientData)obj, interp, method, argc, argv, XOTCL_CM_NO_UNKNOWN);
10417  DECR_REF_COUNT(method);
10418
10419  /*fprintf(stderr, "method  '%s' called args: %d o=%p, result=%d\n",
10420    methodName, argc+1, obj, result);  */
10421
10422  if (result != TCL_OK) {
10423    Tcl_Obj *res =  Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */
10424    INCR_REF_COUNT(res);
10425    XOTclVarErrMsg(interp, ObjStr(res), " during '", ObjStr(obj->cmdName), " ",
10426                   methodName, "'", (char *) NULL);
10427    DECR_REF_COUNT(res);
10428  }
10429  return result;
10430}
10431
10432
10433static int
10434XOTclOConfigureMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10435  XOTclObject *obj = (XOTclObject*)cd;
10436  Tcl_Obj **argv, **nextArgv;
10437  int i, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH;
10438  char *methodName, *nextMethodName;
10439
10440  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
10441  if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName,
10442                                         "configure ?args?");
10443  /* find arguments without leading dash */
10444  for (i=1; i < objc; i++) {
10445    if ((isdasharg = isDashArg(interp, objv[i], &methodName, &argc, &argv)))
10446      break;
10447  }
10448  normalArgs = i-1;
10449
10450  for( ; i < objc;  argc=nextArgc, argv=nextArgv, methodName=nextMethodName) {
10451    Tcl_ResetResult(interp);
10452    switch (isdasharg) {
10453    case SKALAR_DASH:    /* argument is a skalar with a leading dash */
10454      { int j;
10455        for (j = i+1; j < objc; j++, argc++) {
10456          if ((isdasharg = isDashArg(interp, objv[j], &nextMethodName, &nextArgc, &nextArgv)))
10457            break;
10458        }
10459        result = callConfigureMethod(interp, obj, methodName, argc+1, objv+i+1);
10460        if (result != TCL_OK)
10461          return result;
10462        i += argc;
10463        break;
10464      }
10465    case LIST_DASH:  /* argument is a list with a leading dash, grouping determined by list */
10466      {	i++;
10467        if (i<objc)
10468          isdasharg = isDashArg(interp, objv[i], &nextMethodName, &nextArgc, &nextArgv);
10469        result = callConfigureMethod(interp, obj, methodName, argc+1, argv+1);
10470        if (result != TCL_OK)
10471          return result;
10472        break;
10473      }
10474    default:
10475      {
10476        return XOTclVarErrMsg(interp, ObjStr(obj->cmdName),
10477                              " configure: unexpected argument '",
10478                              ObjStr(objv[i]),
10479                              "' between parameters", (char *) NULL);
10480      }
10481    }
10482  }
10483  Tcl_ResetResult(interp);
10484  Tcl_SetIntObj(Tcl_GetObjResult(interp), normalArgs);
10485  return result;
10486}
10487
10488
10489
10490/*
10491 * class method implementations
10492 */
10493
10494static int
10495XOTclCInstDestroyMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10496  XOTclClass *cl = XOTclObjectToClass(cd);
10497  XOTclObject *delobj;
10498  int rc;
10499
10500  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
10501  if (objc < 2)
10502    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "instdestroy <obj/cl>");
10503
10504  if (XOTclObjConvertObject(interp, objv[1], &delobj) != TCL_OK)
10505    return XOTclVarErrMsg(interp, "Can't destroy object ",
10506                          ObjStr(objv[1]), " that does not exist.",
10507                          (char *) NULL);
10508
10509  /*fprintf(stderr,"instdestroy obj=%p %s, flags %.6x opt=%p\n",
10510    delobj, ObjStr(delobj->cmdName), delobj->flags, delobj->opt);*/
10511
10512  rc = freeUnsetTraceVariable(interp, delobj);
10513  if (rc != TCL_OK) {
10514    return rc;
10515  }
10516
10517  /*fprintf(stderr,"instdestroy obj=%p\n", delobj);*/
10518
10519  /*
10520   * latch, and call delete command if not already in progress
10521   */
10522  delobj->flags |= XOTCL_DESTROY_CALLED;
10523  RUNTIME_STATE(interp)->callIsDestroy = 1;
10524  /*fprintf(stderr,"instDestroy: setting callIsDestroy = 1\n");*/
10525  if (RUNTIME_STATE(interp)->exitHandlerDestroyRound !=
10526      XOTCL_EXITHANDLER_ON_SOFT_DESTROY) {
10527    CallStackDestroyObject(interp, delobj);
10528  }
10529
10530  return TCL_OK;
10531}
10532
10533
10534static Tcl_Namespace *
10535callingNameSpace(Tcl_Interp *interp) {
10536  Tcl_Namespace *ns = NULL;
10537  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
10538  XOTclCallStackContent *top = cs->top;
10539  XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 0);
10540
10541  /*fprintf(stderr," **** use last invocation csc = %p\n",  csc);*/
10542  if (csc && csc->currentFramePtr) {
10543    /* use the callspace from the last invocation */
10544    XOTclCallStackContent *called = csc<top? csc+1 : NULL;
10545    Tcl_CallFrame *f = called ?
10546      Tcl_CallFrame_callerPtr(called->currentFramePtr) : NULL;
10547    /*fprintf(stderr," ****  csc use frame= %p\n",  f);*/
10548    if (f) {
10549      ns = f->nsPtr;
10550    } else {
10551      Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(csc->currentFramePtr);
10552      ns = Tcl_GetCurrentNamespace(interp);
10553      /* find last incovation outside ::xotcl (for things like relmgr) */
10554      while (ns == RUNTIME_STATE(interp)->XOTclNS) {
10555        if (f) {
10556          ns = f->nsPtr;
10557          f = Tcl_CallFrame_callerPtr(f);
10558        } else {
10559          ns = Tcl_GetGlobalNamespace(interp);
10560        }
10561      }
10562      /*fprintf(stderr, "found ns %p '%s'\n", ns, ns?ns->fullName:"NULL");*/
10563    }
10564  }
10565  if (!ns) {
10566    /* calls on xotcl toplevel */
10567    XOTclCallStackContent *bot = cs->content + 1;
10568    /*fprintf(stderr, " **** bot=%p diff=%d\n", bot, top-bot);*/
10569    if (top - bot >= 0 && bot->currentFramePtr) {
10570      /* get calling tcl environment */
10571      Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(bot->currentFramePtr);
10572      if (f) {
10573        ns = f->nsPtr;
10574        /*fprintf(stderr, "top=%p, bot=%p b->c=%p f=%p ns=%p\n",
10575          top, bot, bot->currentFramePtr, f, ns);*/
10576        /*fprintf(stderr,"ns from calling tcl environment %p '%s'\n",
10577          ns, ns?ns->fullName : "" );*/
10578      } else {
10579        /* fprintf(stderr, "nothing found, use ::\n"); */
10580        ns = Tcl_GetGlobalNamespace(interp);
10581      }
10582    }
10583  }
10584
10585  /*XOTclCallStackDump(interp);*/
10586  /*XOTclStackDump(interp);*/
10587
10588  /*fprintf(stderr,"callingNameSpace returns %p %s\n", ns, ns?ns->fullName:"");*/
10589  return ns;
10590}
10591
10592
10593static int
10594XOTclCAllocMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10595  XOTclClass *cl = XOTclObjectToClass(cd);
10596  XOTclClass *newcl;
10597  XOTclObject *newobj;
10598  int result;
10599
10600  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
10601  if (objc < 2)
10602    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "alloc <obj/cl> ?args?");
10603
10604#if 0
10605  fprintf(stderr, "type(%s)=%p %s %d\n",
10606          ObjStr(objv[1]), objv[1]->typePtr, objv[1]->typePtr?
10607          objv[1]->typePtr->name:"NULL",
10608          XOTclObjConvertObject(interp, objv[1], &newobj)
10609          );
10610  /*
10611   * if the lookup via GetObject for the object succeeds,
10612   * the object exists already,
10613   * and we do not overwrite it, but re-create it
10614   */
10615  if (XOTclObjConvertObject(interp, objv[1], &newobj) == TCL_OK) {
10616    fprintf(stderr, "lookup successful\n");
10617    result = doCleanup(interp, newobj, &cl->object, objc, objv);
10618  } else
10619#endif
10620    {
10621      /*
10622       * create a new object from scratch
10623       */
10624      char *objName = ObjStr(objv[1]);
10625      Tcl_Obj *tmpName = NULL;
10626
10627      if (!isAbsolutePath(objName)) {
10628        /*fprintf(stderr, "CallocMethod\n");*/
10629        tmpName = NameInNamespaceObj(interp, objName, callingNameSpace(interp));
10630        /*fprintf(stderr, "NoAbsoluteName for '%s' -> determined = '%s'\n",
10631          objName, ObjStr(tmpName));*/
10632        objName = ObjStr(tmpName);
10633
10634        /*fprintf(stderr," **** name is '%s'\n",  objName);*/
10635        INCR_REF_COUNT(tmpName);
10636      }
10637
10638      if (IsMetaClass(interp, cl)) {
10639        /*
10640         * if the base class is a meta-class, we create a class
10641         */
10642        newcl = PrimitiveCCreate(interp, objName, cl);
10643        if (newcl == 0)
10644          result = XOTclVarErrMsg(interp, "Class alloc failed for '", objName,
10645                                  "' (possibly parent namespace does not exist)",
10646                                  (char *) NULL);
10647        else {
10648          Tcl_SetObjResult(interp, newcl->object.cmdName);
10649          result = TCL_OK;
10650        }
10651      } else {
10652        /*
10653         * if the base class is an ordinary class, we create an object
10654         */
10655        newobj = PrimitiveOCreate(interp, objName, cl);
10656        if (newobj == 0)
10657          result = XOTclVarErrMsg(interp, "Object alloc failed for '", objName,
10658                                  "' (possibly parent namespace does not exist)",
10659                                  (char *) NULL);
10660        else {
10661          result = TCL_OK;
10662          Tcl_SetObjResult(interp, newobj->cmdName);
10663        }
10664      }
10665
10666      if (tmpName) {
10667        DECR_REF_COUNT(tmpName);
10668      }
10669
10670    }
10671
10672  return result;
10673}
10674
10675
10676static int
10677createMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *obj,
10678             int objc, Tcl_Obj *CONST objv[]) {
10679  XOTclObject *newobj = NULL;
10680  Tcl_Obj *nameObj, *tmpObj = NULL;
10681  int result;
10682  char *objName, *specifiedName;
10683
10684  ALLOC_ON_STACK(Tcl_Obj*, objc, tov);
10685
10686  memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc));
10687  specifiedName = objName = ObjStr(objv[1]);
10688  /*
10689   * complete the name if it is not absolute
10690   */
10691  if (!isAbsolutePath(objName)) {
10692    tmpObj = NameInNamespaceObj(interp, objName, callingNameSpace(interp));
10693    objName = ObjStr(tmpObj);
10694    /*fprintf(stderr," **** name is '%s'\n",  objName);*/
10695
10696    INCR_REF_COUNT(tmpObj);
10697    tov[1] = tmpObj;
10698  }
10699
10700  /*
10701   * Check whether we have to call recreate (i.e. when the
10702   * object exists already)
10703   */
10704  newobj = XOTclpGetObject(interp, objName);
10705
10706  /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p\n",
10707    specifiedName, objName, newobj);*/
10708
10709  /* don't allow to
10710     - recreate an object as a class, and to
10711     - recreate a class as an object
10712
10713     In these clases, we use destroy + create instead of recrate.
10714  */
10715
10716  if (newobj && (IsMetaClass(interp, cl) == IsMetaClass(interp, newobj->cl))) {
10717    /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n",
10718      ObjStr(tov[1]), objc+1);*/
10719    /* call recreate --> initialization */
10720    result = callMethod((ClientData) obj, interp,
10721                        XOTclGlobalObjects[XOTE_RECREATE], objc+1, tov+1, 0);
10722    if (result != TCL_OK)
10723      goto create_method_exit;
10724
10725    Tcl_SetObjResult(interp, newobj->cmdName);
10726    nameObj = newobj->cmdName;
10727    objTrace("RECREATE", newobj);
10728
10729  } else {
10730
10731    /* newobj might exist here, but will be automatically destroyed
10732       by alloc */
10733
10734    if (!NSCheckColons(specifiedName, 0)) {
10735      result = XOTclVarErrMsg(interp, "Cannot create object -- illegal name '",
10736                              specifiedName, "'", (char *) NULL);
10737      goto create_method_exit;
10738    }
10739
10740    /* fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/
10741    result = callMethod((ClientData) obj, interp,
10742                        XOTclGlobalObjects[XOTE_ALLOC], objc+1, tov+1, 0);
10743    if (result != TCL_OK)
10744      goto create_method_exit;
10745
10746    nameObj = Tcl_GetObjResult(interp);
10747    if (XOTclObjConvertObject(interp, nameObj, &newobj) != TCL_OK) {
10748      result = XOTclErrMsg(interp, "couldn't find result of alloc", TCL_STATIC);
10749      goto create_method_exit;
10750    }
10751
10752    (void)RemoveInstance(newobj, newobj->cl);
10753    AddInstance(newobj, cl);
10754    objTrace("CREATE", newobj);
10755
10756    /* in case, the object is destroyed during initialization, we incr refcount */
10757    INCR_REF_COUNT(nameObj);
10758    result = doObjInitialization(interp, newobj, objc, objv);
10759    DECR_REF_COUNT(nameObj);
10760  }
10761 create_method_exit:
10762
10763  /* fprintf(stderr, "create -- end ... %s\n", ObjStr(tov[1]));*/
10764  if (tmpObj)  {DECR_REF_COUNT(tmpObj);}
10765  FREE_ON_STACK(Tcl_Obj *, tov);
10766  return result;
10767}
10768
10769
10770static int
10771XOTclCCreateMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10772  XOTclClass *cl = XOTclObjectToClass(cd);
10773
10774  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
10775  if (objc < 2)
10776    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "create <obj> ?args?");
10777
10778  if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) {
10779    fprintf(stderr,"### Can't create object %s during shutdown\n", ObjStr(objv[1]));
10780    return TCL_ERROR;
10781    return TCL_OK; /* don't fail, if this happens during destroy, it might be canceled */
10782  }
10783
10784  return createMethod(interp, cl, &cl->object, objc, objv);
10785}
10786
10787
10788static int
10789XOTclCNewMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10790  XOTclClass  *cl = XOTclObjectToClass(cd);
10791  XOTclObject *child = NULL;
10792  Tcl_Obj *fullname;
10793  int result, offset = 1,
10794#if REFCOUNTED
10795    isrefcount = 0,
10796#endif
10797    i, prefixLength;
10798  Tcl_DString dFullname, *dsPtr = &dFullname;
10799  XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss;
10800
10801  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
10802
10803  if (objc < 1)
10804    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "new [-childof obj] ?args?");
10805
10806  for (i=1; i<objc; i++) {
10807    char *option = ObjStr(objv[i]);
10808    if (*option == '-' && strcmp(option,"-childof")==0 && i<objc-1) {
10809      offset += 2;
10810      if (XOTclObjConvertObject(interp, objv[i+1], &child) != TCL_OK) {
10811        return XOTclErrMsg(interp, "not a valid object specified as child", TCL_STATIC);
10812      }
10813#if REFCOUNTED
10814    } else if (strcmp(option,"-refcount")==0) {
10815      isrefcount = 1;
10816      offset += 1;
10817#endif
10818    } else
10819      break;
10820  }
10821
10822  Tcl_DStringInit(dsPtr);
10823  if (child) {
10824    Tcl_DStringAppend(dsPtr, ObjStr(child->cmdName), -1);
10825    Tcl_DStringAppend(dsPtr, "::__#", 5);
10826  } else {
10827    Tcl_DStringAppend(dsPtr, "::xotcl::__#", 12);
10828  }
10829  prefixLength = dsPtr->length;
10830
10831  while (1) {
10832    (void)XOTclStringIncr(iss);
10833    Tcl_DStringAppend(dsPtr, iss->start, iss->length);
10834    if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, 0)) {
10835      break;
10836    }
10837    /* in case the value existed already, reset prefix to the
10838       original length */
10839    Tcl_DStringSetLength(dsPtr, prefixLength);
10840  }
10841
10842  fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
10843
10844  INCR_REF_COUNT(fullname);
10845
10846  objc -= offset;
10847  {
10848    ALLOC_ON_STACK(Tcl_Obj*, objc+3, ov);
10849
10850    ov[0] = objv[0];
10851    ov[1] = XOTclGlobalObjects[XOTE_CREATE];
10852    ov[2] = fullname;
10853    if (objc >= 1)
10854      memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc);
10855
10856    result = DoDispatch(cd, interp, objc+3, ov, 0);
10857    FREE_ON_STACK(Tcl_Obj *, ov);
10858  }
10859
10860#if REFCOUNTED
10861  if (result == TCL_OK) {
10862    if (isrefcount) {
10863      Tcl_Obj *obj = Tcl_GetObjResult(interp);
10864      XOTclObject *o = (XOTclObject*) obj->internalRep.otherValuePtr;
10865      o->flags |= XOTCL_REFCOUNTED;
10866      o->teardown = in;
10867      DECR_REF_COUNT(obj);
10868    }
10869  }
10870#endif
10871
10872  DECR_REF_COUNT(fullname);
10873  Tcl_DStringFree(dsPtr);
10874
10875  return result;
10876}
10877
10878
10879static int
10880XOTclCRecreateMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
10881  XOTclClass *cl = XOTclObjectToClass(cd);
10882  XOTclObject *newobj;
10883  int result;
10884
10885  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
10886  if (objc < 2)
10887    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "recreate <obj> ?args?");
10888
10889  if (XOTclObjConvertObject(interp, objv[1], &newobj) != TCL_OK)
10890    return XOTclVarErrMsg(interp, "can't recreate not existing obj ",
10891                          ObjStr(objv[1]), (char *) NULL);
10892
10893  INCR_REF_COUNT(objv[1]);
10894  newobj->flags |= XOTCL_RECREATE;
10895
10896  result = doCleanup(interp, newobj, &cl->object, objc, objv);
10897  if (result == TCL_OK) {
10898    result = doObjInitialization(interp, newobj, objc, objv);
10899    if (result == TCL_OK)
10900      Tcl_SetObjResult(interp, objv[1]);
10901  }
10902  DECR_REF_COUNT(objv[1]);
10903  return result;
10904}
10905
10906static int
10907XOTclCInfoMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
10908  XOTclClass *cl = XOTclObjectToClass(cd);
10909  Tcl_Namespace *nsp;
10910  XOTclClassOpt *opt;
10911  char *pattern, *cmd;
10912  int modifiers = 0;
10913
10914  if (objc < 2)
10915    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "info <opt> ?args?");
10916
10917  if (cl) {
10918    nsp = cl->nsPtr;
10919    opt = cl->opt;
10920
10921    cmd = ObjStr(objv[1]);
10922    pattern = (objc > 2) ? ObjStr(objv[2]) : 0;
10923
10924    /*
10925     * check for "-" modifiers
10926     */
10927    if (pattern && *pattern == '-') {
10928      modifiers = countModifiers(objc, objv);
10929      pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0;
10930    }
10931
10932    switch (*cmd) {
10933    case 'c':
10934      if (!strcmp(cmd, "classchildren")) {
10935        if (objc > 3 || modifiers > 0)
10936          return XOTclObjErrArgCnt(interp, cl->object.cmdName, "info classchildren ?pattern?");
10937        return ListChildren(interp, (XOTclObject*) cl, pattern, 1);
10938      } else if (!strcmp(cmd, "classparent")) {
10939        if (objc > 2 || modifiers > 0)
10940          return XOTclObjErrArgCnt(interp, cl->object.cmdName, "info classparent");
10941        return ListParent(interp, &cl->object);
10942      }
10943      break;
10944
10945    case 'h':
10946      if (!strcmp(cmd, "heritage")) {
10947        if (objc > 3 || modifiers > 0)
10948          return XOTclObjErrArgCnt(interp, cl->object.cmdName, "info heritage ?pattern?");
10949        return ListHeritage(interp, cl, pattern);
10950      }
10951      break;
10952
10953    case 'i':
10954      if (cmd[1] == 'n' && cmd[2] == 's' && cmd[3] == 't') {
10955        char *cmdTail = cmd + 4;
10956        switch (*cmdTail) {
10957        case 'a':
10958          if (!strcmp(cmdTail, "ances")) {
10959            int withClosure = 0, rc;
10960            XOTclObject *matchObject;
10961            Tcl_DString ds, *dsPtr = &ds;
10962
10963            if (objc-modifiers > 3 || modifiers > 1)
10964              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
10965                                       "info instances ?-closure? ?pattern?");
10966            if (modifiers > 0) {
10967              withClosure = checkForModifier(objv, modifiers, "-closure");
10968              if (withClosure == 0)
10969                return XOTclVarErrMsg(interp, "info instances: unknown modifier ",
10970                                      ObjStr(objv[2]), (char *) NULL);
10971            }
10972
10973            DSTRING_INIT(dsPtr);
10974            if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
10975              return TCL_OK;
10976            }
10977
10978            rc = listInstances(interp, cl, pattern, withClosure, matchObject);
10979            if (matchObject) {
10980              Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
10981            }
10982            DSTRING_FREE(dsPtr);
10983            return TCL_OK;
10984
10985          } else if (!strcmp(cmdTail, "args")) {
10986            if (objc != 3 || modifiers > 0)
10987              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
10988                                       "info instargs <instproc>");
10989            if (cl->nonposArgsTable) {
10990              XOTclNonposArgs *nonposArgs =
10991                NonposArgsGet(cl->nonposArgsTable, pattern);
10992              if (nonposArgs) {
10993                return ListArgsFromOrdinaryArgs(interp, nonposArgs);
10994              }
10995            }
10996            return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern);
10997          }
10998          break;
10999
11000        case 'b':
11001          if (!strcmp(cmdTail, "body")) {
11002            if (objc != 3 || modifiers > 0)
11003              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11004                                       "info instbody <instproc>");
11005            return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern);
11006          }
11007          break;
11008
11009        case 'c':
11010          if (!strcmp(cmdTail, "commands")) {
11011            if (objc > 3 || modifiers > 0)
11012              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11013                                       "info instcommands ?pattern?");
11014            return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern);
11015          }
11016          break;
11017
11018        case 'd':
11019          if (!strcmp(cmdTail, "default")) {
11020            if (objc != 5 || modifiers > 0)
11021              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11022                                       "info instdefault <instproc> <arg> <var>");
11023
11024            if (cl->nonposArgsTable) {
11025              XOTclNonposArgs *nonposArgs =
11026                NonposArgsGet(cl->nonposArgsTable, pattern);
11027              if (nonposArgs) {
11028                return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs,
11029                                                   ObjStr(objv[3]), objv[4]);
11030              }
11031            }
11032            return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern,
11033                                   ObjStr(objv[3]), objv[4]);
11034          }
11035          break;
11036
11037        case 'f':
11038          if (!strcmp(cmdTail, "filter")) {
11039            int withGuards = 0;
11040            if (objc-modifiers > 3)
11041              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11042                                       "info instfilter ?-guards? ?pattern?");
11043            if (modifiers > 0) {
11044              withGuards = checkForModifier(objv, modifiers, "-guards");
11045              if (withGuards == 0)
11046                return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ",
11047                                      ObjStr(objv[2]), (char *) NULL);
11048            }
11049            return opt ? FilterInfo(interp, opt->instfilters, pattern, withGuards, 0) : TCL_OK;
11050
11051          } else if (!strcmp(cmdTail, "filterguard")) {
11052            if (objc != 3 || modifiers > 0)
11053              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11054                                       "info instfilterguard filter");
11055            return opt ? GuardList(interp, opt->instfilters, pattern) : TCL_OK;
11056          } else if (!strcmp(cmdTail, "forward")) {
11057            int argc = objc-modifiers;
11058            int definition;
11059            if (argc < 2 || argc > 3)
11060              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11061                                       "info instforward ?-definition? ?name?");
11062            definition = checkForModifier(objv, modifiers, "-definition");
11063	    if (definition && argc < 3)
11064	      return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11065				       "info instforward ?-definition? ?name?");
11066            if (nsp) {
11067              return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition);
11068	    } else {
11069              return TCL_OK;
11070	    }
11071          }
11072          break;
11073
11074        case 'i':
11075          if (!strcmp(cmdTail, "invar")) {
11076            XOTclAssertionStore *assertions = opt ? opt->assertions : 0;
11077            if (objc != 2 || modifiers > 0)
11078              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11079                                       "info instinvar");
11080
11081            if (assertions && assertions->invariants)
11082              Tcl_SetObjResult(interp, AssertionList(interp, assertions->invariants));
11083            return TCL_OK;
11084          }
11085          break;
11086
11087        case 'm':
11088          if (!strcmp(cmdTail, "mixin")) {
11089              int withClosure = 0, withGuards = 0, rc;
11090            XOTclObject *matchObject;
11091            Tcl_DString ds, *dsPtr = &ds;
11092
11093            if (objc-modifiers > 3 || modifiers > 2)
11094              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11095                                       "info instmixin ?-closure? ?-guards? ?pattern?");
11096            if (modifiers > 0) {
11097              withGuards = checkForModifier(objv, modifiers, "-guards");
11098	      withClosure = checkForModifier(objv, modifiers, "-closure");
11099              if ((withGuards == 0) && (withClosure == 0))
11100                return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ",
11101                                      ObjStr(objv[2]), (char *) NULL);
11102            }
11103
11104            if ((opt) || (withClosure)) {
11105              DSTRING_INIT(dsPtr);
11106              if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
11107                return TCL_OK;
11108              }
11109	      if (withClosure) {
11110                Tcl_HashTable objTable, *commandTable = &objTable;
11111                MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
11112                Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
11113                rc = getAllClassMixins(interp, commandTable, cl, withGuards, pattern, matchObject);
11114                if (matchObject && rc && !withGuards) {
11115                  Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
11116                }
11117                Tcl_DeleteHashTable(commandTable);
11118                MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
11119	      } else {
11120	        rc = opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards, matchObject) : TCL_OK;
11121	      }
11122              DSTRING_FREE(dsPtr);
11123	    }
11124    	    return TCL_OK;
11125
11126          } else if (!strcmp(cmdTail, "mixinof")) {
11127            int withClosure = 0, rc;
11128            XOTclObject *matchObject;
11129            Tcl_DString ds, *dsPtr = &ds;
11130
11131            if (objc-modifiers > 3 || modifiers > 1)
11132              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11133                                       "info instmixinof ?-closure? ?class?");
11134            if (modifiers > 0) {
11135              withClosure = checkForModifier(objv, modifiers, "-closure");
11136              if (withClosure == 0)
11137                return XOTclVarErrMsg(interp, "info instmixinof: unknown modifier ",
11138                                      ObjStr(objv[2]), (char *) NULL);
11139            }
11140
11141            if (opt) {
11142              DSTRING_INIT(dsPtr);
11143              if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
11144                return TCL_OK;
11145              }
11146              if (withClosure) {
11147                Tcl_HashTable objTable, *commandTable = &objTable;
11148                MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
11149                Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
11150                rc = getAllClassMixinsOf(interp, commandTable, cl, 0, 1, pattern, matchObject);
11151                Tcl_DeleteHashTable(commandTable);
11152                MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
11153              } else {
11154                rc = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf,
11155                                                       pattern, matchObject);
11156              }
11157              if (matchObject) {
11158                Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
11159              }
11160              DSTRING_FREE(dsPtr);
11161            }
11162            return TCL_OK;
11163
11164          } else if (!strcmp(cmdTail, "mixinguard")) {
11165            if (objc != 3 || modifiers > 0)
11166              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11167                                       "info instmixinguard mixin");
11168            return opt ? GuardList(interp, opt->instmixins, pattern) : TCL_OK;
11169          }
11170          break;
11171
11172        case 'n':
11173          if (!strcmp(cmdTail, "nonposargs")) {
11174            if (objc != 3 || modifiers > 0)
11175              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11176                                       "info instnonposargs <instproc>");
11177            if (cl->nonposArgsTable) {
11178              XOTclNonposArgs *nonposArgs =
11179                NonposArgsGet(cl->nonposArgsTable, pattern);
11180              if (nonposArgs) {
11181                Tcl_SetObjResult(interp, NonposArgsFormat(interp,
11182                                                      nonposArgs->nonposArgs));
11183              }
11184            }
11185            return TCL_OK;
11186          }
11187          break;
11188
11189        case 'p':
11190          if (!strcmp(cmdTail, "procs")) {
11191            if (objc > 3 || modifiers > 0)
11192              return XOTclObjErrArgCnt(interp, cl->object.cmdName, "info instprocs ?pattern?");
11193            return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern,
11194                                  /*noProcs*/ 0, /*noCmds*/ 1, /* noDups */ 0, 0, 0);
11195          } else if (!strcmp(cmdTail, "pre")) {
11196            XOTclProcAssertion *procs;
11197            if (objc != 3 || modifiers > 0)
11198              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11199                                       "info instpre <proc>");
11200            if (opt && opt->assertions) {
11201              procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2]));
11202              if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre));
11203            }
11204            return TCL_OK;
11205          } else if (!strcmp(cmdTail, "post")) {
11206            XOTclProcAssertion *procs;
11207            if (objc != 3 || modifiers > 0)
11208              return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11209                                       "info instpost <proc>");
11210            if (opt && opt->assertions) {
11211              procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2]));
11212              if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post));
11213            }
11214            return TCL_OK;
11215	  } else if (!strcmp(cmdTail, "parametercmd")) {
11216	    int argc = objc-modifiers;
11217	    if (argc < 2)
11218	      return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11219				       "info instparametercmd ?pattern?");
11220	    if (nsp) {
11221	      return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, 1, 0, 0, 0, 1);
11222	    } else {
11223	      return TCL_OK;
11224	    }
11225	  }
11226	  break;
11227	}
11228      }
11229      break;
11230
11231    case 'm':
11232      if (!strcmp(cmd, "mixinof")) {
11233        XOTclObject *matchObject = NULL;
11234        Tcl_DString ds, *dsPtr = &ds;
11235        int rc, withClosure = 0;
11236
11237        if (objc-modifiers > 3 || modifiers > 1)
11238          return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11239                                   "info mixinof ?-closure? ?pattern?");
11240	if (modifiers > 0) {
11241	  withClosure = checkForModifier(objv, modifiers, "-closure");
11242	  if (withClosure == 0)
11243	    return XOTclVarErrMsg(interp, "info mixinof: unknown modifier ",
11244				  ObjStr(objv[2]), (char *) NULL);
11245	}
11246        if (opt && !withClosure) {
11247          DSTRING_INIT(dsPtr);
11248          if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
11249            return TCL_OK;
11250          }
11251
11252          rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, pattern, matchObject);
11253          if (matchObject) {
11254            Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
11255          }
11256          DSTRING_FREE(dsPtr);
11257        } else if (withClosure) {
11258	  Tcl_HashTable objTable, *commandTable = &objTable;
11259	  MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable);
11260	  Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS);
11261	  rc = getAllObjectMixinsOf(interp, commandTable, cl, 0, 1, pattern, matchObject);
11262          Tcl_DeleteHashTable(commandTable);
11263	  MEM_COUNT_FREE("Tcl_InitHashTable", commandTable);
11264	}
11265        return TCL_OK;
11266      }
11267      break;
11268
11269    case 'p':
11270      if (!strcmp(cmd, "parameterclass")) {
11271        if (opt && opt->parameterClass) {
11272          Tcl_SetObjResult(interp, opt->parameterClass);
11273        } else {
11274          Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_PARAM_CL]);
11275        }
11276        return TCL_OK;
11277      } else if (!strcmp(cmd, "parameter")) {
11278
11279        Tcl_DString ds, *dsPtr = &ds;
11280        XOTclObject *o;
11281        DSTRING_INIT(dsPtr);
11282        Tcl_DStringAppend(dsPtr, className(cl), -1);
11283        Tcl_DStringAppend(dsPtr, "::slot", 6);
11284        o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr));
11285        if (o) {
11286          Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1);
11287          Tcl_Obj *parameters = XOTclOGetInstVar2((XOTcl_Object*)o,
11288                                                  interp, varNameObj, NULL,
11289                                                  TCL_LEAVE_ERR_MSG);
11290          if (parameters) {
11291            Tcl_SetObjResult(interp, parameters);
11292          } else {
11293            fprintf(stderr, "info parameters: No value for %s\n",
11294                    Tcl_DStringValue(dsPtr));
11295            Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
11296          }
11297          DECR_REF_COUNT(varNameObj);
11298        } else {
11299          Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
11300        }
11301        DSTRING_FREE(dsPtr);
11302#if 0
11303        if (cl->parameters) {
11304          Tcl_SetObjResult(interp, cl->parameters);
11305        } else {
11306          Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]);
11307        }
11308#endif
11309        return TCL_OK;
11310      }
11311      break;
11312
11313    case 's':
11314      if (!strcmp(cmd, "superclass")) {
11315        int withClosure = 0, rc;
11316        XOTclObject *matchObject;
11317        Tcl_DString ds, *dsPtr = &ds;
11318
11319        if (objc-modifiers > 3 || modifiers > 1)
11320          return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11321                                   "info superclass ?-closure? ?pattern?");
11322        if (modifiers > 0) {
11323          withClosure = checkForModifier(objv, modifiers, "-closure");
11324          if (withClosure == 0)
11325              return XOTclVarErrMsg(interp, "info superclass: unknown modifier ",
11326                                    ObjStr(objv[2]), (char *) NULL);
11327        }
11328
11329        DSTRING_INIT(dsPtr);
11330        if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
11331          return TCL_OK;
11332        }
11333
11334        if (withClosure) {
11335          XOTclClasses *pl = ComputeOrder(cl, cl->order, Super);
11336          if (pl) pl=pl->next;
11337          rc = AppendMatchingElementsFromClasses(interp, pl, pattern, matchObject);
11338        } else {
11339          XOTclClasses *clSuper = XOTclReverseClasses(cl->super);
11340          rc = AppendMatchingElementsFromClasses(interp, clSuper, pattern, matchObject);
11341          XOTclFreeClasses(clSuper);
11342        }
11343        if (matchObject) {
11344          Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
11345        }
11346        DSTRING_FREE(dsPtr);
11347        return TCL_OK;
11348
11349      } else if (!strcmp(cmd, "subclass")) {
11350        int withClosure = 0, rc;
11351        XOTclObject *matchObject;
11352        Tcl_DString ds, *dsPtr = &ds;
11353
11354        if (objc-modifiers > 3 || modifiers > 1)
11355          return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11356                                   "info subclass ?-closure? ?pattern?");
11357        if (modifiers > 0) {
11358            withClosure = checkForModifier(objv, modifiers, "-closure");
11359            if (withClosure == 0)
11360              return XOTclVarErrMsg(interp, "info subclass: unknown modifier ",
11361                                    ObjStr(objv[2]), (char *) NULL);
11362        }
11363
11364        DSTRING_INIT(dsPtr);
11365        if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) {
11366          return TCL_OK;
11367        }
11368
11369        if (withClosure) {
11370          XOTclClasses *saved = cl->order, *subclasses;
11371          cl->order = NULL;
11372          subclasses = ComputeOrder(cl, cl->order, Sub);
11373          cl->order = saved;
11374          rc = AppendMatchingElementsFromClasses(interp, subclasses ? subclasses->next : NULL,
11375                                                 pattern, matchObject);
11376          XOTclFreeClasses(subclasses);
11377        } else {
11378          rc = AppendMatchingElementsFromClasses(interp, cl->sub, pattern, matchObject);
11379        }
11380        if (matchObject) {
11381          Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]);
11382        }
11383        DSTRING_FREE(dsPtr);
11384        return TCL_OK;
11385
11386      } else if (!strcmp(cmd, "slots")) {
11387        Tcl_DString ds, *dsPtr = &ds;
11388        XOTclObject *o;
11389        int rc;
11390        DSTRING_INIT(dsPtr);
11391        Tcl_DStringAppend(dsPtr, className(cl), -1);
11392        Tcl_DStringAppend(dsPtr, "::slot", 6);
11393        o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr));
11394        if (o) {
11395          rc = ListChildren(interp, o, NULL, 0);
11396        } else {
11397          rc = TCL_OK;
11398        }
11399        DSTRING_FREE(dsPtr);
11400        return rc;
11401      }
11402      break;
11403    }
11404  }
11405
11406  return XOTclOInfoMethod(cd, interp, objc, (Tcl_Obj **)objv);
11407}
11408
11409static int
11410XOTclCParameterMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11411  XOTclClass *cl = XOTclObjectToClass(cd);
11412  Tcl_Obj     **pv;
11413  int         elts, pc,  result;
11414  char *      params;
11415  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11416  if (objc != 2)
11417    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "parameter ?params?");
11418  if (cl->parameters) {
11419    DECR_REF_COUNT(cl->parameters);
11420  }
11421
11422  /* did we delete the parameters ? */
11423  params = ObjStr(objv[1]);
11424  if ((params == NULL) || (*params == '\0')) {
11425    cl->parameters = NULL;
11426    return TCL_OK;
11427  }
11428
11429  /* ok, remember the params */
11430  cl->parameters = objv[1];
11431  INCR_REF_COUNT(cl->parameters);
11432
11433  /* call getter/setter methods in params */
11434  result = Tcl_ListObjGetElements(interp, objv[1], &pc, &pv);
11435  if (result == TCL_OK) {
11436    for (elts = 0; elts < pc; elts++) {
11437      result = callParameterMethodWithArg(&cl->object, interp,
11438                                          XOTclGlobalObjects[XOTE_MKGETTERSETTER],
11439                                          cl->object.cmdName, 3+1, &pv[elts], 0);
11440      if (result != TCL_OK)
11441        break;
11442    }
11443  }
11444  return result;
11445}
11446
11447static int
11448XOTclCParameterClassMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11449  XOTclClass *cl = XOTclObjectToClass(cd);
11450  char *paramClStr;
11451  XOTclClassOpt *opt;
11452
11453  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11454  if (objc != 2)
11455    return XOTclObjErrArgCnt(interp, cl->object.cmdName, "parameterclass cl");
11456
11457  paramClStr = ObjStr(objv[1]);
11458  opt = cl->opt;
11459  if (opt && opt->parameterClass) {
11460    DECR_REF_COUNT(opt->parameterClass);
11461  }
11462  if ((paramClStr == NULL) || (*paramClStr == '\0')) {
11463    if (opt)
11464      opt->parameterClass = NULL;
11465  } else {
11466    opt = XOTclRequireClassOpt(cl);
11467    opt->parameterClass = objv[1];
11468    INCR_REF_COUNT(opt->parameterClass);
11469  }
11470  return TCL_OK;
11471}
11472
11473static int
11474XOTclCInstParameterCmdMethod(ClientData cd, Tcl_Interp *interp,
11475                             int objc, Tcl_Obj * CONST objv[]) {
11476  XOTclClass *cl = XOTclObjectToClass(cd);
11477
11478  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11479  if (objc < 2) return XOTclObjErrArgCnt(interp, cl->object.cmdName, "instparametercmd name");
11480  XOTclAddIMethod(interp, (XOTcl_Class*) cl, ObjStr(objv[1]),
11481                  (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0);
11482  return TCL_OK;
11483}
11484
11485static int
11486XOTclCParameterCmdMethod(ClientData cd, Tcl_Interp *interp,
11487                         int objc, Tcl_Obj * CONST objv[]) {
11488  XOTclObject *obj = (XOTclObject*) cd;
11489
11490  if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, "parametercmd name");
11491  XOTclAddPMethod(interp, (XOTcl_Object*) obj, ObjStr(objv[1]),
11492                  (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0);
11493  return TCL_OK;
11494}
11495
11496static void forwardCmdDeleteProc(ClientData cd) {
11497  forwardCmdClientData *tcd = (forwardCmdClientData *)cd;
11498  if (tcd->cmdName)     {DECR_REF_COUNT(tcd->cmdName);}
11499  if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);}
11500  if (tcd->prefix)      {DECR_REF_COUNT(tcd->prefix);}
11501  if (tcd->args)        {DECR_REF_COUNT(tcd->args);}
11502  FREE(forwardCmdClientData, tcd);
11503}
11504
11505static int
11506forwardProcessOptions(Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[],
11507                      forwardCmdClientData **tcdp) {
11508  forwardCmdClientData *tcd;
11509  int i, rc = 0, earlybinding = 0;
11510
11511  tcd = NEW(forwardCmdClientData);
11512  memset(tcd, 0, sizeof(forwardCmdClientData));
11513
11514  for (i=2; i<objc; i++) {
11515    /*fprintf(stderr, "   processing '%s'\n", ObjStr(objv[i]));*/
11516    if (!strcmp(ObjStr(objv[i]),"-default")) {
11517      if (objc <= i+1) {rc = TCL_ERROR; break;}
11518      tcd->subcommands = objv[i+1];
11519      rc = Tcl_ListObjLength(interp, objv[i+1],&tcd->nr_subcommands);
11520      if (rc != TCL_OK) break;
11521      INCR_REF_COUNT(tcd->subcommands);
11522      i++;
11523    } else if (!strcmp(ObjStr(objv[i]),"-methodprefix")) {
11524      if (objc <= i+1) {rc = TCL_ERROR; break;}
11525      tcd->prefix = objv[i+1];
11526      INCR_REF_COUNT(tcd->prefix);
11527      i++;
11528    } else if (!strcmp(ObjStr(objv[i]),"-objscope")) {
11529      tcd->objscope = 1;
11530    } else if (!strcmp(ObjStr(objv[i]),"-earlybinding")) {
11531      earlybinding = 1;
11532    } else if (!strcmp(ObjStr(objv[i]),"-verbose")) {
11533      tcd->verbose = 1;
11534    } else {
11535      break;
11536    }
11537  }
11538
11539  tcd->needobjmap = 0;
11540  for (; i<objc; i++) {
11541    char *element = ObjStr(objv[i]);
11542    tcd->needobjmap |= (*element == '%' && *(element+1) == '@');
11543
11544    if (tcd->cmdName == NULL) {
11545      tcd->cmdName = objv[i];
11546    } else if (tcd->args == NULL) {
11547      tcd->args = Tcl_NewListObj(1, &objv[i]);
11548      tcd->nr_args++;
11549      INCR_REF_COUNT(tcd->args);
11550    } else {
11551      Tcl_ListObjAppendElement(interp, tcd->args, objv[i]);
11552      tcd->nr_args++;
11553    }
11554  }
11555
11556  if (!tcd->cmdName) {
11557    tcd->cmdName = objv[1];
11558  }
11559
11560  if (tcd->objscope) {
11561    /* when we evaluating objscope, and define ...
11562       o forward append -objscope append
11563       a call to
11564       o append ...
11565       would lead to a recursive call; so we add the appropriate namespace
11566    */
11567    char *name = ObjStr(tcd->cmdName);
11568    if (!isAbsolutePath(name)) {
11569      tcd->cmdName = NameInNamespaceObj(interp, name, callingNameSpace(interp));
11570      /*fprintf(stderr,"name %s not absolute, therefore qualifying %s\n", name,
11571        ObjStr(tcd->cmdName));*/
11572    }
11573  }
11574  INCR_REF_COUNT(tcd->cmdName);
11575
11576  if (earlybinding) {
11577    Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName);
11578    if (cmd == NULL)
11579      return XOTclVarErrMsg(interp, "cannot lookup command '", ObjStr(tcd->cmdName), "'", (char *) NULL);
11580
11581    tcd->objProc = Tcl_Command_objProc(cmd);
11582    if (tcd->objProc == XOTclObjDispatch     /* don't do direct invoke on xotcl objects */
11583        || tcd->objProc == TclObjInterpProc  /* don't do direct invoke on tcl procs */
11584        ) {
11585      /* silently ignore earlybinding flag */
11586      tcd->objProc = NULL;
11587    } else {
11588      tcd->cd      = Tcl_Command_objClientData(cmd);
11589    }
11590  }
11591
11592  tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc;
11593
11594  /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/
11595  if (rc == TCL_OK) {
11596    *tcdp = tcd;
11597  } else {
11598    forwardCmdDeleteProc((ClientData)tcd);
11599  }
11600  return rc;
11601}
11602
11603
11604static int
11605XOTclCInstForwardMethod(ClientData cd, Tcl_Interp *interp,
11606                        int objc, Tcl_Obj * CONST objv[]) {
11607  XOTclClass *cl = XOTclObjectToClass(cd);
11608  forwardCmdClientData *tcd;
11609  int rc;
11610
11611  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11612  if (objc < 2) goto forward_argc_error;
11613  rc = forwardProcessOptions(interp, objc, objv, &tcd);
11614
11615  if (rc == TCL_OK) {
11616    tcd->obj = &cl->object;
11617    XOTclAddIMethod(interp, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])),
11618                    (Tcl_ObjCmdProc*)XOTclForwardMethod,
11619                    (ClientData)tcd, forwardCmdDeleteProc);
11620    return TCL_OK;
11621  } else {
11622    forwardCmdDeleteProc((ClientData)tcd);
11623  forward_argc_error:
11624    return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11625                             "instforward method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?");
11626  }
11627}
11628
11629static int
11630XOTclOForwardMethod(ClientData cd, Tcl_Interp *interp,
11631                    int objc, Tcl_Obj * CONST objv[]) {
11632  XOTcl_Object *obj = (XOTcl_Object*) cd;
11633  forwardCmdClientData *tcd;
11634  int rc;
11635
11636  if (!obj) return XOTclObjErrType(interp, objv[0], "Object");
11637  if (objc < 2) goto forward_argc_error;
11638
11639  rc = forwardProcessOptions(interp, objc, objv, &tcd);
11640
11641  if (rc == TCL_OK) {
11642    tcd->obj = (XOTclObject*)obj;
11643    XOTclAddPMethod(interp, obj, NSTail(ObjStr(objv[1])),
11644                    (Tcl_ObjCmdProc*)XOTclForwardMethod,
11645                    (ClientData)tcd, forwardCmdDeleteProc);
11646    return TCL_OK;
11647  } else {
11648    forwardCmdDeleteProc((ClientData)tcd);
11649  forward_argc_error:
11650    return XOTclObjErrArgCnt(interp, obj->cmdName,
11651                             "forward method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?");
11652  }
11653}
11654
11655
11656static int
11657XOTclOVolatileMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
11658  XOTclObject *obj = (XOTclObject*) cd;
11659  Tcl_Obj *o = obj->cmdName;
11660  int result = TCL_ERROR;
11661  CONST char *fullName = ObjStr(o);
11662  CONST char *vn;
11663  callFrameContext ctx = {0};
11664
11665  if (objc != 1)
11666    return XOTclObjErrArgCnt(interp, obj->cmdName, "volatile");
11667
11668  if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) {
11669    fprintf(stderr,"### Can't make objects volatile during shutdown\n");
11670    return XOTclVarErrMsg(interp, "Can't make objects volatile during shutdown\n", NULL);
11671  }
11672
11673  CallStackUseActiveFrames(interp, &ctx);
11674  vn = NSTail(fullName);
11675
11676  if (Tcl_SetVar2(interp, vn, NULL, fullName, 0)) {
11677    XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj);
11678
11679    /*fprintf(stderr,"### setting trace for %s\n", fullName);*/
11680    result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS, (Tcl_VarTraceProc*)XOTclUnsetTrace,
11681                          (ClientData)o);
11682    opt->volatileVarName = vn;
11683  }
11684  CallStackRestoreSavedFrames(interp, &ctx);
11685
11686  if (result == TCL_OK) {
11687    INCR_REF_COUNT(o);
11688  }
11689  return result;
11690}
11691
11692static int
11693XOTclCInstProcMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11694  XOTclClass *cl = XOTclObjectToClass(cd);
11695  char *argStr, *bdyStr, *name;
11696  XOTclClassOpt *opt;
11697  int incr = 0, result = TCL_OK;
11698
11699  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11700  if (objc < 4 || objc > 7)
11701    return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11702                             "instproc name ?non-positional-args? args body ?preAssertion postAssertion?");
11703
11704  if (objc == 5 || objc == 7) {
11705    incr = 1;
11706  }
11707
11708  argStr = ObjStr(objv[2 + incr]);
11709  bdyStr = ObjStr(objv[3 + incr]);
11710  name = ObjStr(objv[1 + incr]);
11711
11712  if ((cl == RUNTIME_STATE(interp)->theObject && isDestroyString(name)) ||
11713      (cl == RUNTIME_STATE(interp)->theClass && isInstDestroyString(name)) ||
11714      (cl == RUNTIME_STATE(interp)->theClass && isAllocString(name)) ||
11715      (cl == RUNTIME_STATE(interp)->theClass && isCreateString(name)))
11716    return XOTclVarErrMsg(interp, className(cl), " instproc: '", name, "' of ",
11717                          className(cl), " can not be overwritten. Derive a ",
11718                          "sub-class", (char *) NULL);
11719
11720  if (*argStr == 0 && *bdyStr == 0) {
11721    int rc;
11722    opt = cl->opt;
11723    if (opt && opt->assertions)
11724      AssertionRemoveProc(opt->assertions, name);
11725    rc = NSDeleteCmd(interp, cl->nsPtr, name);
11726    if (rc < 0)
11727      return XOTclVarErrMsg(interp, className(cl), " cannot delete instproc: '", name,
11728                            "' of class ", className(cl), (char *) NULL);
11729  } else {
11730    XOTclAssertionStore *aStore = NULL;
11731    if (objc > 5) {
11732      opt = XOTclRequireClassOpt(cl);
11733      if (!opt->assertions)
11734        opt->assertions = AssertionCreateStore();
11735      aStore = opt->assertions;
11736    }
11737    result = MakeProc(cl->nsPtr, aStore, &(cl->nonposArgsTable),
11738                      interp, objc, (Tcl_Obj **) objv, &cl->object);
11739  }
11740
11741  /* could be a filter or filter inheritance ... update filter orders */
11742  FilterInvalidateObjOrders(interp, cl);
11743
11744  return result;
11745}
11746
11747
11748static int
11749XOTclCInstFilterGuardMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11750  XOTclClass *cl = XOTclObjectToClass(cd);
11751  XOTclCmdList *h;
11752  XOTclClassOpt *opt;
11753
11754  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11755  if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11756                                          "instfilterguard filtername filterGuard");
11757
11758  opt = cl->opt;
11759  if (opt && opt->instfilters) {
11760    h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->instfilters);
11761    if (h) {
11762      if (h->clientData)
11763        GuardDel(h);
11764      GuardAdd(interp, h, objv[2]);
11765      FilterInvalidateObjOrders(interp, cl);
11766      return TCL_OK;
11767    }
11768  }
11769
11770  return XOTclVarErrMsg(interp, "Instfilterguard: can't find filter ",
11771                        ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName),
11772                        (char *) NULL);
11773}
11774
11775
11776static int
11777XOTclCInstMixinGuardMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11778  XOTclClass *cl = XOTclObjectToClass(cd);
11779  XOTclCmdList *h;
11780
11781  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11782  if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11783                                          "instmixinguard mixin guard");
11784
11785  if (cl->opt && cl->opt->instmixins) {
11786    XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1]));
11787    Tcl_Command mixinCmd = NULL;
11788    if (mixinCl) {
11789      mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName);
11790    }
11791    if (mixinCmd) {
11792      h = CmdListFindCmdInList(mixinCmd, cl->opt->instmixins);
11793      if (h) {
11794        if (h->clientData)
11795          GuardDel((XOTclCmdList*) h);
11796        GuardAdd(interp, h, objv[2]);
11797        MixinInvalidateObjOrders(interp, cl);
11798        return TCL_OK;
11799      }
11800    }
11801  }
11802
11803  return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ",
11804                        ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName),
11805                        (char *) NULL);
11806}
11807
11808static int
11809XOTclCInvariantsMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11810  XOTclClass *cl = XOTclObjectToClass(cd);
11811  XOTclClassOpt *opt;
11812
11813  if (!cl) return XOTclObjErrType(interp, objv[0], "Class");
11814  if (objc != 2)
11815    return XOTclObjErrArgCnt(interp, cl->object.cmdName,
11816                             "instinvar <invariantList>");
11817  opt = XOTclRequireClassOpt(cl);
11818
11819  if (opt->assertions)
11820    TclObjListFreeList(opt->assertions->invariants);
11821  else
11822    opt->assertions = AssertionCreateStore();
11823
11824  opt->assertions->invariants = AssertionNewList(interp, objv[1]);
11825  return TCL_OK;
11826}
11827
11828static int
11829XOTclCUnknownMethod(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11830  XOTclObject *obj = (XOTclObject*) cd;
11831  char *self = ObjStr(obj->cmdName);
11832  int rc;
11833
11834  if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], "message ?args .. args?");
11835  if (isCreateString(self))
11836    return XOTclVarErrMsg(interp, "error ", self, ": unable to dispatch '",
11837                          ObjStr(objv[1]), "'", (char *) NULL);
11838
11839  rc = callMethod(cd, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0);
11840  return rc;
11841}
11842
11843/*
11844 * New Tcl Commands
11845 */
11846static int
11847XOTcl_NSCopyCmds(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
11848  Tcl_Command cmd;
11849  Tcl_Obj *newFullCmdName, *oldFullCmdName;
11850  char *newName, *oldName, *name;
11851  Tcl_Namespace *ns, *newNs;
11852  Tcl_HashTable *cmdTable, *nonposArgsTable;
11853  Tcl_HashSearch hSrch;
11854  Tcl_HashEntry *hPtr;
11855  XOTclObject *obj;
11856  XOTclClass *cl;
11857
11858  if (objc != 3)
11859    return XOTclObjErrArgCnt(interp, NULL, "namespace_copycmds fromNs toNs");
11860
11861  ns = ObjFindNamespace(interp, objv[1]);
11862  if (!ns)
11863    return TCL_OK;
11864
11865  name = ObjStr(objv[1]);
11866  /* check, if we work on an object or class namespace */
11867  if (isClassName(name)) {
11868    cl  = XOTclpGetClass(interp, NSCutXOTclClasses(name));
11869    obj = (XOTclObject *)cl;
11870    nonposArgsTable = cl->nonposArgsTable;
11871  } else {
11872    cl  = NULL;
11873    obj = XOTclpGetObject(interp, name);
11874    nonposArgsTable = obj->nonposArgsTable;
11875  }
11876
11877  if (obj == NULL) {
11878    return XOTclVarErrMsg(interp, "CopyCmds argument 1 (",ObjStr(objv[1]),") is not an object",
11879			  NULL);
11880  }
11881  /*  obj = XOTclpGetObject(interp, ObjStr(objv[1]));*/
11882
11883  newNs = ObjFindNamespace(interp, objv[2]);
11884  if (!newNs)
11885    return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ",
11886                          ObjStr(objv[2]), " does not exist", (char *) NULL);
11887  /*
11888   * copy all procs & commands in the ns
11889   */
11890  cmdTable = Tcl_Namespace_cmdTable(ns);
11891  hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch);
11892  while (hPtr) {
11893    name = Tcl_GetHashKey(cmdTable, hPtr);
11894
11895    /*
11896     * construct full cmd names
11897     */
11898    newFullCmdName = Tcl_NewStringObj(newNs->fullName,-1);
11899    oldFullCmdName = Tcl_NewStringObj(ns->fullName,-1);
11900
11901    INCR_REF_COUNT(newFullCmdName); INCR_REF_COUNT(oldFullCmdName);
11902    Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char *) NULL);
11903    Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char *) NULL);
11904    newName = ObjStr(newFullCmdName);
11905    oldName = ObjStr(oldFullCmdName);
11906
11907    /*
11908     * Make sure that the destination command does not already exist.
11909     * Otherwise: do not copy
11910     */
11911    cmd = Tcl_FindCommand(interp, newName, 0, 0);
11912    if (cmd) {
11913      /*fprintf(stderr, "%s already exists\n", newName);*/
11914      if (!XOTclpGetObject(interp, newName)) {
11915        /* command or instproc will be deleted & then copied */
11916        Tcl_DeleteCommandFromToken(interp, cmd);
11917      } else {
11918        /* don't overwrite objects -> will be recreated */
11919        hPtr = Tcl_NextHashEntry(&hSrch);
11920        DECR_REF_COUNT(newFullCmdName);
11921        DECR_REF_COUNT(oldFullCmdName);
11922        continue;
11923      }
11924    }
11925
11926    /*
11927     * Find the existing command. An error is returned if simpleName can't
11928     * be found
11929     */
11930    cmd = Tcl_FindCommand(interp, oldName, 0, 0);
11931    if (cmd == NULL) {
11932      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't copy ", " \"",
11933                             oldName, "\": command doesn't exist",
11934                             (char *) NULL);
11935      DECR_REF_COUNT(newFullCmdName);
11936      DECR_REF_COUNT(oldFullCmdName);
11937      return TCL_ERROR;
11938    }
11939    /*
11940     * Do not copy Objects or Classes
11941     */
11942    if (!XOTclpGetObject(interp, oldName)) {
11943      if (TclIsProc((Command*)cmd)) {
11944        Proc *procPtr = TclFindProc((Interp *)interp, oldName);
11945        Tcl_Obj *arglistObj = NULL;
11946        CompiledLocal *localPtr;
11947	XOTclNonposArgs *nonposArgs = NULL;
11948
11949        /*
11950         * Build a list containing the arguments of the proc
11951         */
11952
11953	if (nonposArgsTable) {
11954	  nonposArgs = NonposArgsGet(nonposArgsTable, name);
11955	  if (nonposArgs) {
11956            arglistObj = NonposArgsFormat(interp, nonposArgs->nonposArgs);
11957	    INCR_REF_COUNT(arglistObj);
11958	    AppendOrdinaryArgsFromNonposArgs(interp, nonposArgs, 0, arglistObj);
11959	  }
11960	}
11961
11962	if (!arglistObj) {
11963	  arglistObj = Tcl_NewListObj(0, NULL);
11964	  INCR_REF_COUNT(arglistObj);
11965
11966	  for (localPtr = procPtr->firstLocalPtr;  localPtr;
11967	       localPtr = localPtr->nextPtr) {
11968
11969	    if (TclIsCompiledLocalArgument(localPtr)) {
11970	      Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1);
11971	      INCR_REF_COUNT(defStringObj);
11972
11973	      /* check for default values */
11974	      if ((GetProcDefault(interp, cmdTable, name,
11975				  localPtr->name, &defVal) == TCL_OK) && defVal) {
11976		Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal),
11977				       (char *) NULL);
11978	      }
11979	      Tcl_ListObjAppendElement(interp, arglistObj, defStringObj);
11980	      DECR_REF_COUNT(defStringObj);
11981	    }
11982          }
11983        }
11984
11985        if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) {
11986          Tcl_DString ds, *dsPtr = &ds;
11987
11988          if (cl) {
11989            /* we have a class */
11990            XOTclProcAssertion *procs;
11991
11992            if (cl) {
11993              procs = cl->opt ?
11994                AssertionFindProcs(cl->opt->assertions, name) : 0;
11995            } else {
11996              DECR_REF_COUNT(newFullCmdName);
11997              DECR_REF_COUNT(oldFullCmdName);
11998              DECR_REF_COUNT(arglistObj);
11999              return XOTclVarErrMsg(interp, "No class for inst - assertions", (char *) NULL);
12000            }
12001
12002            /* XOTcl InstProc */
12003            DSTRING_INIT(dsPtr);
12004            Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(newNs->fullName));
12005            Tcl_DStringAppendElement(dsPtr, "instproc");
12006            Tcl_DStringAppendElement(dsPtr, name);
12007            Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj));
12008            Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr)));
12009            if (procs) {
12010              XOTclRequireClassOpt(cl);
12011              AssertionAppendPrePost(interp, dsPtr, procs);
12012            }
12013            Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0);
12014            DSTRING_FREE(dsPtr);
12015          } else {
12016            XOTclObject *obj = XOTclpGetObject(interp, ns->fullName);
12017            XOTclProcAssertion *procs;
12018            if (obj) {
12019              procs = obj->opt ?
12020                AssertionFindProcs(obj->opt->assertions, name) : 0;
12021            } else {
12022              DECR_REF_COUNT(newFullCmdName);
12023              DECR_REF_COUNT(oldFullCmdName);
12024              DECR_REF_COUNT(arglistObj);
12025              return XOTclVarErrMsg(interp, "No object for assertions", (char *) NULL);
12026            }
12027
12028            /* XOTcl Proc */
12029            DSTRING_INIT(dsPtr);
12030            Tcl_DStringAppendElement(dsPtr, newNs->fullName);
12031            Tcl_DStringAppendElement(dsPtr, "proc");
12032            Tcl_DStringAppendElement(dsPtr, name);
12033            Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj));
12034            Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr)));
12035            if (procs) {
12036              XOTclRequireObjectOpt(obj);
12037              AssertionAppendPrePost(interp, dsPtr, procs);
12038            }
12039            Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), 0);
12040            DSTRING_FREE(dsPtr);
12041          }
12042          DECR_REF_COUNT(arglistObj);
12043        } else {
12044          /* Tcl Proc */
12045          Tcl_VarEval(interp, "proc ", newName, " {", ObjStr(arglistObj),"} {\n",
12046                      ObjStr(procPtr->bodyPtr), "}", (char *) NULL);
12047        }
12048      } else {
12049        /*
12050         * Otherwise copy command
12051         */
12052        Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd);
12053        Tcl_CmdDeleteProc *deleteProc = Tcl_Command_deleteProc(cmd);
12054        ClientData cd;
12055        if (objProc) {
12056          cd = Tcl_Command_objClientData(cmd);
12057          if (cd == NULL || cd == XOTCL_NONLEAF_METHOD) {
12058            /* if client data not null, we would have to copy
12059               the client data; we don't know its size...., so rely
12060               on introspection for copying */
12061            Tcl_CreateObjCommand(interp, newName, objProc,
12062                                 Tcl_Command_objClientData(cmd), deleteProc);
12063          }
12064        } else {
12065          cd = Tcl_Command_clientData(cmd);
12066          if (cd == NULL || cd == XOTCL_NONLEAF_METHOD) {
12067            Tcl_CreateCommand(interp, newName, Tcl_Command_proc(cmd),
12068                              Tcl_Command_clientData(cmd), deleteProc);
12069          }
12070        }
12071      }
12072    }
12073    hPtr = Tcl_NextHashEntry(&hSrch);
12074    DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName);
12075  }
12076  return TCL_OK;
12077}
12078
12079static int
12080XOTcl_NSCopyVars(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
12081  Tcl_Namespace *ns, *newNs;
12082  Var *varPtr = NULL;
12083  Tcl_HashSearch hSrch;
12084  Tcl_HashEntry *hPtr;
12085  TclVarHashTable *varTable;
12086  int rc = TCL_OK;
12087  XOTclObject *obj;
12088  char *destFullName;
12089  Tcl_Obj *destFullNameObj;
12090  TclCallFrame frame, *framePtr = &frame;
12091  Tcl_Obj *varNameObj = NULL;
12092  Tcl_Obj *nobjv[4];
12093  int nobjc;
12094  Tcl_Obj *setObj;
12095
12096  if (objc != 3)
12097    return XOTclObjErrArgCnt(interp, NULL, "namespace_copyvars fromNs toNs");
12098
12099  ns = ObjFindNamespace(interp, objv[1]);
12100  if (ns) {
12101    newNs = ObjFindNamespace(interp, objv[2]);
12102    if (!newNs)
12103      return XOTclVarErrMsg(interp, "CopyVars: Destination namespace ",
12104                            ObjStr(objv[2]), " does not exist", (char *) NULL);
12105
12106    obj = XOTclpGetObject(interp, ObjStr(objv[1]));
12107    destFullName = newNs->fullName;
12108    destFullNameObj = Tcl_NewStringObj(destFullName, -1);
12109    INCR_REF_COUNT(destFullNameObj);
12110    varTable = Tcl_Namespace_varTable(ns);
12111    Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, newNs, 0);
12112  } else {
12113    XOTclObject *newObj;
12114    if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) {
12115      return XOTclVarErrMsg(interp, "CopyVars: Origin object/namespace ",
12116                            ObjStr(objv[1]), " does not exist", (char *) NULL);
12117    }
12118    if (XOTclObjConvertObject(interp, objv[2], &newObj) != TCL_OK) {
12119      return XOTclVarErrMsg(interp, "CopyVars: Destination object/namespace ",
12120                            ObjStr(objv[2]), " does not exist", (char *) NULL);
12121    }
12122    varTable = obj->varTable;
12123    destFullNameObj = newObj->cmdName;
12124    destFullName = ObjStr(destFullNameObj);
12125  }
12126
12127  setObj= Tcl_NewStringObj("set", 3);
12128  INCR_REF_COUNT(setObj);
12129  nobjc = 4;
12130  nobjv[0] = destFullNameObj;
12131  nobjv[1] = setObj;
12132
12133  /* copy all vars in the namespace */
12134  hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : 0;
12135  while (hPtr) {
12136
12137    getVarAndNameFromHash(hPtr, &varPtr, &varNameObj);
12138    INCR_REF_COUNT(varNameObj);
12139
12140    if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) {
12141      if (TclIsVarScalar(varPtr)) {
12142        /* it may seem odd that we do not copy obj vars with the
12143         * same SetVar2 as normal vars, but we want to dispatch it in order to
12144         * be able to intercept the copying */
12145
12146        if (obj) {
12147          nobjv[2] = varNameObj;
12148          nobjv[3] = valueOfVar(Tcl_Obj, varPtr, objPtr);
12149          rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0);
12150        } else {
12151          Tcl_ObjSetVar2(interp, varNameObj, NULL,
12152                         valueOfVar(Tcl_Obj, varPtr, objPtr),
12153                         TCL_NAMESPACE_ONLY);
12154        }
12155      } else {
12156        if (TclIsVarArray(varPtr)) {
12157          /* HERE!! PRE85 Why not [array get/set] based? Let the core iterate*/
12158          TclVarHashTable *aTable = valueOfVar(TclVarHashTable, varPtr, tablePtr);
12159          Tcl_HashSearch ahSrch;
12160          Tcl_HashEntry *ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) :0;
12161          for (; ahPtr; ahPtr = Tcl_NextHashEntry(&ahSrch)) {
12162            Tcl_Obj *eltNameObj;
12163            Var *eltVar;
12164
12165            getVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj);
12166
12167            INCR_REF_COUNT(eltNameObj);
12168
12169            if (TclIsVarScalar(eltVar)) {
12170              if (obj) {
12171                Tcl_Obj *fullVarNameObj = Tcl_DuplicateObj(varNameObj);
12172
12173                INCR_REF_COUNT(fullVarNameObj);
12174                Tcl_AppendStringsToObj(fullVarNameObj, "(",
12175                                       ObjStr(eltNameObj), ")", NULL);
12176                nobjv[2] = fullVarNameObj;
12177                nobjv[3] = valueOfVar(Tcl_Obj, eltVar, objPtr);
12178
12179                rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0);
12180                DECR_REF_COUNT(fullVarNameObj);
12181              } else {
12182                Tcl_ObjSetVar2(interp, varNameObj, eltNameObj,
12183                               valueOfVar(Tcl_Obj, eltVar, objPtr),
12184                               TCL_NAMESPACE_ONLY);
12185              }
12186            }
12187            DECR_REF_COUNT(eltNameObj);
12188          }
12189        }
12190      }
12191    }
12192    DECR_REF_COUNT(varNameObj);
12193    hPtr = Tcl_NextHashEntry(&hSrch);
12194  }
12195  if (ns) {
12196    DECR_REF_COUNT(destFullNameObj);
12197    Tcl_PopCallFrame(interp);
12198  }
12199  DECR_REF_COUNT(setObj);
12200  return rc;
12201}
12202
12203int
12204XOTclSelfDispatchCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
12205  XOTclObject *self;
12206  int result;
12207  if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], "::xotcl::my method ?args?");
12208  if ((self = GetSelfObj(interp))) {
12209    result = DoDispatch((ClientData)self, interp, objc, objv, 0);
12210 } else {
12211    result = XOTclVarErrMsg(interp, "Cannot resolve 'self', probably called outside the context of an XOTcl Object",
12212                            (char *) NULL);
12213  }
12214  return result;
12215}
12216
12217#if defined(PRE85) || defined(NRE)
12218int
12219XOTclInitProcNSCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
12220  Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp);
12221
12222  /*RUNTIME_STATE(interp)->varFramePtr = varFramePtr;*/
12223#if 0
12224  Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(RUNTIME_STATE(interp)->cs.top->cmdPtr);
12225  fprintf(stderr,"initProcNS self=%s cmd=%p, '%s'\n",
12226          ObjStr(RUNTIME_STATE(interp)->cs.top->self->cmdName),
12227          nsPtr, nsPtr->fullName);
12228  fprintf(stderr,"\tsetting currentFramePtr in %p to %p in initProcNS\n",
12229          RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr);
12230  XOTclCallStackDump(interp);
12231#endif
12232
12233  if (RUNTIME_STATE(interp)->cs.top->currentFramePtr == NULL) {
12234    RUNTIME_STATE(interp)->cs.top->currentFramePtr = varFramePtr;
12235  } /* else {
12236
12237  fprintf(stderr,"not overwriting currentFramePtr in %p from %p to %p\n",
12238  RUNTIME_STATE(interp)->cs.top,
12239  RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr);
12240  }     */
12241
12242#if !defined(NAMESPACEINSTPROCS)
12243  if (varFramePtr) {
12244    varFramePtr->nsPtr = GetCallerVarFrame(interp, varFramePtr);
12245  }
12246#endif
12247  return TCL_OK;
12248}
12249#endif
12250
12251/*
12252 * Interpretation of Non-Positional Args
12253 */
12254int
12255isNonposArg(Tcl_Interp *interp, char * argStr,
12256            int nonposArgsDefc, Tcl_Obj **nonposArgsDefv,
12257            Tcl_Obj **var,  char **type) {
12258  int i, npac;
12259  Tcl_Obj **npav;
12260  char *varName;
12261  if (argStr[0] == '-') {
12262    for (i=0; i < nonposArgsDefc; i++) {
12263      if (Tcl_ListObjGetElements(interp, nonposArgsDefv[i],
12264                                 &npac, &npav) == TCL_OK && npac > 0) {
12265        varName = argStr+1;
12266        if (!strcmp(varName, ObjStr(npav[0]))) {
12267          *var = npav[0];
12268          *type = ObjStr(npav[1]);
12269          return 1;
12270        }
12271      }
12272    }
12273  }
12274  return 0;
12275}
12276
12277int
12278XOTclCheckBooleanArgs(ClientData cd, Tcl_Interp *interp, int objc,
12279                      Tcl_Obj *CONST objv[]) {
12280  int result, bool;
12281  Tcl_Obj *boolean;
12282
12283  if (objc == 2) {
12284    /* the variable is not yet defined (set), so we cannot check
12285       whether it is boolean or not */
12286    return TCL_OK;
12287  } else if (objc != 3) {
12288    return XOTclObjErrArgCnt(interp, NULL,
12289                             "::xotcl::nonposArgs boolean name ?value?");
12290  }
12291
12292  boolean = Tcl_DuplicateObj(objv[2]);
12293  INCR_REF_COUNT(boolean);
12294  result = Tcl_GetBooleanFromObj(interp, boolean, &bool);
12295  DECR_REF_COUNT(boolean);
12296  /*
12297    result = TCL_OK;
12298  */
12299  if (result != TCL_OK)
12300    return XOTclVarErrMsg(interp,
12301                          "non-positional argument: '", ObjStr(objv[1]), "' with value '",
12302                          ObjStr(objv[2]), "' is not of type boolean",
12303                          (char *) NULL);
12304  return TCL_OK;
12305}
12306
12307int
12308XOTclCheckRequiredArgs(ClientData cd, Tcl_Interp *interp, int objc,
12309                       Tcl_Obj *CONST objv[]) {
12310  if (objc != 2 && objc != 3)
12311    return XOTclObjErrArgCnt(interp, NULL,
12312                             "::xotcl::nonposArgs required <args> ?currentValue?");
12313
12314  if (objc != 3)
12315    return XOTclVarErrMsg(interp,
12316                          "required arg: '", ObjStr(objv[1]), "' missing",
12317                          (char *) NULL);
12318  return TCL_OK;
12319}
12320
12321int
12322XOTclInterpretNonpositionalArgsCmd(ClientData cd, Tcl_Interp *interp, int objc,
12323                                   Tcl_Obj *CONST objv[]) {
12324  Tcl_Obj **npav, **checkv, **checkArgv, **argsv, **nonposArgsDefv,
12325    *invocation[4], **ordinaryArgsDefv, **defaultValueObjv, *list,
12326    *checkObj, *ordinaryArg;
12327  int npac, checkc, checkArgc, argsc, nonposArgsDefc,
12328    ordinaryArgsDefc, defaultValueObjc, argsDefined = 0,
12329    ordinaryArgsCounter = 0, i, j, result, ic;
12330  char * lastDefArg = NULL, *arg, *argStr;
12331  int endOfNonposArgsReached = 0;
12332  Var *varPtr;
12333
12334  XOTclClass *selfClass = GetSelfClass(interp);
12335  char *methodName = (char *) GetSelfProc(interp);
12336  Tcl_HashTable *nonposArgsTable;
12337  XOTclNonposArgs *nonposArgs;
12338  XOTclObject *selfObj;
12339  int r1, r2, r3, r4;
12340
12341  if (objc != 2)
12342    return XOTclObjErrArgCnt(interp, NULL,
12343                             "::xotcl::interpretNonpositionalArgs <args>");
12344
12345  if (selfClass) {
12346    nonposArgsTable = selfClass->nonposArgsTable;
12347  } else if ((selfObj = GetSelfObj(interp))) {
12348    nonposArgsTable = selfObj->nonposArgsTable;
12349  } else {
12350    return XOTclVarErrMsg(interp, "Non positional args: can't find self/self class",
12351                          (char *) NULL);
12352  }
12353
12354  nonposArgs = NonposArgsGet(nonposArgsTable, methodName);
12355  if (nonposArgs == 0) {
12356    return XOTclVarErrMsg(interp,
12357                          "Non positional args: can't find hash entry for: ",
12358                          methodName,
12359                          (char *) NULL);
12360  }
12361
12362  r1 = Tcl_ListObjGetElements(interp, nonposArgs->nonposArgs,
12363                              &nonposArgsDefc, &nonposArgsDefv);
12364  r2 = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs,
12365                              &ordinaryArgsDefc, &ordinaryArgsDefv);
12366  r3 = Tcl_ListObjGetElements(interp, objv[1], &argsc, &argsv);
12367
12368
12369  if (r1 != TCL_OK || r2 != TCL_OK || r3 != TCL_OK) {
12370    return XOTclVarErrMsg(interp,
12371                          "Cannot split non positional args list: ",
12372                          methodName,
12373                          (char *) NULL);
12374  }
12375
12376  /* setting variables to default values */
12377  for (i=0; i < nonposArgsDefc; i++) {
12378    r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav);
12379    if (r1 == TCL_OK) {
12380      if (npac == 3) {
12381          Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, npav[2], 0);
12382          /* for unknown reasons, we can't use  Tcl_ObjSetVar2 here in case the
12383             variable is referenced via eval (sample murr6) */
12384          /* Tcl_ObjSetVar2(interp, npav[0], NULL, npav[2], 0); */
12385      } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) {
12386        Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, Tcl_NewBooleanObj(0), 0);
12387      }
12388    }
12389  }
12390
12391  if (ordinaryArgsDefc > 0) {
12392    lastDefArg = ObjStr(ordinaryArgsDefv[ordinaryArgsDefc-1]);
12393    if (isArgsString(lastDefArg)) {
12394      argsDefined = 1;
12395    }
12396  }
12397
12398  /* setting specified variables */
12399  for (i=0; i < argsc; i++) {
12400
12401    if (!endOfNonposArgsReached) {
12402      char *type;
12403      Tcl_Obj *var;
12404      argStr = ObjStr(argsv[i]);
12405
12406      if (isDoubleDashString(argStr)) {
12407        endOfNonposArgsReached = 1;
12408        i++;
12409      }
12410      if (isNonposArg(interp, argStr, nonposArgsDefc, nonposArgsDefv, &var,&type)) {
12411        if (*type == 's' && !strcmp(type, "switch")) {
12412          int bool;
12413          Tcl_Obj *boolObj = Tcl_ObjGetVar2(interp, var, 0, 0);
12414          if (Tcl_GetBooleanFromObj(interp, boolObj, &bool) != TCL_OK) {
12415            return XOTclVarErrMsg(interp, "Non positional arg '", argStr,
12416                                  "': no boolean value", (char *) NULL);
12417          }
12418          Tcl_SetVar2Ex(interp, ObjStr(var), NULL, Tcl_NewBooleanObj(!bool), 0);
12419          /*Tcl_ObjSetVar2(interp, var, NULL, Tcl_NewBooleanObj(!bool), 0); */
12420        } else {
12421          i++;
12422          if (i >= argsc)
12423            return XOTclVarErrMsg(interp, "Non positional arg '",
12424                                  argStr, "': value missing", (char *) NULL);
12425          Tcl_SetVar2Ex(interp, ObjStr(var), NULL, argsv[i], 0);
12426          /* Tcl_ObjSetVar2(interp, var, NULL, argsv[i], 0);*/
12427        }
12428      } else {
12429        endOfNonposArgsReached = 1;
12430      }
12431    }
12432
12433    if (endOfNonposArgsReached && i < argsc) {
12434      if (ordinaryArgsCounter >= ordinaryArgsDefc) {
12435        Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs);
12436        XOTclVarErrMsg(interp, "unknown argument '",
12437                       ObjStr(argsv[i]),
12438                       "' for method '",
12439                       methodName,
12440                       "': valid arguments ",
12441                       ObjStr(tmp),
12442                       " ",
12443                       ObjStr(nonposArgs->ordinaryArgs),
12444                       (char *) NULL);
12445        DECR_REF_COUNT(tmp);
12446        return TCL_ERROR;
12447      }
12448      arg = ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]);
12449      /* this is the last arg and 'args' is defined */
12450      if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) {
12451        list = Tcl_NewListObj(0, NULL);
12452        INCR_REF_COUNT(list);
12453        for(; i < argsc; i++)
12454          Tcl_ListObjAppendElement(interp, list, argsv[i]);
12455        Tcl_ObjSetVar2(interp, ordinaryArgsDefv[ordinaryArgsCounter], NULL, list, 0);
12456        DECR_REF_COUNT(list);
12457      } else {
12458        /* break down this argument, if it has a default value,
12459           use only the first part */
12460        ordinaryArg = ordinaryArgsDefv[ordinaryArgsCounter];
12461        r4 = Tcl_ListObjGetElements(interp, ordinaryArg,
12462                                    &defaultValueObjc, &defaultValueObjv);
12463        if (r4 == TCL_OK && defaultValueObjc == 2) {
12464          ordinaryArg = defaultValueObjv[0];
12465        }
12466        Tcl_ObjSetVar2(interp, ordinaryArg, NULL, argsv[i], 0);
12467      }
12468      ordinaryArgsCounter++;
12469    }
12470  }
12471
12472  /*fprintf(stderr,"... args defined %d argsc=%d  oa %d oad %d\n",
12473	  argsDefined, argsc,
12474	  ordinaryArgsCounter, ordinaryArgsDefc); */
12475
12476  if ((!argsDefined && ordinaryArgsCounter != ordinaryArgsDefc) ||
12477      (argsDefined && ordinaryArgsCounter < ordinaryArgsDefc-1)) {
12478
12479    /* we do not have enough arguments, maybe there are default arguments
12480       for the missing args */
12481    while (ordinaryArgsCounter != ordinaryArgsDefc) {
12482      if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc)
12483        break;
12484      r4 = Tcl_ListObjGetElements(interp, ordinaryArgsDefv[ordinaryArgsCounter],
12485                                  &defaultValueObjc, &defaultValueObjv);
12486      /*fprintf(stderr,"... try to get default for '%s', rc %d, objc %d\n",
12487	      ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]),
12488	      r4, defaultValueObjc);*/
12489      if (r4 == TCL_OK && defaultValueObjc == 2) {
12490        Tcl_ObjSetVar2(interp, defaultValueObjv[0], NULL, defaultValueObjv[1], 0);
12491      } else {
12492        Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs);
12493        XOTclVarErrMsg(interp, "wrong # args for method '",
12494                       methodName, "': valid arguments ", ObjStr(tmp), " ",
12495                       ObjStr(nonposArgs->ordinaryArgs),
12496                       (char *) NULL);
12497        DECR_REF_COUNT(tmp);
12498        return TCL_ERROR;
12499      }
12500      ordinaryArgsCounter++;
12501    }
12502    if (argsDefined) {
12503      Tcl_SetVar2(interp, "args", NULL, "", 0);
12504    }
12505  } else if (argsDefined && ordinaryArgsCounter == ordinaryArgsDefc-1) {
12506    Tcl_SetVar2(interp, "args", NULL, "", 0);
12507  }
12508
12509  if (!argsDefined) {
12510    Tcl_UnsetVar2(interp, "args", NULL, 0);
12511  }
12512
12513  /* checking vars */
12514  for (i=0; i < nonposArgsDefc; i++) {
12515    r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav);
12516    if (r1 == TCL_OK &&  npac > 1 && *(ObjStr(npav[1])) != '\0') {
12517      r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv);
12518      if (r1 == TCL_OK) {
12519        checkObj = XOTclGlobalObjects[XOTE_NON_POS_ARGS_OBJ];
12520        for (j=0; j < checkc; j++) {
12521          r1 = Tcl_ListObjGetElements(interp, checkv[j], &checkArgc, &checkArgv);
12522          if (r1 == TCL_OK && checkArgc > 1) {
12523            if (isCheckObjString((ObjStr(checkArgv[0]))) && checkArgc == 2) {
12524              checkObj = checkArgv[1];
12525              continue;
12526            }
12527          }
12528          invocation[0] = checkObj;
12529          invocation[1] = checkv[j];
12530          varPtr = TclVarTraceExists(interp, ObjStr(npav[0]));
12531          invocation[2] = npav[0];
12532          ic = 3;
12533          if (varPtr && !TclIsVarUndefined(varPtr)) {
12534            invocation[3] = Tcl_ObjGetVar2(interp, npav[0], 0, 0);
12535            ic = 4;
12536          }
12537          result = Tcl_EvalObjv(interp, ic, invocation, 0);
12538          /*
12539            objPtr = Tcl_ConcatObj(ic, invocation);
12540            fprintf(stderr,"eval on <%s>\n", ObjStr(objPtr));
12541            result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
12542          */
12543          if (result != TCL_OK) {
12544            return result;
12545          }
12546        }
12547      }
12548    }
12549  }
12550  return TCL_OK;
12551}
12552
12553
12554/* create a slave interp that calls XOTcl Init */
12555static int
12556XOTcl_InterpObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
12557  Tcl_Interp *slave;
12558  char *subCmd;
12559  ALLOC_ON_STACK(Tcl_Obj*, objc, ov);
12560
12561  memcpy(ov, objv, sizeof(Tcl_Obj *)*objc);
12562  if (objc < 1) {
12563    XOTclObjErrArgCnt(interp, NULL, "::xotcl::interp name ?args?");
12564    goto interp_error;
12565  }
12566
12567  ov[0] = XOTclGlobalObjects[XOTE_INTERP];
12568  if (Tcl_EvalObjv(interp, objc, ov, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) {
12569    goto interp_error;
12570  }
12571
12572  subCmd = ObjStr(ov[1]);
12573  if (isCreateString(subCmd)) {
12574    slave = Tcl_GetSlave(interp, ObjStr(ov[2]));
12575    if (!slave) {
12576      XOTclVarErrMsg(interp, "Creation of slave interpreter failed", (char *) NULL);
12577      goto interp_error;
12578    }
12579    if (Xotcl_Init(slave) == TCL_ERROR) {
12580      goto interp_error;
12581    }
12582#ifdef XOTCL_MEM_COUNT
12583    xotclMemCountInterpCounter++;
12584#endif
12585  }
12586  FREE_ON_STACK(Tcl_Obj *, ov);
12587  return TCL_OK;
12588 interp_error:
12589  FREE_ON_STACK(Tcl_Obj *, ov);
12590  return TCL_ERROR;
12591}
12592
12593extern Tcl_Obj*
12594XOTclOGetInstVar2(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2,
12595                  int flgs) {
12596  Tcl_Obj *result;
12597  XOTcl_FrameDecls;
12598
12599  XOTcl_PushFrame(interp, (XOTclObject*)obj);
12600  if (((XOTclObject*)obj)->nsPtr)
12601    flgs |= TCL_NAMESPACE_ONLY;
12602
12603  result = Tcl_ObjGetVar2(interp, name1, name2, flgs);
12604  XOTcl_PopFrame(interp, (XOTclObject*)obj);
12605
12606  return result;
12607}
12608
12609
12610#if !defined(NDEBUG)
12611static void
12612checkAllInstances(Tcl_Interp *interp, XOTclClass *cl, int lvl) {
12613  Tcl_HashSearch search;
12614  Tcl_HashEntry *hPtr;
12615  if (cl && cl->object.refCount>0) {
12616    /*fprintf(stderr,"checkallinstances %d cl=%p '%s'\n", lvl, cl, ObjStr(cl->object.cmdName));*/
12617    for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search);  hPtr;
12618         hPtr = Tcl_NextHashEntry(&search)) {
12619      XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr);
12620      assert(inst);
12621      assert(inst->refCount>0);
12622      assert(inst->cmdName->refCount>0);
12623      if (XOTclObjectIsClass(inst) && (XOTclClass*)inst != RUNTIME_STATE(interp)->theClass) {
12624        checkAllInstances(interp, (XOTclClass*) inst, lvl+1);
12625      }
12626    }
12627  }
12628}
12629#endif
12630
12631#ifdef DO_FULL_CLEANUP
12632/* delete global variables and procs */
12633static void
12634deleteProcsAndVars(Tcl_Interp *interp) {
12635  Tcl_Namespace *ns = Tcl_GetGlobalNamespace(interp);
12636  Tcl_HashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : NULL;
12637  Tcl_HashTable *cmdTable = ns ? Tcl_Namespace_cmdTable(ns) : NULL;
12638  Tcl_HashSearch search;
12639  Var *varPtr;
12640  Tcl_Command cmd;
12641  register Tcl_HashEntry *entryPtr;
12642  char *varName;
12643
12644  for (entryPtr = Tcl_FirstHashEntry(varTable, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) {
12645    Tcl_Obj *nameObj;
12646    getVarAndNameFromHash(entryPtr, &varPtr, &nameObj);
12647    if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) {
12648      /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/
12649      Tcl_UnsetVar2(interp, ObjStr(nameObj), (char *)NULL, TCL_GLOBAL_ONLY);
12650    }
12651  }
12652
12653  for (entryPtr = Tcl_FirstHashEntry(cmdTable, &search); entryPtr; entryPtr = Tcl_NextHashEntry(&search)) {
12654    cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
12655
12656    if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) {
12657      char *key = Tcl_GetHashKey(cmdTable, entryPtr);
12658
12659      /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n",
12660	      key, cmd, Tcl_Command_proc(cmd), Tcl_Command_objProc(cmd),
12661	      Tcl_Command_proc(cmd)==RUNTIME_STATE(interp)->objInterpProc);*/
12662
12663      Tcl_DeleteCommandFromToken(interp, cmd);
12664    }
12665  }
12666}
12667#endif
12668
12669
12670#ifdef DO_CLEANUP
12671static int
12672ClassHasSubclasses(XOTclClass *cl) {
12673  return (cl->sub != NULL);
12674}
12675
12676static int
12677ClassHasInstances(XOTclClass *cl) {
12678  Tcl_HashSearch hSrch;
12679  return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL);
12680}
12681
12682static int
12683ObjectHasChildren(Tcl_Interp *interp, XOTclObject *obj) {
12684  Tcl_Namespace *ns = obj->nsPtr;
12685  int result = 0;
12686
12687  if (ns) {
12688    Tcl_HashEntry *hPtr;
12689    Tcl_HashSearch hSrch;
12690    Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns);
12691    XOTcl_FrameDecls;
12692
12693    XOTcl_PushFrame(interp, obj);
12694    for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr;
12695         hPtr = Tcl_NextHashEntry(&hSrch)) {
12696      char *key = Tcl_GetHashKey(cmdTable, hPtr);
12697      if (XOTclpGetObject(interp, key)) {
12698        /*fprintf(stderr,"child = %s\n", key);*/
12699        result = 1;
12700        break;
12701      }
12702    }
12703    XOTcl_PopFrame(interp, obj);
12704  }
12705  return result;
12706}
12707
12708static void
12709freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandNameTable) {
12710  Tcl_HashEntry *hPtr, *hPtr2;
12711  Tcl_HashSearch hSrch, hSrch2;
12712  XOTclObject *object;
12713  XOTclClass  *thecls, *theobj, *cl;
12714  int deleted = 0;
12715
12716  /* fprintf(stderr,"??? freeAllXOTclObjectsAndClasses in %p\n", in); */
12717
12718  thecls = RUNTIME_STATE(interp)->theClass;
12719  theobj = RUNTIME_STATE(interp)->theObject;
12720  /***** PHYSICAL DESTROY *****/
12721  RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY;
12722
12723  /*
12724   * First delete all child commands of all objects, which are not
12725   * objects themselves. This will for example delete namespace
12726   * imprted commands and objects and will resolve potential loops in
12727   * the dependency graph. The result is a plain object/class tree.
12728   */
12729  for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
12730    char *key = Tcl_GetHashKey(commandNameTable, hPtr);
12731    object = XOTclpGetObject(interp, key);
12732
12733    if (object && object->nsPtr) {
12734      for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(object->nsPtr), &hSrch2); hPtr2;
12735           hPtr2 = Tcl_NextHashEntry(&hSrch2)) {
12736        Tcl_Command cmd = Tcl_GetHashValue(hPtr2);
12737        if (cmd &&  Tcl_Command_objProc(cmd) != XOTclObjDispatch) {
12738          Tcl_DeleteCommandFromToken(interp, cmd);
12739          deleted ++;
12740        }
12741      }
12742    }
12743  }
12744  /*fprintf(stderr, "deleted %d cmds\n", deleted);*/
12745
12746  while (1) {
12747    deleted = 0;
12748    for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
12749      char *key = Tcl_GetHashKey(commandNameTable, hPtr);
12750      object = XOTclpGetObject(interp, key);
12751      if (object && !XOTclObjectIsClass(object) && !ObjectHasChildren(interp, object)) {
12752        /* fprintf(stderr,"  ... delete object %s %p, class=%s\n", key, object,
12753           ObjStr(object->cl->object.cmdName));*/
12754        freeUnsetTraceVariable(interp, object);
12755        Tcl_DeleteCommandFromToken(interp, object->id);
12756        Tcl_DeleteHashEntry(hPtr);
12757        deleted++;
12758      }
12759    }
12760    /* fprintf(stderr, "deleted %d Objects\n", deleted);*/
12761    if (deleted > 0) {
12762      continue;
12763    }
12764
12765    for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
12766      char *key = Tcl_GetHashKey(commandNameTable, hPtr);
12767      cl = XOTclpGetClass(interp, key);
12768      /* fprintf(stderr,"cl key = %s %p\n", key, cl); */
12769      if (cl
12770          && !ObjectHasChildren(interp, (XOTclObject*)cl)
12771          && !ClassHasInstances(cl)
12772          && !ClassHasSubclasses(cl)
12773          && cl != RUNTIME_STATE(interp)->theClass
12774          && cl != RUNTIME_STATE(interp)->theObject
12775          ) {
12776        /* fprintf(stderr,"  ... delete class %s %p\n", key, cl); */
12777        freeUnsetTraceVariable(interp, &cl->object);
12778        Tcl_DeleteCommandFromToken(interp, cl->object.id);
12779        Tcl_DeleteHashEntry(hPtr);
12780        deleted++;
12781      }
12782    }
12783    /* fprintf(stderr, "deleted %d Classes\n", deleted);*/
12784    if (deleted == 0) {
12785      break;
12786    }
12787  }
12788
12789#ifdef DO_FULL_CLEANUP
12790  deleteProcsAndVars(interp);
12791#endif
12792
12793  RUNTIME_STATE(interp)->callDestroy = 0;
12794  RemoveSuper(thecls, theobj);
12795  RemoveInstance((XOTclObject*)thecls, thecls);
12796  RemoveInstance((XOTclObject*)theobj, thecls);
12797
12798  Tcl_DeleteCommandFromToken(interp, theobj->object.id);
12799  RUNTIME_STATE(interp)->theObject = NULL;
12800
12801  Tcl_DeleteCommandFromToken(interp, thecls->object.id);
12802  RUNTIME_STATE(interp)->theClass = NULL;
12803
12804  XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->fakeNS);
12805  XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclClassesNS);
12806  XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclNS);
12807
12808}
12809#endif /* DO_CLEANUP */
12810
12811/*
12812 * ::xotcl::finalize command
12813 */
12814static int
12815XOTclFinalizeObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
12816  XOTclObject *obj;
12817  XOTclClass *cl;
12818  int result;
12819  Tcl_HashSearch hSrch;
12820  Tcl_HashEntry *hPtr;
12821  Tcl_HashTable objTable, *commandNameTable = &objTable;
12822
12823  /* fprintf(stderr,"+++ call EXIT handler\n");  */
12824
12825#if defined(PROFILE)
12826  XOTclProfilePrintData(interp);
12827#endif
12828  /*
12829   * evaluate user-defined exit handler
12830   */
12831  result = callMethod((ClientData)RUNTIME_STATE(interp)->theObject, interp,
12832                      XOTclGlobalObjects[XOTE_EXIT_HANDLER], 2, 0, 0);
12833  if (result != TCL_OK) {
12834    fprintf(stderr,"User defined exit handler contains errors!\n"
12835            "Error in line %d: %s\nExecution interrupted.\n",
12836            Tcl_GetErrorLine(interp), ObjStr(Tcl_GetObjResult(interp)));
12837  }
12838
12839  /* deleting in two rounds:
12840   *  (a) SOFT DESTROY: call all user-defined destroys
12841   *  (b) PHYSICAL DESTROY: delete the commands, user-defined
12842   *      destroys are not executed anymore
12843   *
12844   * this is to prevent user-defined destroys from overriding physical
12845   * destroy during exit handler, but still ensure that all
12846   * user-defined destroys are called.
12847   */
12848
12849  Tcl_InitHashTable(commandNameTable, TCL_STRING_KEYS);
12850  MEM_COUNT_ALLOC("Tcl_InitHashTable", commandNameTable);
12851  getAllInstances(interp, commandNameTable, RUNTIME_STATE(interp)->theObject);
12852  /***** SOFT DESTROY *****/
12853  RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY;
12854
12855  for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
12856    char *key = Tcl_GetHashKey(commandNameTable, hPtr);
12857    obj = XOTclpGetObject(interp, key);
12858    /* fprintf(stderr,"key = %s %p %d\n",
12859       key, obj, obj && !XOTclObjectIsClass(obj)); */
12860    if (obj && !XOTclObjectIsClass(obj)
12861        && !(obj->flags & XOTCL_DESTROY_CALLED)) {
12862      callDestroyMethod((ClientData)obj, interp, obj, 0);
12863    }
12864  }
12865
12866  for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) {
12867    char *key = Tcl_GetHashKey(commandNameTable, hPtr);
12868    cl = XOTclpGetClass(interp, key);
12869    if (cl && !(cl->object.flags & XOTCL_DESTROY_CALLED)) {
12870      callDestroyMethod((ClientData)cl, interp, (XOTclObject *)cl, 0);
12871    }
12872  }
12873
12874#ifdef DO_CLEANUP
12875  freeAllXOTclObjectsAndClasses(interp, commandNameTable);
12876#endif
12877
12878  MEM_COUNT_FREE("Tcl_InitHashTable", commandNameTable);
12879  Tcl_DeleteHashTable(commandNameTable);
12880
12881  return TCL_OK;
12882}
12883
12884
12885/*
12886 *  Exit Handler
12887 */
12888static void
12889ExitHandler(ClientData cd) {
12890  Tcl_Interp *interp = (Tcl_Interp *) cd;
12891  int i, flags;
12892  XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
12893
12894  /*
12895   * Don't use exit handler, if the interpreted is destroyed already
12896   * Call to exit handler comes after freeing namespaces, commands, etc.
12897   * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed
12898   */
12899
12900  /*
12901   * Ahem ...
12902   *
12903   * Since we *must* be sure that our destroy methods will run
12904   * we must *cheat* (I mean CHEAT) here: we flip the interp
12905   * flag, saying, "hey boy, you're not deleted any more".
12906   * After our handlers are done, we restore the old state...
12907   * All this is needed so we can do an eval in the interp which
12908   * is potentially marked for delete when we start working here.
12909   *
12910   * I know, I know, this is not really elegant. But...  I'd need a
12911   * standard way of invoking some code at interpreter delete time
12912   * but JUST BEFORE the actual deletion process starts. Sadly,
12913   * there is no such hook in Tcl as of Tcl8.3.2, that I know of.
12914   *
12915   * So, for the rest of procedure, assume the interp is alive !
12916   */
12917  flags = Tcl_Interp_flags(interp);
12918  Tcl_Interp_flags(interp) &= ~DELETED;
12919
12920  if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) {
12921    XOTclFinalizeObjCmd(NULL, interp, 0, NULL);
12922  }
12923
12924  /*
12925   * Pop any callstack entry that is still alive (e.g.
12926   * if "exit" is called and we were jumping out of the
12927   * callframe
12928   */
12929  while (cs->top > cs->content)
12930    CallStackPop(interp);
12931
12932  while (1) {
12933    Tcl_CallFrame *f = Tcl_Interp_framePtr(interp);
12934    if (!f) break;
12935    if (Tcl_CallFrame_level(f) == 0) break;
12936    Tcl_PopCallFrame(interp);
12937  }
12938
12939   /* must be before freeing of XOTclGlobalObjects */
12940  XOTclShadowTclCommands(interp, SHADOW_UNLOAD);
12941
12942  /* free global objects */
12943  for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) {
12944    DECR_REF_COUNT(XOTclGlobalObjects[i]);
12945  }
12946  XOTclStringIncrFree(&RUNTIME_STATE(interp)->iss);
12947
12948#if defined(TCL_MEM_DEBUG)
12949  TclDumpMemoryInfo (stderr);
12950  Tcl_DumpActiveMemory ("./xotclActiveMem");
12951  /* Tcl_GlobalEval(interp, "puts {checkmem to checkmemFile};
12952     checkmem checkmemFile"); */
12953#endif
12954  MEM_COUNT_DUMP();
12955
12956  FREE(Tcl_Obj**, XOTclGlobalObjects);
12957  FREE(XOTclRuntimeState, RUNTIME_STATE(interp));
12958
12959  Tcl_Interp_flags(interp) = flags;
12960  Tcl_Release((ClientData) interp);
12961}
12962
12963
12964#if defined(TCL_THREADS)
12965void XOTcl_ExitProc(ClientData cd);
12966
12967/*
12968 * Gets activated at thread-exit
12969 */
12970static void
12971XOTcl_ThreadExitProc(ClientData cd) {
12972  /*fprintf(stderr,"+++ XOTcl_ThreadExitProc\n");*/
12973#if !defined(PRE83)
12974  Tcl_DeleteExitHandler(XOTcl_ExitProc, cd);
12975#endif
12976  ExitHandler(cd);
12977}
12978#endif
12979
12980/*
12981 * Gets activated at application-exit
12982 */
12983void
12984XOTcl_ExitProc(ClientData cd) {
12985  /*fprintf(stderr,"+++ XOTcl_ExitProc\n");*/
12986#if !defined(PRE83) && defined(TCL_THREADS)
12987  Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, cd);
12988#endif
12989  ExitHandler(cd);
12990}
12991
12992
12993/*
12994 * Registers thread/appl exit handlers.
12995 */
12996static void
12997RegisterExitHandlers(ClientData cd) {
12998  Tcl_Preserve(cd);
12999#if !defined(PRE83) && defined(TCL_THREADS)
13000  Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, cd);
13001#endif
13002  Tcl_CreateExitHandler(XOTcl_ExitProc, cd);
13003}
13004
13005
13006
13007/*
13008 * Tcl extension initialization routine
13009 */
13010
13011extern int
13012Xotcl_Init(Tcl_Interp *interp) {
13013  XOTclClass *theobj = NULL;
13014  XOTclClass *thecls = NULL;
13015  XOTclClass *paramCl = NULL;
13016  XOTclClass *nonposArgsCl = NULL;
13017  ClientData runtimeState;
13018  int result, i;
13019#ifdef XOTCL_BYTECODE
13020  XOTclCompEnv *instructions = XOTclGetCompEnv();
13021#endif
13022
13023#ifndef PRE81
13024# ifdef USE_TCL_STUBS
13025  if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
13026    return TCL_ERROR;
13027  }
13028# endif
13029#endif
13030
13031#if defined(TCL_MEM_DEBUG)
13032  TclDumpMemoryInfo(stderr);
13033#endif
13034
13035  MEM_COUNT_INIT();
13036
13037  /*
13038    fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n", sizeof(XOTclObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(XOTclClass), sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable));
13039  */
13040
13041#if FORWARD_COMPATIBLE
13042  {
13043    int major, minor, patchlvl, type;
13044    Tcl_GetVersion(&major, &minor, &patchlvl, &type);
13045
13046    if ((major == 8) && (minor < 5)) {
13047      /*
13048       * loading a version of xotcl compiled for 8.4 version
13049       * into a 8.4 Tcl
13050       */
13051      /*
13052        fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.4 Tcl\n");
13053      */
13054      forwardCompatibleMode = 0;
13055      lookupVarFromTable  = LookupVarFromTable84;
13056      tclVarHashCreateVar = VarHashCreateVar84;
13057      tclInitVarHashTable = InitVarHashTable84;
13058      tclCleanupVar       = TclCleanupVar84;
13059      varRefCountOffset   = TclOffset(Var, refCount);
13060      varHashTableSize    = sizeof(Tcl_HashTable);
13061    } else {
13062      /*
13063       * loading a version of xotcl compiled for 8.4 version
13064       * into a 8.5 Tcl
13065       */
13066      /*
13067        fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.5 Tcl\n");
13068      */
13069      forwardCompatibleMode = 1;
13070      lookupVarFromTable  = LookupVarFromTable85;
13071      tclVarHashCreateVar = VarHashCreateVar85;
13072      tclInitVarHashTable = (Tcl_InitVarHashTableFunction*)*((&tclIntStubsPtr->reserved0)+235);
13073      tclCleanupVar       = (Tcl_CleanupVarFunction*)*((&tclIntStubsPtr->reserved0)+176);
13074      varRefCountOffset   = TclOffset(VarInHash, refCount);
13075      varHashTableSize    = sizeof(TclVarHashTable85);
13076    }
13077
13078  }
13079#endif
13080
13081  /*
13082   * Runtime State stored in the client data of the Interp's global
13083   * Namespace in order to avoid global state information
13084   */
13085  runtimeState = (ClientData) NEW(XOTclRuntimeState);
13086#if USE_ASSOC_DATA
13087  Tcl_SetAssocData(interp, "XOTclRuntimeState", NULL, runtimeState);
13088#else
13089  Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState;
13090#endif
13091
13092  /* CallStack initialization */
13093  memset(RUNTIME_STATE(interp), 0, sizeof(XOTclRuntimeState));
13094  memset(RUNTIME_STATE(interp)->cs.content, 0, sizeof(XOTclCallStackContent));
13095
13096  RUNTIME_STATE(interp)->cs.top = RUNTIME_STATE(interp)->cs.content;
13097  RUNTIME_STATE(interp)->doFilters = 1;
13098  RUNTIME_STATE(interp)->callDestroy = 1;
13099
13100  /* create xotcl namespace */
13101  RUNTIME_STATE(interp)->XOTclNS =
13102    Tcl_CreateNamespace(interp, "::xotcl", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL);
13103
13104  MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclNS);
13105
13106  /*
13107   * init an empty, faked proc structure in the RUNTIME state
13108   */
13109  RUNTIME_STATE(interp)->fakeProc.iPtr = (Interp *)interp;
13110  RUNTIME_STATE(interp)->fakeProc.refCount = 1;
13111  RUNTIME_STATE(interp)->fakeProc.cmdPtr = NULL;
13112  RUNTIME_STATE(interp)->fakeProc.bodyPtr = NULL;
13113  RUNTIME_STATE(interp)->fakeProc.numArgs  = 0;
13114  RUNTIME_STATE(interp)->fakeProc.numCompiledLocals = 0;
13115  RUNTIME_STATE(interp)->fakeProc.firstLocalPtr = NULL;
13116  RUNTIME_STATE(interp)->fakeProc.lastLocalPtr = NULL;
13117  RUNTIME_STATE(interp)->fakeNS =
13118    Tcl_CreateNamespace(interp, "::xotcl::fakeNS", (ClientData)NULL,
13119                        (Tcl_NamespaceDeleteProc*)NULL);
13120  MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->fakeNS);
13121
13122  /* XOTclClasses in separate Namespace / Objects */
13123  RUNTIME_STATE(interp)->XOTclClassesNS =
13124    Tcl_CreateNamespace(interp, "::xotcl::classes",	(ClientData)NULL,
13125                        (Tcl_NamespaceDeleteProc*)NULL);
13126  MEM_COUNT_ALLOC("TclNamespace", RUNTIME_STATE(interp)->XOTclClassesNS);
13127
13128
13129  /* cache interpreters proc interpretation functions */
13130  RUNTIME_STATE(interp)->objInterpProc = TclGetObjInterpProc();
13131#if USE_INTERP_PROC
13132  RUNTIME_STATE(interp)->interpProc = TclGetInterpProc();
13133#endif
13134  RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF;
13135
13136  RegisterObjTypes();
13137  RegisterExitHandlers((ClientData)interp);
13138
13139  XOTclStringIncrInit(&RUNTIME_STATE(interp)->iss);
13140
13141  /* initialize global Tcl_Obj*/
13142  XOTclGlobalObjects = NEW_ARRAY(Tcl_Obj*, nr_elements(XOTclGlobalStrings));
13143
13144  for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) {
13145    XOTclGlobalObjects[i] = Tcl_NewStringObj(XOTclGlobalStrings[i],-1);
13146    INCR_REF_COUNT(XOTclGlobalObjects[i]);
13147  }
13148
13149  /* create Object and Class, and store them in the RUNTIME STATE */
13150  theobj = PrimitiveCCreate(interp, "::xotcl::Object", 0);
13151  RUNTIME_STATE(interp)->theObject = theobj;
13152  if (!theobj) Tcl_Panic("Cannot create ::xotcl::Object", NULL);
13153
13154  thecls = PrimitiveCCreate(interp, "::xotcl::Class", 0);
13155  RUNTIME_STATE(interp)->theClass = thecls;
13156  if (!thecls) Tcl_Panic("Cannot create ::xotcl::Class", NULL);
13157
13158  Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "Object", 0);
13159  Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "Class", 0);
13160  /*Tcl_AddInterpResolvers(interp, "XOTcl", XOTclResolveCmd, 0, 0);*/
13161
13162#if defined(PROFILE)
13163  XOTclProfileInit(interp);
13164#endif
13165
13166  /* test Object and Class creation */
13167  if (!theobj || !thecls) {
13168    RUNTIME_STATE(interp)->callDestroy = 0;
13169
13170    if (thecls) PrimitiveCDestroy((ClientData) thecls);
13171    if (theobj) PrimitiveCDestroy((ClientData) theobj);
13172
13173    for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) {
13174      DECR_REF_COUNT(XOTclGlobalObjects[i]);
13175    }
13176    FREE(Tcl_Obj**, XOTclGlobalObjects);
13177    FREE(XOTclRuntimeState, RUNTIME_STATE(interp));
13178
13179    return XOTclErrMsg(interp, "Object/Class failed", TCL_STATIC);
13180  }
13181
13182  AddInstance((XOTclObject*)theobj, thecls);
13183  AddInstance((XOTclObject*)thecls, thecls);
13184  AddSuper(thecls, theobj);
13185  {
13186    typedef struct methodDefinition {
13187      char *methodName;
13188      Tcl_ObjCmdProc *proc;
13189    } methodDefinition;
13190    methodDefinition objInstcmds[] = {
13191      {"autoname",         XOTclOAutonameMethod},
13192      {"check",            XOTclOCheckMethod},
13193      {"cleanup",          XOTclOCleanupMethod},
13194      {"configure",        XOTclOConfigureMethod},
13195      {"destroy",          XOTclODestroyMethod},
13196      {"exists",           XOTclOExistsMethod},
13197      {"filterguard",      XOTclOFilterGuardMethod},
13198      {"filtersearch",     XOTclOFilterSearchMethod},
13199      {"info",             XOTclOInfoMethod},
13200      {"instvar",          XOTclOInstVarMethod},
13201      {"invar",            XOTclOInvariantsMethod},
13202      {"isclass",          XOTclOIsClassMethod},
13203      {"ismetaclass",      XOTclOIsMetaClassMethod},
13204      {"isobject",         XOTclOIsObjectMethod},
13205      {"istype",           XOTclOIsTypeMethod},
13206      {"ismixin",          XOTclOIsMixinMethod},
13207#ifdef XOTCL_METADATA
13208      {"metadata",         XOTclOMetaDataMethod},
13209#endif
13210      {"mixinguard",       XOTclOMixinGuardMethod},
13211      {"__next",           XOTclONextMethod},
13212      /*    {"next",         XOTclONextMethod2},*/
13213      {"noinit",           XOTclONoinitMethod},
13214      {"parametercmd",     XOTclCParameterCmdMethod},
13215      { "proc",            XOTclOProcMethod},
13216      {"procsearch",       XOTclOProcSearchMethod},
13217      {"requireNamespace", XOTclORequireNamespaceMethod},
13218      {"set",              XOTclOSetMethod}, /***??**/
13219      {"forward",          XOTclOForwardMethod},
13220      {"uplevel",          XOTclOUplevelMethod},
13221      {"upvar",            XOTclOUpvarMethod},
13222      {"volatile",         XOTclOVolatileMethod},
13223      {"vwait",            XOTclOVwaitMethod}
13224    };
13225    methodDefinition classInstcmds[] = {
13226      {"autoname",         XOTclOAutonameMethod},
13227      {"alloc",            XOTclCAllocMethod},
13228      {"create",           XOTclCCreateMethod},
13229      {"new",              XOTclCNewMethod},
13230      {"info",             XOTclCInfoMethod},
13231      {"instdestroy",      XOTclCInstDestroyMethod},
13232      {"instfilterguard",  XOTclCInstFilterGuardMethod},
13233      {"instinvar",        XOTclCInvariantsMethod},
13234      {"instmixinguard",   XOTclCInstMixinGuardMethod},
13235      {"instparametercmd", XOTclCInstParameterCmdMethod},
13236      {"instproc",         XOTclCInstProcMethod},
13237      {"instforward",      XOTclCInstForwardMethod},
13238      {"parameter",        XOTclCParameterMethod},
13239      {"parameterclass",   XOTclCParameterClassMethod},
13240      {"recreate",         XOTclCRecreateMethod},
13241      {"unknown",          XOTclCUnknownMethod}
13242    };
13243
13244    int namespacelength;
13245    Tcl_DString ds, *dsPtr = &ds;
13246
13247    DSTRING_INIT(dsPtr);
13248    Tcl_DStringAppend(dsPtr,"::xotcl::Object::instcmd", -1);
13249    Tcl_CreateNamespace(interp, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL);
13250    Tcl_DStringAppend(dsPtr,"::", 2);
13251    namespacelength = Tcl_DStringLength(dsPtr);
13252
13253    for (i = 0; i < nr_elements(objInstcmds); i++) {
13254      Tcl_DStringAppend(dsPtr, objInstcmds[i].methodName, -1);
13255      Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), objInstcmds[i].proc, 0, 0);
13256      Tcl_DStringSetLength(dsPtr, namespacelength);
13257    }
13258    Tcl_DStringSetLength(dsPtr, 0);
13259    Tcl_DStringAppend(dsPtr,"::xotcl::Class::instcmd", -1);
13260    Tcl_CreateNamespace(interp, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL);
13261    Tcl_DStringAppend(dsPtr,"::", 2);
13262    namespacelength = Tcl_DStringLength(dsPtr);
13263
13264    for (i = 0; i < nr_elements(classInstcmds); i++) {
13265      Tcl_DStringAppend(dsPtr, classInstcmds[i].methodName, -1);
13266      Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), classInstcmds[i].proc, 0, 0);
13267      Tcl_DStringSetLength(dsPtr, namespacelength);
13268    }
13269
13270    DSTRING_FREE(dsPtr);
13271  }
13272
13273  /*
13274   * overwritten tcl objs
13275   */
13276  result = XOTclShadowTclCommands(interp, SHADOW_LOAD);
13277  if (result != TCL_OK)
13278    return result;
13279
13280  /*
13281   * new tcl cmds
13282   */
13283#ifdef XOTCL_BYTECODE
13284  instructions[INST_SELF_DISPATCH].cmdPtr = (Command *)
13285#endif
13286    Tcl_CreateObjCommand(interp, "::xotcl::my", XOTclSelfDispatchCmd, 0, 0);
13287#ifdef XOTCL_BYTECODE
13288  instructions[INST_NEXT].cmdPtr = (Command *)
13289#endif
13290    Tcl_CreateObjCommand(interp, "::xotcl::next", XOTclNextObjCmd, 0, 0);
13291#ifdef XOTCL_BYTECODE
13292  instructions[INST_SELF].cmdPtr = (Command *)
13293#endif
13294    Tcl_CreateObjCommand(interp, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0);
13295  /*Tcl_CreateObjCommand(interp, "::xotcl::K", XOTclKObjCmd, 0, 0);*/
13296
13297  Tcl_CreateObjCommand(interp, "::xotcl::alias", XOTclAliasCommand, 0, 0);
13298  Tcl_CreateObjCommand(interp, "::xotcl::configure", XOTclConfigureCommand, 0, 0);
13299  Tcl_CreateObjCommand(interp, "::xotcl::deprecated", XOTcl_DeprecatedCmd, 0, 0);
13300  Tcl_CreateObjCommand(interp, "::xotcl::finalize", XOTclFinalizeObjCmd, 0, 0);
13301#if defined(PRE85) || defined(NRE)
13302#ifdef XOTCL_BYTECODE
13303  instructions[INST_INITPROC].cmdPtr = (Command *)
13304#endif
13305    Tcl_CreateObjCommand(interp, "::xotcl::initProcNS", XOTclInitProcNSCmd, 0, 0);
13306#endif
13307  Tcl_CreateObjCommand(interp, "::xotcl::interpretNonpositionalArgs",
13308                       XOTclInterpretNonpositionalArgsCmd, 0, 0);
13309  Tcl_CreateObjCommand(interp, "::xotcl::interp", XOTcl_InterpObjCmd, 0, 0);
13310  Tcl_CreateObjCommand(interp, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0);
13311  Tcl_CreateObjCommand(interp, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0);
13312  Tcl_CreateObjCommand(interp, "::xotcl::__qualify", XOTclQualifyObjCmd, 0, 0);
13313  Tcl_CreateObjCommand(interp, "::xotcl::setinstvar", XOTclSetInstvarCommand, 0, 0);
13314  Tcl_CreateObjCommand(interp, "::xotcl::setrelation", XOTclSetRelationCommand, 0, 0);
13315  Tcl_CreateObjCommand(interp, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0);
13316
13317  Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "self", 0);
13318  Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "next", 0);
13319  Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "my", 0);
13320
13321#ifdef XOTCL_BYTECODE
13322  XOTclBytecodeInit();
13323#endif
13324
13325  /*
13326   * Non-Positional Args Object
13327   */
13328
13329  nonposArgsCl = PrimitiveCCreate(interp,
13330                                  XOTclGlobalStrings[XOTE_NON_POS_ARGS_CL],
13331                                  thecls);
13332  XOTclAddIMethod(interp, (XOTcl_Class*) nonposArgsCl,
13333                  "required",
13334                  (Tcl_ObjCmdProc*) XOTclCheckRequiredArgs, 0, 0);
13335  XOTclAddIMethod(interp, (XOTcl_Class*) nonposArgsCl,
13336                  "switch",
13337                  (Tcl_ObjCmdProc*) XOTclCheckBooleanArgs, 0, 0);
13338  XOTclAddIMethod(interp, (XOTcl_Class*) nonposArgsCl,
13339                  "boolean",
13340                  (Tcl_ObjCmdProc*) XOTclCheckBooleanArgs, 0, 0);
13341  PrimitiveOCreate(interp, XOTclGlobalStrings[XOTE_NON_POS_ARGS_OBJ],
13342                   nonposArgsCl);
13343
13344  /*
13345   *  Parameter Class
13346   */
13347  {
13348    XOTclObject *paramObject;
13349    paramCl = PrimitiveCCreate(interp, XOTclGlobalStrings[XOTE_PARAM_CL], thecls);
13350    paramObject =  &paramCl->object;
13351    XOTclAddPMethod(interp, (XOTcl_Object*) paramObject,
13352                    XOTclGlobalStrings[XOTE_SEARCH_DEFAULTS],
13353                    (Tcl_ObjCmdProc*) ParameterSearchDefaultsMethod, 0, 0);
13354  }
13355
13356  /*
13357   * set runtime version information in Tcl variable
13358   */
13359  Tcl_SetVar(interp, "::xotcl::version", XOTCLVERSION, TCL_GLOBAL_ONLY);
13360  Tcl_SetVar(interp, "::xotcl::patchlevel", XOTCLPATCHLEVEL, TCL_GLOBAL_ONLY);
13361
13362  /*
13363   * with some methods and library procs in tcl - they could go in a
13364   * xotcl.tcl file, but they're embedded here with Tcl_GlobalEval
13365   * to avoid the need to carry around a separate file at runtime.
13366   */
13367  {
13368
13369#include "predefined.h"
13370
13371    /* fprintf(stderr, "predefined=<<%s>>\n", cmd);*/
13372    if (Tcl_GlobalEval(interp, cmd) != TCL_OK) {
13373      static char cmd[] =
13374        "puts stderr \"Error in predefined code\n\
13375	 $::errorInfo\"";
13376      Tcl_EvalEx(interp, cmd, -1, 0);
13377      return TCL_ERROR;
13378    }
13379  }
13380
13381#ifndef AOL_SERVER
13382  /* the AOL server uses a different package loading mechanism */
13383# ifdef COMPILE_XOTCL_STUBS
13384  Tcl_PkgProvideEx(interp, "XOTcl", PACKAGE_VERSION, (ClientData)&xotclStubs);
13385# else
13386  Tcl_PkgProvide(interp, "XOTcl", PACKAGE_VERSION);
13387# endif
13388#endif
13389
13390#if !defined(TCL_THREADS) && !defined(PRE81)
13391  if ((Tcl_GetVar2(interp, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) {
13392    /* a non threaded XOTcl version is loaded into a threaded environment */
13393    fprintf(stderr, "\n A non threaded XOTCL version is loaded into threaded environment\n Please reconfigure XOTcl with --enable-threads!\n\n\n");
13394  }
13395#endif
13396
13397  Tcl_ResetResult(interp);
13398  Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
13399
13400  return TCL_OK;
13401}
13402
13403
13404extern int
13405Xotcl_SafeInit(Tcl_Interp *interp) {
13406  /*** dummy for now **/
13407  return Xotcl_Init(interp);
13408}
13409
13410