1 # Run this TCL script to generate thousands of test cases containing 2 # complicated expressions. 3 # 4 # The generated tests are intended to verify expression evaluation 5 # in SQLite against expression evaluation TCL. 6 # 7 8 # Terms of the $intexpr list each contain two sub-terms. 9 # 10 # * An SQL expression template 11 # * The equivalent TCL expression 12 # 13 # EXPR is replaced by an integer subexpression. BOOL is replaced 14 # by a boolean subexpression. 15 # 16 set intexpr { 17 {11 wide(11)} 18 {13 wide(13)} 19 {17 wide(17)} 20 {19 wide(19)} 21 {a $a} 22 {b $b} 23 {c $c} 24 {d $d} 25 {e $e} 26 {f $f} 27 {t1.a $a} 28 {t1.b $b} 29 {t1.c $c} 30 {t1.d $d} 31 {t1.e $e} 32 {t1.f $f} 33 {(EXPR) (EXPR)} 34 {{ -EXPR} {-EXPR}} 35 {+EXPR +EXPR} 36 {~EXPR ~EXPR} 37 {EXPR+EXPR EXPR+EXPR} 38 {EXPR-EXPR EXPR-EXPR} 39 {EXPR*EXPR EXPR*EXPR} 40 {EXPR+EXPR EXPR+EXPR} 41 {EXPR-EXPR EXPR-EXPR} 42 {EXPR*EXPR EXPR*EXPR} 43 {EXPR+EXPR EXPR+EXPR} 44 {EXPR-EXPR EXPR-EXPR} 45 {EXPR*EXPR EXPR*EXPR} 46 {{EXPR | EXPR} {EXPR | EXPR}} 47 {(abs(EXPR)/abs(EXPR)) (abs(EXPR)/abs(EXPR))} 48 { 49 {case when BOOL then EXPR else EXPR end} 50 {((BOOL)?EXPR:EXPR)} 51 } 52 { 53 {case when BOOL then EXPR when BOOL then EXPR else EXPR end} 54 {((BOOL)?EXPR:((BOOL)?EXPR:EXPR))} 55 } 56 { 57 {case EXPR when EXPR then EXPR else EXPR end} 58 {(((EXPR)==(EXPR))?EXPR:EXPR)} 59 } 60 { 61 {(select AGG from t1)} 62 {(AGG)} 63 } 64 { 65 {coalesce((select max(EXPR) from t1 where BOOL),EXPR)} 66 {[coalesce_subquery [expr {EXPR}] [expr {BOOL}] [expr {EXPR}]]} 67 } 68 { 69 {coalesce((select EXPR from t1 where BOOL),EXPR)} 70 {[coalesce_subquery [expr {EXPR}] [expr {BOOL}] [expr {EXPR}]]} 71 } 72 } 73 74 # The $boolexpr list contains terms that show both an SQL boolean 75 # expression and its equivalent TCL. 76 # 77 set boolexpr { 78 {EXPR=EXPR ((EXPR)==(EXPR))} 79 {EXPR<EXPR ((EXPR)<(EXPR))} 80 {EXPR>EXPR ((EXPR)>(EXPR))} 81 {EXPR<=EXPR ((EXPR)<=(EXPR))} 82 {EXPR>=EXPR ((EXPR)>=(EXPR))} 83 {EXPR<>EXPR ((EXPR)!=(EXPR))} 84 { 85 {EXPR between EXPR and EXPR} 86 {[betweenop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]]} 87 } 88 { 89 {EXPR not between EXPR and EXPR} 90 {(![betweenop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]])} 91 } 92 { 93 {EXPR in (EXPR,EXPR,EXPR)} 94 {([inop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]])} 95 } 96 { 97 {EXPR not in (EXPR,EXPR,EXPR)} 98 {(![inop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]])} 99 } 100 { 101 {EXPR in (select EXPR from t1 union select EXPR from t1)} 102 {[inop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]]} 103 } 104 { 105 {EXPR in (select AGG from t1 union select AGG from t1)} 106 {[inop [expr {EXPR}] [expr {AGG}] [expr {AGG}]]} 107 } 108 { 109 {exists(select 1 from t1 where BOOL)} 110 {(BOOL)} 111 } 112 { 113 {not exists(select 1 from t1 where BOOL)} 114 {!(BOOL)} 115 } 116 {{not BOOL} !BOOL} 117 {{BOOL and BOOL} {BOOL tcland BOOL}} 118 {{BOOL or BOOL} {BOOL || BOOL}} 119 {{BOOL and BOOL} {BOOL tcland BOOL}} 120 {{BOOL or BOOL} {BOOL || BOOL}} 121 {(BOOL) (BOOL)} 122 {(BOOL) (BOOL)} 123 } 124 125 # Aggregate expressions 126 # 127 set aggexpr { 128 {count(*) wide(1)} 129 {{count(distinct EXPR)} {[one {EXPR}]}} 130 {{cast(avg(EXPR) AS integer)} (EXPR)} 131 {min(EXPR) (EXPR)} 132 {max(EXPR) (EXPR)} 133 {(AGG) (AGG)} 134 {{ -AGG} {-AGG}} 135 {+AGG +AGG} 136 {~AGG ~AGG} 137 {abs(AGG) abs(AGG)} 138 {AGG+AGG AGG+AGG} 139 {AGG-AGG AGG-AGG} 140 {AGG*AGG AGG*AGG} 141 {{AGG | AGG} {AGG | AGG}} 142 { 143 {case AGG when AGG then AGG else AGG end} 144 {(((AGG)==(AGG))?AGG:AGG)} 145 } 146 } 147 148 # Convert a string containing EXPR, AGG, and BOOL into a string 149 # that contains nothing but X, Y, and Z. 150 # 151 proc extract_vars {a} { 152 regsub -all {EXPR} $a X a 153 regsub -all {AGG} $a Y a 154 regsub -all {BOOL} $a Z a 155 regsub -all {[^XYZ]} $a {} a 156 return $a 157 } 158 159 160 # Test all templates to make sure the number of EXPR, AGG, and BOOL 161 # expressions match. 162 # 163 foreach term [concat $aggexpr $intexpr $boolexpr] { 164 foreach {a b} $term break 165 if {[extract_vars $a]!=[extract_vars $b]} { 166 error "mismatch: $term" 167 } 168 } 169 170 # Generate a random expression according to the templates given above. 171 # If the argument is EXPR or omitted, then an integer expression is 172 # generated. If the argument is BOOL then a boolean expression is 173 # produced. 174 # 175 proc generate_expr {{e EXPR}} { 176 set tcle $e 177 set ne [llength $::intexpr] 178 set nb [llength $::boolexpr] 179 set na [llength $::aggexpr] 180 set div 2 181 set mx 50 182 set i 0 183 while {1} { 184 set cnt 0 185 set re [lindex $::intexpr [expr {int(rand()*$ne)}]] 186 incr cnt [regsub {EXPR} $e [lindex $re 0] e] 187 regsub {EXPR} $tcle [lindex $re 1] tcle 188 set rb [lindex $::boolexpr [expr {int(rand()*$nb)}]] 189 incr cnt [regsub {BOOL} $e [lindex $rb 0] e] 190 regsub {BOOL} $tcle [lindex $rb 1] tcle 191 set ra [lindex $::aggexpr [expr {int(rand()*$na)}]] 192 incr cnt [regsub {AGG} $e [lindex $ra 0] e] 193 regsub {AGG} $tcle [lindex $ra 1] tcle 194 195 if {$cnt==0} break 196 incr i $cnt 197 198 set v1 [extract_vars $e] 199 if {$v1!=[extract_vars $tcle]} { 200 exit 201 } 202 203 if {$i+[string length $v1]>=$mx} { 204 set ne [expr {$ne/$div}] 205 set nb [expr {$nb/$div}] 206 set na [expr {$na/$div}] 207 set div 1 208 set mx [expr {$mx*1000}] 209 } 210 } 211 regsub -all { tcland } $tcle { \&\& } tcle 212 return [list $e $tcle] 213 } 214 215 # Implementation of routines used to implement the IN and BETWEEN 216 # operators. 217 proc inop {lhs args} { 218 foreach a $args { 219 if {$a==$lhs} {return 1} 220 } 221 return 0 222 } 223 proc betweenop {lhs first second} { 224 return [expr {$lhs>=$first && $lhs<=$second}] 225 } 226 proc coalesce_subquery {a b e} { 227 if {$b} { 228 return $a 229 } else { 230 return $e 231 } 232 } 233 proc one {args} { 234 return 1 235 } 236 237 # Begin generating the test script: 238 # 239 puts {# 2008 December 16 240 # 241 # The author disclaims copyright to this source code. In place of 242 # a legal notice, here is a blessing: 243 # 244 # May you do good and not evil. 245 # May you find forgiveness for yourself and forgive others. 246 # May you share freely, never taking more than you give. 247 # 248 #*********************************************************************** 249 # This file implements regression tests for SQLite library. 250 # 251 # This file tests randomly generated SQL expressions. The expressions 252 # are generated by a TCL script. The same TCL script also computes the 253 # correct value of the expression. So, from one point of view, this 254 # file verifies the expression evaluation logic of SQLite against the 255 # expression evaluation logic of TCL. 256 # 257 # An early version of this script is how bug #3541 was detected. 258 # 259 # $Id: randexpr1.tcl,v 1.1 2008/12/15 16:33:30 drh Exp $ 260 set testdir [file dirname $argv0] 261 source $testdir/tester.tcl 262 263 # Create test data 264 # 265 do_test randexpr1-1.1 { 266 db eval { 267 CREATE TABLE t1(a,b,c,d,e,f); 268 INSERT INTO t1 VALUES(100,200,300,400,500,600); 269 SELECT * FROM t1 270 } 271 } {100 200 300 400 500 600} 272 } 273 274 # Test data for TCL evaluation. 275 # 276 set a [expr {wide(100)}] 277 set b [expr {wide(200)}] 278 set c [expr {wide(300)}] 279 set d [expr {wide(400)}] 280 set e [expr {wide(500)}] 281 set f [expr {wide(600)}] 282 283 # A procedure to generate a test case. 284 # 285 set tn 0 286 proc make_test_case {sql result} { 287 global tn 288 incr tn 289 puts "do_test randexpr-2.$tn {\n db eval {$sql}\n} {$result}" 290 } 291 292 # Generate many random test cases. 293 # 294 expr srand(0) 295 for {set i 0} {$i<1000} {incr i} { 296 while {1} { 297 foreach {sqle tcle} [generate_expr EXPR] break; 298 if {[catch {expr $tcle} ans]} { 299 #puts stderr [list $tcle] 300 #puts stderr ans=$ans 301 if {![regexp {divide by zero} $ans]} exit 302 continue 303 } 304 set len [string length $sqle] 305 if {$len<100 || $len>2000} continue 306 if {[info exists seen($sqle)]} continue 307 set seen($sqle) 1 308 break 309 } 310 while {1} { 311 foreach {sqlb tclb} [generate_expr BOOL] break; 312 if {[catch {expr $tclb} bans]} { 313 #puts stderr [list $tclb] 314 #puts stderr bans=$bans 315 if {![regexp {divide by zero} $bans]} exit 316 continue 317 } 318 break 319 } 320 if {$bans} { 321 make_test_case "SELECT $sqle FROM t1 WHERE $sqlb" $ans 322 make_test_case "SELECT $sqle FROM t1 WHERE NOT ($sqlb)" {} 323 } else { 324 make_test_case "SELECT $sqle FROM t1 WHERE $sqlb" {} 325 make_test_case "SELECT $sqle FROM t1 WHERE NOT ($sqlb)" $ans 326 } 327 if {[regexp { \| } $sqle]} { 328 regsub -all { \| } $sqle { \& } sqle 329 regsub -all { \| } $tcle { \& } tcle 330 if {[catch {expr $tcle} ans]==0} { 331 if {$bans} { 332 make_test_case "SELECT $sqle FROM t1 WHERE $sqlb" $ans 333 } else { 334 make_test_case "SELECT $sqle FROM t1 WHERE NOT ($sqlb)" $ans 335 } 336 } 337 } 338 } 339 340 # Terminate the test script 341 # 342 puts {finish_test} 343