aboutsummaryrefslogtreecommitdiff
path: root/regtest.tcl
blob: a46b849fb52e7a94faba779dc1d0cae1ffde176d (plain)
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
# 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"

# TAKE THE FOLLOWING puts AS LAST LINE

puts "--- ALL TESTS PASSED ---"