tests/defer.test

   1 # vim:se syntax=tcl:
   2
   3 source [file dirname [info script]]/testing.tcl
   4
   5 needs cmd defer
   6 needs cmd interp
   7
   8 test defer-1.1 {defer in proc} {
   9         set x -
  10         proc a {} {
  11                 set x +
  12                 # This does nothing since it increments a local variable
  13                 defer {append x L}
  14                 # This increments the global variable
  15                 defer {append ::x G}
  16                 # Will return "-", not "-L" since return happens before defer triggers
  17                 return $x
  18         }
  19         list [a] $x
  20 } {+ -G}
  21
  22 test defer-1.2 {set $defer directly} {
  23         set x -
  24         proc a {} {
  25                 lappend jim::defer {append ::x a}
  26                 lappend jim::defer {append ::x b}
  27                 return $jim::defer
  28         }
  29         list [a] $x
  30 } {{{append ::x a} {append ::x b}} -ba}
  31
  32
  33 test defer-1.3 {unset $defer} {
  34         set x -
  35         proc a {} {
  36                 defer {append ::x a}
  37                 # unset, to remove all defer actions
  38                 unset jim::defer
  39         }
  40         a
  41         set x
  42 } {-}
  43
  44 test defer-1.4 {error in defer - error} {
  45         set x -
  46         proc a {} {
  47                 # First defer script will not happen because of error in next defer script
  48                 defer {append ::x a}
  49                 # Error ignored because of error from proc
  50                 defer {blah}
  51                 # Last defer script will happen
  52                 defer {append ::x b}
  53                 # This error will take precedence over the error from defer
  54                 error "from a"
  55         }
  56         set rc [catch {a} msg]
  57         list [info ret $rc] $msg $x
  58 } {error {from a} -b}
  59
  60 test defer-1.5 {error in defer - return} {
  61         set x -
  62         proc a {} {
  63                 # First defer script will not happen
  64                 defer {append ::x a}
  65                 defer {blah}
  66                 # Last defer script will happen
  67                 defer {append ::x b}
  68                 return 3
  69         }
  70         set rc [catch {a} msg]
  71         list [info ret $rc] $msg $x
  72 } {error {invalid command name "blah"} -b}
  73
  74 test defer-1.6 {error in defer - ok} {
  75         set x -
  76         proc a {} {
  77                 # First defer script will not happen
  78                 defer {append ::x a}
  79                 # Error ignored because of error from proc
  80                 defer {blah}
  81                 # Last defer script will happen
  82                 defer {append ::x b}
  83         }
  84         set rc [catch {a} msg]
  85         list [info ret $rc] $msg $x
  86 } {error {invalid command name "blah"} -b}
  87
  88 test defer-1.7 {error in defer - break} {
  89         set x -
  90         proc a {} {
  91                 # First defer script will not happen
  92                 defer {append ::x a}
  93                 # This non-zero return code will take precedence over the proc return
  94                 defer {return -code 30 ret30}
  95                 # Last defer script will happen
  96                 defer {append ::x b}
  97
  98                 return -code 20 ret20
  99         }
 100         set rc [catch {a} msg]
 101         list [info ret $rc] $msg $x
 102 } {30 ret30 -b}
 103
 104 test defer-1.8 {error in defer - tailcall} {
 105         set x -
 106         proc a {} {
 107                 # This will prevent tailcall from happening
 108                 defer {blah}
 109
 110                 # Tailcall will not happen because of error in defer
 111                 tailcall append ::x a
 112         }
 113         set rc [catch {a} msg]
 114         list [info ret $rc] $msg $x
 115 } {error {invalid command name "blah"} -}
 116
 117 test defer-1.9 {Add to defer in defer body} {
 118         set x -
 119         proc a {} {
 120                 defer {
 121                         # Add to defer in defer
 122                         defer {
 123                                 # This will do nothing
 124                                 error here
 125                         }
 126                 }
 127                 defer {append ::x a}
 128         }
 129         a
 130         set x
 131 } {-a}
 132
 133 test defer-1.10 {Unset defer in defer body} {
 134         set x -
 135         proc a {} {
 136                 defer {
 137                         # This will do nothing
 138                         unset -nocomplain jim::defer
 139                 }
 140                 defer {append ::x a}
 141         }
 142         a
 143         set x
 144 } {-a}
 145
 146 test defer-1.11 {defer through tailcall} {
 147         set x {}
 148         proc a {} {
 149                 defer {append ::x a}
 150                 b
 151         }
 152         proc b {} {
 153                 defer {append ::x b}
 154                 # c will be invoked as through called from a but this
 155                 # won't make any difference for defer
 156                 tailcall c
 157         }
 158         proc c {} {
 159                 defer {append ::x c}
 160         }
 161         a
 162         set x
 163 } {bca}
 164
 165 test defer-1.12 {defer in recursive call} {
 166         set x {}
 167         proc a {n} {
 168                 # defer happens just before the return, so after the recursive call to a
 169                 defer {lappend ::x $n}
 170                 if {$n > 0} {
 171                         a $($n - 1)
 172                 }
 173         }
 174         a 3
 175         set x
 176 } {0 1 2 3}
 177
 178 test defer-1.13 {defer in recursive tailcall} {
 179         set x {}
 180         proc a {n} {
 181                 # defer happens just before the return, so before the tailcall to a
 182                 defer {lappend ::x $n}
 183                 if {$n > 0} {
 184                         tailcall a $($n - 1)
 185                 }
 186         }
 187         a 3
 188         set x
 189 } {3 2 1 0}
 190
 191 test defer-1.14 {defer capture variables} {
 192         set x {}
 193         proc a {} {
 194                 set y 1
 195                 # A normal defer will evaluate at the end of the proc, so $y may change
 196                 defer {lappend ::x $y}
 197                 incr y
 198
 199                 # What if we want to capture the value of y here? list will work
 200                 defer [list lappend ::x $y]
 201                 incr y
 202
 203                 # But with multiple statements, list doesn't work, so use a lambda
 204                 # to capture the value instead
 205                 defer [lambda {} {y} {
 206                         # multi-line script
 207                         lappend ::x $y
 208                 }]
 209                 incr y
 210
 211                 return $y
 212         }
 213         list [a] $x
 214 } {4 {3 2 4}}
 215
 216 test defer-2.1 {defer from interp} -body {
 217         set i [interp]
 218         # defer needs to have some effect to detect on exit,
 219         # so write to a file
 220         file delete defer.tmp
 221         $i eval {
 222                 defer {
 223                         [open defer.tmp w] puts "leaving child"
 224                 }
 225         }
 226         set a [file exists defer.tmp]
 227         $i delete
 228         # Now the file should exist
 229         set f [open defer.tmp]
 230         $f gets b
 231         $f close
 232         list $a $b
 233 } -result {0 {leaving child}} -cleanup {
 234         file delete defer.tmp
 235 }
 236
 237 testreport