Tcl interface uses Tcl_Objs to implement user-defined functions, thus allowing

BLOB values to be transferred correctly.  Ticket #1304. (CVS 2530)

FossilOrigin-Name: 514aaab3f99637ebb8b6e352f4e29738102579b4

manifest

@@ -1,5 +1,5 @@
-C Documentation\sfixes.\s\sTicket\s#1306.\s(CVS\s2529)
+C Tcl\sinterface\suses\sTcl_Objs\sto\simplement\suser-defined\sfunctions,\sthus\sallowing\nBLOB\svalues\sto\sbe\stransferred\scorrectly.\s\sTicket\s#1304.\s(CVS\s2530)
-D 2005-06-25T19:42:38
+D 2005-06-26T17:55:34
 F Makefile.in 64a6635ef44a98325e0cffe8d67669920a3dad47
 F Makefile.linux-gcc 06be33b2a9ad4f005a5f42b22c4a19dab3cbb5c7
 F README 9c4e2d6706bdcc3efdd773ce752a8cdab4f90028
@@ -65,7 +65,7 @@ F src/shell.c 25b3217d7c64e6497225439d261a253a23efff26
 F src/sqlite.h.in e06d5774e9cfa5962376ae988300a9f114a3e3d7
 F src/sqliteInt.h 2135a5bab820af868bf308f51cdf1adbcb3a85b7
 F src/table.c 25b3ff2b39b7d87e8d4a5da0713d68dfc06cbee9
-F src/tclsqlite.c 9b84e9e612ed573ee664e12bda62c7511e7b7746
+F src/tclsqlite.c cccaf6b78c290d824cf8ea089b8b27377e545830
 F src/test1.c b2885afb71c93e49db6a36f101fe38c71e7e3d6c
 F src/test2.c 716c1809dba8e5be6093703e9cada99d627542dc
 F src/test3.c 683e1e3819152ffd35da2f201e507228921148d0
@@ -80,7 +80,7 @@ F src/vacuum.c 829d9e1a6d7c094b80e0899686670932eafd768c
 F src/vdbe.c 56e892e351eb3ed634c3c239e4ad5c03aecfc2bf
 F src/vdbe.h 75e466d84d362b0c4498978a9d6b1e6bd32ecf3b
 F src/vdbeInt.h 4312faf41630a6c215924b6c7c2f39ebb1af8ffb
-F src/vdbeapi.c 5025a9163107e0a4964212d16e1c4defa13dc5c2
+F src/vdbeapi.c 7f392f0792d1258c958083d7de9eae7c3530c9a6
 F src/vdbeaux.c 38332d91887817a2146f46b58fff2a8a88ed0278
 F src/vdbemem.c da8e8d6f29dd1323f782f000d7cd120027c9ff03
 F src/where.c 3a9a2258ab3364655e9ea215ad5ae7bf41813f54
@@ -196,7 +196,7 @@ F test/subquery.test 0e37f0f032799c28aa8fcc0dc04ee28a78e5ce8b
 F test/subselect.test 3f3f7a940dc3195c3139f4d530385cb54665d614
 F test/table.test e87fb2211b97c6a3a367fbc116e8572091b53160
 F test/tableapi.test 6a66d58b37d46dc0f2b3c7d4bd2617d209399bd1
-F test/tclsqlite.test 7593733310c1d89f0b63c84fb155104ad948135c
+F test/tclsqlite.test faa15080060c39c9d6caa7e067c35e0ab3d4e793
 F test/temptable.test c71eeffe8af807f76eafdc5a39824639a1e301df
 F test/tester.tcl 98ecdc5723b3b2be5a8a5c3a7f38fa53031466ee
 F test/thread1.test 776c9e459b75ba905193b351926ac4019b049f35
@@ -283,7 +283,7 @@ F www/tclsqlite.tcl 425be741b8ae664f55cb1ef2371aab0a75109cf9
 F www/vdbe.tcl 87a31ace769f20d3627a64fa1fade7fed47b90d0
 F www/version3.tcl a99cf5f6d8bd4d5537584a2b342f0fb9fa601d8b
 F www/whentouse.tcl 528299b8316726dbcc5548e9aa0648c8b1bd055b
