gitlab.com/CoiaPrant/sqlite3@v1.19.1/testdata/tcl/tclsqlite.test (about) 1 # 2001 September 15 2 # 3 # The author disclaims copyright to this source code. In place of 4 # a legal notice, here is a blessing: 5 # 6 # May you do good and not evil. 7 # May you find forgiveness for yourself and forgive others. 8 # May you share freely, never taking more than you give. 9 # 10 #*********************************************************************** 11 # This file implements regression tests for TCL interface to the 12 # SQLite library. 13 # 14 # Actually, all tests are based on the TCL interface, so the main 15 # interface is pretty well tested. This file contains some addition 16 # tests for fringe issues that the main test suite does not cover. 17 # 18 # $Id: tclsqlite.test,v 1.73 2009/03/16 13:19:36 danielk1977 Exp $ 19 20 catch {sqlite3} 21 22 set testdir [file dirname $argv0] 23 source $testdir/tester.tcl 24 set testprefix tcl 25 26 # Check the error messages generated by tclsqlite 27 # 28 set r "sqlite_orig HANDLE ?FILENAME? ?-vfs VFSNAME? ?-readonly BOOLEAN? ?-create BOOLEAN? ?-nofollow BOOLEAN? ?-nomutex BOOLEAN? ?-fullmutex BOOLEAN? ?-uri BOOLEAN?" 29 if {[sqlite3 -has-codec]} { 30 append r " ?-key CODECKEY?" 31 } 32 do_test tcl-1.1 { 33 set v [catch {sqlite3 -bogus} msg] 34 regsub {really_sqlite3} $msg {sqlite3} msg 35 lappend v $msg 36 } [list 1 "wrong # args: should be \"$r\""] 37 do_test tcl-1.1.1 { 38 set v [catch {sqlite3} msg] 39 regsub {really_sqlite3} $msg {sqlite3} msg 40 lappend v $msg 41 } [list 1 "wrong # args: should be \"$r\""] 42 do_test tcl-1.2 { 43 set v [catch {db bogus} msg] 44 lappend v $msg 45 } {1 {bad option "bogus": must be authorizer, backup, bind_fallback, busy, cache, changes, close, collate, collation_needed, commit_hook, complete, config, copy, deserialize, enable_load_extension, errorcode, erroroffset, eval, exists, function, incrblob, interrupt, last_insert_rowid, nullvalue, onecolumn, preupdate, profile, progress, rekey, restore, rollback_hook, serialize, status, timeout, total_changes, trace, trace_v2, transaction, unlock_notify, update_hook, version, or wal_hook}} 46 do_test tcl-1.2.1 { 47 set v [catch {db cache bogus} msg] 48 lappend v $msg 49 } {1 {bad option "bogus": must be flush or size}} 50 do_test tcl-1.2.2 { 51 set v [catch {db cache} msg] 52 lappend v $msg 53 } {1 {wrong # args: should be "db cache option ?arg?"}} 54 do_test tcl-1.3 { 55 execsql {CREATE TABLE t1(a int, b int)} 56 execsql {INSERT INTO t1 VALUES(10,20)} 57 set v [catch { 58 db eval {SELECT * FROM t1} data { 59 error "The error message" 60 } 61 } msg] 62 lappend v $msg 63 } {1 {The error message}} 64 do_test tcl-1.4 { 65 set v [catch { 66 db eval {SELECT * FROM t2} data { 67 error "The error message" 68 } 69 } msg] 70 lappend v $msg 71 } {1 {no such table: t2}} 72 do_test tcl-1.5 { 73 set v [catch { 74 db eval {SELECT * FROM t1} data { 75 break 76 } 77 } msg] 78 lappend v $msg 79 } {0 {}} 80 catch {expr x*} msg 81 do_test tcl-1.6 { 82 set v [catch { 83 db eval {SELECT * FROM t1} data { 84 expr x* 85 } 86 } msg] 87 lappend v $msg 88 } [list 1 $msg] 89 do_test tcl-1.7 { 90 set v [catch {db} msg] 91 lappend v $msg 92 } {1 {wrong # args: should be "db SUBCOMMAND ..."}} 93 if {[catch {db auth {}}]==0} { 94 do_test tcl-1.8 { 95 set v [catch {db authorizer 1 2 3} msg] 96 lappend v $msg 97 } {1 {wrong # args: should be "db authorizer ?CALLBACK?"}} 98 } 99 do_test tcl-1.9 { 100 set v [catch {db busy 1 2 3} msg] 101 lappend v $msg 102 } {1 {wrong # args: should be "db busy CALLBACK"}} 103 do_test tcl-1.10 { 104 set v [catch {db progress 1} msg] 105 lappend v $msg 106 } {1 {wrong # args: should be "db progress N CALLBACK"}} 107 do_test tcl-1.11 { 108 set v [catch {db changes xyz} msg] 109 lappend v $msg 110 } {1 {wrong # args: should be "db changes "}} 111 do_test tcl-1.12 { 112 set v [catch {db commit_hook a b c} msg] 113 lappend v $msg 114 } {1 {wrong # args: should be "db commit_hook ?CALLBACK?"}} 115 ifcapable {complete} { 116 do_test tcl-1.13 { 117 set v [catch {db complete} msg] 118 lappend v $msg 119 } {1 {wrong # args: should be "db complete SQL"}} 120 } 121 do_test tcl-1.14 { 122 set v [catch {db eval} msg] 123 lappend v $msg 124 } {1 {wrong # args: should be "db eval ?OPTIONS? SQL ?ARRAY-NAME? ?SCRIPT?"}} 125 do_test tcl-1.15 { 126 set v [catch {db function} msg] 127 lappend v $msg 128 } {1 {wrong # args: should be "db function NAME ?SWITCHES? SCRIPT"}} 129 do_test tcl-1.16 { 130 set v [catch {db last_insert_rowid xyz} msg] 131 lappend v $msg 132 } {1 {wrong # args: should be "db last_insert_rowid "}} 133 do_test tcl-1.17 { 134 set v [catch {db rekey} msg] 135 lappend v $msg 136 } {1 {wrong # args: should be "db rekey KEY"}} 137 do_test tcl-1.18 { 138 set v [catch {db timeout} msg] 139 lappend v $msg 140 } {1 {wrong # args: should be "db timeout MILLISECONDS"}} 141 do_test tcl-1.19 { 142 set v [catch {db collate} msg] 143 lappend v $msg 144 } {1 {wrong # args: should be "db collate NAME SCRIPT"}} 145 do_test tcl-1.20 { 146 set v [catch {db collation_needed} msg] 147 lappend v $msg 148 } {1 {wrong # args: should be "db collation_needed SCRIPT"}} 149 do_test tcl-1.21 { 150 set v [catch {db total_changes xyz} msg] 151 lappend v $msg 152 } {1 {wrong # args: should be "db total_changes "}} 153 do_test tcl-1.22 { 154 set v [catch {db copy} msg] 155 lappend v $msg 156 } {1 {wrong # args: should be "db copy CONFLICT-ALGORITHM TABLE FILENAME ?SEPARATOR? ?NULLINDICATOR?"}} 157 do_test tcl-1.23 { 158 set v [catch {sqlite3 db2 test.db -vfs nosuchvfs} msg] 159 lappend v $msg 160 } {1 {no such vfs: nosuchvfs}} 161 162 catch {unset ::result} 163 do_test tcl-2.1 { 164 execsql "CREATE TABLE t\u0123x(a int, b\u1235 float)" 165 } {} 166 ifcapable schema_pragmas { 167 do_test tcl-2.2 { 168 execsql "PRAGMA table_info(t\u0123x)" 169 } "0 a INT 0 {} 0 1 b\u1235 float 0 {} 0" 170 } 171 do_test tcl-2.3 { 172 execsql "INSERT INTO t\u0123x VALUES(1,2.3)" 173 db eval "SELECT * FROM t\u0123x" result break 174 set result(*) 175 } "a b\u1235" 176 177 178 # Test the onecolumn method 179 # 180 do_test tcl-3.1 { 181 execsql { 182 INSERT INTO t1 SELECT a*2, b*2 FROM t1; 183 INSERT INTO t1 SELECT a*2+1, b*2+1 FROM t1; 184 INSERT INTO t1 SELECT a*2+3, b*2+3 FROM t1; 185 } 186 set rc [catch {db onecolumn {SELECT * FROM t1 ORDER BY a}} msg] 187 lappend rc $msg 188 } {0 10} 189 do_test tcl-3.2 { 190 db onecolumn {SELECT * FROM t1 WHERE a<0} 191 } {} 192 do_test tcl-3.3 { 193 set rc [catch {db onecolumn} errmsg] 194 lappend rc $errmsg 195 } {1 {wrong # args: should be "db onecolumn SQL"}} 196 do_test tcl-3.4 { 197 set rc [catch {db onecolumn {SELECT bogus}} errmsg] 198 lappend rc $errmsg 199 } {1 {no such column: bogus}} 200 ifcapable {tclvar} { 201 do_test tcl-3.5 { 202 set b 50 203 set rc [catch {db one {SELECT * FROM t1 WHERE b>$b}} msg] 204 lappend rc $msg 205 } {0 41} 206 do_test tcl-3.6 { 207 set b 500 208 set rc [catch {db one {SELECT * FROM t1 WHERE b>$b}} msg] 209 lappend rc $msg 210 } {0 {}} 211 do_test tcl-3.7 { 212 set b 500 213 set rc [catch {db one { 214 INSERT INTO t1 VALUES(99,510); 215 SELECT * FROM t1 WHERE b>$b 216 }} msg] 217 lappend rc $msg 218 } {0 99} 219 } 220 ifcapable {!tclvar} { 221 execsql {INSERT INTO t1 VALUES(99,510)} 222 } 223 224 # Turn the busy handler on and off 225 # 226 do_test tcl-4.1 { 227 proc busy_callback {cnt} { 228 break 229 } 230 db busy busy_callback 231 db busy 232 } {busy_callback} 233 do_test tcl-4.2 { 234 db busy {} 235 db busy 236 } {} 237 238 ifcapable {tclvar} { 239 # Parsing of TCL variable names within SQL into bound parameters. 240 # 241 do_test tcl-5.1 { 242 execsql {CREATE TABLE t3(a,b,c)} 243 catch {unset x} 244 set x(1) A 245 set x(2) B 246 execsql { 247 INSERT INTO t3 VALUES($::x(1),$::x(2),$::x(3)); 248 SELECT * FROM t3 249 } 250 } {A B {}} 251 do_test tcl-5.2 { 252 execsql { 253 SELECT typeof(a), typeof(b), typeof(c) FROM t3 254 } 255 } {text text null} 256 do_test tcl-5.3 { 257 catch {unset x} 258 set x [binary format h12 686900686f00] 259 execsql { 260 UPDATE t3 SET a=$::x; 261 } 262 db eval { 263 SELECT a FROM t3 264 } break 265 binary scan $a h12 adata 266 set adata 267 } {686900686f00} 268 do_test tcl-5.4 { 269 execsql { 270 SELECT typeof(a), typeof(b), typeof(c) FROM t3 271 } 272 } {blob text null} 273 } 274 275 # Operation of "break" and "continue" within row scripts 276 # 277 do_test tcl-6.1 { 278 db eval {SELECT * FROM t1} { 279 break 280 } 281 lappend a $b 282 } {10 20} 283 do_test tcl-6.2 { 284 set cnt 0 285 db eval {SELECT * FROM t1} { 286 if {$a>40} continue 287 incr cnt 288 } 289 set cnt 290 } {4} 291 do_test tcl-6.3 { 292 set cnt 0 293 db eval {SELECT * FROM t1} { 294 if {$a<40} continue 295 incr cnt 296 } 297 set cnt 298 } {5} 299 do_test tcl-6.4 { 300 proc return_test {x} { 301 db eval {SELECT * FROM t1} { 302 if {$a==$x} {return $b} 303 } 304 } 305 return_test 10 306 } 20 307 do_test tcl-6.5 { 308 return_test 20 309 } 40 310 do_test tcl-6.6 { 311 return_test 99 312 } 510 313 do_test tcl-6.7 { 314 return_test 0 315 } {} 316 317 do_test tcl-7.1 { 318 db version 319 expr 0 320 } {0} 321 322 # modify and reset the NULL representation 323 # 324 do_test tcl-8.1 { 325 db nullvalue NaN 326 execsql {INSERT INTO t1 VALUES(30,NULL)} 327 db eval {SELECT * FROM t1 WHERE b IS NULL} 328 } {30 NaN} 329 proc concatFunc args {return [join $args {}]} 330 do_test tcl-8.2 { 331 db function concat concatFunc 332 db eval {SELECT concat('a', b, 'z') FROM t1 WHERE b is NULL} 333 } {aNaNz} 334 do_test tcl-8.3 { 335 db nullvalue NULL 336 db nullvalue 337 } {NULL} 338 do_test tcl-8.4 { 339 db nullvalue {} 340 db eval {SELECT * FROM t1 WHERE b IS NULL} 341 } {30 {}} 342 do_test tcl-8.5 { 343 db function concat concatFunc 344 db eval {SELECT concat('a', b, 'z') FROM t1 WHERE b is NULL} 345 } {az} 346 347 # Test the return type of user-defined functions 348 # 349 do_test tcl-9.1 { 350 db function ret_str {return "hi"} 351 execsql {SELECT typeof(ret_str())} 352 } {text} 353 do_test tcl-9.2 { 354 db function ret_dbl {return [expr {rand()*0.5}]} 355 execsql {SELECT typeof(ret_dbl())} 356 } {real} 357 do_test tcl-9.3 { 358 db function ret_int {return [expr {int(rand()*200)}]} 359 execsql {SELECT typeof(ret_int())} 360 } {integer} 361 362 # Recursive calls to the same user-defined function 363 # 364 ifcapable tclvar { 365 do_test tcl-9.10 { 366 proc userfunc_r1 {n} { 367 if {$n<=0} {return 0} 368 set nm1 [expr {$n-1}] 369 return [expr {[db eval {SELECT r1($nm1)}]+$n}] 370 } 371 db function r1 userfunc_r1 372 execsql {SELECT r1(10)} 373 } {55} 374 # Fails under -fsanitize=address,undefined due to stack overflow 375 # do_test tcl-9.11 { 376 # execsql {SELECT r1(100)} 377 # } {5050} 378 } 379 380 # Tests for the new transaction method 381 # 382 do_test tcl-10.1 { 383 db transaction {} 384 } {} 385 do_test tcl-10.2 { 386 db transaction deferred {} 387 } {} 388 do_test tcl-10.3 { 389 db transaction immediate {} 390 } {} 391 do_test tcl-10.4 { 392 db transaction exclusive {} 393 } {} 394 do_test tcl-10.5 { 395 set rc [catch {db transaction xyzzy {}} msg] 396 lappend rc $msg 397 } {1 {bad transaction type "xyzzy": must be deferred, exclusive, or immediate}} 398 do_test tcl-10.6 { 399 set rc [catch {db transaction {error test-error}} msg] 400 lappend rc $msg 401 } {1 test-error} 402 do_test tcl-10.7 { 403 db transaction { 404 db eval {CREATE TABLE t4(x)} 405 db transaction { 406 db eval {INSERT INTO t4 VALUES(1)} 407 } 408 } 409 db eval {SELECT * FROM t4} 410 } 1 411 do_test tcl-10.8 { 412 catch { 413 db transaction { 414 db eval {INSERT INTO t4 VALUES(2)} 415 db eval {INSERT INTO t4 VALUES(3)} 416 db eval {INSERT INTO t4 VALUES(4)} 417 error test-error 418 } 419 } 420 db eval {SELECT * FROM t4} 421 } 1 422 do_test tcl-10.9 { 423 db transaction { 424 db eval {INSERT INTO t4 VALUES(2)} 425 catch { 426 db transaction { 427 db eval {INSERT INTO t4 VALUES(3)} 428 db eval {INSERT INTO t4 VALUES(4)} 429 error test-error 430 } 431 } 432 } 433 db eval {SELECT * FROM t4} 434 } {1 2} 435 do_test tcl-10.10 { 436 for {set i 0} {$i<1} {incr i} { 437 db transaction { 438 db eval {INSERT INTO t4 VALUES(5)} 439 continue 440 } 441 error "This line should not be run" 442 } 443 db eval {SELECT * FROM t4} 444 } {1 2 5} 445 do_test tcl-10.11 { 446 for {set i 0} {$i<10} {incr i} { 447 db transaction { 448 db eval {INSERT INTO t4 VALUES(6)} 449 break 450 } 451 } 452 db eval {SELECT * FROM t4} 453 } {1 2 5 6} 454 do_test tcl-10.12 { 455 set rc [catch { 456 for {set i 0} {$i<10} {incr i} { 457 db transaction { 458 db eval {INSERT INTO t4 VALUES(7)} 459 return 460 } 461 } 462 }] 463 } {2} 464 do_test tcl-10.13 { 465 db eval {SELECT * FROM t4} 466 } {1 2 5 6 7} 467 468 # Now test that [db transaction] commands may be nested with 469 # the expected results. 470 # 471 do_test tcl-10.14 { 472 db transaction { 473 db eval { 474 DELETE FROM t4; 475 INSERT INTO t4 VALUES('one'); 476 } 477 478 catch { 479 db transaction { 480 db eval { INSERT INTO t4 VALUES('two') } 481 db transaction { 482 db eval { INSERT INTO t4 VALUES('three') } 483 error "throw an error!" 484 } 485 } 486 } 487 } 488 489 db eval {SELECT * FROM t4} 490 } {one} 491 do_test tcl-10.15 { 492 # Make sure a transaction has not been left open. 493 db eval {BEGIN ; COMMIT} 494 } {} 495 do_test tcl-10.16 { 496 db transaction { 497 db eval { INSERT INTO t4 VALUES('two'); } 498 db transaction { 499 db eval { INSERT INTO t4 VALUES('three') } 500 db transaction { 501 db eval { INSERT INTO t4 VALUES('four') } 502 } 503 } 504 } 505 db eval {SELECT * FROM t4} 506 } {one two three four} 507 do_test tcl-10.17 { 508 catch { 509 db transaction { 510 db eval { INSERT INTO t4 VALUES('A'); } 511 db transaction { 512 db eval { INSERT INTO t4 VALUES('B') } 513 db transaction { 514 db eval { INSERT INTO t4 VALUES('C') } 515 error "throw an error!" 516 } 517 } 518 } 519 } 520 db eval {SELECT * FROM t4} 521 } {one two three four} 522 do_test tcl-10.18 { 523 # Make sure a transaction has not been left open. 524 db eval {BEGIN ; COMMIT} 525 } {} 526 527 # Mess up a [db transaction] command by locking the database using a 528 # second connection when it tries to commit. Make sure the transaction 529 # is not still open after the "database is locked" exception is thrown. 530 # 531 do_test tcl-10.18 { 532 sqlite3 db2 test.db 533 db2 eval { 534 BEGIN; 535 SELECT * FROM sqlite_master; 536 } 537 538 set rc [catch { 539 db transaction { 540 db eval {INSERT INTO t4 VALUES('five')} 541 } 542 } msg] 543 list $rc $msg 544 } {1 {database is locked}} 545 do_test tcl-10.19 { 546 db eval {BEGIN ; COMMIT} 547 } {} 548 549 # Thwart a [db transaction] command by locking the database using a 550 # second connection with "BEGIN EXCLUSIVE". Make sure no transaction is 551 # open after the "database is locked" exception is thrown. 552 # 553 do_test tcl-10.20 { 554 db2 eval { 555 COMMIT; 556 BEGIN EXCLUSIVE; 557 } 558 set rc [catch { 559 db transaction { 560 db eval {INSERT INTO t4 VALUES('five')} 561 } 562 } msg] 563 list $rc $msg 564 } {1 {database is locked}} 565 do_test tcl-10.21 { 566 db2 close 567 db eval {BEGIN ; COMMIT} 568 } {} 569 do_test tcl-10.22 { 570 sqlite3 db2 test.db 571 db transaction exclusive { 572 catch { db2 eval {SELECT * FROM sqlite_master} } msg 573 set msg "db2: $msg" 574 } 575 set msg 576 } {db2: database is locked} 577 db2 close 578 579 do_test tcl-11.1 { 580 db eval {INSERT INTO t4 VALUES(6)} 581 db exists {SELECT x,x*2,x+x FROM t4 WHERE x==6} 582 } {1} 583 do_test tcl-11.2 { 584 db exists {SELECT 0 FROM t4 WHERE x==6} 585 } {1} 586 do_test tcl-11.3 { 587 db exists {SELECT 1 FROM t4 WHERE x==8} 588 } {0} 589 do_test tcl-11.3.1 { 590 tcl_objproc db exists {SELECT 1 FROM t4 WHERE x==8} 591 } {0} 592 593 do_test tcl-12.1 { 594 unset -nocomplain a b c version 595 set version [db version] 596 scan $version "%d.%d.%d" a b c 597 expr $a*1000000 + $b*1000 + $c 598 } [sqlite3_libversion_number] 599 600 601 # Check to see that when bindings of the form @aaa are used instead 602 # of $aaa, that objects are treated as bytearray and are inserted 603 # as BLOBs. 604 # 605 ifcapable tclvar { 606 do_test tcl-13.1 { 607 db eval {CREATE TABLE t5(x BLOB)} 608 set x abc123 609 db eval {INSERT INTO t5 VALUES($x)} 610 db eval {SELECT typeof(x) FROM t5} 611 } {text} 612 do_test tcl-13.2 { 613 binary scan $x H notUsed 614 db eval { 615 DELETE FROM t5; 616 INSERT INTO t5 VALUES($x); 617 SELECT typeof(x) FROM t5; 618 } 619 } {text} 620 do_test tcl-13.3 { 621 db eval { 622 DELETE FROM t5; 623 INSERT INTO t5 VALUES(@x); 624 SELECT typeof(x) FROM t5; 625 } 626 } {blob} 627 do_test tcl-13.4 { 628 set y 1234 629 db eval { 630 DELETE FROM t5; 631 INSERT INTO t5 VALUES(@y); 632 SELECT hex(x), typeof(x) FROM t5 633 } 634 } {31323334 blob} 635 } 636 637 db func xCall xCall 638 proc xCall {} { return "value" } 639 do_execsql_test tcl-14.1 { 640 CREATE TABLE t6(x); 641 INSERT INTO t6 VALUES(1); 642 } 643 do_test tcl-14.2 { 644 db one {SELECT x FROM t6 WHERE xCall()!='value'} 645 } {} 646 647 # Verify that the "exists" and "onecolumn" methods work when 648 # a "profile" is registered. 649 # 650 catch {db close} 651 sqlite3 db :memory: 652 proc noop-profile {args} { 653 return 654 } 655 do_test tcl-15.0 { 656 db eval {CREATE TABLE t1(a); INSERT INTO t1 VALUES(1),(2),(3);} 657 db onecolumn {SELECT a FROM t1 WHERE a>2} 658 } {3} 659 do_test tcl-15.1 { 660 db exists {SELECT a FROM t1 WHERE a>2} 661 } {1} 662 do_test tcl-15.2 { 663 db exists {SELECT a FROM t1 WHERE a>3} 664 } {0} 665 db profile noop-profile 666 do_test tcl-15.3 { 667 db onecolumn {SELECT a FROM t1 WHERE a>2} 668 } {3} 669 do_test tcl-15.4 { 670 db exists {SELECT a FROM t1 WHERE a>2} 671 } {1} 672 do_test tcl-15.5 { 673 db exists {SELECT a FROM t1 WHERE a>3} 674 } {0} 675 676 677 # 2017-06-26: The --withoutnulls flag to "db eval". 678 # 679 # In the "db eval --withoutnulls SQL ARRAY" form, NULL results cause the 680 # corresponding array entry to be unset. The default behavior (without 681 # the -withoutnulls flags) is for the corresponding array value to get 682 # the [db nullvalue] string. 683 # 684 catch {db close} 685 forcedelete test.db 686 sqlite3 db test.db 687 do_execsql_test tcl-16.100 { 688 CREATE TABLE t1(a,b); 689 INSERT INTO t1 VALUES(1,2),(2,NULL),(3,'xyz'); 690 } 691 do_test tcl-16.101 { 692 set res {} 693 unset -nocomplain x 694 db eval {SELECT * FROM t1} x { 695 lappend res $x(a) [array names x] 696 } 697 set res 698 } {1 {a b *} 2 {a b *} 3 {a b *}} 699 do_test tcl-16.102 { 700 set res [catch { 701 db eval -unknown {SELECT * FROM t1} x { 702 lappend res $x(a) [array names x] 703 } 704 } rc] 705 lappend res $rc 706 } {1 {unknown option: "-unknown"}} 707 do_test tcl-16.103 { 708 set res {} 709 unset -nocomplain x 710 db eval -withoutnulls {SELECT * FROM t1} x { 711 lappend res $x(a) [array names x] 712 } 713 set res 714 } {1 {a b *} 2 {a *} 3 {a b *}} 715 716 #------------------------------------------------------------------------- 717 # Test the -type option to [db function]. 718 # 719 reset_db 720 proc add {a b} { return [expr $a + $b] } 721 proc ret {a} { return $a } 722 723 db function add_i -returntype integer add 724 db function add_r -ret real add 725 db function add_t -return text add 726 db function add_b -returntype blob add 727 db function add_a -returntype any add 728 729 db function ret_i -returntype int ret 730 db function ret_r -returntype real ret 731 db function ret_t -returntype text ret 732 db function ret_b -returntype blob ret 733 db function ret_a -r any ret 734 735 do_execsql_test 17.0 { 736 SELECT quote( add_i(2, 3) ); 737 SELECT quote( add_r(2, 3) ); 738 SELECT quote( add_t(2, 3) ); 739 SELECT quote( add_b(2, 3) ); 740 SELECT quote( add_a(2, 3) ); 741 } {5 5.0 '5' X'35' 5} 742 743 do_execsql_test 17.1 { 744 SELECT quote( add_i(2.2, 3.3) ); 745 SELECT quote( add_r(2.2, 3.3) ); 746 SELECT quote( add_t(2.2, 3.3) ); 747 SELECT quote( add_b(2.2, 3.3) ); 748 SELECT quote( add_a(2.2, 3.3) ); 749 } {5.5 5.5 '5.5' X'352E35' 5.5} 750 751 do_execsql_test 17.2 { 752 SELECT quote( ret_i(2.5) ); 753 SELECT quote( ret_r(2.5) ); 754 SELECT quote( ret_t(2.5) ); 755 SELECT quote( ret_b(2.5) ); 756 SELECT quote( ret_a(2.5) ); 757 } {2.5 2.5 '2.5' X'322E35' 2.5} 758 759 do_execsql_test 17.3 { 760 SELECT quote( ret_i('2.5') ); 761 SELECT quote( ret_r('2.5') ); 762 SELECT quote( ret_t('2.5') ); 763 SELECT quote( ret_b('2.5') ); 764 SELECT quote( ret_a('2.5') ); 765 } {2.5 2.5 '2.5' X'322E35' '2.5'} 766 767 do_execsql_test 17.4 { 768 SELECT quote( ret_i('abc') ); 769 SELECT quote( ret_r('abc') ); 770 SELECT quote( ret_t('abc') ); 771 SELECT quote( ret_b('abc') ); 772 SELECT quote( ret_a('abc') ); 773 } {'abc' 'abc' 'abc' X'616263' 'abc'} 774 775 do_execsql_test 17.5 { 776 SELECT quote( ret_i(X'616263') ); 777 SELECT quote( ret_r(X'616263') ); 778 SELECT quote( ret_t(X'616263') ); 779 SELECT quote( ret_b(X'616263') ); 780 SELECT quote( ret_a(X'616263') ); 781 } {'abc' 'abc' 'abc' X'616263' X'616263'} 782 783 do_test 17.6.1 { 784 list [catch { db function xyz -return object ret } msg] $msg 785 } {1 {bad type "object": must be integer, real, text, blob, or any}} 786 787 do_test 17.6.2 { 788 list [catch { db function xyz -return ret } msg] $msg 789 } {1 {option requires an argument: -return}} 790 791 do_test 17.6.3 { 792 list [catch { db function xyz -n object ret } msg] $msg 793 } {1 {bad option "-n": must be -argcount, -deterministic, -directonly, -innocuous, or -returntype}} 794 795 # 2019-02-28: The "bind_fallback" command. 796 # 797 do_test 18.100 { 798 unset -nocomplain bindings abc def ghi jkl mno e01 e02 799 set bindings(abc) [expr {1+2}] 800 set bindings(def) {hello} 801 set bindings(ghi) [expr {3.1415926*1.0}] 802 proc bind_callback {nm} { 803 global bindings 804 set n2 [string range $nm 1 end] 805 if {[info exists bindings($n2)]} { 806 return $bindings($n2) 807 } 808 if {[string match e* $n2]} { 809 error "no such variable: $nm" 810 } 811 return -code return {} 812 } 813 db bind_fallback bind_callback 814 db eval {SELECT $abc, typeof($abc), $def, typeof($def), $ghi, typeof($ghi)} 815 } {3 integer hello text 3.1415926 real} 816 do_test 18.110 { 817 db eval {SELECT quote(@def), typeof(@def)} 818 } {X'68656C6C6F' blob} 819 do_execsql_test 18.120 { 820 SELECT typeof($mno); 821 } {null} 822 do_catchsql_test 18.130 { 823 SELECT $e01; 824 } {1 {no such variable: $e01}} 825 do_test 18.140 { 826 db bind_fallback 827 } {bind_callback} 828 do_test 18.200 { 829 db bind_fallback {} 830 db eval {SELECT $abc, typeof($abc), $def, typeof($def), $ghi, typeof($ghi)} 831 } {{} null {} null {} null} 832 do_test 18.300 { 833 unset -nocomplain bindings 834 proc bind_callback {nm} {lappend ::bindings $nm} 835 db bind_fallback bind_callback 836 db eval {SELECT $abc, @def, $ghi(123), :mno} 837 set bindings 838 } {{$abc} @def {$ghi(123)} :mno} 839 do_test 18.900 { 840 set rc [catch {db bind_fallback a b} msg] 841 lappend rc $msg 842 } {1 {wrong # args: should be "db bind_fallback ?CALLBACK?"}} 843 do_test 18.910 { 844 db bind_fallback bind_fallback_does_not_exist 845 } {} 846 do_catchsql_test 19.911 { 847 SELECT $abc, typeof($abc), $def, typeof($def), $ghi, typeof($ghi); 848 } {1 {invalid command name "bind_fallback_does_not_exist"}} 849 db bind_fallback {} 850 851 #------------------------------------------------------------------------- 852 do_test 20.0 { 853 db transaction { 854 db close 855 } 856 } {} 857 858 do_test 20.1 { 859 sqlite3 db test.db 860 set rc [catch { 861 db eval {SELECT 1 UNION ALL SELECT 2 UNION ALL SELECT 3} { db close } 862 } msg] 863 list $rc $msg 864 } {1 {invalid command name "db"}} 865 866 867 proc closedb {} { 868 db close 869 return 10 870 } 871 proc func1 {} { return 1 } 872 873 sqlite3 db test.db 874 db func closedb closedb 875 db func func1 func1 876 877 do_test 20.2 { 878 set rc [catch { 879 db eval { 880 SELECT closedb(),func1() UNION ALL SELECT 20,30 UNION ALL SELECT 30,40 881 } 882 } msg] 883 list $rc $msg 884 } {0 {10 1 20 30 30 40}} 885 886 sqlite3 db :memory: 887 do_test 21.1 { 888 catch {db eval {SELECT 1 2 3;}} msg 889 db erroroffset 890 } {9} 891 892 finish_test