itcl/itcl/generic/itcl_util.c

   1 /*
   2  * ------------------------------------------------------------------------
   3  *      PACKAGE:  [incr Tcl]
   4  *  DESCRIPTION:  Object-Oriented Extensions to Tcl
   5  *
   6  *  [incr Tcl] provides object-oriented extensions to Tcl, much as
   7  *  C++ provides object-oriented extensions to C.  It provides a means
   8  *  of encapsulating related procedures together with their shared data
   9  *  in a local namespace that is hidden from the outside world.  It
  10  *  promotes code re-use through inheritance.  More than anything else,
  11  *  it encourages better organization of Tcl applications through the
  12  *  object-oriented paradigm, leading to code that is easier to
  13  *  understand and maintain.
  14  *
  15  *  This segment provides common utility functions used throughout
  16  *  the other [incr Tcl] source files.
  17  *
  18  * ========================================================================
  19  *  AUTHOR:  Michael J. McLennan
  20  *           Bell Labs Innovations for Lucent Technologies
  21  *           mmclennan@lucent.com
  22  *           http://www.tcltk.com/itcl
  23  *
  24  *     RCS:  $Id$
  25  * ========================================================================
  26  *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
  27  * ------------------------------------------------------------------------
  28  * See the file "license.terms" for information on usage and redistribution
  29  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  30  */
  31 #include "itclInt.h"
  32 #include "tclCompile.h"
  33
  34 /*
  35  *  POOL OF LIST ELEMENTS FOR LINKED LIST
  36  */
  37 static Itcl_ListElem *listPool = NULL;
  38 static int listPoolLen = 0;
  39
  40 #define ITCL_VALID_LIST 0x01face10  /* magic bit pattern for validation */
  41 #define ITCL_LIST_POOL_SIZE 200     /* max number of elements in listPool */
  42
  43
  44 /*
  45  *  These records are used to keep track of reference-counted data
  46  *  for Itcl_PreserveData and Itcl_ReleaseData.
  47  */
  48 typedef struct ItclPreservedData {
  49     ClientData data;                /* reference to data */
  50     int usage;                      /* number of active uses */
  51     Tcl_FreeProc *fproc;            /* procedure used to free data */
  52 } ItclPreservedData;
  53
  54 static Tcl_HashTable *ItclPreservedList = NULL;
  55
  56
  57 /*
  58  *  This structure is used to take a snapshot of the interpreter
  59  *  state in Itcl_SaveInterpState.  You can snapshot the state,
  60  *  execute a command, and then back up to the result or the
  61  *  error that was previously in progress.
  62  */
  63 typedef struct InterpState {
  64     int validate;                   /* validation stamp */
  65     int status;                     /* return code status */
  66     Tcl_Obj *objResult;             /* result object */
  67     char *errorInfo;                /* contents of errorInfo variable */
  68     char *errorCode;                /* contents of errorCode variable */
  69 } InterpState;
  70
  71 #define TCL_STATE_VALID 0x01233210  /* magic bit pattern for validation */
  72
  73
  74 \f
  75 /*
  76  * ------------------------------------------------------------------------
  77  *  Itcl_Assert()
  78  *
  79  *  Called whenever an assert() test fails.  Prints a diagnostic
  80  *  message and abruptly exits.
  81  * ------------------------------------------------------------------------
  82  */
  83 #ifndef NDEBUG
  84
  85 void
  86 Itcl_Assert(testExpr, fileName, lineNumber)
  87     char *testExpr;   /* string representing test expression */
  88     char *fileName;   /* file name containing this call */
  89     int lineNumber;   /* line number containing this call */
  90 {
  91     fprintf(stderr, "Assertion failed: \"%s\" (line %d of %s)",
  92         testExpr, lineNumber, fileName);
  93     abort();
  94 }
  95
  96 #endif
  97
  98 \f
  99 /*
 100  * ------------------------------------------------------------------------
 101  *  Itcl_InitStack()
 102  *
 103  *  Initializes a stack structure, allocating a certain amount of memory
 104  *  for the stack and setting the stack length to zero.
 105  * ------------------------------------------------------------------------
 106  */
 107 void
 108 Itcl_InitStack(stack)
 109     Itcl_Stack *stack;     /* stack to be initialized */
 110 {
 111     stack->values = stack->space;
 112     stack->max = sizeof(stack->space)/sizeof(ClientData);
 113     stack->len = 0;
 114 }
 115 \f
 116 /*
 117  * ------------------------------------------------------------------------
 118  *  Itcl_DeleteStack()
 119  *
 120  *  Destroys a stack structure, freeing any memory that may have been
 121  *  allocated to represent it.
 122  * ------------------------------------------------------------------------
 123  */
 124 void
 125 Itcl_DeleteStack(stack)
 126     Itcl_Stack *stack;     /* stack to be deleted */
 127 {
 128     /*
 129      *  If memory was explicitly allocated (instead of using the
 130      *  built-in buffer) then free it.
 131      */
 132     if (stack->values != stack->space) {
 133         ckfree((char*)stack->values);
 134     }
 135     stack->values = NULL;
 136     stack->len = stack->max = 0;
 137 }
 138 \f
 139 /*
 140  * ------------------------------------------------------------------------
 141  *  Itcl_PushStack()
 142  *
 143  *  Pushes a piece of client data onto the top of the given stack.
 144  *  If the stack is not large enough, it is automatically resized.
 145  * ------------------------------------------------------------------------
 146  */
 147 void
 148 Itcl_PushStack(cdata,stack)
 149     ClientData cdata;      /* data to be pushed onto stack */
 150     Itcl_Stack *stack;     /* stack */
 151 {
 152     ClientData *newStack;
 153
 154     if (stack->len+1 >= stack->max) {
 155         stack->max = 2*stack->max;
 156         newStack = (ClientData*)
 157             ckalloc((unsigned)(stack->max*sizeof(ClientData)));
 158
 159         if (stack->values) {
 160             memcpy((char*)newStack, (char*)stack->values,
 161                 (size_t)(stack->len*sizeof(ClientData)));
 162
 163             if (stack->values != stack->space)
 164                 ckfree((char*)stack->values);
 165         }
 166         stack->values = newStack;
 167     }
 168     stack->values[stack->len++] = cdata;
 169 }
 170 \f
 171 /*
 172  * ------------------------------------------------------------------------
 173  *  Itcl_PopStack()
 174  *
 175  *  Pops a bit of client data from the top of the given stack.
 176  * ------------------------------------------------------------------------
 177  */
 178 ClientData
 179 Itcl_PopStack(stack)
 180     Itcl_Stack *stack;  /* stack to be manipulated */
 181 {
 182     if (stack->values && (stack->len > 0)) {
 183         stack->len--;
 184         return stack->values[stack->len];
 185     }
 186     return (ClientData)NULL;
 187 }
 188 \f
 189 /*
 190  * ------------------------------------------------------------------------
 191  *  Itcl_PeekStack()
 192  *
 193  *  Gets the current value from the top of the given stack.
 194  * ------------------------------------------------------------------------
 195  */
 196 ClientData
 197 Itcl_PeekStack(stack)
 198     Itcl_Stack *stack;  /* stack to be examined */
 199 {
 200     if (stack->values && (stack->len > 0)) {
 201         return stack->values[stack->len-1];
 202     }
 203     return (ClientData)NULL;
 204 }
 205 \f
 206 /*
 207  * ------------------------------------------------------------------------
 208  *  Itcl_GetStackValue()
 209  *
 210  *  Gets a value at some index within the stack.  Index "0" is the
 211  *  first value pushed onto the stack.
 212  * ------------------------------------------------------------------------
 213  */
 214 ClientData
 215 Itcl_GetStackValue(stack,pos)
 216     Itcl_Stack *stack;  /* stack to be examined */
 217     int pos;            /* get value at this index */
 218 {
 219     if (stack->values && (stack->len > 0)) {
 220         assert(pos < stack->len);
 221         return stack->values[pos];
 222     }
 223     return (ClientData)NULL;
 224 }
 225
 226 \f
 227 /*
 228  * ------------------------------------------------------------------------
 229  *  Itcl_InitList()
 230  *
 231  *  Initializes a linked list structure, setting the list to the empty
 232  *  state.
 233  * ------------------------------------------------------------------------
 234  */
 235 void
 236 Itcl_InitList(listPtr)
 237     Itcl_List *listPtr;     /* list to be initialized */
 238 {
 239     listPtr->validate = ITCL_VALID_LIST;
 240     listPtr->num      = 0;
 241     listPtr->head     = NULL;
 242     listPtr->tail     = NULL;
 243 }
 244 \f
 245 /*
 246  * ------------------------------------------------------------------------
 247  *  Itcl_DeleteList()
 248  *
 249  *  Destroys a linked list structure, deleting all of its elements and
 250  *  setting it to an empty state.  If the elements have memory associated
 251  *  with them, this memory must be freed before deleting the list or it
 252  *  will be lost.
 253  * ------------------------------------------------------------------------
 254  */
 255 void
 256 Itcl_DeleteList(listPtr)
 257     Itcl_List *listPtr;     /* list to be deleted */
 258 {
 259     Itcl_ListElem *elemPtr;
 260
 261     assert(listPtr->validate == ITCL_VALID_LIST);
 262
 263     elemPtr = listPtr->head;
 264     while (elemPtr) {
 265         elemPtr = Itcl_DeleteListElem(elemPtr);
 266     }
 267     listPtr->validate = 0;
 268 }
 269 \f
 270 /*
 271  * ------------------------------------------------------------------------
 272  *  Itcl_CreateListElem()
 273  *
 274  *  Low-level routined used by procedures like Itcl_InsertList() and
 275  *  Itcl_AppendList() to create new list elements.  If elements are
 276  *  available, one is taken from the list element pool.  Otherwise,
 277  *  a new one is allocated.
 278  * ------------------------------------------------------------------------
 279  */
 280 Itcl_ListElem*
 281 Itcl_CreateListElem(listPtr)
 282     Itcl_List *listPtr;     /* list that will contain this new element */
 283 {
 284     Itcl_ListElem *elemPtr;
 285
 286     if (listPoolLen > 0) {
 287         elemPtr = listPool;
 288         listPool = elemPtr->next;
 289         --listPoolLen;
 290     }
 291     else {
 292         elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem));
 293     }
 294     elemPtr->owner = listPtr;
 295     elemPtr->value = NULL;
 296     elemPtr->next  = NULL;
 297     elemPtr->prev  = NULL;
 298
 299     return elemPtr;
 300 }
 301 \f
 302 /*
 303  * ------------------------------------------------------------------------
 304  *  Itcl_DeleteListElem()
 305  *
 306  *  Destroys a single element in a linked list, returning it to a pool of
 307  *  elements that can be later reused.  Returns a pointer to the next
 308  *  element in the list.
 309  * ------------------------------------------------------------------------
 310  */
 311 Itcl_ListElem*
 312 Itcl_DeleteListElem(elemPtr)
 313     Itcl_ListElem *elemPtr;     /* list element to be deleted */
 314 {
 315     Itcl_List *listPtr;
 316     Itcl_ListElem *nextPtr;
 317
 318     nextPtr = elemPtr->next;
 319
 320     if (elemPtr->prev) {
 321         elemPtr->prev->next = elemPtr->next;
 322     }
 323     if (elemPtr->next) {
 324         elemPtr->next->prev = elemPtr->prev;
 325     }
 326
 327     listPtr = elemPtr->owner;
 328     if (elemPtr == listPtr->head)
 329         listPtr->head = elemPtr->next;
 330     if (elemPtr == listPtr->tail)
 331         listPtr->tail = elemPtr->prev;
 332     --listPtr->num;
 333
 334     if (listPoolLen < ITCL_LIST_POOL_SIZE) {
 335         elemPtr->next = listPool;
 336         listPool = elemPtr;
 337         ++listPoolLen;
 338     }
 339     else {
 340         ckfree((char*)elemPtr);
 341     }
 342     return nextPtr;
 343 }
 344 \f
 345 /*
 346  * ------------------------------------------------------------------------
 347  *  Itcl_InsertList()
 348  *
 349  *  Creates a new list element containing the given value and returns
 350  *  a pointer to it.  The element is inserted at the beginning of the
 351  *  specified list.
 352  * ------------------------------------------------------------------------
 353  */
 354 Itcl_ListElem*
 355 Itcl_InsertList(listPtr,val)
 356     Itcl_List *listPtr;     /* list being modified */
 357     ClientData val;         /* value associated with new element */
 358 {
 359     Itcl_ListElem *elemPtr;
 360     assert(listPtr->validate == ITCL_VALID_LIST);
 361
 362     elemPtr = Itcl_CreateListElem(listPtr);
 363
 364     elemPtr->value = val;
 365     elemPtr->next  = listPtr->head;
 366     elemPtr->prev  = NULL;
 367     if (listPtr->head) {
 368         listPtr->head->prev = elemPtr;
 369     }
 370     listPtr->head  = elemPtr;
 371     if (listPtr->tail == NULL) {
 372         listPtr->tail = elemPtr;
 373     }
 374     ++listPtr->num;
 375
 376     return elemPtr;
 377 }
 378 \f
 379 /*
 380  * ------------------------------------------------------------------------
 381  *  Itcl_InsertListElem()
 382  *
 383  *  Creates a new list element containing the given value and returns
 384  *  a pointer to it.  The element is inserted in the list just before
 385  *  the specified element.
 386  * ------------------------------------------------------------------------
 387  */
 388 Itcl_ListElem*
 389 Itcl_InsertListElem(pos,val)
 390     Itcl_ListElem *pos;     /* insert just before this element */
 391     ClientData val;         /* value associated with new element */
 392 {
 393     Itcl_List *listPtr;
 394     Itcl_ListElem *elemPtr;
 395
 396     listPtr = pos->owner;
 397     assert(listPtr->validate == ITCL_VALID_LIST);
 398     assert(pos != NULL);
 399
 400     elemPtr = Itcl_CreateListElem(listPtr);
 401     elemPtr->value = val;
 402
 403     elemPtr->prev = pos->prev;
 404     if (elemPtr->prev) {
 405         elemPtr->prev->next = elemPtr;
 406     }
 407     elemPtr->next = pos;
 408     pos->prev     = elemPtr;
 409
 410     if (listPtr->head == pos) {
 411         listPtr->head = elemPtr;
 412     }
 413     if (listPtr->tail == NULL) {
 414         listPtr->tail = elemPtr;
 415     }
 416     ++listPtr->num;
 417
 418     return elemPtr;
 419 }
 420 \f
 421 /*
 422  * ------------------------------------------------------------------------
 423  *  Itcl_AppendList()
 424  *
 425  *  Creates a new list element containing the given value and returns
 426  *  a pointer to it.  The element is appended at the end of the
 427  *  specified list.
 428  * ------------------------------------------------------------------------
 429  */
 430 Itcl_ListElem*
 431 Itcl_AppendList(listPtr,val)
 432     Itcl_List *listPtr;     /* list being modified */
 433     ClientData val;         /* value associated with new element */
 434 {
 435     Itcl_ListElem *elemPtr;
 436     assert(listPtr->validate == ITCL_VALID_LIST);
 437
 438     elemPtr = Itcl_CreateListElem(listPtr);
 439
 440     elemPtr->value = val;
 441     elemPtr->prev  = listPtr->tail;
 442     elemPtr->next  = NULL;
 443     if (listPtr->tail) {
 444         listPtr->tail->next = elemPtr;
 445     }
 446     listPtr->tail  = elemPtr;
 447     if (listPtr->head == NULL) {
 448         listPtr->head = elemPtr;
 449     }
 450     ++listPtr->num;
 451
 452     return elemPtr;
 453 }
 454 \f
 455 /*
 456  * ------------------------------------------------------------------------
 457  *  Itcl_AppendListElem()
 458  *
 459  *  Creates a new list element containing the given value and returns
 460  *  a pointer to it.  The element is inserted in the list just after
 461  *  the specified element.
 462  * ------------------------------------------------------------------------
 463  */
 464 Itcl_ListElem*
 465 Itcl_AppendListElem(pos,val)
 466     Itcl_ListElem *pos;     /* insert just after this element */
 467     ClientData val;         /* value associated with new element */
 468 {
 469     Itcl_List *listPtr;
 470     Itcl_ListElem *elemPtr;
 471
 472     listPtr = pos->owner;
 473     assert(listPtr->validate == ITCL_VALID_LIST);
 474     assert(pos != NULL);
 475
 476     elemPtr = Itcl_CreateListElem(listPtr);
 477     elemPtr->value = val;
 478
 479     elemPtr->next = pos->next;
 480     if (elemPtr->next) {
 481         elemPtr->next->prev = elemPtr;
 482     }
 483     elemPtr->prev = pos;
 484     pos->next     = elemPtr;
 485
 486     if (listPtr->tail == pos) {
 487         listPtr->tail = elemPtr;
 488     }
 489     if (listPtr->head == NULL) {
 490         listPtr->head = elemPtr;
 491     }
 492     ++listPtr->num;
 493
 494     return elemPtr;
 495 }
 496 \f
 497 /*
 498  * ------------------------------------------------------------------------
 499  *  Itcl_SetListValue()
 500  *
 501  *  Modifies the value associated with a list element.
 502  * ------------------------------------------------------------------------
 503  */
 504 void
 505 Itcl_SetListValue(elemPtr,val)
 506     Itcl_ListElem *elemPtr; /* list element being modified */
 507     ClientData val;         /* new value associated with element */
 508 {
 509     Itcl_List *listPtr = elemPtr->owner;
 510     assert(listPtr->validate == ITCL_VALID_LIST);
 511     assert(elemPtr != NULL);
 512
 513     elemPtr->value = val;
 514 }
 515
 516 \f
 517 /*
 518  * ========================================================================
 519  *  REFERENCE-COUNTED DATA
 520  *
 521  *  The following procedures manage generic reference-counted data.
 522  *  They are similar in spirit to the Tcl_Preserve/Tcl_Release
 523  *  procedures defined in the Tcl/Tk core.  But these procedures use
 524  *  a hash table instead of a linked list to maintain the references,
 525  *  so they scale better.  Also, the Tcl procedures have a bad behavior
 526  *  during the "exit" command.  Their exit handler shuts them down
 527  *  when other data is still being reference-counted and cleaned up.
 528  *
 529  * ------------------------------------------------------------------------
 530  *  Itcl_EventuallyFree()
 531  *
 532  *  Registers a piece of data so that it will be freed when no longer
 533  *  in use.  The data is registered with an initial usage count of "0".
 534  *  Future calls to Itcl_PreserveData() increase this usage count, and
 535  *  calls to Itcl_ReleaseData() decrease the count until it reaches
 536  *  zero and the data is freed.
 537  * ------------------------------------------------------------------------
 538  */
 539 void
 540 Itcl_EventuallyFree(cdata, fproc)
 541     ClientData cdata;          /* data to be freed when not in use */
 542     Tcl_FreeProc *fproc;       /* procedure called to free data */
 543 {
 544     int newEntry;
 545     Tcl_HashEntry *entry;
 546     ItclPreservedData *chunk;
 547
 548     /*
 549      *  If the clientData value is NULL, do nothing.
 550      */
 551     if (cdata == NULL) {
 552         return;
 553     }
 554
 555     /*
 556      *  If a list has not yet been created to manage bits of
 557      *  preserved data, then create it.
 558      */
 559     if (!ItclPreservedList) {
 560         ItclPreservedList = (Tcl_HashTable*)ckalloc(
 561             (unsigned)sizeof(Tcl_HashTable)
 562         );
 563         Tcl_InitHashTable(ItclPreservedList, TCL_ONE_WORD_KEYS);
 564     }
 565
 566     /*
 567      *  Find or create the data in the global list.
 568      */
 569     entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
 570     if (newEntry) {
 571         chunk = (ItclPreservedData*)ckalloc(
 572             (unsigned)sizeof(ItclPreservedData)
 573         );
 574         chunk->data  = cdata;
 575         chunk->usage = 0;
 576         chunk->fproc = fproc;
 577         Tcl_SetHashValue(entry, (ClientData)chunk);
 578     }
 579     else {
 580         chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
 581         chunk->fproc = fproc;
 582     }
 583
 584     /*
 585      *  If the usage count is zero, then delete the data now.
 586      */
 587     if (chunk->usage == 0) {
 588         chunk->usage = -1;  /* cannot preserve/release anymore */
 589
 590         (*chunk->fproc)((char*)chunk->data);
 591         Tcl_DeleteHashEntry(entry);
 592         ckfree((char*)chunk);
 593     }
 594 }
 595 \f
 596 /*
 597  * ------------------------------------------------------------------------
 598  *  Itcl_PreserveData()
 599  *
 600  *  Increases the usage count for a piece of data that will be freed
 601  *  later when no longer needed.  Each call to Itcl_PreserveData()
 602  *  puts one claim on a piece of data, and subsequent calls to
 603  *  Itcl_ReleaseData() remove those claims.  When Itcl_EventuallyFree()
 604  *  is called, and when the usage count reaches zero, the data is
 605  *  freed.
 606  * ------------------------------------------------------------------------
 607  */
 608 void
 609 Itcl_PreserveData(cdata)
 610     ClientData cdata;      /* data to be preserved */
 611 {
 612     Tcl_HashEntry *entry;
 613     ItclPreservedData *chunk;
 614     int newEntry;
 615
 616     /*
 617      *  If the clientData value is NULL, do nothing.
 618      */
 619     if (cdata == NULL) {
 620         return;
 621     }
 622
 623     /*
 624      *  If a list has not yet been created to manage bits of
 625      *  preserved data, then create it.
 626      */
 627     if (!ItclPreservedList) {
 628         ItclPreservedList = (Tcl_HashTable*)ckalloc(
 629             (unsigned)sizeof(Tcl_HashTable)
 630         );
 631         Tcl_InitHashTable(ItclPreservedList,TCL_ONE_WORD_KEYS);
 632     }
 633
 634     /*
 635      *  Find the data in the global list and bump its usage count.
 636      */
 637     entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
 638     if (newEntry) {
 639         chunk = (ItclPreservedData*)ckalloc(
 640             (unsigned)sizeof(ItclPreservedData)
 641         );
 642         chunk->data  = cdata;
 643         chunk->usage = 0;
 644         chunk->fproc = NULL;
 645         Tcl_SetHashValue(entry, (ClientData)chunk);
 646     }
 647     else {
 648         chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
 649     }
 650
 651     /*
 652      *  Only increment the usage if it is non-negative.
 653      *  Negative numbers mean that the data is in the process
 654      *  of being destroyed by Itcl_ReleaseData(), and should
 655      *  not be further preserved.
 656      */
 657     if (chunk->usage >= 0) {
 658         chunk->usage++;
 659     }
 660 }
 661 \f
 662 /*
 663  * ------------------------------------------------------------------------
 664  *  Itcl_ReleaseData()
 665  *
 666  *  Decreases the usage count for a piece of data that was registered
 667  *  previously via Itcl_PreserveData().  After Itcl_EventuallyFree()
 668  *  is called and the usage count reaches zero, the data is
 669  *  automatically freed.
 670  * ------------------------------------------------------------------------
 671  */
 672 void
 673 Itcl_ReleaseData(cdata)
 674     ClientData cdata;      /* data to be released */
 675 {
 676     Tcl_HashEntry *entry;
 677     ItclPreservedData *chunk;
 678
 679     /*
 680      *  If the clientData value is NULL, do nothing.
 681      */
 682     if (cdata == NULL) {
 683         return;
 684     }
 685
 686     /*
 687      *  Otherwise, find the data in the global list and
 688      *  decrement its usage count.
 689      */
 690     entry = NULL;
 691     if (ItclPreservedList) {
 692         entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata);
 693     }
 694     if (!entry) {
 695         panic("Itcl_ReleaseData can't find reference for 0x%x", cdata);
 696     }
 697
 698     /*
 699      *  Only decrement the usage if it is non-negative.
 700      *  When the usage reaches zero, set it to a negative number
 701      *  to indicate that data is being destroyed, and then
 702      *  invoke the client delete proc.  When the data is deleted,
 703      *  remove the entry from the preservation list.
 704      */
 705     chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
 706     if (chunk->usage > 0 && --chunk->usage == 0) {
 707
 708         if (chunk->fproc) {
 709             chunk->usage = -1;  /* cannot preserve/release anymore */
 710             (*chunk->fproc)((char*)chunk->data);
 711         }
 712
 713         Tcl_DeleteHashEntry(entry);
 714         ckfree((char*)chunk);
 715     }
 716 }
 717
 718 \f
 719 /*
 720  * ------------------------------------------------------------------------
 721  *  Itcl_SaveInterpState()
 722  *
 723  *  Takes a snapshot of the current result state of the interpreter.
 724  *  The snapshot can be restored at any point by Itcl_RestoreInterpState.
 725  *  So if you are in the middle of building a return result, you can
 726  *  snapshot the interpreter, execute a command that might generate an
 727  *  error, restore the snapshot, and continue building the result string.
 728  *
 729  *  Once a snapshot is saved, it must be restored by calling
 730  *  Itcl_RestoreInterpState, or discarded by calling
 731  *  Itcl_DiscardInterpState.  Otherwise, memory will be leaked.
 732  *
 733  *  Returns a token representing the state of the interpreter.
 734  * ------------------------------------------------------------------------
 735  */
 736 Itcl_InterpState
 737 Itcl_SaveInterpState(interp, status)
 738     Tcl_Interp* interp;     /* interpreter being modified */
 739     int status;             /* integer status code for current operation */
 740 {
 741     Interp *iPtr = (Interp*)interp;
 742
 743     InterpState *info;
 744     char *val;
 745
 746     info = (InterpState*)ckalloc(sizeof(InterpState));
 747     info->validate = TCL_STATE_VALID;
 748     info->status = status;
 749     info->errorInfo = NULL;
 750     info->errorCode = NULL;
 751
 752     /*
 753      *  Get the result object from the interpreter.  This synchronizes
 754      *  the old-style result, so we don't have to worry about it.
 755      *  Keeping the object result is enough.
 756      */
 757     info->objResult = Tcl_GetObjResult(interp);
 758     Tcl_IncrRefCount(info->objResult);
 759
 760     /*
 761      *  If an error is in progress, preserve its state.
 762      */
 763     if ((iPtr->flags & ERR_IN_PROGRESS) != 0) {
 764         val = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
 765         if (val) {
 766             info->errorInfo = ckalloc((unsigned)(strlen(val)+1));
 767             strcpy(info->errorInfo, val);
 768         }
 769
 770         val = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
 771         if (val) {
 772             info->errorCode = ckalloc((unsigned)(strlen(val)+1));
 773             strcpy(info->errorCode, val);
 774         }
 775     }
 776
 777     /*
 778      *  Now, reset the interpreter to a clean state.
 779      */
 780     Tcl_ResetResult(interp);
 781
 782     return (Itcl_InterpState)info;
 783 }
 784
 785 \f
 786 /*
 787  * ------------------------------------------------------------------------
 788  *  Itcl_RestoreInterpState()
 789  *
 790  *  Restores the state of the interpreter to a snapshot taken by
 791  *  Itcl_SaveInterpState.  This affects variables such as "errorInfo"
 792  *  and "errorCode".  After this call, the token for the interpreter
 793  *  state is no longer valid.
 794  *
 795  *  Returns the status code that was pending at the time the state was
 796  *  captured.
 797  * ------------------------------------------------------------------------
 798  */
 799 int
 800 Itcl_RestoreInterpState(interp, state)
 801     Tcl_Interp* interp;       /* interpreter being modified */
 802     Itcl_InterpState state;   /* token representing interpreter state */
 803 {
 804     Interp *iPtr = (Interp*)interp;
 805     InterpState *info = (InterpState*)state;
 806     int status;
 807
 808     if (info->validate != TCL_STATE_VALID) {
 809         panic("bad token in Itcl_RestoreInterpState");
 810     }
 811     Tcl_ResetResult(interp);
 812
 813     /*
 814      *  If an error is in progress, restore its state.
 815      *  Set the error code the hard way--set the variable directly
 816      *  and fix the interpreter flags.  Otherwise, if the error code
 817      *  string is really a list, it will get wrapped in extra {}'s.
 818      */
 819     if (info->errorInfo) {
 820         Tcl_AddErrorInfo(interp, info->errorInfo);
 821         ckfree(info->errorInfo);
 822     }
 823
 824     if (info->errorCode) {
 825         (void) Tcl_SetVar2(interp, "errorCode", (char*)NULL,
 826             info->errorCode, TCL_GLOBAL_ONLY);
 827         iPtr->flags |= ERROR_CODE_SET;
 828
 829         ckfree(info->errorCode);
 830     }
 831
 832     /*
 833      *  Assign the object result back to the interpreter, then
 834      *  release our hold on it.
 835      */
 836     Tcl_SetObjResult(interp, info->objResult);
 837     Tcl_DecrRefCount(info->objResult);
 838
 839     status = info->status;
 840     info->validate = 0;
 841     ckfree((char*)info);
 842
 843     return status;
 844 }
 845
 846 \f
 847 /*
 848  * ------------------------------------------------------------------------
 849  *  Itcl_DiscardInterpState()
 850  *
 851  *  Frees the memory associated with an interpreter snapshot taken by
 852  *  Itcl_SaveInterpState.  If the snapshot is not restored, this
 853  *  procedure must be called to discard it, or the memory will be lost.
 854  *  After this call, the token for the interpreter state is no longer
 855  *  valid.
 856  * ------------------------------------------------------------------------
 857  */
 858 void
 859 Itcl_DiscardInterpState(state)
 860     Itcl_InterpState state;  /* token representing interpreter state */
 861 {
 862     InterpState *info = (InterpState*)state;
 863
 864     if (info->validate != TCL_STATE_VALID) {
 865         panic("bad token in Itcl_DiscardInterpState");
 866     }
 867
 868     if (info->errorInfo) {
 869         ckfree(info->errorInfo);
 870     }
 871     if (info->errorCode) {
 872         ckfree(info->errorCode);
 873     }
 874     Tcl_DecrRefCount(info->objResult);
 875
 876     info->validate = 0;
 877     ckfree((char*)info);
 878 }
 879
 880 \f
 881 /*
 882  * ------------------------------------------------------------------------
 883  *  Itcl_Protection()
 884  *
 885  *  Used to query/set the protection level used when commands/variables
 886  *  are defined within a class.  The default protection level (when
 887  *  no public/protected/private command is active) is ITCL_DEFAULT_PROTECT.
 888  *  In the default case, new commands are treated as public, while new
 889  *  variables are treated as protected.
 890  *
 891  *  If the specified level is 0, then this procedure returns the
 892  *  current value without changing it.  Otherwise, it sets the current
 893  *  value to the specified protection level, and returns the previous
 894  *  value.
 895  * ------------------------------------------------------------------------
 896  */
 897 int
 898 Itcl_Protection(interp, newLevel)
 899     Tcl_Interp *interp;  /* interpreter being queried */
 900     int newLevel;        /* new protection level or 0 */
 901 {
 902     int oldVal;
 903     ItclObjectInfo *info;
 904
 905     /*
 906      *  If a new level was specified, then set the protection level.
 907      *  In any case, return the protection level as it stands right now.
 908      */
 909     info = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA,
 910         (Tcl_InterpDeleteProc**)NULL);
 911
 912     assert(info != NULL);
 913     oldVal = info->protection;
 914
 915     if (newLevel != 0) {
 916         assert(newLevel == ITCL_PUBLIC ||
 917             newLevel == ITCL_PROTECTED ||
 918             newLevel == ITCL_PRIVATE ||
 919             newLevel == ITCL_DEFAULT_PROTECT);
 920         info->protection = newLevel;
 921     }
 922     return oldVal;
 923 }
 924
 925 \f
 926 /*
 927  * ------------------------------------------------------------------------
 928  *  Itcl_ProtectionStr()
 929  *
 930  *  Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED,
 931  *  or ITCL_PRIVATE) into a human-readable character string.  Returns
 932  *  a pointer to this string.
 933  * ------------------------------------------------------------------------
 934  */
 935 char*
 936 Itcl_ProtectionStr(pLevel)
 937     int pLevel;     /* protection level */
 938 {
 939     switch (pLevel) {
 940     case ITCL_PUBLIC:
 941         return "public";
 942     case ITCL_PROTECTED:
 943         return "protected";
 944     case ITCL_PRIVATE:
 945         return "private";
 946     }
 947     return "<bad-protection-code>";
 948 }
 949
 950 \f
 951 /*
 952  * ------------------------------------------------------------------------
 953  *  Itcl_CanAccess()
 954  *
 955  *  Checks to see if a class member can be accessed from a particular
 956  *  namespace context.  Public things can always be accessed.  Protected
 957  *  things can be accessed if the "from" namespace appears in the
 958  *  inheritance hierarchy of the class namespace.  Private things
 959  *  can be accessed only if the "from" namespace is the same as the
 960  *  class that contains them.
 961  *
 962  *  Returns 1/0 indicating true/false.
 963  * ------------------------------------------------------------------------
 964  */
 965 int
 966 Itcl_CanAccess(memberPtr, fromNsPtr)
 967     ItclMember* memberPtr;     /* class member being tested */
 968     Tcl_Namespace* fromNsPtr;  /* namespace requesting access */
 969 {
 970     ItclClass* fromCdPtr;
 971     Tcl_HashEntry *entry;
 972
 973     /*
 974      *  If the protection level is "public" or "private", then the
 975      *  answer is known immediately.
 976      */
 977     if (memberPtr->protection == ITCL_PUBLIC) {
 978         return 1;
 979     }
 980     else if (memberPtr->protection == ITCL_PRIVATE) {
 981         return (memberPtr->classDefn->namesp == fromNsPtr);
 982     }
 983
 984     /*
 985      *  If the protection level is "protected", then check the
 986      *  heritage of the namespace requesting access.  If cdefnPtr
 987      *  is in the heritage, then access is allowed.
 988      */
 989     assert (memberPtr->protection == ITCL_PROTECTED);
 990
 991     if (Itcl_IsClassNamespace(fromNsPtr)) {
 992         fromCdPtr = (ItclClass*)fromNsPtr->clientData;
 993
 994         entry = Tcl_FindHashEntry(&fromCdPtr->heritage,
 995             (char*)memberPtr->classDefn);
 996
 997         if (entry) {
 998             return 1;
 999         }
1000     }
1001     return 0;
1002 }
1003
1004 \f
1005 /*
1006  * ------------------------------------------------------------------------
1007  *  Itcl_CanAccessFunc()
1008  *
1009  *  Checks to see if a member function with the specified protection
1010  *  level can be accessed from a particular namespace context.  This
1011  *  follows the same rules enforced by Itcl_CanAccess, but adds one
1012  *  special case:  If the function is a protected method, and if the
1013  *  current context is a base class that has the same method, then
1014  *  access is allowed.
1015  *
1016  *  Returns 1/0 indicating true/false.
1017  * ------------------------------------------------------------------------
1018  */
1019 int
1020 Itcl_CanAccessFunc(mfunc, fromNsPtr)
1021     ItclMemberFunc* mfunc;     /* member function being tested */
1022     Tcl_Namespace* fromNsPtr;  /* namespace requesting access */
1023 {
1024     ItclClass *cdPtr, *fromCdPtr;
1025     ItclMemberFunc *ovlfunc;
1026     Tcl_HashEntry *entry;
1027
1028     /*
1029      *  Apply the usual rules first.
1030      */
1031     if (Itcl_CanAccess(mfunc->member, fromNsPtr)) {
1032         return 1;
1033     }
1034
1035     /*
1036      *  As a last resort, see if the namespace is really a base
1037      *  class of the class containing the method.  Look for a
1038      *  method with the same name in the base class.  If there
1039      *  is one, then this method overrides it, and the base class
1040      *  has access.
1041      */
1042     if ((mfunc->member->flags & ITCL_COMMON) == 0 &&
1043         Itcl_IsClassNamespace(fromNsPtr)) {
1044
1045         cdPtr = mfunc->member->classDefn;
1046         fromCdPtr = (ItclClass*)fromNsPtr->clientData;
1047
1048         if (Tcl_FindHashEntry(&cdPtr->heritage, (char*)fromCdPtr)) {
1049             entry = Tcl_FindHashEntry(&fromCdPtr->resolveCmds,
1050                 mfunc->member->name);
1051
1052             if (entry) {
1053                 ovlfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
1054                 if ((ovlfunc->member->flags & ITCL_COMMON) == 0 &&
1055                      ovlfunc->member->protection < ITCL_PRIVATE) {
1056                     return 1;
1057                 }
1058             }
1059         }
1060     }
1061     return 0;
1062 }
1063
1064 \f
1065 /*
1066  * ------------------------------------------------------------------------
1067  *  Itcl_GetTrueNamespace()
1068  *
1069  *  Returns the current namespace context.  This procedure is similar
1070  *  to Tcl_GetCurrentNamespace, but it supports the notion of
1071  *  "transparent" call frames installed by Itcl_HandleInstance.
1072  *
1073  *  Returns a pointer to the current namespace calling context.
1074  * ------------------------------------------------------------------------
1075  */
1076 Tcl_Namespace*
1077 Itcl_GetTrueNamespace(interp, info)
1078     Tcl_Interp *interp;        /* interpreter being queried */
1079     ItclObjectInfo *info;      /* object info associated with interp */
1080 {
1081     int i, transparent;
1082     Tcl_CallFrame *framePtr, *transFramePtr;
1083     Tcl_Namespace *contextNs;
1084
1085     /*
1086      *  See if the current call frame is on the list of transparent
1087      *  call frames.
1088      */
1089     transparent = 0;
1090
1091     framePtr = _Tcl_GetCallFrame(interp, 0);
1092     for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
1093         transFramePtr = (Tcl_CallFrame*)
1094             Itcl_GetStackValue(&info->transparentFrames, i);
1095
1096         if (framePtr == transFramePtr) {
1097             transparent = 1;
1098             break;
1099         }
1100     }
1101
1102     /*
1103      *  If this is a transparent call frame, return the namespace
1104      *  context one level up.
1105      */
1106     if (transparent) {
1107         framePtr = _Tcl_GetCallFrame(interp, 1);
1108         if (framePtr) {
1109             contextNs = framePtr->nsPtr;
1110         } else {
1111             contextNs = Tcl_GetGlobalNamespace(interp);
1112         }
1113     }
1114     else {
1115         contextNs = Tcl_GetCurrentNamespace(interp);
1116     }
1117     return contextNs;
1118 }
1119
1120 \f
1121 /*
1122  * ------------------------------------------------------------------------
1123  *  Itcl_ParseNamespPath()
1124  *
1125  *  Parses a reference to a namespace element of the form:
1126  *
1127  *      namesp::namesp::namesp::element
1128  *
1129  *  Returns pointers to the head part ("namesp::namesp::namesp")
1130  *  and the tail part ("element").  If the head part is missing,
1131  *  a NULL pointer is returned and the rest of the string is taken
1132  *  as the tail.
1133  *
1134  *  Both head and tail point to locations within the given dynamic
1135  *  string buffer.  This buffer must be uninitialized when passed
1136  *  into this procedure, and it must be freed later on, when the
1137  *  strings are no longer needed.
1138  * ------------------------------------------------------------------------
1139  */
1140 void
1141 Itcl_ParseNamespPath(name, buffer, head, tail)
1142     char *name;          /* path name to class member */
1143     Tcl_DString *buffer; /* dynamic string buffer (uninitialized) */
1144     char **head;         /* returns "namesp::namesp::namesp" part */
1145     char **tail;         /* returns "element" part */
1146 {
1147     register char *sep;
1148
1149     Tcl_DStringInit(buffer);
1150
1151     /*
1152      *  Copy the name into the buffer and parse it.  Look
1153      *  backward from the end of the string to the first '::'
1154      *  scope qualifier.
1155      */
1156     Tcl_DStringAppend(buffer, name, -1);
1157     name = Tcl_DStringValue(buffer);
1158
1159     for (sep=name; *sep != '\0'; sep++)
1160         ;
1161
1162     while (--sep > name) {
1163         if (*sep == ':' && *(sep-1) == ':') {
1164             break;
1165         }
1166     }
1167
1168     /*
1169      *  Found head/tail parts.  If there are extra :'s, keep backing
1170      *  up until the head is found.  This supports the Tcl namespace
1171      *  behavior, which allows names like "foo:::bar".
1172      */
1173     if (sep > name) {
1174         *tail = sep+1;
1175         while (sep > name && *(sep-1) == ':') {
1176             sep--;
1177         }
1178         *sep = '\0';
1179         *head = name;
1180     }
1181
1182     /*
1183      *  No :: separators--the whole name is treated as a tail.
1184      */
1185     else {
1186         *tail = name;
1187         *head = NULL;
1188     }
1189 }
1190
1191 \f
1192 /*
1193  * ------------------------------------------------------------------------
1194  *  Itcl_DecodeScopedCommand()
1195  *
1196  *  Decodes a scoped command of the form:
1197  *
1198  *      namespace inscope <namesp> <command>
1199  *
1200  *  If the given string is not a scoped value, this procedure does
1201  *  nothing and returns TCL_OK.  If the string is a scoped value,
1202  *  then it is decoded, and the namespace, and the simple command
1203  *  string are returned as arguments; the simple command should
1204  *  be freed when no longer in use.  If anything goes wrong, this
1205  *  procedure returns TCL_ERROR, along with an error message in
1206  *  the interpreter.
1207  * ------------------------------------------------------------------------
1208  */
1209 int
1210 Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
1211     Tcl_Interp *interp;      /* current interpreter */
1212     char *name;              /* string to be decoded */
1213     Tcl_Namespace **rNsPtr;  /* returns: namespace for scoped value */
1214     char **rCmdPtr;          /* returns: simple command word */
1215 {
1216     Tcl_Namespace *nsPtr = NULL;
1217     char *cmdName = name;
1218     int len = strlen(name);
1219
1220     char *pos;
1221     int listc, result;
1222     char **listv;
1223
1224     if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
1225         for (pos = (name + 9);  (*pos == ' ');  pos++) {
1226             /* empty body: skip over spaces */
1227         }
1228         if ((*pos == 'i') && ((pos + 7) <= (name + len))
1229                 && (strncmp(pos, "inscope", 7) == 0)) {
1230
1231             result = Tcl_SplitList(interp, name, &listc, &listv);
1232             if (result == TCL_OK) {
1233                 if (listc != 4) {
1234                     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1235                         "malformed command \"", name, "\": should be \"",
1236                         "namespace inscope namesp command\"",
1237                         (char*)NULL);
1238                     result = TCL_ERROR;
1239                 }
1240                 else {
1241                     nsPtr = Tcl_FindNamespace(interp, listv[2],
1242                         (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
1243
1244                     if (!nsPtr) {
1245                         result = TCL_ERROR;
1246                     }
1247                     else {
1248                         cmdName = ckalloc((unsigned)(strlen(listv[3])+1));
1249                         strcpy(cmdName, listv[3]);
1250                     }
1251                 }
1252             }
1253             ckfree((char*)listv);
1254
1255             if (result != TCL_OK) {
1256                 char msg[512];
1257                 sprintf(msg, "\n    (while decoding scoped command \"%.400s\")", name);
1258                 Tcl_AddObjErrorInfo(interp, msg, -1);
1259                 return TCL_ERROR;
1260             }
1261         }
1262     }
1263
1264     *rNsPtr = nsPtr;
1265     *rCmdPtr = cmdName;
1266     return TCL_OK;
1267 }
1268
1269 \f
1270 /*
1271  * ------------------------------------------------------------------------
1272  *  Itcl_EvalArgs()
1273  *
1274  *  This procedure invokes a list of (objc,objv) arguments as a
1275  *  single command.  It is similar to Tcl_EvalObj, but it doesn't
1276  *  do any parsing or compilation.  It simply treats the first
1277  *  argument as a command and invokes that command in the current
1278  *  context.
1279  *
1280  *  Returns TCL_OK if successful.  Otherwise, this procedure returns
1281  *  TCL_ERROR along with an error message in the interpreter.
1282  * ------------------------------------------------------------------------
1283  */
1284 int
1285 Itcl_EvalArgs(interp, objc, objv)
1286     Tcl_Interp *interp;      /* current interpreter */
1287     int objc;                /* number of arguments */
1288     Tcl_Obj *CONST objv[];   /* argument objects */
1289 {
1290     int result;
1291     Tcl_Command cmd;
1292     Command *cmdPtr;
1293     int cmdlinec;
1294     Tcl_Obj **cmdlinev;
1295     Tcl_Obj *cmdlinePtr = NULL;
1296
1297     /*
1298      * Resolve the command by converting it to a CmdName object.
1299      * This caches a pointer to the Command structure for the
1300      * command, so if we need it again, it's ready to use.
1301      */
1302     cmd = Tcl_GetCommandFromObj(interp, objv[0]);
1303     cmdPtr = (Command*)cmd;
1304
1305     cmdlinec = objc;
1306     cmdlinev = (Tcl_Obj**)objv;
1307
1308     /*
1309      * If the command is still not found, handle it with the
1310      * "unknown" proc.
1311      */
1312     if (cmdPtr == NULL) {
1313         cmd = Tcl_FindCommand(interp, "unknown",
1314             (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
1315
1316         if (cmd == NULL) {
1317             Tcl_ResetResult(interp);
1318             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1319                 "invalid command name \"",
1320                 Tcl_GetStringFromObj(objv[0], (int*)NULL), "\"",
1321                 (char*)NULL);
1322             return TCL_ERROR;
1323         }
1324         cmdPtr = (Command*)cmd;
1325
1326         cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv);
1327
1328         (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
1329             &cmdlinec, &cmdlinev);
1330     }
1331
1332     /*
1333      *  Finally, invoke the command's Tcl_ObjCmdProc.  Be careful
1334      *  to pass in the proper client data.
1335      */
1336     Tcl_ResetResult(interp);
1337     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
1338         cmdlinec, cmdlinev);
1339
1340     if (cmdlinePtr) {
1341         Tcl_DecrRefCount(cmdlinePtr);
1342     }
1343     return result;
1344 }
1345
1346 \f
1347 /*
1348  * ------------------------------------------------------------------------
1349  *  Itcl_CreateArgs()
1350  *
1351  *  This procedure takes a string and a list of (objc,objv) arguments,
1352  *  and glues them together in a single list.  This is useful when
1353  *  a command word needs to be prepended or substituted into a command
1354  *  line before it is executed.  The arguments are returned in a single
1355  *  list object, and they can be retrieved by calling
1356  *  Tcl_ListObjGetElements.  When the arguments are no longer needed,
1357  *  they should be discarded by decrementing the reference count for
1358  *  the list object.
1359  *
1360  *  Returns a pointer to the list object containing the arguments.
1361  * ------------------------------------------------------------------------
1362  */
1363 Tcl_Obj*
1364 Itcl_CreateArgs(interp, string, objc, objv)
1365     Tcl_Interp *interp;      /* current interpreter */
1366     char *string;            /* first command word */
1367     int objc;                /* number of arguments */
1368     Tcl_Obj *CONST objv[];   /* argument objects */
1369 {
1370     int i;
1371     Tcl_Obj *listPtr;
1372
1373     listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
1374     Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
1375         Tcl_NewStringObj(string, -1));
1376
1377     for (i=0; i < objc; i++) {
1378         Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objv[i]);
1379     }
1380
1381     Tcl_IncrRefCount(listPtr);
1382     return listPtr;
1383 }