/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* PACKAGE: [incr Tcl]
|
* PACKAGE: [incr Tcl]
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
*
|
*
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* C++ provides object-oriented extensions to C. It provides a means
|
* C++ provides object-oriented extensions to C. It provides a means
|
* of encapsulating related procedures together with their shared data
|
* of encapsulating related procedures together with their shared data
|
* in a local namespace that is hidden from the outside world. It
|
* in a local namespace that is hidden from the outside world. It
|
* promotes code re-use through inheritance. More than anything else,
|
* promotes code re-use through inheritance. More than anything else,
|
* it encourages better organization of Tcl applications through the
|
* it encourages better organization of Tcl applications through the
|
* object-oriented paradigm, leading to code that is easier to
|
* object-oriented paradigm, leading to code that is easier to
|
* understand and maintain.
|
* understand and maintain.
|
*
|
*
|
* This segment provides common utility functions used throughout
|
* This segment provides common utility functions used throughout
|
* the other [incr Tcl] source files.
|
* the other [incr Tcl] source files.
|
*
|
*
|
* ========================================================================
|
* ========================================================================
|
* AUTHOR: Michael J. McLennan
|
* AUTHOR: Michael J. McLennan
|
* Bell Labs Innovations for Lucent Technologies
|
* Bell Labs Innovations for Lucent Technologies
|
* mmclennan@lucent.com
|
* mmclennan@lucent.com
|
* http://www.tcltk.com/itcl
|
* http://www.tcltk.com/itcl
|
*
|
*
|
* RCS: $Id: itcl_util.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_util.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* ========================================================================
|
* ========================================================================
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*/
|
*/
|
#include "itclInt.h"
|
#include "itclInt.h"
|
#include "tclCompile.h"
|
#include "tclCompile.h"
|
|
|
/*
|
/*
|
* POOL OF LIST ELEMENTS FOR LINKED LIST
|
* POOL OF LIST ELEMENTS FOR LINKED LIST
|
*/
|
*/
|
static Itcl_ListElem *listPool = NULL;
|
static Itcl_ListElem *listPool = NULL;
|
static int listPoolLen = 0;
|
static int listPoolLen = 0;
|
|
|
#define ITCL_VALID_LIST 0x01face10 /* magic bit pattern for validation */
|
#define ITCL_VALID_LIST 0x01face10 /* magic bit pattern for validation */
|
#define ITCL_LIST_POOL_SIZE 200 /* max number of elements in listPool */
|
#define ITCL_LIST_POOL_SIZE 200 /* max number of elements in listPool */
|
|
|
|
|
/*
|
/*
|
* These records are used to keep track of reference-counted data
|
* These records are used to keep track of reference-counted data
|
* for Itcl_PreserveData and Itcl_ReleaseData.
|
* for Itcl_PreserveData and Itcl_ReleaseData.
|
*/
|
*/
|
typedef struct ItclPreservedData {
|
typedef struct ItclPreservedData {
|
ClientData data; /* reference to data */
|
ClientData data; /* reference to data */
|
int usage; /* number of active uses */
|
int usage; /* number of active uses */
|
Tcl_FreeProc *fproc; /* procedure used to free data */
|
Tcl_FreeProc *fproc; /* procedure used to free data */
|
} ItclPreservedData;
|
} ItclPreservedData;
|
|
|
static Tcl_HashTable *ItclPreservedList = NULL;
|
static Tcl_HashTable *ItclPreservedList = NULL;
|
|
|
|
|
/*
|
/*
|
* This structure is used to take a snapshot of the interpreter
|
* This structure is used to take a snapshot of the interpreter
|
* state in Itcl_SaveInterpState. You can snapshot the state,
|
* state in Itcl_SaveInterpState. You can snapshot the state,
|
* execute a command, and then back up to the result or the
|
* execute a command, and then back up to the result or the
|
* error that was previously in progress.
|
* error that was previously in progress.
|
*/
|
*/
|
typedef struct InterpState {
|
typedef struct InterpState {
|
int validate; /* validation stamp */
|
int validate; /* validation stamp */
|
int status; /* return code status */
|
int status; /* return code status */
|
Tcl_Obj *objResult; /* result object */
|
Tcl_Obj *objResult; /* result object */
|
char *errorInfo; /* contents of errorInfo variable */
|
char *errorInfo; /* contents of errorInfo variable */
|
char *errorCode; /* contents of errorCode variable */
|
char *errorCode; /* contents of errorCode variable */
|
} InterpState;
|
} InterpState;
|
|
|
#define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */
|
#define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */
|
|
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_Assert()
|
* Itcl_Assert()
|
*
|
*
|
* Called whenever an assert() test fails. Prints a diagnostic
|
* Called whenever an assert() test fails. Prints a diagnostic
|
* message and abruptly exits.
|
* message and abruptly exits.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
#ifndef NDEBUG
|
#ifndef NDEBUG
|
|
|
void
|
void
|
Itcl_Assert(testExpr, fileName, lineNumber)
|
Itcl_Assert(testExpr, fileName, lineNumber)
|
char *testExpr; /* string representing test expression */
|
char *testExpr; /* string representing test expression */
|
char *fileName; /* file name containing this call */
|
char *fileName; /* file name containing this call */
|
int lineNumber; /* line number containing this call */
|
int lineNumber; /* line number containing this call */
|
{
|
{
|
fprintf(stderr, "Assertion failed: \"%s\" (line %d of %s)",
|
fprintf(stderr, "Assertion failed: \"%s\" (line %d of %s)",
|
testExpr, lineNumber, fileName);
|
testExpr, lineNumber, fileName);
|
abort();
|
abort();
|
}
|
}
|
|
|
#endif
|
#endif
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InitStack()
|
* Itcl_InitStack()
|
*
|
*
|
* Initializes a stack structure, allocating a certain amount of memory
|
* Initializes a stack structure, allocating a certain amount of memory
|
* for the stack and setting the stack length to zero.
|
* for the stack and setting the stack length to zero.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_InitStack(stack)
|
Itcl_InitStack(stack)
|
Itcl_Stack *stack; /* stack to be initialized */
|
Itcl_Stack *stack; /* stack to be initialized */
|
{
|
{
|
stack->values = stack->space;
|
stack->values = stack->space;
|
stack->max = sizeof(stack->space)/sizeof(ClientData);
|
stack->max = sizeof(stack->space)/sizeof(ClientData);
|
stack->len = 0;
|
stack->len = 0;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteStack()
|
* Itcl_DeleteStack()
|
*
|
*
|
* Destroys a stack structure, freeing any memory that may have been
|
* Destroys a stack structure, freeing any memory that may have been
|
* allocated to represent it.
|
* allocated to represent it.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteStack(stack)
|
Itcl_DeleteStack(stack)
|
Itcl_Stack *stack; /* stack to be deleted */
|
Itcl_Stack *stack; /* stack to be deleted */
|
{
|
{
|
/*
|
/*
|
* If memory was explicitly allocated (instead of using the
|
* If memory was explicitly allocated (instead of using the
|
* built-in buffer) then free it.
|
* built-in buffer) then free it.
|
*/
|
*/
|
if (stack->values != stack->space) {
|
if (stack->values != stack->space) {
|
ckfree((char*)stack->values);
|
ckfree((char*)stack->values);
|
}
|
}
|
stack->values = NULL;
|
stack->values = NULL;
|
stack->len = stack->max = 0;
|
stack->len = stack->max = 0;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_PushStack()
|
* Itcl_PushStack()
|
*
|
*
|
* Pushes a piece of client data onto the top of the given stack.
|
* Pushes a piece of client data onto the top of the given stack.
|
* If the stack is not large enough, it is automatically resized.
|
* If the stack is not large enough, it is automatically resized.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_PushStack(cdata,stack)
|
Itcl_PushStack(cdata,stack)
|
ClientData cdata; /* data to be pushed onto stack */
|
ClientData cdata; /* data to be pushed onto stack */
|
Itcl_Stack *stack; /* stack */
|
Itcl_Stack *stack; /* stack */
|
{
|
{
|
ClientData *newStack;
|
ClientData *newStack;
|
|
|
if (stack->len+1 >= stack->max) {
|
if (stack->len+1 >= stack->max) {
|
stack->max = 2*stack->max;
|
stack->max = 2*stack->max;
|
newStack = (ClientData*)
|
newStack = (ClientData*)
|
ckalloc((unsigned)(stack->max*sizeof(ClientData)));
|
ckalloc((unsigned)(stack->max*sizeof(ClientData)));
|
|
|
if (stack->values) {
|
if (stack->values) {
|
memcpy((char*)newStack, (char*)stack->values,
|
memcpy((char*)newStack, (char*)stack->values,
|
(size_t)(stack->len*sizeof(ClientData)));
|
(size_t)(stack->len*sizeof(ClientData)));
|
|
|
if (stack->values != stack->space)
|
if (stack->values != stack->space)
|
ckfree((char*)stack->values);
|
ckfree((char*)stack->values);
|
}
|
}
|
stack->values = newStack;
|
stack->values = newStack;
|
}
|
}
|
stack->values[stack->len++] = cdata;
|
stack->values[stack->len++] = cdata;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_PopStack()
|
* Itcl_PopStack()
|
*
|
*
|
* Pops a bit of client data from the top of the given stack.
|
* Pops a bit of client data from the top of the given stack.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
ClientData
|
ClientData
|
Itcl_PopStack(stack)
|
Itcl_PopStack(stack)
|
Itcl_Stack *stack; /* stack to be manipulated */
|
Itcl_Stack *stack; /* stack to be manipulated */
|
{
|
{
|
if (stack->values && (stack->len > 0)) {
|
if (stack->values && (stack->len > 0)) {
|
stack->len--;
|
stack->len--;
|
return stack->values[stack->len];
|
return stack->values[stack->len];
|
}
|
}
|
return (ClientData)NULL;
|
return (ClientData)NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_PeekStack()
|
* Itcl_PeekStack()
|
*
|
*
|
* Gets the current value from the top of the given stack.
|
* Gets the current value from the top of the given stack.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
ClientData
|
ClientData
|
Itcl_PeekStack(stack)
|
Itcl_PeekStack(stack)
|
Itcl_Stack *stack; /* stack to be examined */
|
Itcl_Stack *stack; /* stack to be examined */
|
{
|
{
|
if (stack->values && (stack->len > 0)) {
|
if (stack->values && (stack->len > 0)) {
|
return stack->values[stack->len-1];
|
return stack->values[stack->len-1];
|
}
|
}
|
return (ClientData)NULL;
|
return (ClientData)NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_GetStackValue()
|
* Itcl_GetStackValue()
|
*
|
*
|
* Gets a value at some index within the stack. Index "0" is the
|
* Gets a value at some index within the stack. Index "0" is the
|
* first value pushed onto the stack.
|
* first value pushed onto the stack.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
ClientData
|
ClientData
|
Itcl_GetStackValue(stack,pos)
|
Itcl_GetStackValue(stack,pos)
|
Itcl_Stack *stack; /* stack to be examined */
|
Itcl_Stack *stack; /* stack to be examined */
|
int pos; /* get value at this index */
|
int pos; /* get value at this index */
|
{
|
{
|
if (stack->values && (stack->len > 0)) {
|
if (stack->values && (stack->len > 0)) {
|
assert(pos < stack->len);
|
assert(pos < stack->len);
|
return stack->values[pos];
|
return stack->values[pos];
|
}
|
}
|
return (ClientData)NULL;
|
return (ClientData)NULL;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InitList()
|
* Itcl_InitList()
|
*
|
*
|
* Initializes a linked list structure, setting the list to the empty
|
* Initializes a linked list structure, setting the list to the empty
|
* state.
|
* state.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_InitList(listPtr)
|
Itcl_InitList(listPtr)
|
Itcl_List *listPtr; /* list to be initialized */
|
Itcl_List *listPtr; /* list to be initialized */
|
{
|
{
|
listPtr->validate = ITCL_VALID_LIST;
|
listPtr->validate = ITCL_VALID_LIST;
|
listPtr->num = 0;
|
listPtr->num = 0;
|
listPtr->head = NULL;
|
listPtr->head = NULL;
|
listPtr->tail = NULL;
|
listPtr->tail = NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteList()
|
* Itcl_DeleteList()
|
*
|
*
|
* Destroys a linked list structure, deleting all of its elements and
|
* Destroys a linked list structure, deleting all of its elements and
|
* setting it to an empty state. If the elements have memory associated
|
* setting it to an empty state. If the elements have memory associated
|
* with them, this memory must be freed before deleting the list or it
|
* with them, this memory must be freed before deleting the list or it
|
* will be lost.
|
* will be lost.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteList(listPtr)
|
Itcl_DeleteList(listPtr)
|
Itcl_List *listPtr; /* list to be deleted */
|
Itcl_List *listPtr; /* list to be deleted */
|
{
|
{
|
Itcl_ListElem *elemPtr;
|
Itcl_ListElem *elemPtr;
|
|
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
|
|
elemPtr = listPtr->head;
|
elemPtr = listPtr->head;
|
while (elemPtr) {
|
while (elemPtr) {
|
elemPtr = Itcl_DeleteListElem(elemPtr);
|
elemPtr = Itcl_DeleteListElem(elemPtr);
|
}
|
}
|
listPtr->validate = 0;
|
listPtr->validate = 0;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateListElem()
|
* Itcl_CreateListElem()
|
*
|
*
|
* Low-level routined used by procedures like Itcl_InsertList() and
|
* Low-level routined used by procedures like Itcl_InsertList() and
|
* Itcl_AppendList() to create new list elements. If elements are
|
* Itcl_AppendList() to create new list elements. If elements are
|
* available, one is taken from the list element pool. Otherwise,
|
* available, one is taken from the list element pool. Otherwise,
|
* a new one is allocated.
|
* a new one is allocated.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_ListElem*
|
Itcl_ListElem*
|
Itcl_CreateListElem(listPtr)
|
Itcl_CreateListElem(listPtr)
|
Itcl_List *listPtr; /* list that will contain this new element */
|
Itcl_List *listPtr; /* list that will contain this new element */
|
{
|
{
|
Itcl_ListElem *elemPtr;
|
Itcl_ListElem *elemPtr;
|
|
|
if (listPoolLen > 0) {
|
if (listPoolLen > 0) {
|
elemPtr = listPool;
|
elemPtr = listPool;
|
listPool = elemPtr->next;
|
listPool = elemPtr->next;
|
--listPoolLen;
|
--listPoolLen;
|
}
|
}
|
else {
|
else {
|
elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem));
|
elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem));
|
}
|
}
|
elemPtr->owner = listPtr;
|
elemPtr->owner = listPtr;
|
elemPtr->value = NULL;
|
elemPtr->value = NULL;
|
elemPtr->next = NULL;
|
elemPtr->next = NULL;
|
elemPtr->prev = NULL;
|
elemPtr->prev = NULL;
|
|
|
return elemPtr;
|
return elemPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteListElem()
|
* Itcl_DeleteListElem()
|
*
|
*
|
* Destroys a single element in a linked list, returning it to a pool of
|
* Destroys a single element in a linked list, returning it to a pool of
|
* elements that can be later reused. Returns a pointer to the next
|
* elements that can be later reused. Returns a pointer to the next
|
* element in the list.
|
* element in the list.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_ListElem*
|
Itcl_ListElem*
|
Itcl_DeleteListElem(elemPtr)
|
Itcl_DeleteListElem(elemPtr)
|
Itcl_ListElem *elemPtr; /* list element to be deleted */
|
Itcl_ListElem *elemPtr; /* list element to be deleted */
|
{
|
{
|
Itcl_List *listPtr;
|
Itcl_List *listPtr;
|
Itcl_ListElem *nextPtr;
|
Itcl_ListElem *nextPtr;
|
|
|
nextPtr = elemPtr->next;
|
nextPtr = elemPtr->next;
|
|
|
if (elemPtr->prev) {
|
if (elemPtr->prev) {
|
elemPtr->prev->next = elemPtr->next;
|
elemPtr->prev->next = elemPtr->next;
|
}
|
}
|
if (elemPtr->next) {
|
if (elemPtr->next) {
|
elemPtr->next->prev = elemPtr->prev;
|
elemPtr->next->prev = elemPtr->prev;
|
}
|
}
|
|
|
listPtr = elemPtr->owner;
|
listPtr = elemPtr->owner;
|
if (elemPtr == listPtr->head)
|
if (elemPtr == listPtr->head)
|
listPtr->head = elemPtr->next;
|
listPtr->head = elemPtr->next;
|
if (elemPtr == listPtr->tail)
|
if (elemPtr == listPtr->tail)
|
listPtr->tail = elemPtr->prev;
|
listPtr->tail = elemPtr->prev;
|
--listPtr->num;
|
--listPtr->num;
|
|
|
if (listPoolLen < ITCL_LIST_POOL_SIZE) {
|
if (listPoolLen < ITCL_LIST_POOL_SIZE) {
|
elemPtr->next = listPool;
|
elemPtr->next = listPool;
|
listPool = elemPtr;
|
listPool = elemPtr;
|
++listPoolLen;
|
++listPoolLen;
|
}
|
}
|
else {
|
else {
|
ckfree((char*)elemPtr);
|
ckfree((char*)elemPtr);
|
}
|
}
|
return nextPtr;
|
return nextPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InsertList()
|
* Itcl_InsertList()
|
*
|
*
|
* Creates a new list element containing the given value and returns
|
* Creates a new list element containing the given value and returns
|
* a pointer to it. The element is inserted at the beginning of the
|
* a pointer to it. The element is inserted at the beginning of the
|
* specified list.
|
* specified list.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_ListElem*
|
Itcl_ListElem*
|
Itcl_InsertList(listPtr,val)
|
Itcl_InsertList(listPtr,val)
|
Itcl_List *listPtr; /* list being modified */
|
Itcl_List *listPtr; /* list being modified */
|
ClientData val; /* value associated with new element */
|
ClientData val; /* value associated with new element */
|
{
|
{
|
Itcl_ListElem *elemPtr;
|
Itcl_ListElem *elemPtr;
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
|
|
elemPtr = Itcl_CreateListElem(listPtr);
|
elemPtr = Itcl_CreateListElem(listPtr);
|
|
|
elemPtr->value = val;
|
elemPtr->value = val;
|
elemPtr->next = listPtr->head;
|
elemPtr->next = listPtr->head;
|
elemPtr->prev = NULL;
|
elemPtr->prev = NULL;
|
if (listPtr->head) {
|
if (listPtr->head) {
|
listPtr->head->prev = elemPtr;
|
listPtr->head->prev = elemPtr;
|
}
|
}
|
listPtr->head = elemPtr;
|
listPtr->head = elemPtr;
|
if (listPtr->tail == NULL) {
|
if (listPtr->tail == NULL) {
|
listPtr->tail = elemPtr;
|
listPtr->tail = elemPtr;
|
}
|
}
|
++listPtr->num;
|
++listPtr->num;
|
|
|
return elemPtr;
|
return elemPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InsertListElem()
|
* Itcl_InsertListElem()
|
*
|
*
|
* Creates a new list element containing the given value and returns
|
* Creates a new list element containing the given value and returns
|
* a pointer to it. The element is inserted in the list just before
|
* a pointer to it. The element is inserted in the list just before
|
* the specified element.
|
* the specified element.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_ListElem*
|
Itcl_ListElem*
|
Itcl_InsertListElem(pos,val)
|
Itcl_InsertListElem(pos,val)
|
Itcl_ListElem *pos; /* insert just before this element */
|
Itcl_ListElem *pos; /* insert just before this element */
|
ClientData val; /* value associated with new element */
|
ClientData val; /* value associated with new element */
|
{
|
{
|
Itcl_List *listPtr;
|
Itcl_List *listPtr;
|
Itcl_ListElem *elemPtr;
|
Itcl_ListElem *elemPtr;
|
|
|
listPtr = pos->owner;
|
listPtr = pos->owner;
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(pos != NULL);
|
assert(pos != NULL);
|
|
|
elemPtr = Itcl_CreateListElem(listPtr);
|
elemPtr = Itcl_CreateListElem(listPtr);
|
elemPtr->value = val;
|
elemPtr->value = val;
|
|
|
elemPtr->prev = pos->prev;
|
elemPtr->prev = pos->prev;
|
if (elemPtr->prev) {
|
if (elemPtr->prev) {
|
elemPtr->prev->next = elemPtr;
|
elemPtr->prev->next = elemPtr;
|
}
|
}
|
elemPtr->next = pos;
|
elemPtr->next = pos;
|
pos->prev = elemPtr;
|
pos->prev = elemPtr;
|
|
|
if (listPtr->head == pos) {
|
if (listPtr->head == pos) {
|
listPtr->head = elemPtr;
|
listPtr->head = elemPtr;
|
}
|
}
|
if (listPtr->tail == NULL) {
|
if (listPtr->tail == NULL) {
|
listPtr->tail = elemPtr;
|
listPtr->tail = elemPtr;
|
}
|
}
|
++listPtr->num;
|
++listPtr->num;
|
|
|
return elemPtr;
|
return elemPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_AppendList()
|
* Itcl_AppendList()
|
*
|
*
|
* Creates a new list element containing the given value and returns
|
* Creates a new list element containing the given value and returns
|
* a pointer to it. The element is appended at the end of the
|
* a pointer to it. The element is appended at the end of the
|
* specified list.
|
* specified list.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_ListElem*
|
Itcl_ListElem*
|
Itcl_AppendList(listPtr,val)
|
Itcl_AppendList(listPtr,val)
|
Itcl_List *listPtr; /* list being modified */
|
Itcl_List *listPtr; /* list being modified */
|
ClientData val; /* value associated with new element */
|
ClientData val; /* value associated with new element */
|
{
|
{
|
Itcl_ListElem *elemPtr;
|
Itcl_ListElem *elemPtr;
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
|
|
elemPtr = Itcl_CreateListElem(listPtr);
|
elemPtr = Itcl_CreateListElem(listPtr);
|
|
|
elemPtr->value = val;
|
elemPtr->value = val;
|
elemPtr->prev = listPtr->tail;
|
elemPtr->prev = listPtr->tail;
|
elemPtr->next = NULL;
|
elemPtr->next = NULL;
|
if (listPtr->tail) {
|
if (listPtr->tail) {
|
listPtr->tail->next = elemPtr;
|
listPtr->tail->next = elemPtr;
|
}
|
}
|
listPtr->tail = elemPtr;
|
listPtr->tail = elemPtr;
|
if (listPtr->head == NULL) {
|
if (listPtr->head == NULL) {
|
listPtr->head = elemPtr;
|
listPtr->head = elemPtr;
|
}
|
}
|
++listPtr->num;
|
++listPtr->num;
|
|
|
return elemPtr;
|
return elemPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_AppendListElem()
|
* Itcl_AppendListElem()
|
*
|
*
|
* Creates a new list element containing the given value and returns
|
* Creates a new list element containing the given value and returns
|
* a pointer to it. The element is inserted in the list just after
|
* a pointer to it. The element is inserted in the list just after
|
* the specified element.
|
* the specified element.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_ListElem*
|
Itcl_ListElem*
|
Itcl_AppendListElem(pos,val)
|
Itcl_AppendListElem(pos,val)
|
Itcl_ListElem *pos; /* insert just after this element */
|
Itcl_ListElem *pos; /* insert just after this element */
|
ClientData val; /* value associated with new element */
|
ClientData val; /* value associated with new element */
|
{
|
{
|
Itcl_List *listPtr;
|
Itcl_List *listPtr;
|
Itcl_ListElem *elemPtr;
|
Itcl_ListElem *elemPtr;
|
|
|
listPtr = pos->owner;
|
listPtr = pos->owner;
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(pos != NULL);
|
assert(pos != NULL);
|
|
|
elemPtr = Itcl_CreateListElem(listPtr);
|
elemPtr = Itcl_CreateListElem(listPtr);
|
elemPtr->value = val;
|
elemPtr->value = val;
|
|
|
elemPtr->next = pos->next;
|
elemPtr->next = pos->next;
|
if (elemPtr->next) {
|
if (elemPtr->next) {
|
elemPtr->next->prev = elemPtr;
|
elemPtr->next->prev = elemPtr;
|
}
|
}
|
elemPtr->prev = pos;
|
elemPtr->prev = pos;
|
pos->next = elemPtr;
|
pos->next = elemPtr;
|
|
|
if (listPtr->tail == pos) {
|
if (listPtr->tail == pos) {
|
listPtr->tail = elemPtr;
|
listPtr->tail = elemPtr;
|
}
|
}
|
if (listPtr->head == NULL) {
|
if (listPtr->head == NULL) {
|
listPtr->head = elemPtr;
|
listPtr->head = elemPtr;
|
}
|
}
|
++listPtr->num;
|
++listPtr->num;
|
|
|
return elemPtr;
|
return elemPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_SetListValue()
|
* Itcl_SetListValue()
|
*
|
*
|
* Modifies the value associated with a list element.
|
* Modifies the value associated with a list element.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_SetListValue(elemPtr,val)
|
Itcl_SetListValue(elemPtr,val)
|
Itcl_ListElem *elemPtr; /* list element being modified */
|
Itcl_ListElem *elemPtr; /* list element being modified */
|
ClientData val; /* new value associated with element */
|
ClientData val; /* new value associated with element */
|
{
|
{
|
Itcl_List *listPtr = elemPtr->owner;
|
Itcl_List *listPtr = elemPtr->owner;
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(listPtr->validate == ITCL_VALID_LIST);
|
assert(elemPtr != NULL);
|
assert(elemPtr != NULL);
|
|
|
elemPtr->value = val;
|
elemPtr->value = val;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ========================================================================
|
* ========================================================================
|
* REFERENCE-COUNTED DATA
|
* REFERENCE-COUNTED DATA
|
*
|
*
|
* The following procedures manage generic reference-counted data.
|
* The following procedures manage generic reference-counted data.
|
* They are similar in spirit to the Tcl_Preserve/Tcl_Release
|
* They are similar in spirit to the Tcl_Preserve/Tcl_Release
|
* procedures defined in the Tcl/Tk core. But these procedures use
|
* procedures defined in the Tcl/Tk core. But these procedures use
|
* a hash table instead of a linked list to maintain the references,
|
* a hash table instead of a linked list to maintain the references,
|
* so they scale better. Also, the Tcl procedures have a bad behavior
|
* so they scale better. Also, the Tcl procedures have a bad behavior
|
* during the "exit" command. Their exit handler shuts them down
|
* during the "exit" command. Their exit handler shuts them down
|
* when other data is still being reference-counted and cleaned up.
|
* when other data is still being reference-counted and cleaned up.
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_EventuallyFree()
|
* Itcl_EventuallyFree()
|
*
|
*
|
* Registers a piece of data so that it will be freed when no longer
|
* Registers a piece of data so that it will be freed when no longer
|
* in use. The data is registered with an initial usage count of "0".
|
* in use. The data is registered with an initial usage count of "0".
|
* Future calls to Itcl_PreserveData() increase this usage count, and
|
* Future calls to Itcl_PreserveData() increase this usage count, and
|
* calls to Itcl_ReleaseData() decrease the count until it reaches
|
* calls to Itcl_ReleaseData() decrease the count until it reaches
|
* zero and the data is freed.
|
* zero and the data is freed.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_EventuallyFree(cdata, fproc)
|
Itcl_EventuallyFree(cdata, fproc)
|
ClientData cdata; /* data to be freed when not in use */
|
ClientData cdata; /* data to be freed when not in use */
|
Tcl_FreeProc *fproc; /* procedure called to free data */
|
Tcl_FreeProc *fproc; /* procedure called to free data */
|
{
|
{
|
int newEntry;
|
int newEntry;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclPreservedData *chunk;
|
ItclPreservedData *chunk;
|
|
|
/*
|
/*
|
* If the clientData value is NULL, do nothing.
|
* If the clientData value is NULL, do nothing.
|
*/
|
*/
|
if (cdata == NULL) {
|
if (cdata == NULL) {
|
return;
|
return;
|
}
|
}
|
|
|
/*
|
/*
|
* If a list has not yet been created to manage bits of
|
* If a list has not yet been created to manage bits of
|
* preserved data, then create it.
|
* preserved data, then create it.
|
*/
|
*/
|
if (!ItclPreservedList) {
|
if (!ItclPreservedList) {
|
ItclPreservedList = (Tcl_HashTable*)ckalloc(
|
ItclPreservedList = (Tcl_HashTable*)ckalloc(
|
(unsigned)sizeof(Tcl_HashTable)
|
(unsigned)sizeof(Tcl_HashTable)
|
);
|
);
|
Tcl_InitHashTable(ItclPreservedList, TCL_ONE_WORD_KEYS);
|
Tcl_InitHashTable(ItclPreservedList, TCL_ONE_WORD_KEYS);
|
}
|
}
|
|
|
/*
|
/*
|
* Find or create the data in the global list.
|
* Find or create the data in the global list.
|
*/
|
*/
|
entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
|
entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
|
if (newEntry) {
|
if (newEntry) {
|
chunk = (ItclPreservedData*)ckalloc(
|
chunk = (ItclPreservedData*)ckalloc(
|
(unsigned)sizeof(ItclPreservedData)
|
(unsigned)sizeof(ItclPreservedData)
|
);
|
);
|
chunk->data = cdata;
|
chunk->data = cdata;
|
chunk->usage = 0;
|
chunk->usage = 0;
|
chunk->fproc = fproc;
|
chunk->fproc = fproc;
|
Tcl_SetHashValue(entry, (ClientData)chunk);
|
Tcl_SetHashValue(entry, (ClientData)chunk);
|
}
|
}
|
else {
|
else {
|
chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
|
chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
|
chunk->fproc = fproc;
|
chunk->fproc = fproc;
|
}
|
}
|
|
|
/*
|
/*
|
* If the usage count is zero, then delete the data now.
|
* If the usage count is zero, then delete the data now.
|
*/
|
*/
|
if (chunk->usage == 0) {
|
if (chunk->usage == 0) {
|
chunk->usage = -1; /* cannot preserve/release anymore */
|
chunk->usage = -1; /* cannot preserve/release anymore */
|
|
|
(*chunk->fproc)((char*)chunk->data);
|
(*chunk->fproc)((char*)chunk->data);
|
Tcl_DeleteHashEntry(entry);
|
Tcl_DeleteHashEntry(entry);
|
ckfree((char*)chunk);
|
ckfree((char*)chunk);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_PreserveData()
|
* Itcl_PreserveData()
|
*
|
*
|
* Increases the usage count for a piece of data that will be freed
|
* Increases the usage count for a piece of data that will be freed
|
* later when no longer needed. Each call to Itcl_PreserveData()
|
* later when no longer needed. Each call to Itcl_PreserveData()
|
* puts one claim on a piece of data, and subsequent calls to
|
* puts one claim on a piece of data, and subsequent calls to
|
* Itcl_ReleaseData() remove those claims. When Itcl_EventuallyFree()
|
* Itcl_ReleaseData() remove those claims. When Itcl_EventuallyFree()
|
* is called, and when the usage count reaches zero, the data is
|
* is called, and when the usage count reaches zero, the data is
|
* freed.
|
* freed.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_PreserveData(cdata)
|
Itcl_PreserveData(cdata)
|
ClientData cdata; /* data to be preserved */
|
ClientData cdata; /* data to be preserved */
|
{
|
{
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclPreservedData *chunk;
|
ItclPreservedData *chunk;
|
int newEntry;
|
int newEntry;
|
|
|
/*
|
/*
|
* If the clientData value is NULL, do nothing.
|
* If the clientData value is NULL, do nothing.
|
*/
|
*/
|
if (cdata == NULL) {
|
if (cdata == NULL) {
|
return;
|
return;
|
}
|
}
|
|
|
/*
|
/*
|
* If a list has not yet been created to manage bits of
|
* If a list has not yet been created to manage bits of
|
* preserved data, then create it.
|
* preserved data, then create it.
|
*/
|
*/
|
if (!ItclPreservedList) {
|
if (!ItclPreservedList) {
|
ItclPreservedList = (Tcl_HashTable*)ckalloc(
|
ItclPreservedList = (Tcl_HashTable*)ckalloc(
|
(unsigned)sizeof(Tcl_HashTable)
|
(unsigned)sizeof(Tcl_HashTable)
|
);
|
);
|
Tcl_InitHashTable(ItclPreservedList,TCL_ONE_WORD_KEYS);
|
Tcl_InitHashTable(ItclPreservedList,TCL_ONE_WORD_KEYS);
|
}
|
}
|
|
|
/*
|
/*
|
* Find the data in the global list and bump its usage count.
|
* Find the data in the global list and bump its usage count.
|
*/
|
*/
|
entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
|
entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
|
if (newEntry) {
|
if (newEntry) {
|
chunk = (ItclPreservedData*)ckalloc(
|
chunk = (ItclPreservedData*)ckalloc(
|
(unsigned)sizeof(ItclPreservedData)
|
(unsigned)sizeof(ItclPreservedData)
|
);
|
);
|
chunk->data = cdata;
|
chunk->data = cdata;
|
chunk->usage = 0;
|
chunk->usage = 0;
|
chunk->fproc = NULL;
|
chunk->fproc = NULL;
|
Tcl_SetHashValue(entry, (ClientData)chunk);
|
Tcl_SetHashValue(entry, (ClientData)chunk);
|
}
|
}
|
else {
|
else {
|
chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
|
chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
|
}
|
}
|
|
|
/*
|
/*
|
* Only increment the usage if it is non-negative.
|
* Only increment the usage if it is non-negative.
|
* Negative numbers mean that the data is in the process
|
* Negative numbers mean that the data is in the process
|
* of being destroyed by Itcl_ReleaseData(), and should
|
* of being destroyed by Itcl_ReleaseData(), and should
|
* not be further preserved.
|
* not be further preserved.
|
*/
|
*/
|
if (chunk->usage >= 0) {
|
if (chunk->usage >= 0) {
|
chunk->usage++;
|
chunk->usage++;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ReleaseData()
|
* Itcl_ReleaseData()
|
*
|
*
|
* Decreases the usage count for a piece of data that was registered
|
* Decreases the usage count for a piece of data that was registered
|
* previously via Itcl_PreserveData(). After Itcl_EventuallyFree()
|
* previously via Itcl_PreserveData(). After Itcl_EventuallyFree()
|
* is called and the usage count reaches zero, the data is
|
* is called and the usage count reaches zero, the data is
|
* automatically freed.
|
* automatically freed.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_ReleaseData(cdata)
|
Itcl_ReleaseData(cdata)
|
ClientData cdata; /* data to be released */
|
ClientData cdata; /* data to be released */
|
{
|
{
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclPreservedData *chunk;
|
ItclPreservedData *chunk;
|
|
|
/*
|
/*
|
* If the clientData value is NULL, do nothing.
|
* If the clientData value is NULL, do nothing.
|
*/
|
*/
|
if (cdata == NULL) {
|
if (cdata == NULL) {
|
return;
|
return;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, find the data in the global list and
|
* Otherwise, find the data in the global list and
|
* decrement its usage count.
|
* decrement its usage count.
|
*/
|
*/
|
entry = NULL;
|
entry = NULL;
|
if (ItclPreservedList) {
|
if (ItclPreservedList) {
|
entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata);
|
entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata);
|
}
|
}
|
if (!entry) {
|
if (!entry) {
|
panic("Itcl_ReleaseData can't find reference for 0x%x", cdata);
|
panic("Itcl_ReleaseData can't find reference for 0x%x", cdata);
|
}
|
}
|
|
|
/*
|
/*
|
* Only decrement the usage if it is non-negative.
|
* Only decrement the usage if it is non-negative.
|
* When the usage reaches zero, set it to a negative number
|
* When the usage reaches zero, set it to a negative number
|
* to indicate that data is being destroyed, and then
|
* to indicate that data is being destroyed, and then
|
* invoke the client delete proc. When the data is deleted,
|
* invoke the client delete proc. When the data is deleted,
|
* remove the entry from the preservation list.
|
* remove the entry from the preservation list.
|
*/
|
*/
|
chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
|
chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
|
if (chunk->usage > 0 && --chunk->usage == 0) {
|
if (chunk->usage > 0 && --chunk->usage == 0) {
|
|
|
if (chunk->fproc) {
|
if (chunk->fproc) {
|
chunk->usage = -1; /* cannot preserve/release anymore */
|
chunk->usage = -1; /* cannot preserve/release anymore */
|
(*chunk->fproc)((char*)chunk->data);
|
(*chunk->fproc)((char*)chunk->data);
|
}
|
}
|
|
|
Tcl_DeleteHashEntry(entry);
|
Tcl_DeleteHashEntry(entry);
|
ckfree((char*)chunk);
|
ckfree((char*)chunk);
|
}
|
}
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_SaveInterpState()
|
* Itcl_SaveInterpState()
|
*
|
*
|
* Takes a snapshot of the current result state of the interpreter.
|
* Takes a snapshot of the current result state of the interpreter.
|
* The snapshot can be restored at any point by Itcl_RestoreInterpState.
|
* The snapshot can be restored at any point by Itcl_RestoreInterpState.
|
* So if you are in the middle of building a return result, you can
|
* So if you are in the middle of building a return result, you can
|
* snapshot the interpreter, execute a command that might generate an
|
* snapshot the interpreter, execute a command that might generate an
|
* error, restore the snapshot, and continue building the result string.
|
* error, restore the snapshot, and continue building the result string.
|
*
|
*
|
* Once a snapshot is saved, it must be restored by calling
|
* Once a snapshot is saved, it must be restored by calling
|
* Itcl_RestoreInterpState, or discarded by calling
|
* Itcl_RestoreInterpState, or discarded by calling
|
* Itcl_DiscardInterpState. Otherwise, memory will be leaked.
|
* Itcl_DiscardInterpState. Otherwise, memory will be leaked.
|
*
|
*
|
* Returns a token representing the state of the interpreter.
|
* Returns a token representing the state of the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Itcl_InterpState
|
Itcl_InterpState
|
Itcl_SaveInterpState(interp, status)
|
Itcl_SaveInterpState(interp, status)
|
Tcl_Interp* interp; /* interpreter being modified */
|
Tcl_Interp* interp; /* interpreter being modified */
|
int status; /* integer status code for current operation */
|
int status; /* integer status code for current operation */
|
{
|
{
|
Interp *iPtr = (Interp*)interp;
|
Interp *iPtr = (Interp*)interp;
|
|
|
InterpState *info;
|
InterpState *info;
|
char *val;
|
char *val;
|
|
|
info = (InterpState*)ckalloc(sizeof(InterpState));
|
info = (InterpState*)ckalloc(sizeof(InterpState));
|
info->validate = TCL_STATE_VALID;
|
info->validate = TCL_STATE_VALID;
|
info->status = status;
|
info->status = status;
|
info->errorInfo = NULL;
|
info->errorInfo = NULL;
|
info->errorCode = NULL;
|
info->errorCode = NULL;
|
|
|
/*
|
/*
|
* Get the result object from the interpreter. This synchronizes
|
* Get the result object from the interpreter. This synchronizes
|
* the old-style result, so we don't have to worry about it.
|
* the old-style result, so we don't have to worry about it.
|
* Keeping the object result is enough.
|
* Keeping the object result is enough.
|
*/
|
*/
|
info->objResult = Tcl_GetObjResult(interp);
|
info->objResult = Tcl_GetObjResult(interp);
|
Tcl_IncrRefCount(info->objResult);
|
Tcl_IncrRefCount(info->objResult);
|
|
|
/*
|
/*
|
* If an error is in progress, preserve its state.
|
* If an error is in progress, preserve its state.
|
*/
|
*/
|
if ((iPtr->flags & ERR_IN_PROGRESS) != 0) {
|
if ((iPtr->flags & ERR_IN_PROGRESS) != 0) {
|
val = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
|
val = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
|
if (val) {
|
if (val) {
|
info->errorInfo = ckalloc((unsigned)(strlen(val)+1));
|
info->errorInfo = ckalloc((unsigned)(strlen(val)+1));
|
strcpy(info->errorInfo, val);
|
strcpy(info->errorInfo, val);
|
}
|
}
|
|
|
val = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
|
val = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
|
if (val) {
|
if (val) {
|
info->errorCode = ckalloc((unsigned)(strlen(val)+1));
|
info->errorCode = ckalloc((unsigned)(strlen(val)+1));
|
strcpy(info->errorCode, val);
|
strcpy(info->errorCode, val);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Now, reset the interpreter to a clean state.
|
* Now, reset the interpreter to a clean state.
|
*/
|
*/
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
return (Itcl_InterpState)info;
|
return (Itcl_InterpState)info;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_RestoreInterpState()
|
* Itcl_RestoreInterpState()
|
*
|
*
|
* Restores the state of the interpreter to a snapshot taken by
|
* Restores the state of the interpreter to a snapshot taken by
|
* Itcl_SaveInterpState. This affects variables such as "errorInfo"
|
* Itcl_SaveInterpState. This affects variables such as "errorInfo"
|
* and "errorCode". After this call, the token for the interpreter
|
* and "errorCode". After this call, the token for the interpreter
|
* state is no longer valid.
|
* state is no longer valid.
|
*
|
*
|
* Returns the status code that was pending at the time the state was
|
* Returns the status code that was pending at the time the state was
|
* captured.
|
* captured.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_RestoreInterpState(interp, state)
|
Itcl_RestoreInterpState(interp, state)
|
Tcl_Interp* interp; /* interpreter being modified */
|
Tcl_Interp* interp; /* interpreter being modified */
|
Itcl_InterpState state; /* token representing interpreter state */
|
Itcl_InterpState state; /* token representing interpreter state */
|
{
|
{
|
Interp *iPtr = (Interp*)interp;
|
Interp *iPtr = (Interp*)interp;
|
InterpState *info = (InterpState*)state;
|
InterpState *info = (InterpState*)state;
|
int status;
|
int status;
|
|
|
if (info->validate != TCL_STATE_VALID) {
|
if (info->validate != TCL_STATE_VALID) {
|
panic("bad token in Itcl_RestoreInterpState");
|
panic("bad token in Itcl_RestoreInterpState");
|
}
|
}
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
/*
|
/*
|
* If an error is in progress, restore its state.
|
* If an error is in progress, restore its state.
|
* Set the error code the hard way--set the variable directly
|
* Set the error code the hard way--set the variable directly
|
* and fix the interpreter flags. Otherwise, if the error code
|
* and fix the interpreter flags. Otherwise, if the error code
|
* string is really a list, it will get wrapped in extra {}'s.
|
* string is really a list, it will get wrapped in extra {}'s.
|
*/
|
*/
|
if (info->errorInfo) {
|
if (info->errorInfo) {
|
Tcl_AddErrorInfo(interp, info->errorInfo);
|
Tcl_AddErrorInfo(interp, info->errorInfo);
|
ckfree(info->errorInfo);
|
ckfree(info->errorInfo);
|
}
|
}
|
|
|
if (info->errorCode) {
|
if (info->errorCode) {
|
(void) Tcl_SetVar2(interp, "errorCode", (char*)NULL,
|
(void) Tcl_SetVar2(interp, "errorCode", (char*)NULL,
|
info->errorCode, TCL_GLOBAL_ONLY);
|
info->errorCode, TCL_GLOBAL_ONLY);
|
iPtr->flags |= ERROR_CODE_SET;
|
iPtr->flags |= ERROR_CODE_SET;
|
|
|
ckfree(info->errorCode);
|
ckfree(info->errorCode);
|
}
|
}
|
|
|
/*
|
/*
|
* Assign the object result back to the interpreter, then
|
* Assign the object result back to the interpreter, then
|
* release our hold on it.
|
* release our hold on it.
|
*/
|
*/
|
Tcl_SetObjResult(interp, info->objResult);
|
Tcl_SetObjResult(interp, info->objResult);
|
Tcl_DecrRefCount(info->objResult);
|
Tcl_DecrRefCount(info->objResult);
|
|
|
status = info->status;
|
status = info->status;
|
info->validate = 0;
|
info->validate = 0;
|
ckfree((char*)info);
|
ckfree((char*)info);
|
|
|
return status;
|
return status;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DiscardInterpState()
|
* Itcl_DiscardInterpState()
|
*
|
*
|
* Frees the memory associated with an interpreter snapshot taken by
|
* Frees the memory associated with an interpreter snapshot taken by
|
* Itcl_SaveInterpState. If the snapshot is not restored, this
|
* Itcl_SaveInterpState. If the snapshot is not restored, this
|
* procedure must be called to discard it, or the memory will be lost.
|
* procedure must be called to discard it, or the memory will be lost.
|
* After this call, the token for the interpreter state is no longer
|
* After this call, the token for the interpreter state is no longer
|
* valid.
|
* valid.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DiscardInterpState(state)
|
Itcl_DiscardInterpState(state)
|
Itcl_InterpState state; /* token representing interpreter state */
|
Itcl_InterpState state; /* token representing interpreter state */
|
{
|
{
|
InterpState *info = (InterpState*)state;
|
InterpState *info = (InterpState*)state;
|
|
|
if (info->validate != TCL_STATE_VALID) {
|
if (info->validate != TCL_STATE_VALID) {
|
panic("bad token in Itcl_DiscardInterpState");
|
panic("bad token in Itcl_DiscardInterpState");
|
}
|
}
|
|
|
if (info->errorInfo) {
|
if (info->errorInfo) {
|
ckfree(info->errorInfo);
|
ckfree(info->errorInfo);
|
}
|
}
|
if (info->errorCode) {
|
if (info->errorCode) {
|
ckfree(info->errorCode);
|
ckfree(info->errorCode);
|
}
|
}
|
Tcl_DecrRefCount(info->objResult);
|
Tcl_DecrRefCount(info->objResult);
|
|
|
info->validate = 0;
|
info->validate = 0;
|
ckfree((char*)info);
|
ckfree((char*)info);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_Protection()
|
* Itcl_Protection()
|
*
|
*
|
* Used to query/set the protection level used when commands/variables
|
* Used to query/set the protection level used when commands/variables
|
* are defined within a class. The default protection level (when
|
* are defined within a class. The default protection level (when
|
* no public/protected/private command is active) is ITCL_DEFAULT_PROTECT.
|
* no public/protected/private command is active) is ITCL_DEFAULT_PROTECT.
|
* In the default case, new commands are treated as public, while new
|
* In the default case, new commands are treated as public, while new
|
* variables are treated as protected.
|
* variables are treated as protected.
|
*
|
*
|
* If the specified level is 0, then this procedure returns the
|
* If the specified level is 0, then this procedure returns the
|
* current value without changing it. Otherwise, it sets the current
|
* current value without changing it. Otherwise, it sets the current
|
* value to the specified protection level, and returns the previous
|
* value to the specified protection level, and returns the previous
|
* value.
|
* value.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_Protection(interp, newLevel)
|
Itcl_Protection(interp, newLevel)
|
Tcl_Interp *interp; /* interpreter being queried */
|
Tcl_Interp *interp; /* interpreter being queried */
|
int newLevel; /* new protection level or 0 */
|
int newLevel; /* new protection level or 0 */
|
{
|
{
|
int oldVal;
|
int oldVal;
|
ItclObjectInfo *info;
|
ItclObjectInfo *info;
|
|
|
/*
|
/*
|
* If a new level was specified, then set the protection level.
|
* If a new level was specified, then set the protection level.
|
* In any case, return the protection level as it stands right now.
|
* In any case, return the protection level as it stands right now.
|
*/
|
*/
|
info = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA,
|
info = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA,
|
(Tcl_InterpDeleteProc**)NULL);
|
(Tcl_InterpDeleteProc**)NULL);
|
|
|
assert(info != NULL);
|
assert(info != NULL);
|
oldVal = info->protection;
|
oldVal = info->protection;
|
|
|
if (newLevel != 0) {
|
if (newLevel != 0) {
|
assert(newLevel == ITCL_PUBLIC ||
|
assert(newLevel == ITCL_PUBLIC ||
|
newLevel == ITCL_PROTECTED ||
|
newLevel == ITCL_PROTECTED ||
|
newLevel == ITCL_PRIVATE ||
|
newLevel == ITCL_PRIVATE ||
|
newLevel == ITCL_DEFAULT_PROTECT);
|
newLevel == ITCL_DEFAULT_PROTECT);
|
info->protection = newLevel;
|
info->protection = newLevel;
|
}
|
}
|
return oldVal;
|
return oldVal;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ProtectionStr()
|
* Itcl_ProtectionStr()
|
*
|
*
|
* Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED,
|
* Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED,
|
* or ITCL_PRIVATE) into a human-readable character string. Returns
|
* or ITCL_PRIVATE) into a human-readable character string. Returns
|
* a pointer to this string.
|
* a pointer to this string.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
char*
|
char*
|
Itcl_ProtectionStr(pLevel)
|
Itcl_ProtectionStr(pLevel)
|
int pLevel; /* protection level */
|
int pLevel; /* protection level */
|
{
|
{
|
switch (pLevel) {
|
switch (pLevel) {
|
case ITCL_PUBLIC:
|
case ITCL_PUBLIC:
|
return "public";
|
return "public";
|
case ITCL_PROTECTED:
|
case ITCL_PROTECTED:
|
return "protected";
|
return "protected";
|
case ITCL_PRIVATE:
|
case ITCL_PRIVATE:
|
return "private";
|
return "private";
|
}
|
}
|
return "<bad-protection-code>";
|
return "<bad-protection-code>";
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CanAccess()
|
* Itcl_CanAccess()
|
*
|
*
|
* Checks to see if a class member can be accessed from a particular
|
* Checks to see if a class member can be accessed from a particular
|
* namespace context. Public things can always be accessed. Protected
|
* namespace context. Public things can always be accessed. Protected
|
* things can be accessed if the "from" namespace appears in the
|
* things can be accessed if the "from" namespace appears in the
|
* inheritance hierarchy of the class namespace. Private things
|
* inheritance hierarchy of the class namespace. Private things
|
* can be accessed only if the "from" namespace is the same as the
|
* can be accessed only if the "from" namespace is the same as the
|
* class that contains them.
|
* class that contains them.
|
*
|
*
|
* Returns 1/0 indicating true/false.
|
* Returns 1/0 indicating true/false.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CanAccess(memberPtr, fromNsPtr)
|
Itcl_CanAccess(memberPtr, fromNsPtr)
|
ItclMember* memberPtr; /* class member being tested */
|
ItclMember* memberPtr; /* class member being tested */
|
Tcl_Namespace* fromNsPtr; /* namespace requesting access */
|
Tcl_Namespace* fromNsPtr; /* namespace requesting access */
|
{
|
{
|
ItclClass* fromCdPtr;
|
ItclClass* fromCdPtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* If the protection level is "public" or "private", then the
|
* If the protection level is "public" or "private", then the
|
* answer is known immediately.
|
* answer is known immediately.
|
*/
|
*/
|
if (memberPtr->protection == ITCL_PUBLIC) {
|
if (memberPtr->protection == ITCL_PUBLIC) {
|
return 1;
|
return 1;
|
}
|
}
|
else if (memberPtr->protection == ITCL_PRIVATE) {
|
else if (memberPtr->protection == ITCL_PRIVATE) {
|
return (memberPtr->classDefn->namesp == fromNsPtr);
|
return (memberPtr->classDefn->namesp == fromNsPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* If the protection level is "protected", then check the
|
* If the protection level is "protected", then check the
|
* heritage of the namespace requesting access. If cdefnPtr
|
* heritage of the namespace requesting access. If cdefnPtr
|
* is in the heritage, then access is allowed.
|
* is in the heritage, then access is allowed.
|
*/
|
*/
|
assert (memberPtr->protection == ITCL_PROTECTED);
|
assert (memberPtr->protection == ITCL_PROTECTED);
|
|
|
if (Itcl_IsClassNamespace(fromNsPtr)) {
|
if (Itcl_IsClassNamespace(fromNsPtr)) {
|
fromCdPtr = (ItclClass*)fromNsPtr->clientData;
|
fromCdPtr = (ItclClass*)fromNsPtr->clientData;
|
|
|
entry = Tcl_FindHashEntry(&fromCdPtr->heritage,
|
entry = Tcl_FindHashEntry(&fromCdPtr->heritage,
|
(char*)memberPtr->classDefn);
|
(char*)memberPtr->classDefn);
|
|
|
if (entry) {
|
if (entry) {
|
return 1;
|
return 1;
|
}
|
}
|
}
|
}
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CanAccessFunc()
|
* Itcl_CanAccessFunc()
|
*
|
*
|
* Checks to see if a member function with the specified protection
|
* Checks to see if a member function with the specified protection
|
* level can be accessed from a particular namespace context. This
|
* level can be accessed from a particular namespace context. This
|
* follows the same rules enforced by Itcl_CanAccess, but adds one
|
* follows the same rules enforced by Itcl_CanAccess, but adds one
|
* special case: If the function is a protected method, and if the
|
* special case: If the function is a protected method, and if the
|
* current context is a base class that has the same method, then
|
* current context is a base class that has the same method, then
|
* access is allowed.
|
* access is allowed.
|
*
|
*
|
* Returns 1/0 indicating true/false.
|
* Returns 1/0 indicating true/false.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CanAccessFunc(mfunc, fromNsPtr)
|
Itcl_CanAccessFunc(mfunc, fromNsPtr)
|
ItclMemberFunc* mfunc; /* member function being tested */
|
ItclMemberFunc* mfunc; /* member function being tested */
|
Tcl_Namespace* fromNsPtr; /* namespace requesting access */
|
Tcl_Namespace* fromNsPtr; /* namespace requesting access */
|
{
|
{
|
ItclClass *cdPtr, *fromCdPtr;
|
ItclClass *cdPtr, *fromCdPtr;
|
ItclMemberFunc *ovlfunc;
|
ItclMemberFunc *ovlfunc;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Apply the usual rules first.
|
* Apply the usual rules first.
|
*/
|
*/
|
if (Itcl_CanAccess(mfunc->member, fromNsPtr)) {
|
if (Itcl_CanAccess(mfunc->member, fromNsPtr)) {
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/*
|
/*
|
* As a last resort, see if the namespace is really a base
|
* As a last resort, see if the namespace is really a base
|
* class of the class containing the method. Look for a
|
* class of the class containing the method. Look for a
|
* method with the same name in the base class. If there
|
* method with the same name in the base class. If there
|
* is one, then this method overrides it, and the base class
|
* is one, then this method overrides it, and the base class
|
* has access.
|
* has access.
|
*/
|
*/
|
if ((mfunc->member->flags & ITCL_COMMON) == 0 &&
|
if ((mfunc->member->flags & ITCL_COMMON) == 0 &&
|
Itcl_IsClassNamespace(fromNsPtr)) {
|
Itcl_IsClassNamespace(fromNsPtr)) {
|
|
|
cdPtr = mfunc->member->classDefn;
|
cdPtr = mfunc->member->classDefn;
|
fromCdPtr = (ItclClass*)fromNsPtr->clientData;
|
fromCdPtr = (ItclClass*)fromNsPtr->clientData;
|
|
|
if (Tcl_FindHashEntry(&cdPtr->heritage, (char*)fromCdPtr)) {
|
if (Tcl_FindHashEntry(&cdPtr->heritage, (char*)fromCdPtr)) {
|
entry = Tcl_FindHashEntry(&fromCdPtr->resolveCmds,
|
entry = Tcl_FindHashEntry(&fromCdPtr->resolveCmds,
|
mfunc->member->name);
|
mfunc->member->name);
|
|
|
if (entry) {
|
if (entry) {
|
ovlfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
ovlfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
if ((ovlfunc->member->flags & ITCL_COMMON) == 0 &&
|
if ((ovlfunc->member->flags & ITCL_COMMON) == 0 &&
|
ovlfunc->member->protection < ITCL_PRIVATE) {
|
ovlfunc->member->protection < ITCL_PRIVATE) {
|
return 1;
|
return 1;
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_GetTrueNamespace()
|
* Itcl_GetTrueNamespace()
|
*
|
*
|
* Returns the current namespace context. This procedure is similar
|
* Returns the current namespace context. This procedure is similar
|
* to Tcl_GetCurrentNamespace, but it supports the notion of
|
* to Tcl_GetCurrentNamespace, but it supports the notion of
|
* "transparent" call frames installed by Itcl_HandleInstance.
|
* "transparent" call frames installed by Itcl_HandleInstance.
|
*
|
*
|
* Returns a pointer to the current namespace calling context.
|
* Returns a pointer to the current namespace calling context.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Tcl_Namespace*
|
Tcl_Namespace*
|
Itcl_GetTrueNamespace(interp, info)
|
Itcl_GetTrueNamespace(interp, info)
|
Tcl_Interp *interp; /* interpreter being queried */
|
Tcl_Interp *interp; /* interpreter being queried */
|
ItclObjectInfo *info; /* object info associated with interp */
|
ItclObjectInfo *info; /* object info associated with interp */
|
{
|
{
|
int i, transparent;
|
int i, transparent;
|
Tcl_CallFrame *framePtr, *transFramePtr;
|
Tcl_CallFrame *framePtr, *transFramePtr;
|
Tcl_Namespace *contextNs;
|
Tcl_Namespace *contextNs;
|
|
|
/*
|
/*
|
* See if the current call frame is on the list of transparent
|
* See if the current call frame is on the list of transparent
|
* call frames.
|
* call frames.
|
*/
|
*/
|
transparent = 0;
|
transparent = 0;
|
|
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
|
for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
|
transFramePtr = (Tcl_CallFrame*)
|
transFramePtr = (Tcl_CallFrame*)
|
Itcl_GetStackValue(&info->transparentFrames, i);
|
Itcl_GetStackValue(&info->transparentFrames, i);
|
|
|
if (framePtr == transFramePtr) {
|
if (framePtr == transFramePtr) {
|
transparent = 1;
|
transparent = 1;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If this is a transparent call frame, return the namespace
|
* If this is a transparent call frame, return the namespace
|
* context one level up.
|
* context one level up.
|
*/
|
*/
|
if (transparent) {
|
if (transparent) {
|
framePtr = _Tcl_GetCallFrame(interp, 1);
|
framePtr = _Tcl_GetCallFrame(interp, 1);
|
if (framePtr) {
|
if (framePtr) {
|
contextNs = framePtr->nsPtr;
|
contextNs = framePtr->nsPtr;
|
} else {
|
} else {
|
contextNs = Tcl_GetGlobalNamespace(interp);
|
contextNs = Tcl_GetGlobalNamespace(interp);
|
}
|
}
|
}
|
}
|
else {
|
else {
|
contextNs = Tcl_GetCurrentNamespace(interp);
|
contextNs = Tcl_GetCurrentNamespace(interp);
|
}
|
}
|
return contextNs;
|
return contextNs;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ParseNamespPath()
|
* Itcl_ParseNamespPath()
|
*
|
*
|
* Parses a reference to a namespace element of the form:
|
* Parses a reference to a namespace element of the form:
|
*
|
*
|
* namesp::namesp::namesp::element
|
* namesp::namesp::namesp::element
|
*
|
*
|
* Returns pointers to the head part ("namesp::namesp::namesp")
|
* Returns pointers to the head part ("namesp::namesp::namesp")
|
* and the tail part ("element"). If the head part is missing,
|
* and the tail part ("element"). If the head part is missing,
|
* a NULL pointer is returned and the rest of the string is taken
|
* a NULL pointer is returned and the rest of the string is taken
|
* as the tail.
|
* as the tail.
|
*
|
*
|
* Both head and tail point to locations within the given dynamic
|
* Both head and tail point to locations within the given dynamic
|
* string buffer. This buffer must be uninitialized when passed
|
* string buffer. This buffer must be uninitialized when passed
|
* into this procedure, and it must be freed later on, when the
|
* into this procedure, and it must be freed later on, when the
|
* strings are no longer needed.
|
* strings are no longer needed.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_ParseNamespPath(name, buffer, head, tail)
|
Itcl_ParseNamespPath(name, buffer, head, tail)
|
char *name; /* path name to class member */
|
char *name; /* path name to class member */
|
Tcl_DString *buffer; /* dynamic string buffer (uninitialized) */
|
Tcl_DString *buffer; /* dynamic string buffer (uninitialized) */
|
char **head; /* returns "namesp::namesp::namesp" part */
|
char **head; /* returns "namesp::namesp::namesp" part */
|
char **tail; /* returns "element" part */
|
char **tail; /* returns "element" part */
|
{
|
{
|
register char *sep;
|
register char *sep;
|
|
|
Tcl_DStringInit(buffer);
|
Tcl_DStringInit(buffer);
|
|
|
/*
|
/*
|
* Copy the name into the buffer and parse it. Look
|
* Copy the name into the buffer and parse it. Look
|
* backward from the end of the string to the first '::'
|
* backward from the end of the string to the first '::'
|
* scope qualifier.
|
* scope qualifier.
|
*/
|
*/
|
Tcl_DStringAppend(buffer, name, -1);
|
Tcl_DStringAppend(buffer, name, -1);
|
name = Tcl_DStringValue(buffer);
|
name = Tcl_DStringValue(buffer);
|
|
|
for (sep=name; *sep != '\0'; sep++)
|
for (sep=name; *sep != '\0'; sep++)
|
;
|
;
|
|
|
while (--sep > name) {
|
while (--sep > name) {
|
if (*sep == ':' && *(sep-1) == ':') {
|
if (*sep == ':' && *(sep-1) == ':') {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Found head/tail parts. If there are extra :'s, keep backing
|
* Found head/tail parts. If there are extra :'s, keep backing
|
* up until the head is found. This supports the Tcl namespace
|
* up until the head is found. This supports the Tcl namespace
|
* behavior, which allows names like "foo:::bar".
|
* behavior, which allows names like "foo:::bar".
|
*/
|
*/
|
if (sep > name) {
|
if (sep > name) {
|
*tail = sep+1;
|
*tail = sep+1;
|
while (sep > name && *(sep-1) == ':') {
|
while (sep > name && *(sep-1) == ':') {
|
sep--;
|
sep--;
|
}
|
}
|
*sep = '\0';
|
*sep = '\0';
|
*head = name;
|
*head = name;
|
}
|
}
|
|
|
/*
|
/*
|
* No :: separators--the whole name is treated as a tail.
|
* No :: separators--the whole name is treated as a tail.
|
*/
|
*/
|
else {
|
else {
|
*tail = name;
|
*tail = name;
|
*head = NULL;
|
*head = NULL;
|
}
|
}
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DecodeScopedCommand()
|
* Itcl_DecodeScopedCommand()
|
*
|
*
|
* Decodes a scoped command of the form:
|
* Decodes a scoped command of the form:
|
*
|
*
|
* namespace inscope <namesp> <command>
|
* namespace inscope <namesp> <command>
|
*
|
*
|
* If the given string is not a scoped value, this procedure does
|
* If the given string is not a scoped value, this procedure does
|
* nothing and returns TCL_OK. If the string is a scoped value,
|
* nothing and returns TCL_OK. If the string is a scoped value,
|
* then it is decoded, and the namespace, and the simple command
|
* then it is decoded, and the namespace, and the simple command
|
* string are returned as arguments; the simple command should
|
* string are returned as arguments; the simple command should
|
* be freed when no longer in use. If anything goes wrong, this
|
* be freed when no longer in use. If anything goes wrong, this
|
* procedure returns TCL_ERROR, along with an error message in
|
* procedure returns TCL_ERROR, along with an error message in
|
* the interpreter.
|
* the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
|
Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char *name; /* string to be decoded */
|
char *name; /* string to be decoded */
|
Tcl_Namespace **rNsPtr; /* returns: namespace for scoped value */
|
Tcl_Namespace **rNsPtr; /* returns: namespace for scoped value */
|
char **rCmdPtr; /* returns: simple command word */
|
char **rCmdPtr; /* returns: simple command word */
|
{
|
{
|
Tcl_Namespace *nsPtr = NULL;
|
Tcl_Namespace *nsPtr = NULL;
|
char *cmdName = name;
|
char *cmdName = name;
|
int len = strlen(name);
|
int len = strlen(name);
|
|
|
char *pos;
|
char *pos;
|
int listc, result;
|
int listc, result;
|
char **listv;
|
char **listv;
|
|
|
if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
|
if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
|
for (pos = (name + 9); (*pos == ' '); pos++) {
|
for (pos = (name + 9); (*pos == ' '); pos++) {
|
/* empty body: skip over spaces */
|
/* empty body: skip over spaces */
|
}
|
}
|
if ((*pos == 'i') && ((pos + 7) <= (name + len))
|
if ((*pos == 'i') && ((pos + 7) <= (name + len))
|
&& (strncmp(pos, "inscope", 7) == 0)) {
|
&& (strncmp(pos, "inscope", 7) == 0)) {
|
|
|
result = Tcl_SplitList(interp, name, &listc, &listv);
|
result = Tcl_SplitList(interp, name, &listc, &listv);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
if (listc != 4) {
|
if (listc != 4) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"malformed command \"", name, "\": should be \"",
|
"malformed command \"", name, "\": should be \"",
|
"namespace inscope namesp command\"",
|
"namespace inscope namesp command\"",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
else {
|
else {
|
nsPtr = Tcl_FindNamespace(interp, listv[2],
|
nsPtr = Tcl_FindNamespace(interp, listv[2],
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
|
|
if (!nsPtr) {
|
if (!nsPtr) {
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
else {
|
else {
|
cmdName = ckalloc((unsigned)(strlen(listv[3])+1));
|
cmdName = ckalloc((unsigned)(strlen(listv[3])+1));
|
strcpy(cmdName, listv[3]);
|
strcpy(cmdName, listv[3]);
|
}
|
}
|
}
|
}
|
}
|
}
|
ckfree((char*)listv);
|
ckfree((char*)listv);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[512];
|
char msg[512];
|
sprintf(msg, "\n (while decoding scoped command \"%.400s\")", name);
|
sprintf(msg, "\n (while decoding scoped command \"%.400s\")", name);
|
Tcl_AddObjErrorInfo(interp, msg, -1);
|
Tcl_AddObjErrorInfo(interp, msg, -1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
*rNsPtr = nsPtr;
|
*rNsPtr = nsPtr;
|
*rCmdPtr = cmdName;
|
*rCmdPtr = cmdName;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_EvalArgs()
|
* Itcl_EvalArgs()
|
*
|
*
|
* This procedure invokes a list of (objc,objv) arguments as a
|
* This procedure invokes a list of (objc,objv) arguments as a
|
* single command. It is similar to Tcl_EvalObj, but it doesn't
|
* single command. It is similar to Tcl_EvalObj, but it doesn't
|
* do any parsing or compilation. It simply treats the first
|
* do any parsing or compilation. It simply treats the first
|
* argument as a command and invokes that command in the current
|
* argument as a command and invokes that command in the current
|
* context.
|
* context.
|
*
|
*
|
* Returns TCL_OK if successful. Otherwise, this procedure returns
|
* Returns TCL_OK if successful. Otherwise, this procedure returns
|
* TCL_ERROR along with an error message in the interpreter.
|
* TCL_ERROR along with an error message in the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_EvalArgs(interp, objc, objv)
|
Itcl_EvalArgs(interp, objc, objv)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
int result;
|
int result;
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
int cmdlinec;
|
int cmdlinec;
|
Tcl_Obj **cmdlinev;
|
Tcl_Obj **cmdlinev;
|
Tcl_Obj *cmdlinePtr = NULL;
|
Tcl_Obj *cmdlinePtr = NULL;
|
|
|
/*
|
/*
|
* Resolve the command by converting it to a CmdName object.
|
* Resolve the command by converting it to a CmdName object.
|
* This caches a pointer to the Command structure for the
|
* This caches a pointer to the Command structure for the
|
* command, so if we need it again, it's ready to use.
|
* command, so if we need it again, it's ready to use.
|
*/
|
*/
|
cmd = Tcl_GetCommandFromObj(interp, objv[0]);
|
cmd = Tcl_GetCommandFromObj(interp, objv[0]);
|
cmdPtr = (Command*)cmd;
|
cmdPtr = (Command*)cmd;
|
|
|
cmdlinec = objc;
|
cmdlinec = objc;
|
cmdlinev = (Tcl_Obj**)objv;
|
cmdlinev = (Tcl_Obj**)objv;
|
|
|
/*
|
/*
|
* If the command is still not found, handle it with the
|
* If the command is still not found, handle it with the
|
* "unknown" proc.
|
* "unknown" proc.
|
*/
|
*/
|
if (cmdPtr == NULL) {
|
if (cmdPtr == NULL) {
|
cmd = Tcl_FindCommand(interp, "unknown",
|
cmd = Tcl_FindCommand(interp, "unknown",
|
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
|
|
if (cmd == NULL) {
|
if (cmd == NULL) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"invalid command name \"",
|
"invalid command name \"",
|
Tcl_GetStringFromObj(objv[0], (int*)NULL), "\"",
|
Tcl_GetStringFromObj(objv[0], (int*)NULL), "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
cmdPtr = (Command*)cmd;
|
cmdPtr = (Command*)cmd;
|
|
|
cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv);
|
cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv);
|
|
|
(void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
|
(void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
|
&cmdlinec, &cmdlinev);
|
&cmdlinec, &cmdlinev);
|
}
|
}
|
|
|
/*
|
/*
|
* Finally, invoke the command's Tcl_ObjCmdProc. Be careful
|
* Finally, invoke the command's Tcl_ObjCmdProc. Be careful
|
* to pass in the proper client data.
|
* to pass in the proper client data.
|
*/
|
*/
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
|
cmdlinec, cmdlinev);
|
cmdlinec, cmdlinev);
|
|
|
if (cmdlinePtr) {
|
if (cmdlinePtr) {
|
Tcl_DecrRefCount(cmdlinePtr);
|
Tcl_DecrRefCount(cmdlinePtr);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateArgs()
|
* Itcl_CreateArgs()
|
*
|
*
|
* This procedure takes a string and a list of (objc,objv) arguments,
|
* This procedure takes a string and a list of (objc,objv) arguments,
|
* and glues them together in a single list. This is useful when
|
* and glues them together in a single list. This is useful when
|
* a command word needs to be prepended or substituted into a command
|
* a command word needs to be prepended or substituted into a command
|
* line before it is executed. The arguments are returned in a single
|
* line before it is executed. The arguments are returned in a single
|
* list object, and they can be retrieved by calling
|
* list object, and they can be retrieved by calling
|
* Tcl_ListObjGetElements. When the arguments are no longer needed,
|
* Tcl_ListObjGetElements. When the arguments are no longer needed,
|
* they should be discarded by decrementing the reference count for
|
* they should be discarded by decrementing the reference count for
|
* the list object.
|
* the list object.
|
*
|
*
|
* Returns a pointer to the list object containing the arguments.
|
* Returns a pointer to the list object containing the arguments.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Tcl_Obj*
|
Tcl_Obj*
|
Itcl_CreateArgs(interp, string, objc, objv)
|
Itcl_CreateArgs(interp, string, objc, objv)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char *string; /* first command word */
|
char *string; /* first command word */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
int i;
|
int i;
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_NewStringObj(string, -1));
|
Tcl_NewStringObj(string, -1));
|
|
|
for (i=0; i < objc; i++) {
|
for (i=0; i < objc; i++) {
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objv[i]);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objv[i]);
|
}
|
}
|
|
|
Tcl_IncrRefCount(listPtr);
|
Tcl_IncrRefCount(listPtr);
|
return listPtr;
|
return listPtr;
|
}
|
}
|
|
|