SQLite

/* Forward declaration */
typedef struct SqliteDb SqliteDb;

/*
** New SQL functions can be created as TCL scripts.  Each such function
** is described by an instance of the following structure.
**
** Variable eType may be set to SQLITE_INTEGER, SQLITE_FLOAT, SQLITE_TEXT,
** SQLITE_BLOB or SQLITE_NULL. If it is SQLITE_NULL, then the implementation
** attempts to determine the type of the result based on the Tcl object.
** If it is SQLITE_TEXT or SQLITE_BLOB, then a text (sqlite3_result_text())
** or blob (sqlite3_result_blob()) is returned. If it is SQLITE_INTEGER
** or SQLITE_FLOAT, then an attempt is made to return an integer or float
** value, falling back to float and then text if this is not possible.
*/
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 */
  SqliteDb *pDb;        /* Database connection that owns this function */
  int useEvalObjv;      /* True if it is safe to use Tcl_EvalObjv */
  int eType;            /* Type of value to return */
  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.

    sqlite3_result_error(context, Tcl_GetStringResult(p->interp), -1);
  }else{
    Tcl_Obj *pVar = Tcl_GetObjResult(p->interp);
    int n;
    u8 *data;
    const char *zType = (pVar->typePtr ? pVar->typePtr->name : "");
    char c = zType[0];
    int eType = p->eType;

    if( eType==SQLITE_NULL ){
      if( c=='b' && strcmp(zType,"bytearray")==0 && pVar->bytes==0 ){
        /* Only return a BLOB type if the Tcl variable is a bytearray and
        ** has no string representation. */
        eType = SQLITE_BLOB;
      }else if( (c=='b' && strcmp(zType,"boolean")==0)
             || (c=='w' && strcmp(zType,"wideInt")==0)
             || (c=='i' && strcmp(zType,"int")==0) 
      ){
        eType = SQLITE_INTEGER;
      }else if( c=='d' && strcmp(zType,"double")==0 ){
        eType = SQLITE_FLOAT;
      }else{
        eType = SQLITE_TEXT;
      }
    }

    switch( eType ){
      case SQLITE_BLOB: {
        data = Tcl_GetByteArrayFromObj(pVar, &n);
        sqlite3_result_blob(context, data, n, SQLITE_TRANSIENT);

        break;
      }
      case SQLITE_INTEGER: {
        Tcl_WideInt v;
        if( TCL_OK==Tcl_GetWideIntFromObj(0, pVar, &v) ){
          sqlite3_result_int64(context, v);

          break;
        }
        /* fall-through */
      }
      case SQLITE_FLOAT: {
        double r;
        if( TCL_OK==Tcl_GetDoubleFromObj(0, pVar, &r) ){
          sqlite3_result_double(context, r);


          break;

        }
        /* fall-through */
      }
      default: {

        data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
        sqlite3_result_text(context, (char *)data, n, SQLITE_TRANSIENT);
        break;
      }
    }

  }
}

#ifndef SQLITE_OMIT_AUTHORIZATION
/*
** This is the authentication function.  It appends the authentication
** type code and the two arguments to zCmd[] then invokes the result

  case DB_FUNCTION: {
    int flags = SQLITE_UTF8;
    SqlFunc *pFunc;
    Tcl_Obj *pScript;
    char *zName;
    int nArg = -1;
    int i;
    int eType = SQLITE_NULL;
    if( objc<4 ){
      Tcl_WrongNumArgs(interp, 2, objv, "NAME ?SWITCHES? SCRIPT");
      return TCL_ERROR;
    }
    for(i=3; i<(objc-1); i++){
      const char *z = Tcl_GetString(objv[i]);
      int n = strlen30(z);
      if( n>1 && strncmp(z, "-argcount",n)==0 ){
        if( i==(objc-2) ){
          Tcl_AppendResult(interp, "option requires an argument: ", z,(char*)0);
          return TCL_ERROR;
        }
        if( Tcl_GetIntFromObj(interp, objv[i+1], &nArg) ) return TCL_ERROR;
        if( nArg<0 ){
          Tcl_AppendResult(interp, "number of arguments must be non-negative",
                           (char*)0);
          return TCL_ERROR;
        }
        i++;
      }else
      if( n>1 && strncmp(z, "-deterministic",n)==0 ){
        flags |= SQLITE_DETERMINISTIC;
      }else
      if( n>1 && strncmp(z, "-returntype", n)==0 ){
        const char *azType[] = {"integer", "real", "text", "blob", "any", 0};
        assert( SQLITE_INTEGER==1 && SQLITE_FLOAT==2 && SQLITE_TEXT==3 );
        assert( SQLITE_BLOB==4 && SQLITE_NULL==5 );
        if( i==(objc-2) ){
          Tcl_AppendResult(interp, "option requires an argument: ", z,(char*)0);
          return TCL_ERROR;
        }
        i++;
        if( Tcl_GetIndexFromObj(interp, objv[i], azType, "type", 0, &eType) ){
          return TCL_ERROR;
        }
        eType++;
      }else{
        Tcl_AppendResult(interp, "bad option \"", z,
            "\": must be -argcount, -deterministic or -returntype", (char*)0
        );
        return TCL_ERROR;
      }
    }

    pScript = objv[objc-1];
    zName = Tcl_GetStringFromObj(objv[2], 0);
    pFunc = findSqlFunc(pDb, zName);
    if( pFunc==0 ) return TCL_ERROR;
    if( pFunc->pScript ){
      Tcl_DecrRefCount(pFunc->pScript);
    }
    pFunc->pScript = pScript;
    Tcl_IncrRefCount(pScript);
    pFunc->useEvalObjv = safeToUseEvalObjv(interp, pScript);
    pFunc->eType = eType;
    rc = sqlite3_create_function(pDb->db, zName, nArg, flags,
        pFunc, tclSqlFunc, 0, 0);
    if( rc!=SQLITE_OK ){
      rc = TCL_ERROR;
      Tcl_SetResult(interp, (char *)sqlite3_errmsg(pDb->db), TCL_VOLATILE);
    }
    break;

#
# $Id: tclsqlite.test,v 1.73 2009/03/16 13:19:36 danielk1977 Exp $

catch {sqlite3}

set testdir [file dirname $argv0]
source $testdir/tester.tcl
set testprefix tcl

# Check the error messages generated by tclsqlite
#
set r "sqlite_orig HANDLE ?FILENAME? ?-vfs VFSNAME? ?-readonly BOOLEAN? ?-create BOOLEAN? ?-nomutex BOOLEAN? ?-fullmutex BOOLEAN? ?-uri BOOLEAN?"
if {[sqlite3 -has-codec]} {
  append r " ?-key CODECKEY?"
}

  unset -nocomplain x
  db eval -withoutnulls {SELECT * FROM t1} x {
    lappend res $x(a) [array names x]
  }
  set res
} {1 {a b *} 2 {a *} 3 {a b *}}

#-------------------------------------------------------------------------
# Test the -type option to [db function].
#
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_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 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 

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) ); 
} {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) ); 
} {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) ); 
} {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') ); 
} {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') ); 
} {'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') ); 
} {'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}}

do_test 17.6.2 {
  list [catch { db function xyz -return ret } msg] $msg
} {1 {option requires an argument: -return}}

do_test 17.6.3 {
  list [catch { db function xyz -n object ret } msg] $msg
} {1 {bad option "-n": must be -argcount, -deterministic or -returntype}}

finish_test