itcl_util.c

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


/*
 * ------------------------------------------------------------------------
 *  Itcl_ProtectionStr()
 *
 *  Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED,
 *  or ITCL_PRIVATE) into a human-readable character string.  Returns
 *  a pointer to this string.
 * ------------------------------------------------------------------------
 */
char*
Itcl_ProtectionStr(pLevel)
    int pLevel;     /* protection level */
{
    switch (pLevel) {
    case ITCL_PUBLIC:
        return "public";
    case ITCL_PROTECTED:
        return "protected";
    case ITCL_PRIVATE:
        return "private";
    }
    return "<bad-protection-code>";
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CanAccess()
 *
 *  Checks to see if a class member can be accessed from a particular
 *  namespace context.  Public things can always be accessed.  Protected
 *  things can be accessed if the "from" namespace appears in the
 *  inheritance hierarchy of the class namespace.  Private things
 *  can be accessed only if the "from" namespace is the same as the
 *  class that contains them.
 *
 *  Returns 1/0 indicating true/false.
 * ------------------------------------------------------------------------
 */
int
Itcl_CanAccess(memberPtr, fromNsPtr)
    ItclMember* memberPtr;     /* class member being tested */
    Tcl_Namespace* fromNsPtr;  /* namespace requesting access */
{
    ItclClass* fromCdPtr;
    Tcl_HashEntry *entry;

    /*
     *  If the protection level is "public" or "private", then the
     *  answer is known immediately.
     */
    if (memberPtr->protection == ITCL_PUBLIC) {
        return 1;
    }
    else if (memberPtr->protection == ITCL_PRIVATE) {
        return (memberPtr->classDefn->namesp == fromNsPtr);
    }

    /*
     *  If the protection level is "protected", then check the
     *  heritage of the namespace requesting access.  If cdefnPtr
     *  is in the heritage, then access is allowed.
     */
    assert (memberPtr->protection == ITCL_PROTECTED);

    if (Itcl_IsClassNamespace(fromNsPtr)) {
        fromCdPtr = (ItclClass*)fromNsPtr->clientData;

        entry = Tcl_FindHashEntry(&fromCdPtr->heritage,
            (char*)memberPtr->classDefn);

        if (entry) {
            return 1;
        }
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CanAccessFunc()
 *
 *  Checks to see if a member function with the specified protection
 *  level can be accessed from a particular namespace context.  This
 *  follows the same rules enforced by Itcl_CanAccess, but adds one
 *  special case:  If the function is a protected method, and if the
 *  current context is a base class that has the same method, then
 *  access is allowed.
 *
 *  Returns 1/0 indicating true/false.
 * ------------------------------------------------------------------------
 */
int
Itcl_CanAccessFunc(mfunc, fromNsPtr)
    ItclMemberFunc* mfunc;     /* member function being tested */
    Tcl_Namespace* fromNsPtr;  /* namespace requesting access */
{
    ItclClass *cdPtr, *fromCdPtr;
    ItclMemberFunc *ovlfunc;
    Tcl_HashEntry *entry;

    /*
     *  Apply the usual rules first.
     */
    if (Itcl_CanAccess(mfunc->member, fromNsPtr)) {
        return 1;
    }

    /*
     *  As a last resort, see if the namespace is really a base
     *  class of the class containing the method.  Look for a
     *  method with the same name in the base class.  If there
     *  is one, then this method overrides it, and the base class
     *  has access.
     */
    if ((mfunc->member->flags & ITCL_COMMON) == 0 &&
        Itcl_IsClassNamespace(fromNsPtr)) {

        cdPtr = mfunc->member->classDefn;
        fromCdPtr = (ItclClass*)fromNsPtr->clientData;

        if (Tcl_FindHashEntry(&cdPtr->heritage, (char*)fromCdPtr)) {
            entry = Tcl_FindHashEntry(&fromCdPtr->resolveCmds,
                mfunc->member->name);

            if (entry) {
                ovlfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
                if ((ovlfunc->member->flags & ITCL_COMMON) == 0 &&
                     ovlfunc->member->protection < ITCL_PRIVATE) {
                    return 1;
                }
            }
        }
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetTrueNamespace()
 *
 *  Returns the current namespace context.  This procedure is similar
 *  to Tcl_GetCurrentNamespace, but it supports the notion of
 *  "transparent" call frames installed by Itcl_HandleInstance.
 *
 *  Returns a pointer to the current namespace calling context.
 * ------------------------------------------------------------------------
 */
Tcl_Namespace*
Itcl_GetTrueNamespace(interp, info)
    Tcl_Interp *interp;        /* interpreter being queried */
    ItclObjectInfo *info;      /* object info associated with interp */
{
    int i, transparent;
    Tcl_CallFrame *framePtr, *transFramePtr;
    Tcl_Namespace *contextNs;

    /*
     *  See if the current call frame is on the list of transparent
     *  call frames.
     */
    transparent = 0;

    framePtr = _Tcl_GetCallFrame(interp, 0);
    for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
        transFramePtr = (Tcl_CallFrame*)
            Itcl_GetStackValue(&info->transparentFrames, i);

        if (framePtr == transFramePtr) {
            transparent = 1;
            break;
        }
    }

    /*
     *  If this is a transparent call frame, return the namespace
     *  context one level up.
     */
    if (transparent) {
        framePtr = _Tcl_GetCallFrame(interp, 1);
        if (framePtr) {
            contextNs = framePtr->nsPtr;
        } else {
            contextNs = Tcl_GetGlobalNamespace(interp);
        }
    }
    else {
        contextNs = Tcl_GetCurrentNamespace(interp);
    }
    return contextNs;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ParseNamespPath()
 *
 *  Parses a reference to a namespace element of the form:
 *
 *      namesp::namesp::namesp::element
 *
 *  Returns pointers to the head part ("namesp::namesp::namesp")
 *  and the tail part ("element").  If the head part is missing,
 *  a NULL pointer is returned and the rest of the string is taken
 *  as the tail.
 *
 *  Both head and tail point to locations within the given dynamic
 *  string buffer.  This buffer must be uninitialized when passed
 *  into this procedure, and it must be freed later on, when the
 *  strings are no longer needed.
 * ------------------------------------------------------------------------
 */
void
Itcl_ParseNamespPath(name, buffer, head, tail)
    char *name;          /* path name to class member */
    Tcl_DString *buffer; /* dynamic string buffer (uninitialized) */
    char **head;         /* returns "namesp::namesp::namesp" part */
    char **tail;         /* returns "element" part */
{
    register char *sep;

    Tcl_DStringInit(buffer);

    /*
     *  Copy the name into the buffer and parse it.  Look
     *  backward from the end of the string to the first '::'
     *  scope qualifier.
     */
    Tcl_DStringAppend(buffer, name, -1);
    name = Tcl_DStringValue(buffer);

    for (sep=name; *sep != '\0'; sep++)
        ;

    while (--sep > name) {
        if (*sep == ':' && *(sep-1) == ':') {
            break;
        }
    }

    /*
     *  Found head/tail parts.  If there are extra :'s, keep backing
     *  up until the head is found.  This supports the Tcl namespace
     *  behavior, which allows names like "foo:::bar".
     */
    if (sep > name) {
        *tail = sep+1;
        while (sep > name && *(sep-1) == ':') {
            sep--;
        }
        *sep = '\0';
        *head = name;
    }

    /*
     *  No :: separators--the whole name is treated as a tail.
     */
    else {
        *tail = name;
        *head = NULL;
    }
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DecodeScopedCommand()
 *
 *  Decodes a scoped command of the form:
 *
 *      namespace inscope <namesp> <command>
 *
 *  If the given string is not a scoped value, this procedure does
 *  nothing and returns TCL_OK.  If the string is a scoped value,
 *  then it is decoded, and the namespace, and the simple command
 *  string are returned as arguments; the simple command should
 *  be freed when no longer in use.  If anything goes wrong, this
 *  procedure returns TCL_ERROR, along with an error message in
 *  the interpreter.
 * ------------------------------------------------------------------------
 */
int
Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
    Tcl_Interp *interp;      /* current interpreter */
    char *name;              /* string to be decoded */
    Tcl_Namespace **rNsPtr;  /* returns: namespace for scoped value */
    char **rCmdPtr;          /* returns: simple command word */
{
    Tcl_Namespace *nsPtr = NULL;
    char *cmdName = name;
    int len = strlen(name);

    char *pos;
    int listc, result;
    char **listv;

    if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
	for (pos = (name + 9);  (*pos == ' ');  pos++) {
	    /* empty body: skip over spaces */
	}
	if ((*pos == 'i') && ((pos + 7) <= (name + len))
	        && (strncmp(pos, "inscope", 7) == 0)) {

            result = Tcl_SplitList(interp, name, &listc, &listv);
            if (result == TCL_OK) {
                if (listc != 4) {
                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "malformed command \"", name, "\": should be \"",
                        "namespace inscope namesp command\"",
                        (char*)NULL);
                    result = TCL_ERROR;
                }
                else {
                    nsPtr = Tcl_FindNamespace(interp, listv[2],
                        (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);

                    if (!nsPtr) {
                        result = TCL_ERROR;
                    }
                    else {
                        cmdName = ckalloc((unsigned)(strlen(listv[3])+1));
                        strcpy(cmdName, listv[3]);
                    }
                }
            }
            ckfree((char*)listv);

            if (result != TCL_OK) {
                char msg[512];
                sprintf(msg, "\n    (while decoding scoped command \"%.400s\")", name);
                Tcl_AddObjErrorInfo(interp, msg, -1);
                return TCL_ERROR;
            }
	}
    }

    *rNsPtr = nsPtr;
    *rCmdPtr = cmdName;
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_EvalArgs()
 *
 *  This procedure invokes a list of (objc,objv) arguments as a
 *  single command.  It is similar to Tcl_EvalObj, but it doesn't
 *  do any parsing or compilation.  It simply treats the first
 *  argument as a command and invokes that command in the current
 *  context.
 *
 *  Returns TCL_OK if successful.  Otherwise, this procedure returns
 *  TCL_ERROR along with an error message in the interpreter.
 * ------------------------------------------------------------------------
 */
int
Itcl_EvalArgs(interp, objc, objv)
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    int result;
    Tcl_Command cmd;
    Command *cmdPtr;
    int cmdlinec;
    Tcl_Obj **cmdlinev;
    Tcl_Obj *cmdlinePtr = NULL;

    /*
     * Resolve the command by converting it to a CmdName object.
     * This caches a pointer to the Command structure for the
     * command, so if we need it again, it's ready to use.
     */
    cmd = Tcl_GetCommandFromObj(interp, objv[0]);
    cmdPtr = (Command*)cmd;

    cmdlinec = objc;
    cmdlinev = (Tcl_Obj**)objv;

    /*
     * If the command is still not found, handle it with the
     * "unknown" proc.
     */
    if (cmdPtr == NULL) {
        cmd = Tcl_FindCommand(interp, "unknown",
            (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);

        if (cmd == NULL) {
            Tcl_ResetResult(interp);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "invalid command name \"",
                Tcl_GetStringFromObj(objv[0], (int*)NULL), "\"",
                (char*)NULL);
            return TCL_ERROR;
        }
        cmdPtr = (Command*)cmd;

        cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv);

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

    /*
     *  Finally, invoke the command's Tcl_ObjCmdProc.  Be careful
     *  to pass in the proper client data.
     */
    Tcl_ResetResult(interp);
    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
        cmdlinec, cmdlinev);

    if (cmdlinePtr) {
        Tcl_DecrRefCount(cmdlinePtr);
    }
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateArgs()
 *
 *  This procedure takes a string and a list of (objc,objv) arguments,
 *  and glues them together in a single list.  This is useful when
 *  a command word needs to be prepended or substituted into a command
 *  line before it is executed.  The arguments are returned in a single
 *  list object, and they can be retrieved by calling
 *  Tcl_ListObjGetElements.  When the arguments are no longer needed,
 *  they should be discarded by decrementing the reference count for
 *  the list object.
 *
 *  Returns a pointer to the list object containing the arguments.
 * ------------------------------------------------------------------------
 */
Tcl_Obj*
Itcl_CreateArgs(interp, string, objc, objv)
    Tcl_Interp *interp;      /* current interpreter */
    char *string;            /* first command word */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    int i;
    Tcl_Obj *listPtr;

    listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
        Tcl_NewStringObj(string, -1));

    for (i=0; i < objc; i++) {
        Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objv[i]);
    }

    Tcl_IncrRefCount(listPtr);
    return listPtr;
}