SQLite

/*
** 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.92 2004/06/29 12:39:08 drh Exp $
*/
#ifndef NO_TCL     /* Omit this whole file if TCL is unavailable */

#include "sqliteInt.h"
#include "tcl.h"
#include <stdlib.h>
#include <string.h>

** subroutine to be invoked.
*/
static int DbObjCmd(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
  SqliteDb *pDb = (SqliteDb*)cd;
  int choice;
  int rc = TCL_OK;
  static const char *DB_strs[] = {
    "authorizer",         "busy",              "changes",
    "close",              "collate",           "collation_needed",
    "commit_hook",        "complete",          "errorcode",
    "eval",               "function",          "last_insert_rowid",
    "onecolumn",          "progress",          "rekey",

    "timeout",            "total_changes",     "trace",
    0                    
  };
  enum DB_enum {
    DB_AUTHORIZER,        DB_BUSY,             DB_CHANGES,
    DB_CLOSE,             DB_COLLATE,          DB_COLLATION_NEEDED,
    DB_COMMIT_HOOK,       DB_COMPLETE,         DB_ERRORCODE,
    DB_EVAL,              DB_FUNCTION,         DB_LAST_INSERT_ROWID,
    DB_ONECOLUMN,         DB_PROGRESS,         DB_REKEY,

    DB_TIMEOUT,           DB_TOTAL_CHANGES,    DB_TRACE,
  };

  if( objc<2 ){
    Tcl_WrongNumArgs(interp, 1, objv, "SUBCOMMAND ...");
    return TCL_ERROR;
  }
  if( Tcl_GetIndexFromObj(interp, objv[1], DB_strs, "option", 0, &choice) ){

  **
  ** If this method is invoked with no arguments, the current authorization
  ** callback string is returned.
  */
  case DB_AUTHORIZER: {
    if( objc>3 ){
      Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
      return TCL_ERROR;
    }else if( objc==2 ){
      if( pDb->zAuth ){
        Tcl_AppendResult(interp, pDb->zAuth, 0);
      }
    }else{
      char *zAuth;
      int len;

  ** If the callback throws an exception or returns non-zero, then the
  ** transaction is aborted.  If CALLBACK is an empty string, the callback
  ** is disabled.
  */
  case DB_COMMIT_HOOK: {
    if( objc>3 ){
      Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
      return TCL_ERROR;
    }else if( objc==2 ){
      if( pDb->zCommit ){
        Tcl_AppendResult(interp, pDb->zCommit, 0);
      }
    }else{
      char *zCommit;
      int len;

        sqlite3_commit_hook(pDb->db, DbCommitHandler, pDb);
      }else{
        sqlite3_commit_hook(pDb->db, 0, 0);
      }
    }
    break;
  }

  /*
  **     $db collate NAME SCRIPT
  **
  ** Create a new SQL collation function called NAME.  Whenever
  ** that function is called, invoke SCRIPT to evaluate the function.
  */
  case DB_COLLATE: {
    SqlCollate *pCollate;
    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);
    pCollate = (SqlCollate*)Tcl_Alloc( sizeof(*pCollate) + nScript + 1 );
    if( pCollate==0 ) return TCL_ERROR;
    pCollate->interp = interp;
    pCollate->pNext = pDb->pCollate;
    pCollate->zScript = (char*)&pCollate[1];
    pDb->pCollate = pCollate;
    strcpy(pCollate->zScript, zScript);
    if( sqlite3_create_collation(pDb->db, zName, SQLITE_UTF8, 
        pCollate, tclSqlCollate) ){
      return TCL_ERROR;
    }
    break;
  }

  /*
  **     $db collation_needed SCRIPT
  **
  ** Create a new SQL collation function called NAME.  Whenever
  ** that function is called, invoke SCRIPT to evaluate the function.
  */
  case DB_COLLATION_NEEDED: {
    if( objc!=3 ){
      Tcl_WrongNumArgs(interp, 2, objv, "SCRIPT");
      return TCL_ERROR;
    }
    if( pDb->pCollateNeeded ){
      Tcl_DecrRefCount(pDb->pCollateNeeded);
    }
    pDb->pCollateNeeded = Tcl_DuplicateObj(objv[2]);
    Tcl_IncrRefCount(pDb->pCollateNeeded);
    sqlite3_collation_needed(pDb->db, pDb, tclCollateNeeded);
    break;
  }

  /*    $db complete SQL
  **
  ** Return TRUE if SQL is a complete SQL statement.  Return FALSE if
  ** additional lines of input are needed.  This is similar to the
  ** built-in "info complete" command of Tcl.
  */

    zName = Tcl_GetStringFromObj(objv[2], 0);
    zScript = Tcl_GetStringFromObj(objv[3], &nScript);
    pFunc = (SqlFunc*)Tcl_Alloc( sizeof(*pFunc) + nScript + 1 );
    if( pFunc==0 ) return TCL_ERROR;
    pFunc->interp = interp;
    pFunc->pNext = pDb->pFunc;
    pFunc->zScript = (char*)&pFunc[1];
    pDb->pFunc = pFunc;
    strcpy(pFunc->zScript, zScript);
    sqlite3_create_function(pDb->db, zName, -1, SQLITE_UTF8,
        pFunc, tclSqlFunc, 0, 0);
    break;
  }

  /*

      Tcl_WrongNumArgs(interp, 2, objv, "MILLISECONDS");
      return TCL_ERROR;
    }
    if( Tcl_GetIntFromObj(interp, objv[2], &ms) ) return TCL_ERROR;
    sqlite3_busy_timeout(pDb->db, ms);
    break;
  }

  /*
  **     $db total_changes
  **
  ** Return the number of rows that were modified, inserted, or deleted 
  ** since the database handle was created.
  */
  case DB_TOTAL_CHANGES: {
    Tcl_Obj *pResult;
    if( objc!=2 ){
      Tcl_WrongNumArgs(interp, 2, objv, "");
      return TCL_ERROR;
    }
    pResult = Tcl_GetObjResult(interp);
    Tcl_SetIntObj(pResult, sqlite3_total_changes(pDb->db));
    break;
  }

  /*    $db trace ?CALLBACK?
  **
  ** Make arrangements to invoke the CALLBACK routine for each SQL statement
  ** that is executed.  The text of the SQL is appended to CALLBACK before
  ** it is executed.
  */

      }else{
        sqlite3_trace(pDb->db, 0, 0);
      }
    }
    break;
  }




































































  } /* End of the SWITCH statement */
  return rc;
}

