Tcl Source Code

    if (!isNew) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "exposed command \"%s\" already exists", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
	return TCL_ERROR;
    }

    /*
     * Command resolvers (per-interp, per-namespace) might have resolved to a
     * command for the given namespace scope with this command not being
     * registered with the namespace's command table. During BC compilation,
     * the so-resolved command turns into a CmdName literal. Without
     * invalidating a possible CmdName literal here explicitly, such literals
     * keep being reused while pointing to overhauled commands.
     */

    TclInvalidateCmdLiteral(interp, cmdName, nsPtr);

    /*
     * The list of command exported from the namespace might have changed.
     * However, we do not need to recompute this just yet; next time we need
     * the info will be soon enough.
     */

    TclInvalidateNsCmdLookup(nsPtr);

	     * the new command (if we try to delete it again, we could get
	     * stuck in an infinite loop).
	     */

	    ckfree(Tcl_GetHashValue(hPtr));
	}
    } else {
	/*
	 * Command resolvers (per-interp, per-namespace) might have resolved
	 * to a command for the given namespace scope with this command not
	 * being registered with the namespace's command table. During BC
	 * compilation, the so-resolved command turns into a CmdName literal.
	 * Without invalidating a possible CmdName literal here explicitly,
	 * such literals keep being reused while pointing to overhauled
	 * commands.
	 */

	TclInvalidateCmdLiteral(interp, tail, nsPtr);

	/*
	 * The list of command exported from the namespace might have changed.
	 * However, we do not need to recompute this just yet; next time we
	 * need the info will be soon enough.
	 */

	     * the new command (if we try to delete it again, we could get
	     * stuck in an infinite loop).
	     */

	    ckfree(Tcl_GetHashValue(hPtr));
	}
    } else {
	/*
	 * Command resolvers (per-interp, per-namespace) might have resolved
	 * to a command for the given namespace scope with this command not
	 * being registered with the namespace's command table. During BC
	 * compilation, the so-resolved command turns into a CmdName literal.
	 * Without invalidating a possible CmdName literal here explicitly,
	 * such literals keep being reused while pointing to overhauled
	 * commands.
	 */

	TclInvalidateCmdLiteral(interp, tail, nsPtr);

	/*
	 * The list of command exported from the namespace might have changed.
	 * However, we do not need to recompute this just yet; next time we
	 * need the info will be soon enough.
	 */

     * the info will be soon enough. These might refer to the same variable,
     * but that's no big deal.
     */

    TclInvalidateNsCmdLookup(cmdNsPtr);
    TclInvalidateNsCmdLookup(cmdPtr->nsPtr);

    /*
     * Command resolvers (per-interp, per-namespace) might have resolved to a
     * command for the given namespace scope with this command not being
     * registered with the namespace's command table. During BC compilation,
     * the so-resolved command turns into a CmdName literal. Without
     * invalidating a possible CmdName literal here explicitly, such literals
     * keep being reused while pointing to overhauled commands.
     */

    TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr);

    /*
     * Script for rename traces can delete the command "oldName". Therefore
     * increment the reference count for cmdPtr so that it's Command structure
     * is freed only towards the end of this function by calling
     * TclCleanupCommand.
     *
     * The trace function needs to get a fully qualified name for old and new

MODULE_SCOPE void	TclPushVarName(Tcl_Interp *interp,
			    Tcl_Token *varTokenPtr, CompileEnv *envPtr,
			    int flags, int *localIndexPtr,
			    int *isScalarPtr);
MODULE_SCOPE void	TclPreserveByteCode(ByteCode *codePtr);
MODULE_SCOPE void	TclReleaseByteCode(ByteCode *codePtr);
MODULE_SCOPE void	TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void	TclInvalidateCmdLiteral(Tcl_Interp *interp,
			    const char *name, Namespace *nsPtr);
MODULE_SCOPE int	TclSingleOpCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclSortingOpCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclVariadicOpCmd(ClientData clientData,

     * Free up the old bucket array, if it was dynamically allocated.
     */

    if (oldBuckets != tablePtr->staticBuckets) {
	ckfree(oldBuckets);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclInvalidateCmdLiteral --
 *
 *	Invalidate a command literal entry, if present in the literal hash
 *	tables, by resetting its internal representation. This invalidation
 *	leaves it in the literal tables and in existing literal arrays. As a
 *	result, existing references continue to work but we force a fresh
 *	command look-up upon the next use (see, in particular,
 *	TclSetCmdNameObj()).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Resets the internal representation of the CmdName Tcl_Obj
 *	using TclFreeIntRep().
 *
 *----------------------------------------------------------------------
 */

void
TclInvalidateCmdLiteral(
    Tcl_Interp *interp,		/* Interpreter for which to invalidate a
				 * command literal. */
    const char *name,		/* Points to the start of the cmd literal
				 * name. */
    Namespace *nsPtr)		/* The namespace for which to lookup and
				 * invalidate a cmd literal. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name,
	    strlen(name), -1, NULL, nsPtr, 0, NULL);

    if (literalObjPtr != NULL) {
	if (literalObjPtr->typePtr == &tclCmdNameType) {
	    TclFreeIntRep(literalObjPtr);
	}
	/* Balance the refcount effects of TclCreateLiteral() above */
	Tcl_IncrRefCount(literalObjPtr);
	TclReleaseLiteral(interp, literalObjPtr);
    }
}

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLiteralStats --
 *

    register Tcl_Obj *objPtr)	/* The object containing the command's name.
				 * If the name starts with "::", will be
				 * looked up in global namespace. Else, looked
				 * up first in the current namespace, then in
				 * global namespace. */
{
    register ResolvedCmdName *resPtr;


    /*
     * Get the internal representation, converting to a command type if
     * needed. The internal representation is a ResolvedCmdName that points to
     * the actual command.
     *
     * Check the context namespace and the namespace epoch of the resolved

    /*
     * OK, must create a new internal representation (or fail) as any cache we
     * had is invalid one way or another.
     */

    /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
    if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {

        return NULL;

    }
    resPtr = objPtr->internalRep.twoPtrValue.ptr1;

    return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetCmdNameObj --
 *

    if (objPtr->typePtr == &tclCmdNameType) {
	resPtr = objPtr->internalRep.twoPtrValue.ptr1;
	if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
	    return;
	}
    }


    SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *

    # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj
    # is turned into a command literal shared for a given (here: the global)
    # namespace.
    set r0 [x];			# --> The result of [x] is "Y"
    # 2) After having requested cmd resolution above, we can now use the
    # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is
    # certainly questionable, but defensible

    set r1 [z];			# --> The result of [z] is "Y"
    # 3) We import from the namespace ns1 another z. [namespace import] takes
    # care "shadowed" cmd references, however, till now cmd literals have not
    # been touched. This is, however, necessary since the BC compiler (used in
    # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd
    # literals for a given NS scope. We expect, that r2 is "Z", the result of
    # the namespace imported cmd.
    namespace eval :: {
	namespace import ::ns1::z
	set r2 [z]
    }

    list $r0 $r1 $::r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    namespace delete ::ns1
} -result {Y Y Z}
test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
    testinterpresolver up
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]

    proc ::foo {} {
	proc ::z {} { return Z }
	return [z]
    }
    list $r0 $r1 [::foo]
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::foo ""
    rename ::z ""
} -result {Y Y Z}
test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
    testinterpresolver up
    proc ::Z {} { return Z }
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]

    namespace eval :: {
	rename ::Z ::z
	set r2 [z]
    }

    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::z ""
} -result {Y Y Z}
test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
    testinterpresolver up
    proc ::Z {} { return Z }
    interp hide {} Z
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]

    interp expose {} Z z
    namespace eval :: {
	set r2 [z]
    }

    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::z ""
} -result {Y Y Z}
test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup {
    testinterpresolver up
    namespace eval ::ns1 {
	proc z {} { return Z }
	namespace export z
    }
    proc ::y {} { return Y }
    namespace eval ::ns2 {
	proc x {} {
	    z
	}
    }
    namespace eval :: {
	variable r2 ""
    }
} -constraints testinterpresolver -body {
    set r0 [namespace eval ::ns2 {x}]

    set r1 [namespace eval ::ns2 {z}]
    namespace eval ::ns2 {
	namespace import ::ns1::z
	set r2 [z]
    }

    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    namespace delete ::ns2
    namespace delete ::ns1
} -result {Y Y Z}
test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup {
    testinterpresolver up
    proc ::Z {} { return Z }
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]

    namespace eval :: {
	interp alias {} ::z {} ::Z
	set r2 [z]
    }

    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::Z ""
} -result {Y Y Z}

test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
    testinterpresolver up
    # The compiled var resolver fetches just variables starting with a capital
    # "T" and stores some test information in the resolver-specific resolver
    # var info.
    proc ::x {} {