Index: src/tclsqlite.c ================================================================== --- src/tclsqlite.c +++ src/tclsqlite.c @@ -9,11 +9,11 @@ ** May you share freely, never taking more than you give. ** ************************************************************************* ** A TCL Interface to SQLite ** -** $Id: tclsqlite.c,v 1.135 2005/12/07 06:27:44 danielk1977 Exp $ +** $Id: tclsqlite.c,v 1.136 2005/12/10 21:19:05 drh Exp $ */ #ifndef NO_TCL /* Omit this whole file if TCL is unavailable */ #include "sqliteInt.h" #include "hash.h" @@ -619,25 +619,26 @@ static const char *DB_strs[] = { "authorizer", "busy", "cache", "changes", "close", "collate", "collation_needed", "commit_hook", "complete", "copy", "errorcode", "eval", - "function", "last_insert_rowid", "nullvalue", - "onecolumn", "profile", "progress", - "rekey", "timeout", "total_changes", - "trace", "transaction", "version", - 0 + "exists", "function", "last_insert_rowid", + "nullvalue", "onecolumn", "profile", + "progress", "rekey", "timeout", + "total_changes", "trace", "transaction", + "version", 0 }; enum DB_enum { DB_AUTHORIZER, DB_BUSY, DB_CACHE, DB_CHANGES, DB_CLOSE, DB_COLLATE, DB_COLLATION_NEEDED, DB_COMMIT_HOOK, DB_COMPLETE, DB_COPY, DB_ERRORCODE, DB_EVAL, - DB_FUNCTION, DB_LAST_INSERT_ROWID,DB_NULLVALUE, - DB_ONECOLUMN, DB_PROFILE, DB_PROGRESS, - DB_REKEY, DB_TIMEOUT, DB_TOTAL_CHANGES, - DB_TRACE, DB_TRANSACTION, DB_VERSION + DB_EXISTS, DB_FUNCTION, DB_LAST_INSERT_ROWID, + DB_NULLVALUE, DB_ONECOLUMN, DB_PROFILE, + DB_PROGRESS, DB_REKEY, DB_TIMEOUT, + DB_TOTAL_CHANGES, DB_TRACE, DB_TRANSACTION, + DB_VERSION }; /* don't leave trailing commas on DB_enum, it confuses the AIX xlc compiler */ if( objc<2 ){ Tcl_WrongNumArgs(interp, 1, objv, "SUBCOMMAND ..."); @@ -1134,11 +1135,12 @@ ** ** The onecolumn method is the equivalent of: ** lindex [$db eval $sql] 0 */ case DB_ONECOLUMN: - case DB_EVAL: { + case DB_EVAL: + case DB_EXISTS: { char const *zSql; /* Next SQL statement to execute */ char const *zLeft; /* What is left after first stmt in zSql */ sqlite3_stmt *pStmt; /* Compiled SQL statment */ Tcl_Obj *pArray; /* Name of array into which results are written */ Tcl_Obj *pScript; /* Script to run for each result set */ @@ -1147,23 +1149,26 @@ Tcl_Obj *aParm[10]; /* Static space for apParm[] in the common case */ Tcl_Obj *pRet; /* Value to be returned */ SqlPreparedStmt *pPreStmt; /* Pointer to a prepared statement */ int rc2; - if( choice==DB_ONECOLUMN ){ - if( objc!=3 ){ - Tcl_WrongNumArgs(interp, 2, objv, "SQL"); - return TCL_ERROR; - } - pRet = 0; - }else{ + if( choice==DB_EVAL ){ if( objc<3 || objc>5 ){ Tcl_WrongNumArgs(interp, 2, objv, "SQL ?ARRAY-NAME? ?SCRIPT?"); return TCL_ERROR; } pRet = Tcl_NewObj(); Tcl_IncrRefCount(pRet); + }else{ + if( objc!=3 ){ + Tcl_WrongNumArgs(interp, 2, objv, "SQL"); + return TCL_ERROR; + } + pRet = 0; + if( choice==DB_EXISTS ){ + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } } if( objc==3 ){ pArray = pScript = 0; }else if( objc==4 ){ pArray = 0; @@ -1364,15 +1369,22 @@ Tcl_ObjSetVar2(interp, apColName[i], 0, pVal, 0); }else{ Tcl_ObjSetVar2(interp, pArray, apColName[i], pVal, 0); } }else if( choice==DB_ONECOLUMN ){ + assert( pRet==0 ); if( pRet==0 ){ pRet = pVal; Tcl_IncrRefCount(pRet); } rc = TCL_BREAK; + i = nCol; + }else if( choice==DB_EXISTS ){ + assert( pRet==0 ); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + rc = TCL_BREAK; + i = nCol; }else{ Tcl_ListObjAppendElement(interp, pRet, pVal); } } Index: test/tclsqlite.test ================================================================== --- test/tclsqlite.test +++ test/tclsqlite.test @@ -13,11 +13,11 @@ # # 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.44 2005/08/29 23:00:05 drh Exp $ +# $Id: tclsqlite.test,v 1.45 2005/12/10 21:19:06 drh Exp $ set testdir [file dirname $argv0] source $testdir/tester.tcl # Check the error messages generated by tclsqlite @@ -32,11 +32,11 @@ 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, busy, cache, changes, close, collate, collation_needed, commit_hook, complete, copy, errorcode, eval, function, last_insert_rowid, nullvalue, onecolumn, profile, progress, rekey, timeout, total_changes, trace, transaction, or version}} +} {1 {bad option "bogus": must be authorizer, busy, cache, changes, close, collate, collation_needed, commit_hook, complete, copy, errorcode, eval, exists, function, last_insert_rowid, nullvalue, onecolumn, profile, progress, rekey, timeout, total_changes, trace, transaction, or version}} 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 { @@ -432,7 +432,17 @@ }] } {2} do_test tcl-10.13 { db eval {SELECT * FROM t4} } {1 2 3 4 5 6 7} + +do_test tcl-11.1 { + db exists {SELECT x,x*2,x+x FROM t4 WHERE x==4} +} {1} +do_test tcl-11.2 { + db exists {SELECT 0 FROM t4 WHERE x==4} +} {1} +do_test tcl-11.3 { + db exists {SELECT 1 FROM t4 WHERE x==8} +} {0} finish_test