From 5dd2f03f50c212303b25308aaef88ccc7b87bd76 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Feb 2013 19:18:42 +0000 Subject: 36054447 Convert [namespace export -clear] interface to something less stupid. Test suite does not demand the stupidity continue, thank goodness. --- generic/tclNamesp.c | 50 ++++++++++++++++++-------------------------------- 1 file changed, 18 insertions(+), 32 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 77352a1..22743a5 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1032,7 +1032,7 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr) */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -3131,10 +3131,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 +3140,28 @@ 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 ((objc > firstArg) + && (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0)) { + Tcl_Export(interp, NULL, "::", 1); + Tcl_ResetResult(interp); + firstArg++; } /* @@ -3181,9 +3169,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; } -- cgit v0.12 From 472e10b23285f3b4869e2cb5234a9e8d9f872412 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Feb 2013 20:16:16 +0000 Subject: refinement --- generic/tclNamesp.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 22743a5..f6827aa 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -3157,8 +3157,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) */ firstArg = 2; - if ((objc > firstArg) - && (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0)) { + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { Tcl_Export(interp, NULL, "::", 1); Tcl_ResetResult(interp); firstArg++; -- cgit v0.12 From f85e814a8bfeecccb8dbf087ac826c48b2e55444 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 21 Feb 2013 02:15:58 +0000 Subject: The flag TCL_LEAVE_ERR_MSG has no effect on the routine TclGetNamespaceForQualName() so for goodness sake stop making any special efforts to add it in when making calls. --- generic/tclNamesp.c | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index f6827aa..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)) { @@ -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) { -- cgit v0.12 From bcf9541b4ce95bf706927ad15cab723e849e54aa Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 21 Feb 2013 02:54:05 +0000 Subject: added test --- tests/namespace.test | 8 ++++++++ 1 file changed, 8 insertions(+) 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_*]} -- cgit v0.12