#! /bin/env tclsh
namespace eval doc {}
proc suite_main {} {
package require ycl::test
ycl::test::init
package require ycl::proc
namespace import [yclprefix]::proc::argnames
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::checkdargs
namespace import [yclprefix]::proc::formals
namespace import [yclprefix]::proc::method
namespace import [yclprefix]::proc::upmethod
namespace import [yclprefix]::proc::vmacro
namespace import [yclprefix]::proc::alias
variable proc [yclprefix]::proc
set setup1 {
catch {unset res}
namespace eval ns1 {
namespace export *
namespace ensemble create
}
proc proc1 args {
checkargs doc::proc1
return hello
}
proc proc2 {one two three} {
argnames
}
proc proc3 {arg1 {arg2 3} arg3 args} {
::tcl::mathop::+ $arg2 $arg2 $arg3 {*}$args
}
}
set cleanup1 {
namespace delete ns1
}
test checkargs_mandatory {} -setup $setup1 -body {
variable doc::proc1 {
args {
arg1 {
}
}
}
catch {proc1} res errorInfo
return [string tolower $res]
} -match glob -result {mandatory*argument*is*missing}
test checkargs_constrain {basic constrain functionality} \
-setup $setup1 -body {
variable doc::proc1 {
args {
arg1 {
constrain {
$arg1 > 10
}
}
}
}
lappend res [proc1 arg1 11]
catch {proc1 arg1 5} cres errorInfo
lappend res [string match -nocase *fails*constraint* $cres]
} -result {hello 1}
test checkargs_default_indicates_optional {} -setup $setup1 -body {
variable doc::proc1 {
args {
arg1 {
default {}
process {
should not be evaluated because "default" did not set arg1
}
}
}
}
proc1
} -result {hello}
test checkargs_default_is_constrained {} -setup $setup1 -body {
variable doc::proc1 {
args {
arg1 {
default {
return -level 0 8
}
constrain {
$arg1 > 10
}
}
}
}
catch {proc1} res eopts
return $res
} -match glob -result {*arg1*fails constraint*}
test checkargs_default_passes_constraint {} -setup $setup1 -body {
variable doc::proc1 {
args {
arg1 {
default {
return -level 0 8
}
constrain {
$arg1 < 10
}
}
}
}
catch {proc1} res eopts
return $res
} -match glob -result {hello}
test checkargs_positional_is_constrained {} -setup $setup1 -body {
variable doc::proc1 {
args {
arg1 {
constrain {
$arg1 > 10
}
}
}
}
proc proc1 {arg1} {
checkargs doc::proc1
return hello
}
lappend res [proc1 11]
catch {proc1 5} eres eopts
lappend res $eres
} -match glob -result [list hello {*arg1*fails constraint*}]
test checkdargs_default_indicates_optional {} -body {
variable doc::proc1 {
args {
arg1 {
default {}
process {
should not be evaluated because "default" did not set arg1
}
}
}
}
proc proc1 args {
checkdargs doc::proc1 args
return hello
}
proc1
} -result {hello}
test checkargs_default_processl {} -body {
variable doc::proc1 {
args {
arg1 {
default {set arg1 hello}
process {
list $arg1$arg1
}
}
}
}
proc proc1 args {
checkargs doc::proc1
return $arg1
}
proc1
} -result {hellohello}
test checkdargs_default_processl {} -body {
variable doc::proc1 {
args {
arg1 {
default {set arg1 hello}
process {
set arg1 "$arg1$arg1"
}
}
}
}
proc proc1 args {
checkdargs doc::proc1 args
return $arg1
}
proc1
} -result {hellohello}
test argnames {} -setup $setup1 -body {
lappend res [proc2 2 4 6]
lappend res [apply [list {uno dos tres} {
argnames
} [namespace current]] 1 2 3]
} -result {{one two three} {uno dos tres}}
test formals {} -setup $setup1 -body {
lappend res [formals proc3]
} -cleanup $cleanup1 -result {{arg1 {arg2 3} arg3 args}}
test method {} -setup $setup1 -body {
method run {} {} {speed} {
return $speed
}
variable speed 5
set ns1::speed 8
namespace export run
namespace eval ns1 [list namespace import [namespace current]::run]
lappend res [ns1 run]
method run {} {speed} {} {
return $speed
}
lappend res [ns1 run]
} -cleanup $cleanup1 -result {8 5}
test vmacro {} -body {
set m1 {{subject} {
set {{subject}} ${subject}${subject}
}}
set person Bob
vmacro $m1 person
return $person
} -result BobBob
test alias {} -setup $setup1 -cleanup $cleanup1 -body {
alias newproc proc1
newproc
} -result hello
#the combination of the previous test and the next one currently cause the
#interpreter to abort. See
#http://core.tcl.tk/tcl/tktview?name=a4494e28ed
test overridden_builtins {} -setup $setup1 -cleanup $cleanup1 -body {
namespace eval overridden {
package require ycl::ns
namespace import [yclprefix]::proc::upmethod
namespace export *
namespace ensemble create
proc set {} {
}
proc uplevel {} {
}
upmethod hello {} {} {} {
return hello!
}
proc new {} {
variable nextid
::set id [incr nextid]
namespace eval $id {
namespace export *
namespace ensemble create
namespace import [namespace parent]::hello
}
return [namespace current]::$id
}
}
[overridden new] hello
} -result {hello!}
cleanupTests
}