itcl_ensemble.c

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

        status = Tcl_EvalObj(ensInfo->parser, objPtr);
#endif
	/* END CYGNUS LOCAL */
        Tcl_DecrRefCount(objPtr);  /* we're done with the object */
    }

    /*
     *  Copy the result from the parser interpreter to the
     *  master interpreter.  If an error was encountered,
     *  copy the error info first, and then set the result.
     *  Otherwise, the offending command is reported twice.
     */
    if (status == TCL_ERROR) {
        char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo",
            (char*)NULL, TCL_GLOBAL_ONLY);

        if (errInfo) {
            Tcl_AddObjErrorInfo(interp, errInfo, -1);
        }

        if (objc == 3) {
            char msg[128];
            sprintf(msg, "\n    (\"ensemble\" body line %d)",
                ensInfo->parser->errorLine);
            Tcl_AddObjErrorInfo(interp, msg, -1);
        }
    }
    Tcl_SetObjResult(interp, Tcl_GetObjResult(ensInfo->parser));

    ensInfo->ensData = savedEnsData;
    return status;
}


/*
 *----------------------------------------------------------------------
 *
 * GetEnsembleParser --
 *
 *      Returns the slave interpreter that acts as a parser for
 *      the body of an "ensemble" definition.  The first time that
 *      this is called for an interpreter, the parser is created
 *      and registered as associated data.  After that, it is
 *      simply returned.
 *
 * Results:
 *      Returns a pointer to the ensemble parser data structure.
 *
 * Side effects:
 *      On the first call, the ensemble parser is created and
 *      registered as "itcl_ensembleParser" with the interpreter.
 *
 *----------------------------------------------------------------------
 */