-P 8c99dca60aebee0ec5de9ed11350de864bc76584
+P 3dcdb7942ea9a9e5d708a198ba5183103d5075d9
-R f298a28bc4d82dbd5adfaab265db9284
+R 921bd56e87c8fac8c240733a327a399e
 U drh
-Z e8b0b3df38f0878df8807440d3147bbe
+Z 2d49decf778ceb912dc5c67c477d786e

manifest.uuid

@@ -1 +1 @@
-3dcdb7942ea9a9e5d708a198ba5183103d5075d9
+514aaab3f99637ebb8b6e352f4e29738102579b4

src/tclsqlite.c

@@ -11,7 +11,7 @@
 *************************************************************************
 ** A TCL Interface to SQLite
 **
-** $Id: tclsqlite.c,v 1.126 2005/06/25 19:31:48 drh Exp $
+** $Id: tclsqlite.c,v 1.127 2005/06/26 17:55:34 drh Exp $
 */
 #ifndef NO_TCL     /* Omit this whole file if TCL is unavailable */
 
@@ -21,6 +21,7 @@
 #include <stdlib.h>
 #include <string.h>
 #include <assert.h>
+#include <ctype.h>
 
 #define NUM_PREPARED_STMTS 10
 #define MAX_PREPARED_STMTS 100
@@ -42,7 +43,9 @@
 typedef struct SqlFunc SqlFunc;
 struct SqlFunc {
   Tcl_Interp *interp;   /* The TCL interpret to execute the function */
-  char *zScript;        /* The script to be run */
+  Tcl_Obj *pScript;     /* The Tcl_Obj representation of the script */
+  int useEvalObjv;      /* True if it is safe to use Tcl_EvalObjv */
+  char *zName;          /* Name of this function */
   SqlFunc *pNext;       /* Next function on the list of them all */
 };
 
@@ -54,7 +57,7 @@ typedef struct SqlCollate SqlCollate;
 struct SqlCollate {
   Tcl_Interp *interp;   /* The TCL interpret to execute the function */
   char *zScript;        /* The script to be run */
-  SqlCollate *pNext;       /* Next function on the list of them all */
+  SqlCollate *pNext;    /* Next function on the list of them all */
 };
 
 /*
@@ -76,24 +79,76 @@ struct SqlPreparedStmt {
 */
 typedef struct SqliteDb SqliteDb;
 struct SqliteDb {
-  sqlite3 *db;          /* The "real" database structure */
+  sqlite3 *db;               /* The "real" database structure */
-  Tcl_Interp *interp;   /* The interpreter used for this database */
+  Tcl_Interp *interp;        /* The interpreter used for this database */
-  char *zBusy;          /* The busy callback routine */
+  char *zBusy;               /* The busy callback routine */
-  char *zCommit;        /* The commit hook callback routine */
+  char *zCommit;             /* The commit hook callback routine */
-  char *zTrace;         /* The trace callback routine */
+  char *zTrace;              /* The trace callback routine */
-  char *zProgress;      /* The progress callback routine */
+  char *zProgress;           /* The progress callback routine */
-  char *zAuth;          /* The authorization callback routine */
+  char *zAuth;               /* The authorization callback routine */
-  char *zNull;          /* Text to substitute for an SQL NULL value */
+  char *zNull;               /* Text to substitute for an SQL NULL value */
-  SqlFunc *pFunc;       /* List of SQL functions */
+  SqlFunc *pFunc;            /* List of SQL functions */
-  SqlCollate *pCollate; /* List of SQL collation functions */
+  SqlCollate *pCollate;      /* List of SQL collation functions */
-  int rc;               /* Return code of most recent sqlite3_exec() */
+  int rc;                    /* Return code of most recent sqlite3_exec() */
-  Tcl_Obj *pCollateNeeded;  /* Collation needed script */
+  Tcl_Obj *pCollateNeeded;   /* Collation needed script */
   SqlPreparedStmt *stmtList; /* List of prepared statements*/
   SqlPreparedStmt *stmtLast; /* Last statement in the list */
   int maxStmt;               /* The next maximum number of stmtList */
   int nStmt;                 /* Number of statements in stmtList */
 };
 
