itcl_cmds.c

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

    Tcl_Interp *interp;  /* interpreter to be updated */
{
    if (Initialize(interp) != TCL_OK) {
	return TCL_ERROR;
    }
    return Tcl_Eval(interp, safeInitScript);
}


/*
 * ------------------------------------------------------------------------
 *  ItclDelObjectInfo()
 *
 *  Invoked when the management info for [incr Tcl] is no longer being
 *  used in an interpreter.  This will only occur when all class
 *  manipulation commands are removed from the interpreter.
 * ------------------------------------------------------------------------
 */
static void
ItclDelObjectInfo(cdata)
    char* cdata;    /* client data for class command */
{
    ItclObjectInfo *info = (ItclObjectInfo*)cdata;

    ItclObject *contextObj;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;

    /*
     *  Destroy all known objects by deleting their access
     *  commands.
     */
    entry = Tcl_FirstHashEntry(&info->objects, &place);
    while (entry) {
        contextObj = (ItclObject*)Tcl_GetHashValue(entry);
        Tcl_DeleteCommandFromToken(info->interp, contextObj->accessCmd);
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&info->objects);

    /*
     *  Discard all known object contexts.
     */
    entry = Tcl_FirstHashEntry(&info->contextFrames, &place);
    while (entry) {
        Itcl_ReleaseData( Tcl_GetHashValue(entry) );
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&info->contextFrames);

    Itcl_DeleteStack(&info->transparentFrames);
    Itcl_DeleteStack(&info->cdefnStack);
    ckfree((char*)info);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_FindClassesCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::find classes"
 *  command to query the list of known classes.  Handles the following
 *  syntax:
 *
 *    find classes ?<pattern>?
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_FindClassesCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* class/object info */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
    Tcl_Namespace *globalNs = Tcl_GetGlobalNamespace(interp);
    int forceFullNames = 0;

    char *pattern;
    char *name;
    int i, newEntry, handledActiveNs;
    Tcl_HashTable unique;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    Itcl_Stack search;
    Tcl_Command cmd, originalCmd;
    Namespace *nsPtr;
    Tcl_Obj *listPtr, *objPtr;

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
        return TCL_ERROR;
    }

    if (objc == 2) {
        pattern = Tcl_GetStringFromObj(objv[1], (int*)NULL);
        forceFullNames = (strstr(pattern, "::") != NULL);
    } else {
        pattern = NULL;
    }

    /*
     *  Search through all commands in the current namespace first,
     *  in the global namespace next, then in all child namespaces
     *  in this interpreter.  If we find any commands that
     *  represent classes, report them.
     */
    listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);

    Itcl_InitStack(&search);
    Itcl_PushStack((ClientData)globalNs, &search);
    Itcl_PushStack((ClientData)activeNs, &search);  /* last in, first out! */

    Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS);

    handledActiveNs = 0;
    while (Itcl_GetStackSize(&search) > 0) {
        nsPtr = (Namespace*)Itcl_PopStack(&search);
        if (nsPtr == (Namespace*)activeNs && handledActiveNs) {
            continue;
        }

        entry = Tcl_FirstHashEntry(&nsPtr->cmdTable, &place);
        while (entry) {
            cmd = (Tcl_Command)Tcl_GetHashValue(entry);
            if (Itcl_IsClass(cmd)) {
                originalCmd = TclGetOriginalCommand(cmd);

                /*
                 *  Report full names if:
                 *  - the pattern has namespace qualifiers
                 *  - the class namespace is not in the current namespace
                 *  - the class's object creation command is imported from
                 *      another namespace.
                 *
                 *  Otherwise, report short names.
                 */
                if (forceFullNames || nsPtr != (Namespace*)activeNs ||
                    originalCmd != NULL) {

                    objPtr = Tcl_NewStringObj((char*)NULL, 0);
                    Tcl_GetCommandFullName(interp, cmd, objPtr);
                    name = Tcl_GetStringFromObj(objPtr, (int*)NULL);
                } else {
                    name = Tcl_GetCommandName(interp, cmd);
                    objPtr = Tcl_NewStringObj(name, -1);
                }

                if (originalCmd) {
                    cmd = originalCmd;
                }
                Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry);

                if (newEntry && (!pattern || Tcl_StringMatch(name, pattern))) {
                    Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
                        listPtr, objPtr);
                }
            }
            entry = Tcl_NextHashEntry(&place);
        }
        handledActiveNs = 1;  /* don't process the active namespace twice */

        /*
         *  Push any child namespaces onto the stack and continue
         *  the search in those namespaces.
         */
        entry = Tcl_FirstHashEntry(&nsPtr->childTable, &place);
        while (entry != NULL) {
            Itcl_PushStack(Tcl_GetHashValue(entry), &search);
            entry = Tcl_NextHashEntry(&place);
        }
    }
    Tcl_DeleteHashTable(&unique);
    Itcl_DeleteStack(&search);

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_FindObjectsCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::find objects"
 *  command to query the list of known objects.  Handles the following
 *  syntax:
 *
 *    find objects ?-class <className>? ?-isa <className>? ?<pattern>?
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
int
Itcl_FindObjectsCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* class/object info */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
    Tcl_Namespace *globalNs = Tcl_GetGlobalNamespace(interp);
    int forceFullNames = 0;

    char *pattern = NULL;
    ItclClass *classDefn = NULL;
    ItclClass *isaDefn = NULL;

    char *name, *token;
    int i, pos, newEntry, match, handledActiveNs;
    ItclObject *contextObj;
    Tcl_HashTable unique;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    Itcl_Stack search;
    Tcl_Command cmd, originalCmd;
    Namespace *nsPtr;
    Command *cmdPtr;
    Tcl_Obj *listPtr, *objPtr;

    /*
     *  Parse arguments:
     *  objects ?-class <className>? ?-isa <className>? ?<pattern>?
     */
    pos = 0;
    while (++pos < objc) {
        token = Tcl_GetStringFromObj(objv[pos], (int*)NULL);
        if (*token != '-') {
            if (!pattern) {
                pattern = token;
                forceFullNames = (strstr(pattern, "::") != NULL);
            } else {
                break;
            }
        }
        else if ((pos+1 < objc) && (strcmp(token,"-class") == 0)) {
            name = Tcl_GetStringFromObj(objv[pos+1], (int*)NULL);
            classDefn = Itcl_FindClass(interp, name, /* autoload */ 1);
            if (classDefn == NULL) {
                return TCL_ERROR;
            }
            pos++;
        }
        else if ((pos+1 < objc) && (strcmp(token,"-isa") == 0)) {
            name = Tcl_GetStringFromObj(objv[pos+1], (int*)NULL);
            isaDefn = Itcl_FindClass(interp, name, /* autoload */ 1);
            if (isaDefn == NULL) {
                return TCL_ERROR;
            }
            pos++;
        }

        /*
         * Last token? Take it as the pattern, even if it starts
         * with a "-".  This allows us to match object names that
         * start with "-".
         */
        else if (pos == objc-1 && !pattern) {
            pattern = token;
            forceFullNames = (strstr(pattern, "::") != NULL);
        }
        else {
            break;
        }
    }

    if (pos < objc) {
        Tcl_WrongNumArgs(interp, 1, objv,
            "?-class className? ?-isa className? ?pattern?");
        return TCL_ERROR;
    }

    /*
     *  Search through all commands in the current namespace first,
     *  in the global namespace next, then in all child namespaces
     *  in this interpreter.  If we find any commands that
     *  represent objects, report them.
     */
    listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);

    Itcl_InitStack(&search);
    Itcl_PushStack((ClientData)globalNs, &search);
    Itcl_PushStack((ClientData)activeNs, &search);  /* last in, first out! */

    Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS);

    handledActiveNs = 0;
    while (Itcl_GetStackSize(&search) > 0) {
        nsPtr = (Namespace*)Itcl_PopStack(&search);
        if (nsPtr == (Namespace*)activeNs && handledActiveNs) {
            continue;
        }

        entry = Tcl_FirstHashEntry(&nsPtr->cmdTable, &place);
        while (entry) {
            cmd = (Tcl_Command)Tcl_GetHashValue(entry);
            if (Itcl_IsObject(cmd)) {
                originalCmd = TclGetOriginalCommand(cmd);
                if (originalCmd) {
                    cmd = originalCmd;
                }
                cmdPtr = (Command*)cmd;
                contextObj = (ItclObject*)cmdPtr->objClientData;

                /*
                 *  Report full names if:
                 *  - the pattern has namespace qualifiers
                 *  - the class namespace is not in the current namespace
                 *  - the class's object creation command is imported from
                 *      another namespace.
                 *
                 *  Otherwise, report short names.
                 */
                if (forceFullNames || nsPtr != (Namespace*)activeNs ||
                    originalCmd != NULL) {

                    objPtr = Tcl_NewStringObj((char*)NULL, 0);
                    Tcl_GetCommandFullName(interp, cmd, objPtr);
                    name = Tcl_GetStringFromObj(objPtr, (int*)NULL);
                } else {
                    name = Tcl_GetCommandName(interp, cmd);
                    objPtr = Tcl_NewStringObj(name, -1);
                }

                Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry);

                match = 0;
                if (newEntry && (!pattern || Tcl_StringMatch(name, pattern))) {
                    if (!classDefn || (contextObj->classDefn == classDefn)) {
                        if (!isaDefn) {
                            match = 1;
                        } else {
                            entry = Tcl_FindHashEntry(
                                &contextObj->classDefn->heritage,
                                (char*)isaDefn);

                            if (entry) {
                                match = 1;
                            }
                        }
                    }
                }

                if (match) {
                    Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
                        listPtr, objPtr);
                } else {
                    Tcl_IncrRefCount(objPtr);  /* throw away the name */
                    Tcl_DecrRefCount(objPtr);
                }
            }
            entry = Tcl_NextHashEntry(&place);
        }
        handledActiveNs = 1;  /* don't process the active namespace twice */