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     for {set i 0} {$i < 5} {incr i} {unset i}
 121 }
 122 puts "TEST 18 PASSED"
 123
 124 # REGTEST 19
 125 # 25 May 2011 - crashes with double colon
 126 catch {
 127     expr {5 ne ::}
 128 }
 129 puts "TEST 19 PASSED"
 130
 131 # REGTEST 20
 132 # 26 May 2011 - infinite recursion
 133 proc a {} { global ::blah; set ::blah test }
 134 a
 135 puts "TEST 20 PASSED"
 136
 137 # REGTEST 21
 138 # 26 May 2011 - infinite loop with null byte in subst
 139 subst "abc\0def"
 140 puts "TEST 21 PASSED"
 141
 142 # REGTEST 22
 143 # 21 June 2011 - crashes on lappend to to value with script rep
 144 set x rand
 145 eval $x
 146 lappend x b
 147 puts "TEST 22 PASSED"
 148
 149 # REGTEST 23
 150 # 27 July 2011 - unfreed objects on exit
 151 catch {
 152     set x abc
 153     subst $x
 154     regexp $x $x
 155 }
 156 # Actually, the test passes if no objects leaked on exit
 157 puts "TEST 23 PASSED"
 158
 159 # REGTEST 24
 160 # 13 Nov 2011 - invalid cached global var
 161 proc a {} {
 162     foreach i {1 2} {
 163         incr z [set ::t]
 164         unset ::t
 165     }
 166 }
 167 set t 6
 168 catch a
 169 puts "TEST 24 PASSED"
 170
 171 # REGTEST 25
 172 # 14 Nov 2011 - link global var to proc var
 173 proc a {} {
 174     set x 3
 175     upvar 0 x ::globx
 176 }
 177 set globx 0
 178 catch {
 179     a
 180 }
 181 incr globx
 182 puts "TEST 25 PASSED"
 183
 184 # REGTEST 26
 185 # 2 Dec 2011 - infinite eval recursion
 186 catch {
 187     set x 0
 188     set y {incr x; eval $y}
 189     eval $y
 190 } msg
 191 puts "TEST 26 PASSED"
 192
 193 # REGTEST 27
 194 # 2 Dec 2011 - infinite alias recursion
 195 catch {
 196     proc p {} {}
 197     alias p p
 198     p
 199 } msg
 200 puts "TEST 27 PASSED"
 201
 202 # REGTEST 28
 203 # 16 Dec 2011 - ref count problem with finalizers
 204 catch {
 205     ref x x [list dummy]
 206     collect
 207 }
 208 puts "TEST 28 PASSED"
 209
 210 # REGTEST 29
 211 # Reference counting problem at exit
 212 set x [lindex {} 0]
 213 info source $x
 214 eval $x
 215 puts "TEST 29 PASSED"
 216
 217 # REGTEST 30
 218 # non-UTF8 string tolower
 219 string tolower "/mod/video/h\303\203\302\244xan_ witchcraft through the ages_20131101_0110.t"
 220 puts "TEST 30 PASSED"
 221
 222 # REGTEST 31
 223 # infinite lsort -unique with error
 224 catch {lsort -unique -real {foo 42.0}}
 225 puts "TEST 31 PASSED"
 226
 227 # REGTEST 32
 228 # return -code eval should only used by tailcall, but this incorrect usage
 229 # should not crash the interpreter
 230 proc a {} { tailcall b }
 231 proc b {} { return -code eval c }
 232 proc c {} {}
 233 catch -eval a
 234 puts "TEST 32 PASSED"
 235
 236 # REGTEST 33
 237 # unset array variable which doesn't exist
 238 array unset blahblah abc
 239 puts "TEST 33 PASSED"
 240
 241 # REGTEST 34
 242 # onexception and writable conflict
 243 set f [open [info nameofexecutable]]
 244 $f onexception {incr x}
 245 $f writable {incr y}
 246 $f close
 247 puts "TEST 34 PASSED"
 248
 249 # TAKE THE FOLLOWING puts AS LAST LINE
 250
 251 puts "--- ALL TESTS PASSED ---"