+/*
+** Look at the script prefix in pCmd.  We will be executing this script
+** after first appending one or more arguments.  This routine analyzes
+** the script to see if it is safe to use Tcl_EvalObjv() on the script
+** rather than the more general Tcl_EvalEx().  Tcl_EvalObjv() is much
+** faster.
+**
+** Scripts that are safe to use with Tcl_EvalObjv() consists of a
+** command name followed by zero or more arguments with no [...] or $
+** or {...} or ; to be seen anywhere.  Most callback scripts consist
+** of just a single procedure name and they meet this requirement.
+*/
+static int safeToUseEvalObjv(Tcl_Interp *interp, Tcl_Obj *pCmd){
+  /* We could try to do something with Tcl_Parse().  But we will instead
+  ** just do a search for forbidden characters.  If any of the forbidden
+  ** characters appear in pCmd, we will report the string as unsafe.
+  */
+  const char *z;
+  int n;
+  z = Tcl_GetStringFromObj(pCmd, &n);
+  while( n-- > 0 ){
+    int c = *(z++);
+    if( c=='$' || c=='[' || c==';' ) return 0;
+  }
+  return 1;
+}
+
+/*
+** Find an SqlFunc structure with the given name.  Or create a new
+** one if an existing one cannot be found.  Return a pointer to the
+** structure.
+*/
+static SqlFunc *findSqlFunc(SqliteDb *pDb, const char *zName){
+  SqlFunc *p, *pNew;
+  int i;
+  pNew = (SqlFunc*)Tcl_Alloc( sizeof(*pNew) + strlen(zName) + 1 );
+  pNew->zName = (char*)&pNew[1];
+  for(i=0; zName[i]; i++){ pNew->zName[i] = tolower(zName[i]); }
+  pNew->zName[i] = 0;
+  for(p=pDb->pFunc; p; p=p->pNext){ 
+    if( strcmp(p->zName, pNew->zName)==0 ){
+      Tcl_Free((char*)pNew);
+      return p;
+    }
+  }
+  pNew->interp = pDb->interp;
+  pNew->pScript = 0;
+  pNew->pNext = pDb->pFunc;
+  pDb->pFunc = pNew;
+  return pNew;
+}
+
 /*
 ** Finalize and free a list of prepared statements
 */
