itk_archetype.c

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

    if (strcmp(name, "hull") == 0) {
        tmpNamePtr = Tcl_NewStringObj((char*)NULL, 0);
        Tcl_GetCommandFullName(contextObj->classDefn->interp,
            contextObj->accessCmd, tmpNamePtr);
        Tcl_AppendToObj(tmpNamePtr, "-widget-", -1);
        Tcl_IncrRefCount(tmpNamePtr);
        
        result = TclRenameCommand(interp,
            Tcl_GetStringFromObj(objNamePtr, (int*)NULL),
            Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL));

        if (result != TCL_OK) {
            goto compFail;
        }
    }

    /*
     *  Execute the <createCmds> to create the component widget.
     *  Do this one level up, in the scope of the calling routine.
     */
    uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
    oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr);

      /* CYGNUS LOCAL - Fix for Tcl8.1 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
    if (Tcl_EvalObj(interp, objv[2], 0) != TCL_OK) {
#else
    if (Tcl_EvalObj(interp, objv[2]) != TCL_OK) {
#endif
      /* END CYGNUS LOCAL */
        goto compFail;
    }

    /*
     *  Take the result from the widget creation commands as the
     *  path name for the new component.  Make a local copy of
     *  this, since the interpreter will get used in the mean time.
     */
    resultStr = Tcl_GetStringResult(interp);
    path = (char*)ckalloc((unsigned)(strlen(resultStr)+1));
    strcpy(path, resultStr);

    /*
     *  Look for the access command token in the context of the
     *  calling namespace.  By-pass any protection at this point.
     */
    accessCmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL,
        /* flags */ 0);

    if (!accessCmd) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
           "cannot find component access command \"",
            path, "\" for component \"", name, "\"",
            (char*)NULL);
        goto compFail;
    }

    winNamePtr = Tcl_NewStringObj((char*)NULL, 0);
    Tcl_GetCommandFullName(interp, accessCmd, winNamePtr);
    Tcl_IncrRefCount(winNamePtr);

    (void) _Tcl_ActivateCallFrame(interp, oldFramePtr);

    /*
     *  Create the component record.  Set the protection level
     *  according to the "-protected" or "-private" option.
     */
    ownerClass = contextClass;
    uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
    if (uplevelFramePtr && Itcl_IsClassNamespace(uplevelFramePtr->nsPtr)) {
        ownerClass = (ItclClass*)uplevelFramePtr->nsPtr->clientData;
    }

    archComp = Itk_CreateArchComponent(interp, info, name, ownerClass,
        accessCmd);

    if (!archComp) {
        goto compFail;
    }

    Tcl_SetHashValue(entry, (ClientData)archComp);
    archComp->member->protection = pLevel;

    /*
     *  If this component is the "hull" for the mega-widget, then
     *  move the hull widget access command to a different name,
     *  and move the object access command back into place.  This
     *  way, when the widget name is used as a command, the object
     *  access command will handle all requests.
     */
    if (strcmp(name, "hull") == 0) {
        hullNamePtr = Tcl_NewStringObj((char*)NULL, 0);
        Tcl_GetCommandFullName(interp, accessCmd, hullNamePtr);
        Tcl_AppendToObj(hullNamePtr, "-itk_hull", -1);
        Tcl_IncrRefCount(hullNamePtr);

        result = TclRenameCommand(interp,
            Tcl_GetStringFromObj(winNamePtr, (int*)NULL),
            Tcl_GetStringFromObj(hullNamePtr, (int*)NULL));

        if (result != TCL_OK) {
            goto compFail;
        }

        Tcl_DecrRefCount(winNamePtr);  /* winNamePtr keeps current name */
        winNamePtr = hullNamePtr;
        hullNamePtr = NULL;

        result = TclRenameCommand(interp,
            Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL),
            Tcl_GetStringFromObj(objNamePtr, (int*)NULL));

        if (result != TCL_OK) {
            goto compFail;
        }
    }

    /*
     *  Add a binding onto the new component, so that when its
     *  window is destroyed, it will automatically remove itself
     *  from its parent's component list.  Avoid doing these things
     *  for the "hull" component, since it is a special case and
     *  these things are not really necessary.
     */
    else {
        Tcl_DStringSetLength(&buffer, 0);
        Tcl_DStringAppend(&buffer, "bindtags ", -1);
        Tcl_DStringAppend(&buffer, path, -1);
        if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) {
            goto compFail;
        }

        Tcl_DStringSetLength(&buffer, 0);
        Tcl_DStringAppend(&buffer, "bind itk-destroy-", -1);
        Tcl_DStringAppend(&buffer, path, -1);
        Tcl_DStringAppend(&buffer, " <Destroy> [itcl::code ", -1);

        Tcl_DStringAppend(&buffer,
            Tcl_GetStringFromObj(objNamePtr,(int*)NULL), -1);

        Tcl_DStringAppend(&buffer, " itk_component delete ", -1);
        Tcl_DStringAppend(&buffer, name, -1);
        Tcl_DStringAppend(&buffer, "]\n", -1);
        Tcl_DStringAppend(&buffer, "bindtags ", -1);
        Tcl_DStringAppend(&buffer, path, -1);
        Tcl_DStringAppend(&buffer, " {itk-destroy-", -1);
        Tcl_DStringAppend(&buffer, path, -1);
        Tcl_DStringAppend(&buffer, " ", -1);
        Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1);
        Tcl_DStringAppend(&buffer, "}", -1);
        if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) {
            goto compFail;
        }
    }

    /*
     *  Query the list of configuration options for this widget,
     *  so we will know which ones are valid.  Build an option
     *  table to represent these, so they can be found quickly
     *  by the option parsing commands in "itk::option-parser".
     */
    Tcl_DStringTrunc(&buffer, 0);
    Tcl_DStringAppendElement(&buffer,
        Tcl_GetStringFromObj(winNamePtr, (int*)NULL));
    Tcl_DStringAppendElement(&buffer, "configure");

    result = Tcl_Eval(interp, Tcl_DStringValue(&buffer));

    if (result != TCL_OK) {
        goto compFail;
    }
    Tcl_DStringSetLength(&buffer, 0);
    Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1);

    /*
     *  Find the "itk::option-parser" namespace and get the data
     *  record shared by all of the parsing commands.
     */
    parserNs = Tcl_FindNamespace(interp, "::itk::option-parser",
        (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);

    if (!parserNs) {
        goto compFail;
    }
    mergeInfo = (ArchMergeInfo*)parserNs->clientData;
    assert(mergeInfo);

    /*
     *  Initialize the data record used by the option parsing commands.
     *  Store a table of valid configuration options, along with the
     *  info for the mega-widget that is being updated.
     */
    mergeInfo->optionTable = Itk_CreateGenericOptTable(interp,
        Tcl_DStringValue(&buffer));

    if (!mergeInfo->optionTable) {
        goto compFail;
    }
    mergeInfo->archInfo = info;
    mergeInfo->archComp = archComp;

    /*
     *  Execute the option-handling commands in the "itk::option-parser"
     *  namespace.  If there are no option-handling commands, invoke
     *  the "usual" command instead.
     */
    if (objc != 4) {
        objPtr = Tcl_NewStringObj("usual", -1);
        Tcl_IncrRefCount(objPtr);
    } else {
        objPtr = objv[3];
    }

    result = Tcl_PushCallFrame(interp, &frame,
        parserNs, /* isProcCallFrame */ 0);

    if (result == TCL_OK) {
      /* CYGNUS LOCAL - Fix for Tcl8.1 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
      result = Tcl_EvalObj(interp, objPtr, 0);
#else
      result = Tcl_EvalObj(interp, objPtr);
#endif
      /* END CYGNUS LOCAL */
      Tcl_PopCallFrame(interp);
    }

    if (objPtr != objv[3]) {
        Tcl_DecrRefCount(objPtr);
    }
    if (result != TCL_OK) {
        goto compFail;
    }

    Itk_DelGenericOptTable(mergeInfo->optionTable);
    mergeInfo->optionTable = NULL;
    mergeInfo->archInfo    = NULL;
    mergeInfo->archComp    = NULL;

    ckfree(path);

    Tcl_DStringFree(&buffer);
    if (objNamePtr) {
        Tcl_DecrRefCount(objNamePtr);
    }
    if (tmpNamePtr) {
        Tcl_DecrRefCount(tmpNamePtr);
    }
    if (winNamePtr) {
        Tcl_DecrRefCount(winNamePtr);
    }
    if (hullNamePtr) {
        Tcl_DecrRefCount(hullNamePtr);
    }

    Tcl_SetResult(interp, name, TCL_VOLATILE);
    return TCL_OK;

    /*
     *  If any errors were encountered, clean up and return.
     */
compFail:
    if (archComp) {
        Itk_DelArchComponent(archComp);
    }
    if (entry) {
        Tcl_DeleteHashEntry(entry);
    }
    if (path) {
        ckfree(path);
    }
    if (mergeInfo && mergeInfo->optionTable) {
        Itk_DelGenericOptTable(mergeInfo->optionTable);
        mergeInfo->optionTable = NULL;
        mergeInfo->archInfo    = NULL;
        mergeInfo->archComp    = NULL;
    }

    Tcl_DStringFree(&buffer);
    if (objNamePtr) {
        Tcl_DecrRefCount(objNamePtr);
    }
    if (tmpNamePtr) {
        Tcl_DecrRefCount(tmpNamePtr);
    }
    if (winNamePtr) {
        Tcl_DecrRefCount(winNamePtr);
    }
    if (hullNamePtr) {
        Tcl_DecrRefCount(hullNamePtr);
    }

    /*
     *  Add error info and return.
     */
    objPtr = Tcl_NewStringObj((char*)NULL, 0);
    Tcl_AppendToObj(objPtr, "\n    (while creating component \"", -1);
    Tcl_AppendToObj(objPtr, name, -1);
    Tcl_AppendToObj(objPtr, "\" for widget \"", -1);
    Tcl_GetCommandFullName(contextObj->classDefn->interp,
        contextObj->accessCmd, objPtr);
    Tcl_AppendToObj(objPtr, "\")", -1);
    Tcl_IncrRefCount(objPtr);

    Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
    Tcl_DecrRefCount(objPtr);


    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_ArchCompDeleteCmd()
 *
 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_component
 *  method.  Removes an existing component widget from a mega-widget,
 *  and removes any configuration options associated with it.
 *
 *      itk_component delete <name> ?<name> <name>...?
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
Itk_ArchCompDeleteCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* unused */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    int i;
    char *token;
    ItclClass *contextClass;
    ItclObject *contextObj;
    ArchInfo *info;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    Itcl_ListElem *elem;
    ArchComponent *archComp;
    ArchOption *archOpt;
    ArchOptionPart *optPart;
    Itcl_List delOptList;
    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;
    }

    /*
     *  Scan through the list of component names and delete each
     *  one.  Make sure that each component exists.
     */
    for (i=1; i < objc; i++) {
        token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
        entry = Tcl_FindHashEntry(&info->components, token);
        if (!entry) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "name \"", token, "\" is not a component",
                (char*)NULL);
            return TCL_ERROR;
        }
        archComp = (ArchComponent*)Tcl_GetHashValue(entry);

       /*
        *  Clean up the binding tag that causes the widget to
        *  call this method automatically when destroyed.
        *  Ignore errors if anything goes wrong.
        */
        Tcl_DStringInit(&buffer);
        Tcl_DStringAppend(&buffer, "itk::remove_destroy_hook ", -1);
        Tcl_DStringAppend(&buffer, archComp->pathName, -1);