/trunk/test/randexpr1.tcl |
@@ -0,0 +1,342 @@ |
# Run this TCL script to generate thousands of test cases containing |
# complicated expressions. |
# |
# The generated tests are intended to verify expression evaluation |
# in SQLite against expression evaluation TCL. |
# |
|
# Terms of the $intexpr list each contain two sub-terms. |
# |
# * An SQL expression template |
# * The equivalent TCL expression |
# |
# EXPR is replaced by an integer subexpression. BOOL is replaced |
# by a boolean subexpression. |
# |
set intexpr { |
{11 wide(11)} |
{13 wide(13)} |
{17 wide(17)} |
{19 wide(19)} |
{a $a} |
{b $b} |
{c $c} |
{d $d} |
{e $e} |
{f $f} |
{t1.a $a} |
{t1.b $b} |
{t1.c $c} |
{t1.d $d} |
{t1.e $e} |
{t1.f $f} |
{(EXPR) (EXPR)} |
{{ -EXPR} {-EXPR}} |
{+EXPR +EXPR} |
{~EXPR ~EXPR} |
{EXPR+EXPR EXPR+EXPR} |
{EXPR-EXPR EXPR-EXPR} |
{EXPR*EXPR EXPR*EXPR} |
{EXPR+EXPR EXPR+EXPR} |
{EXPR-EXPR EXPR-EXPR} |
{EXPR*EXPR EXPR*EXPR} |
{EXPR+EXPR EXPR+EXPR} |
{EXPR-EXPR EXPR-EXPR} |
{EXPR*EXPR EXPR*EXPR} |
{{EXPR | EXPR} {EXPR | EXPR}} |
{(abs(EXPR)/abs(EXPR)) (abs(EXPR)/abs(EXPR))} |
{ |
{case when BOOL then EXPR else EXPR end} |
{((BOOL)?EXPR:EXPR)} |
} |
{ |
{case when BOOL then EXPR when BOOL then EXPR else EXPR end} |
{((BOOL)?EXPR:((BOOL)?EXPR:EXPR))} |
} |
{ |
{case EXPR when EXPR then EXPR else EXPR end} |
{(((EXPR)==(EXPR))?EXPR:EXPR)} |
} |
{ |
{(select AGG from t1)} |
{(AGG)} |
} |
{ |
{coalesce((select max(EXPR) from t1 where BOOL),EXPR)} |
{[coalesce_subquery [expr {EXPR}] [expr {BOOL}] [expr {EXPR}]]} |
} |
{ |
{coalesce((select EXPR from t1 where BOOL),EXPR)} |
{[coalesce_subquery [expr {EXPR}] [expr {BOOL}] [expr {EXPR}]]} |
} |
} |
|
# The $boolexpr list contains terms that show both an SQL boolean |
# expression and its equivalent TCL. |
# |
set boolexpr { |
{EXPR=EXPR ((EXPR)==(EXPR))} |
{EXPR<EXPR ((EXPR)<(EXPR))} |
{EXPR>EXPR ((EXPR)>(EXPR))} |
{EXPR<=EXPR ((EXPR)<=(EXPR))} |
{EXPR>=EXPR ((EXPR)>=(EXPR))} |
{EXPR<>EXPR ((EXPR)!=(EXPR))} |
{ |
{EXPR between EXPR and EXPR} |
{[betweenop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]]} |
} |
{ |
{EXPR not between EXPR and EXPR} |
{(![betweenop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]])} |
} |
{ |
{EXPR in (EXPR,EXPR,EXPR)} |
{([inop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]])} |
} |
{ |
{EXPR not in (EXPR,EXPR,EXPR)} |
{(![inop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]])} |
} |
{ |
{EXPR in (select EXPR from t1 union select EXPR from t1)} |
{[inop [expr {EXPR}] [expr {EXPR}] [expr {EXPR}]]} |
} |
{ |
{EXPR in (select AGG from t1 union select AGG from t1)} |
{[inop [expr {EXPR}] [expr {AGG}] [expr {AGG}]]} |
} |
{ |
{exists(select 1 from t1 where BOOL)} |
{(BOOL)} |
} |
{ |
{not exists(select 1 from t1 where BOOL)} |
{!(BOOL)} |
} |
{{not BOOL} !BOOL} |
{{BOOL and BOOL} {BOOL tcland BOOL}} |
{{BOOL or BOOL} {BOOL || BOOL}} |
{{BOOL and BOOL} {BOOL tcland BOOL}} |
{{BOOL or BOOL} {BOOL || BOOL}} |
{(BOOL) (BOOL)} |
{(BOOL) (BOOL)} |
} |
|
# Aggregate expressions |
# |
set aggexpr { |
{count(*) wide(1)} |
{{count(distinct EXPR)} {[one {EXPR}]}} |
{{cast(avg(EXPR) AS integer)} (EXPR)} |
{min(EXPR) (EXPR)} |
{max(EXPR) (EXPR)} |
{(AGG) (AGG)} |
{{ -AGG} {-AGG}} |
{+AGG +AGG} |
{~AGG ~AGG} |
{abs(AGG) abs(AGG)} |
{AGG+AGG AGG+AGG} |
{AGG-AGG AGG-AGG} |
{AGG*AGG AGG*AGG} |
{{AGG | AGG} {AGG | AGG}} |
{ |
{case AGG when AGG then AGG else AGG end} |
{(((AGG)==(AGG))?AGG:AGG)} |
} |
} |
|
# Convert a string containing EXPR, AGG, and BOOL into a string |
# that contains nothing but X, Y, and Z. |
# |
proc extract_vars {a} { |
regsub -all {EXPR} $a X a |
regsub -all {AGG} $a Y a |
regsub -all {BOOL} $a Z a |
regsub -all {[^XYZ]} $a {} a |
return $a |
} |
|
|
# Test all templates to make sure the number of EXPR, AGG, and BOOL |
# expressions match. |
# |
foreach term [concat $aggexpr $intexpr $boolexpr] { |
foreach {a b} $term break |
if {[extract_vars $a]!=[extract_vars $b]} { |
error "mismatch: $term" |
} |
} |
|
# Generate a random expression according to the templates given above. |
# If the argument is EXPR or omitted, then an integer expression is |
# generated. If the argument is BOOL then a boolean expression is |
# produced. |
# |
proc generate_expr {{e EXPR}} { |
set tcle $e |
set ne [llength $::intexpr] |
set nb [llength $::boolexpr] |
set na [llength $::aggexpr] |
set div 2 |
set mx 50 |
set i 0 |
while {1} { |
set cnt 0 |
set re [lindex $::intexpr [expr {int(rand()*$ne)}]] |
incr cnt [regsub {EXPR} $e [lindex $re 0] e] |
regsub {EXPR} $tcle [lindex $re 1] tcle |
set rb [lindex $::boolexpr [expr {int(rand()*$nb)}]] |
incr cnt [regsub {BOOL} $e [lindex $rb 0] e] |
regsub {BOOL} $tcle [lindex $rb 1] tcle |
set ra [lindex $::aggexpr [expr {int(rand()*$na)}]] |
incr cnt [regsub {AGG} $e [lindex $ra 0] e] |
regsub {AGG} $tcle [lindex $ra 1] tcle |
|
if {$cnt==0} break |
incr i $cnt |
|
set v1 [extract_vars $e] |
if {$v1!=[extract_vars $tcle]} { |
exit |
} |
|
if {$i+[string length $v1]>=$mx} { |
set ne [expr {$ne/$div}] |
set nb [expr {$nb/$div}] |
set na [expr {$na/$div}] |
set div 1 |
set mx [expr {$mx*1000}] |
} |
} |
regsub -all { tcland } $tcle { \&\& } tcle |
return [list $e $tcle] |
} |
|
# Implementation of routines used to implement the IN and BETWEEN |
# operators. |
proc inop {lhs args} { |
foreach a $args { |
if {$a==$lhs} {return 1} |
} |
return 0 |
} |
proc betweenop {lhs first second} { |
return [expr {$lhs>=$first && $lhs<=$second}] |
} |
proc coalesce_subquery {a b e} { |
if {$b} { |
return $a |
} else { |
return $e |
} |
} |
proc one {args} { |
return 1 |
} |
|
# Begin generating the test script: |
# |
puts {# 2008 December 16 |
# |
# The author disclaims copyright to this source code. In place of |
# a legal notice, here is a blessing: |
# |
# May you do good and not evil. |
# May you find forgiveness for yourself and forgive others. |
# May you share freely, never taking more than you give. |
# |
#*********************************************************************** |
# This file implements regression tests for SQLite library. |
# |
# This file tests randomly generated SQL expressions. The expressions |
# are generated by a TCL script. The same TCL script also computes the |
# correct value of the expression. So, from one point of view, this |
# file verifies the expression evaluation logic of SQLite against the |
# expression evaluation logic of TCL. |
# |
# An early version of this script is how bug #3541 was detected. |
# |
# $Id: randexpr1.tcl,v 1.1 2008/12/15 16:33:30 drh Exp $ |
set testdir [file dirname $argv0] |
source $testdir/tester.tcl |
|
# Create test data |
# |
do_test randexpr1-1.1 { |
db eval { |
CREATE TABLE t1(a,b,c,d,e,f); |
INSERT INTO t1 VALUES(100,200,300,400,500,600); |
SELECT * FROM t1 |
} |
} {100 200 300 400 500 600} |
} |
|
# Test data for TCL evaluation. |
# |
set a [expr {wide(100)}] |
set b [expr {wide(200)}] |
set c [expr {wide(300)}] |
set d [expr {wide(400)}] |
set e [expr {wide(500)}] |
set f [expr {wide(600)}] |
|
# A procedure to generate a test case. |
# |
set tn 0 |
proc make_test_case {sql result} { |
global tn |
incr tn |
puts "do_test randexpr-2.$tn {\n db eval {$sql}\n} {$result}" |
} |
|
# Generate many random test cases. |
# |
expr srand(0) |
for {set i 0} {$i<1000} {incr i} { |
while {1} { |
foreach {sqle tcle} [generate_expr EXPR] break; |
if {[catch {expr $tcle} ans]} { |
#puts stderr [list $tcle] |
#puts stderr ans=$ans |
if {![regexp {divide by zero} $ans]} exit |
continue |
} |
set len [string length $sqle] |
if {$len<100 || $len>2000} continue |
if {[info exists seen($sqle)]} continue |
set seen($sqle) 1 |
break |
} |
while {1} { |
foreach {sqlb tclb} [generate_expr BOOL] break; |
if {[catch {expr $tclb} bans]} { |
#puts stderr [list $tclb] |
#puts stderr bans=$bans |
if {![regexp {divide by zero} $bans]} exit |
continue |
} |
break |
} |
if {$bans} { |
make_test_case "SELECT $sqle FROM t1 WHERE $sqlb" $ans |
make_test_case "SELECT $sqle FROM t1 WHERE NOT ($sqlb)" {} |
} else { |
make_test_case "SELECT $sqle FROM t1 WHERE $sqlb" {} |
make_test_case "SELECT $sqle FROM t1 WHERE NOT ($sqlb)" $ans |
} |
if {[regexp { \| } $sqle]} { |
regsub -all { \| } $sqle { \& } sqle |
regsub -all { \| } $tcle { \& } tcle |
if {[catch {expr $tcle} ans]==0} { |
if {$bans} { |
make_test_case "SELECT $sqle FROM t1 WHERE $sqlb" $ans |
} else { |
make_test_case "SELECT $sqle FROM t1 WHERE NOT ($sqlb)" $ans |
} |
} |
} |
} |
|
# Terminate the test script |
# |
puts {finish_test} |