@@ -121,6 +176,7 @@ static void DbDeleteCmd(void *db){
   while( pDb->pFunc ){
     SqlFunc *pFunc = pDb->pFunc;
     pDb->pFunc = pFunc->pNext;
+    Tcl_DecrRefCount(pFunc->pScript);
     Tcl_Free((char*)pFunc);
   }
   while( pDb->pCollate ){
@@ -151,16 +207,9 @@ static int DbBusyHandler(void *cd, int nTries){
   SqliteDb *pDb = (SqliteDb*)cd;
   int rc;
   char zVal[30];
-  char *zCmd;
-  Tcl_DString cmd;
 
-  Tcl_DStringInit(&cmd);
-  Tcl_DStringAppend(&cmd, pDb->zBusy, -1);
   sprintf(zVal, "%d", nTries);
-  Tcl_DStringAppendElement(&cmd, zVal);
+  rc = Tcl_VarEval(pDb->interp, pDb->zBusy, " ", zVal, (char*)0);
-  zCmd = Tcl_DStringValue(&cmd);
-  rc = Tcl_Eval(pDb->interp, zCmd);
-  Tcl_DStringFree(&cmd);
   if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){
     return 0;
   }
@@ -247,7 +296,7 @@ static int tclSqlCollate(
   Tcl_IncrRefCount(pCmd);
   Tcl_ListObjAppendElement(p->interp, pCmd, Tcl_NewStringObj(zA, nA));
   Tcl_ListObjAppendElement(p->interp, pCmd, Tcl_NewStringObj(zB, nB));
-  Tcl_EvalObjEx(p->interp, pCmd, 0);
+  Tcl_EvalObjEx(p->interp, pCmd, TCL_EVAL_DIRECT);
   Tcl_DecrRefCount(pCmd);
   return (atoi(Tcl_GetStringResult(p->interp)));
 }
@@ -258,22 +307,88 @@ static int tclSqlCollate(
 */
 static void tclSqlFunc(sqlite3_context *context, int argc, sqlite3_value**argv){
   SqlFunc *p = sqlite3_user_data(context);
-  Tcl_DString cmd;
+  Tcl_Obj *pCmd;
   int i;
   int rc;
 
-  Tcl_DStringInit(&cmd);
+  if( argc==0 ){
-  Tcl_DStringAppend(&cmd, p->zScript, -1);
+    /* If there are no arguments to the function, call Tcl_EvalObjEx on the
-  for(i=0; i<argc; i++){
+    ** script object directly.  This allows the TCL compiler to generate
-    if( SQLITE_NULL==sqlite3_value_type(argv[i]) ){
+    ** bytecode for the command on the first invocation and thus make
-      Tcl_DStringAppendElement(&cmd, "");
+    ** subsequent invocations much faster. */
-    }else{
+    pCmd = p->pScript;
-      Tcl_DStringAppendElement(&cmd, sqlite3_value_text(argv[i]));
+    Tcl_IncrRefCount(pCmd);
+    rc = Tcl_EvalObjEx(p->interp, pCmd, 0);
+    Tcl_DecrRefCount(pCmd);
+  }else{
+    /* If there are arguments to the function, make a shallow copy of the
+    ** script object, lappend the arguments, then evaluate the copy.
+    **
+    ** By "shallow" copy, we mean a only the outer list Tcl_Obj is duplicated.
+    ** The new Tcl_Obj contains pointers to the original list elements. 
+    ** That way, when Tcl_EvalObjv() is run and shimmers the first element
+    ** of the list to tclCmdNameType, that alternate representation will
+    ** be preserved and reused on the next invocation.
+    */
+    Tcl_Obj **aArg;
+    int nArg;
+    if( Tcl_ListObjGetElements(p->interp, p->pScript, &nArg, &aArg) ){
+      sqlite3_result_error(context, Tcl_GetStringResult(p->interp), -1); 
+      return;
+    }     
+    pCmd = Tcl_NewListObj(nArg, aArg);
+    Tcl_IncrRefCount(pCmd);
+    for(i=0; i<argc; i++){
+      sqlite3_value *pIn = argv[i];
+      Tcl_Obj *pVal;
+            
+      /* Set pVal to contain the i'th column of this row. */
+      switch( sqlite3_value_type(pIn) ){
+        case SQLITE_BLOB: {
+          int bytes = sqlite3_value_bytes(pIn);
+          pVal = Tcl_NewByteArrayObj(sqlite3_value_blob(pIn), bytes);
+          break;
+        }
+        case SQLITE_INTEGER: {
+          sqlite_int64 v = sqlite3_value_int64(pIn);
+          if( v>=-2147483647 && v<=2147483647 ){
+            pVal = Tcl_NewIntObj(v);
+          }else{
+            pVal = Tcl_NewWideIntObj(v);
+          }
+          break;
+        }
+        case SQLITE_FLOAT: {
+          double r = sqlite3_value_double(pIn);
+          pVal = Tcl_NewDoubleObj(r);
+          break;
+        }
+        case SQLITE_NULL: {
+          pVal = Tcl_NewStringObj("", 0);
+          break;
+        }
+        default: {
+          int bytes = sqlite3_value_bytes(pIn);
+          pVal = Tcl_NewStringObj(sqlite3_value_text(pIn), bytes);
+          break;
+        }
+      }
+      rc = Tcl_ListObjAppendElement(p->interp, pCmd, pVal);
+      if( rc ){
+        Tcl_DecrRefCount(pCmd);
+        sqlite3_result_error(context, Tcl_GetStringResult(p->interp), -1); 
+        return;
+      }
     }
+    if( !p->useEvalObjv ){
+      /* Tcl_EvalObjEx() will automatically call Tcl_EvalObjv() if pCmd
+      ** is a list without a string representation.  To prevent this from
+      ** happening, make sure pCmd has a valid string representation */
+      Tcl_GetString(pCmd);
+    }
+    rc = Tcl_EvalObjEx(p->interp, pCmd, TCL_EVAL_DIRECT);
+    Tcl_DecrRefCount(pCmd);
   }
-  rc = Tcl_EvalEx(p->interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd),
-                  TCL_EVAL_DIRECT);
-  Tcl_DStringFree(&cmd);
 
   if( rc && rc!=TCL_RETURN ){
     sqlite3_result_error(context, Tcl_GetStringResult(p->interp), -1); 
@@ -284,7 +399,7 @@ static void tclSqlFunc(sqlite3_context *context, int argc, sqlite3_value**argv){
     char *zType = pVar->typePtr ? pVar->typePtr->name : "";
     char c = zType[0];
     if( c=='b' && strcmp(zType,"bytearray")==0 && pVar->bytes==0 ){
-      /* Only load a BLOB type if the Tcl variable is a bytearray and
+      /* Only return a BLOB type if the Tcl variable is a bytearray and
       ** has no string representation. */
       data = Tcl_GetByteArrayFromObj(pVar, &n);
       sqlite3_result_blob(context, data, n, SQLITE_TRANSIENT);
@@ -1158,22 +1273,22 @@ static int DbObjCmd(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
   */
   case DB_FUNCTION: {
     SqlFunc *pFunc;
+    Tcl_Obj *pScript;
     char *zName;
-    char *zScript;
-    int nScript;
     if( objc!=4 ){
       Tcl_WrongNumArgs(interp, 2, objv, "NAME SCRIPT");
       return TCL_ERROR;
     }
     zName = Tcl_GetStringFromObj(objv[2], 0);
-    zScript = Tcl_GetStringFromObj(objv[3], &nScript);
+    pScript = objv[3];
-    pFunc = (SqlFunc*)Tcl_Alloc( sizeof(*pFunc) + nScript + 1 );
+    pFunc = findSqlFunc(pDb, zName);
     if( pFunc==0 ) return TCL_ERROR;
-    pFunc->interp = interp;
+    if( pFunc->pScript ){
-    pFunc->pNext = pDb->pFunc;
+      Tcl_DecrRefCount(pFunc->pScript);
-    pFunc->zScript = (char*)&pFunc[1];
+    }
-    pDb->pFunc = pFunc;
+    pFunc->pScript = pScript;
-    strcpy(pFunc->zScript, zScript);
+    Tcl_IncrRefCount(pScript);
+    pFunc->useEvalObjv = safeToUseEvalObjv(interp, pScript);
     rc = sqlite3_create_function(pDb->db, zName, -1, SQLITE_UTF8,
         pFunc, tclSqlFunc, 0, 0);
     if( rc!=SQLITE_OK ){

src/vdbeapi.c

@@ -369,6 +369,11 @@ sqlite_int64 sqlite3_column_int64(sqlite3_stmt *pStmt, int i){
 const unsigned char *sqlite3_column_text(sqlite3_stmt *pStmt, int i){
   return sqlite3_value_text( columnMem(pStmt,i) );
 }
+#if 0
+sqlite3_value *sqlite3_column_value(sqlite3_stmt *pStmt, int i){
+  return columnMem(pStmt, i);
+}
+#endif
 #ifndef SQLITE_OMIT_UTF16
 const void *sqlite3_column_text16(sqlite3_stmt *pStmt, int i){
   return sqlite3_value_text16( columnMem(pStmt,i) );

test/tclsqlite.test

@@ -15,7 +15,7 @@
 # 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.40 2005/05/05 10:30:30 drh Exp $
+# $Id: tclsqlite.test,v 1.41 2005/06/26 17:55:34 drh Exp $
 
 set testdir [file dirname $argv0]
 source $testdir/tester.tcl
@@ -333,5 +333,20 @@ do_test tcl-9.3 {
   execsql {SELECT typeof(ret_int())}
 } {integer}
 
+# Recursive calls to the same user-defined function
+#
+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}
+
 
 finish_test