| # 2001 September 15 |
| # |
| # 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 TCL interface to the |
| # SQLite library. |
| # |
| # Actually, all tests are based on the TCL interface, so the main |
| # interface is pretty well tested. This file contains some addition |
| # tests for fringe issues that the main test suite does not cover. |
| # |
| # $Id: tclsqlite.test,v 1.73 2009/03/16 13:19:36 danielk1977 Exp $ |
| |
| set testdir [file dirname $argv0] |
| source $testdir/tester.tcl |
| |
| # Check the error messages generated by tclsqlite |
| # |
| if {[sqlite3 -has-codec]} { |
| set r "sqlite_orig HANDLE FILENAME ?-key CODEC-KEY?" |
| } else { |
| set r "sqlite_orig HANDLE FILENAME ?-vfs VFSNAME? ?-readonly BOOLEAN? ?-create BOOLEAN? ?-nomutex BOOLEAN? ?-fullmutex BOOLEAN?" |
| } |
| do_test tcl-1.1 { |
| set v [catch {sqlite3 bogus} msg] |
| regsub {really_sqlite3} $msg {sqlite3} msg |
| lappend v $msg |
| } [list 1 "wrong # args: should be \"$r\""] |
| do_test tcl-1.2 { |
| set v [catch {db bogus} msg] |
| lappend v $msg |
| } {1 {bad option "bogus": must be authorizer, backup, busy, cache, changes, close, collate, collation_needed, commit_hook, complete, copy, enable_load_extension, errorcode, eval, exists, function, incrblob, interrupt, last_insert_rowid, nullvalue, onecolumn, profile, progress, rekey, restore, rollback_hook, status, timeout, total_changes, trace, transaction, unlock_notify, update_hook, version, or wal_hook}} |
| do_test tcl-1.2.1 { |
| set v [catch {db cache bogus} msg] |
| lappend v $msg |
| } {1 {bad option "bogus": must be flush or size}} |
| do_test tcl-1.2.2 { |
| set v [catch {db cache} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db cache option ?arg?"}} |
| do_test tcl-1.3 { |
| execsql {CREATE TABLE t1(a int, b int)} |
| execsql {INSERT INTO t1 VALUES(10,20)} |
| set v [catch { |
| db eval {SELECT * FROM t1} data { |
| error "The error message" |
| } |
| } msg] |
| lappend v $msg |
| } {1 {The error message}} |
| do_test tcl-1.4 { |
| set v [catch { |
| db eval {SELECT * FROM t2} data { |
| error "The error message" |
| } |
| } msg] |
| lappend v $msg |
| } {1 {no such table: t2}} |
| do_test tcl-1.5 { |
| set v [catch { |
| db eval {SELECT * FROM t1} data { |
| break |
| } |
| } msg] |
| lappend v $msg |
| } {0 {}} |
| catch {expr x*} msg |
| do_test tcl-1.6 { |
| set v [catch { |
| db eval {SELECT * FROM t1} data { |
| expr x* |
| } |
| } msg] |
| lappend v $msg |
| } [list 1 $msg] |
| do_test tcl-1.7 { |
| set v [catch {db} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db SUBCOMMAND ..."}} |
| if {[catch {db auth {}}]==0} { |
| do_test tcl-1.8 { |
| set v [catch {db authorizer 1 2 3} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db authorizer ?CALLBACK?"}} |
| } |
| do_test tcl-1.9 { |
| set v [catch {db busy 1 2 3} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db busy CALLBACK"}} |
| do_test tcl-1.10 { |
| set v [catch {db progress 1} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db progress N CALLBACK"}} |
| do_test tcl-1.11 { |
| set v [catch {db changes xyz} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db changes "}} |
| do_test tcl-1.12 { |
| set v [catch {db commit_hook a b c} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db commit_hook ?CALLBACK?"}} |
| ifcapable {complete} { |
| do_test tcl-1.13 { |
| set v [catch {db complete} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db complete SQL"}} |
| } |
| do_test tcl-1.14 { |
| set v [catch {db eval} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db eval SQL ?ARRAY-NAME? ?SCRIPT?"}} |
| do_test tcl-1.15 { |
| set v [catch {db function} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db function NAME [-argcount N] SCRIPT"}} |
| do_test tcl-1.16 { |
| set v [catch {db last_insert_rowid xyz} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db last_insert_rowid "}} |
| do_test tcl-1.17 { |
| set v [catch {db rekey} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db rekey KEY"}} |
| do_test tcl-1.18 { |
| set v [catch {db timeout} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db timeout MILLISECONDS"}} |
| do_test tcl-1.19 { |
| set v [catch {db collate} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db collate NAME SCRIPT"}} |
| do_test tcl-1.20 { |
| set v [catch {db collation_needed} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db collation_needed SCRIPT"}} |
| do_test tcl-1.21 { |
| set v [catch {db total_changes xyz} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db total_changes "}} |
| do_test tcl-1.20 { |
| set v [catch {db copy} msg] |
| lappend v $msg |
| } {1 {wrong # args: should be "db copy CONFLICT-ALGORITHM TABLE FILENAME ?SEPARATOR? ?NULLINDICATOR?"}} |
| do_test tcl-1.21 { |
| set v [catch {sqlite3 db2 test.db -vfs nosuchvfs} msg] |
| lappend v $msg |
| } {1 {no such vfs: nosuchvfs}} |
| |
| catch {unset ::result} |
| do_test tcl-2.1 { |
| execsql "CREATE TABLE t\u0123x(a int, b\u1235 float)" |
| } {} |
| ifcapable schema_pragmas { |
| do_test tcl-2.2 { |
| execsql "PRAGMA table_info(t\u0123x)" |
| } "0 a int 0 {} 0 1 b\u1235 float 0 {} 0" |
| } |
| do_test tcl-2.3 { |
| execsql "INSERT INTO t\u0123x VALUES(1,2.3)" |
| db eval "SELECT * FROM t\u0123x" result break |
| set result(*) |
| } "a b\u1235" |
| |
| |
| # Test the onecolumn method |
| # |
| do_test tcl-3.1 { |
| execsql { |
| INSERT INTO t1 SELECT a*2, b*2 FROM t1; |
| INSERT INTO t1 SELECT a*2+1, b*2+1 FROM t1; |
| INSERT INTO t1 SELECT a*2+3, b*2+3 FROM t1; |
| } |
| set rc [catch {db onecolumn {SELECT * FROM t1 ORDER BY a}} msg] |
| lappend rc $msg |
| } {0 10} |
| do_test tcl-3.2 { |
| db onecolumn {SELECT * FROM t1 WHERE a<0} |
| } {} |
| do_test tcl-3.3 { |
| set rc [catch {db onecolumn} errmsg] |
| lappend rc $errmsg |
| } {1 {wrong # args: should be "db onecolumn SQL"}} |
| do_test tcl-3.4 { |
| set rc [catch {db onecolumn {SELECT bogus}} errmsg] |
| lappend rc $errmsg |
| } {1 {no such column: bogus}} |
| ifcapable {tclvar} { |
| do_test tcl-3.5 { |
| set b 50 |
| set rc [catch {db one {SELECT * FROM t1 WHERE b>$b}} msg] |
| lappend rc $msg |
| } {0 41} |
| do_test tcl-3.6 { |
| set b 500 |
| set rc [catch {db one {SELECT * FROM t1 WHERE b>$b}} msg] |
| lappend rc $msg |
| } {0 {}} |
| do_test tcl-3.7 { |
| set b 500 |
| set rc [catch {db one { |
| INSERT INTO t1 VALUES(99,510); |
| SELECT * FROM t1 WHERE b>$b |
| }} msg] |
| lappend rc $msg |
| } {0 99} |
| } |
| ifcapable {!tclvar} { |
| execsql {INSERT INTO t1 VALUES(99,510)} |
| } |
| |
| # Turn the busy handler on and off |
| # |
| do_test tcl-4.1 { |
| proc busy_callback {cnt} { |
| break |
| } |
| db busy busy_callback |
| db busy |
| } {busy_callback} |
| do_test tcl-4.2 { |
| db busy {} |
| db busy |
| } {} |
| |
| ifcapable {tclvar} { |
| # Parsing of TCL variable names within SQL into bound parameters. |
| # |
| do_test tcl-5.1 { |
| execsql {CREATE TABLE t3(a,b,c)} |
| catch {unset x} |
| set x(1) A |
| set x(2) B |
| execsql { |
| INSERT INTO t3 VALUES($::x(1),$::x(2),$::x(3)); |
| SELECT * FROM t3 |
| } |
| } {A B {}} |
| do_test tcl-5.2 { |
| execsql { |
| SELECT typeof(a), typeof(b), typeof(c) FROM t3 |
| } |
| } {text text null} |
| do_test tcl-5.3 { |
| catch {unset x} |
| set x [binary format h12 686900686f00] |
| execsql { |
| UPDATE t3 SET a=$::x; |
| } |
| db eval { |
| SELECT a FROM t3 |
| } break |
| binary scan $a h12 adata |
| set adata |
| } {686900686f00} |
| do_test tcl-5.4 { |
| execsql { |
| SELECT typeof(a), typeof(b), typeof(c) FROM t3 |
| } |
| } {blob text null} |
| } |
| |
| # Operation of "break" and "continue" within row scripts |
| # |
| do_test tcl-6.1 { |
| db eval {SELECT * FROM t1} { |
| break |
| } |
| lappend a $b |
| } {10 20} |
| do_test tcl-6.2 { |
| set cnt 0 |
| db eval {SELECT * FROM t1} { |
| if {$a>40} continue |
| incr cnt |
| } |
| set cnt |
| } {4} |
| do_test tcl-6.3 { |
| set cnt 0 |
| db eval {SELECT * FROM t1} { |
| if {$a<40} continue |
| incr cnt |
| } |
| set cnt |
| } {5} |
| do_test tcl-6.4 { |
| proc return_test {x} { |
| db eval {SELECT * FROM t1} { |
| if {$a==$x} {return $b} |
| } |
| } |
| return_test 10 |
| } 20 |
| do_test tcl-6.5 { |
| return_test 20 |
| } 40 |
| do_test tcl-6.6 { |
| return_test 99 |
| } 510 |
| do_test tcl-6.7 { |
| return_test 0 |
| } {} |
| |
| do_test tcl-7.1 { |
| db version |
| expr 0 |
| } {0} |
| |
| # modify and reset the NULL representation |
| # |
| do_test tcl-8.1 { |
| db nullvalue NaN |
| execsql {INSERT INTO t1 VALUES(30,NULL)} |
| db eval {SELECT * FROM t1 WHERE b IS NULL} |
| } {30 NaN} |
| do_test tcl-8.2 { |
| db nullvalue NULL |
| db nullvalue |
| } {NULL} |
| do_test tcl-8.3 { |
| db nullvalue {} |
| db eval {SELECT * FROM t1 WHERE b IS NULL} |
| } {30 {}} |
| |
| # Test the return type of user-defined functions |
| # |
| do_test tcl-9.1 { |
| db function ret_str {return "hi"} |
| execsql {SELECT typeof(ret_str())} |
| } {text} |
| do_test tcl-9.2 { |
| db function ret_dbl {return [expr {rand()*0.5}]} |
| execsql {SELECT typeof(ret_dbl())} |
| } {real} |
| do_test tcl-9.3 { |
| db function ret_int {return [expr {int(rand()*200)}]} |
| execsql {SELECT typeof(ret_int())} |
| } {integer} |
| |
| # Recursive calls to the same user-defined function |
| # |
| ifcapable tclvar { |
| do_test tcl-9.10 { |
| proc userfunc_r1 {n} { |
| if {$n<=0} {return 0} |
| set nm1 [expr {$n-1}] |
| return [expr {[db eval {SELECT r1($nm1)}]+$n}] |
| } |
| db function r1 userfunc_r1 |
| execsql {SELECT r1(10)} |
| } {55} |
| do_test tcl-9.11 { |
| execsql {SELECT r1(100)} |
| } {5050} |
| } |
| |
| # Tests for the new transaction method |
| # |
| do_test tcl-10.1 { |
| db transaction {} |
| } {} |
| do_test tcl-10.2 { |
| db transaction deferred {} |
| } {} |
| do_test tcl-10.3 { |
| db transaction immediate {} |
| } {} |
| do_test tcl-10.4 { |
| db transaction exclusive {} |
| } {} |
| do_test tcl-10.5 { |
| set rc [catch {db transaction xyzzy {}} msg] |
| lappend rc $msg |
| } {1 {bad transaction type "xyzzy": must be deferred, exclusive, or immediate}} |
| do_test tcl-10.6 { |
| set rc [catch {db transaction {error test-error}} msg] |
| lappend rc $msg |
| } {1 test-error} |
| do_test tcl-10.7 { |
| db transaction { |
| db eval {CREATE TABLE t4(x)} |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(1)} |
| } |
| } |
| db eval {SELECT * FROM t4} |
| } 1 |
| do_test tcl-10.8 { |
| catch { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(2)} |
| db eval {INSERT INTO t4 VALUES(3)} |
| db eval {INSERT INTO t4 VALUES(4)} |
| error test-error |
| } |
| } |
| db eval {SELECT * FROM t4} |
| } 1 |
| do_test tcl-10.9 { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(2)} |
| catch { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(3)} |
| db eval {INSERT INTO t4 VALUES(4)} |
| error test-error |
| } |
| } |
| } |
| db eval {SELECT * FROM t4} |
| } {1 2} |
| do_test tcl-10.10 { |
| for {set i 0} {$i<1} {incr i} { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(5)} |
| continue |
| } |
| error "This line should not be run" |
| } |
| db eval {SELECT * FROM t4} |
| } {1 2 5} |
| do_test tcl-10.11 { |
| for {set i 0} {$i<10} {incr i} { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(6)} |
| break |
| } |
| } |
| db eval {SELECT * FROM t4} |
| } {1 2 5 6} |
| do_test tcl-10.12 { |
| set rc [catch { |
| for {set i 0} {$i<10} {incr i} { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES(7)} |
| return |
| } |
| } |
| }] |
| } {2} |
| do_test tcl-10.13 { |
| db eval {SELECT * FROM t4} |
| } {1 2 5 6 7} |
| |
| # Now test that [db transaction] commands may be nested with |
| # the expected results. |
| # |
| do_test tcl-10.14 { |
| db transaction { |
| db eval { |
| DELETE FROM t4; |
| INSERT INTO t4 VALUES('one'); |
| } |
| |
| catch { |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('two') } |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('three') } |
| error "throw an error!" |
| } |
| } |
| } |
| } |
| |
| db eval {SELECT * FROM t4} |
| } {one} |
| do_test tcl-10.15 { |
| # Make sure a transaction has not been left open. |
| db eval {BEGIN ; COMMIT} |
| } {} |
| do_test tcl-10.16 { |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('two'); } |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('three') } |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('four') } |
| } |
| } |
| } |
| db eval {SELECT * FROM t4} |
| } {one two three four} |
| do_test tcl-10.17 { |
| catch { |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('A'); } |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('B') } |
| db transaction { |
| db eval { INSERT INTO t4 VALUES('C') } |
| error "throw an error!" |
| } |
| } |
| } |
| } |
| db eval {SELECT * FROM t4} |
| } {one two three four} |
| do_test tcl-10.18 { |
| # Make sure a transaction has not been left open. |
| db eval {BEGIN ; COMMIT} |
| } {} |
| |
| # Mess up a [db transaction] command by locking the database using a |
| # second connection when it tries to commit. Make sure the transaction |
| # is not still open after the "database is locked" exception is thrown. |
| # |
| do_test tcl-10.18 { |
| sqlite3 db2 test.db |
| db2 eval { |
| BEGIN; |
| SELECT * FROM sqlite_master; |
| } |
| |
| set rc [catch { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES('five')} |
| } |
| } msg] |
| list $rc $msg |
| } {1 {database is locked}} |
| do_test tcl-10.19 { |
| db eval {BEGIN ; COMMIT} |
| } {} |
| |
| # Thwart a [db transaction] command by locking the database using a |
| # second connection with "BEGIN EXCLUSIVE". Make sure no transaction is |
| # open after the "database is locked" exception is thrown. |
| # |
| do_test tcl-10.20 { |
| db2 eval { |
| COMMIT; |
| BEGIN EXCLUSIVE; |
| } |
| set rc [catch { |
| db transaction { |
| db eval {INSERT INTO t4 VALUES('five')} |
| } |
| } msg] |
| list $rc $msg |
| } {1 {database is locked}} |
| do_test tcl-10.21 { |
| db2 close |
| db eval {BEGIN ; COMMIT} |
| } {} |
| do_test tcl-10.22 { |
| sqlite3 db2 test.db |
| db transaction exclusive { |
| catch { db2 eval {SELECT * FROM sqlite_master} } msg |
| set msg "db2: $msg" |
| } |
| set msg |
| } {db2: database is locked} |
| db2 close |
| |
| do_test tcl-11.1 { |
| db eval {INSERT INTO t4 VALUES(6)} |
| db exists {SELECT x,x*2,x+x FROM t4 WHERE x==6} |
| } {1} |
| do_test tcl-11.2 { |
| db exists {SELECT 0 FROM t4 WHERE x==6} |
| } {1} |
| do_test tcl-11.3 { |
| db exists {SELECT 1 FROM t4 WHERE x==8} |
| } {0} |
| do_test tcl-11.3.1 { |
| tcl_objproc db exists {SELECT 1 FROM t4 WHERE x==8} |
| } {0} |
| |
| do_test tcl-12.1 { |
| unset -nocomplain a b c version |
| set version [db version] |
| scan $version "%d.%d.%d" a b c |
| expr $a*1000000 + $b*1000 + $c |
| } [sqlite3_libversion_number] |
| |
| |
| # Check to see that when bindings of the form @aaa are used instead |
| # of $aaa, that objects are treated as bytearray and are inserted |
| # as BLOBs. |
| # |
| ifcapable tclvar { |
| do_test tcl-13.1 { |
| db eval {CREATE TABLE t5(x BLOB)} |
| set x abc123 |
| db eval {INSERT INTO t5 VALUES($x)} |
| db eval {SELECT typeof(x) FROM t5} |
| } {text} |
| do_test tcl-13.2 { |
| binary scan $x H notUsed |
| db eval { |
| DELETE FROM t5; |
| INSERT INTO t5 VALUES($x); |
| SELECT typeof(x) FROM t5; |
| } |
| } {text} |
| do_test tcl-13.3 { |
| db eval { |
| DELETE FROM t5; |
| INSERT INTO t5 VALUES(@x); |
| SELECT typeof(x) FROM t5; |
| } |
| } {blob} |
| do_test tcl-13.4 { |
| set y 1234 |
| db eval { |
| DELETE FROM t5; |
| INSERT INTO t5 VALUES(@y); |
| SELECT hex(x), typeof(x) FROM t5 |
| } |
| } {31323334 blob} |
| } |
| |
| |
| finish_test |