* generic/tclNamesp.c: Tighten the detector of nested [namespace code] bug_3202171

        * tests/namespace.test: quoting that the quoted scriptsfunction
        properly even in a namespace that contains a custom "namespace"
        command.  [Bug 3202171]

3 files changed, 33 insertions, 19 deletions

diff --git a/ChangeLog b/ChangeLog
index efc0a67..29dab58 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-03-09  Don Porter  <dgp@users.sourceforge.net>
+
+	* 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  <nijtmans@users.sf.net>
 
 	* generic/tclBasic.c: Fix gcc warnings: variable set but not used
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 1747c99..16f14e9 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -3007,7 +3007,7 @@ NamespaceCodeCmd(
 {
     Namespace *currNsPtr;
     Tcl_Obj *listPtr, *objPtr;
-    register char *arg, *p;
+    register char *arg;
     int length;
 
     if (objc != 3) {
@@ -3017,21 +3017,17 @@ NamespaceCodeCmd(
 
     /*
      * 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);
-    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;
-	}
+    if (*arg==':' && length > 20 
+	    && strncmp(arg, "::namespace inscope ", 20) == 0) {
+	Tcl_SetObjResult(interp, objv[2]);
+	return TCL_OK;
     }
 
     /*
diff --git a/tests/namespace.test b/tests/namespace.test
index 89f6759..504d532 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -24,6 +24,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # 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_*
 } {}
@@ -929,9 +935,8 @@ test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} {
 } [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
+    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_*]}
@@ -942,11 +947,11 @@ 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}
+    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}
+} {::namespace inscope :: {namespace     inscope     ::test_ns_1 cmd}}
 test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
     namespace code unknown
 } {::namespace inscope :: unknown}
@@ -966,6 +971,12 @@ test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
 	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_*]}