/*** 2001 September 15**** The author disclaims copyright to this source code.  In place of** a legal notice, here is a blessing:****    May you do good and not evil.**    May you find forgiveness for yourself and forgive others.**    May you share freely, never taking more than you give.***************************************************************************** A TCL Interface to SQLite**** $Id: tclsqlite.c,v 1.132 2005/08/29 23:00:04 drh Exp $*/#ifndef NO_TCL     /* Omit this whole file if TCL is unavailable */#include "sqliteInt.h"#include "hash.h"#include "tcl.h"#include <stdlib.h>#include <string.h>#include <assert.h>#include <ctype.h>#define NUM_PREPARED_STMTS 10#define MAX_PREPARED_STMTS 100/*** If TCL uses UTF-8 and SQLite is configured to use iso8859, then we** have to do a translation when going between the two.  Set the ** UTF_TRANSLATION_NEEDED macro to indicate that we need to do** this translation.  */#if defined(TCL_UTF_MAX) && !defined(SQLITE_UTF8)# define UTF_TRANSLATION_NEEDED 1#endif/*** New SQL functions can be created as TCL scripts.  Each such function** is described by an instance of the following structure.*/typedef struct SqlFunc SqlFunc;struct SqlFunc {  Tcl_Interp *interp;   /* The TCL interpret to execute the function */  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 */};/*** New collation sequences function can be created as TCL scripts.  Each such** function is described by an instance of the following structure.*/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 */};/*** Prepared statements are cached for faster execution.  Each prepared** statement is described by an instance of the following structure.*/typedef struct SqlPreparedStmt SqlPreparedStmt;struct SqlPreparedStmt {  SqlPreparedStmt *pNext;  /* Next in linked list */  SqlPreparedStmt *pPrev;  /* Previous on the list */  sqlite3_stmt *pStmt;     /* The prepared statement */  int nSql;                /* chars in zSql[] */  char zSql[1];            /* Text of the SQL statement */};/*** There is one instance of this structure for each SQLite database** that has been opened by the SQLite TCL interface.*/typedef struct SqliteDb SqliteDb;struct SqliteDb {  sqlite3 *db;               /* The "real" database structure */  Tcl_Interp *interp;        /* The interpreter used for this database */  char *zBusy;               /* The busy callback routine */  char *zCommit;             /* The commit hook callback routine */  char *zTrace;              /* The trace callback routine */  char *zProfile;            /* The profile callback routine */  char *zProgress;           /* The progress callback routine */  char *zAuth;               /* The authorization callback routine */  char *zNull;               /* Text to substitute for an SQL NULL value */  SqlFunc *pFunc;            /* List of SQL functions */  SqlCollate *pCollate;      /* List of SQL collation functions */  int rc;                    /* Return code of most recent sqlite3_exec() */  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*/static void flushStmtCache( SqliteDb *pDb ){  SqlPreparedStmt *pPreStmt;  while(  pDb->stmtList ){    sqlite3_finalize( pDb->stmtList->pStmt );    pPreStmt = pDb->stmtList;    pDb->stmtList = pDb->stmtList->pNext;    Tcl_Free( (char*)pPreStmt );  }  pDb->nStmt = 0;  pDb->stmtLast = 0;}/*** TCL calls this procedure when an sqlite3 database command is** deleted.*/static void DbDeleteCmd(void *db){  SqliteDb *pDb = (SqliteDb*)db;  flushStmtCache(pDb);  sqlite3_close(pDb->db);  while( pDb->pFunc ){    SqlFunc *pFunc = pDb->pFunc;    pDb->pFunc = pFunc->pNext;    Tcl_DecrRefCount(pFunc->pScript);    Tcl_Free((char*)pFunc);  }  while( pDb->pCollate ){    SqlCollate *pCollate = pDb->pCollate;    pDb->pCollate = pCollate->pNext;    Tcl_Free((char*)pCollate);  }  if( pDb->zBusy ){    Tcl_Free(pDb->zBusy);  }  if( pDb->zTrace ){    Tcl_Free(pDb->zTrace);  }  if( pDb->zProfile ){    Tcl_Free(pDb->zProfile);  }  if( pDb->zAuth ){    Tcl_Free(pDb->zAuth);  }  if( pDb->zNull ){    Tcl_Free(pDb->zNull);  }  Tcl_Free((char*)pDb);}/*** This routine is called when a database file is locked while trying** to execute SQL.*/static int DbBusyHandler(void *cd, int nTries){  SqliteDb *pDb = (SqliteDb*)cd;  int rc;  char zVal[30];  sprintf(zVal, "%d", nTries);  rc = Tcl_VarEval(pDb->interp, pDb->zBusy, " ", zVal, (char*)0);  if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){    return 0;  }  return 1;}/*** This routine is invoked as the 'progress callback' for the database.*/static int DbProgressHandler(void *cd){  SqliteDb *pDb = (SqliteDb*)cd;  int rc;  assert( pDb->zProgress );  rc = Tcl_Eval(pDb->interp, pDb->zProgress);  if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){    return 1;  }  return 0;}/*** This routine is called by the SQLite trace handler whenever a new** block of SQL is executed.  The TCL script in pDb->zTrace is executed.*/static void DbTraceHandler(void *cd, const char *zSql){  SqliteDb *pDb = (SqliteDb*)cd;  Tcl_DString str;  Tcl_DStringInit(&str);  Tcl_DStringAppend(&str, pDb->zTrace, -1);  Tcl_DStringAppendElement(&str, zSql);  Tcl_Eval(pDb->interp, Tcl_DStringValue(&str));  Tcl_DStringFree(&str);  Tcl_ResetResult(pDb->interp);}/*** This routine is called by the SQLite profile handler after a statement** SQL has executed.  The TCL script in pDb->zProfile is evaluated.*/static void DbProfileHandler(void *cd, const char *zSql, sqlite_uint64 tm){  SqliteDb *pDb = (SqliteDb*)cd;  Tcl_DString str;  char zTm[100];  sqlite3_snprintf(sizeof(zTm)-1, zTm, "%lld", tm);  Tcl_DStringInit(&str);  Tcl_DStringAppend(&str, pDb->zProfile, -1);  Tcl_DStringAppendElement(&str, zSql);  Tcl_DStringAppendElement(&str, zTm);  Tcl_Eval(pDb->interp, Tcl_DStringValue(&str));  Tcl_DStringFree(&str);  Tcl_ResetResult(pDb->interp);}/*** This routine is called when a transaction is committed.  The** TCL script in pDb->zCommit is executed.  If it returns non-zero or** if it throws an exception, the transaction is rolled back instead** of being committed.*/static int DbCommitHandler(void *cd){  SqliteDb *pDb = (SqliteDb*)cd;  int rc;  rc = Tcl_Eval(pDb->interp, pDb->zCommit);  if( rc!=TCL_OK || atoi(Tcl_GetStringResult(pDb->interp)) ){    return 1;  }  return 0;}static void tclCollateNeeded(  void *pCtx,  sqlite3 *db,  int enc,  const char *zName){  SqliteDb *pDb = (SqliteDb *)pCtx;  Tcl_Obj *pScript = Tcl_DuplicateObj(pDb->pCollateNeeded);  Tcl_IncrRefCount(pScript);  Tcl_ListObjAppendElement(0, pScript, Tcl_NewStringObj(zName, -1));  Tcl_EvalObjEx(pDb->interp, pScript, 0);  Tcl_DecrRefCount(pScript);}/*** This routine is called to evaluate an SQL collation function implemented** using TCL script.*/static int tclSqlCollate(  void *pCtx,  int nA,  const void *zA,  int nB,  const void *zB){  SqlCollate *p = (SqlCollate *)pCtx;  Tcl_Obj *pCmd;  pCmd = Tcl_NewStringObj(p->zScript, -1);  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, TCL_EVAL_DIRECT);  Tcl_DecrRefCount(pCmd);  return (atoi(Tcl_GetStringResult(p->interp)));}/*** This routine is called to evaluate an SQL function implemented** using TCL script.*/static void tclSqlFunc(sqlite3_context *context, int argc, sqlite3_value**argv){  SqlFunc *p = sqlite3_user_data(context);  Tcl_Obj *pCmd;  int i;  int rc;  if( argc==0 ){    /* If there are no arguments to the function, call Tcl_EvalObjEx on the    ** script object directly.  This allows the TCL compiler to generate    ** bytecode for the command on the first invocation and thus make    ** subsequent invocations much faster. */    pCmd = p->pScript;    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);  }  if( rc && rc!=TCL_RETURN ){