itcl_cmds.c

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

    /*
     *  We must be in an ordinary namespace context.  Resolve
     *  the variable using Tcl_FindNamespaceVar.
     *
     *  TRICKY NOTE:  If this is an array reference, we'll get
     *    the array variable as the variable name.  We must be
     *    careful to add the index (everything from openParen
     *    onward) as well.
     */
    else {
        Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

        var = Tcl_FindNamespaceVar(interp, token, contextNs,
            TCL_NAMESPACE_ONLY);

        if (!var) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "variable \"", token, "\" not found in namespace \"",
                contextNs->fullName, "\"",
                (char*)NULL);
            result = TCL_ERROR;
            goto scopeCmdDone;
        }

        Tcl_GetVariableFullName(interp, var, resultPtr);
        if (openParen) {
            *openParen = '(';
            Tcl_AppendToObj(resultPtr, openParen, -1);
            openParen = NULL;
        }
    }

scopeCmdDone:
    if (openParen) {
        *openParen = '(';
    }
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CodeCmd()
 *
 *  Invoked by Tcl whenever the user issues a "code" command to
 *  create a scoped command string.  Handles the following syntax:
 *
 *    code ?-namespace foo? arg ?arg arg ...?
 *
 *  Unlike the scope command, the code command DOES NOT look for
 *  scoping information at the beginning of the command.  So scopes
 *  will nest in the code command.
 *
 *  The code command is similar to the "namespace code" command in
 *  Tcl, but it preserves the list structure of the input arguments,
 *  so it is a lot more useful.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_CodeCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* unused */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp);

    int pos;
    char *token;
    Tcl_Obj *listPtr, *objPtr;

    /*
     *  Handle flags like "-namespace"...
     */
    for (pos=1; pos < objc; pos++) {
        token = Tcl_GetStringFromObj(objv[pos], (int*)NULL);
        if (*token != '-') {
            break;
        }

        if (strcmp(token, "-namespace") == 0) {
            if (objc == 2) {
                Tcl_WrongNumArgs(interp, 1, objv,
                    "?-namespace name? command ?arg arg...?");
                return TCL_ERROR;
            } else {
                token = Tcl_GetStringFromObj(objv[pos+1], (int*)NULL);
                contextNs = Tcl_FindNamespace(interp, token,
                    (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);

                if (!contextNs) {
                    return TCL_ERROR;
                }
                pos++;
            }
        }
        else if (strcmp(token, "--") == 0) {
            pos++;
            break;
        }
        else {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad option \"", token, "\": should be -namespace or --",
                (char*)NULL);
            return TCL_ERROR;
        }
    }

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv,
            "?-namespace name? command ?arg arg...?");
        return TCL_ERROR;
    }

    /*
     *  Now construct a scoped command by integrating the
     *  current namespace context, and appending the remaining
     *  arguments AS A LIST...
     */
    listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);

    Tcl_ListObjAppendElement(interp, listPtr,
        Tcl_NewStringObj("namespace", -1));
    Tcl_ListObjAppendElement(interp, listPtr,
        Tcl_NewStringObj("inscope", -1));

    if (contextNs == Tcl_GetGlobalNamespace(interp)) {
        objPtr = Tcl_NewStringObj("::", -1);
    } else {
        objPtr = Tcl_NewStringObj(contextNs->fullName, -1);
    }
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    if (objc-pos == 1) {
        objPtr = objv[pos];
    } else {
        objPtr = Tcl_NewListObj(objc-pos, &objv[pos]);
    }
    Tcl_ListObjAppendElement(interp, listPtr, objPtr);

    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_StubCreateCmd()
 *
 *  Invoked by Tcl whenever the user issues a "stub create" command to
 *  create an autoloading stub for imported commands.  Handles the
 *  following syntax:
 *
 *    stub create <name>
 *
 *  Creates a command called <name>.  Executing this command will cause
 *  the real command <name> to be autoloaded.
 * ------------------------------------------------------------------------
 */
