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,¶mCl, 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, ¤tCmd); 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, ¤tCmd); 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 = ¶mCl->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