Tcl Source Code

2011-10-20  Donal K. Fellows  <[email protected]>

	* generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]:
	Additional code for handling the invalidation of literals.
	* generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand)
	(TclRenameCommand, Tcl_ExposeCommand): The four additional places that
	need extra care when dealing with literals.
	* generic/tclTest.c (TestInterpResolverCmd): Additional test machinery
	for interpreter resolvers.

2011-10-18  Reinhard Max  <[email protected]>

	* library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the time
	zone only if it was detected by one of the expensive methods.
	Otherwise after unsetting TCL_TZ or TZ the previous value will still
	be used.

2011-10-15  Venkat Iyer <[email protected]>

	* library/tzdata/America/Sitka : Update to Olson's tzdata2011l
	* library/tzdata/Pacific/Fiji
	* library/tzdata/Asia/Hebron (New)

2011-10-11  Jan Nijtmans  <[email protected]>

	* win/tclWinFile.c:    [Bug 2935503]: Incorrect mode field returned by
	[file stat] command.

2011-10-09  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected handling of
	qualified names, and added spacial cases for empty bodies (used when
	[dict with] is just used for extracting variables).

    if (!isNew) {
	Tcl_AppendResult(interp, "exposed command \"", cmdName,
		"\" already exists", NULL);
        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.
	 */

	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.
	 */

	TclInvalidateNsCmdLookup(nsPtr);

     * 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

			    Tcl_Obj *objPtr, int maxChars);
MODULE_SCOPE void	TclPrintSource(FILE *outFile,
			    const char *string, int maxChars);
MODULE_SCOPE void	TclRegisterAuxDataType(const AuxDataType *typePtr);
MODULE_SCOPE int	TclRegisterLiteral(CompileEnv *envPtr,
			    char *bytes, int length, int flags);
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, (char *) name,
	    strlen(name), -1, NULL, nsPtr, 0, NULL);

    if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) {
	TclFreeIntRep(literalObjPtr);
    }
}

#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * TclLiteralStats --
 *

			    Tcl_Obj *const objv[]);
static int		TestHashSystemHashCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestNRELevels(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestInterpResolverCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

static const Tcl_Filesystem testReportingFilesystem = {
    "reporting",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_1,
    TestReportInFilesystem, /* path in */
    TestReportDupInternalRep,

	    NULL, NULL);
    t3ArgTypes[0] = TCL_EITHER;
    t3ArgTypes[1] = TCL_EITHER;
    Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
	    NULL);

    Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
	    NULL, NULL);

    if (TclObjTest_Init(interp) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Procbodytest_Init(interp) != TCL_OK) {
	return TCL_ERROR;

    result[0] = Tcl_NewIntObj(foo);
    result[1] = Tcl_NewIntObj(count);
    result[2] = Tcl_NewListObj(count, remObjv);
    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
    ckfree(remObjv);
    return TCL_OK;
}

/**
 * Test harness for command and variable resolvers.
 */

static int
InterpCmdResolver(
    Tcl_Interp *interp,
    const char *name,
    Tcl_Namespace *context,
    int flags,
    Tcl_Command *rPtr)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
            varFramePtr->procPtr : NULL;
    Namespace *ns2NsPtr = (Namespace *)
            Tcl_FindNamespace(interp, "::ns2", NULL, 0);

    if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
            || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
        const char *callingCmdName =
                Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);

        if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
                && (name[0] == 'z') && (name[1] == '\0')) {
            Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
                    TCL_GLOBAL_ONLY);

            if (sourceCmdPtr != NULL) {
                *rPtr = sourceCmdPtr;
                return TCL_OK;
            }
        }
    }
    return TCL_CONTINUE;
}

static int
InterpVarResolver(
    Tcl_Interp *interp,
    const char *name,
    Tcl_Namespace *context,
    int flags,
    Tcl_Var *rPtr)
{
    /*
     * Don't resolve the variable; use standard rules.
     */

    return TCL_CONTINUE;
}

