568 lines
17 KiB
Plaintext
568 lines
17 KiB
Plaintext
source [file dirname [info script]]/testing.tcl
|
|
needs cmd namespace
|
|
|
|
test namespace-1.1 {usage for "namespace" command} -body {
|
|
namespace
|
|
} -returnCodes error -match glob -result {wrong # args: should be *}
|
|
|
|
test namespace-1.2 {global namespace's name is "::" or {}} {
|
|
list [namespace current] [namespace eval {} {namespace current}] [namespace eval :: {namespace current}]
|
|
} {:: :: ::}
|
|
|
|
test namespace-1.3 {usage for "namespace eval"} -body {
|
|
namespace eval
|
|
} -returnCodes error -match glob -result {wrong # args: should be "namespace eval *"}
|
|
|
|
test namespace-1.5 {access a new namespace} {
|
|
namespace eval ns1 { namespace current }
|
|
} {::ns1}
|
|
|
|
test namespace-1.7 {usage for "namespace eval"} -body {
|
|
namespace eval ns1
|
|
} -returnCodes error -match glob -result {wrong # args: should be "namespace eval *"}
|
|
|
|
test namespace-1.8 {command "namespace eval" concatenates args} {
|
|
namespace eval ns1 namespace current
|
|
} {::ns1}
|
|
|
|
test namespace-1.9 {simple namespace elements} {
|
|
namespace eval ns1 {
|
|
variable v1 1
|
|
proc p1 {a} {variable v1; list $a $v1}
|
|
p1 3
|
|
}
|
|
} {3 1}
|
|
|
|
test namespace-1.10 {commands in a namespace} {
|
|
namespace eval ns1 {
|
|
info commands [namespace current]::*
|
|
}
|
|
} {::ns1::p1}
|
|
|
|
test namespace-1.11 {variables in a namespace} {
|
|
namespace eval ns1 {
|
|
info vars [namespace current]::*
|
|
}
|
|
} {::ns1::v1}
|
|
|
|
test namespace-1.12 {global vars are separate from locals vars} {
|
|
set v1 2
|
|
list [ns1::p1 123] [set ns1::v1] [set ::v1]
|
|
} {{123 1} 1 2}
|
|
|
|
test namespace-1.13 {add to an existing namespace} {
|
|
namespace eval ns1 {
|
|
variable v2 22
|
|
proc p2 {script} {variable v2; eval $script}
|
|
p2 {return $v2}
|
|
}
|
|
} 22
|
|
|
|
test namespace-1.14 {commands in a namespace} {
|
|
lsort [namespace eval ns1 {info commands [namespace current]::*}]
|
|
} {::ns1::p1 ::ns1::p2}
|
|
|
|
test namespace-1.15 {variables in a namespace} {
|
|
lsort [namespace eval ns1 {info vars [namespace current]::*}]
|
|
} {::ns1::v1 ::ns1::v2}
|
|
|
|
# Tcl produces fully scoped names here
|
|
test namespace-1.16 {variables in a namespace} jim {
|
|
lsort [info vars ns1::*]
|
|
} {ns1::v1 ns1::v2}
|
|
|
|
test namespace-1.17 {commands in a namespace are hidden} -body {
|
|
v2 {return 3}
|
|
} -returnCodes error -result {invalid command name "v2"}
|
|
|
|
test namespace-1.18 {using namespace qualifiers} {
|
|
ns1::p2 {return 44}
|
|
} 44
|
|
|
|
test namespace-1.19 {using absolute namespace qualifiers} {
|
|
::ns1::p2 {return 55}
|
|
} 55
|
|
|
|
test namespace-1.20 {variables in a namespace are hidden} -body {
|
|
set v2
|
|
} -returnCodes error -result {can't read "v2": no such variable}
|
|
|
|
test namespace-1.21 {using namespace qualifiers} {
|
|
list $ns1::v1 $ns1::v2
|
|
} {1 22}
|
|
|
|
test namespace-1.22 {using absolute namespace qualifiers} {
|
|
list $::ns1::v1 $::ns1::v2
|
|
} {1 22}
|
|
|
|
test namespace-1.23 {variables can be accessed within a namespace} {
|
|
ns1::p2 {
|
|
variable v1
|
|
variable v2
|
|
list $v1 $v2
|
|
}
|
|
} {1 22}
|
|
|
|
test namespace-1.24 {setting global variables} {
|
|
ns1::p2 {
|
|
variable v1
|
|
set v1 new
|
|
}
|
|
namespace eval ns1 {
|
|
variable v1
|
|
variable v2
|
|
list $v1 $v2
|
|
}
|
|
} {new 22}
|
|
|
|
test namespace-1.25 {qualified variables don't need a global declaration} {
|
|
namespace eval ns2 { variable x 456 }
|
|
set cmd {set ::ns2::x}
|
|
ns1::p2 "$cmd some-value"
|
|
set ::ns2::x
|
|
} {some-value}
|
|
|
|
test namespace-1.26 {namespace qualifiers are okay after $'s} {
|
|
namespace eval ns1 { variable x; variable y; set x 12; set y 34 }
|
|
set cmd {list $::ns1::x $::ns1::y}
|
|
list [ns1::p2 $cmd] [eval $cmd]
|
|
} {{12 34} {12 34}}
|
|
|
|
test namespace-1.27 {can create commands with null names} {
|
|
proc ns1:: {args} {return $args}
|
|
ns1:: x
|
|
} {x}
|
|
|
|
test namespace-1.28 {namespace variable with array element syntax} -body {
|
|
namespace eval ns1 {
|
|
variable x(3) y
|
|
}
|
|
} -returnCodes error -result {can't define "x(3)": name refers to an element in an array}
|
|
|
|
|
|
test namespace-1.29 {namespace variable too many args} -body {
|
|
namespace eval ns1 {
|
|
variable x(3) y a b c
|
|
}
|
|
} -returnCodes error -result {wrong # args: should be "variable name ?value?"}
|
|
|
|
test namespace-1.30 {namespace current too many args} -body {
|
|
namespace current a
|
|
} -returnCodes error -result {wrong # args: should be "namespace current"}
|
|
|
|
# TODO: Add tests for canonical option
|
|
|
|
test namespace-1.31 {namespace canonical too many args} -body {
|
|
namespace canonical a b c
|
|
} -returnCodes error -result {wrong # args: should be "namespace canonical ?current? ?name?"}
|
|
|
|
|
|
unset -nocomplain ns1::x ns1::y
|
|
|
|
# -----------------------------------------------------------------------
|
|
# TEST: using "info" in namespace contexts
|
|
# -----------------------------------------------------------------------
|
|
test namespace-2.1 {querying: info commands} {
|
|
lsort [ns1::p2 {info commands [namespace current]::*}]
|
|
} {::ns1:: ::ns1::p1 ::ns1::p2}
|
|
|
|
test namespace-2.2 {querying: info procs} {
|
|
lsort [ns1::p2 {info procs}]
|
|
} {{} p1 p2}
|
|
|
|
# Tcl produces fully scoped names here
|
|
test namespace-2.3 {querying: info vars} jim {
|
|
lsort [info vars ns1::*]
|
|
} {ns1::v1 ns1::v2}
|
|
|
|
test namespace-2.4 {querying: info vars} {
|
|
lsort [ns1::p2 {info vars [namespace current]::*}]
|
|
} {::ns1::v1 ::ns1::v2}
|
|
|
|
test namespace-2.5 {querying: info locals} {
|
|
lsort [ns1::p2 {info locals}]
|
|
} {script}
|
|
|
|
test namespace-2.6 {querying: info exists} {
|
|
ns1::p2 {info exists v1}
|
|
} {0}
|
|
|
|
test namespace-2.7 {querying: info exists} {
|
|
ns1::p2 {info exists v2}
|
|
} {1}
|
|
|
|
test namespace-2.8 {querying: info args} {
|
|
info args ns1::p2
|
|
} {script}
|
|
|
|
test namespace-2.9 {querying: info body} {
|
|
string trim [info body ns1::p1]
|
|
} {variable v1; list $a $v1}
|
|
|
|
# -----------------------------------------------------------------------
|
|
# TEST: namespace qualifiers, namespace tail
|
|
# -----------------------------------------------------------------------
|
|
test namespace-3.1 {usage for "namespace qualifiers"} {
|
|
list [catch "namespace qualifiers" msg] $msg
|
|
} {1 {wrong # args: should be "namespace qualifiers string"}}
|
|
|
|
test namespace-3.2 {querying: namespace qualifiers} {
|
|
list [namespace qualifiers ""] \
|
|
[namespace qualifiers ::] \
|
|
[namespace qualifiers x] \
|
|
[namespace qualifiers ::x] \
|
|
[namespace qualifiers foo::x] \
|
|
[namespace qualifiers ::foo::bar::xyz]
|
|
} {{} {} {} {} foo ::foo::bar}
|
|
|
|
test namespace-3.3 {usage for "namespace tail"} {
|
|
list [catch "namespace tail" msg] $msg
|
|
} {1 {wrong # args: should be "namespace tail string"}}
|
|
|
|
test namespace-3.4 {querying: namespace tail} {
|
|
list [namespace tail ""] \
|
|
[namespace tail ::] \
|
|
[namespace tail x] \
|
|
[namespace tail ::x] \
|
|
[namespace tail foo::x] \
|
|
[namespace tail ::foo::bar::xyz]
|
|
} {{} {} x x x xyz}
|
|
|
|
# -----------------------------------------------------------------------
|
|
# TEST: namespace hierarchy
|
|
# -----------------------------------------------------------------------
|
|
test namespace-5.1 {define nested namespaces} {
|
|
set test_ns_var_global "var in ::"
|
|
proc test_ns_cmd_global {} {return "cmd in ::"}
|
|
namespace eval nsh1 {
|
|
set test_ns_var_hier1 "particular to hier1"
|
|
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
|
|
proc test_ns_show {} {return "[namespace current]: 1"}
|
|
namespace eval nsh2 {
|
|
set test_ns_var_hier2 "particular to hier2"
|
|
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
|
|
proc test_ns_show {} {return "[namespace current]: 2"}
|
|
namespace eval nsh3a {}
|
|
namespace eval nsh3b {}
|
|
}
|
|
namespace eval nsh2a {}
|
|
namespace eval nsh2b {}
|
|
}
|
|
} {}
|
|
|
|
test namespace-5.2 {namespaces can be nested} {
|
|
list [namespace eval nsh1 {namespace current}] \
|
|
[namespace eval nsh1 {
|
|
namespace eval nsh2 {namespace current}
|
|
}]
|
|
} {::nsh1 ::nsh1::nsh2}
|
|
|
|
test namespace-5.3 {namespace qualifiers work in namespace command} {
|
|
list [namespace eval ::nsh1 {namespace current}] \
|
|
[namespace eval nsh1::nsh2 {namespace current}] \
|
|
[namespace eval ::nsh1::nsh2 {namespace current}]
|
|
} {::nsh1 ::nsh1::nsh2 ::nsh1::nsh2}
|
|
|
|
test namespace-5.4 {nested namespaces can access global namespace} {
|
|
list [namespace eval nsh1 {set ::test_ns_var_global}] \
|
|
[namespace eval nsh1 {test_ns_cmd_global}] \
|
|
[namespace eval nsh1::nsh2 {set ::test_ns_var_global}] \
|
|
[namespace eval nsh1::nsh2 {test_ns_cmd_global}]
|
|
} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}}
|
|
|
|
test namespace-5.6 {commands in different namespaces don't conflict} {
|
|
list [nsh1::test_ns_show] \
|
|
[nsh1::nsh2::test_ns_show]
|
|
} {{::nsh1: 1} {::nsh1::nsh2: 2}}
|
|
test namespace-5.7 {nested namespaces don't see variables in parent} {
|
|
set cmd {
|
|
namespace eval nsh1::nsh2 {set test_ns_var_hier1}
|
|
}
|
|
list [catch $cmd msg] $msg
|
|
} {1 {can't read "test_ns_var_hier1": no such variable}}
|
|
test namespace-5.8 {nested namespaces don't see commands in parent} {
|
|
set cmd {
|
|
namespace eval nsh1::nsh2 {test_ns_cmd_hier1}
|
|
}
|
|
list [catch $cmd msg] $msg
|
|
} {1 {invalid command name "test_ns_cmd_hier1"}}
|
|
|
|
test namespace-5.18 {usage for "namespace parent"} {
|
|
list [catch {namespace parent x y} msg] $msg
|
|
} {1 {wrong # args: should be "namespace parent ?name?"}}
|
|
|
|
test namespace-5.20 {querying namespace parent} {
|
|
list [namespace eval :: {namespace parent}] \
|
|
[namespace eval nsh1 {namespace parent}] \
|
|
[namespace eval nsh1::nsh2 {namespace parent}] \
|
|
[namespace eval nsh1::nsh2::nsh3a {namespace parent}] \
|
|
} {{} :: ::nsh1 ::nsh1::nsh2}
|
|
|
|
test namespace-5.21 {querying namespace parent for explicit namespace} {
|
|
list [namespace parent ::] \
|
|
[namespace parent nsh1] \
|
|
[namespace parent nsh1::nsh2] \
|
|
[namespace parent nsh1::nsh2::nsh3a]
|
|
} {{} :: ::nsh1 ::nsh1::nsh2}
|
|
|
|
test namespace-5.22 {query namespace parent with fully qualified names} {
|
|
list [namespace eval :: {namespace parent}] \
|
|
[namespace eval ::nsh1 {namespace parent}] \
|
|
[namespace eval ::nsh1::nsh2 {namespace parent}] \
|
|
[namespace eval nsh1::nsh2::nsh3a {namespace parent ::nsh1::nsh2}] \
|
|
} {{} :: ::nsh1 ::nsh1}
|
|
|
|
# -----------------------------------------------------------------------
|
|
# TEST: name resolution and caching
|
|
# -----------------------------------------------------------------------
|
|
test namespace-6.1 {relative ns names only looked up in current ns} {
|
|
namespace eval tns1 {}
|
|
namespace eval tns2 {}
|
|
namespace eval tns2::test_ns_cache3 {}
|
|
set trigger {
|
|
namespace eval tns2 {namespace current}
|
|
}
|
|
set trigger2 {
|
|
namespace eval tns2::test_ns_cache3 {namespace current}
|
|
}
|
|
list [namespace eval tns1 $trigger] \
|
|
[namespace eval tns1 $trigger2]
|
|
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
|
|
test namespace-6.2 {relative ns names only looked up in current ns} {
|
|
namespace eval tns1::tns2 {}
|
|
list [namespace eval tns1 $trigger] \
|
|
[namespace eval tns1 $trigger2]
|
|
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
|
|
test namespace-6.3 {relative ns names only looked up in current ns} {
|
|
namespace eval tns1::tns2::test_ns_cache3 {}
|
|
list [namespace eval tns1 $trigger] \
|
|
[namespace eval tns1 $trigger2]
|
|
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
|
|
test namespace-6.4 {relative ns names only looked up in current ns} {
|
|
namespace delete tns1::tns2
|
|
list [namespace eval tns1 $trigger] \
|
|
[namespace eval tns1 $trigger2]
|
|
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
|
|
|
|
test namespace-6.5 {define test commands} {
|
|
proc testcmd {} {
|
|
return "global version"
|
|
}
|
|
namespace eval tns1 {
|
|
proc trigger {} {
|
|
testcmd
|
|
}
|
|
}
|
|
tns1::trigger
|
|
} {global version}
|
|
|
|
test namespace-6.6 {one-level check for command shadowing} {
|
|
proc tns1::testcmd {} {
|
|
return "cache1 version"
|
|
}
|
|
tns1::trigger
|
|
} {cache1 version}
|
|
|
|
test namespace-6.7 {renaming commands changes command epoch} {
|
|
namespace eval tns1 {
|
|
rename testcmd testcmd_new
|
|
}
|
|
tns1::trigger
|
|
} {global version}
|
|
test namespace-6.8 {renaming back handles shadowing} {
|
|
namespace eval tns1 {
|
|
rename testcmd_new testcmd
|
|
}
|
|
tns1::trigger
|
|
} {cache1 version}
|
|
test namespace-6.9 {deleting commands changes command epoch} {
|
|
namespace eval tns1 {
|
|
rename testcmd ""
|
|
}
|
|
tns1::trigger
|
|
} {global version}
|
|
test namespace-6.10 {define test namespaces} {
|
|
namespace eval tns2 {
|
|
proc testcmd {} {
|
|
return "global cache2 version"
|
|
}
|
|
}
|
|
namespace eval tns1 {
|
|
proc trigger {} {
|
|
tns2::testcmd
|
|
}
|
|
}
|
|
namespace eval tns1::tns2 {
|
|
proc trigger {} {
|
|
testcmd
|
|
}
|
|
}
|
|
list [tns1::trigger] [tns1::tns2::trigger]
|
|
} {{global cache2 version} {global version}}
|
|
|
|
test namespace-6.11 {commands affect all parent namespaces} {
|
|
proc tns1::tns2::testcmd {} {
|
|
return "cache2 version"
|
|
}
|
|
list [tns1::trigger] [tns1::tns2::trigger]
|
|
} {{cache2 version} {cache2 version}}
|
|
|
|
# -----------------------------------------------------------------------
|
|
# TEST: uplevel/upvar across namespace boundaries
|
|
# -----------------------------------------------------------------------
|
|
# Note that Tcl behaves a little differently for uplevel and upvar
|
|
|
|
test namespace-7.1 {uplevel in namespace eval} jim {
|
|
set x 66
|
|
namespace eval uns1 {
|
|
variable y 55
|
|
set x 33
|
|
uplevel 1 set x
|
|
}
|
|
} {66}
|
|
|
|
test namespace-7.2 {upvar in ns proc} jim {
|
|
proc uns1::getvar {v} {
|
|
variable y
|
|
upvar $v var
|
|
list $var $y
|
|
}
|
|
uns1::getvar x
|
|
} {66 55}
|
|
|
|
# -----------------------------------------------------------------------
|
|
# TEST: scoped values
|
|
# -----------------------------------------------------------------------
|
|
test namespace-10.1 {define namespace for scope test} {
|
|
namespace eval ins1 {
|
|
variable x "x-value"
|
|
proc show {args} {
|
|
return "show: $args"
|
|
}
|
|
proc do {args} {
|
|
return [eval $args]
|
|
}
|
|
list [set x] [show test]
|
|
}
|
|
} {x-value {show: test}}
|
|
|
|
test namespace-10.2 {command "namespace code" requires one argument} {
|
|
list [catch {namespace code} msg] $msg
|
|
} {1 {wrong # args: should be "namespace code arg"}}
|
|
|
|
test namespace-10.3 {command "namespace code" requires one argument} {
|
|
list [catch {namespace code first "second arg" third} msg] $msg
|
|
} {1 {wrong # args: should be "namespace code arg"}}
|
|
|
|
test namespace-10.4 {command "namespace code" gets current namesp context} {
|
|
namespace eval ins1 {
|
|
namespace code {"1 2 3" "4 5" 6}
|
|
}
|
|
} {::namespace inscope ::ins1 {"1 2 3" "4 5" 6}}
|
|
|
|
test namespace-10.5 {with one arg, first "scope" sticks} {
|
|
set sval [namespace eval ins1 {namespace code {one two}}]
|
|
namespace code $sval
|
|
} {::namespace inscope ::ins1 {one two}}
|
|
|
|
test namespace-10.6 {with many args, each "scope" adds new args} {
|
|
set sval [namespace eval ins1 {namespace code {one two}}]
|
|
namespace code "$sval three"
|
|
} {::namespace inscope ::ins1 {one two} three}
|
|
|
|
test namespace-10.7 {scoped commands work with eval} {
|
|
set cref [namespace eval ins1 {namespace code show}]
|
|
list [eval $cref "a" "b c" "d e f"]
|
|
} {{show: a b c d e f}}
|
|
|
|
test namespace-10.8 {scoped commands execute in namespace context} {
|
|
set cref [namespace eval ins1 {
|
|
namespace code {variable x; set x "some new value"}
|
|
}]
|
|
list [set ins1::x] [eval $cref] [set ins1::x]
|
|
} {x-value {some new value} {some new value}}
|
|
|
|
test namespace-11.1 {command caching} {
|
|
proc cmd1 {} { return global }
|
|
set result {}
|
|
namespace eval ns1 {
|
|
proc cmd1 {} { return ns1 }
|
|
proc cmd2 {} {
|
|
uplevel 1 cmd1
|
|
}
|
|
lappend ::result [cmd2]
|
|
}
|
|
lappend result [ns1::cmd2]
|
|
} {ns1 global}
|
|
|
|
test namespace-12.1 {namespace import} {
|
|
namespace eval test_ns_scope1 {
|
|
proc a {} { return a }
|
|
namespace export a
|
|
}
|
|
namespace eval test_ns_scope2 {
|
|
namespace import ::test_ns_scope1::a
|
|
a
|
|
}
|
|
} {a}
|
|
|
|
test namespace-12.2 {namespace import recursive} -body {
|
|
namespace eval test_ns_scope1 {
|
|
namespace import [namespace current]::*
|
|
}
|
|
} -returnCodes error -match glob -result {import pattern "*" tries to import from namespace "*" into itself}
|
|
|
|
test namespace-12.3 {namespace import loop} -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-12.4 {namespace import} {
|
|
namespace eval ::test_ns_one {}
|
|
proc ::test_ns_one::testcmd args { return 2 }
|
|
namespace import ::test_ns_one::*
|
|
testcmd
|
|
} 2
|
|
|
|
foreach cmd [info commands test_ns_*] {
|
|
rename $cmd ""
|
|
}
|
|
|
|
catch {rename cmd {}}
|
|
catch {rename cmd1 {}}
|
|
catch {rename cmd2 {}}
|
|
catch {rename ncmd {}}
|
|
catch {rename ncmd1 {}}
|
|
catch {rename ncmd2 {}}
|
|
catch {unset cref}
|
|
catch {unset trigger}
|
|
catch {unset trigger2}
|
|
catch {unset sval}
|
|
catch {unset msg}
|
|
catch {unset x}
|
|
catch {unset test_ns_var_global}
|
|
catch {unset cmd}
|
|
catch {eval namespace delete [namespace children :: test_ns_*]}
|
|
|
|
# cleanup
|
|
::tcltest::cleanupTests
|
|
return
|
|
|
|
# Local Variables:
|
|
# mode: tcl
|
|
# End:
|