3605447 Make sure the -clear option to [namespace export] always clears,

whether or not new export patterns are specified.

3 files changed, 35 insertions, 40 deletions

diff --git a/ChangeLog b/ChangeLog
index 81d2616..a2970f3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2013-02-20  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclNamesp.c:	[Bug 3605447] Make sure the -clear option
+	* tests/namespace.test:	to [namespace export] always clears, whether
+	or not new export patterns are specified.
+
 2013-02-15  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/regc_nfa.c:	[Bug 3604074] Fix regexp optimization to
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 77352a1..be7c4cd 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -454,8 +454,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
 	 * Find the parent for the new namespace.
 	 */
 
-	TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
-		/*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
+	TclGetNamespaceForQualName(interp, name, NULL, CREATE_NS_IF_UNKNOWN,
 		&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
 
 	/*
@@ -930,8 +929,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
      * Check that the pattern doesn't have namespace qualifiers.
      */
 
-    TclGetNamespaceForQualName(interp, pattern, nsPtr,
-	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
+    TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
 	    &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
 
     if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
@@ -1032,7 +1030,7 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr)
      */
 
     if (namespacePtr == NULL) {
-        nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp);
+        nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
     } else {
         nsPtr = (Namespace *) namespacePtr;
     }
@@ -1158,8 +1156,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
 	        "empty import pattern", -1);
         return TCL_ERROR;
     }
-    TclGetNamespaceForQualName(interp, pattern, nsPtr,
-	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
+    TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
 	    &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
 
     if (importNsPtr == NULL) {
@@ -1363,8 +1360,7 @@ Tcl_ForgetImport(interp, namespacePtr, pattern)
      * and the simple pattern.
      */
 
-    TclGetNamespaceForQualName(interp, pattern, nsPtr,
-	    /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
+    TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
 	    &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
 
     if (sourceNsPtr == NULL) {
@@ -3131,10 +3127,7 @@ NamespaceExportCmd(dummy, interp, objc, objv)
     int objc;			/* Number of arguments. */
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
-    Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp);
-    char *pattern, *string;
-    int resetListFirst = 0;
-    int firstArg, patternCt, i, result;
+    int firstArg, i;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 2, objv,
@@ -3143,37 +3136,27 @@ NamespaceExportCmd(dummy, interp, objc, objv)
     }
 
     /*
-     * Process the optional "-clear" argument.
+     * If no pattern arguments are given, and "-clear" isn't specified,
+     * return the namespace's current export pattern list.
      */
 
-    firstArg = 2;
-    if (firstArg < objc) {
-	string = Tcl_GetString(objv[firstArg]);
-	if (strcmp(string, "-clear") == 0) {
-	    resetListFirst = 1;
-	    firstArg++;
-	}
+    if (objc == 2) {
+	Tcl_Obj *listPtr = Tcl_NewObj();
+
+	(void) Tcl_AppendExportList(interp, NULL, listPtr);
+	Tcl_SetObjResult(interp, listPtr);
+	return TCL_OK;
     }
 
     /*
-     * If no pattern arguments are given, and "-clear" isn't specified,
-     * return the namespace's current export pattern list.
+     * Process the optional "-clear" argument.
      */
 
-    patternCt = (objc - firstArg);
-    if (patternCt == 0) {
-	if (firstArg > 2) {
-	    return TCL_OK;
-	} else {		/* create list with export patterns */
-	    Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
-	    result = Tcl_AppendExportList(interp,
-		    (Tcl_Namespace *) currNsPtr, listPtr);
-	    if (result != TCL_OK) {
-		return result;
-	    }
-	    Tcl_SetObjResult(interp, listPtr);
-	    return TCL_OK;
-	}
+    firstArg = 2;
+    if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
+	Tcl_Export(interp, NULL, "::", 1);
+	Tcl_ResetResult(interp);
+	firstArg++;
     }
 
     /*
@@ -3181,9 +3164,7 @@ NamespaceExportCmd(dummy, interp, objc, objv)
      */
     
     for (i = firstArg;  i < objc;  i++) {
-	pattern = Tcl_GetString(objv[i]);
-	result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
-		((i == firstArg)? resetListFirst : 0));
+	int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
         if (result != TCL_OK) {
             return result;
         }
diff --git a/tests/namespace.test b/tests/namespace.test
index 166ff00..cac547a 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1056,6 +1056,14 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} {
     }
     list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
 } [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
+test namespace-26.8 {NamespaceExportCmd, -clear resets export list} {
+    catch {namespace delete foo}
+    namespace eval foo {
+	namespace export x
+	namespace export -clear
+    }
+    list [namespace eval foo namespace export] [namespace delete foo]
+} {{} {}}
 
 test namespace-27.1 {NamespaceForgetCmd, no args} {
     catch {eval namespace delete [namespace children :: test_ns_*]}