Index: src/tclsqlite.c ================================================================== --- src/tclsqlite.c +++ src/tclsqlite.c @@ -47,10 +47,14 @@ /* Compatability between Tcl8.6 and Tcl9.0 */ #if TCL_MAJOR_VERSION==9 # define CONST const #elif !defined(Tcl_Size) typedef int Tcl_Size; +# ifndef Tcl_BounceRefCount +# define Tcl_BounceRefCount(X) Tcl_IncrRefCount(X); Tcl_DecrRefCount(X) + /* https://www.tcl-lang.org/man/tcl9.0/TclLib/Object.html */ +# endif #endif /**** End copy of tclsqlite.h ****/ #include @@ -1082,11 +1086,13 @@ } rc = Tcl_EvalObjEx(p->interp, pCmd, TCL_EVAL_DIRECT); Tcl_DecrRefCount(pCmd); } - if( rc && rc!=TCL_RETURN ){ + if( TCL_BREAK==rc ){ + sqlite3_result_null(context); + }else if( rc && rc!=TCL_RETURN ){ sqlite3_result_error(context, Tcl_GetStringResult(p->interp), -1); }else{ Tcl_Obj *pVar = Tcl_GetObjResult(p->interp); Tcl_Size n; u8 *data; @@ -1100,11 +1106,11 @@ ** has no string representation. */ eType = SQLITE_BLOB; }else if( (c=='b' && pVar->bytes==0 && strcmp(zType,"boolean")==0 ) || (c=='b' && pVar->bytes==0 && strcmp(zType,"booleanString")==0 ) || (c=='w' && strcmp(zType,"wideInt")==0) - || (c=='i' && strcmp(zType,"int")==0) + || (c=='i' && strcmp(zType,"int")==0) ){ eType = SQLITE_INTEGER; }else if( c=='d' && strcmp(zType,"double")==0 ){ eType = SQLITE_FLOAT; }else{ @@ -1614,15 +1620,16 @@ Tcl_Obj *pSql; /* Object holding string zSql */ const char *zSql; /* Remaining SQL to execute */ SqlPreparedStmt *pPreStmt; /* Current statement */ int nCol; /* Number of columns returned by pStmt */ int evalFlags; /* Flags used */ - Tcl_Obj *pArray; /* Name of array variable */ + Tcl_Obj *pTgtName; /* Name of target array/dict variable */ Tcl_Obj **apColName; /* Array of column names */ }; #define SQLITE_EVAL_WITHOUTNULLS 0x00001 /* Unset array(*) for NULL */ +#define SQLITE_EVAL_ASDICT 0x00002 /* Use dict instead of array */ /* ** Release any cache of column names currently held as part of ** the DbEvalContext structure passed as the first argument. */ @@ -1639,34 +1646,34 @@ } /* ** Initialize a DbEvalContext structure. ** -** If pArray is not NULL, then it contains the name of a Tcl array +** If pTgtName is not NULL, then it contains the name of a Tcl array ** variable. The "*" member of this array is set to a list containing ** the names of the columns returned by the statement as part of each ** call to dbEvalStep(), in order from left to right. e.g. if the names ** of the returned columns are a, b and c, it does the equivalent of the ** tcl command: ** -** set ${pArray}(*) {a b c} +** set ${pTgtName}(*) {a b c} */ static void dbEvalInit( DbEvalContext *p, /* Pointer to structure to initialize */ SqliteDb *pDb, /* Database handle */ Tcl_Obj *pSql, /* Object containing SQL script */ - Tcl_Obj *pArray, /* Name of Tcl array to set (*) element of */ + Tcl_Obj *pTgtName, /* Name of Tcl array to set (*) element of */ int evalFlags /* Flags controlling evaluation */ ){ memset(p, 0, sizeof(DbEvalContext)); p->pDb = pDb; p->zSql = Tcl_GetString(pSql); p->pSql = pSql; Tcl_IncrRefCount(pSql); - if( pArray ){ - p->pArray = pArray; - Tcl_IncrRefCount(pArray); + if( pTgtName ){ + p->pTgtName = pTgtName; + Tcl_IncrRefCount(pTgtName); } p->evalFlags = evalFlags; addDatabaseRef(p->pDb); } @@ -1685,33 +1692,48 @@ int i; /* Iterator variable */ int nCol; /* Number of columns returned by pStmt */ Tcl_Obj **apColName = 0; /* Array of column names */ p->nCol = nCol = sqlite3_column_count(pStmt); - if( nCol>0 && (papColName || p->pArray) ){ + if( nCol>0 && (papColName || p->pTgtName) ){ apColName = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*)*nCol ); for(i=0; iapColName = apColName; } - /* If results are being stored in an array variable, then create - ** the array(*) entry for that array + /* If results are being stored in a variable then create the + ** array(*) or dict(*) entry for that variable. */ - if( p->pArray ){ + if( p->pTgtName ){ Tcl_Interp *interp = p->pDb->interp; Tcl_Obj *pColList = Tcl_NewObj(); Tcl_Obj *pStar = Tcl_NewStringObj("*", -1); + Tcl_IncrRefCount(pColList); + Tcl_IncrRefCount(pStar); for(i=0; ipArray, pStar, pColList, 0); + if( 0==(SQLITE_EVAL_ASDICT & p->evalFlags) ){ + Tcl_ObjSetVar2(interp, p->pTgtName, pStar, pColList, 0); + }else{ + Tcl_Obj * pDict = Tcl_ObjGetVar2(interp, p->pTgtName, NULL, 0); + if( !pDict ){ + pDict = Tcl_NewDictObj(); + }else if( Tcl_IsShared(pDict) ){ + pDict = Tcl_DuplicateObj(pDict); + } + if( Tcl_DictObjPut(interp, pDict, pStar, pColList)==TCL_OK ){ + Tcl_ObjSetVar2(interp, p->pTgtName, NULL, pDict, 0); + } + Tcl_BounceRefCount(pDict); + } Tcl_DecrRefCount(pStar); + Tcl_DecrRefCount(pColList); } } if( papColName ){ *papColName = p->apColName; @@ -1749,11 +1771,11 @@ rcs = sqlite3_step(pStmt); if( rcs==SQLITE_ROW ){ return TCL_OK; } - if( p->pArray ){ + if( p->pTgtName ){ dbEvalRowInfo(p, 0, 0); } rcs = sqlite3_reset(pStmt); pDb->nStep = sqlite3_stmt_status(pStmt,SQLITE_STMTSTATUS_FULLSCAN_STEP,1); @@ -1800,13 +1822,13 @@ if( p->pPreStmt ){ sqlite3_reset(p->pPreStmt->pStmt); dbReleaseStmt(p->pDb, p->pPreStmt, 0); p->pPreStmt = 0; } - if( p->pArray ){ - Tcl_DecrRefCount(p->pArray); - p->pArray = 0; + if( p->pTgtName ){ + Tcl_DecrRefCount(p->pTgtName); + p->pTgtName = 0; } Tcl_DecrRefCount(p->pSql); dbReleaseColumnNames(p); delDatabaseRef(p->pDb); } @@ -1877,11 +1899,11 @@ #endif /* ** This function is part of the implementation of the command: ** -** $db eval SQL ?ARRAYNAME? SCRIPT +** $db eval SQL ?TGT-NAME? SCRIPT */ static int SQLITE_TCLAPI DbEvalNextCmd( ClientData data[], /* data[0] is the (DbEvalContext*) */ Tcl_Interp *interp, /* Tcl interpreter */ int result /* Result so far */ @@ -1891,28 +1913,59 @@ /* The first element of the data[] array is a pointer to a DbEvalContext ** structure allocated using Tcl_Alloc(). The second element of data[] ** is a pointer to a Tcl_Obj containing the script to run for each row ** returned by the queries encapsulated in data[0]. */ DbEvalContext *p = (DbEvalContext *)data[0]; - Tcl_Obj *pScript = (Tcl_Obj *)data[1]; - Tcl_Obj *pArray = p->pArray; + Tcl_Obj * const pScript = (Tcl_Obj *)data[1]; + Tcl_Obj * const pTgtName = p->pTgtName; while( (rc==TCL_OK || rc==TCL_CONTINUE) && TCL_OK==(rc = dbEvalStep(p)) ){ int i; int nCol; Tcl_Obj **apColName; dbEvalRowInfo(p, &nCol, &apColName); for(i=0; ievalFlags & SQLITE_EVAL_WITHOUTNULLS)!=0 - && sqlite3_column_type(p->pPreStmt->pStmt, i)==SQLITE_NULL + && sqlite3_column_type(p->pPreStmt->pStmt, i)==SQLITE_NULL ){ - Tcl_UnsetVar2(interp, Tcl_GetString(pArray), - Tcl_GetString(apColName[i]), 0); + /* Remove NULL-containing column from the target container... */ + if( 0==(SQLITE_EVAL_ASDICT & p->evalFlags) ){ + /* Target is an array */ + Tcl_UnsetVar2(interp, Tcl_GetString(pTgtName), + Tcl_GetString(apColName[i]), 0); + }else{ + /* Target is a dict */ + Tcl_Obj *pDict = Tcl_ObjGetVar2(interp, pTgtName, NULL, 0); + if( pDict ){ + if( Tcl_IsShared(pDict) ){ + pDict = Tcl_DuplicateObj(pDict); + } + if( Tcl_DictObjRemove(interp, pDict, apColName[i])==TCL_OK ){ + Tcl_ObjSetVar2(interp, pTgtName, NULL, pDict, 0); + } + Tcl_BounceRefCount(pDict); + } + } + }else if( 0==(SQLITE_EVAL_ASDICT & p->evalFlags) ){ + /* Target is an array: set target(colName) = colValue */ + Tcl_ObjSetVar2(interp, pTgtName, apColName[i], + dbEvalColumnValue(p,i), 0); }else{ - Tcl_ObjSetVar2(interp, pArray, apColName[i], dbEvalColumnValue(p,i), 0); + /* Target is a dict: set target(colName) = colValue */ + Tcl_Obj *pDict = Tcl_ObjGetVar2(interp, pTgtName, NULL, 0); + if( !pDict ){ + pDict = Tcl_NewDictObj(); + }else if( Tcl_IsShared(pDict) ){ + pDict = Tcl_DuplicateObj(pDict); + } + if( Tcl_DictObjPut(interp, pDict, apColName[i], + dbEvalColumnValue(p,i))==TCL_OK ){ + Tcl_ObjSetVar2(interp, pTgtName, NULL, pDict, 0); + } + Tcl_BounceRefCount(pDict); } } /* The required interpreter variables are now populated with the data ** from the current row. If using NRE, schedule callbacks to evaluate @@ -2017,11 +2070,11 @@ "progress", "rekey", "restore", "rollback_hook", "serialize", "status", "timeout", "total_changes", "trace", "trace_v2", "transaction", "unlock_notify", "update_hook", "version", "wal_hook", - 0 + 0 }; enum DB_enum { DB_AUTHORIZER, DB_BACKUP, DB_BIND_FALLBACK, DB_BUSY, DB_CACHE, DB_CHANGES, DB_CLOSE, DB_COLLATE, DB_COLLATION_NEEDED, @@ -2851,35 +2904,38 @@ } break; } /* - ** $db eval ?options? $sql ?array? ?{ ...code... }? + ** $db eval ?options? $sql ?varName? ?{ ...code... }? ** - ** The SQL statement in $sql is evaluated. For each row, the values are - ** placed in elements of the array named "array" and ...code... is executed. - ** If "array" and "code" are omitted, then no callback is every invoked. - ** If "array" is an empty string, then the values are placed in variables - ** that have the same name as the fields extracted by the query. + ** The SQL statement in $sql is evaluated. For each row, the values + ** are placed in elements of the array or dict named $varName and + ** ...code... is executed. If $varName and $code are omitted, then + ** no callback is ever invoked. If $varName is an empty string, + ** then the values are placed in variables that have the same name + ** as the fields extracted by the query, and those variables are + ** accessible during the eval of $code. */ case DB_EVAL: { int evalFlags = 0; const char *zOpt; while( objc>3 && (zOpt = Tcl_GetString(objv[2]))!=0 && zOpt[0]=='-' ){ if( strcmp(zOpt, "-withoutnulls")==0 ){ evalFlags |= SQLITE_EVAL_WITHOUTNULLS; - } - else{ + }else if( strcmp(zOpt, "-asdict")==0 ){ + evalFlags |= SQLITE_EVAL_ASDICT; + }else{ Tcl_AppendResult(interp, "unknown option: \"", zOpt, "\"", (void*)0); return TCL_ERROR; } objc--; objv++; } if( objc<3 || objc>5 ){ - Tcl_WrongNumArgs(interp, 2, objv, - "?OPTIONS? SQL ?ARRAY-NAME? ?SCRIPT?"); + Tcl_WrongNumArgs(interp, 2, objv, + "?OPTIONS? SQL ?VAR-NAME? ?SCRIPT?"); return TCL_ERROR; } if( objc==3 ){ DbEvalContext sEval; @@ -2901,21 +2957,21 @@ } Tcl_DecrRefCount(pRet); }else{ ClientData cd2[2]; DbEvalContext *p; - Tcl_Obj *pArray = 0; + Tcl_Obj *pTgtName = 0; Tcl_Obj *pScript; if( objc>=5 && *(char *)Tcl_GetString(objv[3]) ){ - pArray = objv[3]; + pTgtName = objv[3]; } pScript = objv[objc-1]; Tcl_IncrRefCount(pScript); p = (DbEvalContext *)Tcl_Alloc(sizeof(DbEvalContext)); - dbEvalInit(p, pDb, objv[2], pArray, evalFlags); + dbEvalInit(p, pDb, objv[2], pTgtName, evalFlags); cd2[0] = (void *)p; cd2[1] = (void *)pScript; rc = DbEvalNextCmd(cd2, interp, TCL_OK); } Index: test/tclsqlite.test ================================================================== --- test/tclsqlite.test +++ test/tclsqlite.test @@ -7,11 +7,11 @@ # 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. +# 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. # @@ -119,11 +119,11 @@ } {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 ?OPTIONS? SQL ?ARRAY-NAME? ?SCRIPT?"}} +} {1 {wrong # args: should be "db eval ?OPTIONS? SQL ?VAR-NAME? ?SCRIPT?"}} do_test tcl-1.15 { set v [catch {db function} msg] lappend v $msg } {1 {wrong # args: should be "db function NAME ?SWITCHES? SCRIPT"}} do_test tcl-1.16 { @@ -356,10 +356,22 @@ } {real} do_test tcl-9.3 { db function ret_int {return [expr {int(rand()*200)}]} execsql {SELECT typeof(ret_int())} } {integer} +proc breakAsNullUdf args { + if {"1" eq [lindex $args 0]} {return -code break} +} +do_test tcl-9.4 { + db function banu breakAsNullUdf + execsql {SELECT typeof(banu()), typeof(banu(1))} +} {text null} +do_test tcl-9.5 { + db nullvalue banunull + db eval {SELECT banu(), banu(1)} +} {{} banunull} + # Recursive calls to the same user-defined function # ifcapable tclvar { do_test tcl-9.10 { @@ -463,21 +475,21 @@ } {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 +# 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 { + catch { db transaction { db eval { INSERT INTO t4 VALUES('two') } db transaction { db eval { INSERT INTO t4 VALUES('three') } error "throw an error!" @@ -672,15 +684,15 @@ do_test tcl-15.5 { db exists {SELECT a FROM t1 WHERE a>3} } {0} -# 2017-06-26: The --withoutnulls flag to "db eval". +# 2017-06-26: The -withoutnulls flag to "db eval". # -# In the "db eval --withoutnulls SQL ARRAY" form, NULL results cause the -# corresponding array entry to be unset. The default behavior (without -# the -withoutnulls flags) is for the corresponding array value to get +# In the "db eval -withoutnulls SQL TARGET" form, NULL results cause the +# corresponding target entry to be unset. The default behavior (without +# the -withoutnulls flags) is for the corresponding target value to get # the [db nullvalue] string. # catch {db close} forcedelete test.db sqlite3 db test.db @@ -718,68 +730,68 @@ # reset_db proc add {a b} { return [expr $a + $b] } proc ret {a} { return $a } -db function add_i -returntype integer add +db function add_i -returntype integer add db function add_r -ret real add -db function add_t -return text add -db function add_b -returntype blob add -db function add_a -returntype any add +db function add_t -return text add +db function add_b -returntype blob add +db function add_a -returntype any add -db function ret_i -returntype int ret +db function ret_i -returntype int ret db function ret_r -returntype real ret -db function ret_t -returntype text ret -db function ret_b -returntype blob ret -db function ret_a -r any ret +db function ret_t -returntype text ret +db function ret_b -returntype blob ret +db function ret_a -r any ret do_execsql_test 17.0 { SELECT quote( add_i(2, 3) ); - SELECT quote( add_r(2, 3) ); - SELECT quote( add_t(2, 3) ); - SELECT quote( add_b(2, 3) ); - SELECT quote( add_a(2, 3) ); + SELECT quote( add_r(2, 3) ); + SELECT quote( add_t(2, 3) ); + SELECT quote( add_b(2, 3) ); + SELECT quote( add_a(2, 3) ); } {5 5.0 '5' X'35' 5} do_execsql_test 17.1 { SELECT quote( add_i(2.2, 3.3) ); - SELECT quote( add_r(2.2, 3.3) ); - SELECT quote( add_t(2.2, 3.3) ); - SELECT quote( add_b(2.2, 3.3) ); - SELECT quote( add_a(2.2, 3.3) ); + SELECT quote( add_r(2.2, 3.3) ); + SELECT quote( add_t(2.2, 3.3) ); + SELECT quote( add_b(2.2, 3.3) ); + SELECT quote( add_a(2.2, 3.3) ); } {5.5 5.5 '5.5' X'352E35' 5.5} do_execsql_test 17.2 { SELECT quote( ret_i(2.5) ); - SELECT quote( ret_r(2.5) ); - SELECT quote( ret_t(2.5) ); - SELECT quote( ret_b(2.5) ); - SELECT quote( ret_a(2.5) ); + SELECT quote( ret_r(2.5) ); + SELECT quote( ret_t(2.5) ); + SELECT quote( ret_b(2.5) ); + SELECT quote( ret_a(2.5) ); } {2.5 2.5 '2.5' X'322E35' 2.5} do_execsql_test 17.3 { SELECT quote( ret_i('2.5') ); - SELECT quote( ret_r('2.5') ); - SELECT quote( ret_t('2.5') ); - SELECT quote( ret_b('2.5') ); - SELECT quote( ret_a('2.5') ); + SELECT quote( ret_r('2.5') ); + SELECT quote( ret_t('2.5') ); + SELECT quote( ret_b('2.5') ); + SELECT quote( ret_a('2.5') ); } {2.5 2.5 '2.5' X'322E35' '2.5'} do_execsql_test 17.4 { SELECT quote( ret_i('abc') ); - SELECT quote( ret_r('abc') ); - SELECT quote( ret_t('abc') ); - SELECT quote( ret_b('abc') ); - SELECT quote( ret_a('abc') ); + SELECT quote( ret_r('abc') ); + SELECT quote( ret_t('abc') ); + SELECT quote( ret_b('abc') ); + SELECT quote( ret_a('abc') ); } {'abc' 'abc' 'abc' X'616263' 'abc'} do_execsql_test 17.5 { SELECT quote( ret_i(X'616263') ); - SELECT quote( ret_r(X'616263') ); - SELECT quote( ret_t(X'616263') ); - SELECT quote( ret_b(X'616263') ); - SELECT quote( ret_a(X'616263') ); + SELECT quote( ret_r(X'616263') ); + SELECT quote( ret_t(X'616263') ); + SELECT quote( ret_b(X'616263') ); + SELECT quote( ret_a(X'616263') ); } {'abc' 'abc' 'abc' X'616263' X'616263'} do_test 17.6.1 { list [catch { db function xyz -return object ret } msg] $msg } {1 {bad type "object": must be integer, real, text, blob, or any}} @@ -846,25 +858,72 @@ do_catchsql_test 19.911 { SELECT $abc, typeof($abc), $def, typeof($def), $ghi, typeof($ghi); } {1 {invalid command name "bind_fallback_does_not_exist"}} db bind_fallback {} -#------------------------------------------------------------------------- +# 2025-05-05: the -asdict eval flag +# do_test 20.0 { + execsql {CREATE TABLE tad(a,b)} + execsql {INSERT INTO tad(a,b) VALUES('aa','bb'),('AA','BB')} + db eval -asdict { + SELECT a, b FROM tad WHERE 0 + } D {} + set D +} {* {a b}} +do_test 20.1 { + unset D + set i 0 + set res {} + set colNames {} + db eval -asdict { + SELECT a, b FROM tad ORDER BY a + } D { + dict set D i [incr i] + lappend res $i [dict get $D a] [dict get $D b] + if {1 == $i} { + set colNames [dict get $D *] + } + } + lappend res $colNames + unset D + set res +} {1 AA BB 2 aa bb {a b}} +do_test 20.2 { + set res {} + db eval -asdict -withoutnulls { + SELECT n, a, b FROM ( + SELECT 1 as n, 'aa' as a, NULL as b + UNION ALL + SELECT 2 as n, NULL as a, 'bb' as b + ) + ORDER BY n + } D { + dict unset D * + lappend res [dict values $D] + } + unset D + execsql {DROP TABLE tad} + set res +} {{1 aa} {2 bb}} + +#------------------------------------------------------------------------- +do_test 21.0 { db transaction { db close } } {} -do_test 20.1 { +do_test 21.1 { sqlite3 db test.db set rc [catch { db eval {SELECT 1 UNION ALL SELECT 2 UNION ALL SELECT 3} { db close } } msg] list $rc $msg } {1 {invalid command name "db"}} - + + proc closedb {} { db close return 10 } @@ -872,21 +931,22 @@ sqlite3 db test.db db func closedb closedb db func func1 func1 -do_test 20.2 { +do_test 21.2 { set rc [catch { db eval { SELECT closedb(),func1() UNION ALL SELECT 20,30 UNION ALL SELECT 30,40 } } msg] list $rc $msg } {0 {10 1 20 30 30 40}} sqlite3 db :memory: -do_test 21.1 { +do_test 22.1 { catch {db eval {SELECT 1 2 3;}} msg db erroroffset } {9} + finish_test