summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2013-02-21 03:04:32 (GMT)
committerdgp <dgp@users.sourceforge.net>2013-02-21 03:04:32 (GMT)
commit7c09879dbba02a4c3b86b6fbc4b9f1a05dba7b5b (patch)
tree07c48614a03f7136e549dac0234cda794f4b14f1
parentee8be54ede03c2d1f37f4639dcff5b9a94722992 (diff)
parentbcf9541b4ce95bf706927ad15cab723e849e54aa (diff)
downloadtcl-7c09879dbba02a4c3b86b6fbc4b9f1a05dba7b5b.zip
tcl-7c09879dbba02a4c3b86b6fbc4b9f1a05dba7b5b.tar.gz
tcl-7c09879dbba02a4c3b86b6fbc4b9f1a05dba7b5b.tar.bz2
3605447 Make sure the -clear option to [namespace export] always clears,
whether or not new export patterns are specified.
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclNamesp.c61
-rw-r--r--tests/namespace.test8
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_*]}