itcl_util.c

linux 下的源代码分析阅读器 red hat公司新版

 */
Itcl_ListElem*
Itcl_AppendListElem(pos,val)
    Itcl_ListElem *pos;     /* insert just after this element */
    ClientData 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(elemPtr,val)
    Itcl_ListElem *elemPtr; /* list element being modified */
    ClientData val;         /* new value associated with element */
{
    Itcl_List *listPtr = elemPtr->owner;
    assert(listPtr->validate == ITCL_VALID_LIST);
    assert(elemPtr != NULL);

    elemPtr->value = val;
}


/*
 * ========================================================================
 *  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 use
 *  a hash table instead of a linked list to maintain the references,
 *  so they scale better.  Also, the Tcl procedures have a bad behavior
 *  during the "exit" command.  Their exit handler shuts them down
 *  when other data is still being reference-counted and cleaned up.
 *
 * ------------------------------------------------------------------------
 *  Itcl_EventuallyFree()
 *
 *  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".
 *  Future calls to Itcl_PreserveData() increase this usage count, and
 *  calls to Itcl_ReleaseData() decrease the count until it reaches
 *  zero and the data is freed.
 * ------------------------------------------------------------------------
 */
void
Itcl_EventuallyFree(cdata, fproc)
    ClientData cdata;          /* data to be freed when not in use */
    Tcl_FreeProc *fproc;       /* procedure called to free data */
{
    int newEntry;
    Tcl_HashEntry *entry;
    ItclPreservedData *chunk;

    /*
     *  If the clientData value is NULL, do nothing.
     */
    if (cdata == NULL) {
        return;
    }

    /*
     *  If a list has not yet been created to manage bits of
     *  preserved data, then create it.
     */
    if (!ItclPreservedList) {
        ItclPreservedList = (Tcl_HashTable*)ckalloc(
            (unsigned)sizeof(Tcl_HashTable)
        );
        Tcl_InitHashTable(ItclPreservedList, TCL_ONE_WORD_KEYS);
    }

    /*
     *  Find or create the data in the global list.
     */
    entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
    if (newEntry) {
        chunk = (ItclPreservedData*)ckalloc(
            (unsigned)sizeof(ItclPreservedData)
        );
        chunk->data  = cdata;
        chunk->usage = 0;
        chunk->fproc = fproc;
        Tcl_SetHashValue(entry, (ClientData)chunk);
    }
    else {
        chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
        chunk->fproc = fproc;
    }

    /*
     *  If the usage count is zero, then delete the data now.
     */
    if (chunk->usage == 0) {
        chunk->usage = -1;  /* cannot preserve/release anymore */

        (*chunk->fproc)((char*)chunk->data);
        Tcl_DeleteHashEntry(entry);
        ckfree((char*)chunk);
    }
}

/*
 * ------------------------------------------------------------------------
 *  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(cdata)
    ClientData cdata;      /* data to be preserved */
{
    Tcl_HashEntry *entry;
    ItclPreservedData *chunk;
    int newEntry;

    /*
     *  If the clientData value is NULL, do nothing.
     */
    if (cdata == NULL) {
        return;
    }

    /*
     *  If a list has not yet been created to manage bits of
     *  preserved data, then create it.
     */
    if (!ItclPreservedList) {
        ItclPreservedList = (Tcl_HashTable*)ckalloc(
            (unsigned)sizeof(Tcl_HashTable)
        );
        Tcl_InitHashTable(ItclPreservedList,TCL_ONE_WORD_KEYS);
    }

    /*
     *  Find the data in the global list and bump its usage count.
     */
    entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry);
    if (newEntry) {
        chunk = (ItclPreservedData*)ckalloc(
            (unsigned)sizeof(ItclPreservedData)
        );
        chunk->data  = cdata;
        chunk->usage = 0;
        chunk->fproc = NULL;
        Tcl_SetHashValue(entry, (ClientData)chunk);
    }
    else {
        chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
    }

    /*
     *  Only increment the usage if it is non-negative.
     *  Negative numbers mean that the data is in the process
     *  of being destroyed by Itcl_ReleaseData(), and should
     *  not be further preserved.
     */
    if (chunk->usage >= 0) {
        chunk->usage++;
    }
}

