regtest.tcl

   1 # These regression tests all provoked crashes at some point.
   2 # Thus they are kept separate from the regular test suite in tests/
   3
   4 # REGTEST 1
   5 # 27Jan2005 - SIGSEGV for bug on Jim_DuplicateObj().
   6
   7 for {set i 0} {$i < 100} {incr i} {
   8     set a "x"
   9     lappend a n
  10 }
  11 puts "TEST 1 PASSED"
  12
  13 # REGTEST 2
  14 # 29Jan2005 - SEGFAULT parsing script composed of just one comment.
  15 eval {#foobar}
  16 puts "TEST 2 PASSED"
  17
  18 # REGTEST 3
  19 # 29Jan2005 - "Error in Expression" with correct expression
  20 set x 5
  21 expr {$x-5}
  22 puts "TEST 3 PASSED"
  23
  24 # REGTEST 4
  25 # 29Jan2005 - SIGSEGV when run this code, due to expr's bug.
  26 proc fibonacci {x} {
  27     if {$x <= 1} {
  28     expr 1
  29     } else {
  30     expr {[fibonacci [expr {$x-1}]] + [fibonacci [expr {$x-2}]]}
  31     }
  32 }
  33 fibonacci 6
  34 puts "TEST 4 PASSED"
  35
  36 # REGTEST 5
  37 # 06Mar2005 - This looped forever...
  38 for {set i 0} {$i < 10} {incr i} {continue}
  39 puts "TEST 5 PASSED"
  40
  41 # REGTEST 6
  42 # 07Mar2005 - Unset create variable + dict is using dict syntax sugar at
  43 #             currently non-existing variable
  44 catch {unset thisvardoesnotexists(thiskeytoo)}
  45 if {[catch {set thisvardoesnotexists}] == 0} {
  46   puts "TEST 6 FAILED - unset created dict for non-existing variable"
  47   break
  48 }
  49 puts "TEST 6 PASSED"
  50
  51 # REGTEST 7
  52 # 04Nov2008 - variable parsing does not eat last brace
  53 set a 1
  54 list ${a}
  55 puts "TEST 7 PASSED"
  56
  57 # REGTEST 8
  58 # 04Nov2008 - string toupper/tolower do not convert to string rep
  59 string tolower [list a]
  60 string toupper [list a]
  61 puts "TEST 8 PASSED"
  62
  63 # REGTEST 9
  64 # 04Nov2008 - crash on exit when replacing Tcl proc with C command.
  65 # Requires the clock extension to be built as a loadable module.
  66 proc clock {args} {}
  67 catch {package require clock}
  68 # Note, crash on exit, so don't say we passed!
  69
  70 # REGTEST 10
  71 # 05Nov2008 - incorrect lazy expression evaluation with unary not
  72 expr {1 || !0}
  73 puts "TEST 10 PASSED"
  74
  75 # REGTEST 11
  76 # 14 Feb 2010 - access static variable in deleted proc
  77 proc a {} {{x 1}} { rename a ""; incr x }
  78 a
  79 puts "TEST 11 PASSED"
  80
  81 # REGTEST 12
  82 # 13 Sep 2010 - reference with invalid tag
  83 set a b[ref value "tag name"]
  84 getref [string range $a 1 end]
  85 puts "TEST 12 PASSED"
  86
  87 # REGTEST 13
  88 # 14 Sep 2010 - parse list with trailing backslash
  89 set x "switch -0 \$on \\"
  90 lindex $x 1
  91 puts "TEST 13 PASSED"
  92
  93 # REGTEST 14
  94 # 14 Sep 2010 - command expands to nothing
  95 eval "{*}{}"
  96 puts "TEST 14 PASSED"
  97
  98 # REGTEST 15
  99 # 24 Feb 2010 - bad reference counting of the stack trace in 'error'
 100 proc a {msg stack} {
 101     tailcall error $msg $stack
 102 }
 103 catch {fail} msg opts
 104 catch {a $msg $opts(-errorinfo)}
 105
 106 # REGTEST 16
 107 # 24 Feb 2010 - rename the current proc
 108 # Leaves unfreed objects on the stack
 109 proc a {} { rename a newa}
 110 a
 111
 112 # REGTEST 17
 113 # 26 Nov 2010 - crashes on invalid dict sugar
 114 catch {eval {$x(}}
 115 puts "TEST 17 PASSED"
 116
 117 # REGTEST 18
 118 # 12 Apr 2011 - crashes on unset for loop var
 119 catch {
 120     set j 0
 121     for {set i 0} {$i < 5} {incr i} {
 122         unset i
 123         if {[incr j] == 5} {
 124             break
 125         }
 126     }
 127 }
 128 puts "TEST 18 PASSED"
 129
 130 # REGTEST 19
 131 # 25 May 2011 - crashes with double colon
 132 catch {
 133     expr {5 ne ::}
 134 }
 135 puts "TEST 19 PASSED"
 136
 137 # REGTEST 20
 138 # 26 May 2011 - infinite recursion
 139 proc a {} { global ::blah; set ::blah test }
 140 a
 141 puts "TEST 20 PASSED"
 142
 143 # REGTEST 21
 144 # 26 May 2011 - infinite loop with null byte in subst
 145 subst "abc\0def"
 146 puts "TEST 21 PASSED"
 147
 148 # REGTEST 22
 149 # 21 June 2011 - crashes on lappend to to value with script rep
 150 set x rand
 151 eval $x
 152 lappend x b
 153 puts "TEST 22 PASSED"
 154
 155 # REGTEST 23
 156 # 27 July 2011 - unfreed objects on exit
 157 catch {
 158     set x abc
 159     subst $x
 160     regexp $x $x
 161 }
 162 # Actually, the test passes if no objects leaked on exit
 163 puts "TEST 23 PASSED"
 164
 165 # REGTEST 24
 166 # 13 Nov 2011 - invalid cached global var
 167 proc a {} {
 168     foreach i {1 2} {
 169         incr z [set ::t]
 170         unset ::t
 171     }
 172 }
 173 set t 6
 174 catch a
 175 puts "TEST 24 PASSED"
 176
 177 # REGTEST 25
 178 # 14 Nov 2011 - link global var to proc var
 179 proc a {} {
 180     set x 3
 181     upvar 0 x ::globx
 182 }
 183 set globx 0
 184 catch {
 185     a
 186 }
 187 incr globx
 188 puts "TEST 25 PASSED"
 189
 190 # REGTEST 26
 191 # 2 Dec 2011 - infinite eval recursion
 192 catch {
 193     set x 0
 194     set y {incr x; eval $y}
 195     eval $y
 196 } msg
 197 puts "TEST 26 PASSED"
 198
 199 # REGTEST 27
 200 # 2 Dec 2011 - infinite alias recursion
 201 catch {
 202     proc p {} {}
 203     alias p p
 204     p
 205 } msg
 206 puts "TEST 27 PASSED"
 207
 208 # REGTEST 28
 209 # 16 Dec 2011 - ref count problem with finalizers
 210 catch {
 211     ref x x [list dummy]
 212     collect
 213 }
 214 puts "TEST 28 PASSED"
 215
 216 # REGTEST 29
 217 # Reference counting problem at exit
 218 set x [lindex {} 0]
 219 info source $x
 220 eval $x
 221 puts "TEST 29 PASSED"
 222
 223 # REGTEST 30
 224 # non-UTF8 string tolower
 225 string tolower "/mod/video/h\303\203\302\244xan_ witchcraft through the ages_20131101_0110.t"
 226 puts "TEST 30 PASSED"
 227
 228 # REGTEST 31
 229 # infinite lsort -unique with error
 230 catch {lsort -unique -real {foo 42.0}}
 231 puts "TEST 31 PASSED"
 232
 233 # REGTEST 32
 234 # return -code eval should only used by tailcall, but this incorrect usage
 235 # should not crash the interpreter
 236 proc a {} { tailcall b }
 237 proc b {} { return -code eval c }
 238 proc c {} {}
 239 catch -eval a
 240 puts "TEST 32 PASSED"
 241
 242 # REGTEST 33
 243 # unset array variable which doesn't exist
 244 array unset blahblah abc
 245 puts "TEST 33 PASSED"
 246
 247 # REGTEST 34
 248 # onexception and writable conflict
 249 set f [open [info nameofexecutable]]
 250 $f onexception {incr x}
 251 $f writable {incr y}
 252 $f close
 253 puts "TEST 34 PASSED"
 254
 255 # REGTEST 35
 256 # caching of command resolution after local proc deleted
 257 set result {}
 258 proc x {} { }
 259 proc p {n} {
 260     if {$n in {2 3}} {
 261         local proc x {} { }
 262     }
 263     x
 264 }
 265 foreach i {1 2 3 4} {
 266     p $i
 267 }
 268 puts "TEST 35 PASSED"
 269
 270 # TAKE THE FOLLOWING puts AS LAST LINE
 271
 272 puts "--- ALL TESTS PASSED ---"