int
Itcl_StubCreateCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* not used */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    char *cmdName;
    Command *cmdPtr;

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "name");
        return TCL_ERROR;
    }
    cmdName = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    /*
     *  Create a stub command with the characteristic ItclDeleteStub
     *  procedure.  That way, we can recognize this command later
     *  on as a stub.  Save the cmd token as client data, so we can
     *  get the full name of this command later on.
     */
    cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdName,
        ItclHandleStubCmd, (ClientData)NULL,
        (Tcl_CmdDeleteProc*)ItclDeleteStub);

    cmdPtr->objClientData = (ClientData) cmdPtr;

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_StubExistsCmd()
 *
 *  Invoked by Tcl whenever the user issues a "stub exists" command to
 *  see if an existing command is an autoloading stub.  Handles the
 *  following syntax:
 *
 *    stub exists <name>
 *
 *  Looks for a command called <name> and checks to see if it is an
 *  autoloading stub.  Returns a boolean result.
 * ------------------------------------------------------------------------
 */
int
Itcl_StubExistsCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* not used */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    char *cmdName;
    Tcl_Command cmd;

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "name");
        return TCL_ERROR;
    }
    cmdName = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace*)NULL, 0);

    if (cmd != NULL && Itcl_IsStub(cmd)) {
        Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
    } else {
        Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_IsStub()
 *
 *  Checks the given Tcl command to see if it represents an autoloading
 *  stub created by the "stub create" command.  Returns non-zero if
 *  the command is indeed a stub.
 * ------------------------------------------------------------------------
 */
int
Itcl_IsStub(cmd)
    Tcl_Command cmd;         /* command being tested */
{
    Command *cmdPtr = (Command*)cmd;

    /*
     *  This may be an imported command, but don't try to get the
     *  original.  Just check to see if this particular command
     *  is a stub.  If we really want the original command, we'll
     *  find it at a higher level.
     */
    if (cmdPtr->deleteProc == ItclDeleteStub) {
        return 1;
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  ItclHandleStubCmd()
 *
 *  Invoked by Tcl to handle commands created by "stub create".
 *  Calls "auto_load" with the full name of the current command to
 *  trigger autoloading of the real implementation.  Then, calls the
 *  command to handle its function.  If successful, this command
 *  returns TCL_OK along with the result from the real implementation
 *  of this command.  Otherwise, it returns TCL_ERROR, along with an
 *  error message in the interpreter.
 * ------------------------------------------------------------------------
 */
static int
ItclHandleStubCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* command token for this stub */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Tcl_Command cmd = (Tcl_Command) clientData;

    int result, loaded;
    char *cmdName;
    int cmdlinec;
    Tcl_Obj **cmdlinev;
    Tcl_Obj *objAutoLoad[2], *objPtr, *cmdNamePtr, *cmdlinePtr;

    cmdNamePtr = Tcl_NewStringObj((char*)NULL, 0);
    Tcl_GetCommandFullName(interp, cmd, cmdNamePtr);
    Tcl_IncrRefCount(cmdNamePtr);
    cmdName = Tcl_GetStringFromObj(cmdNamePtr, (int*)NULL);

    /*
     *  Try to autoload the real command for this stub.
     */
    objAutoLoad[0] = Tcl_NewStringObj("::auto_load", -1);
    Tcl_IncrRefCount(objAutoLoad[0]);
    objAutoLoad[1] = cmdNamePtr;
    Tcl_IncrRefCount(objAutoLoad[1]);

    result = Itcl_EvalArgs(interp, 2, objAutoLoad);

    Tcl_DecrRefCount(objAutoLoad[0]);
    Tcl_DecrRefCount(objAutoLoad[1]);

    if (result != TCL_OK) {
        Tcl_DecrRefCount(cmdNamePtr);
        return TCL_ERROR;
    }

    objPtr = Tcl_GetObjResult(interp);
    result = Tcl_GetIntFromObj(interp, objPtr, &loaded);
    if (result != TCL_OK || !loaded) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "can't autoload \"", cmdName, "\"", (char*)NULL);
        Tcl_DecrRefCount(cmdNamePtr);
        return TCL_ERROR;
    }

    /*
     *  At this point, the real implementation has been loaded.
     *  Invoke the command again with the arguments passed in.
     */
    cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc-1, objv+1);

    (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
        &cmdlinec, &cmdlinev);

    Tcl_ResetResult(interp);
    result = Itcl_EvalArgs(interp, cmdlinec, cmdlinev);
    Tcl_DecrRefCount(cmdlinePtr);

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  ItclDeleteStub()
 *
 *  Invoked by Tcl whenever a stub command is deleted.  This procedure
 *  does nothing, but its presence identifies a command as a stub.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static void
ItclDeleteStub(cdata)
    ClientData cdata;      /* not used */
{
    /* do nothing */
}