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 test curry-1.5 "Delete curry" {
  66         unset one two
  67         collect
  68 } {2}
  69
  70 test local-1.2 "local curry in proc" {
  71         proc a {} {
  72                 local set p [curry info exists]
  73                 set x 1
  74                 list $p [$p x] [$p y]
  75         }
  76         lassign [a] p exists_x exists_y
  77         list [info procs $p] $exists_x $exists_y
  78 } {{} 1 0}
  79
  80 test local-1.2 "set local curry in proc" {
  81         proc a {} {
  82                 set p [local curry info exists]
  83                 set x 1
  84                 list $p [$p x] [$p y]
  85         }
  86         lassign [a] p exists_x exists_y
  87         list [info procs $p] $exists_x $exists_y
  88 } {{} 1 0}
  89
  90 test local-1.3 "local alias in proc" {
  91         proc a {} {
  92                 local alias p info exists
  93                 set x 1
  94                 list [p x] [p y]
  95         }
  96         lassign [a] exists_x exists_y
  97         list [info commands p] $exists_x $exists_y
  98 } {{} 1 0}
  99
 100 test local-1.5 "local proc in proc" {
 101         set ::x 1
 102         proc a {} {
 103                 local proc b {} { incr ::x }
 104                 b
 105                 set ::x
 106         }
 107         a
 108         list [info procs b] $::x
 109 } {{} 2}
 110
 111 test local-1.6 "local lambda in lsort" {
 112         proc a {} {
 113                 lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
 114         }
 115         a
 116 } {a d f g}
 117
 118 test local-1.7 "check no reference procs" {
 119         info procs "<reference*"
 120 } {}
 121
 122 test local-1.8 "local on non-existent command" {
 123         list [catch {local set x blah} msg] $msg
 124 } {1 {invalid command name "blah"}}
 125
 126 test local-1.9 "local on existing proc" {
 127         proc x {} {
 128                 proc a {b} {incr b}
 129                 local function a
 130                 set c [lambda b {incr b -1}]
 131                 local function $c
 132                 lappend result [a 1] [$c 2]
 133         }
 134         set result [x]
 135         list [info procs a] $result
 136 } {{} {2 1}}
 137
 138 test statics-1.1 "missing static variable init" {
 139         unset -nocomplain c
 140         catch {
 141                 proc a {b} {c} {
 142                         # No initialiser for c
 143                 }
 144         }
 145 } 1
 146
 147 test statics-1.2 "static variable with invalid name" {
 148         catch {
 149                 proc a {b} "{c\0d 4}" {
 150                 }
 151         }
 152 } 1
 153
 154 test statics-1.3 "duplicate static variable" {
 155         catch {
 156                 proc a {b} {{c 1} {c 2}} {
 157                 }
 158         }
 159 } 1
 160
 161 test statics-1.4 "bad static variable init" {
 162         catch {
 163                 proc a {b} {{c 1 2}} {
 164                 }
 165         }
 166 } 1
 167
 168 test local-2.1 "proc over existing proc" {
 169         proc a {b} {incr b}
 170         proc t {x} {
 171                 proc a {b} {incr b -1}
 172                 a $x
 173         }
 174         unset -nocomplain x
 175         lappend x [a 5]
 176         lappend x [t 5]
 177         lappend x [a 5]
 178 } {6 4 4}
 179
 180 test local-2.2 "local proc over existing proc" {
 181         proc a {b} {incr b}
 182         proc t {x} {
 183                 local proc a {b} {incr b -1}
 184                 a $x
 185         }
 186         unset -nocomplain x
 187         lappend x [a 5]
 188         lappend x [t 5]
 189         lappend x [a 5]
 190 } {6 4 6}
 191
 192 test local-2.3 "local proc over existing proc" {
 193         proc a {b} {incr b}
 194         proc t {x} {
 195                 local proc a {b} {incr b -1}
 196                 a $x
 197         }
 198         unset -nocomplain x
 199         lappend x [a 5]
 200         lappend x [t 5]
 201         lappend x [a 5]
 202 } {6 4 6}
 203
 204 test upcall-1.1 "upcall pushed proc" {
 205         proc a {b} {incr b}
 206         local proc a {b} {
 207                 incr b 10
 208                 # invoke the original defn via upcall
 209                 return [upcall a $b]
 210         }
 211         # Should call the new defn which will call the original defn
 212         a 3
 213 } 14
 214
 215 test upcall-1.2 "upcall in proc" {
 216         proc a {b} {incr b}
 217         proc t {c} {
 218                 local proc a {b} {
 219                         incr b 10
 220                         return [upcall a $b]
 221                 }
 222                 a $c
 223         }
 224         unset -nocomplain x
 225         lappend x [t 5]
 226         lappend x [a 5]
 227         set x
 228 } {16 6}
 229
 230 test upcall-1.3 "double upcall" {
 231         proc a {} {return 1}
 232         local proc a {} {list 2 {*}[upcall a]}
 233         local proc a {} {list 3 {*}[upcall a]}
 234         a
 235 } {3 2 1}
 236
 237 test upcall-1.4 "upcall errors" {
 238         proc a {} {return 1}
 239         list [catch {upcall a} msg] $msg
 240 } {1 {no previous command: "a"}}
 241
 242 test upcall-1.4 "upcall errors" {
 243         proc a {} {upcall a}
 244         list [catch a msg] $msg
 245 } {1 {no previous command: "a"}}
 246
 247 testreport