/*
 * ------------------------------------------------------------------------
 *  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(cdata)
    ClientData cdata;      /* data to be released */
{
    Tcl_HashEntry *entry;
    ItclPreservedData *chunk;

    /*
     *  If the clientData value is NULL, do nothing.
     */
    if (cdata == NULL) {
        return;
    }

    /*
     *  Otherwise, find the data in the global list and
     *  decrement its usage count.
     */
    entry = NULL;
    if (ItclPreservedList) {
        entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata);
    }
    if (!entry) {
        panic("Itcl_ReleaseData can't find reference for 0x%x", cdata);
    }

    /*
     *  Only decrement the usage if it is non-negative.
     *  When the usage reaches zero, set it to a negative number
     *  to indicate that data is being destroyed, and then
     *  invoke the client delete proc.  When the data is deleted,
     *  remove the entry from the preservation list.
     */
    chunk = (ItclPreservedData*)Tcl_GetHashValue(entry);
    if (chunk->usage > 0 && --chunk->usage == 0) {

        if (chunk->fproc) {
            chunk->usage = -1;  /* cannot preserve/release anymore */
            (*chunk->fproc)((char*)chunk->data);
        }

        Tcl_DeleteHashEntry(entry);
        ckfree((char*)chunk);
    }
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, status)
    Tcl_Interp* interp;     /* interpreter being modified */
    int status;             /* integer status code for current operation */
{
    Interp *iPtr = (Interp*)interp;

    InterpState *info;
    char *val;

    info = (InterpState*)ckalloc(sizeof(InterpState));
    info->validate = TCL_STATE_VALID;
    info->status = status;
    info->errorInfo = NULL;
    info->errorCode = NULL;

    /*
     *  Get the result object from the interpreter.  This synchronizes
     *  the old-style result, so we don't have to worry about it.
     *  Keeping the object result is enough.
     */
    info->objResult = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(info->objResult);

    /*
     *  If an error is in progress, preserve its state.
     */
    if ((iPtr->flags & ERR_IN_PROGRESS) != 0) {
        val = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
        if (val) {
            info->errorInfo = ckalloc((unsigned)(strlen(val)+1));
            strcpy(info->errorInfo, val);
        }

        val = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
        if (val) {
            info->errorCode = ckalloc((unsigned)(strlen(val)+1));
            strcpy(info->errorCode, val);
        }
    }

    /*
     *  Now, reset the interpreter to a clean state.
     */
    Tcl_ResetResult(interp);

    return (Itcl_InterpState)info;
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, state)
    Tcl_Interp* interp;       /* interpreter being modified */
    Itcl_InterpState state;   /* token representing interpreter state */
{
    Interp *iPtr = (Interp*)interp;
    InterpState *info = (InterpState*)state;
    int status;

    if (info->validate != TCL_STATE_VALID) {
        panic("bad token in Itcl_RestoreInterpState");
    }
    Tcl_ResetResult(interp);

    /*
     *  If an error is in progress, restore its state.
     *  Set the error code the hard way--set the variable directly
     *  and fix the interpreter flags.  Otherwise, if the error code
     *  string is really a list, it will get wrapped in extra {}'s.
     */
    if (info->errorInfo) {
        Tcl_AddErrorInfo(interp, info->errorInfo);
        ckfree(info->errorInfo);
    }

    if (info->errorCode) {
        (void) Tcl_SetVar2(interp, "errorCode", (char*)NULL,
            info->errorCode, TCL_GLOBAL_ONLY);
        iPtr->flags |= ERROR_CODE_SET;

        ckfree(info->errorCode);
    }

    /*
     *  Assign the object result back to the interpreter, then
     *  release our hold on it.
     */
    Tcl_SetObjResult(interp, info->objResult);
    Tcl_DecrRefCount(info->objResult);

    status = info->status;
    info->validate = 0;
    ckfree((char*)info);

    return status;
}


/*
 * ------------------------------------------------------------------------
 *  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(state)
    Itcl_InterpState state;  /* token representing interpreter state */
{
    InterpState *info = (InterpState*)state;

    if (info->validate != TCL_STATE_VALID) {
        panic("bad token in Itcl_DiscardInterpState");
    }

    if (info->errorInfo) {
        ckfree(info->errorInfo);
    }
    if (info->errorCode) {
        ckfree(info->errorCode);
    }
    Tcl_DecrRefCount(info->objResult);

    info->validate = 0;
    ckfree((char*)info);
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, newLevel)
    Tcl_Interp *interp;  /* interpreter being queried */
    int newLevel;        /* new protection level or 0 */
{
    int oldVal;
    ItclObjectInfo *info;

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

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

    if (newLevel != 0) {
        assert(newLevel == ITCL_PUBLIC ||
            newLevel == ITCL_PROTECTED ||
            newLevel == ITCL_PRIVATE ||
            newLevel == ITCL_DEFAULT_PROTECT);
        info->protection = newLevel;
    }
    return oldVal;
}