Tcl Source Code

2011-03-09  Don Porter  <[email protected]>

	* generic/tclNamesp.c:	Tighten the detector of nested [namespace code]
	* tests/namespace.test:	quoting that the quoted scriptsfunction
	properly even in a namespace that contains a custom "namespace"
	command.  [Bug 3202171]

2011-03-08  Jan Nijtmans  <[email protected]>

	* generic/tclBasic.c: Fix gcc warnings: variable set but not used

2011-03-08  Don Porter  <[email protected]>

	* generic/tclInt.h:	Remove TclMarkList() routine, an experimental

    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Namespace *currNsPtr;
    Tcl_Obj *listPtr, *objPtr;
    register char *arg;
    int length;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "arg");
	return TCL_ERROR;
    }

    /*
     * If "arg" is already a scoped value, then return it directly.
     * Take care to only check for scoping in precisely the style that
     * [::namespace code] generates it.  Anything more forgiving can have
     * the effect of failing in namespaces that contain their own custom
     " "namespace" command.  [Bug 3202171].
     */

    arg = TclGetStringFromObj(objv[2], &length);


    if (*arg==':' && length > 20 

	    && strncmp(arg, "::namespace inscope ", 20) == 0) {




	Tcl_SetObjResult(interp, objv[2]);
	return TCL_OK;

    }

    /*
     * Otherwise, construct a scoped command by building a list with
     * "namespace inscope", the full name of the current namespace, and the
     * argument "arg". By constructing a list, we ensure that scoped commands
     * are interpreted properly when they are executed later, by the

#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}

proc fq {ns} {
    if {[string match ::* $ns]} {return $ns}
    set current [uplevel 1 {namespace current}]
    return [string trimright $current :]::[string trimleft $ns :]
}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
    namespace children :: test_ns_*
} {}

catch {unset l}
test namespace-2.1 {Tcl_GetCurrentNamespace} {

} {::test_ns_1::test_ns_foo}
test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} {
    namespace eval test_ns_1::test_ns_foo {}
    lsort [namespace children test_ns_1 test*]
} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}]
test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} {
    namespace eval test_ns_1 {}
    namespace children [namespace current] [fq test_ns_1]
} [fq test_ns_1]


test namespace-22.1 {NamespaceCodeCmd, bad args} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    list [catch {namespace code} msg] $msg \
         [catch {namespace code xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}}
test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} {
    namespace eval test_ns_1 {
        proc cmd {} {return "test_ns_1::cmd"}
    }
    namespace code {::namespace inscope ::test_ns_1 cmd}
} {::namespace inscope ::test_ns_1 cmd}
test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} {
    namespace code {namespace     inscope     ::test_ns_1 cmd}
} {::namespace inscope :: {namespace     inscope     ::test_ns_1 cmd}}
test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
    namespace code unknown
} {::namespace inscope :: unknown}
test namespace-22.5 {NamespaceCodeCmd, in other namespace} {
    namespace eval test_ns_1 {
        namespace code cmd
    }
} {::namespace inscope ::test_ns_1 cmd}
test namespace-22.6 {NamespaceCodeCmd, in other namespace} { 
    namespace eval test_ns_1 { 
	variable v 42 
    } 
    namespace eval test_ns_2 { 
	proc namespace args {} 
    } 
    namespace eval test_ns_2 [namespace eval test_ns_1 { 
	namespace code {set v} 
    }] 
} {42} 
test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} {
    namespace eval demo {
	proc namespace args {puts $args}
	::namespace code {namespace inscope foo}
    }
} [list ::namespace inscope [fq demo] {namespace inscope foo}]

test namespace-23.1 {NamespaceCurrentCmd, bad args} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    list [catch {namespace current xxx} msg] $msg \
         [catch {namespace current xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}}
test namespace-23.2 {NamespaceCurrentCmd, at global level} {