summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2013-02-21 03:16:21 (GMT)
committerdgp <dgp@users.sourceforge.net>2013-02-21 03:16:21 (GMT)
commit75356d2bd57c3f9c2107bab0cbff3dee826c7076 (patch)
treede158f20d809ee283b1fec11dd160db16dc30236
parentf8e35a6396aefc1ffbb6a104b8cfd659e1afa2d9 (diff)
parent7c09879dbba02a4c3b86b6fbc4b9f1a05dba7b5b (diff)
downloadtcl-75356d2bd57c3f9c2107bab0cbff3dee826c7076.zip
tcl-75356d2bd57c3f9c2107bab0cbff3dee826c7076.tar.gz
tcl-75356d2bd57c3f9c2107bab0cbff3dee826c7076.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.c63
-rw-r--r--tests/namespace.test8
3 files changed, 34 insertions, 43 deletions
diff --git a/ChangeLog b/ChangeLog
index dc27e27..009a49e 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-19 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclTrace.c: [Bug 2438181]: Incorrect error reporting in
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 44634d4..d2decb9 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -760,8 +760,7 @@ Tcl_CreateNamespace(
* Find the parent for the new namespace.
*/
- TclGetNamespaceForQualName(interp, name, NULL,
- /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
+ TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
/*
@@ -1277,8 +1276,7 @@ Tcl_Export(
* 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)) {
@@ -1491,8 +1489,7 @@ Tcl_Import(
Tcl_SetObjResult(interp, Tcl_NewStringObj("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) {
@@ -1730,8 +1727,7 @@ Tcl_ForgetImport(
* 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) {
@@ -3401,10 +3397,7 @@ NamespaceExportCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- char *pattern, *string;
- int resetListFirst = 0;
- int firstArg, patternCt, i, result;
+ int firstArg, i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?");
@@ -3412,41 +3405,27 @@ NamespaceExportCmd(
}
/*
- * 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 = TclGetString(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, 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++;
}
/*
@@ -3454,9 +3433,7 @@ NamespaceExportCmd(
*/
for (i = firstArg; i < objc; i++) {
- pattern = TclGetString(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 2be4cfc..4eecac1 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1109,6 +1109,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 {namespace delete {*}[namespace children :: test_ns_*]}