tests/alias.test

   1 source [file dirname [info script]]/testing.tcl
   2
   3 needs constraint jim
   4 needs cmd array
   5 needs cmd ref
   6
   7 test alias-1.1 "One word alias" {
   8         set x 2
   9         alias newincr incr
  10         newincr x
  11 } {3}
  12
  13 test alias-1.4 "Two word alias" {
  14         alias infoexists info exists
  15         infoexists x
  16 } {1}
  17
  18 test alias-1.5 "Replace alias" {
  19         alias newincr infoexists
  20         newincr x
  21 } {1}
  22
  23 test alias-1.6 "Delete alias" {
  24         rename newincr ""
  25         catch {newincr x}
  26 } {1}
  27
  28 test alias-1.7 "Replace alias with proc" {
  29         proc infoexists {n} {
  30                 return yes
  31         }
  32         infoexists any
  33 } {yes}
  34
  35 test alias-1.8 "Replace proc with alias" {
  36         alias infoexists info exists
  37         infoexists any
  38 } {0}
  39
  40 test alias-1.9 "error message from alias" -body {
  41         alias newstring string
  42         newstring match
  43 } -returnCodes error -result {wrong # args: should be "string match ?-nocase? pattern string"}
  44
  45 test alias-1.10 "info alias" {
  46         alias x info exists
  47         info alias x
  48 } {info exists}
  49
  50 test alias-1.10 "info alias on non-alias" -body {
  51         info alias format
  52 } -returnCodes error -result {command "format" is not an alias}
  53
  54 test curry-1.1 "One word curry" {
  55         set x 2
  56         set one [curry incr]
  57         $one x
  58 } {3}
  59
  60 test curry-1.4 "Two word curry" {
  61         set two [curry info exists]
  62         list [$two x] [$two y]
  63 } {1 0}
  64
  65 collect
  66 test curry-1.5 "Delete curry" {
  67         unset one two
  68         collect
  69 } {2}
  70
  71 test local-1.2 "local curry in proc" {
  72         proc a {} {
  73                 local set p [curry info exists]
  74                 set x 1
  75                 list $p [$p x] [$p y]
  76         }
  77         lassign [a] p exists_x exists_y
  78         list [info procs $p] $exists_x $exists_y
  79 } {{} 1 0}
  80
  81 test local-1.2 "set local curry in proc" {
  82         proc a {} {
  83                 set p [local curry info exists]
  84                 set x 1
  85                 list $p [$p x] [$p y]
  86         }
  87         lassign [a] p exists_x exists_y
  88         list [info procs $p] $exists_x $exists_y
  89 } {{} 1 0}
  90
  91 test local-1.3 "local alias in proc" {
  92         proc a {} {
  93                 local alias p info exists
  94                 set x 1
  95                 list [p x] [p y]
  96         }
  97         lassign [a] exists_x exists_y
  98         list [info commands p] $exists_x $exists_y
  99 } {{} 1 0}
 100
 101 test local-1.5 "local proc in proc" {
 102         set ::x 1
 103         proc a {} {
 104                 local proc b {} { incr ::x }
 105                 b
 106                 set ::x
 107         }
 108         a
 109         list [info procs b] $::x
 110 } {{} 2}
 111
 112 test local-1.6 "local lambda in lsort" {
 113         proc a {} {
 114                 lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
 115         }
 116         a
 117 } {a d f g}
 118
 119 test local-1.7 "check no reference procs" {
 120         info procs "<reference*"
 121 } {}
 122
 123 test local-1.8 "local on non-existent command" {
 124         list [catch {local set x blah} msg] $msg
 125 } {1 {invalid command name "blah"}}
 126
 127 test local-1.9 "local on existing proc" {
 128         proc x {} {
 129                 proc a {b} {incr b}
 130                 local function a
 131                 set c [lambda b {incr b -1}]
 132                 local function $c
 133                 lappend result [a 1] [$c 2]
 134         }
 135         set result [x]
 136         list [info procs a] $result
 137 } {{} {2 1}}
 138
 139 test statics-1.1 "missing static variable init" {
 140         unset -nocomplain c
 141         catch {
 142                 proc a {b} {c} {
 143                         # No initialiser for c
 144                 }
 145         }
 146 } 1
 147
 148 test statics-1.2 "static variable with invalid name" {
 149         catch {
 150                 proc a {b} "{c\0d 4}" {
 151                 }
 152         }
 153 } 1
 154
 155 test statics-1.3 "duplicate static variable" {
 156         catch {
 157                 proc a {b} {{c 1} {c 2}} {
 158                 }
 159         }
 160 } 1
 161
 162 test statics-1.4 "bad static variable init" {
 163         catch {
 164                 proc a {b} {{c 1 2}} {
 165                 }
 166         }
 167 } 1
 168
 169 test local-2.1 "proc over existing proc" {
 170         proc a {b} {incr b}
 171         proc t {x} {
 172                 proc a {b} {incr b -1}
 173                 a $x
 174         }
 175         unset -nocomplain x
 176         lappend x [a 5]
 177         lappend x [t 5]
 178         lappend x [a 5]
 179 } {6 4 4}
 180
 181 test local-2.2 "local proc over existing proc" {
 182         proc a {b} {incr b}
 183         proc t {x} {
 184                 local proc a {b} {incr b -1}
 185                 a $x
 186         }
 187         unset -nocomplain x
 188         lappend x [a 5]
 189         lappend x [t 5]
 190         lappend x [a 5]
 191 } {6 4 6}
 192
 193 test local-2.3 "local proc over existing proc" {
 194         proc a {b} {incr b}
 195         proc t {x} {
 196                 local proc a {b} {incr b -1}
 197                 a $x
 198         }
 199         unset -nocomplain x
 200         lappend x [a 5]
 201         lappend x [t 5]
 202         lappend x [a 5]
 203 } {6 4 6}
 204
 205 test upcall-1.1 "upcall pushed proc" {
 206         proc a {b} {incr b}
 207         local proc a {b} {
 208                 incr b 10
 209                 # invoke the original defn via upcall
 210                 return [upcall a $b]
 211         }
 212         # Should call the new defn which will call the original defn
 213         a 3
 214 } 14
 215
 216 test upcall-1.2 "upcall in proc" {
 217         proc a {b} {incr b}
 218         proc t {c} {
 219                 local proc a {b} {
 220                         incr b 10
 221                         return [upcall a $b]
 222                 }
 223                 a $c
 224         }
 225         unset -nocomplain x
 226         lappend x [t 5]
 227         lappend x [a 5]
 228         set x
 229 } {16 6}
 230
 231 test upcall-1.3 "double upcall" {
 232         proc a {} {return 1}
 233         local proc a {} {list 2 {*}[upcall a]}
 234         local proc a {} {list 3 {*}[upcall a]}
 235         a
 236 } {3 2 1}
 237
 238 test upcall-1.4 "upcall errors" {
 239         proc a {} {return 1}
 240         list [catch {upcall a} msg] $msg
 241 } {1 {no previous command: "a"}}
 242
 243 test upcall-1.4 "upcall errors" {
 244         proc a {} {upcall a}
 245         list [catch a msg] $msg
 246 } {1 {no previous command: "a"}}
 247
 248 testreport