diff options
Diffstat (limited to 'tests/alias.test')
| -rw-r--r-- | tests/alias.test | 248 |
1 files changed, 248 insertions, 0 deletions
diff --git a/tests/alias.test b/tests/alias.test new file mode 100644 index 0000000..c539920 --- /dev/null +++ b/tests/alias.test @@ -0,0 +1,248 @@ +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} + +collect +test curry-1.5 "Delete curry" { + 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 invalid name" { + catch { + proc a {b} "{c\0d 4}" { + } + } +} 1 + +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.4 "upcall errors" { + proc a {} {upcall a} + list [catch a msg] $msg +} {1 {no previous command: "a"}} + +testreport |