typedef struct MyResolvedVarInfo {
    Tcl_ResolvedVarInfo vInfo;  /* This must be the first element. */
    Tcl_Var var;
    Tcl_Obj *nameObj;
} MyResolvedVarInfo;

static inline void
HashVarFree(
    Tcl_Var var)
{
    if (VarHashRefCount(var) < 2) {
        ckfree(var);
    } else {
        VarHashRefCount(var)--;
    }
}

static void
MyCompiledVarFree(
    Tcl_ResolvedVarInfo *vInfoPtr)
{
    MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr;

    Tcl_DecrRefCount(resVarInfo->nameObj);
    if (resVarInfo->var) {
        HashVarFree(resVarInfo->var);
    }
    ckfree(vInfoPtr);
}

#define TclVarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))

static Tcl_Var
MyCompiledVarFetch(
    Tcl_Interp *interp,
    Tcl_ResolvedVarInfo *vinfoPtr)
{
    MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;
    Tcl_Var var = resVarInfo->var;
    int isNewVar;
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;

    if (var != NULL) {
        if (!(((Var *) var)->flags & VAR_DEAD_HASH)) {
            /*
             * The cached variable is valid, return it.
             */

            return var;
        }

        /*
         * The variable is not valid anymore. Clean it up.
         */

        HashVarFree(var);
    }

    hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable,
            (char *) resVarInfo->nameObj, &isNewVar);
    if (hPtr) {
        var = (Tcl_Var) TclVarHashGetValue(hPtr);
    } else {
        var = NULL;
    }
    resVarInfo->var = var;

    /*
     * Increment the reference counter to avoid ckfree() of the variable in
     * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
     */

    VarHashRefCount(var)++;
    return var;
}

static int
InterpCompiledVarResolver(
    Tcl_Interp *interp,
    const char *name,
    int length,
    Tcl_Namespace *context,
    Tcl_ResolvedVarInfo **rPtr)
{
    if (*name == 'T') {
 	MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));

 	resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
 	resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
 	resVarInfo->var = NULL;
 	resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
 	Tcl_IncrRefCount(resVarInfo->nameObj);
 	*rPtr = &resVarInfo->vInfo;
 	return TCL_OK;
    }
    return TCL_CONTINUE;
}

static int
TestInterpResolverCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    static const char *const table[] = {
        "down", "up", NULL
    };
    int idx;
#define RESOLVER_KEY "testInterpResolver"

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "up|down");
 	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
            &idx) != TCL_OK) {
        return TCL_ERROR;
    }
    switch (idx) {
    case 1: /* up */
        Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver,
                InterpVarResolver, InterpCompiledVarResolver);
        break;
    case 0: /*down*/
        if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) {
            Tcl_AppendResult(interp, "could not remove the resolver scheme",
                    NULL);
            return TCL_ERROR;
        }
    }
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */

# This test collection covers some unwanted interactions between command
# literal sharing and the use of command resolvers (per-interp) which cause
# command literals to be re-used with their command references being invalid
# in the reusing context.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2011 Gustaf Neumann <[email protected]>
# Copyright (c) 2011 Stefan Sobernig <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

testConstraint testinterpresolver [llength [info commands testinterpresolver]]

test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
    testinterpresolver up
    namespace eval ::ns1 {
	proc z {} { return Z }
	namespace export z
    }
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    # 1) Have the proc body compiled: During compilation or, alternatively,
    # the first evaluation of the compiled body, the InterpCmdResolver (see
    # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the
    # 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
	}
    }
} -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 {} {
	set T1 100
	return $T1
    }
} -constraints testinterpresolver -body {
    # Call "x" the first time, causing a byte code compilation of the body.
    # During the compilation the compiled var resolver, the resolve-specific
    # var info is allocated, during the execution of the body, the variable is
    # fetched and cached.
    x;
    # During later calls, the cached variable is reused.
    x
    # When the proc is freed, the resolver-specific resolver var info is
    # freed. This did not happen before fix #3383616.
    rename ::x ""
} -cleanup {
    testinterpresolver down
} -result {}

cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End: