1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366
|
# These regression tests all provoked crashes at some point.
# Thus they are kept separate from the regular test suite in tests/
# REGTEST 1
# 27Jan2005 - SIGSEGV for bug on Jim_DuplicateObj().
for {set i 0} {$i < 100} {incr i} {
set a "x"
lappend a n
}
puts "TEST 1 PASSED"
# REGTEST 2
# 29Jan2005 - SEGFAULT parsing script composed of just one comment.
eval {#foobar}
puts "TEST 2 PASSED"
# REGTEST 3
# 29Jan2005 - "Error in Expression" with correct expression
set x 5
expr {$x-5}
puts "TEST 3 PASSED"
# REGTEST 4
# 29Jan2005 - SIGSEGV when run this code, due to expr's bug.
proc fibonacci {x} {
if {$x <= 1} {
expr 1
} else {
expr {[fibonacci [expr {$x-1}]] + [fibonacci [expr {$x-2}]]}
}
}
fibonacci 6
puts "TEST 4 PASSED"
# REGTEST 5
# 06Mar2005 - This looped forever...
for {set i 0} {$i < 10} {incr i} {continue}
puts "TEST 5 PASSED"
# REGTEST 6
# 07Mar2005 - Unset create variable + dict is using dict syntax sugar at
# currently non-existing variable
catch {unset thisvardoesnotexists(thiskeytoo)}
if {[catch {set thisvardoesnotexists}] == 0} {
puts "TEST 6 FAILED - unset created dict for non-existing variable"
break
}
puts "TEST 6 PASSED"
# REGTEST 7
# 04Nov2008 - variable parsing does not eat last brace
set a 1
list ${a}
puts "TEST 7 PASSED"
# REGTEST 8
# 04Nov2008 - string toupper/tolower do not convert to string rep
string tolower [list a]
string toupper [list a]
puts "TEST 8 PASSED"
# REGTEST 9
# 04Nov2008 - crash on exit when replacing Tcl proc with C command.
# Requires the clock extension to be built as a loadable module.
proc clock {args} {}
catch {package require clock}
# Note, crash on exit, so don't say we passed!
# REGTEST 10
# 05Nov2008 - incorrect lazy expression evaluation with unary not
expr {1 || !0}
puts "TEST 10 PASSED"
# REGTEST 11
# 14 Feb 2010 - access static variable in deleted proc
proc a {} {{x 1}} { rename a ""; incr x }
a
puts "TEST 11 PASSED"
# REGTEST 12
# 13 Sep 2010 - reference with invalid tag
set a b[ref value "tag name"]
getref [string range $a 1 end]
puts "TEST 12 PASSED"
# REGTEST 13
# 14 Sep 2010 - parse list with trailing backslash
set x "switch -0 \$on \\"
lindex $x 1
puts "TEST 13 PASSED"
# REGTEST 14
# 14 Sep 2010 - command expands to nothing
eval "{*}{}"
puts "TEST 14 PASSED"
# REGTEST 15
# 24 Feb 2010 - bad reference counting of the stack trace in 'error'
proc a {msg stack} {
tailcall error $msg $stack
}
catch {fail} msg opts
catch {a $msg $opts(-errorinfo)}
# REGTEST 16
# 24 Feb 2010 - rename the current proc
# Leaves unfreed objects on the stack
proc a {} { rename a newa}
a
# REGTEST 17
# 26 Nov 2010 - crashes on invalid dict sugar
catch {eval {$x(}}
puts "TEST 17 PASSED"
# REGTEST 18
# 12 Apr 2011 - crashes on unset for loop var
catch {
set j 0
for {set i 0} {$i < 5} {incr i} {
unset i
if {[incr j] == 5} {
break
}
}
}
puts "TEST 18 PASSED"
# REGTEST 19
# 25 May 2011 - crashes with double colon
catch {
expr {5 ne ::}
}
puts "TEST 19 PASSED"
# REGTEST 20
# 26 May 2011 - infinite recursion
proc a {} { global ::blah; set ::blah test }
a
puts "TEST 20 PASSED"
# REGTEST 21
# 26 May 2011 - infinite loop with null byte in subst
subst "abc\0def"
puts "TEST 21 PASSED"
# REGTEST 22
# 21 June 2011 - crashes on lappend to to value with script rep
set x rand
eval $x
lappend x b
puts "TEST 22 PASSED"
# REGTEST 23
# 27 July 2011 - unfreed objects on exit
catch {
set x abc
subst $x
regexp $x $x
}
# Actually, the test passes if no objects leaked on exit
puts "TEST 23 PASSED"
# REGTEST 24
# 13 Nov 2011 - invalid cached global var
proc a {} {
foreach i {1 2} {
incr z [set ::t]
unset ::t
}
}
set t 6
catch a
puts "TEST 24 PASSED"
# REGTEST 25
# 14 Nov 2011 - link global var to proc var
proc a {} {
set x 3
upvar 0 x ::globx
}
set globx 0
catch {
a
}
incr globx
puts "TEST 25 PASSED"
# REGTEST 26
# 2 Dec 2011 - infinite eval recursion
catch {
set x 0
set y {incr x; eval $y}
eval $y
} msg
puts "TEST 26 PASSED"
# REGTEST 27
# 2 Dec 2011 - infinite alias recursion
catch {
proc p {} {}
alias p p
p
} msg
puts "TEST 27 PASSED"
# REGTEST 28
# 16 Dec 2011 - ref count problem with finalizers
catch {
ref x x [list dummy]
collect
}
puts "TEST 28 PASSED"
# REGTEST 29
# Reference counting problem at exit
set x [lindex {} 0]
info source $x
eval $x
puts "TEST 29 PASSED"
# REGTEST 30
# non-UTF8 string tolower
string tolower "/mod/video/h\303\203\302\244xan_ witchcraft through the ages_20131101_0110.t"
puts "TEST 30 PASSED"
# REGTEST 31
# infinite lsort -unique with error
catch {lsort -unique -real {foo 42.0}}
puts "TEST 31 PASSED"
# REGTEST 32
# return -code eval should only used by tailcall, but this incorrect usage
# should not crash the interpreter
proc a {} { tailcall b }
proc b {} { return -code eval c }
proc c {} {}
catch -eval a
puts "TEST 32 PASSED"
# REGTEST 33
# unset array variable which doesn't exist
array unset blahblah abc
puts "TEST 33 PASSED"
# REGTEST 34
# onexception and writable conflict
set f [open [info nameofexecutable]]
$f onexception {incr x}
$f writable {incr y}
$f close
puts "TEST 34 PASSED"
# REGTEST 35
# caching of command resolution after local proc deleted
set result {}
proc x {} { }
proc p {n} {
if {$n in {2 3}} {
local proc x {} { }
}
x
}
foreach i {1 2 3 4} {
p $i
}
puts "TEST 35 PASSED"
# REGTEST 36
# divide integer by integer zero
catch {/ 1 0}
puts "TEST 36 PASSED"
# REGTEST 37
# ternary operator order
catch {expr {1 : 2 ? 3}}
puts "TEST 37 PASSED"
# REGTEST 38
# refcount with interpolation and expr
set b(-1) 5
set a $b($(-1))
puts "TEST 38 PASSED"
# REGTEST 39
# invalid ternary expr
catch {set a $(5?6,7?8:?9:10%11:12)}
puts "TEST 39 PASSED"
# REGTEST 40
# ref count problem - double free
set d [dict create a b]
lsort r($d)
catch {dict remove r($d) m}
puts "TEST 40 PASSED"
# REGTEST 41
# access invalid memory on no scan conversion char
catch {scan x %3}
puts "TEST 41 PASSED"
# REGTEST 42
# | and |& are not acceptable as prefixes
catch {exec dummy |x second}
puts "TEST 42 PASSED"
# REGTEST 43
# too many flags to format
catch {format %----------------------------------------d 1}
puts "TEST 43 PASSED"
# REGTEST 44
# lsort -unique with no duplicate - invalid memory write
lsort -unique {a b c d}
puts "TEST 44 PASSED"
# REGTEST 45
# regexp with missing close brace for count
catch [list regexp "u{0" x]
puts "TEST 45 PASSED"
# REGTEST 46
# scan with no stringrep
catch {scan $(1) $(1)}
puts "TEST 46 PASSED"
# REGTEST 47
# Invalid ternary expression
catch {set a $(99?9,99?9:*9:999)?9)}
puts "TEST 47 PASSED"
# REGTEST 48
# scan: -ve XPG3 specifier
catch {scan a {%-9999999$c}}
puts "TEST 48 PASSED"
# REGTEST 49
# format: precision too large
catch {format %1.9999999999f 1.0}
puts "TEST 49 PASSED"
# REGTEST 50
# expr missing operand
catch {expr {>>-$x}}
puts "TEST 50 PASSED"
# REGTEST 51
# expr convert invalid value to boolean
catch {expr {2 && "abc$"}}
puts "TEST 51 PASSED"
# REGTEST 52
# lsearch -command with too few args
catch {lsearch -all -command abc def}
puts "TEST 52 PASSED"
# REGTEST 53
# string last with invalid index
catch {string last foo bar -1}
puts "TEST 53 PASSED"
# TAKE THE FOLLOWING puts AS LAST LINE
puts "--- ALL TESTS PASSED ---"
|