itk_archetype.c

这是一个Linux下的集成开发环境

Itk_ArchInitOptsCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* unused */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    int newEntry, result;
    ArchInfo *info;
    ItclClass *contextClass;
    ItclObject *contextObj;
    Tcl_HashTable *objsWithArchInfo;
    Tcl_HashEntry *entry;
    Command *cmdPtr;

    if (objc != 1) {
        Tcl_WrongNumArgs(interp, 1, objv, "");
        return TCL_ERROR;
    }

    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
        !contextObj) {

        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot use \"", token, "\" without an object context",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Create some archetype info for the current object and
     *  register it on the list of all known objects.
     */
    objsWithArchInfo = ItkGetObjsWithArchInfo(interp);

    info = (ArchInfo*)ckalloc(sizeof(ArchInfo));
    info->itclObj = contextObj;
    info->tkwin = NULL;  /* not known yet */
    Tcl_InitHashTable(&info->components, TCL_STRING_KEYS);
    Tcl_InitHashTable(&info->options, TCL_STRING_KEYS);
    Itk_OptListInit(&info->order, &info->options);

    entry = Tcl_CreateHashEntry(objsWithArchInfo, (char*)contextObj, &newEntry);
    if (!newEntry) {
        Itk_DelArchInfo( Tcl_GetHashValue(entry) );
    }
    Tcl_SetHashValue(entry, (ClientData)info);

    /*
     *  Make sure that the access command for this object
     *  resides in the global namespace.  If need be, move
     *  the command.
     */
    result = TCL_OK;
    cmdPtr = (Command*)contextObj->accessCmd;

    if (cmdPtr->nsPtr != (Namespace*)Tcl_GetGlobalNamespace(interp)) {
        Tcl_Obj *oldNamePtr, *newNamePtr;

        oldNamePtr = Tcl_NewStringObj((char*)NULL, 0);
        Tcl_GetCommandFullName(interp, contextObj->accessCmd, oldNamePtr);
        Tcl_IncrRefCount(oldNamePtr);

        newNamePtr = Tcl_NewStringObj("::", -1);
        Tcl_AppendToObj(newNamePtr,
            Tcl_GetCommandName(interp, contextObj->accessCmd), -1);
        Tcl_IncrRefCount(newNamePtr);

        result = TclRenameCommand(interp,
            Tcl_GetStringFromObj(oldNamePtr, (int*)NULL),
            Tcl_GetStringFromObj(newNamePtr, (int*)NULL));

        Tcl_DecrRefCount(oldNamePtr);
        Tcl_DecrRefCount(newNamePtr);
    }

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_DelArchInfo()
 *
 *  Invoked when the option info associated with an itk::Archetype
 *  widget is no longer needed.  This usually happens when a widget
 *  is destroyed.  Frees the given bundle of data and removes it
 *  from the global list of Archetype objects.
 * ------------------------------------------------------------------------
 */
static void
Itk_DelArchInfo(cdata)
    ClientData cdata;    /* client data for Archetype objects */
{
    ArchInfo *info = (ArchInfo*)cdata;

    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    ArchOption *archOpt;
    ArchComponent *archComp;

    /*
     *  Destroy all component widgets.
     */
    entry = Tcl_FirstHashEntry(&info->components, &place);
    while (entry) {
        archComp = (ArchComponent*)Tcl_GetHashValue(entry);
        Itk_DelArchComponent(archComp);
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&info->components);

    /*
     *  Destroy all information associated with configuration options.
     */
    entry = Tcl_FirstHashEntry(&info->options, &place);
    while (entry) {
        archOpt = (ArchOption*)Tcl_GetHashValue(entry);
        Itk_DelArchOption(archOpt);
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&info->options);
    Itk_OptListFree(&info->order);

    ckfree((char*)info);
}


/*
 * ------------------------------------------------------------------------
 *  Itk_ArchDeleteOptsCmd()
 *
 *  Invoked by [incr Tcl] to handle the itk::Archetype::_deleteOptionInfo
 *  method.  This method should be called out in the destructor for each
 *  object, to clean up data allocated by Itk_ArchInitOptsCmd().
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
Itk_ArchDeleteOptsCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* unused */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclClass *contextClass;
    ItclObject *contextObj;
    Tcl_HashTable *objsWithArchInfo;
    Tcl_HashEntry *entry;

    if (objc != 1) {
        Tcl_WrongNumArgs(interp, 1, objv, "");
        return TCL_ERROR;
    }
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
        !contextObj) {

        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot use \"", token, "\" without an object context",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Find the info associated with this object.
     *  Destroy the data and remove it from the global list.
     */
    objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
    entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj);

    if (entry) {
        Itk_DelArchInfo( Tcl_GetHashValue(entry) );
        Tcl_DeleteHashEntry(entry);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_ArchComponentCmd()
 *
 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_component
 *  method.  Handles the following options:
 *
 *      itk_component add ?-protected? ?-private? ?--? <name> \
 *          <createCmds> ?<optionCmds>?
 *
 *      itk_component delete <name> ?<name>...?
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
Itk_ArchComponentCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* unused */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    char *cmd, *token, c;
    int length;

    /*
     *  Check arguments and handle the various options...
     */
    if (objc < 2) {
        cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be one of...\n",
            "  ", cmd, " add ?-protected? ?-private? ?--? name createCmds ?optionCmds?\n",
            "  ", cmd, " delete name ?name name...?",
            (char*)NULL);
        return TCL_ERROR;
    }

    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    c = *token;
    length = strlen(token);

    /*
     *  Handle:  itk_component add...
     */
    if (c == 'a' && strncmp(token, "add", length) == 0) {
        if (objc < 4) {
            Tcl_WrongNumArgs(interp, 1, objv,
                "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?");
            return TCL_ERROR;
        }
        return Itk_ArchCompAddCmd(dummy, interp, objc-1, objv+1);
    }

    /*
     *  Handle:  itk_component delete...
     */
    else if (c == 'd' && strncmp(token, "delete", length) == 0) {
        if (objc < 3) {
            Tcl_WrongNumArgs(interp, 1, objv, "delete name ?name name...?");
            return TCL_ERROR;
        }
        return Itk_ArchCompDeleteCmd(dummy, interp, objc-1, objv+1);
    }

    /*
     *  Flag any errors.
     */
    cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
        "bad option \"", token,
        "\": should be one of...\n",
        "  ", cmd, " add name createCmds ?optionCmds?\n",
        "  ", cmd, " delete name ?name name...?",
        (char*)NULL);
    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_ArchCompAddCmd()
 *
 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_component
 *  method.  Adds a new component widget into the mega-widget,
 *  integrating its configuration options into the master list.
 *
 *      itk_component add ?-protected? ?-private? ?--? <name> \
 *          <createCmds> <optionCmds>
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
Itk_ArchCompAddCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* unused */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Tcl_HashEntry *entry = NULL;
    char *path = NULL;
    ArchComponent *archComp = NULL;
    ArchMergeInfo *mergeInfo = NULL;
    Tcl_Obj *objNamePtr = NULL;
    Tcl_Obj *tmpNamePtr = NULL;
    Tcl_Obj *winNamePtr = NULL;
    Tcl_Obj *hullNamePtr = NULL;
    int pLevel = ITCL_PUBLIC;

    int newEntry, result;
    char *cmd, *token, *name, *resultStr;
    Tcl_Namespace *parserNs;
    ItclClass *contextClass, *ownerClass;
    ItclObject *contextObj;
    ArchInfo *info;
    Tcl_CallFrame frame, *uplevelFramePtr, *oldFramePtr;
    Tcl_Command accessCmd;
    Tcl_Obj *objPtr;
    Tcl_DString buffer;

    /*
     *  Get the Archetype info associated with this widget.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
        !contextObj) {

        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access components without an object context",
            (char*)NULL);
        return TCL_ERROR;
    }

    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Look for options like "-protected" or "-private".
     */
    cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);

    while (objc > 1) {
        token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
        if (*token != '-') {
            break;
        }
        else if (strcmp(token,"-protected") == 0) {
            pLevel = ITCL_PROTECTED;
        }
        else if (strcmp(token,"-private") == 0) {
            pLevel = ITCL_PRIVATE;
        }
        else if (strcmp(token,"--") == 0) {
            objc--;
            objv++;
            break;
        }
        else {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad option \"", token,
                "\": should be -private, -protected or --",
                (char*)NULL);
            return TCL_ERROR;
        }
        objc--;
        objv++;
    }

    if (objc < 3 || objc > 4) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be \"", cmd,
            " ?-protected? ?-private? ?--? name createCmds ?optionCmds?",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  See if a component already exists with the symbolic name.
     */
    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    entry = Tcl_CreateHashEntry(&info->components, name, &newEntry);
    if (!newEntry) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "component \"", name, "\" already defined",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  If this component is the "hull" for the mega-widget, then
     *  move the object access command out of the way before
     *  creating the component, so it is not accidentally deleted.
     */
    Tcl_DStringInit(&buffer);

    objNamePtr = Tcl_NewStringObj((char*)NULL, 0);
    Tcl_GetCommandFullName(contextObj->classDefn->interp,
        contextObj->accessCmd, objNamePtr);
    Tcl_IncrRefCount(objNamePtr);