test/tclsqlite.test

   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