/*
**   sqlite DBNAME FILENAME ?MODE? ?-key KEY?
**

#    May you share freely, never taking more than you give.
#
#***********************************************************************
# This file implements regression tests for SQLite library.  The
# focus of this script is testing the ATTACH and DETACH commands
# and related functionality.
#
# $Id: auth.test,v 1.16 2004/06/29 12:39:08 drh Exp $
#

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

# disable this test if the SQLITE_OMIT_AUTHORIZATION macro is
# defined during compilation.

  }
  db authorizer ::auth
  catchsql {CREATE TABLE t1(a,b,c)}
} {1 {not authorized}}
do_test auth-1.1.2 {
  db errorcode
} {23}
do_test auth-1.1.3 {
  db authorizer
} {::auth}
do_test auth-1.2 {
  execsql {SELECT name FROM sqlite_master}
} {}
do_test auth-1.3.1 {
  proc auth {code arg1 arg2 arg3 arg4} {
    if {$code=="SQLITE_CREATE_TABLE"} {
      set ::authargs [list $arg1 $arg2 $arg3 $arg4]

# This file implements regression tests for TCL interface to the
# SQLite library. 
#
# The focus of the tests in this file is the  following interface:
#
#      sqlite_commit_hook
#
# $Id: hook.test,v 1.5 2004/06/29 12:39:08 drh Exp $

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

do_test hook-1.2 {
  db commit_hook
} {}

do_test hook-3.7 {
  set ::commit_cnt
} {1 2 2 3 3 4 4 5 5 6 6 7}
do_test hook-3.8 {
  execsql {SELECT * FROM t2}
} {1 2 2 3 3 4 4 5 5 6}

# Test turnning off the commit hook
#
do_test hook-3.9 {
  db commit_hook {}
  set ::commit_cnt {}
  execsql {
    INSERT INTO t2 VALUES(7,8);
  }
  set ::commit_cnt
} {}

finish_test

# 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.
#
#***********************************************************************
# This file implements regression tests for SQLite library.  The
# focus of this file is testing the 'progress callback'.
#
# $Id: progress.test,v 1.3 2004/06/29 12:39:08 drh Exp $

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

# Build some test data
#
execsql {

  set counter 0
  db progress 1 "[namespace code {incr counter}] ; expr 0"
  execsql {
    SELECT * FROM t1
  }
  expr $counter > 1
} 1
do_test progress-1.0.1 {
  db progress
} {::namespace inscope :: {incr counter} ; expr 0}
do_test progress-1.0.2 {
  set v [catch {db progress xyz bogus} msg]
  lappend v $msg
} {1 {expected integer but got "xyz"}}

# Test that the query is abandoned when the progress callback returns non-zero
do_test progress1.1 {
  set counter 0
  db progress 1 "[namespace code {incr counter}] ; expr 1"
  set rc [catch {execsql {
    SELECT * FROM t1

# This file implements regression tests for TCL interface to the
# 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.
#
# $Id: tclsqlite.test,v 1.26 2004/06/29 12:39:08 drh Exp $

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

# Check the error messages generated by tclsqlite
#
if {[sqlite3 -has-codec]} {
  set r "sqlite_orig HANDLE FILENAME ?-key CODEC-KEY?"
} else {
  set r "sqlite3 HANDLE FILENAME ?MODE?"
}
do_test tcl-1.1 {
  set v [catch {sqlite3 bogus} msg]
  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, changes, close, collate, collation_needed, commit_hook, complete, errorcode, eval, function, last_insert_rowid, onecolumn, progress, rekey, timeout, total_changes, or trace}}
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 {
      error "The error message"
    }

    db eval {SELECT * FROM t1} data {
      expr x*
    }
  } msg]
  regsub {:.*$} $msg {} msg
  lappend v $msg
} {1 {syntax error in expression "x*"}}
do_test tcl-1.7 {
  set v [catch {db} msg]
  lappend v $msg
} {1 {wrong # args: should be "db SUBCOMMAND ..."}}
do_test tcl-1.8 {
  set v [catch {db authorizer 1 2 3} msg]
  lappend v $msg
} {1 {wrong # args: should be "db authorizer ?CALLBACK?"}}
do_test tcl-1.9 {
  set v [catch {db busy 1 2 3} msg]
  lappend v $msg
} {1 {wrong # args: should be "db busy CALLBACK"}}
do_test tcl-1.10 {
  set v [catch {db progress 1} msg]
  lappend v $msg
} {1 {wrong # args: should be "db progress N CALLBACK"}}
do_test tcl-1.11 {
  set v [catch {db changes xyz} msg]
  lappend v $msg
} {1 {wrong # args: should be "db changes "}}
do_test tcl-1.12 {
  set v [catch {db commit_hook a b c} msg]
  lappend v $msg
} {1 {wrong # args: should be "db commit_hook ?CALLBACK?"}}
do_test tcl-1.13 {
  set v [catch {db complete} msg]
  lappend v $msg
} {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 SQL ?ARRAY-NAME CODE?"}}
do_test tcl-1.15 {
  set v [catch {db function} msg]
  lappend v $msg
} {1 {wrong # args: should be "db function NAME SCRIPT"}}
do_test tcl-1.14 {
  set v [catch {db last_insert_rowid xyz} msg]
  lappend v $msg
} {1 {wrong # args: should be "db last_insert_rowid "}}
do_test tcl-1.15 {
  set v [catch {db rekey} msg]
  lappend v $msg
} {1 {wrong # args: should be "db rekey KEY"}}
do_test tcl-1.16 {
  set v [catch {db timeout} msg]
  lappend v $msg
} {1 {wrong # args: should be "db timeout MILLISECONDS"}}
do_test tcl-1.17 {
  set v [catch {db collate} msg]
  lappend v $msg
} {1 {wrong # args: should be "db collate NAME SCRIPT"}}
do_test tcl-1.18 {
  set v [catch {db collation_needed} msg]
  lappend v $msg
} {1 {wrong # args: should be "db collation_needed SCRIPT"}}
do_test tcl-1.19 {
  set v [catch {db total_changes xyz} msg]
  lappend v $msg
} {1 {wrong # args: should be "db total_changes "}}


if {[sqlite3 -tcl-uses-utf]} {
  do_test tcl-2.1 {
    execsql "CREATE TABLE t\u0123x(a int, b\u1235 float)"
    execsql "PRAGMA table_info(t\u0123x)"
  } "0 a int 0 {} 0 1 b\u1235 float 0 {} 0"
  do_test tcl-2.2 {

do_test tcl-3.2 {
  db onecolumn {SELECT * FROM t1 WHERE a<0}
} {}
do_test tcl-3.3 {
  set rc [catch {db onecolumn} errmsg]
  lappend rc $errmsg
} {1 {wrong # args: should be "db onecolumn SQL"}}
do_test tcl-3.4 {
  set rc [catch {db onecolumn {SELECT bogus}} errmsg]
  lappend rc $errmsg
} {1 {no such column: bogus}}

# Turn the busy handler on and off
#
do_test tcl-4.1 {
  proc busy_callback {cnt} {
    break
  }
  db busy busy_callback
  db busy
} {busy_callback}
do_test tcl-4.2 {
  db busy {}
  db busy
} {}

finish_test