diff options
| -rw-r--r-- | ChangeLog | 2 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 48 | ||||
| -rw-r--r-- | tests/namespace.test | 46 |
3 files changed, 74 insertions, 22 deletions
@@ -3,6 +3,8 @@ * generic/tclNamesp.c (Tcl_ForgetImport): Corrected faulty * tests/namespace.test: logic that relied exclusively on string matching and failed in the presence of [rename]s. [Bug 560297] + Also corrected faulty prevention of [namespace import] cycles. + [Bug 1017299] 2004-09-08 Kevin B. Kenny <kennykb@acm.org> diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 5cc4ed9..27aff8d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.2 2004/09/09 15:45:28 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.3 2004/09/09 17:12:13 dgp Exp $ */ #include "tclInt.h" @@ -1117,7 +1117,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Command *cmdPtr, *realCmdPtr; + Command *cmdPtr; ImportRef *refPtr; Tcl_Command autoCmd, importedCmd; ImportedCmdData *dataPtr; @@ -1217,6 +1217,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * pattern. Check whether it was exported. If it wasn't, * we ignore it. */ + Tcl_HashEntry *found; wasExported = 0; for (i = 0; i < importNsPtr->numExportPatterns; i++) { @@ -1234,9 +1235,9 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * Unless there is a name clash, create an imported command * in the current namespace that refers to cmdPtr. */ - - if ((Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) - || allowOverwrite) { + + found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); + if ((found == NULL) || allowOverwrite) { /* * Create the imported command and its client data. * To create the new command in the current namespace, @@ -1254,25 +1255,30 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) /* * Check whether creating the new imported command in the - * current namespace would create a cycle of imported->real - * command references that also would destroy an existing - * "real" command already in the current namespace. + * current namespace would create a cycle of imported + * command references. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if (cmdPtr->deleteProc == DeleteImportedCmd) { - realCmdPtr = (Command *) TclGetOriginalCommand( - (Tcl_Command) cmdPtr); - if ((realCmdPtr != NULL) - && (realCmdPtr->nsPtr == currNsPtr) - && (Tcl_FindHashEntry(&currNsPtr->cmdTable, - cmdName) != NULL)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "import pattern \"", pattern, - "\" would create a loop containing command \"", - Tcl_DStringValue(&ds), "\"", (char *) NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; + if ((found != NULL) + && cmdPtr->deleteProc == DeleteImportedCmd) { + + Command *overwrite = (Command *) Tcl_GetHashValue(found); + Command *link = cmdPtr; + while (link->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr; + + dataPtr = (ImportedCmdData *) link->objClientData; + link = dataPtr->realCmdPtr; + if (overwrite == link) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "import pattern \"", pattern, + "\" would create a loop containing ", + "command \"", Tcl_DStringValue(&ds), + "\"", (char *) NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } } } diff --git a/tests/namespace.test b/tests/namespace.test index 1b0c23d..1751eb5 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.21.2.1 2004/09/09 15:45:28 dgp Exp $ +# RCS: @(#) $Id: namespace.test,v 1.21.2.2 2004/09/09 17:12:13 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -244,6 +244,50 @@ test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { [test_ns_export::cmd1 j k l] } {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}} +test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { + namespace eval one { + namespace export cmd + proc cmd {} {} + } + namespace eval two { + namespace export cmd + proc other args {} + } + namespace eval two \ + [list namespace import [namespace current]::one::cmd] + namespace eval three \ + [list namespace import [namespace current]::two::cmd] + namespace eval three { + rename cmd other + namespace export other + } +} -body { + namespace eval two [list namespace import -force \ + [namespace current]::three::other] + namespace origin two::other +} -cleanup { + namespace delete one two three +} -match glob -result *::one::cmd + +test namespace-9.9 {Tcl_Import: Bug 1017299} -setup { + namespace eval one { + namespace export cmd + proc cmd {} {} + } + namespace eval two namespace export cmd + namespace eval two \ + [list namespace import [namespace current]::one::cmd] + namespace eval three namespace export cmd + namespace eval three \ + [list namespace import [namespace current]::two::cmd] +} -body { + namespace eval two [list namespace import -force \ + [namespace current]::three::cmd] + namespace origin two::cmd +} -cleanup { + namespace delete one two three +} -returnCodes error -match glob -result {import pattern * would create a loop*} + test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} { catch {eval namespace delete [namespace children :: test_ns_*]} list [catch {namespace forget xyzzy::*} msg] $msg |