Tcl Source Code

Check-in [ac4c249ecf]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:
* 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]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bug-3202171
Files: files | file ages | folders
SHA1: ac4c249ecfb6ff77a5aac99c07d75270410ee002
User & Date: dgp 2011-03-09 14:56:37
Original Comment:
* 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]
Context
2011-03-09
15:55
* generic/tclNamesp.c: Tighten the detector of nested [namespace code] * tests/name...
check-in: 88cba3ed97 user: dgp tags: core-8-5-branch
14:56
* generic/tclNamesp.c: Tighten the detector of nested [namespace code] * tests/nam...
Closed-Leaf check-in: ac4c249ecf user: dgp tags: bug-3202171
2011-03-08
22:14
Fix gcc warnings: variable set but not used check-in: 8302182f6c user: jan.nijtmans tags: core-8-5-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.








1
2
3
4
5
6
7






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
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
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

Changes to generic/tclNamesp.c.

3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019




3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
    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, *p;
    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.




     */

    arg = TclGetStringFromObj(objv[2], &length);
    while (*arg == ':') {
	arg++;
	length--;
    }
    if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) {
	for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) {
	    /* empty body: skip over whitespace */
	}
	if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==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






|









>
>
>
>



|
|
<
<
<
<
<
<
<
|
|
<







3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028







3029
3030

3031
3032
3033
3034
3035
3036
3037
    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

Changes to tests/namespace.test.

19
20
21
22
23
24
25






26
27
28
29
30
31
32
...
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
...
962
963
964
965
966
967
968






969
970
971
972
973
974
975
#
# 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_*]}







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] \
	    [string trimright [namespace current] :]::test_ns_1
} [string trimright [namespace current] :]::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     ::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 eval test_ns_2 { 
	proc namespace args {} 
    } 
    namespace eval test_ns_2 [namespace eval test_ns_1 { 
	namespace code {set v} 
    }] 
} {42} 







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} {






>
>
>
>
>
>







 







|
|
<










|
|


|







 







>
>
>
>
>
>







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
...
931
932
933
934
935
936
937
938
939

940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
...
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
#
# 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 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} {