static EnsembleParser*
GetEnsembleParser(interp)
    Tcl_Interp *interp;     /* interpreter handling the ensemble */
{
    Namespace *nsPtr;
    Tcl_Namespace *childNs;
    EnsembleParser *ensInfo;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_Command cmd;

    /*
     *  Look for an existing ensemble parser.  If it is found,
     *  return it immediately.
     */
    ensInfo = (EnsembleParser*) Tcl_GetAssocData(interp,
        "itcl_ensembleParser", NULL);

    if (ensInfo) {
        return ensInfo;
    }

    /*
     *  Create a slave interpreter that can be used to parse
     *  the body of an ensemble definition.
     */
    ensInfo = (EnsembleParser*)ckalloc(sizeof(EnsembleParser));
    ensInfo->master = interp;
    ensInfo->parser = Tcl_CreateInterp();
    ensInfo->ensData = NULL;

    /*
     *  Remove all namespaces and all normal commands from the
     *  parser interpreter.
     */
    nsPtr = (Namespace*)Tcl_GetGlobalNamespace(ensInfo->parser);

    for (hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
         hPtr != NULL;
         hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {

        childNs = (Tcl_Namespace*)Tcl_GetHashValue(hPtr);
        Tcl_DeleteNamespace(childNs);
    }

    for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
         hPtr != NULL;
         hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {

        cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
        Tcl_DeleteCommandFromToken(ensInfo->parser, cmd);
    }

    /*
     *  Add the allowed commands to the parser interpreter:
     *  part, delete, ensemble
     */
    Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd,
        (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd,
        (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd,
        (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL);

    /*
     *  Install the parser data, so we'll have it the next time
     *  we call this procedure.
     */
    (void) Tcl_SetAssocData(interp, "itcl_ensembleParser",
            DeleteEnsParser, (ClientData)ensInfo);

    return ensInfo;
}


/*
 *----------------------------------------------------------------------
 *
 * DeleteEnsParser --
 *
 *      Called when an interpreter is destroyed to clean up the
 *      ensemble parser within it.  Destroys the slave interpreter
 *      and frees up the data associated with it.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
static void
DeleteEnsParser(clientData, interp)
    ClientData clientData;    /* client data for ensemble-related commands */
    Tcl_Interp *interp;       /* interpreter containing the data */
{
    EnsembleParser* ensInfo = (EnsembleParser*)clientData;
    Tcl_DeleteInterp(ensInfo->parser);
    ckfree((char*)ensInfo);
}


/*
 *----------------------------------------------------------------------
 *
 * Itcl_EnsPartCmd --
 *
 *      Invoked by Tcl whenever the user issues the "part" command
 *      to manipulate an ensemble.  This command can only be used
 *      inside the "ensemble" command, which handles ensembles.
 *      Handles the following syntax:
 *
 *        ensemble <ensName> {
 *            part <partName> <args> <body>
 *        }
 *
 *      Adds a new part called <partName> to the ensemble.  If a
 *      part already exists with that name, it is an error.  The
 *      new part is handled just like an ordinary Tcl proc, with
 *      a list of <args> and a <body> of code to execute.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything
 *      goes wrong.
 *
 * Side effects:
 *      If anything goes wrong, this procedure returns an error
 *      message as the result in the interpreter.
 *
 *----------------------------------------------------------------------
 */
int
Itcl_EnsPartCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* ensemble data */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    EnsembleParser *ensInfo = (EnsembleParser*)clientData;
    Ensemble *ensData = (Ensemble*)ensInfo->ensData;

    int status, varArgs, space;
    char *partName, *usage;
    Proc *procPtr;
    Command *cmdPtr;
    CompiledLocal *localPtr;
    EnsemblePart *ensPart;
    Tcl_DString buffer;

    if (objc != 4) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be \"",
            Tcl_GetStringFromObj(objv[0], (int*)NULL),
            " name args body\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Create a Tcl-style proc definition using the specified args
     *  and body.  This is not a proc in the usual sense.  It belongs
     *  to the namespace that contains the ensemble, but it is
     *  accessed through the ensemble, not through a Tcl command.
     */
    partName = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    cmdPtr = (Command*)ensData->cmd;

    if (TclCreateProc(interp, cmdPtr->nsPtr, partName, objv[2], objv[3],
        &procPtr) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Deduce the usage information from the argument list.
     *  We'll register this when we create the part, in a moment.
     */
    Tcl_DStringInit(&buffer);
    varArgs = 0;
    space = 0;

    for (localPtr=procPtr->firstLocalPtr;
         localPtr != NULL;
         localPtr=localPtr->nextPtr) {

        if (TclIsVarArgument(localPtr)) {
            varArgs = 0;
            if (strcmp(localPtr->name, "args") == 0) {
                varArgs = 1;
            }
            else if (localPtr->defValuePtr) {
                if (space) {
                    Tcl_DStringAppend(&buffer, " ", 1);
                }
                Tcl_DStringAppend(&buffer, "?", 1);
                Tcl_DStringAppend(&buffer, localPtr->name, -1);
                Tcl_DStringAppend(&buffer, "?", 1);
                space = 1;
            }
            else {
                if (space) {
                    Tcl_DStringAppend(&buffer, " ", 1);
                }
                Tcl_DStringAppend(&buffer, localPtr->name, -1);
                space = 1;
            }
        }
    }
    if (varArgs) {
        if (space) {
            Tcl_DStringAppend(&buffer, " ", 1);
        }
        Tcl_DStringAppend(&buffer, "?arg arg ...?", 13);
    }

    usage = Tcl_DStringValue(&buffer);

    /*
     *  Create a new part within the ensemble.  If successful,
     *  plug the command token into the proc; we'll need it later
     *  if we try to compile the Tcl code for the part.  If
     *  anything goes wrong, clean up before bailing out.
     */
    status = AddEnsemblePart(interp, ensData, partName, usage,
        TclObjInterpProc, (ClientData)procPtr, TclProcDeleteProc,
        &ensPart);

    if (status == TCL_OK) {
        procPtr->cmdPtr = ensPart->cmdPtr;
    } else {
        TclProcDeleteProc((ClientData)procPtr);
    }
    Tcl_DStringFree(&buffer);

    return status;
}


/*
 *----------------------------------------------------------------------
 *
 * Itcl_EnsembleErrorCmd --
 *
 *      Invoked when the user tries to access an unknown part for
 *      an ensemble.  Acts as the default handler for the "@error"
 *      part.  Generates an error message like:
 *
 *          bad option "foo": should be one of...
 *            info args procname
 *            info body procname
 *            info cmdcount
 *            ...
 *
 * Results:
 *      Always returns TCL_OK.
 *
 * Side effects:
 *      Returns the error message as the result in the interpreter.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Itcl_EnsembleErrorCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* ensemble info */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Ensemble *ensData = (Ensemble*)clientData;

    char *cmdName;
    Tcl_Obj *objPtr;

    cmdName = Tcl_GetStringFromObj(objv[0], (int*)NULL);

    objPtr = Tcl_NewStringObj((char*)NULL, 0);
    Tcl_AppendStringsToObj(objPtr,
        "bad option \"", cmdName, "\": should be one of...\n",
        (char*)NULL);
    GetEnsembleUsage(ensData, objPtr);

    Tcl_SetObjResult(interp, objPtr);
    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * FreeEnsInvocInternalRep --
 *
 *      Frees the resources associated with an ensembleInvoc object's
 *      internal representation.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Decrements the ref count of the two objects referenced by
 *      this object.  If there are no more uses, this will free
 *      the other objects.
 *
 *----------------------------------------------------------------------
 */
static void
FreeEnsInvocInternalRep(objPtr)
    register Tcl_Obj *objPtr;   /* namespName object with internal
                                 * representation to free */
{
    Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2;

    if (prevArgObj) {
        Tcl_DecrRefCount(prevArgObj);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * DupEnsInvocInternalRep --
 *
 *      Initializes the internal representation of an ensembleInvoc
 *      object to a copy of the internal representation of
 *      another ensembleInvoc object.
 *
 *      This shouldn't be called.  Normally, a temporary ensembleInvoc
 *      object is created while an ensemble call is in progress.
 *      This object may be converted to string form if an error occurs.
 *      It does not stay around long, and there is no reason for it
 *      to be duplicated.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      copyPtr's internal rep is set to duplicates of the objects
 *      pointed to by srcPtr's internal rep.
 *
 *----------------------------------------------------------------------
 */
static void
DupEnsInvocInternalRep(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;                /* Object with internal rep to copy. */
    register Tcl_Obj *copyPtr;      /* Object with internal rep to set. */
{
    EnsemblePart *ensPart = (EnsemblePart*)srcPtr->internalRep.twoPtrValue.ptr1;
    Tcl_Obj *prevArgObj = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr2;
    Tcl_Obj *objPtr;

    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart;

    if (prevArgObj) {
        objPtr = Tcl_DuplicateObj(prevArgObj);
        Tcl_IncrRefCount(objPtr);
        copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) objPtr;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * SetEnsInvocFromAny --
 *
 *