itk_archetype.c

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

    Tcl_Obj *codePtr;

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

    /*
     *  Make sure that this command is being accessed in the
     *  proper context.  The merge info record should be set up
     *  properly.
     */
    if (!mergeInfo->archInfo || !mergeInfo->optionTable) {
        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "improper usage: \"", token,
            "\" should only be accessed via itk_component",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  If a tag name was specified, then use this to look up
     *  the "usual" code.  Otherwise, use the class name for
     *  the component widget.
     */
    if (objc == 2) {
        tag = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    } else {
        tag = Tk_Class(mergeInfo->archComp->tkwin);
    }

    /*
     *  Look for some code associated with the tag and evaluate
     *  it in the current context.
     */
    entry = Tcl_FindHashEntry(&mergeInfo->usualCode, tag);
    if (entry) {
        codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
      /* CYGNUS LOCAL - Fix for Tcl8.1 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
        return Tcl_EvalObj(interp, codePtr, 0);
#else
        return Tcl_EvalObj(interp, codePtr);
#endif
      /* END CYGNUS LOCAL */
    }

    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
        "can't find usual code for tag \"", tag, "\"",
        (char*)NULL);
    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_UsualCmd()
 *
 *  Invoked by [incr Tcl] to handle the "usual" command in the ::itk
 *  namespace.  Used to query or set the option-handling code associated
 *  with a widget class or arbitrary tag name.  This code is later
 *  used by the "usual" command in the "itk::option-parser" namespace.
 *
 *  Handles the following syntax:
 *
 *      usual ?<tag>? ?<code>?
 *
 *  If the <tag> is not specified, then this returns a list of all
 *  known tags.  If the <code> is not specified, then this returns
 *  the current code associated with <tag>, or an empty string if
 *  <tag> is not recognized.  Otherwise, it sets the code fragment
 *  for <tag> to <code>.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itk_UsualCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* option merging info record */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)clientData;

    int newEntry;
    char *tag, *token;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    Tcl_Obj *codePtr;

    if (objc > 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "?tag? ?commands?");
        return TCL_ERROR;
    }

    /*
     *  If no arguments were specified, then return a list of
     *  all known tags.
     */
    if (objc == 1) {
        entry = Tcl_FirstHashEntry(&mergeInfo->usualCode, &place);
        while (entry) {
            tag = Tcl_GetHashKey(&mergeInfo->usualCode, entry);
            Tcl_AppendElement(interp, tag);
            entry = Tcl_NextHashEntry(&place);
        }
        return TCL_OK;
    }

    /*
     *  If a code fragment was specified, then save it in the
     *  hash table for "usual" code.
     */
    else if (objc == 3) {
        token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
        entry = Tcl_CreateHashEntry(&mergeInfo->usualCode, token, &newEntry);
        if (!newEntry) {
            codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
            Tcl_DecrRefCount(codePtr);
        }

        codePtr = objv[2];
        Tcl_IncrRefCount(codePtr);
        Tcl_SetHashValue(entry, (ClientData)codePtr);

        return TCL_OK;
    }

    /*
     *  Otherwise, look for a code fragment with the specified tag.
     */
    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    entry = Tcl_FindHashEntry(&mergeInfo->usualCode, token);
    if (entry) {
        codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
        Tcl_SetObjResult(interp, codePtr);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_ArchInitCmd()
 *
 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_initialize
 *  method.  This method should be called out in the constructor for
 *  each mega-widget class, to build the composite option list at
 *  each class level.  Handles the following syntax:
 *
 *      itk_initialize ?-option val -option val...?
 *
 *  Integrates any class-based options into the composite option list,
 *  handles option settings from the command line, and then configures
 *  all options to have the proper initial value.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
Itk_ArchInitCmd(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, *cdefn;
    ItclObject *contextObj;
    ArchInfo *info;

    int i, result;
    char *token, *val;
    Tcl_CallFrame *framePtr;
    ItkClassOption *opt;
    ItkClassOptTable *optTable;
    Itcl_ListElem *part;
    ArchOption *archOpt;
    ArchOptionPart *optPart;
    ItclHierIter hier;
    ItclVarDefn *vdefn;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;

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

        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "improper usage: should be \"object ",
            token, " ?-option value -option value...?\"",
            (char*)NULL);
        return TCL_ERROR;
    }

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

    /*
     *  See what class is being initialized by getting the namespace
     *  for the calling context.
     */
    framePtr = _Tcl_GetCallFrame(interp, 1);
    if (framePtr && Itcl_IsClassNamespace(framePtr->nsPtr)) {
        contextClass = (ItclClass*)framePtr->nsPtr->clientData;
    }

    /*
     *  Integrate all public variables for the current class
     *  context into the composite option list.
     */
    Itcl_InitHierIter(&hier, contextClass);
    while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
        entry = Tcl_FirstHashEntry(&cdefn->variables, &place);
        while (entry) {
            vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);

            if (vdefn->member->protection == ITCL_PUBLIC) {
                optPart = Itk_FindArchOptionPart(info,
                    vdefn->member->name, (ClientData)vdefn);

                if (!optPart) {
                    optPart = Itk_CreateOptionPart(interp, (ClientData)vdefn,
                        Itk_PropagatePublicVar, (Tcl_CmdDeleteProc*)NULL,
                        (ClientData)vdefn);

                    val = Itcl_GetInstanceVar(interp, vdefn->member->fullname,
                        contextObj, contextObj->classDefn);

                    result = Itk_AddOptionPart(interp, info,
                        vdefn->member->name, (char*)NULL, (char*)NULL,
                        val, (char*)NULL, optPart, &archOpt);

                    if (result != TCL_OK) {
                        Itk_DelOptionPart(optPart);
                        return TCL_ERROR;
                    }
                }
            }
            entry = Tcl_NextHashEntry(&place);
        }
    }
    Itcl_DeleteHierIter(&hier);

    /*
     *  Integrate all class-based options for the current class
     *  context into the composite option list.
     */
    optTable = Itk_FindClassOptTable(contextClass);
    if (optTable) {
        for (i=0; i < optTable->order.len; i++) {
            opt = (ItkClassOption*)Tcl_GetHashValue(optTable->order.list[i]);

            optPart = Itk_FindArchOptionPart(info, opt->member->name,
                (ClientData)contextClass);

            if (!optPart) {
                optPart = Itk_CreateOptionPart(interp, (ClientData)opt,
                    Itk_ConfigClassOption, (Tcl_CmdDeleteProc*)NULL,
                    (ClientData)contextClass);

                result = Itk_AddOptionPart(interp, info,
                    opt->member->name, opt->resName, opt->resClass,
                    opt->init, (char*)NULL, optPart, &archOpt);

                if (result != TCL_OK) {
                    Itk_DelOptionPart(optPart);
                    return TCL_ERROR;
                }
            }
        }
    }

    /*
     *  If any option values were specified on the command line,
     *  override the current option settings.
     */
    if (objc > 1) {
        for (objc--,objv++; objc > 0; objc-=2, objv+=2) {
            token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
            if (objc < 2) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "value for \"", token, "\" missing",
                    (char*)NULL);
                return TCL_ERROR;
            }

            val = Tcl_GetStringFromObj(objv[1], (int*)NULL);
            if (Itk_ArchConfigOption(interp, info, token, val) != TCL_OK) {
                return TCL_ERROR;
            }
        }
    }

    /*
     *  If this is most-specific class, then finish constructing
     *  the mega-widget:
     *
     *  Scan through all options in the composite list and
     *  look for any that have been set but not initialized.
     *  Invoke the parts of uninitialized options to propagate
     *  changes and update the widget.
     */
    if (contextObj->classDefn == contextClass) {
        for (i=0; i < info->order.len; i++) {
            archOpt = (ArchOption*)Tcl_GetHashValue(info->order.list[i]);

            if ((archOpt->flags & ITK_ARCHOPT_INIT) == 0) {
                val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);

                if (!val) {
                    Itk_ArchOptAccessError(interp, info, archOpt);
                    return TCL_ERROR;
                }

                part = Itcl_FirstListElem(&archOpt->parts);
                while (part) {
                    optPart = (ArchOptionPart*)Itcl_GetListValue(part);
                    result  = (*optPart->configProc)(interp, contextObj,
                        optPart->clientData, val);

                    if (result != TCL_OK) {
                        Itk_ArchOptConfigError(interp, info, archOpt);
                        return result;
                    }
                    part = Itcl_NextListElem(part);
                }
                archOpt->flags |= ITK_ARCHOPT_INIT;
            }
        }
    }

    Tcl_ResetResult(interp);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itk_ArchOptionCmd()
 *
 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_option
 *  method.  Handles the following options:
 *
 *      itk_option define <switch> <resName> <resClass> <init> ?<config>?
 *      itk_option add <name> ?<name>...?
 *      itk_option remove <name> ?<name>...?
 *
 *  These commands customize the options list of a specific widget.
 *  They are similar to the "itk_option" ensemble in the class definition
 *  parser, but manipulate a single instance instead of an entire class.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
Itk_ArchOptionCmd(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 name ?name name...?\n",
            "  ", cmd, " define -switch resourceName resourceClass init ?config?\n",
            "  ", cmd, " remove name ?name name...?",
            (char*)NULL);
        return