/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  [incr Tcl] provides object-oriented extensions to Tcl, much as
 *  C++ provides object-oriented extensions to C.  It provides a means
 *  of encapsulating related procedures together with their shared data
 *  in a local namespace that is hidden from the outside world.  It
 *  promotes code re-use through inheritance.  More than anything else,
 *  it encourages better organization of Tcl applications through the
 *  object-oriented paradigm, leading to code that is easier to
 *  understand and maintain.
 *
 *  This segment provides common utility functions used throughout
 *  the other [incr Tcl] source files.
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           mmclennan@lucent.com
 *           http://www.tcltk.com/itcl
 *
 *  overhauled version author: Arnulf Wiedemann
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"
#include <limits.h>

/*
 *  POOL OF LIST ELEMENTS FOR LINKED LIST
 */
static Itcl_ListElem *listPool = NULL;
static int listPoolLen = 0;

#define ITCL_VALID_LIST 0x01face10  /* magic bit pattern for validation */
#define ITCL_LIST_POOL_SIZE 200     /* max number of elements in listPool */

/*
 *  This structure is used to take a snapshot of the interpreter
 *  state in Itcl_SaveInterpState.  You can snapshot the state,
 *  execute a command, and then back up to the result or the
 *  error that was previously in progress.
 */
typedef struct InterpState {
    int validate;                   /* validation stamp */
    int status;                     /* return code status */
    Tcl_Obj *objResult;             /* result object */
    char *errorInfo;                /* contents of errorInfo variable */
    char *errorCode;                /* contents of errorCode variable */
} InterpState;

#define TCL_STATE_VALID 0x01233210  /* magic bit pattern for validation */


/*
 * ------------------------------------------------------------------------
 *  Itcl_Assert()
 *
 *  Called whenever an assert() test fails.  Prints a diagnostic
 *  message and abruptly exits.
 * ------------------------------------------------------------------------
 */

void
Itcl_Assert(
    const char *testExpr,   /* string representing test expression */
    const char *fileName,   /* file name containing this call */
    int lineNumber)	    /* line number containing this call */
{
    Tcl_Panic("Itcl Assertion failed: \"%s\" (line %d of %s)",
	testExpr, lineNumber, fileName);
}



/*
 * ------------------------------------------------------------------------
 *  Itcl_InitStack()
 *
 *  Initializes a stack structure, allocating a certain amount of memory
 *  for the stack and setting the stack length to zero.
 * ------------------------------------------------------------------------
 */
