269 lines
4.9 KiB
Plaintext
269 lines
4.9 KiB
Plaintext
source [file dirname [info script]]/testing.tcl
|
|
|
|
needs constraint jim
|
|
needs cmd array
|
|
needs cmd ref
|
|
|
|
test alias-1.1 "One word alias" {
|
|
set x 2
|
|
alias newincr incr
|
|
newincr x
|
|
} {3}
|
|
|
|
test alias-1.4 "Two word alias" {
|
|
alias infoexists info exists
|
|
infoexists x
|
|
} {1}
|
|
|
|
test alias-1.5 "Replace alias" {
|
|
alias newincr infoexists
|
|
newincr x
|
|
} {1}
|
|
|
|
test alias-1.6 "Delete alias" {
|
|
rename newincr ""
|
|
catch {newincr x}
|
|
} {1}
|
|
|
|
test alias-1.7 "Replace alias with proc" {
|
|
proc infoexists {n} {
|
|
return yes
|
|
}
|
|
infoexists any
|
|
} {yes}
|
|
|
|
test alias-1.8 "Replace proc with alias" {
|
|
alias infoexists info exists
|
|
infoexists any
|
|
} {0}
|
|
|
|
test alias-1.9 "error message from alias" -body {
|
|
alias newstring string
|
|
newstring match
|
|
} -returnCodes error -result {wrong # args: should be "string match ?-nocase? pattern string"}
|
|
|
|
test alias-1.10 "info alias" {
|
|
alias x info exists
|
|
info alias x
|
|
} {info exists}
|
|
|
|
test alias-1.10 "info alias on non-alias" -body {
|
|
info alias format
|
|
} -returnCodes error -result {command "format" is not an alias}
|
|
|
|
test curry-1.1 "One word curry" {
|
|
set x 2
|
|
set one [curry incr]
|
|
$one x
|
|
} {3}
|
|
|
|
test curry-1.4 "Two word curry" {
|
|
set two [curry info exists]
|
|
list [$two x] [$two y]
|
|
} {1 0}
|
|
|
|
test curry-1.5 "Delete curry" references {
|
|
collect
|
|
$one abc
|
|
unset one two
|
|
collect
|
|
} {2}
|
|
|
|
test local-1.2 "local curry in proc" {
|
|
proc a {} {
|
|
local set p [curry info exists]
|
|
set x 1
|
|
list $p [$p x] [$p y]
|
|
}
|
|
lassign [a] p exists_x exists_y
|
|
list [info procs $p] $exists_x $exists_y
|
|
} {{} 1 0}
|
|
|
|
test local-1.2 "set local curry in proc" {
|
|
proc a {} {
|
|
set p [local curry info exists]
|
|
set x 1
|
|
list $p [$p x] [$p y]
|
|
}
|
|
lassign [a] p exists_x exists_y
|
|
list [info procs $p] $exists_x $exists_y
|
|
} {{} 1 0}
|
|
|
|
test local-1.3 "local alias in proc" {
|
|
proc a {} {
|
|
local alias p info exists
|
|
set x 1
|
|
list [p x] [p y]
|
|
}
|
|
lassign [a] exists_x exists_y
|
|
list [info commands p] $exists_x $exists_y
|
|
} {{} 1 0}
|
|
|
|
test local-1.5 "local proc in proc" {
|
|
set ::x 1
|
|
proc a {} {
|
|
local proc b {} { incr ::x }
|
|
b
|
|
set ::x
|
|
}
|
|
a
|
|
list [info procs b] $::x
|
|
} {{} 2}
|
|
|
|
test local-1.6 "local lambda in lsort" {
|
|
proc a {} {
|
|
lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
|
|
}
|
|
a
|
|
} {a d f g}
|
|
|
|
test local-1.7 "check no reference procs" {
|
|
info procs "<reference*"
|
|
} {}
|
|
|
|
test local-1.8 "local on non-existent command" {
|
|
list [catch {local set x blah} msg] $msg
|
|
} {1 {invalid command name "blah"}}
|
|
|
|
test local-1.9 "local on existing proc" {
|
|
proc x {} {
|
|
proc a {b} {incr b}
|
|
local function a
|
|
set c [lambda b {incr b -1}]
|
|
local function $c
|
|
lappend result [a 1] [$c 2]
|
|
}
|
|
set result [x]
|
|
list [info procs a] $result
|
|
} {{} {2 1}}
|
|
|
|
test statics-1.1 "missing static variable init" {
|
|
unset -nocomplain c
|
|
catch {
|
|
proc a {b} {c} {
|
|
# No initialiser for c
|
|
}
|
|
}
|
|
} 1
|
|
|
|
test statics-1.2 "static variable with name containing null" {
|
|
proc a {b} "{c\0d 4}" {
|
|
return [set c\0d]
|
|
}
|
|
a 5
|
|
} 4
|
|
|
|
test statics-1.3 "duplicate static variable" {
|
|
catch {
|
|
proc a {b} {{c 1} {c 2}} {
|
|
}
|
|
}
|
|
} 1
|
|
|
|
test statics-1.4 "bad static variable init" {
|
|
catch {
|
|
proc a {b} {{c 1 2}} {
|
|
}
|
|
}
|
|
} 1
|
|
|
|
test local-2.1 "proc over existing proc" {
|
|
proc a {b} {incr b}
|
|
proc t {x} {
|
|
proc a {b} {incr b -1}
|
|
a $x
|
|
}
|
|
unset -nocomplain x
|
|
lappend x [a 5]
|
|
lappend x [t 5]
|
|
lappend x [a 5]
|
|
} {6 4 4}
|
|
|
|
test local-2.2 "local proc over existing proc" {
|
|
proc a {b} {incr b}
|
|
proc t {x} {
|
|
local proc a {b} {incr b -1}
|
|
a $x
|
|
}
|
|
unset -nocomplain x
|
|
lappend x [a 5]
|
|
lappend x [t 5]
|
|
lappend x [a 5]
|
|
} {6 4 6}
|
|
|
|
test local-2.3 "local proc over existing proc" {
|
|
proc a {b} {incr b}
|
|
proc t {x} {
|
|
local proc a {b} {incr b -1}
|
|
a $x
|
|
}
|
|
unset -nocomplain x
|
|
lappend x [a 5]
|
|
lappend x [t 5]
|
|
lappend x [a 5]
|
|
} {6 4 6}
|
|
|
|
test upcall-1.1 "upcall pushed proc" {
|
|
proc a {b} {incr b}
|
|
local proc a {b} {
|
|
incr b 10
|
|
# invoke the original defn via upcall
|
|
return [upcall a $b]
|
|
}
|
|
# Should call the new defn which will call the original defn
|
|
a 3
|
|
} 14
|
|
|
|
test upcall-1.2 "upcall in proc" {
|
|
proc a {b} {incr b}
|
|
proc t {c} {
|
|
local proc a {b} {
|
|
incr b 10
|
|
return [upcall a $b]
|
|
}
|
|
a $c
|
|
}
|
|
unset -nocomplain x
|
|
lappend x [t 5]
|
|
lappend x [a 5]
|
|
set x
|
|
} {16 6}
|
|
|
|
test upcall-1.3 "double upcall" {
|
|
proc a {} {return 1}
|
|
local proc a {} {list 2 {*}[upcall a]}
|
|
local proc a {} {list 3 {*}[upcall a]}
|
|
a
|
|
} {3 2 1}
|
|
|
|
test upcall-1.4 "upcall errors" {
|
|
proc a {} {return 1}
|
|
list [catch {upcall a} msg] $msg
|
|
} {1 {no previous command: "a"}}
|
|
|
|
test upcall-1.5 "upcall errors" {
|
|
proc a {} {upcall a}
|
|
list [catch a msg] $msg
|
|
} {1 {no previous command: "a"}}
|
|
|
|
test upcall-1.6 "delete local command" -setup {
|
|
# First make sure a is gone
|
|
rename a ""
|
|
} -body {
|
|
local proc a {x} {list 2 $x}
|
|
# It is OK to rename this local proc
|
|
rename a b
|
|
b 5
|
|
} -result {2 5} -cleanup {
|
|
rename b ""
|
|
}
|
|
|
|
test upcall-1.6 {delete local command with upcall} -body {
|
|
local proc a {x} {list 2 $x}
|
|
local proc a {x} {list 3 $x}
|
|
# Can't rename a because it would invalide upcalls from a
|
|
rename a c
|
|
} -returnCodes error -result {can't rename local command "a"}
|
|
|
|
testreport
|