diff options
Diffstat (limited to 'tests/namespace.test')
| -rw-r--r-- | tests/namespace.test | 428 |
1 files changed, 352 insertions, 76 deletions
diff --git a/tests/namespace.test b/tests/namespace.test index 504d532..9d7cb59 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1,20 +1,20 @@ # 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. +# 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]] # # REMARK: the tests for 'namespace upvar' are not done here. They are to be @@ -23,7 +23,7 @@ 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}] @@ -49,7 +49,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} { @@ -596,9 +595,8 @@ test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up onl 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 { @@ -719,14 +717,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" @@ -735,7 +735,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 @@ -813,7 +815,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} @@ -835,7 +837,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 { @@ -856,7 +857,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 {}} @@ -888,7 +888,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} { @@ -897,7 +896,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_* } {} @@ -1014,7 +1013,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 @@ -1130,10 +1129,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_*]} +} -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_*]} - lsort [namespace import] -} {bytestring cleanupTests configure customMatch debug errorChannel errorFile getMatchingFiles interpreter limitConstraints loadFile loadScript loadTestedCommands mainThread makeDirectory makeFile match matchDirectories matchFiles normalizeMsg normalizePath outputChannel outputFile preserveCore removeDirectory removeFile restoreState runAllTests saveState singleProcess skip skipDirectories skipFiles temporaryDirectory test testConstraint testsDirectory threadReap verbose viewFile workingDirectory} +} -result {bar boo foo} test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} { namespace import -force } {} @@ -1410,16 +1422,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 {} @@ -1437,7 +1450,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 {} @@ -1451,19 +1463,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 @@ -1502,18 +1511,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} @@ -1521,11 +1530,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 { @@ -1538,11 +1547,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 { @@ -1555,10 +1564,10 @@ 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] @@ -1585,7 +1594,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} @@ -1594,10 +1603,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 @@ -1695,6 +1704,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 { @@ -1705,7 +1717,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 @@ -1721,15 +1733,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] @@ -1769,7 +1778,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 @@ -1919,7 +1928,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} { @@ -1986,7 +1995,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 @@ -2050,7 +2059,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 {} } @@ -2067,6 +2076,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}} @@ -2075,6 +2085,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 { @@ -2386,7 +2397,6 @@ 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 { set ::result {} namespace eval ::test_ns_1 { @@ -2394,7 +2404,7 @@ test namespace-51.13 {name resolution path control} -body { } 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 {} { @@ -2417,17 +2427,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*] @@ -2440,11 +2450,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} @@ -2467,6 +2477,46 @@ 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} +} -constraints knownBug -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} # TIP 181 - namespace unknown tests test namespace-52.1 {unknown: default handler ::unknown} { @@ -2637,7 +2687,233 @@ test namespace-52.12 {unknown: error case must not reset handler} -body { } -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} |