util/src/TclTk/tcl8.6.12/pkgs/itcl4.2.2/generic/itclUtil.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  *  overhauled version author: Arnulf Wiedemann
  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 <limits.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  *  This structure is used to take a snapshot of the interpreter
  45  *  state in Itcl_SaveInterpState.  You can snapshot the state,
  46  *  execute a command, and then back up to the result or the
  47  *  error that was previously in progress.
  48  */
  49 typedef struct InterpState {
  50     int validate;                   /* validation stamp */
  51     int status;                     /* return code status */
  52     Tcl_Obj *objResult;             /* result object */
  53     char *errorInfo;                /* contents of errorInfo variable */
  54     char *errorCode;                /* contents of errorCode variable */
  55 } InterpState;
  56
  57 #define TCL_STATE_VALID 0x01233210  /* magic bit pattern for validation */
  58
  59 \f
  60 /*
  61  * ------------------------------------------------------------------------
  62  *  Itcl_Assert()
  63  *
  64  *  Called whenever an assert() test fails.  Prints a diagnostic
  65  *  message and abruptly exits.
  66  * ------------------------------------------------------------------------
  67  */
  68
  69 void
  70 Itcl_Assert(
  71     const char *testExpr,   /* string representing test expression */
  72     const char *fileName,   /* file name containing this call */
  73     int lineNumber)         /* line number containing this call */
  74 {
  75     Tcl_Panic("Itcl Assertion failed: \"%s\" (line %d of %s)",
  76         testExpr, lineNumber, fileName);
  77 }
  78
  79
  80 \f
  81 /*
  82  * ------------------------------------------------------------------------
  83  *  Itcl_InitStack()
  84  *
  85  *  Initializes a stack structure, allocating a certain amount of memory
  86  *  for the stack and setting the stack length to zero.
  87  * ------------------------------------------------------------------------
  88  */
  89 void
  90 Itcl_InitStack(
  91     Itcl_Stack *stack)     /* stack to be initialized */
  92 {
  93     stack->values = stack->space;
  94     stack->max = sizeof(stack->space)/sizeof(ClientData);
  95     stack->len = 0;
  96 }
  97 \f
  98 /*
  99  * ------------------------------------------------------------------------
 100  *  Itcl_DeleteStack()
 101  *
 102  *  Destroys a stack structure, freeing any memory that may have been
 103  *  allocated to represent it.
 104  * ------------------------------------------------------------------------
 105  */
 106 void
 107 Itcl_DeleteStack(
 108     Itcl_Stack *stack)     /* stack to be deleted */
 109 {
 110     /*
 111      *  If memory was explicitly allocated (instead of using the
 112      *  built-in buffer) then free it.
 113      */
 114     if (stack->values != stack->space) {
 115         ckfree((char*)stack->values);
 116     }
 117     stack->values = NULL;
 118     stack->len = stack->max = 0;
 119 }
 120 \f
 121 /*
 122  * ------------------------------------------------------------------------
 123  *  Itcl_PushStack()
 124  *
 125  *  Pushes a piece of client data onto the top of the given stack.
 126  *  If the stack is not large enough, it is automatically resized.
 127  * ------------------------------------------------------------------------
 128  */
 129 void
 130 Itcl_PushStack(
 131     ClientData cdata,      /* data to be pushed onto stack */
 132     Itcl_Stack *stack)     /* stack */
 133 {
 134     ClientData *newStack;
 135
 136     if (stack->len+1 >= stack->max) {
 137         stack->max = 2*stack->max;
 138         newStack = (ClientData*)
 139             ckalloc((unsigned)(stack->max*sizeof(ClientData)));
 140
 141         if (stack->values) {
 142             memcpy((char*)newStack, (char*)stack->values,
 143                 (size_t)(stack->len*sizeof(ClientData)));
 144
 145             if (stack->values != stack->space)
 146                 ckfree((char*)stack->values);
 147         }
 148         stack->values = newStack;
 149     }
 150     stack->values[stack->len++] = cdata;
 151 }
 152 \f
 153 /*
 154  * ------------------------------------------------------------------------
 155  *  Itcl_PopStack()
 156  *
 157  *  Pops a bit of client data from the top of the given stack.
 158  * ------------------------------------------------------------------------
 159  */
 160 ClientData
 161 Itcl_PopStack(
 162     Itcl_Stack *stack)  /* stack to be manipulated */
 163 {
 164     if (stack->values && (stack->len > 0)) {
 165         stack->len--;
 166         return stack->values[stack->len];
 167     }
 168     return NULL;
 169 }
 170 \f
 171 /*
 172  * ------------------------------------------------------------------------
 173  *  Itcl_PeekStack()
 174  *
 175  *  Gets the current value from the top of the given stack.
 176  * ------------------------------------------------------------------------
 177  */
 178 ClientData
 179 Itcl_PeekStack(
 180     Itcl_Stack *stack)  /* stack to be examined */
 181 {
 182     if (stack->values && (stack->len > 0)) {
 183         return stack->values[stack->len-1];
 184     }
 185     return NULL;
 186 }
 187 \f
 188 /*
 189  * ------------------------------------------------------------------------
 190  *  Itcl_GetStackValue()
 191  *
 192  *  Gets a value at some index within the stack.  Index "0" is the
 193  *  first value pushed onto the stack.
 194  * ------------------------------------------------------------------------
 195  */
 196 ClientData
 197 Itcl_GetStackValue(
 198     Itcl_Stack *stack,  /* stack to be examined */
 199     int pos)            /* get value at this index */
 200 {
 201     if (stack->values && (stack->len > 0)) {
 202         assert(pos < stack->len);
 203         return stack->values[pos];
 204     }
 205     return NULL;
 206 }
 207
 208 \f
 209 /*
 210  * ------------------------------------------------------------------------
 211  *  Itcl_InitList()
 212  *
 213  *  Initializes a linked list structure, setting the list to the empty
 214  *  state.
 215  * ------------------------------------------------------------------------
 216  */
 217 void
 218 Itcl_InitList(
 219     Itcl_List *listPtr)     /* list to be initialized */
 220 {
 221     listPtr->validate = ITCL_VALID_LIST;
 222     listPtr->num      = 0;
 223     listPtr->head     = NULL;
 224     listPtr->tail     = NULL;
 225 }
 226 \f
 227 /*
 228  * ------------------------------------------------------------------------
 229  *  Itcl_DeleteList()
 230  *
 231  *  Destroys a linked list structure, deleting all of its elements and
 232  *  setting it to an empty state.  If the elements have memory associated
 233  *  with them, this memory must be freed before deleting the list or it
 234  *  will be lost.
 235  * ------------------------------------------------------------------------
 236  */
 237 void
 238 Itcl_DeleteList(
 239     Itcl_List *listPtr)     /* list to be deleted */
 240 {
 241     Itcl_ListElem *elemPtr;
 242
 243     assert(listPtr->validate == ITCL_VALID_LIST);
 244
 245     elemPtr = listPtr->head;
 246     while (elemPtr) {
 247         elemPtr = Itcl_DeleteListElem(elemPtr);
 248     }
 249     listPtr->validate = 0;
 250 }
 251 \f
 252 /*
 253  * ------------------------------------------------------------------------
 254  *  Itcl_CreateListElem()
 255  *
 256  *  Low-level routined used by procedures like Itcl_InsertList() and
 257  *  Itcl_AppendList() to create new list elements.  If elements are
 258  *  available, one is taken from the list element pool.  Otherwise,
 259  *  a new one is allocated.
 260  * ------------------------------------------------------------------------
 261  */
 262 Itcl_ListElem*
 263 Itcl_CreateListElem(
 264     Itcl_List *listPtr)     /* list that will contain this new element */
 265 {
 266     Itcl_ListElem *elemPtr;
 267
 268     if (listPoolLen > 0) {
 269         elemPtr = listPool;
 270         listPool = elemPtr->next;
 271         --listPoolLen;
 272     } else {
 273         elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem));
 274     }
 275     elemPtr->owner = listPtr;
 276     elemPtr->value = NULL;
 277     elemPtr->next  = NULL;
 278     elemPtr->prev  = NULL;
 279
 280     return elemPtr;
 281 }
 282 \f
 283 /*
 284  * ------------------------------------------------------------------------
 285  *  Itcl_DeleteListElem()
 286  *
 287  *  Destroys a single element in a linked list, returning it to a pool of
 288  *  elements that can be later reused.  Returns a pointer to the next
 289  *  element in the list.
 290  * ------------------------------------------------------------------------
 291  */
 292 Itcl_ListElem*
 293 Itcl_DeleteListElem(
 294     Itcl_ListElem *elemPtr)     /* list element to be deleted */
 295 {
 296     Itcl_List *listPtr;
 297     Itcl_ListElem *nextPtr;
 298
 299     nextPtr = elemPtr->next;
 300
 301     if (elemPtr->prev) {
 302         elemPtr->prev->next = elemPtr->next;
 303     }
 304     if (elemPtr->next) {
 305         elemPtr->next->prev = elemPtr->prev;
 306     }
 307
 308     listPtr = elemPtr->owner;
 309     if (elemPtr == listPtr->head) {
 310         listPtr->head = elemPtr->next;
 311     }
 312     if (elemPtr == listPtr->tail) {
 313         listPtr->tail = elemPtr->prev;
 314     }
 315     --listPtr->num;
 316
 317     if (listPoolLen < ITCL_LIST_POOL_SIZE) {
 318         elemPtr->next = listPool;
 319         listPool = elemPtr;
 320         ++listPoolLen;
 321     } else {
 322         ckfree((char*)elemPtr);
 323     }
 324     return nextPtr;
 325 }
 326 \f
 327 /*
 328  * ------------------------------------------------------------------------
 329  *  Itcl_InsertList()
 330  *
 331  *  Creates a new list element containing the given value and returns
 332  *  a pointer to it.  The element is inserted at the beginning of the
 333  *  specified list.
 334  * ------------------------------------------------------------------------
 335  */
 336 Itcl_ListElem*
 337 Itcl_InsertList(
 338     Itcl_List *listPtr,     /* list being modified */
 339     ClientData val)         /* value associated with new element */
 340 {
 341     Itcl_ListElem *elemPtr;
 342     assert(listPtr->validate == ITCL_VALID_LIST);
 343
 344     elemPtr = Itcl_CreateListElem(listPtr);
 345
 346     elemPtr->value = val;
 347     elemPtr->next  = listPtr->head;
 348     elemPtr->prev  = NULL;
 349     if (listPtr->head) {
 350         listPtr->head->prev = elemPtr;
 351     }
 352     listPtr->head  = elemPtr;
 353     if (listPtr->tail == NULL) {
 354         listPtr->tail = elemPtr;
 355     }
 356     ++listPtr->num;
 357
 358     return elemPtr;
 359 }
 360 \f
 361 /*
 362  * ------------------------------------------------------------------------
 363  *  Itcl_InsertListElem()
 364  *
 365  *  Creates a new list element containing the given value and returns
 366  *  a pointer to it.  The element is inserted in the list just before
 367  *  the specified element.
 368  * ------------------------------------------------------------------------
 369  */
 370 Itcl_ListElem*
 371 Itcl_InsertListElem(
 372     Itcl_ListElem *pos,     /* insert just before this element */
 373     ClientData val)         /* value associated with new element */
 374 {
 375     Itcl_List *listPtr;
 376     Itcl_ListElem *elemPtr;
 377
 378     listPtr = pos->owner;
 379     assert(listPtr->validate == ITCL_VALID_LIST);
 380     assert(pos != NULL);
 381
 382     elemPtr = Itcl_CreateListElem(listPtr);
 383     elemPtr->value = val;
 384
 385     elemPtr->prev = pos->prev;
 386     if (elemPtr->prev) {
 387         elemPtr->prev->next = elemPtr;
 388     }
 389     elemPtr->next = pos;
 390     pos->prev     = elemPtr;
 391
 392     if (listPtr->head == pos) {
 393         listPtr->head = elemPtr;
 394     }
 395     if (listPtr->tail == NULL) {
 396         listPtr->tail = elemPtr;
 397     }
 398     ++listPtr->num;
 399
 400     return elemPtr;
 401 }
 402 \f
 403 /*
 404  * ------------------------------------------------------------------------
 405  *  Itcl_AppendList()
 406  *
 407  *  Creates a new list element containing the given value and returns
 408  *  a pointer to it.  The element is appended at the end of the
 409  *  specified list.
 410  * ------------------------------------------------------------------------
 411  */
 412 Itcl_ListElem*
 413 Itcl_AppendList(
 414     Itcl_List *listPtr,     /* list being modified */
 415     ClientData val)         /* value associated with new element */
 416 {
 417     Itcl_ListElem *elemPtr;
 418     assert(listPtr->validate == ITCL_VALID_LIST);
 419
 420     elemPtr = Itcl_CreateListElem(listPtr);
 421
 422     elemPtr->value = val;
 423     elemPtr->prev  = listPtr->tail;
 424     elemPtr->next  = NULL;
 425     if (listPtr->tail) {
 426         listPtr->tail->next = elemPtr;
 427     }
 428     listPtr->tail  = elemPtr;
 429     if (listPtr->head == NULL) {
 430         listPtr->head = elemPtr;
 431     }
 432     ++listPtr->num;
 433
 434     return elemPtr;
 435 }
 436 \f
 437 /*
 438  * ------------------------------------------------------------------------
 439  *  Itcl_AppendListElem()
 440  *
 441  *  Creates a new list element containing the given value and returns
 442  *  a pointer to it.  The element is inserted in the list just after
 443  *  the specified element.
 444  * ------------------------------------------------------------------------
 445  */
 446 Itcl_ListElem*
 447 Itcl_AppendListElem(
 448     Itcl_ListElem *pos,     /* insert just after this element */
 449     ClientData val)         /* value associated with new element */
 450 {
 451     Itcl_List *listPtr;
 452     Itcl_ListElem *elemPtr;
 453
 454     listPtr = pos->owner;
 455     assert(listPtr->validate == ITCL_VALID_LIST);
 456     assert(pos != NULL);
 457
 458     elemPtr = Itcl_CreateListElem(listPtr);
 459     elemPtr->value = val;
 460
 461     elemPtr->next = pos->next;
 462     if (elemPtr->next) {
 463         elemPtr->next->prev = elemPtr;
 464     }
 465     elemPtr->prev = pos;
 466     pos->next     = elemPtr;
 467
 468     if (listPtr->tail == pos) {
 469         listPtr->tail = elemPtr;
 470     }
 471     if (listPtr->head == NULL) {
 472         listPtr->head = elemPtr;
 473     }
 474     ++listPtr->num;
 475
 476     return elemPtr;
 477 }
 478 \f
 479 /*
 480  * ------------------------------------------------------------------------
 481  *  Itcl_SetListValue()
 482  *
 483  *  Modifies the value associated with a list element.
 484  * ------------------------------------------------------------------------
 485  */
 486 void
 487 Itcl_SetListValue(
 488     Itcl_ListElem *elemPtr, /* list element being modified */
 489     ClientData val)         /* new value associated with element */
 490 {
 491     assert(elemPtr != NULL);
 492     assert(elemPtr->owner->validate == ITCL_VALID_LIST);
 493     elemPtr->value = val;
 494 }
 495
 496 \f
 497 /*
 498  * ------------------------------------------------------------------------
 499  *  Itcl_FinishList()
 500  *
 501  *  free all memory used in the list pool
 502  * ------------------------------------------------------------------------
 503  */
 504 void
 505 Itcl_FinishList()
 506 {
 507     Itcl_ListElem *listPtr;
 508     Itcl_ListElem *elemPtr;
 509
 510     listPtr = listPool;
 511     while (listPtr != NULL) {
 512         elemPtr = listPtr;
 513         listPtr = elemPtr->next;
 514         ckfree((char *)elemPtr);
 515         elemPtr = NULL;
 516     }
 517     listPool = NULL;
 518     listPoolLen = 0;
 519 }
 520
 521 \f
 522 /*
 523  * ========================================================================
 524  *  REFERENCE-COUNTED DATA
 525  *
 526  *  The following procedures manage generic reference-counted data.
 527  *  They are similar in spirit to the Tcl_Preserve/Tcl_Release
 528  *  procedures defined in the Tcl/Tk core.  But these procedures attach a
 529  *  refcount directly to the allocated memory, and then use it to govern
 530  *  shared access and properly timed release.
 531  */
 532
 533 typedef struct PresMemoryPrefix {
 534     Tcl_FreeProc *freeProc;     /* called by last Itcl_ReleaseData */
 535     size_t refCount;            /* refernce (resp preserving) counter */
 536 } PresMemoryPrefix;
 537
 538 /*
 539  * ------------------------------------------------------------------------
 540  *  Itcl_EventuallyFree()
 541  *
 542  *  Asscociates with cdata (allocated by Itcl_Alloc()) a routine to
 543  *  be called when cdata should be freed. This routine will be called
 544  *  when the number of Itcl_ReleaseData() calls on cdata  matches the
 545  *  number of Itcl_PreserveData() calls on cdata.
 546  * ------------------------------------------------------------------------
 547  */
 548 void
 549 Itcl_EventuallyFree(
 550     ClientData cdata,          /* data to be freed when not in use */
 551     Tcl_FreeProc *fproc)       /* procedure called to free data */
 552 {
 553     PresMemoryPrefix *blk;
 554
 555     if (cdata == NULL) {
 556         return;
 557     }
 558
 559     /* Itcl memory block to ckalloc block */
 560     blk = ((PresMemoryPrefix *)cdata)-1;
 561
 562     /* Set new free proc */
 563     blk->freeProc = fproc;
 564 }
 565 \f
 566 /*
 567  * ------------------------------------------------------------------------
 568  *  Itcl_PreserveData()
 569  *
 570  *  Increases the usage count for a piece of data that will be freed
 571  *  later when no longer needed.  Each call to Itcl_PreserveData()
 572  *  puts one claim on a piece of data, and subsequent calls to
 573  *  Itcl_ReleaseData() remove those claims.  When Itcl_EventuallyFree()
 574  *  is called, and when the usage count reaches zero, the data is
 575  *  freed.
 576  * ------------------------------------------------------------------------
 577  */
 578 void
 579 Itcl_PreserveData(
 580     ClientData cdata)     /* data to be preserved */
 581 {
 582     PresMemoryPrefix *blk;
 583
 584     if (cdata == NULL) {
 585         return;
 586     }
 587
 588     /* Itcl memory block to ckalloc block */
 589     blk = ((PresMemoryPrefix *)cdata)-1;
 590
 591     /* Increment preservation count */
 592     ++blk->refCount;
 593 }
 594 \f
 595 /*
 596  * ------------------------------------------------------------------------
 597  *  Itcl_ReleaseData()
 598  *
 599  *  Decreases the usage count for a piece of data that was registered
 600  *  previously via Itcl_PreserveData().  After Itcl_EventuallyFree()
 601  *  is called and the usage count reaches zero, the data is
 602  *  automatically freed.
 603  * ------------------------------------------------------------------------
 604  */
 605 void
 606 Itcl_ReleaseData(
 607     ClientData cdata)      /* data to be released */
 608 {
 609     PresMemoryPrefix *blk;
 610     Tcl_FreeProc *freeProc;
 611
 612     if (cdata == NULL) {
 613         return;
 614     }
 615
 616     /* Itcl memory block to ckalloc block */
 617     blk = ((PresMemoryPrefix *)cdata)-1;
 618
 619     /* Usage sanity check */
 620     assert(blk->refCount != 0); /* must call Itcl_PreserveData() first */
 621     assert(blk->freeProc);      /* must call Itcl_EventuallyFree() first */
 622
 623     /* Decrement preservation count */
 624     if (--blk->refCount) {
 625         return;
 626     }
 627
 628     /* Free cdata now */
 629     freeProc = blk->freeProc;
 630     blk->freeProc = NULL;
 631     freeProc((char *)cdata);
 632 }
 633 \f
 634 /*
 635  * ------------------------------------------------------------------------
 636  * Itcl_Alloc()
 637  *
 638  *      Allocate preservable memory. In opposite to ckalloc the result can be
 639  *      supplied to preservation facilities of Itcl (Itcl_PreserveData).
 640  *
 641  * Results:
 642  *      Pointer to new allocated memory.
 643  * ------------------------------------------------------------------------
 644  */
 645 void * Itcl_Alloc(
 646     size_t size)        /* Size of memory to allocate */
 647 {
 648     size_t numBytes;
 649     PresMemoryPrefix *blk;
 650
 651     /* The ckalloc() in Tcl 8 can alloc at most UINT_MAX bytes */
 652     assert (size <= UINT_MAX - sizeof(PresMemoryPrefix));
 653     numBytes = size + sizeof(PresMemoryPrefix);
 654
 655     /* This will panic on allocation failure. No need to check return value. */
 656     blk = (PresMemoryPrefix *)ckalloc(numBytes);
 657
 658     /* Itcl_Alloc defined to zero-init memory it allocates */
 659     memset(blk, 0, numBytes);
 660
 661     /* ckalloc block to Itcl memory block */
 662     return blk+1;
 663 }
 664 /*
 665  * ------------------------------------------------------------------------
 666  * ItclFree()
 667  *
 668  *      Release memory allocated by Itcl_Alloc() that was never preserved.
 669  *
 670  * Results:
 671  *      None.
 672  *
 673  * ------------------------------------------------------------------------
 674  */
 675 void Itcl_Free(void *ptr) {
 676     PresMemoryPrefix *blk;
 677
 678     if (ptr == NULL) {
 679         return;
 680     }
 681     /* Itcl memory block to ckalloc block */
 682     blk = ((PresMemoryPrefix *)ptr)-1;
 683
 684     assert(blk->refCount == 0); /* it should be not preserved */
 685     assert(blk->freeProc == NULL); /* it should be released */
 686     ckfree(blk);
 687 }
 688 \f
 689 /*
 690  * ------------------------------------------------------------------------
 691  *  Itcl_SaveInterpState()
 692  *
 693  *  Takes a snapshot of the current result state of the interpreter.
 694  *  The snapshot can be restored at any point by Itcl_RestoreInterpState.
 695  *  So if you are in the middle of building a return result, you can
 696  *  snapshot the interpreter, execute a command that might generate an
 697  *  error, restore the snapshot, and continue building the result string.
 698  *
 699  *  Once a snapshot is saved, it must be restored by calling
 700  *  Itcl_RestoreInterpState, or discarded by calling
 701  *  Itcl_DiscardInterpState.  Otherwise, memory will be leaked.
 702  *
 703  *  Returns a token representing the state of the interpreter.
 704  * ------------------------------------------------------------------------
 705  */
 706 Itcl_InterpState
 707 Itcl_SaveInterpState(
 708     Tcl_Interp* interp,     /* interpreter being modified */
 709     int status)             /* integer status code for current operation */
 710 {
 711     return (Itcl_InterpState) Tcl_SaveInterpState(interp, status);
 712 }
 713
 714 \f
 715 /*
 716  * ------------------------------------------------------------------------
 717  *  Itcl_RestoreInterpState()
 718  *
 719  *  Restores the state of the interpreter to a snapshot taken by
 720  *  Itcl_SaveInterpState.  This affects variables such as "errorInfo"
 721  *  and "errorCode".  After this call, the token for the interpreter
 722  *  state is no longer valid.
 723  *
 724  *  Returns the status code that was pending at the time the state was
 725  *  captured.
 726  * ------------------------------------------------------------------------
 727  */
 728 int
 729 Itcl_RestoreInterpState(
 730     Tcl_Interp* interp,       /* interpreter being modified */
 731     Itcl_InterpState state)   /* token representing interpreter state */
 732 {
 733     return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state);
 734 }
 735
 736 \f
 737 /*
 738  * ------------------------------------------------------------------------
 739  *  Itcl_DiscardInterpState()
 740  *
 741  *  Frees the memory associated with an interpreter snapshot taken by
 742  *  Itcl_SaveInterpState.  If the snapshot is not restored, this
 743  *  procedure must be called to discard it, or the memory will be lost.
 744  *  After this call, the token for the interpreter state is no longer
 745  *  valid.
 746  * ------------------------------------------------------------------------
 747  */
 748 void
 749 Itcl_DiscardInterpState(
 750     Itcl_InterpState state)  /* token representing interpreter state */
 751 {
 752     Tcl_DiscardInterpState((Tcl_InterpState)state);
 753     return;
 754 }
 755 \f
 756 /*
 757  * ------------------------------------------------------------------------
 758  *  Itcl_Protection()
 759  *
 760  *  Used to query/set the protection level used when commands/variables
 761  *  are defined within a class.  The default protection level (when
 762  *  no public/protected/private command is active) is ITCL_DEFAULT_PROTECT.
 763  *  In the default case, new commands are treated as public, while new
 764  *  variables are treated as protected.
 765  *
 766  *  If the specified level is 0, then this procedure returns the
 767  *  current value without changing it.  Otherwise, it sets the current
 768  *  value to the specified protection level, and returns the previous
 769  *  value.
 770  * ------------------------------------------------------------------------
 771  */
 772 int
 773 Itcl_Protection(
 774     Tcl_Interp *interp,  /* interpreter being queried */
 775     int newLevel)        /* new protection level or 0 */
 776 {
 777     int oldVal;
 778     ItclObjectInfo *infoPtr;
 779
 780     /*
 781      *  If a new level was specified, then set the protection level.
 782      *  In any case, return the protection level as it stands right now.
 783      */
 784     infoPtr = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA,
 785         NULL);
 786
 787     assert(infoPtr != NULL);
 788     oldVal = infoPtr->protection;
 789
 790     if (newLevel != 0) {
 791         assert(newLevel == ITCL_PUBLIC ||
 792             newLevel == ITCL_PROTECTED ||
 793             newLevel == ITCL_PRIVATE ||
 794             newLevel == ITCL_DEFAULT_PROTECT);
 795         infoPtr->protection = newLevel;
 796     }
 797     return oldVal;
 798 }
 799 \f
 800 /*
 801  * ------------------------------------------------------------------------
 802  *  Itcl_ParseNamespPath()
 803  *
 804  *  Parses a reference to a namespace element of the form:
 805  *
 806  *      namesp::namesp::namesp::element
 807  *
 808  *  Returns pointers to the head part ("namesp::namesp::namesp")
 809  *  and the tail part ("element").  If the head part is missing,
 810  *  a NULL pointer is returned and the rest of the string is taken
 811  *  as the tail.
 812  *
 813  *  Both head and tail point to locations within the given dynamic
 814  *  string buffer.  This buffer must be uninitialized when passed
 815  *  into this procedure, and it must be freed later on, when the
 816  *  strings are no longer needed.
 817  * ------------------------------------------------------------------------
 818  */
 819 void
 820 Itcl_ParseNamespPath(
 821     const char *name,    /* path name to class member */
 822     Tcl_DString *buffer, /* dynamic string buffer (uninitialized) */
 823     const char **head,   /* returns "namesp::namesp::namesp" part */
 824     const char **tail)   /* returns "element" part */
 825 {
 826     char *sep, *newname;
 827
 828     Tcl_DStringInit(buffer);
 829
 830     /*
 831      *  Copy the name into the buffer and parse it.  Look
 832      *  backward from the end of the string to the first '::'
 833      *  scope qualifier.
 834      */
 835     Tcl_DStringAppend(buffer, name, -1);
 836     newname = Tcl_DStringValue(buffer);
 837
 838     for (sep=newname; *sep != '\0'; sep++)
 839         ;
 840
 841     while (--sep > newname) {
 842         if (*sep == ':' && *(sep-1) == ':') {
 843             break;
 844         }
 845     }
 846
 847     /*
 848      *  Found head/tail parts.  If there are extra :'s, keep backing
 849      *  up until the head is found.  This supports the Tcl namespace
 850      *  behavior, which allows names like "foo:::bar".
 851      */
 852     if (sep > newname) {
 853         *tail = sep+1;
 854         while (sep > newname && *(sep-1) == ':') {
 855             sep--;
 856         }
 857         *sep = '\0';
 858         *head = newname;
 859     } else {
 860
 861         /*
 862          *  No :: separators--the whole name is treated as a tail.
 863          */
 864         *tail = newname;
 865         *head = NULL;
 866     }
 867 }
 868 \f
 869 /*
 870  * ------------------------------------------------------------------------
 871  *  Itcl_CanAccess2()
 872  *
 873  *  Checks to see if a class member can be accessed from a particular
 874  *  namespace context.  Public things can always be accessed.  Protected
 875  *  things can be accessed if the "from" namespace appears in the
 876  *  inheritance hierarchy of the class namespace.  Private things
 877  *  can be accessed only if the "from" namespace is the same as the
 878  *  class that contains them.
 879  *
 880  *  Returns 1/0 indicating true/false.
 881  * ------------------------------------------------------------------------
 882  */
 883 int
 884 Itcl_CanAccess2(
 885     ItclClass *iclsPtr,        /* class being tested */
 886     int protection,            /* protection level being tested */
 887     Tcl_Namespace* fromNsPtr)  /* namespace requesting access */
 888 {
 889     ItclClass* fromIclsPtr;
 890     Tcl_HashEntry *entry;
 891
 892     /*
 893      *  If the protection level is "public" or "private", then the
 894      *  answer is known immediately.
 895      */
 896     if (protection == ITCL_PUBLIC) {
 897         return 1;
 898     } else {
 899         if (protection == ITCL_PRIVATE) {
 900             entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses,
 901                 fromNsPtr);
 902             if (entry == NULL) {
 903                 return 0;
 904             }
 905             return (iclsPtr == Tcl_GetHashValue(entry));
 906         }
 907     }
 908
 909     /*
 910      *  If the protection level is "protected", then check the
 911      *  heritage of the namespace requesting access.  If cdefnPtr
 912      *  is in the heritage, then access is allowed.
 913      */
 914     assert (protection == ITCL_PROTECTED);
 915
 916     if (Itcl_IsClassNamespace(fromNsPtr)) {
 917         entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses,
 918                 fromNsPtr);
 919         if (entry == NULL) {
 920             return 0;
 921         }
 922         fromIclsPtr = (ItclClass *)Tcl_GetHashValue(entry);
 923
 924         entry = Tcl_FindHashEntry(&fromIclsPtr->heritage,
 925                 (char*)iclsPtr);
 926
 927         if (entry) {
 928             return 1;
 929         }
 930     }
 931     return 0;
 932 }
 933 \f
 934 /*
 935  * ------------------------------------------------------------------------
 936  *  Itcl_CanAccess()
 937  *
 938  *  Checks to see if a class member can be accessed from a particular
 939  *  namespace context.  Public things can always be accessed.  Protected
 940  *  things can be accessed if the "from" namespace appears in the
 941  *  inheritance hierarchy of the class namespace.  Private things
 942  *  can be accessed only if the "from" namespace is the same as the
 943  *  class that contains them.
 944  *
 945  *  Returns 1/0 indicating true/false.
 946  * ------------------------------------------------------------------------
 947  */
 948 int
 949 Itcl_CanAccess(
 950     ItclMemberFunc* imPtr,     /* class member being tested */
 951     Tcl_Namespace* fromNsPtr)  /* namespace requesting access */
 952 {
 953     return Itcl_CanAccess2(imPtr->iclsPtr, imPtr->protection, fromNsPtr);
 954 }
 955
 956 \f
 957 /*
 958  * ------------------------------------------------------------------------
 959  *  Itcl_CanAccessFunc()
 960  *
 961  *  Checks to see if a member function with the specified protection
 962  *  level can be accessed from a particular namespace context.  This
 963  *  follows the same rules enforced by Itcl_CanAccess, but adds one
 964  *  special case:  If the function is a protected method, and if the
 965  *  current context is a base class that has the same method, then
 966  *  access is allowed.
 967  *
 968  *  Returns 1/0 indicating true/false.
 969  * ------------------------------------------------------------------------
 970  */
 971 int
 972 Itcl_CanAccessFunc(
 973     ItclMemberFunc* imPtr,     /* member function being tested */
 974     Tcl_Namespace* fromNsPtr)  /* namespace requesting access */
 975 {
 976     ItclClass *iclsPtr;
 977     ItclClass *fromIclsPtr;
 978     ItclMemberFunc *ovlfunc;
 979     Tcl_HashEntry *entry;
 980
 981     /*
 982      *  Apply the usual rules first.
 983      */
 984     if (Itcl_CanAccess(imPtr, fromNsPtr)) {
 985         return 1;
 986     }
 987
 988     /*
 989      *  As a last resort, see if the namespace is really a base
 990      *  class of the class containing the method.  Look for a
 991      *  method with the same name in the base class.  If there
 992      *  is one, then this method overrides it, and the base class
 993      *  has access.
 994      */
 995     if ((imPtr->flags & ITCL_COMMON) == 0 &&
 996             Itcl_IsClassNamespace(fromNsPtr)) {
 997         Tcl_HashEntry *hPtr;
 998
 999         iclsPtr = imPtr->iclsPtr;
1000         hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses,
1001                 (char *)fromNsPtr);
1002         if (hPtr == NULL) {
1003             return 0;
1004         }
1005         fromIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
1006
1007         if (Tcl_FindHashEntry(&iclsPtr->heritage, (char*)fromIclsPtr)) {
1008             entry = Tcl_FindHashEntry(&fromIclsPtr->resolveCmds,
1009                 (char *)imPtr->namePtr);
1010
1011             if (entry) {
1012                 ItclCmdLookup *clookup;
1013                 clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
1014                 ovlfunc = clookup->imPtr;
1015                 if ((ovlfunc->flags & ITCL_COMMON) == 0 &&
1016                      ovlfunc->protection < ITCL_PRIVATE) {
1017                     return 1;
1018                 }
1019             }
1020         }
1021     }
1022     return 0;
1023 }
1024
1025 \f
1026 /*
1027  * ------------------------------------------------------------------------
1028  *  Itcl_DecodeScopedCommand()
1029  *
1030  *  Decodes a scoped command of the form:
1031  *
1032  *      namespace inscope <namesp> <command>
1033  *
1034  *  If the given string is not a scoped value, this procedure does
1035  *  nothing and returns TCL_OK.  If the string is a scoped value,
1036  *  then it is decoded, and the namespace, and the simple command
1037  *  string are returned as arguments; the simple command should
1038  *  be freed when no longer in use.  If anything goes wrong, this
1039  *  procedure returns TCL_ERROR, along with an error message in
1040  *  the interpreter.
1041  * ------------------------------------------------------------------------
1042  */
1043 int
1044 Itcl_DecodeScopedCommand(
1045     Tcl_Interp *interp,         /* current interpreter */
1046     const char *name,           /* string to be decoded */
1047     Tcl_Namespace **rNsPtr,     /* returns: namespace for scoped value */
1048     char **rCmdPtr)             /* returns: simple command word */
1049 {
1050     Tcl_Namespace *nsPtr;
1051     char *cmdName;
1052     const char *pos;
1053     const char **listv;
1054     int listc;
1055     int result;
1056     int len;
1057
1058     nsPtr = NULL;
1059     len = strlen(name);
1060     cmdName = (char *)ckalloc(strlen(name)+1);
1061     strcpy(cmdName, name);
1062
1063     if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
1064         for (pos = (name + 9);  (*pos == ' ');  pos++) {
1065             /* empty body: skip over spaces */
1066         }
1067         if ((*pos == 'i') && ((pos + 7) <= (name + len))
1068                 && (strncmp(pos, "inscope", 7) == 0)) {
1069
1070             result = Tcl_SplitList(interp, (const char *)name, &listc,
1071                     &listv);
1072             if (result == TCL_OK) {
1073                 if (listc != 4) {
1074                     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1075                         "malformed command \"", name, "\": should be \"",
1076                         "namespace inscope namesp command\"",
1077                         NULL);
1078                     result = TCL_ERROR;
1079                 } else {
1080                     nsPtr = Tcl_FindNamespace(interp, listv[2],
1081                         NULL, TCL_LEAVE_ERR_MSG);
1082
1083                     if (nsPtr == NULL) {
1084                         result = TCL_ERROR;
1085                     } else {
1086                         ckfree(cmdName);
1087                         cmdName = (char *)ckalloc(strlen(listv[3])+1);
1088                         strcpy(cmdName, listv[3]);
1089                     }
1090                 }
1091             }
1092             ckfree((char*)listv);
1093
1094             if (result != TCL_OK) {
1095                 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1096                         "\n    (while decoding scoped command \"%s\")",
1097                         name));
1098                 ckfree(cmdName);
1099                 return TCL_ERROR;
1100             }
1101         }
1102     }
1103
1104     *rNsPtr = nsPtr;
1105     *rCmdPtr = cmdName;
1106     return TCL_OK;
1107 }