diff options
Diffstat (limited to 'tests/namespace.test')
| -rw-r--r-- | tests/namespace.test | 565 |
1 files changed, 464 insertions, 101 deletions
diff --git a/tests/namespace.test b/tests/namespace.test index ed9889c..fab0040 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1,22 +1,23 @@ # Functionality covered: this file contains a collection of tests for the -# procedures in tclNamesp.c that implement Tcl's basic support for -# namespaces. Other namespace-related tests appear in variable.test. +# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic +# support for namespaces. Other namespace-related tests appear in +# variable.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # -# 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.62 2006/11/03 00:34:53 hobbs Exp $ +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import -force ::tcltest::* +testConstraint memory [llength [info commands memory]] + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] # # REMARK: the tests for 'namespace upvar' are not done here. They are to be @@ -25,6 +26,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} + +proc fq {ns} { + if {[string match ::* $ns]} {return $ns} + set current [uplevel 1 {namespace current}] + return [string trimright $current :]::[string trimleft $ns :] +} test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { namespace children :: test_ns_* @@ -45,7 +52,6 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { } } lappend l [namespace current] - set l } {:: ::test_ns_1 ::test_ns_1::foo ::} test namespace-3.1 {Tcl_GetGlobalNamespace} { @@ -148,7 +154,6 @@ test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} { } {} test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} { # [Bug 1355942] - # Currently fails due to [Bug 1355342] namespace eval test_ns_2 { proc x {} {} trace add command x delete "namespace delete [namespace current];#" @@ -165,13 +170,29 @@ test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} } {} test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} { # [Bug 1355942] - # Currently fails due to [Bug 1355342] namespace eval test_ns_2 { proc x {} {} trace add command x delete "namespace delete [namespace current];#" } namespace delete test_ns_2 } {} +test namespace-7.7 {Bug 1655305} -setup { + interp create slave + # Can't invoke through the ensemble, since deleting the global namespace + # (indirectly, via deleting ::tcl) deletes the ensemble. + slave eval {rename ::tcl::info::commands ::infocommands} + slave hide infocommands + slave eval { + proc foo {} { + namespace delete :: + } + } +} -body { + slave eval foo + slave invokehidden infocommands +} -cleanup { + interp delete slave +} -result {} test namespace-8.1 {TclTeardownNamespace, delete global namespace} { @@ -217,7 +238,7 @@ test namespace-8.3 {TclTeardownNamespace, delete child namespaces} { [namespace children test_ns_1] \ [catch {namespace children test_ns_1::test_ns_2} msg] $msg \ [info commands test_ns_1::test_ns_2::test_ns_3a::*] -} {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}} +} {::test_ns_1::test_ns_2 {} {} 1 {namespace "test_ns_1::test_ns_2" not found in "::"} {}} test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_export { @@ -282,7 +303,7 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { +test namespace-9.5 {Tcl_Import, RFE 1230597} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg } {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { @@ -537,6 +558,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { lappend l [info commands ::test_ns_import::*] } } {::test_ns_import::cmd1 {}} +test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { + # Will panic if still buggy + namespace eval src {namespace export foo; proc foo {} {}} + namespace eval dst {namespace import [namespace parent]::src::foo} + trace add command src::foo delete \ + "[list namespace delete [namespace current]::dst] ;#" + proc src::foo {} {} + namespace delete src +} {} test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -557,7 +587,7 @@ test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } -} {1 {can't read "::test_ns_777::v": no such variable} 1 {unknown namespace "test_ns_777" in namespace children command}} +} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} test namespace-14.3 {TclGetNamespaceForQualName, relative names} { namespace eval test_ns_1 { list $v $test_ns_2::v @@ -571,15 +601,14 @@ test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up onl list [namespace children test_ns_2] \ [catch {namespace children test_ns_1} msg] $msg } -} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval ::test_ns_2 { namespace eval bar {} } namespace eval test_ns_1 { - set l [list [catch {namespace delete test_ns_2::bar} msg] $msg] + list [catch {namespace delete test_ns_2::bar} msg] $msg } - set l } {1 {unknown namespace "test_ns_2::bar" in namespace delete command}} test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { @@ -589,7 +618,7 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl list [namespace children test_ns_2] \ [catch {namespace children test_ns_1} msg] $msg } -} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { namespace children test_ns_1::: } {::test_ns_1::test_ns_2} @@ -700,14 +729,16 @@ test namespace-16.8 {Tcl_FindCommand, relative name found} { cmd a b c } } {::test_ns_1::cmd: a b c} -test namespace-16.9 {Tcl_FindCommand, relative name found} { - catch {rename cmd2 {}} +test namespace-16.9 {Tcl_FindCommand, relative name found} -body { proc cmd2 {args} {return "[namespace current]::cmd2: $args"} namespace eval test_ns_1 { cmd2 a b c } -} {::::cmd2: a b c} -test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} { +} -cleanup { + catch {rename cmd2 {}} +} -result {::::cmd2: a b c} +test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} -body { + proc cmd2 {args} {return "[namespace current]::cmd2: $args"} namespace eval test_ns_1 { proc cmd2 {args} { return "[namespace current]::cmd2 in test_ns_1: $args" @@ -716,7 +747,9 @@ test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current cmd2 a b c } } -} {::::cmd2: a b c} +} -cleanup { + catch {rename cmd2 {}} +} -result {::::cmd2: a b c} test namespace-16.11 {Tcl_FindCommand, relative name not found} { namespace eval test_ns_1 { list [catch {cmd3 a b c} msg] $msg @@ -794,7 +827,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 - set a + return $a } 1 catch {unset a} catch {unset x} @@ -816,7 +849,6 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] - set l } {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { @@ -837,7 +869,6 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado } } lappend l [test_ns_1::trigger] - set l } {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} catch {unset l} catch {rename foo {}} @@ -852,11 +883,11 @@ test namespace-19.2 {GetNamespaceFromObj, relative name found} { namespace children test_ns_2 } } {} -test namespace-19.3 {GetNamespaceFromObj, name not found} { +test namespace-19.3 {GetNamespaceFromObj, name not found} -body { namespace eval test_ns_1 { - list [catch {namespace children test_ns_99} msg] $msg + namespace children test_ns_99 } -} {1 {unknown namespace "test_ns_99" in namespace children command}} +} -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"} test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace eval test_ns_1 { proc foo {} { @@ -869,7 +900,6 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] - set l } {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { @@ -878,7 +908,7 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body { namespace wombat {} -} -returnCodes error -match glob -result {bad option "wombat": must be *} +} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *} test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} @@ -914,6 +944,10 @@ test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { namespace eval test_ns_1::test_ns_foo {} lsort [namespace children test_ns_1 test*] } [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}] +test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} { + namespace eval test_ns_1 {} + namespace children [namespace current] [fq test_ns_1] +} [fq test_ns_1] test namespace-22.1 {NamespaceCodeCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -924,11 +958,11 @@ test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} { namespace eval test_ns_1 { proc cmd {} {return "test_ns_1::cmd"} } - namespace code {namespace inscope ::test_ns_1 cmd} -} {namespace inscope ::test_ns_1 cmd} + namespace code {::namespace inscope ::test_ns_1 cmd} +} {::namespace inscope ::test_ns_1 cmd} test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} { namespace code {namespace inscope ::test_ns_1 cmd} -} {namespace inscope ::test_ns_1 cmd} +} {::namespace inscope :: {namespace inscope ::test_ns_1 cmd}} test namespace-22.4 {NamespaceCodeCmd, in :: namespace} { namespace code unknown } {::namespace inscope :: unknown} @@ -948,6 +982,12 @@ test namespace-22.6 {NamespaceCodeCmd, in other namespace} { namespace code {set v} }] } {42} +test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} { + namespace eval demo { + proc namespace args {puts $args} + ::namespace code {namespace inscope foo} + } +} [list ::namespace inscope [fq demo] {namespace inscope foo}] test namespace-23.1 {NamespaceCurrentCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -985,7 +1025,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} { } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} test namespace-25.2 {NamespaceEvalCmd, bad args} -body { namespace test_ns_1 -} -returnCodes error -match glob -result {bad option "test_ns_1": must be *} +} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *} catch {unset v} test namespace-25.3 {NamespaceEvalCmd, new namespace} { set v 123 @@ -1080,6 +1120,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_*]} @@ -1101,10 +1149,23 @@ test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} { info commands ::test_ns_2::* } {::test_ns_2::cmd2} -test namespace-28.1 {NamespaceImportCmd, no args} { +test namespace-28.1 {NamespaceImportCmd, no args} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - namespace import -} {} +} -body { + namespace eval ::test_ns_1 { + proc foo {} {} + proc bar {} {} + proc boo {} {} + proc glorp {} {} + namespace export foo b* + } + namespace eval ::test_ns_2 { + namespace import ::test_ns_1::* + lsort [namespace import] + } +} -cleanup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -result {bar boo foo} test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} { namespace import -force } {} @@ -1128,9 +1189,9 @@ test namespace-29.1 {NamespaceInscopeCmd, bad args} { test namespace-29.2 {NamespaceInscopeCmd, bad args} { list [catch {namespace inscope ::} msg] $msg } {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} -test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} { - list [catch {namespace inscope test_ns_1 {set v}} msg] $msg -} {1 {unknown namespace "test_ns_1" in inscope namespace command}} +test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} -body { + namespace inscope test_ns_1 {set v} +} -returnCodes error -result {namespace "test_ns_1" not found in "::"} test namespace-29.4 {NamespaceInscopeCmd, simple case} { namespace eval test_ns_1 { variable v 747 @@ -1200,9 +1261,9 @@ test namespace-31.3 {NamespaceParentCmd, namespace specified} { [namespace parent test_ns_1::test_ns_2] \ [namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}] } {{} ::test_ns_1 ::test_ns_1} -test namespace-31.4 {NamespaceParentCmd, bad namespace specified} { - list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg -} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}} +test namespace-31.4 {NamespaceParentCmd, bad namespace specified} -body { + namespace parent test_ns_1::test_ns_foo +} -returnCodes error -result {namespace "test_ns_1::test_ns_foo" not found in "::"} test namespace-32.1 {NamespaceQualifiersCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1348,11 +1409,11 @@ test namespace-37.1 {SetNsNameFromAny, ns name found} { namespace children ::test_ns_1 } } {::test_ns_1::test_ns_2} -test namespace-37.2 {SetNsNameFromAny, ns name not found} { +test namespace-37.2 {SetNsNameFromAny, ns name not found} -body { namespace eval test_ns_1 { - list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg + namespace children ::test_ns_1::test_ns_foo } -} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}} +} -returnCodes error -result {namespace "::test_ns_1::test_ns_foo" not found} test namespace-38.1 {UpdateStringOfNsName} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1381,16 +1442,17 @@ test namespace-39.3 {NamespaceExistsCmd error} { list [catch {namespace exists a b} msg] $msg } {1 {wrong # args: should be "namespace exists name"}} -test namespace-40.1 {Ignoring namespace proc "unknown"} { +test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { rename unknown _unknown +} -body { proc unknown args {return global} namespace eval ns {proc unknown args {return local}} - set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]] + list [namespace eval ns aaa bbb] [namespace eval ns aaa] +} -cleanup { rename unknown {} rename _unknown unknown namespace delete ns - set l -} {global global} +} -result {global global} test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} @@ -1408,7 +1470,6 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {0 1} - test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { set res {} namespace eval ns {} @@ -1422,19 +1483,16 @@ test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {New proc is called} - test namespace-41.3 {Shadowing byte-compiled commands, Bugs: 231259, 729692} { set res {} namespace eval ns { variable b 0 } - proc ns::a {i} { variable b proc set args {return "New proc is called"} return [set b $i] } - set res [list [ns::a 1] $ns::b] namespace delete ns set res @@ -1473,18 +1531,18 @@ test namespace-42.3 {ensembles: basic} { namespace delete ns lappend result [info command ns::x1] } {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}} -test namespace-42.4 {ensembles: basic} { +test namespace-42.4 {ensembles: basic} -body { namespace eval ns { namespace export y* proc x1 {} {format 1} proc x2 {} {format 2} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown subcommand "x": namespace ::ns does not export any commands}} -test namespace-42.5 {ensembles: basic} { +} -result {1 {unknown subcommand "x": namespace ::ns does not export any commands}} +test namespace-42.5 {ensembles: basic} -body { namespace eval ns { namespace export x* proc x1 {} {format 1} @@ -1492,11 +1550,11 @@ test namespace-42.5 {ensembles: basic} { proc x3 {} {format 3} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} -test namespace-42.6 {ensembles: nested} { +} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} +test namespace-42.6 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1509,11 +1567,11 @@ test namespace-42.6 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {0 1 2 3} -test namespace-42.7 {ensembles: nested} { +} -result {0 1 2 3} +test namespace-42.7 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1526,10 +1584,24 @@ test namespace-42.7 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {{1 ::ns::x0::z} 1 2 3} +} -result {{1 ::ns::x0::z} 1 2 3} +test namespace-42.8 {ensembles: [Bug 1670091]} -setup { + proc demo args {} + variable target [list [namespace which demo] x] + proc trial args {variable target; string length $target} + trace add execution demo enter [namespace code trial] + namespace ensemble create -command foo -map [list bar $target] +} -body { + foo bar +} -cleanup { + unset target + rename demo {} + rename trial {} + rename foo {} +} -result {} test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { @@ -1542,7 +1614,7 @@ test namespace-43.1 {ensembles: dict-driven} { rename ns {} lappend result [namespace ensemble exists ns] } {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0} -test namespace-43.2 {ensembles: dict-driven} { +test namespace-43.2 {ensembles: dict-driven} -body { namespace eval ns { namespace export x* proc x1 {args} {list 1 $args} @@ -1551,10 +1623,10 @@ test namespace-43.2 {ensembles: dict-driven} { a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .} } } - set result [list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]] + list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo] +} -cleanup { namespace delete ns - set result -} {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} +} -result {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} set SETUP { namespace eval ns { namespace export a b @@ -1652,6 +1724,9 @@ test namespace-44.5 {ensemble: errors} -setup { } -cleanup { rename foobar {} } -returnCodes error -result {invalid command name "::foobarconfigure"} +test namespace-44.6 {ensemble: errors} -returnCodes error -body { + namespace ensemble create gorp +} -result {wrong # args: should be "namespace ensemble create ?option value ...?"} test namespace-45.1 {ensemble: introspection} { namespace eval ns { @@ -1662,7 +1737,7 @@ test namespace-45.1 {ensemble: introspection} { } namespace delete ns set result -} {-map {} -namespace ::ns -prefixes 1 -subcommands {} -unknown {}} +} {-map {} -namespace ::ns -parameters {} -prefixes 1 -subcommands {} -unknown {}} test namespace-45.2 {ensemble: introspection} { namespace eval ns { namespace export x @@ -1678,15 +1753,12 @@ test namespace-46.1 {ensemble: modification} { namespace eval ns { namespace export x proc x {} {format 123} - # Ensemble maps A->x namespace ensemble create -command ns -map {A ::ns::x} set ::result [list [namespace ensemble configure ns -map] [ns A]] - # Ensemble maps B->x namespace ensemble configure ns -map {B ::ns::x} lappend ::result [namespace ensemble configure ns -map] [ns B] - # Ensemble maps x->x namespace ensemble configure ns -map {} lappend ::result [namespace ensemble configure ns -map] [ns x] @@ -1726,7 +1798,7 @@ test namespace-46.3 {ensemble: implementation errors} { lappend result $ns::count namespace delete ns lappend result [info command p] -} {1 {wrong # args: should be "ns subcommand ?argument ...?"} 10 3010 3010 {}} +} {1 {wrong # args: should be "ns subcommand ?arg ...?"} 10 3010 3010 {}} test namespace-46.4 {ensemble: implementation errors} { namespace eval ns { namespace ensemble create @@ -1876,7 +1948,7 @@ test namespace-47.5 {ensemble: unknown handler} { lappend result [catch {foo bar} msg] $msg [namespace ensemble config foo] rename foo {} set result -} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -prefixes 1 -subcommands {} -unknown bar}} +} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -parameters {} -prefixes 1 -subcommands {} -unknown bar}} test namespace-47.6 {ensemble: unknown handler} { namespace ensemble create -command foo -unknown bar proc bar {args} { @@ -1943,7 +2015,7 @@ test namespace-48.1 {ensembles and namespace import: unknown handler} { bar z 789 namespace delete foo set result -} {{-map {} -namespace ::foo -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789} +} {{-map {} -namespace ::foo -parameters {} -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789} test namespace-48.2 {ensembles and namespace import: exists} { namespace eval foo { namespace ensemble create -command ::foo::bar @@ -2007,7 +2079,7 @@ test namespace-50.1 {ensembles affect proc arguments error messages} -body { namespace ens cre -command a -map {b {bb foo}} proc bb {c d {e f} args} {list $c $args} a b -} -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup { +} -returnCodes error -result "wrong # args: should be \"a b d ?e? ?arg ...?\"" -cleanup { rename a {} rename bb {} } @@ -2024,6 +2096,7 @@ test namespace-50.3 {chained ensembles affect error messages} -body { a b d } -returnCodes error -result "wrong # args: should be \"a b d f\"" -cleanup { rename a {} + rename c {} } test namespace-50.4 {chained ensembles affect error messages} -body { namespace ens cre -command a -map {b {c d}} @@ -2032,6 +2105,7 @@ test namespace-50.4 {chained ensembles affect error messages} -body { a b d } -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup { rename a {} + rename c {} } test namespace-51.1 {name resolution path control} -body { @@ -2300,7 +2374,7 @@ test namespace-51.10 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace path does::not::exist } -} -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup { +} -returnCodes error -result {namespace "does::not::exist" not found in "::test_ns_1"} -cleanup { catch {namespace delete ::test_ns_1} } test namespace-51.11 {name resolution path control} -body { @@ -2343,16 +2417,14 @@ test namespace-51.12 {name resolution path control} -body { catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } - test namespace-51.13 {name resolution path control} -body { - # Currently fails due to [Bug 1355342] set ::result {} namespace eval ::test_ns_1 { proc foo {} {lappend ::result 1} } namespace eval ::test_ns_2 { proc foo {} {lappend ::result 2} - trace add command foo delete {namespace eval ::test_ns_3 foo;#} + trace add command foo delete "namespace eval ::test_ns_3 foo;#" } namespace eval ::test_ns_3 { proc foo {} { @@ -2375,17 +2447,17 @@ test namespace-51.13 {name resolution path control} -body { catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } -test namespace-51.14 {name resolution path control} -body { +test namespace-51.14 {name resolution path control} -setup { foreach cmd [info commands foo*] { rename $cmd {} } + namespace eval ::test_ns_1 {} + namespace eval ::test_ns_2 {} + namespace eval ::test_ns_3 {} +} -body { proc foo0 {} {} - namespace eval ::test_ns_1 { - proc foo1 {} {} - } - namespace eval ::test_ns_2 { - proc foo2 {} {} - } + proc ::test_ns_1::foo1 {} {} + proc ::test_ns_2::foo2 {} {} namespace eval ::test_ns_3 { variable result {} lappend result [info commands foo*] @@ -2398,11 +2470,11 @@ test namespace-51.14 {name resolution path control} -body { namespace delete ::test_ns_1 lappend result [info commands foo*] } -} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} -cleanup { +} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} -} +} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} test namespace-51.15 {namespace resolution path control} -body { namespace eval ::test_ns_2 { proc foo {} {return 2} @@ -2425,6 +2497,62 @@ test namespace-51.16 {Bug 1566526} { slave eval namespace eval demo namespace path :: interp delete slave } {} +test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { + set result {} + catch {namespace delete ::a} +} -body { + namespace eval ::a { + proc c {} {lappend ::result A} + c + namespace eval b { + variable d c + lappend ::result [catch { $d }] + } + lappend ::result . + namespace eval b { + namespace path [namespace parent] + $d;[format %c 99] + } + lappend ::result . + namespace eval b { + proc c {} {lappend ::result B} + $d;[format %c 99] + } + lappend ::result . + } + namespace eval ::a::b { + $d;[format %c 99] + lappend ::result . + proc ::c {} {lappend ::result G} + $d;[format %c 99] + lappend ::result . + rename ::a::c {} + $d;[format %c 99] + lappend ::result . + rename ::a::b::c {} + $d;[format %c 99] + } +} -cleanup { + namespace delete ::a + catch {rename ::c {}} + unset result +} -result {A 1 . A A . B B . B B . B B . B B . G G} +test namespace-51.18 {Bug 3185407} -setup { + namespace eval ::test_ns_1 {} +} -body { + namespace eval ::test_ns_1 { + variable result {} + namespace eval ns {proc foo {} {}} + namespace eval ns2 {proc foo {} {}} + namespace path {ns ns2} + variable x foo + lappend result [namespace which $x] + proc foo {} {} + lappend result [namespace which $x] + } +} -cleanup { + namespace delete ::test_ns_1 +} -result {::test_ns_1::ns::foo ::test_ns_1::foo} # TIP 181 - namespace unknown tests test namespace-52.1 {unknown: default handler ::unknown} { @@ -2586,7 +2714,242 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup { rename unknown.save ::unknown namespace eval :: [list namespace unknown $handler] } -result SUCCESS - +test namespace-52.12 {unknown: error case must not reset handler} -body { + namespace eval foo { + namespace unknown ok + catch {namespace unknown {{}{}{}}} + namespace unknown + } +} -cleanup { + namespace delete foo +} -result ok + +# TIP 314 - ensembles with parameters +test namespace-53.1 {ensembles: parameters} { + namespace eval ns { + namespace export x + proc x {para} {list 1 $para} + namespace ensemble create -parameters {para1} + } + list [info command ns] [ns bar x] [namespace delete ns] [info command ns] +} {ns {1 bar} {} {}} +test namespace-53.2 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x + proc x {para} {list 1 $para} + namespace ensemble create + } +} -body { + namespace ensemble configure ns -parameters {para1} + rename ns foo + list [info command foo] [foo bar x] [namespace delete ns] [info command foo] +} -result {foo {1 bar} {} {}} +test namespace-53.3 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {para} {list 1 $para} + proc x2 {para} {list 2 $para} + namespace ensemble create -parameters param1 + } +} -body { + set result [list [ns x2 x1] [ns x1 x2]] + lappend result [catch {ns x} msg] $msg + lappend result [catch {ns x x} msg] $msg + rename ns {} + lappend result [info command ns::x1] + namespace delete ns + lappend result [info command ns::x1] +} -result\ + {{1 x2} {2 x1}\ + 1 {wrong # args: should be "ns param1 subcommand ?arg ...?"}\ + 1 {unknown or ambiguous subcommand "x": must be x1, or x2}\ + ::ns::x1 {}} +test namespace-53.4 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {a1 a2} {list 1 $a1 $a2} + proc x2 {a1 a2} {list 2 $a1 $a2} + proc x3 {a1 a2} {list 3 $a1 $a2} + namespace ensemble create + } +} -body { + set result {} + lappend result [ns x1 x2 x3] + namespace ensemble configure ns -parameters p1 + lappend result [ns x1 x2 x3] + namespace ensemble configure ns -parameters {p1 p2} + lappend result [ns x1 x2 x3] +} -cleanup { + namespace delete ns +} -result {{1 x2 x3} {2 x1 x3} {3 x1 x2}} +test namespace-53.5 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {para} {list 1 $para} + proc x2 {para} {list 2 $para} + proc x3 {para} {list 3 $para} + namespace ensemble create + } +} -body { + set result [list [catch {ns x x1} msg] $msg] + lappend result [catch {ns x1 x} msg] $msg + namespace ensemble configure ns -parameters p1 + lappend result [catch {ns x1 x} msg] $msg + lappend result [catch {ns x x1} msg] $msg +} -cleanup { + namespace delete ns +} -result\ + {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\ + 0 {1 x}\ + 1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\ + 0 {1 x}} +test namespace-53.6 {ensembles: nested} -setup { + namespace eval ns { + namespace export x* + namespace eval x0 { + proc z {args} {list 0 $args} + namespace export z + namespace ensemble create + } + proc x1 {args} {list 1 $args} + proc x2 {args} {list 2 $args} + proc x3 {args} {list 3 $args} + namespace ensemble create -parameters p + } +} -body { + list [ns z x0] [ns z x1] [ns z x2] [ns z x3] +} -cleanup { + namespace delete ns +} -result {{0 {}} {1 z} {2 z} {3 z}} +test namespace-53.7 {ensembles: parameters & wrong # args} -setup { + namespace eval ns { + namespace export x* + proc x1 {a1 a2 a3 a4} {list x1 $a1 $a2 $a3 $a4} + namespace ensemble create -parameters p1 + } +} -body { + set result {} + lappend result [catch {ns} msg] $msg + lappend result [catch {ns x1} msg] $msg + lappend result [catch {ns x1 x1} msg] $msg + lappend result [catch {ns x1 x1 x1} msg] $msg + lappend result [catch {ns x1 x1 x1 x1} msg] $msg + lappend result [catch {ns x1 x1 x1 x1 x1} msg] $msg +} -cleanup { + namespace delete ns +} -result\ + {1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\ + 1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\ + 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\ + 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\ + 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\ + 0 {x1 x1 x1 x1 x1}} +test namespace-53.8 {ensemble: unknown handler changing -parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {a1} {list 1 $a1} + proc Magic {ensemble subcmd args} { + namespace ensemble configure $ensemble\ + -parameters [lrange p1 [llength [ + namespace ensemble configure $ensemble -parameters + ]] 0] + list + } + namespace ensemble create -unknown ::ns::Magic + } +} -body { + set result {} + lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns x2 x3} msg] $msg [namespace ensemble configure ns -parameters] +} -cleanup { + namespace delete ns +} -result\ + {0 {1 x2} {}\ + 0 {1 x2} p1\ + 1 {unknown or ambiguous subcommand "x2": must be x1} {}} +test namespace-53.9 {ensemble: unknown handler changing -parameters,\ + thereby eating all args} -setup { + namespace eval ns { + namespace export x* + proc x1 {args} {list 1 $args} + proc Magic {ensemble subcmd args} { + namespace ensemble configure $ensemble\ + -parameters {p1 p2 p3 p4 p5} + list + } + namespace ensemble create -unknown ::ns::Magic + } +} -body { + set result {} + lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns a1 a2 a3 a4 a5 x1} msg] $msg [namespace ensemble configure ns -parameters] +} -cleanup { + namespace delete ns +} -result\ + {0 {1 x2} {}\ + 1 {wrong # args: should be "ns p1 p2 p3 p4 p5 subcommand ?arg ...?"} {p1 p2 p3 p4 p5}\ + 0 {1 {a1 a2 a3 a4 a5}} {p1 p2 p3 p4 p5}} +test namespace-53.10 {ensembles: nested rewrite} -setup { + namespace eval ns { + namespace export x + namespace eval x { + proc z0 {} {list 0} + proc z1 {a1} {list 1 $a1} + proc z2 {a1 a2} {list 2 $a1 $a2} + proc z3 {a1 a2 a3} {list 3 $a1 $a2 $a3} + namespace export z* + namespace ensemble create + } + namespace ensemble create -parameters p + } +} -body { + set result {} + # In these cases, parsing the subensemble does not grab a new word. + lappend result [catch {ns z0 x} msg] $msg + lappend result [catch {ns z1 x} msg] $msg + lappend result [catch {ns z2 x} msg] $msg + lappend result [catch {ns z2 x v} msg] $msg + namespace ensemble configure ns::x -parameters q1 + # In these cases, parsing the subensemble grabs a new word. + lappend result [catch {ns v x z0} msg] $msg + lappend result [catch {ns v x z1} msg] $msg + lappend result [catch {ns v x z2} msg] $msg + lappend result [catch {ns v x z2 v2} msg] $msg +} -cleanup { + namespace delete ns +} -result\ + {0 0\ + 1 {wrong # args: should be "ns z1 x a1"}\ + 1 {wrong # args: should be "ns z2 x a1 a2"}\ + 1 {wrong # args: should be "ns z2 x a1 a2"}\ + 1 {wrong # args: should be "::ns::x::z0"}\ + 0 {1 v}\ + 1 {wrong # args: should be "ns v x z2 a2"}\ + 0 {2 v v2}} + +test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ +-setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set ns ::y$i + namespace eval $ns {} + namespace delete $ns + set start $end + set end [getbytes] + } + set leakedBytes [expr {$end - $start}] +} -cleanup { + rename getbytes {} + unset i ns start end +} -result 0 + # cleanup catch {rename cmd1 {}} catch {unset l} |