void
Itcl_InitStack(
    Itcl_Stack *stack)     /* stack to be initialized */
{
    stack->values = stack->space;
    stack->max = sizeof(stack->space)/sizeof(void *);
    stack->len = 0;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteStack()
 *
 *  Destroys a stack structure, freeing any memory that may have been
 *  allocated to represent it.
 * ------------------------------------------------------------------------
 */
void
Itcl_DeleteStack(
    Itcl_Stack *stack)     /* stack to be deleted */
{
    /*
     *  If memory was explicitly allocated (instead of using the
     *  built-in buffer) then free it.
     */
    if (stack->values != stack->space) {
        ckfree((char*)stack->values);
    }
    stack->values = NULL;
    stack->len = stack->max = 0;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_PushStack()
 *
 *  Pushes a piece of client data onto the top of the given stack.
 *  If the stack is not large enough, it is automatically resized.
 * ------------------------------------------------------------------------
 */
void
Itcl_PushStack(
    void *cdata,           /* data to be pushed onto stack */
    Itcl_Stack *stack)     /* stack */
{
    void **newStack;

    if (stack->len+1 >= stack->max) {
        stack->max = 2*stack->max;
        newStack = (void **)
            ckalloc(stack->max*sizeof(void *));

        if (stack->values) {
            memcpy(newStack, stack->values,
                stack->len*sizeof(void *));

            if (stack->values != stack->space)
                ckfree((char*)stack->values);
        }
        stack->values = newStack;
    }
    stack->values[stack->len++] = cdata;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_PopStack()
 *
 *  Pops a bit of client data from the top of the given stack.
 * ------------------------------------------------------------------------
 */
void *
Itcl_PopStack(
    Itcl_Stack *stack)  /* stack to be manipulated */
{
    if (stack->values && (stack->len > 0)) {
        stack->len--;
        return stack->values[stack->len];
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_PeekStack()
 *
 *  Gets the current value from the top of the given stack.
 * ------------------------------------------------------------------------
 */
void *
Itcl_PeekStack(
    Itcl_Stack *stack)  /* stack to be examined */
{
    if (stack->values && (stack->len > 0)) {
        return stack->values[stack->len-1];
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_GetStackValue()
 *
 *  Gets a value at some index within the stack.  Index "0" is the
 *  first value pushed onto the stack.
 * ------------------------------------------------------------------------
 */
void *
Itcl_GetStackValue(
    Itcl_Stack *stack,  /* stack to be examined */
    Tcl_Size pos)            /* get value at this index */
{
    if (stack->values && (pos >= 0) && (pos < stack->len)) {
        return stack->values[pos];
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_InitList()
 *
 *  Initializes a linked list structure, setting the list to the empty
 *  state.
 * ------------------------------------------------------------------------
 */
void
Itcl_InitList(
    Itcl_List *listPtr)     /* list to be initialized */
{
    listPtr->validate = ITCL_VALID_LIST;
    listPtr->num      = 0;
    listPtr->head     = NULL;
    listPtr->tail     = NULL;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteList()
 *
 *  Destroys a linked list structure, deleting all of its elements and
 *  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
 *  will be lost.
 * ------------------------------------------------------------------------
 */
void
Itcl_DeleteList(
    Itcl_List *listPtr)     /* list to be deleted */
{
    Itcl_ListElem *elemPtr;

    assert(listPtr->validate == ITCL_VALID_LIST);

    elemPtr = listPtr->head;
    while (elemPtr) {
        elemPtr = Itcl_DeleteListElem(elemPtr);
    }
    listPtr->validate = 0;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateListElem()
 *
 *  Low-level routined used by procedures like Itcl_InsertList() and
 *  Itcl_AppendList() to create new list elements.  If elements are
 *  available, one is taken from the list element pool.  Otherwise,
 *  a new one is allocated.
 * ------------------------------------------------------------------------
 */
Itcl_ListElem*
Itcl_CreateListElem(
    Itcl_List *listPtr)     /* list that will contain this new element */
{
    Itcl_ListElem *elemPtr;

    if (listPoolLen > 0) {
        elemPtr = listPool;
        listPool = elemPtr->next;
        --listPoolLen;
    } else {
        elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem));
    }
    elemPtr->owner = listPtr;
    elemPtr->value = NULL;
    elemPtr->next  = NULL;
    elemPtr->prev  = NULL;

    return elemPtr;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteListElem()
 *
 *  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
 *  element in the list.
 * ------------------------------------------------------------------------
 */
Itcl_ListElem*
Itcl_DeleteListElem(
    Itcl_ListElem *elemPtr)     /* list element to be deleted */
{
    Itcl_List *listPtr;
    Itcl_ListElem *nextPtr;

    nextPtr = elemPtr->next;

    if (elemPtr->prev) {
        elemPtr->prev->next = elemPtr->next;
    }
    if (elemPtr->next) {
        elemPtr->next->prev = elemPtr->prev;
    }

    listPtr = elemPtr->owner;
    if (elemPtr == listPtr->head) {
        listPtr->head = elemPtr->next;
    }
    if (elemPtr == listPtr->tail) {
        listPtr->tail = elemPtr->prev;
    }
    --listPtr->num;

    if (listPoolLen < ITCL_LIST_POOL_SIZE) {
        elemPtr->next = listPool;
        listPool = elemPtr;
        ++listPoolLen;
    } else {
        ckfree((char*)elemPtr);
    }
    return nextPtr;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_InsertList()
 *
 *  Creates a new list element containing the given value and returns
 *  a pointer to it.  The element is inserted at the beginning of the
 *  specified list.
 * ------------------------------------------------------------------------
 */
Itcl_ListElem*
Itcl_InsertList(
    Itcl_List *listPtr,     /* list being modified */
    void *val)              /* value associated with new element */
{
    Itcl_ListElem *elemPtr;
    assert(listPtr->validate == ITCL_VALID_LIST);

    elemPtr = Itcl_CreateListElem(listPtr);

    elemPtr->value = val;
    elemPtr->next  = listPtr->head;
    elemPtr->prev  = NULL;
    if (listPtr->head) {
        listPtr->head->prev = elemPtr;
    }
    listPtr->head  = elemPtr;
    if (listPtr->tail == NULL) {
        listPtr->tail = elemPtr;
    }
    ++listPtr->num;

    return elemPtr;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_InsertListElem()
 *
 *  Creates a new list element containing the given value and returns
 *  a pointer to it.  The element is inserted in the list just before
 *  the specified element.
 * ------------------------------------------------------------------------
 */
Itcl_ListElem*
Itcl_InsertListElem(
    Itcl_ListElem *pos,     /* insert just before this element */
    void *val)              /* value associated with new element */
{
    Itcl_List *listPtr;
    Itcl_ListElem *elemPtr;

    listPtr = pos->owner;
    assert(listPtr->validate == ITCL_VALID_LIST);
    assert(pos != NULL);

    elemPtr = Itcl_CreateListElem(listPtr);
    elemPtr->value = val;

    elemPtr->prev = pos->prev;
    if (elemPtr->prev) {
        elemPtr->prev->next = elemPtr;
    }
    elemPtr->next = pos;
    pos->prev     = elemPtr;

    if (listPtr->head == pos) {
        listPtr->head = elemPtr;
    }
    if (listPtr->tail == NULL) {
        listPtr->tail = elemPtr;
    }
    ++listPtr->num;

    return elemPtr;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_AppendList()
 *
 *  Creates a new list element containing the given value and returns
 *  a pointer to it.  The element is appended at the end of the
 *  specified list.
 * ------------------------------------------------------------------------
 */
Itcl_ListElem*
Itcl_AppendList(
    Itcl_List *listPtr,     /* list being modified */
    void *val)              /* value associated with new element */
{
    Itcl_ListElem *elemPtr;
    assert(listPtr->validate == ITCL_VALID_LIST);

    elemPtr = Itcl_CreateListElem(listPtr);

    elemPtr->value = val;
    elemPtr->prev  = listPtr->tail;
    elemPtr->next  = NULL;
    if (listPtr->tail) {
        listPtr->tail->next = elemPtr;
    }
    listPtr->tail  = elemPtr;
    if (listPtr->head == NULL) {
        listPtr->head = elemPtr;
    }
    ++listPtr->num;

    return elemPtr;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_AppendListElem()
 *
 *  Creates a new list element containing the given value and returns
 *  a pointer to it.  The element is inserted in the list just after
 *  the specified element.
 * ------------------------------------------------------------------------
 */
Itcl_ListElem*
Itcl_AppendListElem(
    Itcl_ListElem *pos,     /* insert just after this element */
    void *val)              /* value associated with new element */
{
    Itcl_List *listPtr;
    Itcl_ListElem *elemPtr;

    listPtr = pos->owner;
    assert(listPtr->validate == ITCL_VALID_LIST);
    assert(pos != NULL);

    elemPtr = Itcl_CreateListElem(listPtr);
    elemPtr->value = val;

    elemPtr->next = pos->next;
    if (elemPtr->next) {
        elemPtr->next->prev = elemPtr;
    }
    elemPtr->prev = pos;
    pos->next     = elemPtr;

    if (listPtr->tail == pos) {
        listPtr->tail = elemPtr;
    }
    if (listPtr->head == NULL) {
        listPtr->head = elemPtr;
    }
    ++listPtr->num;

    return elemPtr;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_SetListValue()
 *
 *  Modifies the value associated with a list element.
 * ------------------------------------------------------------------------
 */
void
Itcl_SetListValue(
    Itcl_ListElem *elemPtr, /* list element being modified */
    void *val)              /* new value associated with element */
{
    assert(elemPtr != NULL);
    assert(elemPtr->owner->validate == ITCL_VALID_LIST);
    elemPtr->value = val;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_FinishList()
 *
 *  free all memory used in the list pool
 * ------------------------------------------------------------------------
 */
void
Itcl_FinishList()
{
    Itcl_ListElem *listPtr;
    Itcl_ListElem *elemPtr;

    listPtr = listPool;
    while (listPtr != NULL) {
        elemPtr = listPtr;
	listPtr = elemPtr->next;
	ckfree((char *)elemPtr);
        elemPtr = NULL;
    }
    listPool = NULL;
    listPoolLen = 0;
}


/*
 * ========================================================================
 *  REFERENCE-COUNTED DATA
 *
 *  The following procedures manage generic reference-counted data.
 *  They are similar in spirit to the Tcl_Preserve/Tcl_Release
 *  procedures defined in the Tcl/Tk core.  But these procedures attach a
 *  refcount directly to the allocated memory, and then use it to govern
 *  shared access and properly timed release.
 */

typedef struct PresMemoryPrefix {
    Tcl_FreeProc *freeProc;     /* called by last Itcl_ReleaseData */
    size_t refCount;            /* refernce (resp preserving) counter */
} PresMemoryPrefix;

/*
 * ------------------------------------------------------------------------
 *  Itcl_EventuallyFree()
 *
 *  Asscociates with cdata (allocated by Itcl_Alloc()) a routine to
 *  be called when cdata should be freed. This routine will be called
 *  when the number of Itcl_ReleaseData() calls on cdata  matches the
 *  number of Itcl_PreserveData() calls on cdata.
 * ------------------------------------------------------------------------
 */
void
Itcl_EventuallyFree(
    void *cdata,               /* data to be freed when not in use */
    Tcl_FreeProc *fproc)       /* procedure called to free data */
{
    PresMemoryPrefix *blk;

    if (cdata == NULL) {
        return;
    }

    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)cdata)-1;

    /* Set new free proc */
    blk->freeProc = fproc;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_PreserveData()
 *
 *  Increases the usage count for a piece of data that will be freed
 *  later when no longer needed.  Each call to Itcl_PreserveData()
 *  puts one claim on a piece of data, and subsequent calls to
 *  Itcl_ReleaseData() remove those claims.  When Itcl_EventuallyFree()
 *  is called, and when the usage count reaches zero, the data is
 *  freed.
 * ------------------------------------------------------------------------
 */
void
Itcl_PreserveData(
    void *cdata)     /* data to be preserved */
{
    PresMemoryPrefix *blk;

    if (cdata == NULL) {
        return;
    }

    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)cdata)-1;

    /* Increment preservation count */
    ++blk->refCount;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ReleaseData()
 *
 *  Decreases the usage count for a piece of data that was registered
 *  previously via Itcl_PreserveData().  After Itcl_EventuallyFree()
 *  is called and the usage count reaches zero, the data is
 *  automatically freed.
 * ------------------------------------------------------------------------
 */
void
Itcl_ReleaseData(
    void *cdata)      /* data to be released */
{
    PresMemoryPrefix *blk;
    Tcl_FreeProc *freeProc;

    if (cdata == NULL) {
        return;
    }

    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)cdata)-1;

    /* Usage sanity check */
    assert(blk->refCount > 0); /* must call Itcl_PreserveData() first */
    assert(blk->freeProc);	/* must call Itcl_EventuallyFree() first */

    /* Decrement preservation count */
    if (blk->refCount-- > 1) {
	return;
    }

    /* Free cdata now */
    freeProc = blk->freeProc;
    blk->freeProc = NULL;
    freeProc((char *)cdata);
}

/*
 * ------------------------------------------------------------------------
 * Itcl_Alloc()
 *
 *	Allocate preservable memory. In opposite to ckalloc the result can be
 *	supplied to preservation facilities of Itcl (Itcl_PreserveData).
 *
 * Results:
 *	Pointer to new allocated memory.
 * ------------------------------------------------------------------------
 */
void * Itcl_Alloc(
    size_t size)	/* Size of memory to allocate */
{
    size_t numBytes;
    PresMemoryPrefix *blk;

#if TCL_MAJOR_VERSION < 9
    /* The ckalloc() in Tcl 8 can alloc at most UINT_MAX bytes */
    assert (size <= UINT_MAX - sizeof(PresMemoryPrefix));
#else
    assert (size < -sizeof(PresMemoryPrefix));
#endif
    numBytes = size + sizeof(PresMemoryPrefix);

    /* This will panic on allocation failure. No need to check return value. */
    blk = (PresMemoryPrefix *)ckalloc(numBytes);

    /* Itcl_Alloc defined to zero-init memory it allocates */
    memset(blk, 0, numBytes);

    /* ckalloc block to Itcl memory block */
    return blk+1;
}
/*
 * ------------------------------------------------------------------------
 * Itcl_Free()
 *
 *	Release memory allocated by Itcl_Alloc() that was never preserved.
 *
 * Results:
 *	None.
 *
 * ------------------------------------------------------------------------
 */
void Itcl_Free(void *ptr) {
    PresMemoryPrefix *blk;

    if (ptr == NULL) {
	return;
    }
    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)ptr)-1;

    assert(blk->refCount == 0); /* it should be not preserved */
    assert(blk->freeProc == NULL); /* it should be released */
    ckfree(blk);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_SaveInterpState()
 *
 *  Takes a snapshot of the current result state of the interpreter.
 *  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
 *  snapshot the interpreter, execute a command that might generate an
 *  error, restore the snapshot, and continue building the result string.
 *
 *  Once a snapshot is saved, it must be restored by calling
 *  Itcl_RestoreInterpState, or discarded by calling
 *  Itcl_DiscardInterpState.  Otherwise, memory will be leaked.
 *
 *  Returns a token representing the state of the interpreter.
 * ------------------------------------------------------------------------
 */
Itcl_InterpState
Itcl_SaveInterpState(
    Tcl_Interp* interp,     /* interpreter being modified */
    int status)             /* integer status code for current operation */
{
    return (Itcl_InterpState) Tcl_SaveInterpState(interp, status);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_RestoreInterpState()
 *
 *  Restores the state of the interpreter to a snapshot taken by
 *  Itcl_SaveInterpState.  This affects variables such as "errorInfo"
 *  and "errorCode".  After this call, the token for the interpreter
 *  state is no longer valid.
 *
 *  Returns the status code that was pending at the time the state was
 *  captured.
 * ------------------------------------------------------------------------
 */
int
Itcl_RestoreInterpState(
    Tcl_Interp* interp,       /* interpreter being modified */
    Itcl_InterpState state)   /* token representing interpreter state */
{
    return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DiscardInterpState()
 *
 *  Frees the memory associated with an interpreter snapshot taken by
 *  Itcl_SaveInterpState.  If the snapshot is not restored, this
 *  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
 *  valid.
 * ------------------------------------------------------------------------
 */
void
Itcl_DiscardInterpState(
    Itcl_InterpState state)  /* token representing interpreter state */
{
    Tcl_DiscardInterpState((Tcl_InterpState)state);
    return;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_Protection()
 *
 *  Used to query/set the protection level used when commands/variables
 *  are defined within a class.  The default protection level (when
 *  no public/protected/private command is active) is ITCL_DEFAULT_PROTECT.
 *  In the default case, new commands are treated as public, while new
 *  variables are treated as protected.
 *
 *  If the specified level is 0, then this procedure returns the
 *  current value without changing it.  Otherwise, it sets the current
 *  value to the specified protection level, and returns the previous
 *  value.
 * ------------------------------------------------------------------------
 */
int
Itcl_Protection(
    Tcl_Interp *interp,  /* interpreter being queried */
    int newLevel)        /* new protection level or 0 */
{
    int oldVal;
    ItclObjectInfo *infoPtr;

    /*
     *  If a new level was specified, then set the protection level.
     *  In any case, return the protection level as it stands right now.
     */
    infoPtr = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA,
        NULL);

    assert(infoPtr != NULL);
    oldVal = infoPtr->protection;

    if (newLevel != 0) {
        assert(newLevel == ITCL_PUBLIC ||
            newLevel == ITCL_PROTECTED ||
            newLevel == ITCL_PRIVATE ||
            newLevel == ITCL_DEFAULT_PROTECT);
        infoPtr->protection = newLevel;
    }
    return oldVal;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ParseNamespPath()
 *
 *  Parses a reference to a namespace element of the form:
 *
 *      namesp::namesp::namesp::element
 *
 *  Returns pointers to the head part ("namesp::namesp::namesp")
 *  and the tail part ("element").  If the head part is missing,
 *  a NULL pointer is returned and the rest of the string is taken
 *  as the tail.
 *
 *  Both head and tail point to locations within the given dynamic
 *  string buffer.  This buffer must be uninitialized when passed
 *  into this procedure, and it must be freed later on, when the
 *  strings are no longer needed.
 * ------------------------------------------------------------------------
 */
void
Itcl_ParseNamespPath(
    const char *name,    /* path name to class member */
    Tcl_DString *buffer, /* dynamic string buffer (uninitialized) */
    const char **head,   /* returns "namesp::namesp::namesp" part */
    const char **tail)   /* returns "element" part */
{
    char *sep, *newname;

    Tcl_DStringInit(buffer);

    /*
     *  Copy the name into the buffer and parse it.  Look
     *  backward from the end of the string to the first '::'
     *  scope qualifier.
     */
    Tcl_DStringAppend(buffer, name, -1);
    newname = Tcl_DStringValue(buffer);

    for (sep=newname; *sep != '\0'; sep++)
        ;

    while (--sep > newname) {
        if (*sep == ':' && *(sep-1) == ':') {
            break;
        }
    }

    /*
     *  Found head/tail parts.  If there are extra :'s, keep backing
     *  up until the head is found.  This supports the Tcl namespace
     *  behavior, which allows names like "foo:::bar".
     */
    if (sep > newname) {
        *tail = sep+1;
        while (sep > newname && *(sep-1) == ':') {
            sep--;
        }
        *sep = '\0';
        *head = newname;
    } else {

        /*
         *  No :: separators--the whole name is treated as a tail.
         */
        *tail = newname;
        *head = NULL;
    }
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CanAccess2()
 *
 *  Checks to see if a class member can be accessed from a particular
 *  namespace context.  Public things can always be accessed.  Protected
 *  things can be accessed if the "from" namespace appears in the
 *  inheritance hierarchy of the class namespace.  Private things
 *  can be accessed only if the "from" namespace is the same as the
 *  class that contains them.
 *
 *  Returns 1/0 indicating true/false.
 * ------------------------------------------------------------------------
 */
int
Itcl_CanAccess2(
    ItclClass *iclsPtr,        /* class being tested */
    int protection,            /* protection level being tested */
    Tcl_Namespace* fromNsPtr)  /* namespace requesting access */
{
    ItclClass* fromIclsPtr;
    Tcl_HashEntry *entry;

    /*
     *  If the protection level is "public" or "private", then the
     *  answer is known immediately.
     */
    if (protection == ITCL_PUBLIC) {
        return 1;
    } else {
        if (protection == ITCL_PRIVATE) {
	    entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses,
		fromNsPtr);
	    if (entry == NULL) {
		return 0;
	    }
	    return (iclsPtr == Tcl_GetHashValue(entry));
        }
    }

    /*
     *  If the protection level is "protected", then check the
     *  heritage of the namespace requesting access.  If cdefnPtr
     *  is in the heritage, then access is allowed.
     */
    assert (protection == ITCL_PROTECTED);

    if (Itcl_IsClassNamespace(fromNsPtr)) {
	entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses,
		fromNsPtr);
	if (entry == NULL) {
	    return 0;
	}
	fromIclsPtr = (ItclClass *)Tcl_GetHashValue(entry);

        entry = Tcl_FindHashEntry(&fromIclsPtr->heritage,
	        (char*)iclsPtr);

        if (entry) {
            return 1;
        }
    }
    return 0;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CanAccess()
 *
 *  Checks to see if a class member can be accessed from a particular
 *  namespace context.  Public things can always be accessed.  Protected
 *  things can be accessed if the "from" namespace appears in the
 *  inheritance hierarchy of the class namespace.  Private things
 *  can be accessed only if the "from" namespace is the same as the
 *  class that contains them.
 *
 *  Returns 1/0 indicating true/false.
 * ------------------------------------------------------------------------
 */
int
Itcl_CanAccess(
    ItclMemberFunc* imPtr,     /* class member being tested */
    Tcl_Namespace* fromNsPtr)  /* namespace requesting access */
{
    return Itcl_CanAccess2(imPtr->iclsPtr, imPtr->protection, fromNsPtr);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CanAccessFunc()
 *
 *  Checks to see if a member function with the specified protection
 *  level can be accessed from a particular namespace context.  This
 *  follows the same rules enforced by Itcl_CanAccess, but adds one
 *  special case:  If the function is a protected method, and if the
 *  current context is a base class that has the same method, then
 *  access is allowed.
 *
 *  Returns 1/0 indicating true/false.
 * ------------------------------------------------------------------------
 */
int
Itcl_CanAccessFunc(
    ItclMemberFunc* imPtr,     /* member function being tested */
    Tcl_Namespace* fromNsPtr)  /* namespace requesting access */
{
    ItclClass *iclsPtr;
    ItclClass *fromIclsPtr;
    ItclMemberFunc *ovlfunc;
    Tcl_HashEntry *entry;

    /*
     *  Apply the usual rules first.
     */
    if (Itcl_CanAccess(imPtr, fromNsPtr)) {
        return 1;
    }

    /*
     *  As a last resort, see if the namespace is really a base
     *  class of the class containing the method.  Look for a
     *  method with the same name in the base class.  If there
     *  is one, then this method overrides it, and the base class
     *  has access.
     */
    if ((imPtr->flags & ITCL_COMMON) == 0 &&
            Itcl_IsClassNamespace(fromNsPtr)) {
        Tcl_HashEntry *hPtr;

        iclsPtr = imPtr->iclsPtr;
	hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses,
	        (char *)fromNsPtr);
	if (hPtr == NULL) {
	    return 0;
	}
        fromIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);

        if (Tcl_FindHashEntry(&iclsPtr->heritage, (char*)fromIclsPtr)) {
            entry = Tcl_FindHashEntry(&fromIclsPtr->resolveCmds,
                (char *)imPtr->namePtr);

            if (entry) {
		ItclCmdLookup *clookup;
		clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
		ovlfunc = clookup->imPtr;
                if ((ovlfunc->flags & ITCL_COMMON) == 0 &&
                     ovlfunc->protection < ITCL_PRIVATE) {
                    return 1;
                }
            }
        }
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DecodeScopedCommand()
 *
 *  Decodes a scoped command of the form:
 *
 *      namespace inscope <namesp> <command>
 *
 *  If the given string is not a scoped value, this procedure does
 *  nothing and returns TCL_OK.  If the string is a scoped value,
 *  then it is decoded, and the namespace, and the simple command
 *  string are returned as arguments; the simple command should
 *  be freed when no longer in use.  If anything goes wrong, this
 *  procedure returns TCL_ERROR, along with an error message in
 *  the interpreter.
 * ------------------------------------------------------------------------
 */
int
Itcl_DecodeScopedCommand(
    Tcl_Interp *interp,		/* current interpreter */
    const char *name,		/* string to be decoded */
    Tcl_Namespace **rNsPtr,	/* returns: namespace for scoped value */
    char **rCmdPtr)		/* returns: simple command word */
{
    Tcl_Namespace *nsPtr;
    char *cmdName;
    const char *pos;
    const char **listv;
    Tcl_Size listc;
    int result;
    size_t len;

    nsPtr = NULL;
    len = strlen(name);
    cmdName = (char *)ckalloc(strlen(name)+1);
    strcpy(cmdName, name);

    if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
	for (pos = (name + 9);  (*pos == ' ');  pos++) {
	    /* empty body: skip over spaces */
	}
	if ((*pos == 'i') && ((pos + 7) <= (name + len))
	        && (strncmp(pos, "inscope", 7) == 0)) {

            result = Tcl_SplitList(interp, (const char *)name, &listc,
		    &listv);
            if (result == TCL_OK) {
                if (listc != 4) {
                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "malformed command \"", name, "\": should be \"",
                        "namespace inscope namesp command\"",
                        NULL);
                    result = TCL_ERROR;
                } else {
                    nsPtr = Tcl_FindNamespace(interp, listv[2],
                        NULL, TCL_LEAVE_ERR_MSG);

                    if (nsPtr == NULL) {
                        result = TCL_ERROR;
                    } else {
		        ckfree(cmdName);
                        cmdName = (char *)ckalloc(strlen(listv[3])+1);
                        strcpy(cmdName, listv[3]);
                    }
                }
            }
            ckfree((char*)listv);

            if (result != TCL_OK) {
                Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
                        "\n    (while decoding scoped command \"%s\")",
                        name));
		ckfree(cmdName);
                return TCL_ERROR;
            }
	}
    }

    *rNsPtr = nsPtr;
    *rCmdPtr = cmdName;
    return TCL_OK;
}