137 lines
2.8 KiB
Plaintext
137 lines
2.8 KiB
Plaintext
source [file dirname [info script]]/testing.tcl
|
|
|
|
needs constraint jim
|
|
needs cmd array
|
|
|
|
proc aproc {} {
|
|
list
|
|
}
|
|
proc bproc {b} {
|
|
list b $b
|
|
}
|
|
proc cproc {b c} {
|
|
list b $b c $c
|
|
}
|
|
proc dproc {b c {d dd}} {
|
|
list b $b c $c d $d
|
|
}
|
|
proc eproc {b c {d dd} e} {
|
|
list b $b c $c d $d e $e
|
|
}
|
|
proc fproc {b c {d dd} args} {
|
|
list b $b c $c d $d args $args
|
|
}
|
|
proc gproc {b c {d dd} args e} {
|
|
list b $b c $c d $d args $args e $e
|
|
}
|
|
proc hproc {{a aa} args} {
|
|
list a $a args $args
|
|
}
|
|
|
|
proc iproc {{a aa} b {c cc}} {
|
|
list a $a b $b c $c
|
|
}
|
|
|
|
proc jproc {args {a aa} b {c cc} d} {
|
|
list a $a b $b c $c d $d args $args
|
|
}
|
|
|
|
set n 1
|
|
foreach {proc params result} {
|
|
aproc {} {}
|
|
bproc B {b B}
|
|
cproc {B C} {b B c C}
|
|
dproc {B C} {b B c C d dd}
|
|
dproc {B C D} {b B c C d D}
|
|
eproc {B C D E} {b B c C d D e E}
|
|
eproc {B C E} {b B c C d dd e E}
|
|
fproc {B C} {b B c C d dd args {}}
|
|
fproc {B C D} {b B c C d D args {}}
|
|
fproc {B C D E} {b B c C d D args E}
|
|
fproc {B C D E F} {b B c C d D args {E F}}
|
|
gproc {B C E} {b B c C d dd args {} e E}
|
|
gproc {B C D E} {b B c C d D args {} e E}
|
|
gproc {B C D X E} {b B c C d D args X e E}
|
|
gproc {B C D X Y Z E} {b B c C d D args {X Y Z} e E}
|
|
hproc {} {a aa args {}}
|
|
hproc {A} {a A args {}}
|
|
hproc {A X Y Z} {a A args {X Y Z}}
|
|
iproc {B} {a aa b B c cc}
|
|
iproc {A B} {a A b B c cc}
|
|
iproc {A B C} {a A b B c C}
|
|
jproc {B D} {a aa b B c cc d D args {}}
|
|
jproc {A B D} {a A b B c cc d D args {}}
|
|
jproc {A B C D} {a A b B c C d D args {}}
|
|
jproc {E F A B C D} {a A b B c C d D args {E F}}
|
|
} {
|
|
test proc-1.$n "Proc args combos" [list $proc {*}$params] $result
|
|
incr n
|
|
}
|
|
|
|
proc onearg_search {{nocase ""} value list} {
|
|
lsearch {*}$nocase $list $value
|
|
}
|
|
|
|
proc multiarg_search {args value list} {
|
|
lsearch {*}$args $list $value
|
|
}
|
|
|
|
test proc-2.1 "Real test of optional switches" {
|
|
onearg_search c {A a B b C c D d}
|
|
} 5
|
|
|
|
test proc-2.2 "Real test of optional switches" {
|
|
onearg_search -nocase c {A a B b C c D d}
|
|
} 4
|
|
|
|
test proc-2.3 "Real test of optional switches" {
|
|
multiarg_search -glob c* {A a B b C c D d}
|
|
} 5
|
|
|
|
test proc-2.4 "Real test of optional switches" {
|
|
multiarg_search -nocase -glob c* {A a B b C c D d}
|
|
} 4
|
|
|
|
test proc-3.1 "Rename optional args" {
|
|
proc a {b {args vars}} {
|
|
}
|
|
catch {a} msg
|
|
set msg
|
|
} {wrong # args: should be "a b ?vars ...?"}
|
|
|
|
test proc-3.2 "Rename optional args" {
|
|
proc a {b {args vars} c} {
|
|
}
|
|
catch {a} msg
|
|
set msg
|
|
} {wrong # args: should be "a b ?vars ...? c"}
|
|
|
|
test proc-3.2 "Rename optional args" {
|
|
proc a {b {args vars}} {
|
|
return $vars
|
|
}
|
|
a B C D
|
|
} {C D}
|
|
|
|
test proc-3.3 "dict sugar arg" {
|
|
proc a {b(c)} { return $b}
|
|
a 4
|
|
} {c 4}
|
|
|
|
test proc-3.4 "invalid upref in rightargs" {
|
|
proc a {{x 2} &b} { return $b}
|
|
unset -nocomplain B
|
|
catch {a B}
|
|
} 1
|
|
|
|
test proc-3.5 "error message with optional args" {
|
|
proc a {b args} {
|
|
return $args
|
|
}
|
|
catch a msg
|
|
set msg
|
|
} {wrong # args: should be "a b ?arg ...?"}
|
|
|
|
|
|
testreport
|